; FILE AUTOMATICALLY GENERATED!
;
; This file was automatically generated by the svnwiki-scheme-library extension.
; The authoritative source for this is:
;
;   http://wiki.freaks-unidos.net/weblogs/azul/simple-logging
;
; Generation data:
;
;   Input revision: 17005
;   User: www-data
;   Machine: mononykus.freaks-unidos.net
;   Date: Wed Jul  7 23:18:14 2010

(module simple-logging ((logging logging-proc) with-logging get-logging-dir (log-fatal logging-proc) (log-error logging-proc) (log-warning logging-proc) (log-info logging-proc) (log-debug logging-proc))


(import scheme chicken)
(use posix extras srfi-1 data-structures format-compiler)

(define *logging-directory* #f)

(define *severities* #f)

(define *logging-program-name* #f)

(define *logs-to-keep* #f)

(define *log-size* #f)

(define *log-files* #f)

(define-record log-file file version length path)

(define (with-logging program-name thunk)
  (initialize-global-state program-name)
  (let ((result (thunk)))
    (close-all-open-logs)
    result))

(define getenv get-environment-variable)

(define (initialize-global-state program-name)
  (cond
    ((equal? (getenv "LOG_DIR") "")
     (set! *logging-directory* #f))
    (else
     (set! *severities*
       `((fatal #t)
         (error #t)
         (warning #t)
         (info #t)
         (debug ,(getenv "LOG_DEBUG"))))
     (set! *logging-directory*
       (format #f "~A/log-~A-~A-~A"
         (get-logging-dir)
         (or (getenv "LOG_PROGRAM") program-name)
         (current-seconds)
         (current-process-id)))
     (set! *logs-to-keep* (string->number (or (getenv "LOG_COLLECT") "2")))
     (set! *log-size* (string->number (or (getenv "LOG_SIZE") "1048576")))
     (set! *log-files* '()))))

(define (close-all-open-logs)
  (when *logging-directory*
    (for-each (compose close-output-port log-file-file cadr) *log-files*)))

(define (get-logging-dir)
  (or (getenv "LOG_DIR")
      (getenv "TMPDIR")
      (getenv "TEMP")
      (getenv "TMP")
      "/tmp"))

(define (open-log-file severity file)
  (assert *logging-directory*)
  (condition-case (create-directory *logging-directory*) (e (exn) #f))
  (when (and file (log-file-file file))
    (close-output-port (log-file-file file))
    (when (and (positive? *logs-to-keep*)
               (>= (log-file-version file) *logs-to-keep*))
      (condition-case (delete-file (log-file-path file)) (e (exn) #f))))
  (let* ((version (if file (+ (log-file-version file) 1) 0))
         (path (format #f "~A/~A-~A-~A"
                       *logging-directory*
                       severity
                       version
                       (current-seconds))))
    (make-log-file (open-output-file path) 0 version path)))

(define (logging-with-severity severity str)
  (assert *logging-directory*)
  (let ((file (assoc severity *log-files*)))
    (define (get-new-length)
      (+ (log-file-length (cadr file))
         (string-length str)
         (string-length "\n")))
    (cond
      ((not file)
       (set! file `(,severity ,(open-log-file severity #f)))
       (set! *log-files* (cons file *log-files*)))
      ((> (get-new-length) *log-size*)
       (set-car! (cdr file) (open-log-file severity (cadr file)))))
    (assert file)
    (assert (log-file? (cadr file)))
    (assert (port? (log-file-file (cadr file))))
    (write-line str (log-file-file (cadr file)))
    (log-file-length-set! (cadr file) (get-new-length))))

(define (log-call position severity proc fmt . args)
  (if *logging-directory*
    (let* ((id (gensym)) (str (format #f " ~A ~?" id fmt args)))
      (log-str position severity ">~A" str)
      (let ((result (proc)))
        (log-str position severity "<~A" str)
        result))
    (proc)))

(define (log-str position severity fmt . args)
  (when *logging-directory*
    (let ((str (format #f
                       "~A: ~A: ~A: ~A: ~?"
                       severity
                       (or position "[unknown]")
                       (seconds->string (current-seconds))
                       (current-process-id)
                       fmt
                       args))
          (severities (find-tail (lambda (s) (eq? (car s) severity))
                                 *severities*)))
      (cond
        (severities
         (for-each
           (lambda (s)
             (when (cadr s)
               (logging-with-severity (car s) str)))
           severities))
        ((assoc 'warning *severities*)
         (log-str position 'warning "Invalid logging severity: ~A: ~?" severity fmt args))))))

(define (logging-proc position severity fmt . args)
  (let ((result (apply (if (procedure? fmt) log-call log-str)
                       position severity fmt args)))
    (when (eq? severity 'fatal)
      (exit 1))
    result))

(define-syntax (logging x r c)
  (cons* (r 'logging-proc) (get-line-number x) (cdr x)))

(define-syntax (log-fatal x r c) (cons* (r 'logging-proc) (get-line-number x) ''fatal (cdr x)))
(define-syntax (log-error x r c) (cons* (r 'logging-proc) (get-line-number x) ''error (cdr x)))
(define-syntax (log-warning x r c) (cons* (r 'logging-proc) (get-line-number x) ''warning (cdr x)))
(define-syntax (log-info x r c) (cons* (r 'logging-proc) (get-line-number x) ''info (cdr x)))
(define-syntax (log-debug x r c) (cons* (r 'logging-proc) (get-line-number x) ''debug (cdr x)))

) ; end of module definition