1 #! /usr/bin/cl-launch -X --
4 (cl:defpackage #:ansible-inventory
7 (in-package #:ansible-inventory)
9 (declaim (optimize debug))
11 ;;;--------------------------------------------------------------------------
12 ;;; General utilities.
14 (defun compose (&rest funcs)
16 (lambda (&rest args) (multiple-value-call g (apply f args))))
17 funcs :initial-value #'values))
19 ;;;--------------------------------------------------------------------------
22 (defvar *print-json-comma*)
24 (defun print-json-itemstart ()
25 (cond (*print-json-comma*
27 (pprint-newline :linear))
29 (setf *print-json-comma* t))))
31 (defun print-json-map* (thunk)
32 (print-json-itemstart)
34 (pprint-indent :block 2)
35 (pprint-newline :linear)
36 (pprint-logical-block (*standard-output* nil)
37 (let ((*print-json-comma* nil)) (funcall thunk)))
39 (pprint-indent :block 0)
40 (pprint-newline :linear)
43 (defmacro print-json-map (&body body)
44 `(print-json-map* (lambda () ,@body)))
46 (defun print-json-list* (thunk)
47 (print-json-itemstart)
49 (pprint-indent :block 2)
50 (pprint-newline :linear)
51 (pprint-logical-block (*standard-output* nil)
52 (let ((*print-json-comma* nil)) (funcall thunk)))
53 (pprint-indent :block 0)
54 (pprint-newline :linear)
57 (defmacro print-json-list (&body body)
58 `(print-json-list* (lambda () ,@body)))
60 (defun print-json-mapping* (label thunk)
61 (print-json-itemstart)
62 (pprint-logical-block (*standard-output* nil)
63 (let ((*print-json-comma* nil))
64 (print-json-simple label))
66 (pprint-newline :miser)
67 (let ((*print-json-comma* nil))
70 (defmacro print-json-mapping (label &body body)
71 `(print-json-mapping* ,label (lambda () ,@body)))
73 (defun print-json-simple (value)
75 ((and vector (not string))
77 (dotimes (i (length value)) (print-json-simple (aref value i)))))
83 (print-json-mapping (car i)
84 (print-json-simple (cdr i))))))
87 (maphash (lambda (k v)
89 (print-json-simple v)))
92 (print-json-itemstart)
94 (integer (format t "~A" value))
95 (float (format t "~G" value))
96 (rational (format t "~G" (float value 0.0d0)))
97 (string (format t "~S" value))
98 ((eql t) (princ "true"))
99 ((eql nil) (princ "false"))
100 ((eql :undefined) (princ "undefined"))
101 (symbol (format t "~S" (string-downcase value)))))))
103 (defun print-json* (thunk)
104 (let ((*print-json-comma* nil))
105 (pprint-logical-block (*standard-output* nil)
109 (defmacro print-json (&body body)
110 `(print-json* (lambda () ,@body)))
112 ;;;--------------------------------------------------------------------------
113 ;;; Host definitions.
115 (defvar *hosts* (make-hash-table))
118 (defun addhost (name alist)
119 (setf (gethash name *hosts*) alist))
122 (defmacro defhost (name &body alist)
123 `(progn (addhost ',name ',alist) ',name))
126 (defun host-plist (name)
127 (multiple-value-bind (plist foundp) (gethash name *hosts*)
128 (unless foundp (error "Host ~S not found" name))
132 (defun hostprop (name prop &optional default)
133 (multiple-value-bind (found-name value tail)
134 (get-properties (host-plist name) (list prop))
135 (declare (ignore found-name))
138 (values default nil))))
139 (defun (setf hostprop) (value name prop &optional default)
140 (declare (ignore default))
141 (let ((plist (host-plist name)))
142 (multiple-value-bind (found-name found-value tail)
143 (get-properties plist (list prop))
144 (declare (ignore found-name found-value))
146 (setf (cadr tail) value)
147 (setf (gethash name *hosts*)
148 (cons prop (cons value plist))))
151 (export 'hostprop-default)
152 (defun hostprop-default (host prop value)
153 (multiple-value-bind (found-value foundp) (hostprop host prop)
154 (declare (ignore found-value))
155 (unless foundp (setf (hostprop host prop) value))))
158 (defun hostpropp (host prop)
159 (multiple-value-bind (value foundp) (hostprop host prop)
160 (declare (ignore value))
164 (defun maphosts (func)
165 (maphash (lambda (name plist)
166 (declare (ignore plist))
171 (defmacro dohosts ((hostvar &optional valueform) &body body)
172 `(block nil (maphosts (lambda (,hostvar) ,@body)) ,valueform))
174 ;;;--------------------------------------------------------------------------
175 ;;; Group definitions.
177 (defvar *groups* nil)
180 (defun add-group (name type func)
181 (let* ((found (assoc name *groups*))
186 (when (funcall func host) (push host list)))))
190 (setf (cdr found) list)
191 (push (cons name list) *groups*))))
194 (defmacro defgroup (name type args &body body)
195 `(progn (add-group ',name ,type
198 (destructuring-bind (hostvar) args
199 `(lambda (,hostvar) ,@body)))
201 (destructuring-bind () args
202 `(lambda () ,@body)))))
205 ;;;--------------------------------------------------------------------------
206 ;;; Post-processing hooks.
208 (defstruct hook-entry
212 (export '(prio-props prio-groups))
213 (defconstant prio-props 10)
214 (defconstant prio-groups 20)
216 (defvar *hostproc-hooks* nil)
219 (defun addhook (prio func)
220 (push (make-hook-entry :prio prio :func func) *hostproc-hooks*))
223 (defmacro defhook ((prio) &body body)
224 `(addhook ,prio (lambda () ,@body)))
226 ;;;--------------------------------------------------------------------------
227 ;;; Read the input file and hook definitions.
230 #.(or *compile-file-pathname* *load-pathname*))
232 (defvar *user-package*
233 (make-package "ANSIBLE-INVENTORY-USER"
234 :use '("CL" "ANSIBLE-INVENTORY")))
236 (defun load-input (file)
237 (let ((*package* *user-package*))
238 (load file :verbose nil)))
240 (defun parse-command-line (args)
241 (loop (let* ((arg (pop args))
243 (cond ((string= arg "--") (return))
244 ((string= arg "-") (push arg args) (return))
245 ((and (plusp (length arg))
246 (char= (char arg 0) #\-))
250 (cond ((< (1+ i) len)
251 (prog1 (subseq arg (1+ i))
256 (error "missing argument")))))
258 (#\h (format t "usage: ~A FILE ...~%"
259 (pathname-name *progname*)))
260 (t (error "unknown option `-~A'" (char arg i)))))))
261 (t (push arg args) (return)))))
262 (mapc #'load-input args))
264 ;;;--------------------------------------------------------------------------
268 (setf *hostproc-hooks* (sort *hostproc-hooks* #'< :key #'hook-entry-prio))
269 (mapc (compose #'hook-entry-func #'funcall) *hostproc-hooks*))
271 ;;;--------------------------------------------------------------------------
272 ;;; Output the definitions.
275 (let ((*print-right-margin* 77))
278 (print-json-mapping "all"
279 (print-json-list (maphosts #'print-json-simple)))
280 (dolist (assoc *groups*)
281 (print-json-mapping (car assoc)
283 (mapc #'print-json-simple (cdr assoc)))))
284 (print-json-mapping "_meta"
286 (print-json-mapping "hostvars"
288 (maphash (lambda (host plist)
289 (print-json-mapping host
291 (do ((plist plist (cddr plist)))
293 (print-json-mapping (car plist)
294 (print-json-simple (cadr plist)))))))
297 ;;;--------------------------------------------------------------------------
302 (parse-command-line cl-launch:*arguments*)
306 ;;;----- That's all, folks --------------------------------------------------