;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; log4scm-mzgtk2
;;;
;;; Author            : Hans Oesterholt-Dijkema
;;; License           : LGPL
;;; Short Description : This module provides a GUI for viewing and
;;;                     configuring log4scm log files.
;;;
;;; $Id: log4scm-mzgtk2.scm,v 1.9 2007/04/30 17:34:16 HansOesterholt Exp $
;;;
;;; $Log: log4scm-mzgtk2.scm,v $
;;; Revision 1.9  2007/04/30 17:34:16  HansOesterholt
;;; *** empty log message ***
;;;
;;; Revision 1.8  2007/04/30 17:22:51  HansOesterholt
;;; *** empty log message ***
;;;
;;; Revision 1.7  2006/09/22 19:07:08  HansOesterholt
;;; no message
;;;
;;; Revision 1.6  2006/01/09 00:29:05  HansOesterholt
;;; no message
;;;
;;; Revision 1.5  2006/01/05 20:30:38  HansOesterholt
;;; Adaptation to planet requires
;;;
;;; Revision 1.4  2005/12/16 07:23:18  HansOesterholt
;;; array changed
;;;
;;; Revision 1.3  2005/11/22 19:53:01  HansOesterholt
;;; no message
;;;
;;; Revision 1.2  2005/11/13 19:44:10  HansOesterholt
;;; - Bug fixing.
;;; - Making things more consistent.
;;; - Adding the log4scm-viewer application
;;; - Making things start as a real windows application.
;;;
;;; Revision 1.1  2005/11/13 16:02:58  HansOesterholt
;;; - Add log configuration class
;;; - Add log reader class
;;; - Add mzgtk2 component for viewing and configuring log files
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module log4scm-mzgtk2 mzscheme
	(require (lib "mzgtk2.scm"   "mzgtk2"))
	(require (planet "roos.scm" ("oesterholt" "roos.plt" 1 0)))
	(require (planet "sprefs.scm" ("oesterholt" "ho-utils.plt" 1 0)))
	(require (planet "internat.scm" ("oesterholt" "internat.plt" 1 0)))
	(require (planet "sutil.scm" ("oesterholt" "ho-utils.plt" 1 0)))
	(require (planet "units.scm" ("oesterholt" "ho-utils.plt" 1 0)))
	(require (planet "array.scm" ("oesterholt" "datastructs.plt" 1 0)))
	(require "log4scm-cfg.scm")
	(require "log4scm-reader.scm")
	(require "log4scm.scm")
	(provide log4scm-mzgtk2)


;;; log view

(def-class
  (this (listview-log-files current-log-files callback-view-file))
  (supers (gtk-list-model))
  (private
   (define log-files    (vector))
   )
  (public

   (define (refresh)
     (set! log-files (vector))    ;; If you are going to refresh, always clear
                                  ;; the tree/list first.
     (-> supers refresh)
     (set! log-files (apply vector (current-log-files)))
     (-> supers refresh))

   (define (get-#columns)          1)
   (define (get-#rows)             (vector-length log-files))
   (define (get-columnn-type col)  "string")
   (define (get-value row col)     (vector-ref log-files row))

   (define widget                  #f)
   )
  (constructor
   (let* ((column    (gtk-tree-view-column 'title      (_ "log file")
					   'renderer   (gtk-cell-renderer-text)
					   'column     0
					   'model      this
					   'resizable  #t
					   'clickable  #t))

	  (treeview  (gtk-tree-view        'model this
				           'widgets (list column)))

	  (scrolledw (gtk-scrolled-window  'widgets treeview
					   'policy  '(never always)))

	  (frame     (gtk-frame      'widgets scrolledw)))

     (-> treeview connect "row-activated" (lambda (widget treepath column)
					    (mzgtk2-alive-gobjects)
					    (callback-view-file (vector-ref log-files (car treepath)))))
     (-> treeview set-size-request 200 150)
     (-> this  destroy-with-view)
     (set! widget frame)
     (refresh))
   )
  )


(def-class 
  (this (log4scm-mzgtk2 add-menu add-view change-label))
  (supers (gtk-list-model))
  (private
   (define reader #f)
   (define opened #f)
   (define cfg    (log4scm-cfg "untitled.scfg"))

   (define cell-timestamp   (gtk-cell-renderer-text))
   (define cell-level       (gtk-cell-renderer-text))
   (define cell-message     (gtk-cell-renderer-text))

   (define label-keep       (gtk-label 'label           (_ "Keep days : ") 
				       'expand          #f))
   (define entry-keep       (gtk-spin-button 'range     (-> (-> cfg keep-range-in-days) range)
					     'value     (-> cfg keep)
					     'expand      #f))


   (define label-level      (gtk-label 'label           (_ "Minimum log level : ") 
				       'expand          #f))
   (define combo-level      (gtk-combo-box 'items       (map (lambda (obj) (-> obj level))
							     (-> cfg configurable-minimum-log-levels))
					   'default     (-> cfg level)
					   'expand      #f))

   (define label-mode       (gtk-label 'label           (_ "Log mode : ")
				                        'expand #f))
   (define combo-mode       (gtk-combo-box 'items       (map (lambda (obj) (-> obj mode))
							     (-> cfg configurable-log-modes))
					   'default     (-> cfg mode)
					   'expand      #f))

   (define check-tail-mode  (gtk-check-button 'label     (_ "_Tail mode")
					      'closure   (lambda (w)
							   (-> cfg tail-mode (-> check-tail-mode check))
							   (-> this go-to-tail-if-tail-mode))
					      'init      (-> cfg tail-mode)
					      'expand    #f))

   (define menu-recent      (gtk-menu-recently-used-files (lambda max
							    (meta-apply sprefs-cond-set!-get '(log recent max) 4 max))
							  (lambda files
							    (meta-apply sprefs-cond-set!-get '(log recent files) (list) files))
							  'label (_ "_Recently used")
							  'closure (lambda (filename) (open filename))))

   (define log-files       (listview-log-files (lambda () (-> cfg current-log-files)) (lambda (file) (view file))))

   (define block-view      #f)

   (define log-view          #f)  ; Needs construction (depends on this)
   (define log-view-filename (gtk-label 'label ""
					'expand #f))
   (define log-view-filesize (gtk-label 'label ""
					'expand #f))
   (define log-view-num-of-lines (gtk-label 'label ""
					    'expand #f))

   (define log-progress   (gtk-progress-bar 'expand #f))
   (define current-perc   -1)

   (define log-file-array (array))
   (define log-file-lines 0)
   (define log-loading    #f)

   (define timer-id       #f)
   (define kill-timer     #f)

   )
  (public

   ; Handling opening filenames etc.

   (define (open cfg-filename)

     (set! cfg (log4scm-cfg cfg-filename))
     (-> combo-level       activate (-> cfg level))
     (-> combo-mode        activate (-> cfg mode))
     (-> entry-keep        set      (-> cfg keep))
     (-> check-tail-mode   set      (-> cfg tail-mode))

     (sprefs-set! '(log last-directory) (basedir cfg-filename))
     (sprefs-set! '(log recent files) 
		  (cons cfg-filename (sprefs-get '(log recent files) '())))
     (-> menu-recent refresh)
     (-> log-files   refresh)
     (set! opened #t)

     (change-label (basename cfg-filename))
     #t)

   (define (save cfg-filename)
     (-> cfg keep    (-> entry-keep get))
     (-> cfg level   (-> combo-level activated))
     (-> cfg mode    (-> combo-mode activated))
     (-> cfg commit cfg-filename)
     (sprefs-set! 'last-directory (basedir cfg-filename))
     (sprefs-set! '(log recent files) 
		  (cons cfg-filename (sprefs-get '(log recent files) '())))
     (-> menu-recent refresh)
     (log-info (format "log file configuration has been committed to ~a" cfg-filename))

     (change-label (basename cfg-filename))
     )

   (define (go-to-tail-if-tail-mode)
     (if (not block-view)
	 (if (-> cfg tail-mode)
	     (if (> log-file-lines 0)
		 (begin
		   (-> log-view scroll-to-cell (- log-file-lines 1))
		   (-> log-view set-cursor     (- log-file-lines 1))
		   (-> log-view process-pending-events))))))

   ;;; Tricky! (how do read-more, timed-read-more and kill-timed-read-more interact?).
   (define (read-more)
     (log-debug "start read-more")

     (let ((read-any (-> reader read)))

       (if log-loading
	   (begin
	     (log-debug "refreshing...")
	     (-> this refresh)
	     (log-debug "refreshed")))

       (if read-any
	   (begin
	     (-> log-view-filename label (-> reader name))
	     (-> log-view-filesize label (unit-convert->rounded->string 
					  (-> reader size) 'b '(kb mb gb tb) 2))
	     (-> log-view-num-of-lines label (number->string log-file-lines))
	     (-> this go-to-tail-if-tail-mode)))

       (-> log-view process-pending-events)
       (log-debug "end of read-more")
       ))


   (define (timed-read-more)
     (log-debug "start of timed-read-more")
     (if (not kill-timer)
	 (read-more))
     (if (not kill-timer)
	 (set! timer-id (mzgtk2-timer-add 1000 timed-read-more)))
     (log-debug "end of timed-read-more")
     #f)

   (define (kill-timed-read-more)
     (set! kill-timer #t)
     (if timer-id (mzgtk2-timer-remove timer-id))
     (set! kill-timer #f))

   ; callbacks for gtk-tree-model

   (define (get-#columns)
     3)

   (define (get-#rows)
     (array-length log-file-array))

   (define (get-value row col)
     (let ((A (array-ref log-file-array row)))
       (if (= col 0)
	   (let ((colour (-> cfg color (array-ref A 1))))
	     (for-each (lambda (c)
			 (-> c foreground colour))
		       (list cell-timestamp cell-level cell-message))))
       (array-ref A col)))

   (define (get-column-type col)
     "string")

   ; callbacks from log4scm-reader

   (define (add-line obj)
     (array-set! log-file-array log-file-lines (array (-> obj timestamp)
						      (-> obj level)
						      (-> obj message)))
     (if (not log-loading)
	 (-> this row-inserted log-file-lines))
     (++ log-file-lines)
     #t)

   (define (progress percentage)
     (if (not (= percentage current-perc))
	 (begin
	   (set! current-perc percentage)
	   (-> log-progress fraction (/ (exact->inexact percentage) 100.0))
	   (-> log-progress label (format "~a%" percentage))
	   (-> log-progress process-pending-events)))
     #t)

   ; Callbacks for the gui

   (define (view log-filename)
     (if (not block-view)
	 (begin

	   (log-info (format "Opening log file ~a" log-filename))

	   (set! block-view #t)

	   (kill-timed-read-more)
	   
	   ;; clear the view array and refresh the model view, otherwise it will break
	   (set! log-file-array (array))
	   (set! log-file-lines 0)
	   (-> this refresh)

	   ;; close the file of the current reader
	   (if reader (-> reader close))

	   ;; refill the view arra
	   (set! reader (log4scm-reader cfg this))
	   (-> reader log-file log-filename)
	   (set! log-loading #t)
	   (read-more)
	   (set! log-loading #f)

	   (timed-read-more)
	   (set! block-view #f)
	   (-> this go-to-tail-if-tail-mode))
	 (log-warn (format "A log file is currently loading, view request for ~a ignored" 
			   log-filename)))
     #t)

   (define (open-log-cfg parent)
     (let ((dlg (gtk-file-chooser-dialog 'parent         parent
					 'title          (_ "Open log configuration file")
					 'filters        (list 
						          (gtk-file-filter 'filter-name (_ "Scheme Configuration File")
									   'patterns (list "*.scfg")))
					 'action         'open
					 'current-folder (sprefs-get '(log last-directory) "."))))
       (let ((result (-> dlg run)))
	 (if (eq? result 'open)
	     (open (-> dlg filename)))
	 (-> dlg destroy))))



   (define (save-log-cfg parent prev-opened)
     (if (eq? prev-opened #f)
	 (let ((dlg (gtk-file-chooser-dialog 'parent         parent
					     'title          (_ "Save log configuration file")
					     'filters        (list
							      (gtk-file-filter 'filter-name (_ "Scheme Configuration File")
									       'patterns (list "*.scfg")))
					     'action 'save)))
	   
	   (-> dlg current-name (-> cfg filename))
	   (if opened (-> dlg filename (-> cfg filename)))
	   (let ((result (-> dlg run)))
	     (if (eq? result 'save)
		 (save (-> dlg filename)))
	     (-> dlg destroy)))
	 (save (-> cfg filename))))

   (define (change-colors parent)

     (let ((my-parent #f))

       (define (change-color parent level)
	 (log-debug (format "Parent: ~a" (-> parent name)))
	 (log-debug "change-color")
	 (let* ((colour (-> cfg color level))
		(dlg (gtk-color-selection-dialog 'parent parent
						 'color  (gdk-color colour))))
	   (log-debug "run change-color")
	   (if (eq? (-> dlg run) 'ok)
	       (-> cfg color level (-> (-> dlg color) ->string)))
	   (-> dlg destroy)))
       
       (define (color-handler obj)
	 (let* ((level  (-> obj level))
		(label  (-> obj label))
		(lentry  (gtk-label  'label    (_ label) 
				     'expand   #f))
		(entry   (gtk-entry  'text     (_ label)
				     'readonly #t)))
					;'expand   #f)))
	   (-> entry modify-text 'normal (gdk-color (-> cfg color level)))
	   (-> entry width-chars (inexact->exact (/ (string-length label) 2.0)))
	   (log-debug (format "label-length: ~a (request ~a) (~a) ~%" (string-length label) (-> entry width-chars) label))
	   (list 
	    (gtk-button 'label (symbol->string level)
			'closure (lambda (w)
				   (change-color my-parent level)
				   (-> entry modify-text 'normal (gdk-color (-> cfg color level))))
			'expand #f)
	    entry)))
       
       (let* (
;	      (widgets (apply append (map color-handler (-> cfg configurable-log-levels))))
;	      (table   (gtk-table 'rows (length (-> cfg configurable-log-levels))
;				  'columns 2
;				  'widgets widgets))
	      (sizegroup      (gtk-size-group 'mode 'vertical))
	      (vbox-labels    (gtk-vbox 'expand #f))
	      (vbox-entries   (gtk-vbox))
	      (hbox           (gtk-hbox 'widgets (list vbox-labels vbox-entries)))
	      (dlg            (gtk-dialog 'name    'color-dialog
					  'title   (_ "LOG Colors")
					  'parent  parent
					  'buttons (list (list 'ok (lambda () 'ok)))
					;				   'widgets table)))
					  'widgets hbox)))
	 (for-each (lambda (obj)
		     (apply (lambda (label entry)
			      (-> sizegroup add label)
			      (-> vbox-labels add label)
			      (-> sizegroup add entry)
			      (-> vbox-entries add entry))
			    (color-handler obj)))
		   (-> cfg configurable-log-levels))
	 (log-debug (format "Parent: ~a" (-> parent name)))
	 (set! my-parent dlg)
	 (-> dlg run)
	 (-> dlg destroy)
       
	 #t)))

   ; Create the gui

   (define (create-gui)
     (set! log-view (gtk-tree-view 'model this
				   'widgets (let ((col 0))
					      (map
					       (lambda (l)
						 (gtk-tree-view-column 'title     (_ (car l))
						                       'column    (post++ col)
								       'renderer  (cadr l)
								       'model     this
								       'resizable #t
								       'clickable #f))
					       (list 
						(list "Timestamp" cell-timestamp)
						(list "Level"     cell-level)
						(list "Message"   cell-message))))))

     (let* ((table        (gtk-table 'rows 4 'columns 2
				     'widgets (list
					       label-keep  entry-keep
					       label-level combo-level
					       label-mode  combo-mode
					       check-tail-mode ;(gtk-label 'label "") check-tail-mode
					       )
				     'expand #f))
	    (hbox         (gtk-expander 'expanded #t
					'label (_ "Log configuration")
					'widgets (gtk-frame 'widgets
							    (list
							     (gtk-table 'rows    1
									'columns 2
									'widgets (list table (-> log-files widget))
									'expand  #f)))
					'expand #f))
	    (log-info     (gtk-frame 'widgets (gtk-hbox 'widgets (list
								  (gtk-frame 'widgets
									     (gtk-hbox 'widgets (list
												 (gtk-label 'label (_ "Filename : ") 'expand #f)
												 log-view-filename)))
								  (gtk-frame 'widgets
									     (gtk-hbox 'widgets (list
												 (gtk-label 'label (_ "Filesize : ") 'expand #f)
												 log-view-filesize)))
								  (gtk-frame 'widgets
									     (gtk-hbox 'widgets (list
												 (gtk-label 'label (_ "Lines : ") 'expand #f)
												 log-view-num-of-lines)))))
				     'expand #f))
	    (s-log-view   (gtk-scrolled-window 'widgets log-view))
	    (vbox         (gtk-vbox  'widgets (list hbox log-info s-log-view log-progress)))
	    (pane         vbox)

	    (menu  (gtk-menu-submenu 'name 'log-menu
				     'label (_ "_Log server")
				     'entries (list 
					       (gtk-menu-label 'name 'open
							       'label (_ "_Open")
							       'closure open-log-cfg)
					       (gtk-menu-label 'name 'save
							       'label (_ "_Save")
							       'closure (lambda (parent)
									  (save-log-cfg parent opened))
							       'accelerator (gtk-accelerator "<Ctrl>s" '(log4scm log save) (lambda (parent) #t)))
															     ;(save-log-cfg parent opened))))
					       (gtk-menu-label 'name 'save-as
							       'label (_ "Save _As")
							       'closure (lambda (parent)
									  (save-log-cfg parent #f)))
					       (gtk-menu-label 'name 'colors
							       'label (_ "_Colors")
							       'closure change-colors)
					       (gtk-menu-separator)
					       menu-recent))))

       (-> log-view search-column 2)
       (-> this destroy-with-view)
       (-> pane associate-destroy-handler 
	   (lambda () 
	     (kill-timed-read-more)))

       (add-menu menu)
       (add-view pane)))
     
   )
  (constructor
   (create-gui)
   )
  )

)