1 #! /usr/bin/cl-launch -X --
4 (cl:defpackage #:ansible-inventory
6 (:import-from #:cl-launch #:*arguments*))
8 (in-package #:ansible-inventory)
10 (declaim (optimize debug))
12 ;;;--------------------------------------------------------------------------
13 ;;; General utilities.
15 (defun compose (&rest funcs)
17 (lambda (&rest args) (multiple-value-call g (apply f args))))
18 funcs :initial-value #'values))
20 ;;;--------------------------------------------------------------------------
23 (defvar *print-json-comma*)
25 (defun print-json-itemstart ()
26 (cond (*print-json-comma*
28 (pprint-newline :linear))
30 (setf *print-json-comma* t))))
32 (defun print-json-map* (thunk)
33 (print-json-itemstart)
35 (pprint-indent :block 2)
36 (pprint-newline :linear)
37 (pprint-logical-block (*standard-output* nil)
38 (let ((*print-json-comma* nil)) (funcall thunk)))
40 (pprint-indent :block 0)
41 (pprint-newline :linear)
44 (defmacro print-json-map (&body body)
45 `(print-json-map* (lambda () ,@body)))
47 (defun print-json-list* (thunk)
48 (print-json-itemstart)
50 (pprint-indent :block 2)
51 (pprint-newline :linear)
52 (pprint-logical-block (*standard-output* nil)
53 (let ((*print-json-comma* nil)) (funcall thunk)))
54 (pprint-indent :block 0)
55 (pprint-newline :linear)
58 (defmacro print-json-list (&body body)
59 `(print-json-list* (lambda () ,@body)))
61 (defun print-json-mapping* (label thunk)
62 (print-json-itemstart)
63 (pprint-logical-block (*standard-output* nil)
64 (let ((*print-json-comma* nil))
65 (print-json-simple label))
67 (pprint-newline :miser)
68 (let ((*print-json-comma* nil))
71 (defmacro print-json-mapping (label &body body)
72 `(print-json-mapping* ,label (lambda () ,@body)))
74 (defun print-json-simple (value)
76 (list (print-json-list (dolist (i value) (print-json-simple i))))
77 (hash-table (print-json-map (maphash (lambda (k v)
79 (print-json-simple v)))
82 (print-json-itemstart)
84 (integer (format t "~A" value))
85 (float (format t "~G" value))
86 (rational (format t "~G" (float value 0.0d0)))
87 (string (format t "~S" value))
88 ((eql t) (princ "true"))
89 ((eql nil) (princ "false"))
90 ((eql :undefined) (princ "undefined"))
91 (symbol (format t "~S" (string-downcase value)))))))
93 (defun print-json* (thunk)
94 (let ((*print-json-comma* nil))
95 (pprint-logical-block (*standard-output* nil)
99 (defmacro print-json (&body body)
100 `(print-json* (lambda () ,@body)))
102 ;;;--------------------------------------------------------------------------
103 ;;; Host definitions.
105 (defvar *hosts* (make-hash-table))
108 (defun addhost (name alist)
109 (setf (gethash name *hosts*) alist))
112 (defmacro defhost (name &body alist)
113 `(progn (addhost ',name ',alist) ',name))
116 (defun host-plist (name)
117 (multiple-value-bind (plist foundp) (gethash name *hosts*)
118 (unless foundp (error "Host ~S not found" name))
122 (defun hostprop (name prop &optional default)
123 (multiple-value-bind (found-name value tail)
124 (get-properties (host-plist name) (list prop))
125 (declare (ignore found-name))
128 (values default nil))))
129 (defun (setf hostprop) (value name prop &optional default)
130 (declare (ignore default))
131 (let ((plist (host-plist name)))
132 (multiple-value-bind (found-name found-value tail)
133 (get-properties plist (list prop))
134 (declare (ignore found-name found-value))
136 (setf (cadr tail) value)
137 (setf (gethash name *hosts*)
138 (cons prop (cons value plist))))
141 (export 'hostprop-default)
142 (defun hostprop-default (host prop value)
143 (multiple-value-bind (found-value foundp) (hostprop host prop)
144 (declare (ignore found-value))
145 (unless foundp (setf (hostprop host prop) value))))
148 (defun hostpropp (host prop)
149 (multiple-value-bind (value foundp) (hostprop host prop)
150 (declare (ignore value))
154 (defun maphosts (func)
155 (maphash (lambda (name plist)
156 (declare (ignore plist))
161 (defmacro dohosts ((hostvar &optional valueform) &body body)
162 `(block nil (maphosts (lambda (,hostvar) ,@body)) ,valueform))
164 ;;;--------------------------------------------------------------------------
165 ;;; Group definitions.
167 (defvar *groups* nil)
170 (defun add-group (name type func)
171 (let* ((found (assoc name *groups*))
176 (when (funcall func host) (push host list)))))
180 (setf (cdr found) list)
181 (push (cons name list) *groups*))))
184 (defmacro defgroup (name type args &body body)
185 `(progn (add-group ',name ,type
188 (destructuring-bind (hostvar) args
189 `(lambda (,hostvar) ,@body)))
191 (destructuring-bind () args
192 `(lambda () ,@body)))))
195 ;;;--------------------------------------------------------------------------
196 ;;; Post-processing hooks.
198 (defstruct hook-entry
202 (export '(prio-props prio-groups))
203 (defconstant prio-props 10)
204 (defconstant prio-groups 20)
206 (defvar *hostproc-hooks* nil)
209 (defun addhook (prio func)
210 (push (make-hook-entry :prio prio :func func) *hostproc-hooks*))
213 (defmacro defhook ((prio) &body body)
214 `(addhook ,prio (lambda () ,@body)))
216 ;;;--------------------------------------------------------------------------
217 ;;; Read the input file and hook definitions.
220 #.(or *compile-file-pathname* *load-pathname*))
222 (let ((pkg (make-package "ANSIBLE-INVENTORY-USER"
223 :use '("CL" "ANSIBLE-INVENTORY")))
225 (loop (let* ((arg (pop args))
227 (cond ((string= arg "--") (return))
228 ((string= arg "-") (push arg args) (return))
229 ((and (plusp (length arg))
230 (char= (char arg 0) #\-))
234 (cond ((< (1+ i) len)
235 (prog1 (subseq arg (1+ i))
240 (error "missing argument"))))))
242 (#\h (format t "usage: ~A FILE ...~%"
243 (pathname-name *progname*)))
244 (t (error "unknown option `-~A'" (char arg i))))))
245 (t (push arg args) (return)))))
247 (let ((*package* pkg))
248 (load arg :verbose nil))))
250 ;;;--------------------------------------------------------------------------
253 (setf *hostproc-hooks* (sort *hostproc-hooks* #'< :key #'hook-entry-prio))
254 (mapc (compose #'hook-entry-func #'funcall) *hostproc-hooks*)
256 ;;;--------------------------------------------------------------------------
257 ;;; Output the definitions.
259 (setf *print-right-margin* 77)
262 (print-json-mapping "all"
263 (print-json-list (maphosts #'print-json-simple)))
264 (dolist (assoc *groups*)
265 (print-json-mapping (car assoc)
267 (mapc #'print-json-simple (cdr assoc)))))
268 (print-json-mapping "_meta"
270 (print-json-mapping "hostvars"
272 (maphash (lambda (host plist)
273 (print-json-mapping host
275 (do ((plist plist (cddr plist)))
277 (print-json-mapping (car plist)
278 (print-json-simple (cadr plist)))))))
281 ;;;----- That's all, folks --------------------------------------------------