[noctool-cvs] CVS source
jprewett
jprewett at common-lisp.net
Mon Dec 8 20:53:50 UTC 2008
Update of /project/noctool/cvsroot/source
In directory cl-net:/tmp/cvs-serv5171
Modified Files:
config.lisp generics.lisp scheduler.lisp tests.lisp web.lisp
Log Message:
made various config objects set their PARENT slot
made "multiple after methods" work for web UI
--- /project/noctool/cvsroot/source/config.lisp 2008/12/03 16:42:28 1.11
+++ /project/noctool/cvsroot/source/config.lisp 2008/12/08 20:53:50 1.12
@@ -107,7 +107,7 @@
(defnested disks (&rest diskspec)
:machine
(let ((*macro-nesting* (cons :disk *macro-nesting*)))
- `(let ((*disk-container* (car (noctool::make-monitor 'noctool::disk-container ,*config-object* :parent ,*config-object*))))
+ `(let ((*disk-container* (car (noctool::make-monitor 'noctool::disk-container ,*config-object*))))
,@(mapcar #'macroexpand diskspec))))
(defnested disk (path disk-percent &optional (inodes-percent 90))
@@ -143,16 +143,16 @@
(interval 60))
:machine
(list max-rtt max-fail interval ping-count)
- `(noctool::make-monitor 'ping-monitor ,*config-object* :parent ,*config-object* , at args))
+ `(noctool::make-monitor 'ping-monitor ,*config-object* , at args))
(defnested load-monitor (&optional (low-water 1.0) (high-water 5.0))
:machine
- `(noctool::make-monitor 'load-monitor ,*config-object* :low-water ,low-water :high-water ,high-water :parent ,*config-object*))
+ `(noctool::make-monitor 'load-monitor ,*config-object* :low-water ,low-water :high-water ,high-water))
(defmacro defmon (mon-class)
(export (list mon-class))
`(defnested ,mon-class (&rest options) :machine
- `(noctool::make-monitor ',',mon-class ,*config-object* :parent ,*config-object* , at options)))
+ `(noctool::make-monitor ',',mon-class ,*config-object* , at options)))
(defmacro cluster ((fmt low high &optional (name nil) (c-fmt t)) form)
(let ((format-string (if c-fmt
--- /project/noctool/cvsroot/source/generics.lisp 2008/03/17 08:27:58 1.1.1.1
+++ /project/noctool/cvsroot/source/generics.lisp 2008/12/08 20:53:50 1.2
@@ -2,7 +2,7 @@
(defun make-monitor (type kit &rest options)
- (let ((monitor (apply 'make-instance type :equipment kit options)))
+ (let ((monitor (apply 'make-instance type :equipment kit :parent kit options)))
(push monitor (monitors kit))))
(defun class-list-class (class)
--- /project/noctool/cvsroot/source/scheduler.lisp 2008/12/03 12:28:01 1.14
+++ /project/noctool/cvsroot/source/scheduler.lisp 2008/12/08 20:53:50 1.15
@@ -4,7 +4,7 @@
(defvar *network-updates-needed* nil)
(defvar *total-processes*
- #+darwin 1
+ #+darwin 8
#-darwin 32)
(defvar *process-semaphore* (sb-thread:make-semaphore :name "Simultaneous processes" :count *total-processes*))
--- /project/noctool/cvsroot/source/tests.lisp 2008/12/03 14:58:53 1.12
+++ /project/noctool/cvsroot/source/tests.lisp 2008/12/08 20:53:50 1.13
@@ -3,9 +3,9 @@
;; OK, this is *awesome* programming form, but...
(defmacro without-errors (error-form &body body)
`(handler-case , at body
- (t (c) (progn
- (warn "ignoring condition: ~A" c)
- ,error-form))))
+ (t (c) (progn
+ (warn "ignoring condition: ~A" c)
+ ,error-form))))
(defmethod process :around ((monitor monitor))
(unwind-protect
--- /project/noctool/cvsroot/source/web.lisp 2008/12/03 16:42:28 1.4
+++ /project/noctool/cvsroot/source/web.lisp 2008/12/08 20:53:50 1.5
@@ -44,8 +44,7 @@
(defmacro defensure (name widget-form hash &body body)
`(defmacro ,name (instance )
(with-gensyms ((val "VAL")
- (foundp "FOUNDP")
- (the-widget-form "WIDGET-FORM"))
+ (foundp "FOUNDP"))
` (multiple-value-bind (,val ,foundp)
(gethash ,instance ,,hash)
(if ,foundp
@@ -79,6 +78,54 @@
(defvar *load-5-hash* (make-hash-table))
(defvar *load-10-hash* (make-hash-table))
+(defvar *method-hash* (make-hash-table :test #'equal))
+
+(defmacro get-method-actions (method instance)
+ (let ((i instance))
+ `(gethash (list ,method ,i) *method-hash*)))
+
+(defmacro add-method-actions (method instance action)
+ `(setf (get-method-actions ',method ,instance)
+ (append
+ (get-method-actions ',method ,instance)
+ (list ,action))))
+
+(defmacro method-after-method (method instance (&rest args))
+ (let ((actions (gensym))
+ (action (gensym)))
+ `(defmethod ,method :after (, at args)
+ (let ((,actions (get-method-actions ',method ,instance)))
+ (mapcar
+ (lambda (,action)
+ (funcall ,action ,@(mapcan (lambda (x)
+ (cond ((listp x)
+ (list (car x)))
+ ((eql x '&optional)
+ ())
+ (t (list x))))
+ args)))
+ ,actions)))))
+
+(defmacro defaftermethod (method instance widget-form (&rest lambda-list) &body body)
+ (let ((func (gensym))
+ (actions (gensym))
+ (action (gensym))
+ (reduced-lambda-list (gensym)))
+ `(let* ((instance ,instance)
+ (widget ,widget-form)
+ (,func #'(lambda (,@(mapcan (lambda (x)
+ (cond ((listp x)
+ (list (car x)))
+ ((eql x '&optional)
+ ())
+ (t (list x))))
+ lambda-list))
+ , at body)))
+ ;; set up the after method
+ (method-after-method ,method ,instance ,lambda-list)
+ ;; add this func to the list
+ (add-method-actions ,method ,instance ,func))))
+
(defmacro ensure-load (name graph-slot hash)
(with-gensyms ((graph "GRAPH") (span "SPAN"))
`(defensure ,name
@@ -92,8 +139,8 @@
:css-class (alert-class (noctool::alert-level instance)))))
,span)
,hash
- (defmethod noctool::add-value
- :after ((graph (eql (slot-value instance ',graph-slot))) value)
+ (defaftermethod noctool::add-value instance widget
+ ((graph (eql (slot-value instance ',graph-slot))) value)
(setf (html-of widget)
(format NIL
"~2$"
@@ -123,9 +170,10 @@
(add-to widget load (mk-span " ") load-1 (mk-span " ") load-5 (mk-span " ") load-10))))
(defensure ensure-monitor-widget (make-instance 'monitor :monitor instance :css-class (alert-class (noctool::alert-level instance))) *monitor-hash*
- (defmethod (setf noctool::alert-level) :after (new (instance (eql instance)))
- (setf (css-class-of widget)
- (alert-class (noctool::alert-level instance)))))
+ (let ((i instance))
+ (defaftermethod (setf noctool::alert-level) instance widget (new (instance (eql instance)))
+ (setf (css-class-of widget)
+ (alert-class (noctool::alert-level instance))))))
(defmacro print-last-updated (instance)
`(handler-case (sb-int:format-universal-time NIL (noctool::last-updated ,instance))
@@ -135,7 +183,7 @@
(mk-span (print-last-updated instance)
:css-class (alert-class (noctool::alert-level instance)))
*last-updated-hash*
- (defmethod (setf noctool::last-updated) :after (new (instance (eql instance)))
+ (defaftermethod (setf noctool::last-updated) instance widget (new (instance (eql instance)))
(setf (html-of widget)
(sb-int:format-universal-time NIL new))
(setf (css-class-of widget)
@@ -145,7 +193,7 @@
(mk-span (format NIL "~A" (noctool::alert-level instance))
:css-class (alert-class (noctool::alert-level instance)))
*alert-level-hash*
- (defmethod (setf noctool::alert-level) :after (new (instance (eql instance)))
+ (defaftermethod (setf noctool::alert-level) instance widget (new (instance (eql instance)))
(setf (html-of widget)
(format NIL "~A" (noctool::alert-level instance)))
(setf (css-class-of widget)
@@ -157,7 +205,7 @@
(sb-int:format-universal-time NIL next-time)
"None!") :css-class (alert-class (noctool::alert-level instance))))
*next-run-hash*
- (defmethod noctool-scheduler::schedule :after ((object (eql instance)) time &optional scheduler)
+ (defaftermethod noctool-scheduler::schedule instance widget ((object (eql instance)) time &optional scheduler)
(setf (html-of widget)
(sb-int:format-universal-time NIL time))
(setf (css-class-of widget)
@@ -171,7 +219,7 @@
(mod (1- idx) 300))))
:css-class (alert-class (noctool::alert-level instance)))
*last-rtt-hash*
- (defmethod noctool::add-value :after ((graph (eql (noctool::graph instance))) value)
+ (defaftermethod noctool::add-value instance widget ((graph (eql (noctool::graph instance))) value)
(setf (html-of widget)
(format NIL "~A seconds"
(aref (noctool-graphs::short
@@ -186,7 +234,7 @@
(noctool::failed instance))
:css-class (alert-class (noctool::alert-level instance)))
*last-failed-hash*
- (defmethod (setf noctool::failed) :after (new (instance (eql instance)))
+ (defaftermethod (setf noctool::failed) instance widget (new (instance (eql instance)))
(setf (html-of widget)
(format NIL "~A" new))
(setf (css-class-of widget)
@@ -198,7 +246,7 @@
(noctool::over-rtt instance))
:css-class (alert-class (noctool::alert-level instance)))
*last-over-rtt-hash*
- (defmethod (setf noctool::over-rtt) :after (new (instance (eql instance)))
+ (defaftermethod (setf noctool::over-rtt) instance widget (new (instance (eql instance)))
(setf (html-of widget)
(format NIL "~A" new))
(setf (css-class-of widget)
@@ -214,8 +262,8 @@
:noc-host instance
:css-class (alert-class (noctool::alert-level instance)))
*noc-host-hash*
- (defmethod (setf noctool::alert-level)
- :after (new-val (host (eql instance)))
+ (defaftermethod (setf noctool::alert-level)
+ instance widget (new-val (host (eql instance)))
(setf (css-class-of widget)
(alert-class (noctool::alert-level instance)))))
@@ -224,8 +272,8 @@
(setf (css-class-of widget) (alert-class (noctool::alert-level instance)))
widget)
*disk-widget-hash*
- (defmethod (setf noctool::alert-level)
- :after (new-val (host (eql instance)))
+ (defaftermethod (setf noctool::alert-level)
+ instance widget (new-val (host (eql instance)))
(setf (css-class-of widget)
(alert-class (noctool::alert-level instance)))))
More information about the noctool-cvs
mailing list