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 (list (print-json-list (dolist (i value) (print-json-simple i))))
76 (hash-table (print-json-map (maphash (lambda (k v)
78 (print-json-simple v)))
81 (print-json-itemstart)
83 (integer (format t "~A" value))
84 (float (format t "~G" value))
85 (rational (format t "~G" (float value 0.0d0)))
86 (string (format t "~S" value))
87 ((eql t) (princ "true"))
88 ((eql nil) (princ "false"))
89 ((eql :undefined) (princ "undefined"))
90 (symbol (format t "~S" (string-downcase value)))))))
92 (defun print-json* (thunk)
93 (let ((*print-json-comma* nil))
94 (pprint-logical-block (*standard-output* nil)
98 (defmacro print-json (&body body)
99 `(print-json* (lambda () ,@body)))
101 ;;;--------------------------------------------------------------------------
102 ;;; Host definitions.
104 (defvar *hosts* (make-hash-table))
107 (defun addhost (name alist)
108 (setf (gethash name *hosts*) alist))
111 (defmacro defhost (name &body alist)
112 `(progn (addhost ',name ',alist) ',name))
115 (defun host-plist (name)
116 (multiple-value-bind (plist foundp) (gethash name *hosts*)
117 (unless foundp (error "Host ~S not found" name))
121 (defun hostprop (name prop &optional default)
122 (multiple-value-bind (found-name value tail)
123 (get-properties (host-plist name) (list prop))
124 (declare (ignore found-name))
127 (values default nil))))
128 (defun (setf hostprop) (value name prop &optional default)
129 (declare (ignore default))
130 (let ((plist (host-plist name)))
131 (multiple-value-bind (found-name found-value tail)
132 (get-properties plist (list prop))
133 (declare (ignore found-name found-value))
135 (setf (cadr tail) value)
136 (setf (gethash name *hosts*)
137 (cons prop (cons value plist))))
140 (export 'hostprop-default)
141 (defun hostprop-default (host prop value)
142 (multiple-value-bind (found-value foundp) (hostprop host prop)
143 (declare (ignore found-value))
144 (unless foundp (setf (hostprop host prop) value))))
147 (defun hostpropp (host prop)
148 (multiple-value-bind (value foundp) (hostprop host prop)
149 (declare (ignore value))
153 (defun maphosts (func)
154 (maphash (lambda (name plist)
155 (declare (ignore plist))
160 (defmacro dohosts ((hostvar &optional valueform) &body body)
161 `(block nil (maphosts (lambda (,hostvar) ,@body)) ,valueform))
163 ;;;--------------------------------------------------------------------------
164 ;;; Group definitions.
166 (defvar *groups* nil)
169 (defun add-group (name type func)
170 (let* ((found (assoc name *groups*))
175 (when (funcall func host) (push host list)))))
179 (setf (cdr found) list)
180 (push (cons name list) *groups*))))
183 (defmacro defgroup (name type args &body body)
184 `(progn (add-group ',name ,type
187 (destructuring-bind (hostvar) args
188 `(lambda (,hostvar) ,@body)))
190 (destructuring-bind () args
191 `(lambda () ,@body)))))
194 ;;;--------------------------------------------------------------------------
195 ;;; Post-processing hooks.
197 (defstruct hook-entry
201 (export '(prio-props prio-groups))
202 (defconstant prio-props 10)
203 (defconstant prio-groups 20)
205 (defvar *hostproc-hooks* nil)
208 (defun addhook (prio func)
209 (push (make-hook-entry :prio prio :func func) *hostproc-hooks*))
212 (defmacro defhook ((prio) &body body)
213 `(addhook ,prio (lambda () ,@body)))
215 ;;;--------------------------------------------------------------------------
216 ;;; Read the input file and hook definitions.
219 #.(or *compile-file-pathname* *load-pathname*))
221 (defvar *user-package*
222 (make-package "ANSIBLE-INVENTORY-USER"
223 :use '("CL" "ANSIBLE-INVENTORY")))
225 (defun load-input (file)
226 (let ((*package* *user-package*))
227 (load file :verbose nil)))
229 (defun parse-command-line (args)
230 (loop (let* ((arg (pop args))
232 (cond ((string= arg "--") (return))
233 ((string= arg "-") (push arg args) (return))
234 ((and (plusp (length arg))
235 (char= (char arg 0) #\-))
239 (cond ((< (1+ i) len)
240 (prog1 (subseq arg (1+ i))
245 (error "missing argument")))))
247 (#\h (format t "usage: ~A FILE ...~%"
248 (pathname-name *progname*)))
249 (t (error "unknown option `-~A'" (char arg i)))))))
250 (t (push arg args) (return)))))
251 (mapc #'load-input args))
253 ;;;--------------------------------------------------------------------------
257 (setf *hostproc-hooks* (sort *hostproc-hooks* #'< :key #'hook-entry-prio))
258 (mapc (compose #'hook-entry-func #'funcall) *hostproc-hooks*))
260 ;;;--------------------------------------------------------------------------
261 ;;; Output the definitions.
264 (let ((*print-right-margin* 77))
267 (print-json-mapping "all"
268 (print-json-list (maphosts #'print-json-simple)))
269 (dolist (assoc *groups*)
270 (print-json-mapping (car assoc)
272 (mapc #'print-json-simple (cdr assoc)))))
273 (print-json-mapping "_meta"
275 (print-json-mapping "hostvars"
277 (maphash (lambda (host plist)
278 (print-json-mapping host
280 (do ((plist plist (cddr plist)))
282 (print-json-mapping (car plist)
283 (print-json-simple (cadr plist)))))))
286 ;;;--------------------------------------------------------------------------
291 (parse-command-line cl-launch:*arguments*)
295 ;;;----- That's all, folks --------------------------------------------------