├── .gitignore ├── LICENSE ├── NEWS.md ├── NOTICE ├── README.md ├── README.org ├── elisp ├── log4cl.el ├── log4slime.el └── log4sly.el ├── examples ├── customize-log-expr.lisp └── naming-examples.lisp ├── images ├── screenshot-10.png ├── screenshot-11.png ├── screenshot-12.png ├── screenshot-15.png ├── screenshot-16.png ├── screenshot-17.png ├── screenshot-18.png ├── screenshot-19.png ├── screenshot-20.png ├── screenshot-22.png ├── screenshot-23.png └── screenshot-25.png ├── log4cl-examples.asd ├── log4cl.asd ├── log4cl.log4slime.asd ├── log4cl.log4sly.asd ├── src ├── appender │ ├── appender-base.lisp │ ├── appender.lisp │ ├── layout.lisp │ ├── pattern-layout.lisp │ ├── simple-layout.lisp │ ├── syslog-appender-cffi.lisp │ ├── syslog-appender-sbcl.lisp │ └── syslog-appender.lisp ├── configurator.lisp ├── defs.lisp ├── hierarchy-base.lisp ├── hierarchy.lisp ├── impl-package.lisp ├── log4elisp.lisp ├── log4slime.lisp ├── log4sly.lisp ├── logger.lisp ├── logging-macros.lisp ├── naming-ccl.lisp ├── naming-sbcl.lisp ├── naming.lisp ├── package.lisp ├── property-configurator.lisp ├── property-parser.lisp ├── self-logger.lisp └── watcher.lisp └── tests ├── log4cl.properties ├── log4j.jar ├── log4j.properties ├── test-appenders.lisp ├── test-category-separator.lisp ├── test-compat.lisp ├── test-configurator.lisp ├── test-defs.lisp ├── test-file-category-2.lisp ├── test-file-category.lisp ├── test-layouts.lisp ├── test-logger.lisp ├── test-regressions.lisp ├── test-speed.lisp └── test.java /.gitignore: -------------------------------------------------------------------------------- 1 | .* 2 | #*# 3 | !.gitignore 4 | *.fas 5 | *.fasl 6 | *.lib 7 | *~ 8 | *.bak 9 | *.orig 10 | *.class 11 | *.o 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright 1999-2005 The Apache Software Foundation 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | ## 1.1.3 - Resuscitation 2 | 3 | * A syslog appender using either cl-syslog or SBCL's syslog support 4 | has been added. 5 | 6 | * Fix for ABCL has been applied. 7 | 8 | * Various fixes for Log4Slime. 9 | 10 | * Fix problem with join-thread-error. 11 | 12 | ## 1.1.2 - Bugfixes 13 | 14 | * Re-initialize any appenders that remember the resolved stream in INIT-HOOK on 15 | SBCL; which fixes a crash if SBCL dump is ressurected without doing 16 | (CLEAR-LOGGING-CONFIGURATION). Patch by Jan Moringen. 17 | 18 | * Add (log:config ...adding an appender... :filter LEVEL) option, which causes 19 | appender to drop messages less serious then LEVEL. This allows one to 20 | configure per-level appenders, for example error.log and debug.log. Patch by 21 | https://github.com/naryl 22 | 23 | ## 1.1.1 - Log4Slime 24 | 25 | * LOG:CONFIG :thread or :ndc argument can be followed by two numbers, 26 | which will be used as MIN/MAX width fields, this helps if you want 27 | to align output from multiple threads. 28 | 29 | * Pattern layout can use {pretty}{100} to set **PRINT-RIGHT-MARGIN** in 30 | addition to forcing pretty printing. 31 | 32 | * (LOG:CONFIG (LOG:CATEGORY) ...) from top level now configures the package logger 33 | instea of package. logger. 34 | 35 | * :console appender changed back to use **DEBUG-IO** instead of 36 | **TERMINAL-IO**, because on LispWorks **TERMINAL-IO** goes to actual 37 | terminal. 38 | 39 | * Removed forgotten Log4Slime dependency on org-mode in faces definition. 40 | 41 | * Default logging configuration is now :SANE2 42 | 43 | * Fix LOG:CONFIG :backup option not accepting NIL argument. 44 | 45 | * Log4SLime informational message about logger level changes was giving error 46 | if category name contained % character. 47 | 48 | * %t and %h pattern layout (displaying thread and host name) were crashing 49 | if corresponding attribute was actually NIL (apparently its possible to 50 | do create SBCL thread with NIL name) 51 | 52 | * (LOG:CONFIG :daily ...) now accepts pathnames again 53 | 54 | ## 1.1.0 - Log4Slime 55 | 56 | * Log4CL now has Slime/Emacs integration, which is available in a 57 | system :log4slime. It colorizes the log output, and provides 58 | ability to change log levels from Emacs. 59 | 60 | * Default category separator changed to dot. 61 | 62 | * The old CLOS method of setting option is depreciated in favor of new 63 | (LOG:PACKAGE-OPTIONS) macro 64 | 65 | * LOG package namespace was cleaned up, and its now an actual 66 | package named LOG. The LOG4CL package is now nickname for 67 | LOG4CL-IMPL 68 | 69 | * Loggers now retain information about source file and package they 70 | were instantiated from, with corresponding PATTERN-LAYOUT formats 71 | to print them 72 | 73 | As a consequence to pass a dynamically determined logger object to a 74 | log statement, now requires (log:debug :logger 75 | (form-that-returs-a-logger)) 76 | 77 | * (log:info a b c) and such now automatiaclly do (log:expr) like processing 78 | if they don't detect a format control string as first argument. 79 | 80 | * Automatic category naming implemented on Clozure Common Lisp (CCL), 81 | working exactly like SBCL one. 82 | 83 | * Pattern layout extended with control of pretty printing and other enchencements 84 | 85 | * Much more robust error handling in standard appenders, better reporting 86 | of errors. 87 | 88 | * It is possible to set a log level for the source file, it takes precedence 89 | over the package category. 90 | 91 | * On SBCL Log4CL hierarchy watcher thread that is used for flushing, a 92 | is automatically terminated on exit, and before SAVE-LISP-AND-DIE. 93 | 94 | * Added API to flush all appenders, LOG4CL:FLUSH-ALL-APPENDERS, which 95 | is automatically called on SBCL from exit hooks. 96 | 97 | * (LOG:CONFIG) now has many new pattern layout related options 98 | :pretty, :nopretty, :file, :file2, :nofile, :time, :notime, :package 99 | :nopackage, :ndc, :thread 100 | 101 | These options change the built-in pattern used for :sane, :console 102 | and other options that add new appender 103 | 104 | * (LOG:CONFIG) with only the pattern options, will change existing console 105 | appender instead of adding a new one. 106 | 107 | * (LOG:CONFIG) appender displays a number next to each appender, and allows 108 | removing of appenders via :REMOVE option 109 | 110 | ## 1.0.0 111 | * (Bugfix): Fix SB-C package lock error when compiling on new SBCL. 112 | Created stable branch stable version 113 | 114 | ## 0.9.5 115 | 116 | * (Bugfix) DAILY-FILE-APPENDER was only rolling over the file if 117 | rollover time passed in between two log mesjsages. Therefore a 118 | short-lived command line utility configured with `(log:config :daily 119 | "log.txt")` would never roll over the log.txt to 120 | log.txt-yyyy-mm-dd.txt, unless it happen to run exactly at 121 | midnight. This had now been corrected, and pre-existing log file 122 | will be rolled over based on its modification time. 123 | 124 | ## 0.9.3 125 | 126 | * (Feature): Added ability to quick save/restore of named logging 127 | configurations, with the list of 30 most recently used 128 | configurations saved in a file in user home directory. See next to 129 | last section in README.md QuickStart quide describing new 130 | functionality 131 | 132 | * (Bugfix): Change log4cl package to forward functions and macros from the 133 | log4cl-impl package by setf'ing fdefinition or macro-function. This allows 134 | Slime M-. key to correctly locate sources of "nicknamed" functions or macros. 135 | 136 | ## 0.9.2 137 | * (Bugfix) When logger is specified at runtime, check that it has the correct type 138 | 139 | * Do not reset log level to info with :sane when no log level was 140 | specified. I had found that `(log:config :sane)` resetting log level 141 | back to info, when it used to be debug seems surprising. If you want 142 | old behavior, use `(log:config :sane :i)` 143 | 144 | * (Feature): Added %& pattern format, which does FRESH-LINE, that is 145 | outputs a newline only if output position is not already at the 146 | beginning of a new line 147 | 148 | * On some complicated functions inside of LOOP inside of LABELS, the 149 | automatic logger naming was duplicating the function name. 150 | 151 | ## 0.9.1 152 | 153 | * (Doc): Added examples directory which shows how to customize the 154 | logging category per-package, and include the file name as part of 155 | logging category. 156 | 157 | * (New Feature): Pattern layout %c formatter had been extended with 158 | %c{FROM,COUNT} format, which allows printing of Nth category name in 159 | the hierarchy. This is especially useful if one uses filename as 160 | part of of the category name, and allows user to configure pattern 161 | as for example `(file.lisp) ` 162 | 163 | * (New Feature): the `(log:expr)` now uses pretty printing conditional 164 | newline to separate printed values, which results in much better 165 | formatted output when a large structures are printed. In addition 166 | `(nameing-option)` generic function protocol had been extended to 167 | allow specifying custom formatting for `(log:expr)` (ie different 168 | separator between var=value then default equal sign, or different 169 | separator between entire experssions). 170 | 171 | * (Bugfix): %z timezone string had wrong sign, ie +0400 instead of -0400 172 | and did not take daylight savings into account 173 | 174 | * (Bugfix): All tests now correctly pass with inverted readtable in 175 | effect 176 | 177 | * (Bugfix) The console appender in the initial configuration changed 178 | to use `:immediate-flush t` and therefore will no longer start the 179 | background thread. Correspondinly an `:immediate-flush` option was 180 | added to `(log:config)` which will cause appenders it creates to 181 | have `:immediate-flush t` property. It's recommended that user 182 | reconfigures the logging system from initial configuration without 183 | the `:immediate-flush` option, as stream appenders flushed by 184 | background thread have much better performance 185 | 186 | * (Bugfix): Fixed running under LispWorks. 187 | 188 | * (Doc): Assorted docstrings were updated to reflect reality. 189 | -------------------------------------------------------------------------------- /NOTICE: -------------------------------------------------------------------------------- 1 | Log4CL logging framework for Common Lisp. 2 | Copyright (c) 2012, Max Mikhanosha 3 | 4 | This product includes software developed by Max Mikhanosha 5 | (max.mikhanosha@gmail.com) 6 | 7 | -------------------------------------------------------------------------------- /elisp/log4slime.el: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Emacs-Lisp; -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; Copyright (c) 2021, Hugh Daschbach 5 | ;;; 6 | ;;; This file is licensed to You under the Apache License, Version 2.0 7 | ;;; (the "License"); you may not use this file except in compliance 8 | ;;; with the License. You may obtain a copy of the License at 9 | ;;; http://www.apache.org/licenses/LICENSE-2.0 10 | ;;; 11 | ;;; Unless required by applicable law or agreed to in writing, software 12 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 13 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | ;;; See the License for the specific language governing permissions and 15 | ;;; limitations under the License. 16 | 17 | (require 'cl-lib) 18 | (require 'log4cl) 19 | (require 'slime) 20 | 21 | (cl-defmethod log4slime-eval ((backend (eql :log4slime)) form) 22 | (when (log4slime-check-connection) 23 | ;; I swear it something in slime-eval screws with point sometimes 24 | (save-excursion 25 | (cl-destructuring-bind (fn . args) form 26 | (let ((slime-current-thread t) 27 | (fn-sym (intern (concat "log4cl.log4slime:" (symbol-name fn))))) 28 | (slime-eval `(cl:ignore-errors (,fn-sym ,@args)))))))) 29 | 30 | (cl-defmethod log4slime-load-lisp-system ((backend (eql :log4slime))) 31 | (slime-eval `(cl:multiple-value-bind 32 | (ok err) 33 | (cl:ignore-errors 34 | (cl:setf (cl:get :log4slime :no-emacs-startup-message) t) 35 | (asdf:load-system :log4cl.log4slime)) 36 | (cl:if ok :ok (cl:princ-to-string err))))) 37 | 38 | (cl-defmethod log4slime-connected-p ((backend (eql :log4slime))) 39 | (slime-connected-p)) 40 | 41 | (cl-defmethod log4slime-current-package ((backend (eql :log4slime))) 42 | (slime-current-package)) 43 | 44 | (cl-defmethod log4slime-symbol-at-point ((backend (eql :log4slime))) 45 | (slime-symbol-at-point)) 46 | 47 | (cl-defmethod log4slime-sexp-at-point ((backend (eql :log4slime))) 48 | (slime-sexp-at-point)) 49 | 50 | (cl-defmethod log4slime-analyze-xrefs ((backend (eql :log4slime)) xrefs) 51 | (slime-analyze-xrefs xrefs)) 52 | 53 | (cl-defmethod log4slime-push-definition-stack ((backend (eql :log4slime))) 54 | (slime-push-definition-stack)) 55 | 56 | (cl-defmethod log4slime-xref.location ((backend (eql :log4slime)) xref) 57 | (slime-xref.location xref)) 58 | 59 | (cl-defmethod log4slime-current-connection ((backend (eql :log4slime))) 60 | (slime-current-connection)) 61 | 62 | (cl-defmethod log4slime-show-xrefs ((backend (eql :log4slime)) 63 | xrefs types symbol package) 64 | (slime-show-xrefs xrefs types symbol package)) 65 | 66 | (cl-defmethod log4slime-pop-to-location ((backend (eql :log4slime)) 67 | location &optional where) 68 | (slime-pop-to-location location where)) 69 | 70 | ;; Log message formatting hook 71 | 72 | (eval-after-load 'slime-repl 73 | '(defadvice slime-repl-emit (around highlight-logging-category activate compile) 74 | (with-current-buffer (slime-output-buffer) 75 | (if log4slime-mode 76 | (let ((start (marker-position slime-output-end))) 77 | (setq ad-return-value ad-do-it) 78 | (log4slime-highlight-log-message start (marker-position slime-output-end))) 79 | (setq ad-return-value ad-do-it))))) 80 | 81 | ;; log4slime mode definition 82 | 83 | (define-minor-mode log4slime-mode 84 | "\\\ 85 | Support mode integrating log4slime logging system with SLIME 86 | 87 | \\[log4slime-level-selection] - Set log level fast via keyboard 88 | 89 | Only \"standard\" log levels show up in the menu and keyboard bindings. 90 | 91 | There are also 8 extra debug levels, DEBU1..DEBU4 are more specific then DEBUG 92 | but less specific then TRACE, and DEBU5..DEBU9 come after TRACE. 93 | 94 | To make them show up in the menu, but you can customize the 95 | variable `log4slime-menu-levels'. 96 | " 97 | :keymap log4slime-mode-map 98 | (when log4slime-mode 99 | (setq log4slime-backend :log4slime) 100 | (log4slime-check-connection t))) 101 | 102 | (defun turn-on-log4slime-mode () 103 | "Turn on `log4slime-mode' in the current buffer if appropriate." 104 | (interactive) 105 | (if (member major-mode '(lisp-mode slime-repl-mode)) 106 | (log4slime-mode 1) 107 | (when (called-interactively-p 'interactive) 108 | (message "This buffer does not support log4slime mode")))) 109 | 110 | (define-globalized-minor-mode global-log4slime-mode 111 | log4slime-mode 112 | turn-on-log4slime-mode 113 | :group 'log4slime) 114 | 115 | (provide 'log4slime) 116 | 117 | ;;; log4slime.el ends here 118 | -------------------------------------------------------------------------------- /elisp/log4sly.el: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Emacs-Lisp; -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; Copyright (c) 2021, Hugh Daschbach 5 | ;;; 6 | ;;; This file is licensed to You under the Apache License, Version 2.0 7 | ;;; (the "License"); you may not use this file except in compliance 8 | ;;; with the License. You may obtain a copy of the License at 9 | ;;; http://www.apache.org/licenses/LICENSE-2.0 10 | ;;; 11 | ;;; Unless required by applicable law or agreed to in writing, software 12 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 13 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | ;;; See the License for the specific language governing permissions and 15 | ;;; limitations under the License. 16 | 17 | (require 'cl-lib) 18 | (require 'log4cl) 19 | (require 'sly) 20 | 21 | (cl-defmethod log4slime-eval ((backend (eql :log4sly)) form) 22 | (when (log4slime-check-connection) 23 | ;; I swear it something in slime-eval screws with point sometimes 24 | (save-excursion 25 | (cl-destructuring-bind (fn . args) form 26 | (let ((sly-current-thread t) 27 | (fn-sym (intern (concat "log4cl.log4sly:" (symbol-name fn))))) 28 | (sly-eval `(cl:ignore-errors (,fn-sym ,@args)))))))) 29 | 30 | (cl-defmethod log4slime-load-lisp-system ((backend (eql :log4sly))) 31 | (sly-eval `(cl:multiple-value-bind 32 | (ok err) 33 | (cl:ignore-errors 34 | (cl:setf (cl:get :log4sly :no-emacs-startup-message) t) 35 | (asdf:load-system :log4cl.log4sly)) 36 | (cl:if ok :ok (cl:princ-to-string err))))) 37 | 38 | (cl-defmethod log4slime-connected-p ((backend (eql :log4sly))) 39 | (sly-connected-p)) 40 | 41 | (cl-defmethod log4slime-current-package ((backend (eql :log4sly))) 42 | (sly-current-package)) 43 | 44 | (cl-defmethod log4slime-symbol-at-point ((backend (eql :log4sly))) 45 | (sly-symbol-at-point)) 46 | 47 | (cl-defmethod log4slime-sexp-at-point ((backend (eql :log4sly))) 48 | (sly-sexp-at-point)) 49 | 50 | (cl-defmethod log4slime-analyze-xrefs ((backend (eql :log4sly)) xrefs) 51 | (sly-analyze-xrefs xrefs)) 52 | 53 | (cl-defmethod log4slime-push-definition-stack ((backend (eql :log4sly))) 54 | (sly-push-definition-stack)) 55 | 56 | (cl-defmethod log4slime-xref.location ((backend (eql :log4sly)) xref) 57 | (sly-xref.location xref)) 58 | 59 | (cl-defmethod log4slime-current-connection ((backend (eql :log4sly))) 60 | (sly-current-connection)) 61 | 62 | (cl-defmethod log4slime-buffer-file-name ((backend (eql :log4sly))) 63 | (buffer-file-name)) 64 | 65 | (cl-defmethod log4slime-show-xrefs ((backend (eql :log4sly)) 66 | xrefs types symbol package) 67 | (sly-edit-definition symbol)) 68 | 69 | (cl-defmethod log4slime-pop-to-location ((backend (eql :log4sly)) 70 | location &optional where) 71 | (sly--display-source-location location nil where)) 72 | 73 | ;; Log message formatting hook 74 | 75 | (defun log4sly-mrepl-highlight-string (string) 76 | "Highlight STRING as a log4cl message when log4slime-mode enabled. 77 | This is used to format ‘sly’ output. Output from ’sly’ is 78 | presented as a string to be transformed, rather than a buffer 79 | region." 80 | (if log4sly-mode 81 | (with-temp-buffer 82 | (insert string) 83 | (let ((log4slime-category-package-properties 84 | (append 85 | (list 'font-lock-face 'log4slime-package-face) 86 | log4slime-category-package-properties)) 87 | (log4slime-category-file-properties 88 | (append 89 | (list 'font-lock-face 'log4slime-file-face) 90 | log4slime-category-file-properties)) 91 | (log4slime-category-function-properties 92 | (append 93 | (list 'font-lock-face 'log4slime-function-face) 94 | log4slime-category-function-properties)) 95 | (log4slime-category-level-properties 96 | (append 97 | (list 'font-lock-face 'log4slime-level-face) 98 | log4slime-category-level-properties))) 99 | (log4slime-highlight-log-message (point-min) (point-max))) 100 | (buffer-string)) 101 | string)) 102 | 103 | (eval-after-load 'sly-mrepl 104 | '(add-hook 105 | 'sly-mrepl-output-filter-functions 106 | #'log4sly-mrepl-highlight-string)) 107 | 108 | ;; log4sly mode definition 109 | 110 | (define-minor-mode log4sly-mode 111 | "\\\ 112 | Support mode integrating log4sly logging system with SLY 113 | 114 | \\[log4slime-level-selection] - Set log level fast via keyboard 115 | 116 | Only \"standard\" log levels show up in the menu and keyboard bindings. 117 | 118 | There are also 8 extra debug levels, DEBU1..DEBU4 are more specific then DEBUG 119 | but less specific then TRACE, and DEBU5..DEBU9 come after TRACE. 120 | 121 | To make them show up in the menu, but you can customize the 122 | variable `log4slime-menu-levels'. 123 | " 124 | :keymap log4slime-mode-map 125 | (when log4sly-mode 126 | (setq log4slime-backend :log4sly) 127 | (log4slime-check-connection t))) 128 | 129 | (defun turn-on-log4sly-mode () 130 | "Turn on `log4sly-mode' in the current buffer if appropriate." 131 | (interactive) 132 | (if (member major-mode '(lisp-mode sly-mrepl-mode)) 133 | (log4sly-mode 1) 134 | (when (called-interactively-p 'interactive) 135 | (message "This buffer does not support log4sly mode")))) 136 | 137 | (define-globalized-minor-mode global-log4sly-mode 138 | log4sly-mode 139 | turn-on-log4sly-mode 140 | :group 'log4slime) 141 | 142 | (provide 'log4sly) 143 | 144 | ;;; log4sly.el ends here 145 | -------------------------------------------------------------------------------- /examples/customize-log-expr.lisp: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; Shows how you can customize (LOG:EXPR) to print expressions and 3 | ;; values in a different way 4 | ;; 5 | ;; EXAMPLE-3> (test) 6 | ;; 7 | ;; [11:11:48] [debug] 8 | ;; * values are A: 1 B: (TWO THREE) 9 | ;; C: (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 10 | ;; 11 | 12 | 13 | (defpackage :customize-log-expr 14 | (:use :cl) 15 | (:export :test)) 16 | 17 | (in-package :customize-log-expr) 18 | 19 | ;; Use even prettier printing of expressions, at expanse 20 | ;; of slightly more code size/consing 21 | ;; 22 | ;; "~:_~<~(~W~): ~2I~_~W~:> " 23 | ;; 24 | (log:package-options :expr-print-format log4cl:+expr-format-fancy+) 25 | 26 | (defun test () 27 | (let ((a 1) (b '(two three)) 28 | (c (loop for i from 1 to 15 collect i))) 29 | (log:info "values are" a b c))) 30 | 31 | 32 | -------------------------------------------------------------------------------- /examples/naming-examples.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :test.package.one 2 | (:use :cl) 3 | (:export :greetings :foobar :instantiating-a-logger-1 :instantiating-a-logger-2 4 | :from-a-label)) 5 | 6 | (in-package :test.package.one) 7 | 8 | (defvar *greeting-text* "Hi There!") 9 | 10 | (defun greetings () 11 | (log:info "~A" *greeting-text*)) 12 | 13 | (greetings) 14 | 15 | (defmethod foobar (a b (c number)) 16 | (log:expr a b c)) 17 | 18 | (defmethod foobar ((a symbol) b (c (eql :ok))) 19 | (log:expr a b c)) 20 | 21 | (defmethod foobar (a b (c (eql :ok))) 22 | (log:expr a b c)) 23 | 24 | (defmethod foobar (a (b string) (c (eql :ok))) 25 | (log:expr a b c)) 26 | 27 | (defmethod foobar :after ((a string) b (c (eql :ok))) 28 | (log:expr a b c)) 29 | 30 | (defmethod foobar :after ((a string) (b string) (c (eql :ok))) 31 | (log:expr "two strings!" a b c)) 32 | 33 | (defmethod foobar :after (a b (c (eql 42))) 34 | (log:expr "Its forty two" a b c)) 35 | 36 | (defmethod foobar :around (a b c) 37 | (log:trace "Ever had a feeling someone is always watching you?") 38 | (log:trace a b c) 39 | (call-next-method)) 40 | 41 | (defun (setf greetings) (new-greeting) 42 | (log:info new-greeting "Its not nice to change someone's greeting but I'll do it just for you") 43 | (setq *greeting-text* new-greeting)) 44 | 45 | ;; More esoteric stuff 46 | 47 | (defun from-a-label (&optional runtime-logger-object) 48 | (labels ((i-am-a-local-function () 49 | (log:debug "This is a local function") 50 | (when runtime-logger-object 51 | (log:debug "we were passed" runtime-logger-object) 52 | (log:debug :logger runtime-logger-object "Lets see where this goes?")))) 53 | (log:info "this is main function") 54 | (i-am-a-local-function))) 55 | 56 | (defun instantiate-a-logger-1 () 57 | (let ((logger (log:category '(category via list)))) 58 | (log:info "Going to call" #'from-a-label "and pass it a logger" 59 | "note the limitations of Log4SLime fontification") 60 | (from-a-label logger))) 61 | 62 | (defun instantiate-a-logger-2 () 63 | (let ((logger (log:category :category.via.keyword))) 64 | (log:info "Going to call" #'from-a-label "and pass it a logger") 65 | (from-a-label logger))) 66 | 67 | -------------------------------------------------------------------------------- /images/screenshot-10.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-10.png -------------------------------------------------------------------------------- /images/screenshot-11.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-11.png -------------------------------------------------------------------------------- /images/screenshot-12.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-12.png -------------------------------------------------------------------------------- /images/screenshot-15.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-15.png -------------------------------------------------------------------------------- /images/screenshot-16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-16.png -------------------------------------------------------------------------------- /images/screenshot-17.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-17.png -------------------------------------------------------------------------------- /images/screenshot-18.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-18.png -------------------------------------------------------------------------------- /images/screenshot-19.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-19.png -------------------------------------------------------------------------------- /images/screenshot-20.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-20.png -------------------------------------------------------------------------------- /images/screenshot-22.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-22.png -------------------------------------------------------------------------------- /images/screenshot-23.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-23.png -------------------------------------------------------------------------------- /images/screenshot-25.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/images/screenshot-25.png -------------------------------------------------------------------------------- /log4cl-examples.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (asdf:defsystem "log4cl-examples" 17 | :version "1.1.4" 18 | :depends-on ("log4cl" "swank") 19 | :components ((:file "examples/naming-examples") 20 | (:file "examples/customize-log-expr"))) 21 | -------------------------------------------------------------------------------- /log4cl.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (asdf:defsystem "log4cl" 17 | :version "1.1.4" 18 | :depends-on ("bordeaux-threads" 19 | #+sbcl "sb-posix") ; for SB-POSIX:GETPID in pattern-layout.lisp 20 | :components ((:module "src" 21 | :serial t 22 | :components ((:file "impl-package") 23 | (:file "defs") 24 | (:file "naming") 25 | #+sbcl (:file "naming-sbcl") 26 | #+ccl (:file "naming-ccl") 27 | (:file "hierarchy-base") 28 | (:file "hierarchy") 29 | (:file "logger") 30 | (:file "logging-macros") 31 | (:file "self-logger"))) 32 | (:module "appender" 33 | :pathname "src/appender" 34 | :depends-on ("src") 35 | :serial t 36 | :components ((:file "layout") 37 | (:file "simple-layout") 38 | (:file "pattern-layout") 39 | 40 | (:file "appender-base") 41 | (:file "appender"))) 42 | (:module "configuration" 43 | :pathname "src" 44 | :depends-on ("src" "appender") 45 | :serial t 46 | :components ((:file "configurator") 47 | (:file "property-parser") 48 | (:file "property-configurator"))) 49 | (:module "watcher" 50 | :pathname "src" 51 | :depends-on ("src" "appender") 52 | :components ((:file "watcher"))) 53 | (:module "client-package" 54 | :pathname "src" 55 | :depends-on ("src" "configuration") 56 | :components ((:file "package")))) 57 | :in-order-to ((test-op (test-op "log4cl/test")))) 58 | 59 | (defmethod perform :after ((op load-op) (system (eql (find-system "log4cl")))) 60 | (let ((package (find-package '#:log4cl))) 61 | (when package 62 | (let ((*package* package) 63 | (foo (find-symbol (symbol-name '#:%fix-root-logger-check)))) 64 | (when foo 65 | (funcall foo))))) 66 | (values)) 67 | 68 | (asdf:defsystem "log4cl/syslog" 69 | :version "1.1.4" 70 | :depends-on ("log4cl" 71 | #-sbcl "cl-syslog") 72 | :components ((:module "appender" 73 | :pathname "src/appender" 74 | :serial t 75 | :components ((:file "syslog-appender") 76 | #+sbcl (:file "syslog-appender-sbcl") 77 | #-sbcl (:file "syslog-appender-cffi"))))) 78 | 79 | (asdf:defsystem "log4cl/test" 80 | :version "1.1.4" 81 | :depends-on ("log4cl" "stefil") 82 | :components ((:module "tests" 83 | :serial t 84 | :components ((:file "test-defs") 85 | (:file "test-logger") 86 | (:file "test-category-separator") 87 | (:file "test-layouts") 88 | (:file "test-appenders") 89 | (:file "test-configurator") 90 | (:file "test-speed") 91 | (:file "test-file-category") 92 | (:file "test-compat") 93 | (:file "test-regressions"))))) 94 | 95 | (defmethod perform ((op test-op) (system (eql (find-system :log4cl/test)))) 96 | (let ((*package* (find-package :log4cl-test))) 97 | (eval (read-from-string "(stefil:funcall-test-with-feedback-message 'log4cl-test::test)"))) 98 | (values)) 99 | -------------------------------------------------------------------------------- /log4cl.log4slime.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; Copyright (c) 2021, Hugh Daschbach 5 | ;;; 6 | ;;; This file is licensed to You under the Apache License, Version 2.0 7 | ;;; (the "License"); you may not use this file except in compliance 8 | ;;; with the License. You may obtain a copy of the License at 9 | ;;; http://www.apache.org/licenses/LICENSE-2.0 10 | ;;; 11 | ;;; Unless required by applicable law or agreed to in writing, software 12 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 13 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | ;;; See the License for the specific language governing permissions and 15 | ;;; limitations under the License. 16 | 17 | (asdf:defsystem "log4cl.log4slime" 18 | :version "1.1.4" 19 | :depends-on ("log4cl" "swank") 20 | :components ((:module "src" 21 | :components 22 | ((:file "log4elisp") 23 | (:file "log4slime" :depends-on ("log4elisp")))))) 24 | -------------------------------------------------------------------------------- /log4cl.log4sly.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; Copyright (c) 2021, Hugh Daschbach 5 | ;;; 6 | ;;; This file is licensed to You under the Apache License, Version 2.0 7 | ;;; (the "License"); you may not use this file except in compliance 8 | ;;; with the License. You may obtain a copy of the License at 9 | ;;; http://www.apache.org/licenses/LICENSE-2.0 10 | ;;; 11 | ;;; Unless required by applicable law or agreed to in writing, software 12 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 13 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | ;;; See the License for the specific language governing permissions and 15 | ;;; limitations under the License. 16 | 17 | (asdf:defsystem "log4cl.log4sly" 18 | :version "1.1.4" 19 | :depends-on ("log4cl" "slynk") 20 | :components ((:module "src" 21 | :components 22 | ((:file "log4elisp") 23 | (:file "log4sly" :depends-on ("log4elisp")))))) 24 | -------------------------------------------------------------------------------- /src/appender/appender-base.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | ;; Base APPENDER class and generics that logging core needs to see 19 | 20 | (defclass appender () 21 | ((layout :initform (make-instance 'simple-layout) 22 | :initarg :layout :accessor appender-layout) 23 | (logger-count :initform 0 :accessor appender-logger-count 24 | :type (integer 0)) 25 | (loggers :initform nil :accessor appender-loggers) 26 | (enabled :initform t :accessor appender-enabled-p) 27 | (filter :initform nil 28 | :initarg :filter :accessor appender-filter) 29 | (last-error :initform nil :accessor appender-last-error) 30 | (last-ignored-error :initform nil :accessor appender-last-ignored-error) 31 | (error-count :initform 0 :accessor appender-error-count 32 | :type (integer 0)) 33 | (ignored-error-count :initform 0 :accessor appender-ignored-error-count 34 | :type (integer 0)) 35 | (message-count :initform 0 :accessor appender-message-count 36 | :type (integer 0))) 37 | (:documentation "Appender is log message sink, and is responsible 38 | for physically delivering the log message, somewhere. The formatting 39 | of message is done by layout. 40 | 41 | Appenders can be called from multiple threads and are responsible for 42 | serializing access to any resources. 43 | 44 | Appender will not be appended into if ENABLED slot is NIL 45 | 46 | HANDLE-APPENDER-ERROR generic function is called if condition is 47 | signaled from APPENDER-DO-APPEND method. See description of that 48 | function for the protocol. 49 | ")) 50 | 51 | (defgeneric appender-added (logger appender) 52 | (:documentation "Called when appender is added to a logger. Default 53 | method is used to keep logger count, and if re-implemented 54 | the (CALL-NEXT-METHOD) needs to be called.")) 55 | 56 | (defgeneric appender-removed (logger appender) 57 | (:documentation "Called when appender is removed from a logger 58 | Default method is used to keep logger refcount, and calls 59 | CLOSE-APPENDER when it reaches zero. If re-implemented 60 | the (CALL-NEXT-METHOD) needs to be called")) 61 | 62 | (defgeneric close-appender (appender) 63 | (:documentation "Called when appender refcount reaches zero after 64 | being positive. Should close any streams or files that appender had 65 | opened.")) 66 | 67 | (defgeneric save-appender (appender) 68 | (:documentation "Called from SAVE-HOOKS, must close appenders that 69 | own their stream in a such way, so its possible to reopen them")) 70 | 71 | 72 | (defgeneric appender-do-append (appender logger level log-func) 73 | (:documentation 74 | "Writes the log message into the appender. Text of the log message 75 | is specified indirectly via LOG-FUNC argument, which will be a 76 | function that accepts a stream, and writes the text of log message to 77 | it. 78 | 79 | This function should first figure out or obtain the stream to write 80 | the log message to, and then call the LAYOUT-TO-STREAM function to have 81 | layout do actual formatting. 82 | 83 | If appender destination is ultimately not a stream, then it can 84 | obtain the full text of the log message by calling LAYOUT-TO-STREAM 85 | inside of WITH-OUTPUT-TO-STRING 86 | 87 | Example: 88 | 89 | (defmethod appender-do-append ((self custom-appender) logger level log-func) 90 | (let ((stream (custom-appender-destination))) 91 | (layout-to-stream (slot-value self 'layout) 92 | stream logger level log-func)) 93 | (values)) 94 | 95 | Return value of this function is ignored") 96 | (:method :around ((appender appender) logger level log-func) 97 | (let ((filter (appender-filter appender))) 98 | (when (or (not filter) 99 | (>= filter level)) 100 | (call-next-method))))) 101 | 102 | (defgeneric handle-appender-error (appender condition) 103 | (:documentation "Called when a condition is raised doing writing to 104 | the appender by APPENDER-DO-APPEND call, must return a keyword 105 | indicating action to take. 106 | 107 | :DISABLE -- Appender is permanently disabled by setting ENABLED slot 108 | to NIL, any farther appends will be ignored. 109 | 110 | :RETRY -- immediately retry logging the same log message. To prevent 111 | forever loops, only up to three retries will be performed, and if 112 | error persists on the third try, appender will be disabled 113 | 114 | :IGNORE -- Do nothing. Log message will be lost, but appender will 115 | be used again if more log messages come in. 116 | 117 | Any other values are treated as :DISABLE 118 | 119 | After calling this function, LOG4CL will update the RETRY-COUNT, 120 | IGNORE-COUNT, LAST-ERROR and LAST-IGNORED-ERROR slots of the appender, 121 | based on the return value. 122 | 123 | Default primary method logs the error, and returns :DISABLE 124 | ")) 125 | 126 | (defgeneric property-initarg-from-string (instance property value) 127 | (:documentation "Called on appenders and layouts to possibly convert 128 | property value from a string into whatever its supposed to be. Default 129 | method will handle numeric, boolean and string properties, by calling 130 | PROPERTY-ALIST function")) 131 | 132 | (defgeneric property-alist (instance) 133 | (:documentation "Should return list of valid object properties, each 134 | element of the list being (INITARG SLOT TYPE) with INITARG being the 135 | keyword, SLOT is the slot name for the property and TYPE one of: 136 | 137 | Type | Description 138 | ------------------------|------------------------------------------------------ 139 | NUMBER or :NUMBER | Integer property, converted by (parse-integer) 140 | ------------------------|------------------------------------------------------ 141 | BOOLEAN or :BOOLEAN | Boolean, accepts \"true\" \"t\" \"on\" \"false\" 142 | | \"off\" \"nil\" and empty string 143 | ------------------------|------------------------------------------------------ 144 | STRING or :STRING | Value as-is after the equal sign in NAME = 145 | | Whitespace is not stripped 146 | ------------------------|------------------------------------------------------ 147 | :STRING-SKIP-WHITESPACE | Value with the leading whitespace removed 148 | 149 | Overriding this method to add extra properties is the only thing 150 | needed to allow extra properties in custom appenders/layouts to be 151 | configurable from by property file configurator. See also 152 | PROPERTY-INITARG-FROM-STRING")) 153 | 154 | (defgeneric appender-do-flush (appender time) 155 | (:documentation 156 | "Perform any flushes of appender output if needed, marking the that 157 | output was performed at time TIME. This function can be called from 158 | any thread and should take care of serializing") 159 | (:method (appender time) 160 | (declare (ignore appender time)))) 161 | -------------------------------------------------------------------------------- /src/appender/layout.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | (defclass layout () () 19 | (:documentation "Abstract layout class")) 20 | 21 | (defgeneric layout-to-stream (layout stream logger level log-func) 22 | (:documentation 23 | "Prints the log message to the specified stream. log message can is 24 | specified indirectly by LOG-FUNC argument, which is a callable object 25 | that accepts a stream and writes log message to it")) 26 | 27 | (defmethod property-alist ((instance layout)) 28 | "Abstract layout has no properties" 29 | '()) 30 | 31 | -------------------------------------------------------------------------------- /src/appender/simple-layout.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | (defclass simple-layout (layout) () 19 | (:documentation 20 | "Simple layout outputs log level and user message separated by 21 | dash. For example: INFO - user log message")) 22 | 23 | (declaim (inline write-log-level)) 24 | 25 | (defun write-log-level (level stream) 26 | "Print the log LEVEL's name to the STREAM" 27 | (write-string (log-level-to-string level) stream) 28 | (values)) 29 | 30 | (defmethod layout-to-stream ((layout simple-layout) 31 | stream 32 | logger 33 | level 34 | log-func) 35 | "Format the log message with the simple layout" 36 | (declare (ignore logger)) 37 | (fresh-line stream) 38 | (write-log-level level stream) 39 | (write-string " - " stream) 40 | (call-user-log-message log-func stream) 41 | (terpri stream) 42 | (values)) 43 | 44 | -------------------------------------------------------------------------------- /src/appender/syslog-appender-cffi.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2013, 2014, Jan Moringen. All rights reserved. 4 | ;;; 5 | ;;; License: Apache-2.0 6 | ;;; 7 | (in-package #:log4cl) 8 | 9 | (defmethod appender-do-append ((appender syslog-appender) logger level log-func) 10 | (let* ((syslog-level (%log4cl-level->syslog-level level)) 11 | (layout (appender-layout appender)) 12 | (message 13 | (with-output-to-string (stream) 14 | (layout-to-stream layout stream logger level log-func)))) 15 | (cl-syslog:log (syslog-appender-name appender) :user syslog-level message 16 | (if (syslog-appender-include-pid? appender) 17 | cl-syslog:+log-pid+ 0)))) 18 | 19 | 20 | ;; Utility functions 21 | 22 | (defun %log4cl-level->syslog-level (level) 23 | (let ((level/keyword (aref +log-level-to-keyword+ level))) 24 | (ecase level/keyword 25 | (:fatal :crit) 26 | (:error :err) 27 | (:warn :warning) 28 | (:info :info) 29 | ((:debug :debu1 :debu2 :debu3 :debu4 :debu5 :debu6 :debu7 :debu8 :debu9) 30 | :debug)))) 31 | -------------------------------------------------------------------------------- /src/appender/syslog-appender-sbcl.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2013, 2014, Jan Moringen. All rights reserved. 4 | ;;; 5 | ;;; License: Apache-2.0 6 | ;;; 7 | (in-package #:log4cl) 8 | 9 | (defmethod appender-do-append ((appender syslog-appender) logger level log-func) 10 | (let* ((syslog-level (%log4cl-level->syslog-level level)) 11 | (layout (appender-layout appender)) 12 | (message 13 | (with-output-to-string (stream) 14 | (layout-to-stream layout stream logger level log-func)))) 15 | (sb-posix:openlog (syslog-appender-name appender) 16 | (logior sb-posix:log-user 17 | (if (syslog-appender-include-pid? appender) 18 | sb-posix:log-pid 0))) 19 | (sb-posix:syslog syslog-level "~A" message) 20 | (sb-posix:closelog))) 21 | 22 | ;; Utility functions 23 | 24 | (defun %log4cl-level->syslog-level (level) 25 | (let ((level/keyword (aref +log-level-to-keyword+ level))) 26 | (ecase level/keyword 27 | (:fatal sb-posix:log-crit) 28 | (:error sb-posix:log-err) 29 | (:warn sb-posix:log-warning) 30 | (:info sb-posix:log-info) 31 | ((:debug :debu1 :debu2 :debu3 :debu4 :debu5 :debu6 :debu7 :debu8 :debu9) 32 | sb-posix:log-debug)))) 33 | -------------------------------------------------------------------------------- /src/appender/syslog-appender.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2013, 2014, Jan Moringen. All rights reserved. 4 | ;;; 5 | ;;; License: Apache-2.0 6 | ;;; 7 | 8 | (in-package #:log4cl) 9 | 10 | (defclass syslog-appender (appender) 11 | ((name :initarg :name :type string 12 | :accessor syslog-appender-name) 13 | (include-pid? :initarg :include-pid? :type boolean 14 | :accessor syslog-appender-include-pid?)) 15 | (:default-initargs 16 | :layout (make-instance 'pattern-layout :conversion-pattern "%m") 17 | :name (lisp-implementation-type) 18 | :include-pid? t) 19 | (:documentation 20 | "An appender that writes log messages to the syslog. 21 | 22 | The identity of the syslog connection is controlled by the :name 23 | initarg and defaults to 24 | 25 | (lisp-implementation-type) 26 | 27 | The :include-pid? initarg controls whether log entries produced by the 28 | syslog connection should include the process id (PID). The default is 29 | true.")) 30 | 31 | (defmethod property-alist ((instance syslog-appender)) 32 | (append (call-next-method) 33 | '((:name name :string-skip-whitespace) 34 | (:include-pid? include-pid? boolean)))) 35 | -------------------------------------------------------------------------------- /src/defs.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | ;; 18 | ;; Global variables and constants 19 | ;; 20 | ;; Define the log levels. Similar to Log4J, except that we add extra 21 | ;; nice log levels named "user1" through "user9" with "trace" log 22 | ;; level in-between user4 and user5 23 | ;; 24 | ;; Reasoning behind extra levels is: 25 | ;; 26 | ;; Unlike log4j the design of log4cl allows for mulitple log levels to 27 | ;; be enabled simultaneously. This is currently not used, but may be 28 | ;; used in the future 29 | ;; 30 | ;; This will allow for more fine grained control of logging in the 31 | ;; future where it would be possible to enable TRACE but not DEBUG or 32 | ;; INFO 33 | ;; 34 | (defconstant +log-level-unset+ 16) 35 | (defconstant +log-level-debu9+ 15) 36 | (defconstant +log-level-debu8+ 14) 37 | (defconstant +log-level-debu7+ 13) 38 | (defconstant +log-level-debu6+ 12) 39 | (defconstant +log-level-debu5+ 11) 40 | (defconstant +log-level-trace+ 10) 41 | (defconstant +log-level-debu4+ 9) 42 | (defconstant +log-level-debu3+ 8) 43 | (defconstant +log-level-debu2+ 7) 44 | (defconstant +log-level-debu1+ 6) 45 | (defconstant +log-level-debug+ 5) 46 | (defconstant +log-level-info+ 4) 47 | (defconstant +log-level-warn+ 3) 48 | (defconstant +log-level-error+ 2) 49 | (defconstant +log-level-fatal+ 1) 50 | (defconstant +log-level-off+ 0) 51 | (defconstant +min-log-level+ +log-level-fatal+) 52 | (defconstant +max-log-level+ +log-level-debu9+) 53 | 54 | ;; For converting log levels from string 55 | (defparameter +log-level-from-letter+ "OFEWID1234T56789U") 56 | 57 | (defparameter +log-level-symbols+ 58 | '(off fatal error warn info 59 | debug debu1 debu2 debu3 debu4 trace 60 | debu5 debu6 debu7 debu8 debu9 unset)) 61 | 62 | (defparameter +log-level-macro-symbols+ 63 | (remove-if (lambda (x) (member x '(off unset))) 64 | +log-level-symbols+)) 65 | 66 | (defparameter +log-level-from-string+ 67 | (mapcar 'string-upcase (mapcar 'symbol-name +log-level-symbols+))) 68 | 69 | ;; For converting level to string 70 | (defparameter +log-level-to-keyword+ 71 | (coerce '(:off :fatal :error :warn :info :debug 72 | :debu1 :debu2 :debu3 :debu4 :trace :debu5 :debu6 73 | :debu7 :debu8 :debu9) 74 | 'simple-vector)) 75 | 76 | (defparameter +log-level-to-string+ 77 | (map 'simple-vector #'string-upcase +log-level-to-keyword+)) 78 | 79 | (defparameter +log-level-to-lc-string+ 80 | (map 'simple-vector #'string-downcase +log-level-to-keyword+)) 81 | 82 | (defvar *log-indent* 0 83 | "Indent level can be used to indent logging info, is printed by %I 84 | pattern format") 85 | 86 | (declaim (special +self-logger+ +self-meta-logger+)) 87 | 88 | (defvar *ndc-context*) 89 | (eval-when (:load-toplevel :execute) 90 | (setf (documentation '*ndc-context* 'variable) "Value that is printed by %x pattern format")) 91 | 92 | (defvar *log-event-time* nil 93 | "Value of (GET-UNIVERSAL-TIME) for the current log event") 94 | 95 | (defvar *log-event-package-hint* nil 96 | "Package at call site or NIL if log statement had no literal symbols 97 | interned in *PACKAGE*") 98 | 99 | (defvar *inside-user-log-function* nil 100 | "True when we are inside of user log function, used to distinguish 101 | errors that are signaled the log statement itself, vs errors in layout 102 | or appender.") 103 | 104 | (defvar *logger-truename* nil 105 | "Will be used instead of *COMPILE-FILE-TRUENAME* or *LOAD-TRUENAME* 106 | when non-NIL to determine logger's parent file logger.") 107 | 108 | (define-condition log4cl-error (simple-error program-error) () 109 | (:documentation "Base class for all LOG4CL errors")) 110 | 111 | (define-condition log4cl-style-warning (simple-condition style-warning) ()) 112 | 113 | (defun log4cl-error (message &rest args) 114 | (error 'log4cl-error 115 | :format-control message 116 | :format-arguments args)) 117 | 118 | (defun log4cl-style-warning (message &rest args) 119 | (warn 'log4cl-style-warning 120 | :format-control message 121 | :format-arguments args)) 122 | 123 | (defun check-arg (name value) 124 | (or value 125 | (log4cl-error "Required argument ~@[~S ~]missing." name))) 126 | 127 | ;; Prevent problems with when loading directly over old version 128 | (eval-when (:compile-toplevel :execute) 129 | (fmakunbound 'logger-category) 130 | (fmakunbound 'logger-category-separator) 131 | (fmakunbound 'logger-name-start-pos) 132 | (fmakunbound 'logger-parent) 133 | (fmakunbound 'logger-child-hash) 134 | (fmakunbound 'logger-state) 135 | (fmakunbound 'logger-depth) 136 | (fmakunbound '%get-logger) 137 | (fmakunbound 'is-enabled-for) 138 | (fmakunbound 'current-state) 139 | (fmakunbound 'log-level-to-string) 140 | (fmakunbound 'log-level-to-lc-string) 141 | (fmakunbound 'log-event-time) 142 | (fmakunbound 'adjusted-logger-depth) 143 | (fmakunbound 'adjust-logger) 144 | (fmakunbound '(setf logger-log-level)) 145 | (fmakunbound '(setf logger-additivity)) 146 | (fmakunbound 'package-wrapper) 147 | (fmakunbound 'naming-option) 148 | ;; Under sbcl it was declared with always-bound in stable version 149 | #-sbcl(makunbound '*ndc-context*)) 150 | 151 | (defconstant +logger-category-depth-bits+ 6) 152 | (deftype logger-cat-idx () `(unsigned-byte ,+logger-category-depth-bits+)) 153 | (defconstant +logger-after-package-flag+ (ash 1 +logger-category-depth-bits+)) 154 | 155 | -------------------------------------------------------------------------------- /src/hierarchy-base.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | (defvar *hierarchy-max* 1 19 | "Number of hierarchies registered with the log4cl library. Each 20 | hierarchy has independent configuration with regards to log levels and 21 | appenders") 22 | 23 | (defvar *hierarchy* 0 24 | "Active hierarchy index. All logging functions use logger state 25 | indexed by this variable. Can be assigned directly or ") 26 | 27 | (defvar *hierarchy-lock* 28 | (bt:make-recursive-lock "Log4CL global configuration lock") 29 | "Global lock for changing logging configuration") 30 | 31 | (defvar *hierarchy-watcher-heartbeat* 1 32 | "How long hierarchy watcher thread sleeps between calling 33 | WATCHER-HOOK of each hierarchy") 34 | 35 | (defvar *watcher-event-time* 0 36 | "Universal time of the current watcher heartbeat") 37 | 38 | (defvar *watcher-thread* nil 39 | "The hierarchy watcher thread") 40 | 41 | (defclass hierarchy () 42 | ((name :initarg :name) 43 | ;; the index into logger-state array in each logger 44 | (index :initarg :index) 45 | ;; List of objects, for whom the watcher thread will call 46 | ;; WATCH-TOKEN-CHECK method every *HIERARCHY-WATCHER-HEARTBEAT* 47 | ;; seconds 48 | ;; 49 | ;; Used for auto-reloading the modified files in 50 | ;; PROPERTY-CONFIGURATOR but can be used for other stuff. 51 | (watch-tokens :initform nil :accessor watch-tokens) 52 | (%lock :initform (bt:make-recursive-lock "Log4CL hierarchy lock")))) 53 | 54 | (defvar *hierarchies* 55 | (make-array 1 :adjustable t :fill-pointer t 56 | :initial-contents 57 | `(,(make-instance 'hierarchy :name :default :index 0))) 58 | "Array of all hierarchies in the system") 59 | 60 | 61 | (defvar *name-to-hierarchy* (let* ((table (make-hash-table)) 62 | (h (aref *hierarchies* 0))) 63 | (setf (gethash (slot-value h 'name) table) h) 64 | table) 65 | "EQL hash table mapping hierarchy identifier to hierarchy index") 66 | 67 | 68 | (defgeneric watch-token-check (token) 69 | (:documentation "Will be called on each member of WATCH-TOKENS list 70 | when hierarchy watcher thread is started. If a unhandled condition is 71 | signaled from this function the watcher thread will remove 72 | corresponding token from the list")) 73 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /src/hierarchy.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | #+sbcl 19 | (declaim (sb-ext:always-bound 20 | *hierarchy* 21 | *hierarchy-lock* 22 | *name-to-hierarchy* 23 | *hierarchy-max* 24 | *watcher-event-time*)) 25 | 26 | (declaim (type fixnum *hierarchy-max* *hierarchy*) 27 | (type hash-table *name-to-hierarchy*) 28 | (inline hierarchy-index 29 | current-hierarchy) 30 | (ftype (function (fixnum) t) adjust-all-loggers-state) 31 | (ftype (function (t) t) %hierarchy-index hierarchy-index)) 32 | 33 | (defun current-hierarchy () 34 | "Return the currently active hierarchy" 35 | (aref *hierarchies* *hierarchy*)) 36 | 37 | (defmacro with-hierarchies-lock (&body body) 38 | `(bt:with-recursive-lock-held (*hierarchy-lock*) 39 | ,@body)) 40 | 41 | (defmacro with-hierarchy-lock ((&optional (hierarchy (current-hierarchy))) 42 | &body body) 43 | `(bt:with-recursive-lock-held ((slot-value ,hierarchy '%lock)) 44 | ,@body)) 45 | 46 | 47 | (defun %hierarchy-index (name) 48 | (when (stringp name) 49 | (setq name (intern name))) 50 | (let ((h (or (gethash name *name-to-hierarchy*) 51 | (with-hierarchies-lock 52 | (let ((h (make-instance 'hierarchy 53 | :index *hierarchy-max* 54 | :name name))) 55 | (adjust-all-loggers-state (1+ *hierarchy-max*)) 56 | (setf (gethash name *name-to-hierarchy*) h) 57 | (vector-push-extend h *hierarchies*) 58 | (incf *hierarchy-max*) 59 | h))))) 60 | (slot-value h 'index))) 61 | 62 | (defun hierarchy-index (hierarchy) 63 | "Return the hierarchy index for the specified hierarchy. Hierarchy 64 | must be already a number or a unique identifier suitable for comparing 65 | using EQL. If hierarchy is a string, it will be interned in the current 66 | package" 67 | (typecase hierarchy 68 | (number hierarchy) 69 | (hierarchy (slot-value hierarchy 'index)) 70 | (t (%hierarchy-index hierarchy)))) 71 | 72 | (defun add-watch-token (token &key 73 | (test #'equal) key 74 | (hierarchy (current-hierarchy))) 75 | "Add unique watch token to the HIERARCHY, uniqueness is determined 76 | by TEST and KEY arguments which are passed to FIND and REMOVE. Any 77 | matching token is already present, the old token is removed and new 78 | one is inserted. 79 | 80 | The per-hierarchy lock is held doing the operation. 81 | 82 | Automatically starts hierarchy watcher thread, if it was not already started 83 | " 84 | (with-slots (watch-tokens) hierarchy 85 | (with-hierarchy-lock (hierarchy) 86 | ;; remove first, in case caller got the test wrong initially, 87 | ;; and is now stuck with extra values 88 | (setf watch-tokens (remove token watch-tokens :test test :key key)) 89 | (push token watch-tokens)) 90 | (start-hierarchy-watcher-thread))) 91 | 92 | (defun remove-watch-token (token &key 93 | (test #'equal) key 94 | (hierarchy (current-hierarchy))) 95 | "Removes the watch token from the hierarchy, that matches the 96 | specified KEY and TEST arguments, which are passed to REMOVE 97 | function. Holds per-hierarchy lock doing its operation" 98 | (with-slots (watch-tokens) hierarchy 99 | (with-hierarchy-lock (hierarchy) 100 | (setf watch-tokens (remove token watch-tokens :test test :key key))))) 101 | 102 | 103 | -------------------------------------------------------------------------------- /src/impl-package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | ;; Implementation package for LOG4CL, that can be included in the :USE 17 | ;; list of other packages. All logging functions that otherwise would 18 | ;; conflict with CL package or with common words are named with LOG- 19 | ;; prefix 20 | ;; 21 | ;; Use this package if you are extending LOG4CL or writing your own 22 | ;; appenders 23 | 24 | (defpackage #:log4cl.package-setup 25 | (:use #:cl)) 26 | 27 | (in-package #:log4cl.package-setup) 28 | 29 | (macrolet 30 | ((%define-log4cl-package () 31 | (let* ((p2 (find-package '#:log4cl-impl)) 32 | (old-exports (when p2 33 | (let ((list '())) 34 | (do-external-symbols (s p2 list) 35 | (push s list))))) 36 | (new-exports 37 | '(;; log levels 38 | #:+log-level-unset+ #:+log-level-unset+ #:+log-level-debu9+ 39 | #:+log-level-debu8+ #:+log-level-debu7+ #:+log-level-debu6+ 40 | #:+log-level-debu5+ #:+log-level-debu4+ #:+log-level-debu3+ 41 | #:+log-level-debu2+ #:+log-level-debu1+ #:+log-level-trace+ 42 | #:+log-level-debug+ #:+log-level-info+ #:+log-level-warn+ 43 | #:+log-level-error+ #:+log-level-fatal+ #:+log-level-off+ 44 | ;; logging macros 45 | #:log-fatal #:log-error #:log-warn #:log-info #:log-debug #:log-trace 46 | #:log-debu1 #:log-debu2 #:log-debu3 #:log-debu4 #:log-debu5 #:log-debu6 47 | #:log-debu7 #:log-debu8 #:log-debu9 #:log-sexp #:log-sexp-with-level 48 | ;; sexp version of logging macros 49 | #:log-sexp-fatal #:log-sexp-error #:log-sexp-warn #:log-sexp-info #:log-sexp-debug #:log-sexp-trace 50 | #:log-sexp-debu1 #:log-sexp-debu2 #:log-sexp-debu3 #:log-sexp-debu4 #:log-sexp-debu5 #:log-sexp-debu6 51 | #:log-sexp-debu7 #:log-sexp-debu8 #:log-sexp-debu9 52 | #:log-indented 53 | ;; logger access functions 54 | #:make-log-level #:make-logger 55 | #:set-log-level 56 | #:logger-parent 57 | #:logger-log-level 58 | #:logger-appenders 59 | #:effective-log-level 60 | #:effective-appenders 61 | #:add-appender 62 | #:appender-added 63 | #:appender-removed 64 | #:logger-added 65 | #:logger-removed 66 | #:stream-appender 67 | #:log-config 68 | #:logger-name 69 | #:logger-category 70 | #:logger-depth 71 | #:naming-option 72 | #:log-level-from-object 73 | #:resolve-logger-form 74 | #:resolve-default-logging-form 75 | #:enclosing-scope-block-name 76 | #:reset-logging-configuration 77 | #:clear-logging-configuration 78 | ;; special variables 79 | #:*hierarchy* #:*root-logger* #:*default-logger-name* #:*log-indent* 80 | #:*ndc-context* #:*global-console* 81 | ;; hierarchy 82 | #:hierarchy-index 83 | #:with-log-hierarchy 84 | #:in-log-hierarchy 85 | #:with-package-log-hierarchy 86 | #:in-package-log-hierarchy 87 | ;; layouts & appenders 88 | #:layout 89 | #:layout-to-stream 90 | #:appender-do-append 91 | ;; standard layouts 92 | #:default-layout 93 | #:simple-layout 94 | ;; standard appenders 95 | #:appender 96 | #:stream-appender 97 | #:console-appender 98 | #:serialized-appender 99 | #:fixed-stream-appender 100 | #:appender-stream 101 | #:pattern-layout 102 | #:pattern-layout-error 103 | #:+min-log-level+ 104 | #:+max-log-level+ 105 | #:log-level-to-string 106 | #:with-ndc-context 107 | #:with-ndc 108 | #:with-log-indent 109 | #:logger-additivity 110 | #:appender-error 111 | #:handle-appender-error 112 | #:file-appender-base 113 | #:file-appender 114 | #:rolling-file-appender-base 115 | #:time-rolling-file-appender 116 | #:maybe-roll-file 117 | #:backup-log-file 118 | #:appender-logger-count 119 | #:close-appender 120 | #:remove-appender 121 | #:remove-all-appenders 122 | #:appender-filename 123 | #:daily-file-appender 124 | #:+self-logger+ 125 | #:package-wrapper 126 | #:logger-categories 127 | #:property-parser 128 | #:parse-property-stream 129 | #:property-configurator 130 | #:conversion-pattern 131 | #:property-parser-error 132 | #:configure 133 | #:logger-children 134 | #:logger-descendants 135 | #:map-logger-children 136 | #:map-logger-descendants 137 | #:start-hierarchy-watcher-thread 138 | #:stop-hierarchy-watcher-thread 139 | #:add-watch-token 140 | #:remove-watch-token 141 | #:watch-token-check 142 | #:log4cl-error 143 | #:save 144 | #:*configurations-file* 145 | #:*save-configurations-to-file* 146 | #:*max-configurations* 147 | #:restore 148 | #:same-configuration-p 149 | #:all-configurations 150 | #:list-configurations 151 | #:configuration-element 152 | #:configuration 153 | #:*logger-truename* 154 | #:logger-file 155 | #:*default-naming-configuration* 156 | #:*naming-configuration* 157 | #:naming-configuration 158 | #:appender-next-backup-file 159 | #:appender-last-backup-file 160 | #:logger-file-namestring 161 | #:logger-file-logger 162 | #:logger-ancestors 163 | #:inherited-log-level 164 | #:+self-meta-logger+ 165 | #:appender-layout 166 | #:appender-last-error 167 | #:appender-last-ignored-error 168 | #:appender-error-count 169 | #:appender-ignored-error-count 170 | #:appender-message-count 171 | #:appender-enabled-p 172 | #:counting-appender 173 | #:this-console-appender 174 | #:temp-appender 175 | #:temp-appender-error-type 176 | #:appender-loggers 177 | #:old-logging-macros 178 | #:packge-options 179 | #:appender-do-flush 180 | #:flush-appender 181 | #:flush-all-appenders 182 | #:save-appender 183 | #:all-appenders 184 | #:+expr-format-simple+ 185 | #:+expr-format-fancy+ 186 | #:category-separator 187 | #:category-case 188 | #:expr-print-format 189 | #:join-categories 190 | #:make-package-categories 191 | #:%get-logger 192 | #:with-package-naming-configuration 193 | #:fix-method-spec-list 194 | #:tricky-console-appender 195 | #:syslog-appender)) 196 | ;; avoid SBCL (also exports) error 197 | (removed-exports 198 | (set-difference old-exports 199 | new-exports 200 | :test #'string= 201 | :key #'string)) 202 | (defpackage-form 203 | `(defpackage #:log4cl-impl 204 | (:nicknames #:log4cl) 205 | (:use #:cl) 206 | (:export ,@new-exports)))) 207 | (when (and p2 removed-exports) 208 | (unexport removed-exports p2)) 209 | defpackage-form))) 210 | (%define-log4cl-package)) 211 | -------------------------------------------------------------------------------- /src/log4slime.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; Copyright (c) 2021, Hugh Daschbach 5 | ;;; 6 | ;;; This file is licensed to You under the Apache License, Version 2.0 7 | ;;; (the "License"); you may not use this file except in compliance 8 | ;;; with the License. You may obtain a copy of the License at 9 | ;;; http://www.apache.org/licenses/LICENSE-2.0 10 | ;;; 11 | ;;; Unless required by applicable law or agreed to in writing, software 12 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 13 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | ;;; See the License for the specific language governing permissions and 15 | ;;; limitations under the License. 16 | 17 | (defpackage #:log4cl.log4slime 18 | (:use #:cl) 19 | (:import-from #:log4cl.elisp 20 | #:*quicklisp-directory* 21 | #:*system-directory*) 22 | (:export #:emacs-helper 23 | #:get-buffer-log-menu 24 | #:install 25 | #:*quicklisp-directory* 26 | #:*system-directory*)) 27 | 28 | (in-package #:log4cl.log4slime) 29 | (log:package-options :shortest-nickname nil) 30 | 31 | ;; 32 | ;; Backend dispatch methods 33 | ;; 34 | 35 | (defmethod log4cl.elisp:find-definitions ((backend (eql :log4slime)) name) 36 | (swank::find-definitions name)) 37 | 38 | (defmethod log4cl.elisp:xref>elisp ((backend (eql :log4slime)) xref) 39 | (swank::xref>elisp xref)) 40 | 41 | (defmethod log4cl.elisp:parse-package ((backend (eql :log4slime)) package) 42 | (swank::parse-package package)) 43 | 44 | (defmethod log4cl.elisp:format-menu-plist ((backend (eql :log4slime)) 45 | pkg find-package-categories 46 | find-logger frob) 47 | (swank::with-buffer-syntax (pkg) 48 | (log4cl:with-package-naming-configuration (*package*) 49 | (funcall find-package-categories) 50 | (multiple-value-bind (logger display-name) (funcall find-logger) 51 | (log:expr logger display-name) 52 | (funcall frob logger display-name))))) 53 | 54 | ;; 55 | ;; Elisp interface functions 56 | ;; 57 | 58 | (defun emacs-helper (info) 59 | "Wrapper around ‘log4cl.elisp:emacs-helper’. 60 | This provides the dynamic dispatch parameter to provide log4cl.elisp 61 | with access to Swank support functions." 62 | (log4cl.elisp:emacs-helper :log4slime info)) 63 | 64 | (defun get-buffer-log-menu (&rest args) 65 | "Wrapper around ‘log4cl.elisp:get-buffer-log-menu’. 66 | This provides the dynamic dispatch parameter to provide log4cl.elisp 67 | with access to Swank support functions." 68 | (log4cl.elisp:get-buffer-log-menu :log4slime args)) 69 | 70 | ;; 71 | ;; Support for snippets compiled via C-c C-c correctly identifying the source file 72 | ;; 73 | (defvar *old-compile-string-for-emacs* 74 | (fdefinition 'swank::compile-string-for-emacs)) 75 | 76 | ;; Patch the COMPILE-STRING-FOR-EMACS to bind *LOGGER-TRUENAME* to the file 77 | ;; name that C-c C-c snippet is from 78 | (setf (fdefinition 'swank::compile-string-for-emacs) 79 | (lambda (string buffer position filename policy) 80 | (let ((log4cl:*logger-truename* 81 | (when filename (ignore-errors (parse-namestring filename))))) 82 | (funcall *old-compile-string-for-emacs* 83 | string buffer position filename policy)))) 84 | 85 | ;; In case SWANK was patched with the "thread stopper" patch that defines 86 | ;; protocol for starting/stopping threads around calls to fork(), register 87 | ;; a callback for the watcher thread 88 | (let ((rss-foo (find-symbol (symbol-name '#:register-thread-stopper) (find-package :swank)))) 89 | (and rss-foo (funcall rss-foo :log4cl #'log4cl::start/stop-watcher-hook))) 90 | 91 | (defun install (&key force 92 | (destination-directory *quicklisp-directory*) 93 | just-message) 94 | "Generate log4slime-setup.el if it does not exist. 95 | Sanity check it if it does exist." 96 | (log4cl.elisp:install "LOG4SLIME" :force force 97 | :destination-directory destination-directory 98 | :just-message just-message)) 99 | 100 | (unless (get :log4slime :no-emacs-startup-message) 101 | (install :just-message t)) 102 | -------------------------------------------------------------------------------- /src/log4sly.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; Copyright (c) 2021, Hugh Daschbach 5 | ;;; 6 | ;;; This file is licensed to You under the Apache License, Version 2.0 7 | ;;; (the "License"); you may not use this file except in compliance 8 | ;;; with the License. You may obtain a copy of the License at 9 | ;;; http://www.apache.org/licenses/LICENSE-2.0 10 | ;;; 11 | ;;; Unless required by applicable law or agreed to in writing, software 12 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 13 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | ;;; See the License for the specific language governing permissions and 15 | ;;; limitations under the License. 16 | 17 | (defpackage #:log4cl.log4sly 18 | (:use #:cl) 19 | (:import-from #:log4cl.elisp 20 | #:*quicklisp-directory* 21 | #:*system-directory*) 22 | (:export #:emacs-helper 23 | #:get-buffer-log-menu 24 | #:install 25 | #:*quicklisp-directory* 26 | #:*system-directory*)) 27 | 28 | (in-package #:log4cl.log4sly) 29 | (log:package-options :shortest-nickname nil) 30 | 31 | ;; 32 | ;; Backend dispatch methods 33 | ;; 34 | 35 | (defmethod log4cl.elisp:find-definitions ((backend (eql :log4sly)) name) 36 | (slynk::find-definitions name)) 37 | 38 | (defmethod log4cl.elisp:xref>elisp ((backend (eql :log4sly)) xref) 39 | (slynk::xref>elisp xref)) 40 | 41 | (defmethod log4cl.elisp:parse-package ((backend (eql :log4sly)) package) 42 | (slynk::parse-package package)) 43 | 44 | (defmethod log4cl.elisp:format-menu-plist ((backend (eql :log4sly)) 45 | pkg find-package-categories 46 | find-logger frob) 47 | (slynk::with-buffer-syntax (pkg) 48 | (log4cl:with-package-naming-configuration (*package*) 49 | (funcall find-package-categories) 50 | (multiple-value-bind (logger display-name) (funcall find-logger) 51 | (log:expr logger display-name) 52 | (funcall frob logger display-name))))) 53 | 54 | ;; 55 | ;; Elisp interface functions 56 | ;; 57 | 58 | (defun emacs-helper (info) 59 | "Wrapper around ‘log4cl.elisp:emacs-helper’. 60 | This provides the dynamic dispatch parameter to provide log4cl.elisp 61 | with access to Slynk support functions." 62 | (log4cl.elisp:emacs-helper :log4sly info)) 63 | 64 | (defun get-buffer-log-menu (&rest args) 65 | "Wrapper around ‘log4cl.elisp:get-buffer-log-menu’. 66 | This provides the dynamic dispatch parameter to provide log4cl.elisp 67 | with access to Slynk support functions." 68 | (log4cl.elisp:get-buffer-log-menu :log4sly args)) 69 | 70 | ;; 71 | ;; Support for snippets compiled via C-c C-c correctly identifying the source file 72 | ;; 73 | (defvar *old-compile-string-for-emacs* 74 | (fdefinition 'slynk::compile-string-for-emacs)) 75 | 76 | ;; Patch the COMPILE-STRING-FOR-EMACS to bind *LOGGER-TRUENAME* to the file 77 | ;; name that C-c C-c snippet is from 78 | (setf (fdefinition 'slynk::compile-string-for-emacs) 79 | (lambda (string buffer position filename policy) 80 | (let ((log4cl:*logger-truename* 81 | (when filename (ignore-errors (parse-namestring filename))))) 82 | (funcall *old-compile-string-for-emacs* 83 | string buffer position filename policy)))) 84 | 85 | ;; In case SLYNK was patched with the "thread stopper" patch that defines 86 | ;; protocol for starting/stopping threads around calls to fork(), register 87 | ;; a callback for the watcher thread 88 | (let ((rss-foo (find-symbol (symbol-name '#:register-thread-stopper) (find-package :slynk)))) 89 | (and rss-foo (funcall rss-foo :log4cl #'log4cl::start/stop-watcher-hook))) 90 | 91 | (defun install (&key force 92 | (destination-directory *quicklisp-directory*) 93 | just-message) 94 | "Generate log4sly-setup.el if it does not exist. 95 | Sanity check it if it does exist." 96 | (log4cl.elisp:install "LOG4SLY" :force force 97 | :destination-directory destination-directory 98 | :just-message just-message)) 99 | 100 | (unless (get :log4sly :no-emacs-startup-message) 101 | (install :just-message t)) 102 | -------------------------------------------------------------------------------- /src/logging-macros.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | (defmacro with-log-indent ((&optional (indent '(1+ *log-indent*))) 19 | &body body) 20 | "Executes forms in BODY with *LOG-INDENT* set to INDENT" 21 | `(let ((*log-indent* ,indent)) 22 | ,@body)) 23 | 24 | (defmacro deflog-macros (levels) 25 | (let (list) 26 | (dolist (level levels) 27 | (let ((log-macro-name (intern (format nil "~a-~a" 28 | (string '#:log) 29 | (string level)))) 30 | (level-name (intern (format nil "+~a-~a+" 31 | (string '#:log-level) 32 | (string level))))) 33 | (push `(defmacro ,log-macro-name (&rest args &environment env) 34 | " 35 | Submit log message to the logging system. Whenever 36 | the message is actually displayed or not depends on logging system 37 | configuration at run-time. 38 | 39 | The ARGS are parsed as follows: 40 | 41 | 1. Determine a logger object 42 | 43 | If first argument is a constant list, constant symbol or a keyword, it 44 | is made into a logger object as described in the MAKE-LOGGER macro 45 | documentation 46 | 47 | If first argument is a constant string, logger name is auto-determined 48 | from context as described in the MAKE-LOGGER macro documentation, and 49 | system proceeds to step 2. 50 | 51 | Otherwise any non-NIL first argument is assumed to be a form, that 52 | when evaluated will return a logger object. 53 | 54 | 2. If there are remaining arguments, they are used as format control 55 | string and format arguments, to be passed into the FORMAT function to 56 | produce the log message, when one is produced. 57 | 58 | If there were no other arguments, then this macro expands into a form, 59 | that will return T or NIL depending if logging with specified log 60 | level will actually produce any log messages. Note that having log 61 | level enabled does not necessary mean logging with log level is 62 | enabled, it also takes into account whenever log message will reach 63 | any appenders. 64 | " 65 | (expand-log-with-level env ,level-name args)) 66 | list))) 67 | `(progn 68 | ,@(nreverse list)))) 69 | 70 | (deflog-macros #.+log-level-macro-symbols+) 71 | 72 | (defvar +make-logger-symbols+ '(make-logger)) 73 | 74 | (defmacro log-sexp-with-level (level &rest sexps &environment env) 75 | "Expands into LOG- log statement that will print each element 76 | of SEXPS in the form of ELEMENT=VALUE where ELEMENT will be the 77 | literal argument without evaluating it, and VALUE will be the result 78 | of evaluation. Constant string elements will be output directly. 79 | 80 | A pretty printer (pprint-newline :fill) format will be used as a 81 | separator between expressions, so that long expressions start 82 | on a new line, if *PRINT-PRETTY* is non-NIL 83 | 84 | Example: 85 | 86 | (let ((a 1) (b '(two three)) 87 | (c (loop for i from 1 to 15 collect i))) 88 | (log:sexp \"values are\" a b c)) 89 | 90 | will produce log message: 91 | 92 | [debug] - values are A=1 B=(TWO THREE) 93 | C=(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 94 | 95 | Separator between expression and value, which defaults to equal sign, 96 | and a suffix after each value, which defaults to \" ~:_\" (a space 97 | followed by conditional newline) can be customized per package via 98 | NAMING-OPTION generic function 99 | " 100 | (declare (ignore env)) 101 | (with-package-naming-configuration (*package*) 102 | `(,level from-log-expr ,@sexps))) 103 | 104 | (defmacro deflog-sexp-macros (levels) 105 | (let (list) 106 | (dolist (level levels) 107 | (let ((log-sexp-macro-name (intern (format nil "~a-~a" 108 | (string '#:log-sexp) 109 | (string level)))) 110 | (log-macro-name (intern (format nil "~a-~a" 111 | (string '#:log) 112 | (string level))))) 113 | (push `(defmacro ,log-sexp-macro-name (&rest args) 114 | "Expands into the log statement that will print each 115 | element of ARGS in the form of ELEMENT=VALUE where ELEMENT will be the 116 | literal argument without evaluating it, and VALUE will be the result 117 | of evaluation. For constant string elements, it is output literally 118 | without printing its value. 119 | 120 | Example: 121 | 122 | (let ((a 1) (b '(two three))) 123 | (log-sexp \"values are\" a b)) 124 | 125 | will produce log message: 126 | 127 | [debug] - values are A=1 B=(TWO THREE) 128 | 129 | " 130 | `(log-sexp-with-level ,',log-macro-name ,@args)) 131 | list))) 132 | `(progn ,@(reverse list)))) 133 | 134 | (deflog-sexp-macros #.+log-level-macro-symbols+) 135 | 136 | (defmacro log-sexp (&rest args) 137 | (with-package-naming-configuration (*package*) 138 | (let* ((level (naming-option *package* :expr-log-level)) 139 | (log-sexp-macro-name (intern (format nil "~a-~a" 140 | (string '#:log-sexp) 141 | (string (aref +log-level-to-keyword+ level))) 142 | :log4cl-impl))) 143 | `(,log-sexp-macro-name ,@args)))) 144 | 145 | (setf (documentation 'log-sexp 'function) (documentation 'log-sexp-debug 'function)) 146 | 147 | (defmacro with-log-hierarchy ((hierarchy) &body body) 148 | "Binds the *CURRENT-HIERARCHY* to the specified hierarchy for the 149 | dynamic scope of BODY. HIERARCHY can be hierarchy index or name" 150 | `(let ((*hierarchy* (hierarchy-index ,hierarchy))) 151 | ,@body)) 152 | 153 | (defmacro with-package-log-hierarchy (&body body) 154 | "Binds the *CURRENT-HIERARCHY* to the unique hierarchy for the current 155 | package for the dynamic scope of BODY." 156 | `(with-log-hierarchy (*package*) ,@body)) 157 | 158 | (defmacro in-log-hierarchy (&optional hierarchy) 159 | "Sets the *CURRENT-HIERARCHY* to specified hierarchy, or the default 160 | one when NIL" 161 | `(setq *hierarchy* (hierarchy-index (or ,hierarchy :default)))) 162 | 163 | (defmacro in-package-log-hierarchy () 164 | "Sets the *CURRENT-HIERARCHY* to specified hierarchy, or the default 165 | one when NIL" 166 | `(in-log-hierarchy *package*)) 167 | 168 | (defmacro make-logger (&optional (arg nil arg-p) &environment env) 169 | (with-package-naming-configuration (*package*) 170 | (resolve-logger-form *package* env (if arg-p `(from-make-logger ,arg))))) 171 | 172 | (defmacro with-ndc ((&optional (ndc nil ndcp)) &body body) 173 | "Execute forms in BODY with *NDC-CONTEXT* set to CONTEXT. The 174 | context is printed by the %x pattern layout format" 175 | (if ndcp 176 | `(let ((*ndc-context* ,ndc)) 177 | ,@body) 178 | `(progv '(*ndc-context*) 179 | () 180 | ,@body))) 181 | 182 | -------------------------------------------------------------------------------- /src/naming-ccl.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | (defun ccl-get-block-name (env) 19 | (declare (ignore env)) 20 | (labels ((maybe-fix-ccl-method (elem) 21 | (if (and (consp elem) 22 | (= 3 (length elem)) 23 | (keywordp (first elem)) 24 | (symbolp (second elem)) 25 | (consp (third elem))) 26 | `(,(second elem) 27 | ,(first elem) 28 | ,@(cddr elem)) 29 | elem))) 30 | (when ccl::*nx-current-function* 31 | (let ((name (ccl::afunc-name ccl::*nx-current-function*))) 32 | (fix-method-spec-list 33 | (cond ((not (consp name)) name) 34 | ((eq :internal (first name)) 35 | (let ((names (reverse (rest name)))) 36 | (append (list (first names)) 37 | (rest names)))) 38 | (t (maybe-fix-ccl-method name)))))))) 39 | 40 | (defmethod enclosing-scope-block-name (package env) 41 | "Return the enclosing block name suitable for naming a logger" 42 | (declare (ignore package)) 43 | (ccl-get-block-name env)) 44 | -------------------------------------------------------------------------------- /src/naming-sbcl.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | 19 | (eval-when (:compile-toplevel :load-toplevel :execute) 20 | (defun safe-intern (name) 21 | (let* ((name (string-upcase name)) 22 | (pos (position #\: name)) 23 | (package-name (subseq name 0 pos)) 24 | (symbol-name (subseq name (+ pos 25 | (if (char= #\: (char name (1+ pos))) 26 | 2 1)))) 27 | (pkg (find-package package-name))) 28 | (find-symbol symbol-name pkg)))) 29 | 30 | (sb-ext:defglobal +sbcl-wrapper-names+ 31 | (remove nil (mapcar #'safe-intern 32 | '("sb-c::hairy-arg-processor" 33 | "sb-c::varargs-entry" 34 | "sb-c::xep" "sb-c::tl-xep" 35 | "sb-c::&more-processor" 36 | "sb-c::top-level-form" 37 | "sb-c::&optional-processor")))) 38 | 39 | (sb-ext:defglobal +sbcl-wrapper-ignore+ 40 | (remove nil (mapcar #'safe-intern 41 | '("sb-c::.anonymous." 42 | "sb-thread::with-mutex-thunk")))) 43 | 44 | 45 | (defun include-block-debug-name? (debug-name) 46 | "Figures out if we should include the debug-name into the stack of 47 | nested blocks.. Should return the symbol to use. 48 | 49 | For now SBCL seems to use: 50 | 51 | SYMBOL => normal defun block 52 | (LABELS SYMBOL) => inside of labels function 53 | (FLET SYMBOL) => inside of flet function 54 | (LAMBDA (arglist) => inside of anonymous lambda 55 | (SB-PCL::FAST-METHOD SYMBOL ...) for defmethod 56 | (SB-PCL::VARARGS-ENTRY (SB-PCL::FAST-METHOD SYMBOL )) for defmethod with &rest parametwer 57 | (SB-C::HAIRY-ARG-PROCESSOR SYMBOL) => for functions with complex lambda lists 58 | 59 | In all of the above cases except LAMBDA we simply return SYMBOL, for 60 | LAMBDA we return the word LAMBDA and NIL for anything else. 61 | 62 | Example: As a result of this default logger name for SBCL for the 63 | following form: 64 | 65 | (defmethod foo () 66 | (labels ((bar () 67 | (funcall (lambda () 68 | (flet ((baz () 69 | (log-info \"test\"))) 70 | (baz)))))) 71 | (bar))) 72 | 73 | will be: package.foo.bar.baz 74 | 75 | " 76 | (if (symbolp debug-name) 77 | (when (and (not (member debug-name +sbcl-wrapper-ignore+)) 78 | (symbol-package debug-name) 79 | (not (equal 0 (search "CLEANUP-FUN-" 80 | (symbol-name debug-name))))) 81 | debug-name) 82 | (cond 83 | ((atom debug-name) 84 | (string debug-name)) 85 | ((member (first debug-name) '(flet labels lambda)) 86 | (include-block-debug-name? (second debug-name))) 87 | ((eq 'labels (first debug-name)) 88 | (include-block-debug-name? (second debug-name))) 89 | ((eq 'flet (first debug-name)) 90 | (include-block-debug-name? (second debug-name))) 91 | ;; (lambda 'lambda) 92 | ((eq 'sb-pcl::fast-method (first debug-name)) 93 | (rest debug-name)) 94 | ((member (first debug-name) +sbcl-wrapper-names+) 95 | (include-block-debug-name? (second debug-name))) 96 | ((eq (first debug-name) 'setf) 97 | debug-name)))) 98 | 99 | (defun sbcl-get-block-name (env) 100 | "Return a list naming SBCL lexical environment. For example when 101 | compiling local function FOO inside a global function FOOBAR, will 102 | return \(FOOBAR FOO\)" 103 | (let* ((names-from-lexenv 104 | (nreverse 105 | (loop with last = nil 106 | as lambda = (sb-c::lexenv-lambda env) 107 | then (sb-c::lexenv-lambda (sb-c::lambda-lexenv lambda)) 108 | while lambda 109 | as debug-name = (include-block-debug-name? (sb-c::leaf-debug-name lambda)) 110 | if (and debug-name (not (eq last debug-name))) 111 | collect debug-name 112 | and do (setq last debug-name)))) 113 | (name (or names-from-lexenv sb-pcl::*method-name*))) 114 | (fix-method-spec-list name))) 115 | 116 | 117 | (defmethod enclosing-scope-block-name (package env) 118 | "Return the enclosing block name suitable for naming a logger" 119 | (declare (ignore package)) 120 | (when env (sbcl-get-block-name env))) 121 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (cl:in-package #:log4cl) 17 | 18 | (macrolet ((log4cl-defpackage () 19 | (labels ((reexport-from (name names) 20 | `((:import-from ,name ,@names) 21 | (:export ,@names))) 22 | (level-expr-syms () 23 | ;; make SEXP- symbols for all debug levels 24 | (loop for sym in +log-level-macro-symbols+ 25 | collect (make-symbol (format nil "~a-~a" 26 | (string '#:sexp) 27 | (string sym))))) 28 | (shadow-and-export (syms) 29 | `((:shadow ,@syms) 30 | (:export ,@syms)))) 31 | `(defpackage #:log 32 | (:use) 33 | ,@(reexport-from 34 | '#:log4cl 35 | '( ;; class names 36 | ;; #:fixed-stream-appender 37 | ;; #:console-appender 38 | ;; #:file-appender 39 | ;; #:daily-file-appender 40 | ;; #:property-configurator 41 | ;; #:simple-layout 42 | ;; #:pattern-layout 43 | 44 | ;; 45 | ;; #:clear-logging-configuration 46 | ;; #:reset-logging-configuration 47 | 48 | ;; utility stuff 49 | ;; #:configure 50 | ;; #:add-appender 51 | ;; #:remove-appender 52 | ;; #:remove-all-appenders 53 | ;; #:logger-additivity 54 | ;; #:logger-appenders 55 | ;; #:effective-appenders 56 | ;; #:effective-log-level 57 | ;; #:logger-category 58 | ;; #:logger-name 59 | ;; #:logger-parent 60 | ;; #:logger-children 61 | ;; #:logger-descendants 62 | ;; #:logger-ancestors 63 | ;; #:logger-depth 64 | ;; #:logger-log-level 65 | ;; #:log-sexp-with-level 66 | ;; customization 67 | ;; #:naming-option 68 | ;; #:log-level-from-object 69 | ;; #:resolve-logger-form 70 | ;; #:resolve-default-logging-form 71 | ;; #:enclosing-scope-block-name 72 | ;; #:reset-logging-configuration 73 | ;; #:clear-logging-configuration 74 | ;; #:naming-option 75 | ;; #:package-wrapper 76 | ;; #:map-logger-children 77 | ;; #:map-logger-descendants 78 | ;; #:start-hierarchy-watcher-thread 79 | ;; #:stop-hierarchy-watcher-thread 80 | ;; #:add-watch-token 81 | ;; #:remove-watch-token 82 | ;; #:watch-token-check 83 | ;; #:log4cl-error 84 | ;; #:log4cl-error 85 | ;; variables 86 | ;; #:*root-logger* 87 | ;; quick save/restore of configurations 88 | #:save 89 | #:restore 90 | #:package-options 91 | #:with-ndc 92 | ;; #:configuration-element 93 | ;; #:configuration 94 | ;; #:same-configuration-p 95 | ;; #:all-configurations 96 | ;; #:list-configurations 97 | ;; #:*configurations-file* 98 | ;; #:*save-configurations-to-file* 99 | ;; #:*max-configurations* 100 | )) 101 | (:import-from :cl #:in-package) 102 | ,@(shadow-and-export 103 | `(#:sexp 104 | #:expr #:config ,@+log-level-macro-symbols+ ,@(level-expr-syms) 105 | #:make #:category 106 | #:with-hierarchy 107 | #:push #:pop 108 | #:with-package-hierarchy 109 | #:in-package-hierarchy 110 | #:in-hierarchy 111 | #:with-indent 112 | ;; one letter logging macro forwarders 113 | #:f #:e #:w #:i #:d #:d1 #:d2 #:d3 #:d4 114 | #:t #:d5 #:d6 #:d7 #:d8 #:d9 #:c #:s)) 115 | 116 | (:export 117 | #:f #:e #:w #:i #:d #:d1 #:d2 #:d3 #:d4 #:t #:d5 #:d6 #:d7 #:d8 #:d9 #:c #:s))))) 118 | (log4cl-defpackage)) 119 | 120 | (defmacro forward-macro (name from-name &optional deprecate replacement) 121 | (if deprecate 122 | (let ((replacement 123 | ;; we want stuff to print as LOG4CL:SOMETHING rather 124 | ;; then LOG4CL-IMPL:SOMETHING but can't change package 125 | ;; name right now 126 | (when replacement 127 | (cond 128 | ((and (symbolp replacement) 129 | (eq *package* (symbol-package replacement))) 130 | (format nil "~A:~A" '#:log4cl replacement)) 131 | ((and (consp replacement) 132 | (endp (cddr replacement))) 133 | (format nil "~A:~A" (first replacement) (second replacement))) 134 | (t 135 | (format nil "~S" replacement)))))) 136 | `(progn 137 | (setf (documentation ',name 'function) (documentation ',from-name 'function)) 138 | (setf (macro-function ',name) 139 | (lambda (&rest args) 140 | (log4cl-style-warning "Macro ~S is deprecated~^. Use ~A instead" ',name 141 | ,@(when replacement `(',replacement))) 142 | (apply (macro-function ',from-name) args))))) 143 | `(progn 144 | (setf (documentation ',name 'function) (documentation ',from-name 'function)) 145 | (setf (macro-function ',name) (macro-function ',from-name))))) 146 | 147 | (defmacro forward-function (name from-name) 148 | `(progn 149 | (setf (documentation ',name 'function) (documentation ',from-name 'function)) 150 | (setf (fdefinition ',name) (fdefinition ',from-name)))) 151 | 152 | (defmacro forward-levels (levels) 153 | (let ((defs 154 | (loop for level in levels 155 | as macro-name = (intern (symbol-name level) :log) 156 | as forward-name = (or (find-symbol (format nil "~A-~A" 157 | (string '#:log) 158 | (string level)) 159 | :log4cl) 160 | (error "Unable to find logging macro for ~S" level)) 161 | collect `(forward-macro ,macro-name ,forward-name)))) 162 | `(progn 163 | ,@defs))) 164 | 165 | (defmacro forward-sexp-levels (levels) 166 | (let ((defs 167 | (loop for level in levels 168 | ;; sexp-debug, sexp-info etc 169 | as macro-name = (intern (symbol-name level) :log) 170 | as sexp-macro-name = (intern (format nil "~A-~A" 171 | (string '#:sexp) 172 | (string level)) 173 | :log) 174 | ;; in impl package they are called LOG-SEXP-DEBUG LOG-SEXP-INFO ETC 175 | as sexp-forward-name = (or (find-symbol (format nil "~A-~A" 176 | (string'#:log-sexp) 177 | (string level)) 178 | :log4cl) 179 | (error "Unable to find logging macro for ~S" level)) 180 | collect `(forward-macro ,sexp-macro-name ,sexp-forward-name t ,macro-name)))) 181 | `(progn 182 | ,@defs))) 183 | 184 | (forward-levels #.+log-level-macro-symbols+) 185 | (forward-sexp-levels #.+log-level-macro-symbols+) 186 | (forward-macro log:sexp log4cl:log-sexp) 187 | 188 | ;; make (log:expr) same as (log:sexp) and (log:make) shortcut for (log:make-logger) 189 | (forward-macro log:expr log4cl:log-sexp) 190 | 191 | (forward-macro log:category log4cl:make-logger) 192 | (forward-macro log:make log4cl:make-logger t log:category) 193 | 194 | ;; one letter logging macros 195 | (forward-macro log:f log4cl:log-fatal) 196 | (forward-macro log:e log4cl:log-sexp) 197 | (forward-macro log:w log4cl:log-warn) 198 | (forward-macro log:i log4cl:log-info) 199 | 200 | (forward-macro log:d log4cl:log-debug) 201 | (forward-macro log:d1 log4cl:log-debu1) 202 | (forward-macro log:d2 log4cl:log-debu2) 203 | (forward-macro log:d3 log4cl:log-debu3) 204 | (forward-macro log:d4 log4cl:log-debu4) 205 | (forward-macro log:t log4cl:log-trace) 206 | (forward-macro log:d5 log4cl:log-debu5) 207 | (forward-macro log:d6 log4cl:log-debu6) 208 | (forward-macro log:d7 log4cl:log-debu7) 209 | (forward-macro log:d8 log4cl:log-debu8) 210 | (forward-macro log:d9 log4cl:log-debu9) 211 | (forward-macro log:s log4cl:log-sexp) 212 | 213 | (forward-macro log:with-indent log4cl:with-log-indent) 214 | 215 | (forward-function log:config log-config) 216 | (forward-function log:c log-config) 217 | (forward-function log:pop restore) 218 | (forward-function log:push save) 219 | 220 | ;; deprecated forwards 221 | (forward-macro log:with-hierarchy log4cl:with-log-hierarchy t log4cl:with-log-hierarchy) 222 | (forward-macro log:with-package-hierarchy log4cl:with-package-log-hierarchy t log4cl:with-package-log-hierarchy) 223 | (forward-macro log:in-hierarchy log4cl:in-log-hierarchy t log4cl:in-log-hierarchy) 224 | (forward-macro log:in-package-hierarchy log4cl:in-package-log-hierarchy t log4cl:in-package-log-hierarchy) 225 | 226 | (forward-macro log4cl:with-ndc-context log4cl:with-ndc t log4cl:with-ndc) 227 | -------------------------------------------------------------------------------- /src/property-configurator.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | (defclass property-configurator (property-parser) 19 | ((loggers) 20 | (additivity) 21 | (appenders)) 22 | (:documentation "Class that holds configurator state while parsing 23 | the properties file")) 24 | 25 | (defmethod shared-initialize :after ((config property-configurator) slots &rest initargs &key) 26 | (declare (ignore slots initargs)) 27 | (with-slots (loggers additivity appenders) 28 | config 29 | (setf loggers '() additivity '() appenders '()))) 30 | 31 | (defclass logger-record (property-location) 32 | ((logger :initarg :logger) 33 | (level :initarg :level) 34 | (appender-names :initform nil :initarg :appender-names))) 35 | 36 | (defclass delayed-instance (property-location) 37 | ((class :initform nil) 38 | (properties :initform nil) 39 | (extra-initargs :initform nil) 40 | (instance :initform nil))) 41 | 42 | (defclass delayed-layout (delayed-instance) 43 | ((name :initarg :name))) 44 | 45 | (defclass delayed-appender (delayed-instance) 46 | ((layout :initform nil) 47 | (name :initarg :name) 48 | (used :initform nil))) 49 | 50 | (defmethod parse-property-keyword ((parser property-configurator) 51 | keyword 52 | tokens 53 | value) 54 | "Ignores anything that does not start with LOG4CL prefix, otherwise 55 | calls PARSE-PROPERTY-TOKENS again (which will convert 2nd level of the 56 | token name into the keyword and call this function again" 57 | (log-sexp keyword) 58 | (if (eq keyword :log4cl) 59 | (parse-property-tokens parser tokens value) 60 | (call-next-method))) 61 | 62 | 63 | (defun parse-logger-helper (parser keyword tokens value) 64 | "Common helper that handles both .rootLogger= and .logger.name= 65 | lines" 66 | (with-slots (name-token-separator name-token-read-case loggers) 67 | parser 68 | (let ((logger 69 | (cond ((eq keyword :rootlogger) 70 | (or (null tokens) 71 | (log4cl-error "Root logger cannot have any sub-properties")) 72 | *root-logger*) 73 | (t (or tokens (log4cl-error "Logger name missing")) 74 | (%get-logger 75 | tokens name-token-separator name-token-read-case)))) 76 | (value-tokens (split-string value "," t))) 77 | (unless (plusp (length value-tokens)) 78 | (log4cl-error "Expecting LEVEL, [ ...] as the value")) 79 | (setf loggers (delete logger loggers :key #'car)) 80 | (push (cons logger 81 | (make-instance 'logger-record 82 | :logger logger 83 | :level (log-level-from-object (first value-tokens) *package*) 84 | :appender-names 85 | (mapcar (lambda (name) 86 | (log-sexp name 87 | (convert-read-case 88 | name name-token-read-case)) 89 | (convert-read-case 90 | name name-token-read-case)) 91 | (rest value-tokens)))) 92 | loggers)))) 93 | 94 | (defmethod parse-property-keyword ((parser property-configurator) 95 | (keyword (eql :rootlogger)) 96 | tokens 97 | value) 98 | (parse-logger-helper parser keyword tokens value)) 99 | 100 | 101 | (defmethod parse-property-keyword ((parser property-configurator) 102 | (keyword (eql :logger)) 103 | tokens 104 | value) 105 | (parse-logger-helper parser keyword tokens value)) 106 | 107 | 108 | (defun intern-boolean (value) 109 | "Parse boolean value" 110 | (setq value (strip-whitespace value)) 111 | (cond ((zerop (length value)) 112 | nil) 113 | ((char= (char value 0) #\#) 114 | nil) 115 | ((member value '("nil" "none" "false" "off") :test 'equalp) 116 | nil) 117 | ((member value '("t" "true" "yes" "on") :test 'equalp) 118 | t) 119 | (t (log4cl-error "Invalid boolean value ~s" value)))) 120 | 121 | (defmethod parse-property-keyword ((parser property-configurator) 122 | (keyword (eql :additivity)) 123 | tokens 124 | value) 125 | (with-slots (name-token-separator name-token-read-case additivity) 126 | parser 127 | (or tokens 128 | (log4cl-error "Missing logger name")) 129 | (let* ((logger 130 | (if (equalp tokens '("rootlogger")) 131 | *root-logger* 132 | (%get-logger 133 | tokens name-token-separator name-token-read-case)))) 134 | (setf additivity (delete logger additivity :key #'car)) 135 | (push (cons logger (intern-boolean value)) 136 | additivity)))) 137 | 138 | (defun intern-class-name (string) 139 | (let ((pos (position #\: string)) 140 | (*print-readably* nil)) 141 | (if (null pos) 142 | (find-symbol string) 143 | (let ((pkg (find-package (substr string 0 pos))) 144 | (only-external-p t)) 145 | (when pkg 146 | (incf pos) 147 | (when (and (< pos (length string)) 148 | (char= (char string pos) #\:)) 149 | (incf pos) 150 | (setf only-external-p nil)) 151 | (log-sexp pkg only-external-p (substr string pos)) 152 | (multiple-value-bind (symbol visibility) 153 | (find-symbol (substr string pos) pkg) 154 | (and (or (not only-external-p) 155 | (equal visibility :external)) 156 | symbol))))))) 157 | 158 | (defun set-delayed-instance-class (instance value) 159 | (with-slots (class name) instance 160 | (let ((new-class (intern-class-name value))) 161 | (or (null class) (log4cl-error "~a class specified twice" name)) 162 | (or new-class (log4cl-error "~a class ~s not found" name value)) 163 | (setf class new-class)))) 164 | 165 | (defun set-delayed-instance-property (instance tokens value) 166 | (with-slots (name properties) 167 | instance 168 | (let ((prop (intern (pop tokens) :keyword))) 169 | (or (null tokens) (log4cl-error "~a expecting a single property" name)) 170 | (or (null (assoc prop properties)) 171 | (log4cl-error "~a property ~s specified twice" name prop)) 172 | (push (list prop value (make-instance 'property-location)) properties)))) 173 | 174 | (defmethod parse-property-keyword ((parser property-configurator) 175 | (keyword (eql :appender)) 176 | tokens 177 | value) 178 | (with-slots (name-token-separator name-token-read-case appenders) 179 | parser 180 | (when (null tokens) 181 | (log4cl-error "appender should be followed by appender name")) 182 | (let* ((name (strip-whitespace (pop tokens))) 183 | (appender (or (cdr (assoc name appenders :test 'equal)) 184 | (cdar (push (cons 185 | name 186 | (make-instance 'delayed-appender 187 | :name (format nil "appender ~A" name))) 188 | appenders))))) 189 | (with-slots (class layout initargs) 190 | appender 191 | (cond ((null tokens) 192 | (set-delayed-instance-class 193 | appender (convert-read-case 194 | (strip-whitespace value) name-token-read-case))) 195 | ((equal (first tokens) (symbol-name :layout)) 196 | (pop tokens) 197 | (or layout 198 | (setf layout (make-instance 'delayed-layout 199 | :name 200 | (format nil "~A's appender layout" 201 | name)))) 202 | (if (null tokens) 203 | (set-delayed-instance-class 204 | layout (convert-read-case 205 | (strip-whitespace value) name-token-read-case)) 206 | (set-delayed-instance-property layout tokens value))) 207 | (t (set-delayed-instance-property appender tokens value))))))) 208 | 209 | 210 | (defun create-delayed-instance (instance) 211 | "First filter all properties through through INSTANCE-PROPERTY-FROM-STRING, 212 | and then create the instance" 213 | (with-property-location (instance) 214 | (with-slots (instance name class properties extra-initargs) 215 | instance 216 | (setf instance 217 | (make-instance (or class (log4cl-error "Class not specified for ~a" name)))) 218 | ;; need to do it twice to apply properties, since property parsing 219 | ;; stuff is specialized on the instance class 220 | (setf instance (apply #'reinitialize-instance 221 | instance 222 | (append 223 | (loop for (prop value location) in properties 224 | appending 225 | (with-property-location (location) 226 | (list prop (property-initarg-from-string 227 | instance prop value)))) 228 | extra-initargs)))))) 229 | 230 | (defmethod parse-property-stream :after ((configurator property-configurator) stream) 231 | "Parse the stream and apply changes to logging configuration" 232 | (declare (ignore stream)) 233 | (with-log-indent () 234 | (with-slots (appenders loggers additivity) 235 | configurator 236 | ;; for each logger, see that logger's in appender list were defined 237 | (loop for (logger . rec) in loggers 238 | do (with-property-location (rec) 239 | (log-sexp rec %parse-line %parse-line-num) 240 | (dolist (name (slot-value rec 'appender-names)) 241 | (or (assoc name appenders :test 'equal) 242 | (log4cl-error "Logger ~a refers to non-existing appender ~s" 243 | logger name)) 244 | (setf (slot-value (cdr (assoc name appenders :test 'equal)) 245 | 'used) t)))) 246 | ;; create the appenders, we do this before mucking with loggers, 247 | ;; in case creating an appender signals an error 248 | (loop for (nil . a) in appenders 249 | if (slot-value a 'used) 250 | do (with-slots (layout extra-initargs) a 251 | (when layout 252 | (setf extra-initargs 253 | `(:layout ,(create-delayed-instance layout)))) 254 | (create-delayed-instance a))) 255 | (loop for (logger . rec) in loggers do 256 | (progn 257 | (log-sexp "Doing " logger (slot-value rec 'level)) 258 | (when (assoc logger additivity) 259 | (set-additivity logger (cdr (assoc logger additivity)) nil)) 260 | (remove-all-appenders-internal logger nil) 261 | (set-log-level logger (slot-value rec 'level) nil) 262 | (dolist (name (slot-value rec 'appender-names)) 263 | (add-appender-internal 264 | logger (slot-value (cdr (assoc name appenders :test 'equal)) 265 | 'instance) 266 | nil)) 267 | (adjust-logger logger)))))) 268 | 269 | (defmethod property-initarg-from-string (instance property value) 270 | "Generic implementation for numbers, boolean and string properties, 271 | that calls PROPERTY-ALIST function to determine what kind of 272 | property it is. Signals error if property is not in the list" 273 | (let* ((props-alist (property-alist instance)) 274 | (type (third (assoc property props-alist)))) 275 | (case type 276 | ((number :number) (parse-integer (strip-whitespace value))) 277 | ((boolean :boolean) (intern-boolean (strip-whitespace value))) 278 | ((string :string) value) 279 | (:string-skip-whitespace 280 | (loop for idx from 0 below (length value) 281 | for c = (char value idx) 282 | while (member c '(#\Space #\Tab) :test 'char=) 283 | finally (return (coerce (substr value idx) 'simple-string)))) 284 | (t (log4cl-error "Unknown property ~s for class ~s" property instance))))) 285 | 286 | (defgeneric configure (configurator source &key &allow-other-keys) 287 | (:documentation "Configure the logging system from specified source")) 288 | 289 | (defmethod configure ((configurator property-configurator) 290 | (s stream) &key) 291 | "Configures logging from the specified stream" 292 | (parse-property-stream configurator s)) 293 | 294 | (defclass property-configurator-file-watch () 295 | ((filespec :initarg :filespec :accessor filespec-of) 296 | (time :initarg :time) 297 | (configurator :initarg :configurator))) 298 | 299 | (defmethod print-object ((watch property-configurator-file-watch) stream) 300 | (print-unreadable-object (watch stream :type t) 301 | (prin1 (slot-value watch 'filespec) stream))) 302 | 303 | (defmethod configure ((configurator property-configurator) filespec &key auto-reload) 304 | "Configures logging from the specified file. If AUTO-RELOAD is 305 | non-NIL, then after initial configuration will watch the file for 306 | modifications and re-configure when it changes. Note that auto-reload 307 | will not be configured if initial configuration signaled a error" 308 | (let ((filespec (merge-pathnames filespec))) 309 | (with-open-file (s filespec) 310 | (configure configurator s)) 311 | (when auto-reload 312 | (add-watch-token (make-instance 'property-configurator-file-watch 313 | :filespec filespec 314 | :time (file-write-date filespec) 315 | :configurator configurator) 316 | :test 317 | (lambda (watch1 watch2) 318 | (and (typep watch2 'property-configurator-file-watch) 319 | (equal (slot-value watch1 'filespec) 320 | (slot-value watch2 'filespec)))))))) 321 | 322 | (defmethod watch-token-check ((token property-configurator-file-watch)) 323 | "Checks properties file write time, and re-configure from it if it changed. 324 | Catches and does not re-signal PROPERTY-PARSER-ERROR, so watching the 325 | file continues if newly modified file had an error" 326 | (with-slots (filespec time configurator) token 327 | (let ((new-time (file-write-date filespec))) 328 | (when (/= new-time time) 329 | (setf time new-time) 330 | (handler-case 331 | (progn (configure configurator filespec) 332 | (log-info '(log4cl) "Re-configured logging from ~A" 333 | (enough-namestring filespec))) 334 | (property-parser-error (c) 335 | (log-error '(log4cl) 336 | "Re-configuring from ~A failed:~%~A" 337 | (enough-namestring filespec) c))))))) 338 | -------------------------------------------------------------------------------- /src/property-parser.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | ;; generic property file parser, can be reused for other stuff 19 | 20 | (defclass property-parser () 21 | ((name-token-separator :initform ":" :initarg :separator) 22 | (name-token-read-case :initform (readtable-case *readtable*) 23 | :initarg :read-case) 24 | (%orig-initargs)) 25 | (:documentation "Class for reading Java style property files.")) 26 | 27 | 28 | (defvar %parse-line nil 29 | "Current line being parsed") 30 | (defvar %parse-line-num nil 31 | "Current line number in the input stream") 32 | 33 | (defclass property-location () 34 | ((line :initform %parse-line) 35 | (line-num :initform %parse-line-num)) 36 | (:documentation "Remembered line and line number in the input 37 | stream where object appeared, so we can signal errors with that 38 | info")) 39 | 40 | (defmacro with-property-location ((location) &body body) 41 | "Run BODY with %PARSE-LINE and %PARSE-LINE-NUM bound to the 42 | remembered location, so that any errors signaled will have correct 43 | location" 44 | `(with-slots (line-num line) 45 | ,location 46 | (let ((%parse-line line) 47 | (%parse-line-num line-num)) 48 | ,@body))) 49 | 50 | (define-condition property-parser-error (log4cl-error parse-error) 51 | ((condition :initarg :condition :accessor condition-of) 52 | (line-num :initarg :line-num :accessor line-num-of) 53 | (line :initarg :line :accessor line-of)) 54 | (:report (lambda (c stream) 55 | (format stream "\"~A\"~%~ 56 | Error at line ~D:~%~ 57 | ~A~%" 58 | (line-of c) 59 | (line-num-of c) 60 | (condition-of c))))) 61 | 62 | (defmethod shared-initialize :after ((parser property-parser) slots &rest initargs &key &allow-other-keys) 63 | (declare (ignore slots)) 64 | (with-slots (name-token-separator name-token-read-case 65 | line-num %orig-initargs) parser 66 | (unless (slot-boundp parser '%orig-initargs) 67 | (setf %orig-initargs initargs)) 68 | (setf name-token-separator (getf %orig-initargs :separator ":") 69 | name-token-read-case (getf %orig-initargs :read-case 70 | (readtable-case *readtable*))))) 71 | 72 | (defgeneric parse-property-stream (parser stream) 73 | (:documentation "Read stream and for each line that is not a 74 | comment, call PARSE-LINE function.")) 75 | 76 | (defgeneric parse-property-line (parser name value) 77 | (:documentation "Called for each NAME=VALUE line in the properties 78 | stream. Both NAME and VALUE are strings")) 79 | 80 | (defgeneric parse-property-tokens (parser tokens value) 81 | (:documentation "Called by default PARSE-PROPERTY-LINE 82 | method. TOKENS will be the NAME part of the NAME=VALUE line, split 83 | according to NAME-TOKEN-SEPARATOR and their case adjusted by 84 | NAME-TOKEN-READ-CASE")) 85 | 86 | (defgeneric parse-property-keyword (parser keyword more-tokens value) 87 | (:documentation "Called to handle properties that start with a 88 | common prefix. KEYWORD will be the 1st token of the property name, 89 | interned as a keyword. MORE-TOKENS are the rest of the name tokens as strings 90 | 91 | For example for a the properties stream line: 92 | \"log4cl:foo:bar=baz\" 93 | this function will be called with the arguments 94 | (:LOG4CL '(\"FOO\" \"BAR\") \"BAZ\"value) 95 | ")) 96 | 97 | (defmethod parse-property-stream ((parser property-parser) stream) 98 | ;; so that we can re-parse with the same parser 99 | (reinitialize-instance parser) 100 | (let (pos start name (%parse-line-num 0) (%parse-line nil)) 101 | (flet ((space-or-equal-p (c) 102 | (or (char= c #\Space) 103 | (char= c #\Tab) 104 | (char= c #\=)))) 105 | (tagbody 106 | ;; bite my shiny metal ass Dijkstra 107 | :next-line 108 | (unless (setq %parse-line (read-line stream nil)) (go :exit)) 109 | (incf %parse-line-num) 110 | (setq start (position-if-not #'space-or-equal-p %parse-line)) 111 | (when (or (not start) (char= (char %parse-line start) #\#)) 112 | (go :next-line)) 113 | (setq pos (position-if #'space-or-equal-p %parse-line :start start)) 114 | (setq name (substr %parse-line start pos)) 115 | (unless (plusp (length name)) 116 | (log4cl-error "Property name can't be empty")) 117 | (unless (and pos (setq pos (position #\= %parse-line :start pos))) 118 | (log4cl-error "Expecting '=' after property '~a'" name)) 119 | ;; note we don't strip whitespace from beginning of value, since 120 | ;; string properties like pattern layout's :conversion-pattern 121 | ;; may start with literal whitespace 122 | (parse-property-line parser name (substr %parse-line (1+ pos))) 123 | (go :next-line) 124 | :exit)))) 125 | 126 | (defun convert-read-case (string case) 127 | "Convert STRING according to CASE" 128 | (declare (type string string) 129 | (type (member nil :upcase :downcase :invert :preserve) case)) 130 | (with-output-to-string (s) 131 | (if (not case) 132 | (princ string s) 133 | (write-string-modify-case (coerce string 'simple-string) 134 | s case)))) 135 | 136 | 137 | (defmethod parse-property-line ((parser property-parser) name value) 138 | "Handles two special cases of SEPARATOR=VALUE and 139 | READ-CASE=VALUE (ignoring case differences), and updates the parser 140 | accordingly, otherwise splits NAME with current separator, converts 141 | tokens according to read case, and forwards to PARSE-PROPERTY-TOKENS" 142 | (with-slots (name-token-separator name-token-read-case) parser 143 | (log-sexp name value) 144 | (let ((name-tokens (split-string name name-token-separator))) 145 | (cond ((equalp "separator" (first name-tokens)) 146 | (unless (null (cdr name-tokens)) 147 | (log4cl-error "Separator can't have any sub-properties")) 148 | (setf name-token-separator (strip-whitespace value)) 149 | (unless (plusp (length name-token-separator)) 150 | (log4cl-error "Separator can't be empty")) 151 | (log-sexp "changed separator" name-token-separator)) 152 | ((equalp "read-case" (first name-tokens)) 153 | (unless (null (cdr name-tokens)) 154 | (log4cl-error "Read-case can't have any sub-properties")) 155 | (setq name-token-read-case 156 | (let ((read-case (strip-whitespace value))) 157 | (cond ((equalp read-case ":upcase") 158 | :upcase) 159 | ((equalp read-case ":downcase") 160 | :downcase) 161 | ((equalp read-case ":invert") 162 | :invert) 163 | ((equalp read-case ":preserve") 164 | :preserve) 165 | ((or (equalp "" read-case) 166 | (equalp "nil" read-case)) 167 | nil) 168 | (t (log4cl-error "Invalid read case ~s" read-case))))) 169 | (log-sexp "changed read-case" name-token-read-case)) 170 | (t 171 | (parse-property-tokens 172 | parser 173 | (mapcar (lambda (token) 174 | (convert-read-case token name-token-read-case)) 175 | name-tokens) 176 | value)))))) 177 | 178 | (defmethod parse-property-tokens ((parser property-parser) tokens value) 179 | "Interns the first element of TOKENS as a keyword, and forwards to 180 | PARSE-PROPERTY-KEYWORD" 181 | (let ((keyword (intern (pop tokens) :keyword))) 182 | (log-sexp keyword tokens value) 183 | (parse-property-keyword parser keyword tokens value))) 184 | 185 | 186 | (defmethod parse-property-stream :around ((parser property-parser) stream) 187 | "Wrap errors with line number" 188 | (declare (ignore stream)) 189 | (handler-bind 190 | ((serious-condition (lambda (c) 191 | (error 'property-parser-error 192 | :line %parse-line 193 | :line-num %parse-line-num 194 | :condition c)))) 195 | (call-next-method))) 196 | 197 | -------------------------------------------------------------------------------- /src/self-logger.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (cl:in-package #:log4cl) 17 | 18 | (defvar *self-log-config* '(:sane :warn :own :two-line :immediate-flush)) 19 | 20 | (defvar +self-meta-logger+ 21 | (let ((logger (make-logger '#:meta))) 22 | (setf (logger-additivity logger) nil) 23 | logger)) 24 | 25 | (defvar +self-logger+ 26 | (let ((logger (%logger-parent +self-meta-logger+))) 27 | (setf (logger-additivity logger) nil) 28 | logger)) 29 | 30 | -------------------------------------------------------------------------------- /src/watcher.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl) 17 | 18 | (defvar *watcher-thread-bindings* nil 19 | "Extra bindings for watcher thread") 20 | 21 | (defun call-with-logged-problems (context thunk) 22 | (handler-case (funcall thunk) 23 | (error (condition) 24 | (log-error :logger +self-meta-logger+ 25 | "~@" 26 | (type-of condition) context condition)) 27 | (warning (condition) 28 | (log-warn :logger +self-meta-logger+ 29 | "~@" 30 | (type-of condition) context condition)))) 31 | 32 | (defmacro with-logged-problems (context &body body) 33 | `(call-with-logged-problems ',context (lambda () ,@body))) 34 | 35 | (defvar *stop-semaphore* (bt:make-semaphore :name "stop-log4cl")) 36 | 37 | (defun start-hierarchy-watcher-thread () 38 | (unless *watcher-thread* 39 | (let ((logger (make-logger '(log4cl)))) 40 | (bordeaux-threads:make-thread 41 | (lambda () 42 | ;; prevent two watcher threads from being started due to race 43 | (when (with-hierarchies-lock 44 | (cond (*watcher-thread* 45 | (log-debug "Watcher thread already started") 46 | nil) 47 | (t (setq *watcher-thread* (bt:current-thread))))) 48 | (unwind-protect 49 | (handler-case 50 | (progn 51 | (log-info :logger logger "Hierarchy watcher started") 52 | (loop 53 | for *watcher-event-time* = (get-universal-time) 54 | do (hierarchy-watcher-once) 55 | until (bt:wait-on-semaphore *stop-semaphore* 56 | :timeout *hierarchy-watcher-heartbeat*))) 57 | (error (e) 58 | (log-error :logger logger "Error in hierarchy watcher thread:~%~A" e))) 59 | (with-hierarchies-lock 60 | (setf *watcher-thread* nil)) 61 | (log-info :logger logger "Hierarchy watcher thread ended")))) 62 | :name "Hierarchy Watcher" 63 | :initial-bindings 64 | `((*hierarchy* . 0) 65 | (*package* . (find-package '#:log4cl-impl)) 66 | ,@*watcher-thread-bindings*))))) 67 | 68 | (defun hierarchy-watcher-do-one-token (hier token) 69 | (with-slots (name) hier 70 | (with-log-hierarchy (hier) 71 | (handler-bind ((serious-condition 72 | (lambda (c) 73 | (remove-watch-token token :test #'eq) 74 | (log-error 75 | '(log4cl) 76 | "WATCH-TOKEN-CHECK in ~S hierarchy signaled error for token ~S~%~A" 77 | name token c) 78 | (return-from hierarchy-watcher-do-one-token)))) 79 | (watch-token-check token))))) 80 | 81 | (defun hierarchy-watcher-once () 82 | "Do one iteration of watcher loop." 83 | (map nil 84 | (lambda (hier) 85 | (dolist (token (slot-value hier 'watch-tokens)) 86 | (hierarchy-watcher-do-one-token hier token))) 87 | *hierarchies*)) 88 | 89 | (defun stop-hierarchy-watcher-thread () 90 | (let ((thread (with-hierarchies-lock *watcher-thread*))) 91 | (when thread 92 | (with-logged-problems '(stop-hierarchy-watcher-thread :destroy-thread) 93 | (bt:signal-semaphore *stop-semaphore*)) 94 | (with-logged-problems '(stop-hierarchy-watcher-thread :join-thread) 95 | (bt:join-thread thread))))) 96 | 97 | (defun maybe-start-watcher-thread () 98 | (with-hierarchies-lock 99 | (let* ((tokens 100 | (loop for h :across *hierarchies* :append (watch-tokens h))) 101 | (have-appenders-p 102 | (some (lambda (x) (and (typep x 'stream-appender) 103 | (not (slot-value x 'immediate-flush)))) 104 | tokens))) 105 | (when have-appenders-p 106 | (start-hierarchy-watcher-thread))))) 107 | 108 | (defun save-hook () 109 | "Flushes all existing appenders, and stops watcher thread" 110 | (with-logged-problems (save-hook :flush-all-appenders) 111 | (flush-all-appenders)) 112 | (with-logged-problems (save-hook :save-all-appenders) 113 | (save-all-appenders)) 114 | (with-logged-problems (save-hook :stop-hierarch-watcher-thread) 115 | (stop-hierarchy-watcher-thread))) 116 | 117 | (defun exit-hook () 118 | "Flushes all existing appenders" 119 | (with-logged-problems (exit-hook :flush-all-appenders) 120 | (flush-all-appenders))) 121 | 122 | (defun init-hook () 123 | "Starts watcher thread if any existing appenders don't 124 | have :immediate-flush option" 125 | (with-logged-problems (init-hook :maybe-start-watch-thread) 126 | (maybe-start-watcher-thread)) 127 | (with-logged-problems (init-hook :reinitialize-this-console-appender) 128 | (dolist (appender (all-appenders)) 129 | (when (typep appender 'this-console-appender) 130 | (setf (slot-value appender 'stream) *global-console*) 131 | (reinitialize-instance appender))))) 132 | 133 | (defun all-appenders (&optional (all-hierarchies t)) 134 | "Return all existing appenders in all hierarchies" 135 | (let ((appenders '())) 136 | (labels ((collect-appenders (x) 137 | (dolist (a (logger-appenders x)) 138 | (push a appenders))) 139 | (collect-hier (x) 140 | (let ((*hierarchy* x)) 141 | (collect-appenders *root-logger*) 142 | (map-logger-descendants #'collect-appenders *root-logger*)))) 143 | (if all-hierarchies 144 | (with-hierarchies-lock (dotimes (i *hierarchy-max*) (collect-hier i))) 145 | (collect-hier *hierarchy*)) 146 | appenders))) 147 | 148 | (defun start/stop-watcher-hook (cmd &optional arg) 149 | (ecase cmd 150 | (:stop (let ((thread (with-hierarchies-lock *watcher-thread*))) 151 | (when thread 152 | (stop-hierarchy-watcher-thread) 153 | (funcall arg)))) 154 | (:start (start-hierarchy-watcher-thread)))) 155 | 156 | #+sbcl (pushnew 'save-hook sb-ext:*save-hooks*) 157 | #+sbcl (pushnew 'exit-hook sb-ext:*exit-hooks*) 158 | #+sbcl (pushnew 'init-hook sb-ext:*init-hooks*) 159 | -------------------------------------------------------------------------------- /tests/log4cl.properties: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2012, Max Mikhanosha. All rights reserved. 2 | # 3 | # This file is licensed to You under the Apache License, Version 2.0 4 | # (the "License"); you may not use this file except in compliance 5 | # with the License. You may obtain a copy of the License at 6 | # http://www.apache.org/licenses/LICENSE-2.0 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | 14 | 15 | log4cl:rootLogger = INFO, file1, console 16 | #, syslog1 17 | log4cl:appender:console = log4cl:console-appender 18 | log4cl:appender:console:layout = log4cl:pattern-layout 19 | log4cl:appender:console:layout:conversion-pattern =|%p| |%c| - %m%n 20 | log4cl:appender:file1 = log4cl:file-appender 21 | log4cl:appender:file1:file = /tmp/logfile.txt 22 | log4cl:appender:file1:immediate-flush = true 23 | #log4cl:appender:syslog1 = log4cl:syslog-appender 24 | #log4cl:appender:syslog1:name = myprogram 25 | #log4cl:appender:syslog1:layout = log4cl:pattern-layout 26 | #log4cl:appender:syslog1:layout:conversion-pattern =%p %m 27 | -------------------------------------------------------------------------------- /tests/log4j.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sharplispers/log4cl/fe3da517147d023029782ced7cd989ba24f1e62d/tests/log4j.jar -------------------------------------------------------------------------------- /tests/log4j.properties: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2012, Max Mikhanosha. All rights reserved. 2 | # 3 | # This file is licensed to You under the Apache License, Version 2.0 4 | # (the "License"); you may not use this file except in compliance 5 | # with the License. You may obtain a copy of the License at 6 | # http://www.apache.org/licenses/LICENSE-2.0 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | # defaults 14 | 15 | 16 | # 17 | # Used it testing log4cl vs log4j speed 18 | # 19 | 20 | speed.file=/dev/null 21 | root.level=DEBUG 22 | root.appender=speed 23 | # Log4j configuration file. 24 | log4j.rootCategory=${root.level}, ${root.appender} 25 | # Available levels are DEBUG, INFO, WARN, ERROR, FATAL 26 | log4j.appender.SIMPLE=org.apache.log4j.ConsoleAppender 27 | log4j.appender.SIMPLE.layout=org.apache.log4j.SimpleLayout 28 | # 29 | log4j.appender.speed=org.apache.log4j.FileAppender 30 | log4j.appender.speed.file=${speed.file} 31 | log4j.appender.speed.layout=org.apache.log4j.SimpleLayout 32 | log4j.appender.speed.bufferedIO=true 33 | log4j.appender.speed.encoding=latin1 34 | # 35 | # A1 is a ConsoleAppender 36 | # 37 | log4j.appender.A1=org.apache.log4j.ConsoleAppender 38 | log4j.appender.A1.layout=org.apache.log4j.PatternLayout 39 | #log4j.appender.A1.layout.ConversionPattern=[%d{MM/dd/yyyy HH:mm:ss}] %-5p %c %m%n 40 | log4j.appender.A1.layout.ConversionPattern=%-5p %c %m%n 41 | # 42 | # A2 is a DailyRollingFileAppender 43 | # 44 | log4j.appender.A2=org.apache.log4j.DailyRollingFileAppender 45 | log4j.appender.A2.file=logs/logfile.log 46 | log4j.appender.A2.datePattern='.'yyyy-MM-dd 47 | log4j.appender.A2.append=true 48 | log4j.appender.A2.layout=org.apache.log4j.PatternLayout 49 | log4j.appender.A2.layout.ConversionPattern=%-5p %d{ISO8601} [%t] - %m%n 50 | # 51 | # A3 is a UDPAppender for sending logs as broadcast UDP packets 52 | # 53 | log4j.appender.A3=org.apache.log4j.net.UDPAppender 54 | log4j.appender.A3.remoteHost=192.168.15.255 55 | log4j.appender.A3.port=8881 56 | log4j.appender.A3.layout=org.apache.log4j.PatternLayout 57 | log4j.appender.A3.layout.ConversionPattern=%-5p %d{ISO8601} [%t] - %m%n 58 | 59 | #log4j.category.cat1=DEBUG 60 | -------------------------------------------------------------------------------- /tests/test-category-separator.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (log4cl-test:defsubsuite :log4cl-test.dots) 17 | (in-package :log4cl-test.dots) 18 | (log4cl-test:subsuite-start) 19 | 20 | ;; 21 | ;; Test in a different package, where logger category separator is dot 22 | ;; instead of new line 23 | 24 | (deftest make-logger-by-list-of-categories () 25 | "Test MAKE-LOGGER macro with static list of categories" 26 | (with-package-log-hierarchy 27 | (let ((logger (make-logger '(two three four)))) 28 | (log4cl-test::basics logger) 29 | (is (equal (logger-category logger) 30 | (concatenate 'string 31 | (symbol-name 'two) "." 32 | (symbol-name 'three) "." 33 | (symbol-name 'four)))) 34 | (is (equal (logger-name logger) (symbol-name 'four))) 35 | (is (eql (logger-depth logger) 3))))) 36 | 37 | (deftest logger-name-via-dotted-keyword () 38 | "Test that specifying logger name by a keyword containing dots is 39 | correctly parsed into multiple loggers" 40 | (with-package-log-hierarchy 41 | (clear-logging-configuration) 42 | (is (null (logger-appenders *root-logger*))) 43 | (is (null (logger-log-level *root-logger*))) 44 | (is (eql +log-level-off+ (effective-log-level *root-logger*))) 45 | (let* ((logger (make-logger :one.two.three)) 46 | (logger-one (make-logger :one)) 47 | (logger-two (make-logger :one.two))) 48 | (is (eq (logger-parent logger) logger-two)) 49 | (is (eq (logger-parent logger-two) logger-one)) 50 | (is (null (logger-log-level logger))) 51 | (is (eql +log-level-off+ (effective-log-level logger))) 52 | ;; Add appender to the parent 53 | (add-appender logger-one (make-instance 'console-appender)) 54 | ;; see that it got inherited 55 | (is (null (logger-appenders logger))) 56 | (is (not (null (effective-appenders logger))))))) 57 | 58 | (deftest appender-additivity-1 () 59 | "Test appender additivity works" 60 | (with-package-log-hierarchy 61 | (clear-logging-configuration) 62 | (let* ((one (make-logger :one)) 63 | (one-two (make-logger :one.two)) 64 | (one-two-three (make-logger :one.two.three)) 65 | (a1 (make-instance 'counting-appender)) 66 | (a2 (make-instance 'counting-appender)) 67 | (a3 (make-instance 'counting-appender))) 68 | (log-config :i) 69 | (add-appender one a1) 70 | (add-appender one-two a2) 71 | (add-appender one-two-three a3) 72 | (is (log-info :logger one-two-three)) 73 | (setf (logger-additivity one-two) nil) 74 | (is (log-info :logger one-two-three)) 75 | (log-info :logger one "hey") 76 | (log-info :logger one-two "hey") 77 | (is (equal 1 (slot-value a1 'count))) 78 | (is (equal 1 (slot-value a2 'count))) 79 | (is (equal 0 (slot-value a3 'count))) 80 | (log-info :logger one-two-three "hey") 81 | (is (equal 1 (slot-value a1 'count))) 82 | (is (equal 2 (slot-value a2 'count))) 83 | (is (equal 1 (slot-value a3 'count))) 84 | (setf (logger-additivity one-two) t) 85 | (log-info :logger one-two-three "hey") 86 | (is (equal 2 (slot-value a1 'count))) 87 | (is (equal 3 (slot-value a2 'count))) 88 | (is (equal 2 (slot-value a3 'count))) 89 | ;; damn, our (reset-logger) uses HAVE-APPENDERS-FOR-LEVEL 90 | ;; rather then (EFFECTIVE-APPENDERS), to avoid consing, and 91 | ;; I forgot to update it for additivity... Test that (log-whatever) 92 | ;; expressions take additivity into account as well 93 | (log-config one-two-three :d) 94 | (is (log-debug :logger one-two-three)) 95 | (setf (logger-additivity one-two-three) nil) 96 | (is (log-debug :logger one-two-three)) 97 | (remove-appender one-two-three a3) 98 | (is (not (log-debug :logger one-two-three))) 99 | (setf (logger-additivity one-two-three) t) 100 | (setf (logger-additivity one-two) nil) 101 | (is (log-debug :logger one-two-three)) 102 | (remove-appender one-two a2) 103 | (is (not (log-debug :logger one-two-three)))))) 104 | 105 | (deftest appender-additivity-2 () 106 | "Test appender additivity works" 107 | (with-package-log-hierarchy 108 | (clear-logging-configuration) 109 | (let* ((one (make-logger :one)) 110 | (one-two (make-logger :one.two)) 111 | (one-two-three (make-logger :one.two.three))) 112 | ;; Add appender to the root, and one-two 113 | (add-appender *root-logger* (make-instance 'console-appender)) 114 | (add-appender one (make-instance 'console-appender)) 115 | ;; see that it got inherited 116 | (is (null (logger-appenders one-two-three))) 117 | (is (not (null (effective-appenders one-two-three)))) 118 | (is (equal 2 (length (effective-appenders one-two-three)))) 119 | (is (equal 2 (length (effective-appenders one-two)))) 120 | (is (equal 2 (length (effective-appenders one)))) 121 | ;; now make :one.two non-additive 122 | (setf (logger-additivity one-two) nil) 123 | (is (equal 0 (length (effective-appenders one-two-three)))) 124 | (is (equal 0 (length (effective-appenders one-two)))) 125 | (is (equal 2 (length (effective-appenders one)))) 126 | ;; add logger to one-two 127 | (add-appender one-two (make-instance 'console-appender)) 128 | (is (equal 1 (length (effective-appenders one-two-three)))) 129 | (is (equal 1 (length (effective-appenders one-two)))) 130 | (add-appender one-two (make-instance 'console-appender)) 131 | (is (equal 2 (length (effective-appenders one-two-three)))) 132 | (setf (logger-additivity one-two) t) 133 | (is (equal 4 (length (effective-appenders one-two-three))))))) 134 | 135 | (deftest inherit-log-levels () 136 | "Test log level inheritance" 137 | (with-package-log-hierarchy 138 | (clear-logging-configuration) 139 | (let ((logger (make-logger :one.two.three)) 140 | (parent (make-logger :one))) 141 | ;; verify no logging 142 | (is (eql +log-level-off+ (effective-log-level logger))) 143 | (is (null (log-warn))) 144 | (is (null (log-warn :logger logger))) 145 | ;; now set root log level to info, and verify that 146 | ;; the levels are right 147 | (setf (logger-log-level parent) :info) 148 | (is (null (logger-log-level logger))) 149 | (is (eql +log-level-info+ (effective-log-level logger))) 150 | ;; debugging is still off because of no appenders 151 | (is (null (log-debug :logger logger))) 152 | (is (null (log-warn :logger logger))) 153 | ;; add appender, verify debugging is now on 154 | (add-appender parent (make-instance 'console-appender)) 155 | (is (log-warn :logger logger)) 156 | (is (null (log-debug :logger logger))) 157 | ;; turn debug on on :one.two.three logger 158 | (setf (logger-log-level logger) :debug) 159 | ;; verify the level 160 | (is (eql +log-level-debug+ (logger-log-level logger))) 161 | (is (eql +log-level-debug+ (effective-log-level logger))) 162 | ;; verify both debug and info are on for logger 163 | (is (log-debug :logger logger)) 164 | (is (log-warn :logger logger)) 165 | ;; verify only info is on for root logger 166 | (is (null (log-debug :one))) 167 | (is (log-warn :one)) 168 | ;; and same for logger parent 169 | (is (null (log-debug :one.two))) 170 | (is (log-warn :one.two)) 171 | ;; set root logger off, verify that explicit setting on logger 172 | ;; is still in effect 173 | (setf (logger-log-level parent) :off) 174 | (is (null (log-debug))) 175 | (is (null (log-warn))) 176 | (is (log-debug :logger logger)) 177 | (is (log-warn :logger logger)) 178 | (values logger parent)))) 179 | 180 | (deftest make-logger-with-dotted-symbol-name () 181 | (with-package-log-hierarchy 182 | (let ((logger (make-logger :one.two.three))) 183 | (log4cl-test::basics logger) 184 | (is (equal (logger-category logger) 185 | (concatenate 'string 186 | (package-name #.*package*) 187 | "." 188 | (symbol-name :one.two.three))))))) 189 | 190 | 191 | -------------------------------------------------------------------------------- /tests/test-compat.lisp: -------------------------------------------------------------------------------- 1 | (log4cl-test:defsubsuite :log4cl-test.compat) 2 | (in-package :log4cl-test.compat) 3 | (log4cl-test:subsuite-start) 4 | 5 | (log:package-options :old-logging-macros t) 6 | 7 | (deftest produces-output-with-explicit-logger () 8 | "Test that log statement with explicit logger produce output" 9 | (with-package-log-hierarchy 10 | (reset-logging-configuration) 11 | (is (equal (with-output-to-string (*debug-io*) 12 | (log-warn (make-logger) "Hello World!")) 13 | "WARN - Hello World! 14 | ")) 15 | (is (equal (with-output-to-string (*debug-io*) 16 | (log-warn '(blah test foobar) "Hello World!")) 17 | "WARN - Hello World! 18 | ")) 19 | (is (equal (with-output-to-string (*debug-io*) 20 | (log-warn :foobar "Hello World!")) 21 | "WARN - Hello World! 22 | ")) 23 | (is (equal (with-output-to-string (*debug-io*) 24 | (log-warn 'foobar "Hello World!")) 25 | "WARN - Hello World! 26 | ")))) 27 | 28 | (deftest logger-by-variable () 29 | "Test logging macros to verify that we can bind logger into a 30 | variable, and that logging macros are correctly handling this 31 | situation" 32 | (with-package-log-hierarchy 33 | (reset-logging-configuration) 34 | (let ((logger (make-logger :foobar))) 35 | (is (log-warn logger))))) 36 | 37 | (defun returns-a-logger () 38 | (let ((logger (make-logger))) 39 | (log-config logger :d) 40 | logger)) 41 | 42 | (deftest logger-by-expression () 43 | "Test logging macros to verify that we can make a function returning 44 | a logger, and that logging macros are correctly handling this 45 | situation" 46 | (with-package-log-hierarchy 47 | (reset-logging-configuration) 48 | (is (equal (with-output-to-string (*debug-io*) 49 | (log-debug (returns-a-logger) "Hello World!")) 50 | "DEBUG - Hello World! 51 | ")))) 52 | 53 | (defun test-runtime-logger-of-wrong-type-helper (&optional arg) 54 | arg) 55 | 56 | (deftest test-runtime-logger-of-wrong-type () 57 | "Test that specifying logger at run time checks its type" 58 | (with-package-log-hierarchy 59 | (clear-logging-configuration) 60 | (log:config :i) 61 | (let ((e (test-runtime-logger-of-wrong-type-helper))) 62 | (signals type-error (log:info e)) 63 | (setq e (test-runtime-logger-of-wrong-type-helper (make-condition 'error))) 64 | (signals type-error (log:info e)))) 65 | (values)) 66 | -------------------------------------------------------------------------------- /tests/test-configurator.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (log4cl-test:defsubsuite #:log4cl-test.configurator) 17 | (in-package #:log4cl-test.configurator) 18 | (log4cl-test:subsuite-start) 19 | 20 | (deftest test-clear-ignores-self-logger () 21 | (with-package-log-hierarchy 22 | (clear-logging-configuration) 23 | (let ((logger log4cl:+self-logger+)) 24 | (is (logger-log-level logger)) 25 | (log-config :clear) 26 | (is (logger-log-level logger)) 27 | (log-config :clear :all) 28 | (is (logger-log-level logger))))) 29 | 30 | (deftest test-clear-ignores-non-additive-logger () 31 | (with-package-log-hierarchy 32 | (clear-logging-configuration) 33 | (let ((logger1 (make-logger :one)) 34 | (logger2 (make-logger :one.two)) 35 | (logger3 (make-logger :one.two.three))) 36 | (add-appender *root-logger* (make-instance 'console-appender)) 37 | (is (equal (logger-parent logger3) logger2)) 38 | (is (equal (logger-parent logger2) logger1)) 39 | (log-config logger1 :debug) 40 | (log-config logger2 :nonadditive :trace) 41 | (is (log-debug :logger logger1)) 42 | (is (not (log-trace :logger logger1))) 43 | ;; no appenders 44 | (is (not (log-warn :logger logger2))) 45 | (is (not (log-warn :logger logger3))) 46 | ;; appears after adding appenders 47 | (add-appender logger2 (make-instance 'console-appender)) 48 | (is (log-trace :logger logger2)) 49 | (is (log-trace :logger logger3)) 50 | (log-config :clear) 51 | ;; disappeared from normal loggers 52 | (is (not (logger-log-level logger1))) 53 | (is (not (log-debug :logger logger1))) 54 | ;; but not from additive 55 | (is (log-trace :logger logger2)) 56 | (is (log-trace :logger logger3)) 57 | (log-config :clear :all) 58 | (is (not (log-warn :logger logger2))) 59 | (is (not (log-warn :logger logger3)))))) 60 | 61 | 62 | (defclass ignore-extra-stuff-parser (property-parser) 63 | ()) 64 | 65 | (defmethod log4cl::parse-property-keyword ((parser ignore-extra-stuff-parser) 66 | keyword 67 | tokens 68 | value) 69 | (declare (ignore parser keyword tokens value))) 70 | 71 | (defclass ignore-extra-stuff-configurator 72 | (property-configurator ignore-extra-stuff-parser) () 73 | (:documentation "Property configurator that ignores lines not starting with log4cl")) 74 | 75 | 76 | (deftest test-property-configurator-whitespace-and-comments () 77 | (with-package-log-hierarchy 78 | (clear-logging-configuration) 79 | (let ((c (make-instance 'ignore-extra-stuff-configurator))) 80 | (finishes (with-input-from-string (s "") (configure c s))) 81 | (finishes 82 | (with-input-from-string 83 | (s " # comment 84 | # 85 | one.two=three 86 | #") 87 | (configure c s))) 88 | (finishes 89 | (with-input-from-string (s " one.two = three") 90 | (configure c s))) 91 | (signals property-parser-error 92 | (with-input-from-string (s "one") (configure c s)))))) 93 | 94 | (deftest test-property-configurator-1 () 95 | (with-package-log-hierarchy 96 | (let ((config (make-instance 'property-configurator))) 97 | ;; repeat two times to verify that configurator can be used 98 | ;; multiple times 99 | (dotimes (cnt 2) 100 | (clear-logging-configuration) 101 | ;; verify (clear-log-configuration) cleared everything 102 | (is (equal (effective-log-level (make-logger)) +log-level-off+)) 103 | (is (equal 0 (length (effective-appenders (make-logger))))) 104 | ;; configure 105 | (with-input-from-string 106 | (s "log4cl:rootlogger=DEBUG, A1 107 | log4cl:appender:A1=console-appender") 108 | (configure 109 | config s)) 110 | ;; see that changes were made 111 | (is (equal (effective-log-level (make-logger)) +log-level-debug+)) 112 | (is (equal 1 (length (effective-appenders (make-logger))))) 113 | (is (typep (first (effective-appenders (make-logger))) 'console-appender)))))) 114 | 115 | (deftest test-property-configurator-whitespace-and-separator () 116 | ;; test using different separator, and that whitespace works 117 | (with-package-log-hierarchy 118 | (let ((config (make-instance 'property-configurator))) 119 | (let ((logger (make-logger '(one two three)))) 120 | (clear-logging-configuration) 121 | ;; verify (clear-log-configuration) cleared everything 122 | (is (equal (effective-log-level logger) +log-level-off+)) 123 | (is (equal 0 (length (effective-appenders logger)))) 124 | ;; parse 125 | (with-input-from-string 126 | (s "separator =. 127 | log4cl.logger.one.two.three = DEBUG, A1 128 | log4cl.appender.A1 = console-appender") 129 | (configure config s)) 130 | ;; see that changes were made 131 | (is (equal (effective-log-level logger) +log-level-debug+)) 132 | (is (equal 1 (length (effective-appenders logger)))))))) 133 | 134 | (deftest test-property-configurator-appender-lower-case () 135 | "Verify that specifying appender name in lower case works" 136 | (with-package-log-hierarchy 137 | (let ((config (make-instance 'property-configurator))) 138 | (let ((logger (make-logger '(one two three)))) 139 | (clear-logging-configuration) 140 | (with-input-from-string 141 | (s " log4cl:logger:one:two:three = DEBUG, a1 142 | log4cl:appender:a1 = console-appender") 143 | (configure config s)) 144 | ;; see that changes were made 145 | (is (equal (effective-log-level logger) +log-level-debug+)) 146 | (is (equal 1 (length (effective-appenders logger)))))))) 147 | 148 | (deftest test-property-configurator-boolean-property () 149 | (with-package-log-hierarchy 150 | (let ((config (make-instance 'property-configurator))) 151 | ;; test giving appender properties works 152 | (dolist (val '("true" "yes" "on" "t")) 153 | (clear-logging-configuration) 154 | (with-input-from-string 155 | (s (format nil "log4cl:logger:log4cl-test = DEBUG, A1 156 | log4cl:appender:A1:immediate-flush = ~a 157 | log4cl:appender:A1 = console-appender" val)) 158 | (configure config s)) 159 | (is (equal (effective-log-level (make-logger)) +log-level-debug+)) 160 | (is (equal 1 (length (effective-appenders (make-logger))))) 161 | (let ((appender (first (effective-appenders (make-logger))))) 162 | (is (equal t (slot-value appender 'log4cl::immediate-flush))))) 163 | (dolist (val '("off" "false" "nil" "")) 164 | (clear-logging-configuration) 165 | (finishes 166 | (with-input-from-string 167 | (s (format nil "log4cl:logger:log4cl-test = DEBUG, A1 168 | log4cl:appender:A1:immediate-flush = ~a 169 | log4cl:appender:A1 = console-appender" val)) 170 | (configure config s))) 171 | (let ((appender (first (effective-appenders (make-logger))))) 172 | (is (equal nil (slot-value appender 'log4cl::immediate-flush)))))))) 173 | 174 | (deftest test-property-configurator-number-property () 175 | (with-package-log-hierarchy 176 | (let ((config (make-instance 'property-configurator))) 177 | ;; test giving appender properties works 178 | (clear-logging-configuration) 179 | (finishes 180 | (with-input-from-string 181 | (s "log4cl:logger:log4cl-test=DEBUG, A1 182 | log4cl:appender:A1:flush-interval=123 183 | log4cl:appender:A1=console-appender") 184 | (configure config s))) 185 | (is (equal (effective-log-level (make-logger)) +log-level-debug+)) 186 | (is (equal 1 (length (effective-appenders (make-logger))))) 187 | (let ((appender (first (effective-appenders (make-logger))))) 188 | (is (equal 123 (slot-value appender 'log4cl::flush-interval))))))) 189 | 190 | (deftest test-property-configurator-errors () 191 | (with-package-log-hierarchy 192 | (let* ((config (make-instance 'property-configurator)) 193 | remembered-error) 194 | (macrolet ((remember-error (&body body) 195 | `(handler-bind ((serious-condition 196 | (lambda (c) 197 | (setq remembered-error c)))) 198 | (setq remembered-error nil) 199 | ,@body))) 200 | ;; Test invalid numeric property 201 | (signals property-parser-error 202 | (remember-error 203 | (with-input-from-string 204 | (s "log4cl:logger:log4cl-test=DEBUG, A1 205 | log4cl:appender:A1:flush-interval=blah 206 | log4cl:appender:A1=console-appender") 207 | (configure config s)))) 208 | ;; Check that it logged error with the right line number 209 | (is (search "line 2" (format nil "~A" remembered-error))) 210 | (clear-logging-configuration) 211 | ;; Test with non-existing property 212 | (signals property-parser-error 213 | (remember-error 214 | (with-input-from-string 215 | (s "log4cl:logger:log4cl-test=DEBUG, A1 216 | log4cl:appender:A1=console-appender 217 | log4cl:appender:A1:non-existent-property=whatever") 218 | (configure config s)))) 219 | ;; Check that it logged error with the right line number 220 | (is (search "line 3" (format nil "~A" remembered-error))) 221 | (clear-logging-configuration) 222 | ;; Test with non-existent appender 223 | (signals property-parser-error 224 | (remember-error 225 | (with-input-from-string 226 | (s "log4cl:logger:log4cl-test=DEBUG, A2 227 | log4cl:appender:A1=console-appender 228 | # comment 229 | log4cl:appender:A1:non-existent-property=whatever") 230 | (configure config s)))) 231 | ;; Check that it logged error with the right line number 232 | (is (search "line 1" (format nil "~A" remembered-error))) 233 | ;; Test with non-existing class 234 | (signals property-parser-error 235 | (remember-error 236 | (with-input-from-string 237 | (s "log4cl:logger:log4cl-test=DEBUG, A1 238 | # comment 239 | log4cl:appender:A1 = no such class 240 | log4cl:appender:A1:non-existent-property=whatever") 241 | (configure config s)))) 242 | ;; Check that it logged error with the right line number 243 | (is (search "line 3" (format nil "~A" remembered-error))))))) 244 | 245 | 246 | (deftest test-property-configurator-with-daily-file-appender () 247 | "A copy of the TEST-DAILY-FILE-APPENDER-1 but with configuration 248 | done via property configurator, rather then directly" 249 | (with-package-log-hierarchy 250 | (clear-logging-configuration) 251 | (let* ((fname-base (merge-pathnames (rand-filename) *tests-dir*)) 252 | (name-format (format nil "~a-%H-%M-%S.log" fname-base)) 253 | (config (make-instance 'property-configurator)) 254 | (logger (make-logger '(blah crap baz)))) 255 | (finishes 256 | (with-input-from-string 257 | (s (format 258 | nil "log4cl:logger:blah:crap:baz=INFO, DAILY 259 | log4cl:appender:DAILY=daily-file-appender 260 | log4cl:appender:DAILY:rollover-check-period=1 261 | log4cl:appender:DAILY:name-format=~a" name-format)) 262 | (configure config s))) 263 | (is (equal 1 (length (logger-appenders logger)))) 264 | (is (log-info :logger logger)) 265 | (log-info :logger logger "Hey") 266 | (let* ((a (first (logger-appenders logger))) 267 | (fname1 (appender-filename a))) 268 | (sleep 1.2) 269 | (log-info :logger logger "Hey again") 270 | (let ((fname2 (appender-filename a))) 271 | (log-sexp fname1 fname2) 272 | (unwind-protect 273 | (progn 274 | (is (not (equal fname1 fname2))) 275 | (with-open-file (s fname1) 276 | (is (equal (read-line s) "INFO - Hey"))) 277 | ;; So we don't have to sleep for auto-flush 278 | (remove-all-appenders logger) 279 | (with-open-file (s fname2) 280 | (is (equal (read-line s) "INFO - Hey again")))) 281 | (ignore-errors (delete-file fname1)) 282 | (ignore-errors (delete-file fname2)))))))) 283 | 284 | (deftest test-property-configurator-with-pattern-layout () 285 | "A copy of previous test, but we add a pattern layout" 286 | (with-package-log-hierarchy 287 | (clear-logging-configuration) 288 | (let* ((fname-base (merge-pathnames (rand-filename) *tests-dir*)) 289 | (name-format (format nil "~a-%H-%M-%S.log" fname-base)) 290 | (config (make-instance 'property-configurator)) 291 | (logger (make-logger '(bar baz)))) 292 | (finishes 293 | (with-input-from-string 294 | (s 295 | (format 296 | nil 297 | "log4cl:logger:bar:baz=DEBUG, DAILY 298 | log4cl:appender:DAILY:layout=pattern-layout 299 | log4cl:appender:DAILY:layout:conversion-pattern=%p %c %m 300 | log4cl:appender:DAILY=daily-file-appender 301 | log4cl:appender:DAILY:rollover-check-period=1 302 | log4cl:appender:DAILY:name-format=~a" name-format)) 303 | (configure config s))) 304 | (is (equal 1 (length (logger-appenders logger)))) 305 | (is (log-debug :logger logger)) 306 | (log-info :logger logger "Hey") 307 | (let* ((a (first (logger-appenders logger))) 308 | (fname1 (appender-filename a))) 309 | (sleep 1.2) 310 | (log-debug :logger logger "Hey again") 311 | (let ((fname2 (appender-filename a))) 312 | (unwind-protect 313 | (progn 314 | (is (not (equal fname1 fname2))) 315 | (with-open-file (s fname1) 316 | (is (equal (read-line s) 317 | (format nil "INFO ~a.~a Hey" 318 | (string 'bar) 319 | (string 'baz))))) 320 | ;; So we don't have to sleep for auto-flush 321 | (remove-all-appenders logger) 322 | (with-open-file (s fname2) 323 | (is (equal (read-line s) 324 | (format nil "DEBUG ~a.~a Hey again" 325 | (string 'bar) 326 | (string 'baz)))))) 327 | (ignore-errors (delete-file fname1)) 328 | (ignore-errors (delete-file fname2)))))))) 329 | 330 | (deftest test-log-config-clear () 331 | "Test that :clear option works" 332 | (with-package-log-hierarchy 333 | (clear-logging-configuration) 334 | (let ((four (make-logger '(one two three clear four))) 335 | (clear (make-logger '(one two three clear))) 336 | (three (make-logger '(one two three))) 337 | (one (make-logger '(one)))) 338 | (add-appender three (make-instance 'console-appender)) 339 | (log-config one :sane) 340 | (log-config one :i) 341 | (is (log-info :logger one)) 342 | (is (log-info :logger four)) 343 | (is (not (log-debug :logger four))) 344 | (log-config three :own) 345 | (is (not (logger-additivity three))) 346 | (log-config clear :d) 347 | (is (log-debug :logger four)) 348 | (is (logger-appenders three)) 349 | (log-config one :i :clear) 350 | (is (logger-appenders three)) 351 | (is (not (log-debug :logger four))) 352 | (log-config one :clear :appenders :all) 353 | (is (null (logger-appenders three)))))) 354 | -------------------------------------------------------------------------------- /tests/test-defs.lisp: -------------------------------------------------------------------------------- 1 | 2 | 3 | (eval-when (:compile-toplevel :execute) 4 | (let ((p (find-package :log4cl-test))) 5 | (when p 6 | (dolist (p2 (package-used-by-list p)) 7 | (unuse-package p p2)) 8 | (delete-package p) 9 | (in-package :cl-user)))) 10 | 11 | (defpackage :log4cl-test 12 | (:use :cl :log4cl-impl :stefil) 13 | (:export 14 | :test :test-speed 15 | :test-pattern-layout 16 | :make-expected 17 | :defsubsuite 18 | :subsuite-start 19 | :rand-filename 20 | :*tests-dir* 21 | :*temp-dir*)) 22 | 23 | (in-package :log4cl-test) 24 | 25 | (eval-when (:compile-toplevel :load-toplevel :execute) 26 | (progn 27 | #+sbcl (declaim (sb-ext:muffle-conditions stefil::test-style-warning)) 28 | (in-root-suite) 29 | (defsuite* test))) 30 | 31 | (defmacro defsubsuite (name) 32 | `(progn 33 | (defpackage ,name 34 | (:use :cl :log4cl :log4cl-test :stefil) 35 | (:shadow #:test) 36 | (:export #:test)) 37 | (in-package ,name))) 38 | 39 | (defmacro subsuite-start () 40 | (let ((name (find-symbol (string '#:test) *package*))) 41 | `(eval-when (:compile-toplevel :load-toplevel :execute) 42 | #+sbcl (declaim (sb-ext:muffle-conditions stefil::test-style-warning)) 43 | (progn 44 | (in-root-suite) 45 | (in-suite log4cl-test:test) 46 | (defsuite* ,name))))) 47 | 48 | (defparameter *file-tests-random-state* (make-random-state t)) 49 | 50 | (defun rand-filename (&optional (num-chars 5)) 51 | (with-output-to-string (s) 52 | (dotimes (cnt num-chars) 53 | (princ (code-char 54 | (+ (char-code #\a) 55 | (random 26 *file-tests-random-state*))) 56 | s)))) 57 | 58 | (defun can-create-file-p (dir) 59 | (when (stringp dir) 60 | (unless (member (elt dir (1- (length dir))) 61 | '(#\\ #\/)) 62 | (setq dir (concatenate 'string dir "/"))) 63 | (setq dir (parse-namestring dir)) 64 | (let ((file (merge-pathnames (rand-filename) dir)) 65 | ok) 66 | (handler-case 67 | (with-open-file (s file :direction :output :if-does-not-exist :create) 68 | (print "test" s) 69 | (setq ok dir))) 70 | (ignore-errors (delete-file file)) 71 | ok))) 72 | 73 | (defparameter *temp-dir* 74 | (or (can-create-file-p "/tmp") 75 | (can-create-file-p (asdf::getenv "TEMP")) 76 | (can-create-file-p (asdf::getenv "TMP")) 77 | (can-create-file-p "."))) 78 | 79 | (defparameter *tests-dir* 80 | (ensure-directories-exist 81 | (merge-pathnames (format nil "~a/" (rand-filename)) 82 | *temp-dir*))) 83 | 84 | (deftest test-pattern-layout (pattern expected-result 85 | &key 86 | (level +log-level-info+) 87 | (logger (make-logger '(one two three))) 88 | (message "message")) 89 | "Output a log message into an appender with a pattern layout with 90 | specified PATTERN and compare its output to EXPECTED-RESULT" 91 | (with-package-log-hierarchy 92 | (clear-logging-configuration) 93 | (let ((output 94 | (with-output-to-string (s) 95 | (add-appender *root-logger* 96 | (make-instance 'fixed-stream-appender 97 | :stream s 98 | :layout (make-instance 'pattern-layout 99 | :conversion-pattern pattern))) 100 | (setf (logger-log-level *root-logger*) level) 101 | ;; TODO need a macro that logs with specified level 102 | (cond 103 | ((eql level +log-level-fatal+) (log-fatal :logger logger "~a" message)) 104 | ((eql level +log-level-error+) (log-error :logger logger "~a" message)) 105 | ((eql level +log-level-warn+) (log-warn :logger logger "~a" message)) 106 | ((eql level +log-level-info+) (log-info :logger logger "~a" message)) 107 | ((eql level +log-level-debug+) (log-debug :logger logger "~a" message)) 108 | ((eql level +log-level-debu1+) (log-debu1 :logger logger "~a" message)) 109 | ((eql level +log-level-debu2+) (log-debu2 :logger logger "~a" message)) 110 | ((eql level +log-level-debu3+) (log-debu3 :logger logger "~a" message)) 111 | ((eql level +log-level-debu4+) (log-debu4 :logger logger "~a" message)) 112 | ((eql level +log-level-trace+) (log-trace :logger logger "~a" message)) 113 | ((eql level +log-level-debu5+) (log-debu5 :logger logger "~a" message)) 114 | ((eql level +log-level-debu6+) (log-debu6 :logger logger "~a" message)) 115 | ((eql level +log-level-debu7+) (log-debu7 :logger logger "~a" message)) 116 | ((eql level +log-level-debu8+) (log-debu8 :logger logger "~a" message)) 117 | ((eql level +log-level-debu9+) (log-debu9 :logger logger "~a" message)))))) 118 | (is (equal output expected-result)))) 119 | (values)) 120 | -------------------------------------------------------------------------------- /tests/test-file-category-2.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package :log4cl-test.file-category) 17 | (in-suite test) 18 | 19 | (deftest test-file-category-5 () 20 | (with-package-log-hierarchy 21 | (clear-logging-configuration) 22 | (is (not (log-debug))) 23 | (is (not (log-warn))) 24 | (let* ((logger-1 (make-logger :one.two.four)) 25 | (logger-2 (logger-parent (logger-parent logger-1)))) 26 | (dolist (logger (list logger-1 logger-2)) 27 | (is (logger-file-logger logger))) 28 | 29 | (is (equal "test-file-category-2.lisp" (logger-file-namestring logger-1))) 30 | (is (equal "test-file-category.lisp" (logger-file-namestring logger-2))) 31 | 32 | (is (not (eq (logger-file-logger logger-1) 33 | (logger-file-logger logger-2)))) 34 | 35 | (log-config *root-logger* :warn :console) 36 | 37 | (is (log-warn logger-1)) 38 | (is (log-warn logger-2)) 39 | 40 | (is (not (log-info logger-1))) 41 | (is (not (log-info logger-2))) 42 | 43 | ;; test that we inherit from file of the leaf logger 44 | (log-config (logger-file-logger logger-2) :info) 45 | 46 | (is (log-info logger-2)) 47 | (is (not (log-info logger-1))) 48 | 49 | ;; configure this file logger to debug, see that logger 50 | ;; instantiated here is inheriting it 51 | (log-config (logger-file-logger logger-1) :debug) 52 | 53 | (is (not (log-debug logger-2))) 54 | (is (log-debug logger-1)) 55 | (is (log-info logger-2)) 56 | 57 | ;; Now make the .one logger :warn, check that this overrides 58 | ;; anything set in the file 59 | 60 | (log-config logger-2 :warn) 61 | 62 | (is (not (log-info logger-1))) 63 | (is (not (log-info logger-2))) 64 | 65 | (is (log-warn logger-1)) 66 | (is (log-warn logger-2)) 67 | 68 | ;; back again 69 | 70 | (log-config logger-2 :unset) 71 | (is (not (log-debug logger-2))) 72 | (is (log-debug logger-1)) 73 | (is (log-info logger-2)) 74 | 75 | ;; unset file loggers, and verify we go back to root 76 | 77 | (log-config (logger-file-logger logger-1) :unset) 78 | (log-config (logger-file-logger logger-2) :unset) 79 | 80 | (is (log-warn logger-1)) 81 | (is (log-warn logger-2)) 82 | 83 | (is (not (log-info logger-1))) 84 | (is (not (log-info logger-2)))))) 85 | -------------------------------------------------------------------------------- /tests/test-file-category.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | 17 | 18 | (log4cl-test:defsubsuite :log4cl-test.file-category) 19 | (in-package :log4cl-test.file-category) 20 | (log4cl-test:subsuite-start) 21 | 22 | ;; (setup-logging) 23 | 24 | (deftest test-file-category-1 () 25 | (with-package-log-hierarchy 26 | (clear-logging-configuration) 27 | (let ((no-file-logger (make-logger '(one two three))) 28 | (has-file-logger (make-logger :foo.bar))) 29 | (is (null (logger-file no-file-logger))) 30 | (is (pathnamep (logger-file has-file-logger))) 31 | (is (equal "test-file-category.lisp" (logger-file-namestring has-file-logger))) 32 | 33 | ;; cross test that %c and %C ignore each other stuff 34 | (test-pattern-layout "%c" (make-expected (list (package-name *package*) :foo.bar) ".") 35 | :logger has-file-logger) 36 | 37 | ;; just the package 38 | (test-pattern-layout "%g" (make-expected (list (package-name *package*)) ".") 39 | :logger has-file-logger) 40 | 41 | ;; everything else but the package 42 | (test-pattern-layout "%C" (make-expected (list :foo.bar) ".") 43 | :logger has-file-logger) 44 | 45 | ;; using : as separator because '(one two three) logger was 46 | ;; instantiated in earlier test with default package config 47 | (test-pattern-layout "%c" (make-expected '(one two three) ".") 48 | :logger no-file-logger) 49 | (test-pattern-layout "%C" (make-expected '(one two three) ".") 50 | :logger no-file-logger) 51 | (test-pattern-layout "%g" "" :logger no-file-logger)))) 52 | 53 | 54 | (deftest test-file-category-3 () 55 | ;; Test %F (file name) pattern 56 | (with-package-log-hierarchy 57 | (clear-logging-configuration) 58 | (let ((logger (make-logger :test-file-category-3))) 59 | (is (pathnamep (logger-file logger))) 60 | (is (equal "test-file-category.lisp" (logger-file-namestring logger))) 61 | 62 | (test-pattern-layout "%c" (make-expected (list (package-name *package*) :test-file-category-3) ".") 63 | :logger logger) 64 | (test-pattern-layout "%F" "test-file-category.lisp" :logger logger)))) 65 | 66 | (deftest test-file-category-4 () 67 | (with-package-log-hierarchy 68 | (clear-logging-configuration) 69 | (is (not (log-debug))) 70 | (is (not (log-warn))) 71 | (let* ((logger-1 (make-logger :one.two.three)) 72 | (logger-2 (make-logger :one))) 73 | (dolist (logger (list logger-1 logger-2)) 74 | (is (logger-file-logger logger)) 75 | (is (equal "test-file-category.lisp" (logger-file-namestring logger)))) 76 | 77 | (is (eq logger-2 (logger-parent (logger-parent logger-1)))) 78 | (is (eq (logger-file-logger logger-1) 79 | (logger-file-logger logger-2))) 80 | 81 | (log-config *root-logger* :warn :console) 82 | (is (log-warn :logger logger-1)) 83 | (is (log-warn :logger logger-2)) 84 | (is (not (log-info :logger logger-1))) 85 | (log-config logger-2 :info) 86 | (is (log-info :logger logger-1)) 87 | (is (log-info :logger logger-2))))) 88 | 89 | 90 | (deftest logger-package-override () 91 | "If a logger is first retrieved via exploit category, ie 92 | \(LOG:LOGGER '(P A)\) it won't have any package info, and %g (package 93 | category) pattern format will print empty string for the logger. 94 | 95 | Test that if later the same logger is referenced from the package P, 96 | for example from (defun P:A () (LOG-DEBUG whatever)), that we store 97 | the package info, even if logger already exist, and did not have one." 98 | 99 | (let* ((name-sym (gensym "SOME-PACKAGE.ONE")) 100 | (logger (eval `(make-logger '(,@(log4cl::split-string (symbol-name name-sym) ".") 101 | one two))))) 102 | (test-pattern-layout "%g" "" :logger logger) 103 | ;; now instantiate it from a package 104 | (let* ((*package* (find-package :keyword)) 105 | (form-string (with-output-to-string (*standard-output*) 106 | (write 107 | `(progn 108 | (in-package ,name-sym) 109 | (make-logger :one.two)) 110 | :readably t))) 111 | (*package* (make-package name-sym)) 112 | (form (read-from-string form-string)) 113 | (logger2 (eval form))) 114 | (is (eq logger logger2)) 115 | (test-pattern-layout "%g" (symbol-name name-sym) 116 | :logger logger)))) 117 | 118 | -------------------------------------------------------------------------------- /tests/test-logger.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | (in-package #:log4cl-test) 16 | 17 | (in-suite test) 18 | 19 | (deftest basics (logger) 20 | "Test some basic facts about the logger structure" 21 | (with-package-log-hierarchy 22 | (is (not (null logger))) 23 | (is (not (null (log4cl::logger-state logger)))) 24 | (is (not (null (logger-category logger)))) 25 | (is (eql (length (log4cl::logger-state logger)) log4cl::*hierarchy-max*)))) 26 | 27 | (deftest make-logger-by-list-of-categories () 28 | "Test MAKE-LOGGER macro with static list of categories" 29 | (with-package-log-hierarchy 30 | (let ((logger (make-logger '(one two three four)))) 31 | (basics logger) 32 | (is (equal (logger-category logger) 33 | (concatenate 'string 34 | (symbol-name 'one) "." 35 | (symbol-name 'two) "." 36 | (symbol-name 'three) "." 37 | (symbol-name 'four)))) 38 | (is (equal (logger-name logger) (symbol-name 'four))) 39 | (is (eql (logger-depth logger) 4))))) 40 | 41 | 42 | (deftest single-name () 43 | "Test the logger name being correct when no separators are found in 44 | the name" 45 | (let ((logger (make-logger '(foobar)))) 46 | (is (equal (logger-category logger) (symbol-name 'foobar))) 47 | (is (equal (logger-name logger) (symbol-name 'foobar))))) 48 | 49 | (deftest reset-configuration-0 () 50 | "Test that CLEAR-LOGGING-CONFIGURATION works and that 51 | RESET-LOGGING-CONFIGURATION reset the logging system to a sane 52 | state. Also tests that different hierarchies do not affect each other 53 | configuration" 54 | ;; verify clear/reset only does so for current configuration (current-indentation) 55 | (with-log-hierarchy ('dummy) 56 | ;; clear deletes everything 57 | (clear-logging-configuration) 58 | (is (not (log-warn))) 59 | (is (null (logger-appenders *root-logger*))) 60 | ;; reset provides sane defaults 61 | (reset-logging-configuration) 62 | (is (log-warn)) 63 | (is (not (log-debug))) 64 | (is (not (null (logger-appenders *root-logger*)))) 65 | ;; do reset and clear in the different hierarchy 66 | (with-package-log-hierarchy 67 | (reset-logging-configuration) 68 | (is (log-warn)) 69 | (is (not (log-debug))) 70 | (clear-logging-configuration) 71 | (is (not (log-warn))) 72 | (is (null (logger-appenders *root-logger*)))) 73 | ;; see that original one is unchanged 74 | (is (log-warn)) 75 | (is (not (log-debug))) 76 | (is (not (null (logger-appenders *root-logger*)))))) 77 | 78 | (deftest produces-output () 79 | "Test that default logging configuration produces correct output" 80 | (with-package-log-hierarchy 81 | (reset-logging-configuration) 82 | (is (equal (with-output-to-string (*debug-io*) 83 | (log-warn "Hello World!")) 84 | "WARN - Hello World! 85 | ")))) 86 | 87 | (deftest produces-output-with-explicit-logger () 88 | "Test that log statement with explicit logger produce output" 89 | (with-package-log-hierarchy 90 | (reset-logging-configuration) 91 | (is (equal (with-output-to-string (*debug-io*) 92 | (log-warn :logger (make-logger) "Hello World!")) 93 | "WARN - Hello World! 94 | ")) 95 | (is (equal (with-output-to-string (*debug-io*) 96 | (log-warn '(blah test foobar) "Hello World!")) 97 | "WARN - Hello World! 98 | ")) 99 | (is (equal (with-output-to-string (*debug-io*) 100 | (log-warn :foobar "Hello World!")) 101 | "WARN - Hello World! 102 | ")) 103 | (is (equal (with-output-to-string (*debug-io*) 104 | (log-warn 'foobar "Hello World!")) 105 | "WARN - Hello World! 106 | ")))) 107 | 108 | (deftest verify-returns-same-logger () 109 | "Test that MAKE-LOGGER returns singleton logger object every time" 110 | (with-package-log-hierarchy 111 | (clear-logging-configuration) 112 | (let* ((logger (make-logger '(one two three)))) 113 | (is (eq logger (make-logger '(one two three)))) 114 | (is (eq logger (make-logger logger))) 115 | (is (not (eq logger *root-logger*))) 116 | (clear-logging-configuration) 117 | (is (eq logger (make-logger '(one two three))))))) 118 | 119 | (deftest logger-by-variable () 120 | "Test logging macros to verify that we can bind logger into a 121 | variable, and that logging macros are correctly handling this 122 | situation" 123 | (with-package-log-hierarchy 124 | (reset-logging-configuration) 125 | (let ((logger (make-logger :foobar))) 126 | (is (log-warn :logger logger))))) 127 | 128 | (defun returns-a-logger () 129 | (let ((logger (make-logger))) 130 | (log-config logger :d) 131 | logger)) 132 | 133 | (deftest logger-by-expression () 134 | "Test logging macros to verify that we can make a function returning 135 | a logger, and that logging macros are correctly handling this 136 | situation" 137 | (with-package-log-hierarchy 138 | (reset-logging-configuration) 139 | (is (equal (with-output-to-string (*debug-io*) 140 | (log-debug :logger 141 | (returns-a-logger) "Hello World!")) 142 | "DEBUG - Hello World! 143 | ")))) 144 | 145 | (defun test-runtime-logger-of-wrong-type-helper (&optional arg) 146 | arg) 147 | 148 | (deftest test-runtime-logger-of-wrong-type () 149 | "Test that specifying logger at run time checks its type" 150 | (with-package-log-hierarchy 151 | (clear-logging-configuration) 152 | (log:config :i) 153 | (let ((e (test-runtime-logger-of-wrong-type-helper))) 154 | ;; tests with NIL 155 | (signals type-error (log:info :logger e)) 156 | ;; tests with condition 157 | (setq e (test-runtime-logger-of-wrong-type-helper (make-condition 'error))) 158 | (signals type-error (log:info :logger e)))) 159 | (values)) 160 | 161 | (deftest should-not-unset-root-logger () 162 | (with-package-log-hierarchy 163 | (clear-logging-configuration) 164 | (log-config *root-logger* :unset) 165 | (is (equal (logger-log-level *root-logger*) +log-level-off+)))) 166 | 167 | 168 | (deftest test-ndc-unbind () 169 | "Unit test for bug where numbers were not printed correctly as NDC" 170 | (unwind-protect 171 | (progn 172 | (with-ndc (1) 173 | (is (equal *ndc-context* 1))) 174 | (is (null (boundp '*ndc-context*))) 175 | ;; sets global value 176 | (setq *ndc-context* 2) 177 | (with-ndc (3) 178 | (is (equal *ndc-context* 3)) 179 | (with-ndc () 180 | (is (null (boundp '*ndc-context*)))) 181 | ;; back to bound 182 | (is (equal *ndc-context* 3))) 183 | ;; See that global value not changed 184 | (is (equal *ndc-context* 2))) 185 | (makunbound '*ndc-context*))) 186 | -------------------------------------------------------------------------------- /tests/test-regressions.lisp: -------------------------------------------------------------------------------- 1 | (log4cl-test:defsubsuite :log4cl-test.regressions) 2 | (log4cl-test:subsuite-start) 3 | 4 | (deftest join-thread-error.issue#1 () 5 | "https://github.com/sharplispers/log4cl/issues/1" 6 | (log4cl:start-hierarchy-watcher-thread) 7 | (finishes (log4cl-impl::save-hook))) 8 | 9 | (deftest recursive-lock.issue#8.1 () 10 | "https://github.com/sharplispers/log4cl/issues/8" 11 | (finishes 12 | (with-simple-restart (abort "Abort") 13 | (handler-bind 14 | ((error (lambda (condition) 15 | (log:error "caught error: ~A" condition) 16 | (abort)))) 17 | (log:warn "~@{~A ~A~}" 1))))) 18 | 19 | (defun logging-function () 20 | (log:warn "I log, too") 21 | :result) 22 | 23 | (deftest recursive-lock.issue#8.2 () 24 | "https://github.com/sharplispers/log4cl/issues/8" 25 | (finishes (log:warn "~A" (logging-function)))) 26 | -------------------------------------------------------------------------------- /tests/test-speed.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- 2 | ;;; 3 | ;;; Copyright (c) 2012, Max Mikhanosha. All rights reserved. 4 | ;;; 5 | ;;; This file is licensed to You under the Apache License, Version 2.0 6 | ;;; (the "License"); you may not use this file except in compliance 7 | ;;; with the License. You may obtain a copy of the License at 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (in-package #:log4cl-test) 17 | 18 | (eval-when (:compile-toplevel :load-toplevel :execute) 19 | (in-root-suite) 20 | (defsuite* test-speed)) 21 | 22 | ;; Logging case, with default optimizations 23 | ;; 24 | ;; (time (log4cl-test::speed-test-to-file :iterations 10000000)) 25 | ;; 26 | ;; Evaluation took: 27 | ;; 27.621 seconds of real time 28 | ;; 27.632799 seconds of total run time (27.606803 user, 0.025996 system) 29 | ;; 100.04% CPU 30 | ;; 37 lambdas converted 31 | ;; 66,169,657,401 processor cycles 32 | ;; 1,981,984 bytes consed 33 | ;; 34 | ;; java test 10000000 8.74s user 15.62s system 101% cpu 24.002 total 35 | ;; 36 | ;; Times with other configurations: 37 | ;; - *print-pretty* NIL (speed 3) (safety 1), 25.5 secs, 1 slower then java 38 | ;; 39 | ;; No logging case (note 10x iterations the logging case) 40 | ;; 41 | ;; (time (log4cl-test::speed-test-to-file :iterations 100000000 42 | ;; :root-logger-level :info)) 43 | ;; 44 | ;; Evaluation took: 45 | ;; 1.099 seconds of real time 46 | ;; 1.097834 seconds of total run time (1.091835 user, 0.005999 system) 47 | ;; 99.91% CPU 48 | ;; 37 lambdas converted 49 | ;; 2,567,753,657 processor cycles 50 | ;; 1,079,664 bytes consed 51 | ;; 52 | ;; java -Droot.level=INFO test 100000000 15.07s user 0.85s system 101% cpu 15.757 total 53 | ;; 54 | 55 | (deftest speed-test-to-file (&key (filespec "/dev/null") 56 | (external-format :default) 57 | (layout (make-instance 'simple-layout)) 58 | (iterations 1000000) 59 | (root-logger-level :debug)) 60 | (with-package-log-hierarchy 61 | (with-open-file (stream filespec :direction :output 62 | :if-exists :supersede 63 | :external-format external-format) 64 | (clear-logging-configuration) 65 | (add-appender *root-logger* (make-instance 'fixed-stream-appender 66 | :layout layout 67 | :stream stream 68 | :immediate-flush nil 69 | :flush-interval nil)) 70 | (setf (logger-log-level *root-logger*) root-logger-level) 71 | (dotimes (cnt iterations) 72 | (log-debug :log4cl-test.category "iter=~d" cnt))))) 73 | -------------------------------------------------------------------------------- /tests/test.java: -------------------------------------------------------------------------------- 1 | // Copyright (c) 2012, Max Mikhanosha. All rights reserved. 2 | // 3 | // This file is licensed to You under the Apache License, Version 2.0 4 | // (the "License"); you may not use this file except in compliance 5 | // with the License. You may obtain a copy of the License at 6 | // http://www.apache.org/licenses/LICENSE-2.0 7 | // 8 | // Unless required by applicable law or agreed to in writing, software 9 | // distributed under the License is distributed on an "AS IS" BASIS, 10 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | // See the License for the specific language governing permissions and 12 | // limitations under the License. 13 | 14 | // 15 | // Used to test log4j vs log4cl speed 16 | // 17 | 18 | import org.apache.log4j.*; 19 | 20 | public class test 21 | { 22 | public static void main(String args[]) 23 | { 24 | System.out.println("Hello there"); 25 | PropertyConfigurator.configure("log4j.properties"); 26 | int limit = 1; 27 | 28 | if (args.length > 0) 29 | limit = Integer.valueOf(args[0]).intValue(); 30 | 31 | final Category log = Category.getInstance("cat1.logger"); 32 | 33 | for (int i = 0; i < limit; i++) 34 | log.debug("iter=" + i); 35 | } 36 | } 37 | --------------------------------------------------------------------------------