[noctool-cvs] CVS source

[imattsson]

Update of /project/noctool/cvsroot/source
In directory clnet:/tmp/cvs-serv25149

Modified Files:
	packages.lisp config.lisp 
Log Message:
IM

Added support for C-style format strings to cluster and also made C-style
format the default.

Added support for "cluster configuration" (touches both config.lisp and
packages.lisp, since it needs to be exported to be seen in the scrap package).


--- /project/noctool/cvsroot/source/packages.lisp	2008/05/18 10:59:57	1.3
+++ /project/noctool/cvsroot/source/packages.lisp	2008/05/29 07:21:12	1.4
@@ -24,7 +24,7 @@
   (:nicknames #:noctool-config)
   (:use #:net.hexapodia.noctool #:cl)
   (:shadow #:load)
-  (:export #:ping #:load #:machine #:user #:ip #:ssh-port #:disk #:disks #:disk-ignore))
+  (:export #:cluster #:ping #:load #:machine #:user #:ip #:ssh-port #:disk #:disks #:disk-ignore))
 
 (defpackage #:net.hexapodia.noctool-network
   (:use #:net.hexapodia.noctool #:cl #:usocket)
--- /project/noctool/cvsroot/source/config.lisp	2008/05/22 06:07:17	1.6
+++ /project/noctool/cvsroot/source/config.lisp	2008/05/29 07:21:12	1.7
@@ -25,6 +25,34 @@
     (push sym *loaded-configurations*)
     sym))
 
+(defun get-config-symbol (name)
+  (let ((scrap (find-package *scrap-package-name*)))
+    (or (find-symbol (string name) scrap)
+	(intern (string name) scrap))))
+
+(defun translate-format (c-fmt)
+  "Translate C format strings, we are primarily concerned with %d and %0nd and %%"
+  (flet ((sub (str start end repl)
+	   (format nil "~a~a~a" (subseq str 0 start) repl (subseq str end)))
+	 (emit (n)
+	   (loop for x from 1 to n
+		 do (format t " "))
+	   (format t "^~%")))
+    (let ((rv (copy-seq c-fmt)))
+      (loop for start = 0 then (1+ pos)
+	    for pos = (position #\% rv :start start :test #'char=)
+	    while pos
+	    do (cond ((char= (char rv (1+ pos)) #\0)
+		      (let ((fmt-end (position #\d rv :test #'char=)))
+			(let ((width (parse-integer rv :start (1+ pos) :end fmt-end)))
+			  (setf rv (sub rv pos (1+ fmt-end) (format nil "~~~d,'0d" width))))))
+		     ((char= (char rv (1+ pos)) #\%)
+		      (setf rv (sub rv pos (+ 2 pos) "%")))
+		     ((char= (char rv (1+ pos)) #\d)
+		      (setf rv (sub rv pos (+ 2 pos) "~d")))
+		     (t (format t "Unknown format control~%~a~%" rv)
+			(emit pos))))
+      rv)))
 
 (defmacro expand-config-stanza (&rest body)
   "Macro-expand a configuration snippet. Intended solely as a debug aid."
@@ -115,7 +143,17 @@
   (export (list mon-class))
   `(defnested ,mon-class (&rest options) :machine
      `(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
+			   (translate-format fmt)
+			   fmt)) 
+	(name (or name
+		  (get-config-symbol "NAME"))))
+    `(progn
+      ,@(loop for n from low to high
+	      for realname = (format nil format-string n)
+	      collect (substitute realname name form)))))
 
 (defun load (file)
   (let ((load-package (bodge-package)))