;;;
;;; logger.scm - simple use-level logging
;;;  
;;;   Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
;;;   
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;   
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;  
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;  
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;  
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;  
;;;  $Id: logger.scm,v 1.8 2005/08/22 21:07:57 shirok Exp $
;;;

(define-module gauche.logger
  (use srfi-1)
  (use srfi-13)
  (use gauche.fcntl)
  (use gauche.parameter)
  (export <log-drain>
          log-open
          log-format
          log-default-drain)
  )
(select-module gauche.logger)

;; delay loading some modules until needed
(autoload gauche.syslog sys-openlog sys-syslog LOG_PID LOG_INFO LOG_USER)
(autoload file.util file-mtime<?)

;; Kludge! determine the default lock policy heuristically.
;; AFAIK, MacOSX didn't support fcntl lock until 10.3.
(define (default-lock-policy)
  (if (#/apple-darwin[56]/ (gauche-architecture)) 'file 'fcntl))

;; <log-drain> class
(define-class <log-drain> ()
  ((path   :init-keyword :path :initform #f)
   (program-name :init-keyword :program-name
                 :initform  (sys-basename (with-module user *program-name*)))
   (retry  :init-keyword :retry :initform 5)
   (prefix :init-keyword :prefix :initform "~T ~P[~$]: ")
   (lock-policy :init-keyword :lock-policy :initform (default-lock-policy))
   ;; The following parameters are used for syslog.
   ;; The default values will be set when log-open is called with 'syslog.
   (syslog-option   :init-keyword :syslog-option)
   (syslog-facility :init-keyword :syslog-facility)
   (syslog-priority :init-keyword :syslog-priority)
   ))

(define log-default-drain
  (make-parameter (make <log-drain>)))

(define-method initialize ((self <log-drain>) initargs)
  (next-method)
  ;; if 'syslog is specified, we need some setup...
  (when (eq? (slot-ref self 'path) 'syslog)
    (unless (slot-bound? self 'syslog-option)
      (set! (slot-ref self 'syslog-option) LOG_PID))
    (unless (slot-bound? self 'syslog-facility)
      (set! (slot-ref self 'syslog-facility) LOG_USER))
    (unless (slot-bound? self 'syslog-priority)
      (set! (slot-ref self 'syslog-priority) LOG_INFO))
    (set! (slot-ref self 'prefix) #f)
    (sys-openlog (slot-ref self 'program-name)
                 (slot-ref self 'syslog-option)
                 (slot-ref self 'syslog-facility))
    ))

;; prefix spec
;;   ~T   current time as "MMM DD hh:mm:ss" where MMM is abbrev month.
;;   ~Y   4-digit year
;;   ~P   program name
;;   ~$   pid
;;   ~U   user name
;;   ~H   host name

(define (log-format-prefix drain pstr)
  (with-string-io pstr
    (lambda ()
      (let loop ((c (read-char)))
        (cond ((eof-object? c))
              ((char=? c #\~ )
               (let ((c1 (read-char)))
                 (cond ((eof-object? c1) (display c))
                       ((char=? c1 #\P)
                        (display (slot-ref drain 'program-name))
                        (loop (read-char)))
                       ((char=? c1 #\T)
                        ;; NB: I used to use (sys-strftime "%b %e %H:%M:%S"), but
                        ;; not all implementations supports %e, which is like
                        ;; %d (day of the month) but suppressing the leading
                        ;; zeros.  It is necessary to match syslog date format.
                        (let1 t (sys-localtime (sys-time))
                          (format #t "~a ~2d ~2,'0d:~2,'0d:~2,'0d"
                                  (sys-strftime "%b" t)
                                  (slot-ref t 'mday)
                                  (slot-ref t 'hour)
                                  (slot-ref t 'min)
                                  (slot-ref t 'sec)))
                        (loop (read-char)))
                       ((char=? c1 #\Y)
                        (display (sys-strftime "%Y" (sys-localtime (sys-time))))
                        (loop (read-char)))
                       ((char=? c1 #\$)
                        (display (sys-getpid))
                        (loop (read-char)))
                       ((char=? c1 #\U)
                        (display (or (sys-uid->user-name (sys-geteuid))
                                     (sys-geteuid)))
                        (loop (read-char)))
                       ((char=? c1 #\H)
                        (display (sys-gethostname))
                        (loop (read-char)))
                       (else
                        (display c) (display c1) (loop (read-char))))))
              (else (display c) (loop (read-char))))
        ))))

(define (log-get-prefix drain)
  (let ((pstr (slot-ref drain 'prefix)))
    (cond ((string? pstr) (log-format-prefix drain pstr))
          ((not pstr) "")
          (else (pstr drain)))))

;; File lock handling
;;   Only called if the drain is file and successfully opened.

(define-constant FILE_LOCK_TIMEOUT 600)

(define (lock-data drain port)
  (case (slot-ref drain 'lock-policy)
    ((fcntl) (make <sys-flock> :type |F_WRLCK| :whence 0))
    ((file)  (string-append (slot-ref drain 'path) ".lock"))
    (else    #t)))

(define (lock-file drain port data)
  (case (slot-ref drain 'lock-policy)
    ((fcntl) (sys-fcntl port |F_SETLKW| data))
    ((file)
     (let loop ((retry 0)
                (o (open-output-file data :if-exists #f)))
       (cond (o (close-output-port o) #t)
             ((> retry (slot-ref drain 'retry))
              (errorf "couldn't obtain lock with ~a (retry limit reached)"
                      data))
             ((file-mtime<? data (- (sys-time) FILE_LOCK_TIMEOUT))
              ;; maybe the lock file is stale.
              (sys-unlink data)
              (loop 0 (open-output-file data :if-exists #f)))
             (else
              (sys-sleep 1)
              (loop (+ retry 1) (open-output-file data :if-exists #f))))))
    (else #t)))

(define (unlock-file drain port data)
  (case (slot-ref drain 'lock-policy)
    ((fcntl)
     (slot-set! data 'type |F_UNLCK|)
     (sys-fcntl port |F_SETLK| data))
    ((file)
     (sys-unlink data))
    (else #t)))

;; Write log
(define (with-log-output drain proc)
  (let ((path (slot-ref drain 'path)))
    (cond ((string? path)
           (let* ((p (open-output-file path :if-exists :append))
                  (l (lock-data drain p)))
             (dynamic-wind
              (lambda () (lock-file drain p l))
              (lambda () (proc p))
              (lambda () (unlock-file drain p l) (close-output-port p)))))
          ((eq? path #t)
           (proc (current-error-port)))
          ((eq? path #f)
           (call-with-output-string proc))
          ((eq? path 'syslog)
           (sys-syslog (logior (slot-ref drain 'syslog-facility)
                               (slot-ref drain 'syslog-priority))
                       (call-with-output-string proc)))
          (else
           #f))))

;; External APIs
;; log-format "fmtstr" arg ...
;; log-format drain "fmtstr" arg ...

(define-method log-format ((fmtstr <string>) . args)
  (apply log-format (log-default-drain) fmtstr args))

(define-method log-format ((drain <log-drain>) fmt . args)
  (let* ((prefix (log-get-prefix drain))
         (str (string-concatenate
               (fold-right
                (lambda (data rest)
                  (if (and (null? rest) (string-null? data))
                      '()          ;ignore trailing newlines
                      (list* prefix data "\n" rest)))
                '()
                (string-split (apply format #f fmt args) #\newline)))))
    (with-log-output drain (lambda (p) (display str p)))))

;; log-open path &keyword :program-name :prefix

(define (log-open path . args)
  (log-default-drain (apply make <log-drain> :path path args)))

(provide "gauche/logger")
