1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2011, 2012 Bert Burgemeister
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 2 of the License, or
7 ;;; (at your option) any later version.
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
14 ;;; You should have received a copy of the GNU General Public License along
15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
21 (defmacro defun
* (name lambda-list
&body body
)
22 "Like defun, define a function, but with an additional lambda list
23 keyword &mandatory-key which goes after the &key section or in place
24 of it. &mandatory-key argument definitions are plain symbols (no
25 lists). An error is signalled on function calls where one of those
27 (let ((mandatory-key-position (position '&mandatory-key lambda-list
))
28 (after-key-position (or (position '&allow-other-keys lambda-list
)
29 (position '&aux lambda-list
))))
30 (when mandatory-key-position
32 (append (subseq lambda-list
0 mandatory-key-position
)
33 (unless (position '&key lambda-list
)
37 `(,k
(error ,(format nil
"~A: argument ~A undefined"
40 (1+ mandatory-key-position
)
42 (when after-key-position
43 (subseq lambda-list after-key-position
))))))
44 `(defun ,name
,lambda-list
,@body
))
46 (defmacro logged-query
(message-tag &rest args
)
47 "Act like postmodern:query; additionally log some debug information
48 tagged by the short string message-tag."
49 (cl-utilities:with-unique-names
50 (executed-query query-milliseconds query-result
)
51 `(let* (,executed-query
54 (cl-postgres:*query-callback
*
55 #'(lambda (query-string clock-ticks
)
56 (setf ,query-milliseconds clock-ticks
)
57 (setf ,executed-query query-string
))))
60 (etypecase (car ',args
)
62 (typecase (caar ',args
)
64 (query (sql-compile ',(car args
))
66 (t ;function (supposedly) returning string
74 "[~A] Query ~S~& took ~F seconds and yielded~& ~A."
77 (/ ,query-milliseconds
1000)
80 (defmacro cli
:with-options
((&key log database aux-database tolerate-missing
)
83 &aux postgresql-credentials
)
84 "Evaluate body with options bound to the values of the respective
85 command line arguments. Signal error if tolerate-missing is nil and a
86 command line argument doesn't have a value. Elements of options may
87 be symbols named according to the :long-name argument of the option,
88 or lists shaped like (symbol) which bind symbol to a list of values
89 collected for multiple occurence of that option. If log is t, start
90 logging first. If database or aux-database are t, evaluate body with
91 the appropriate database connection(s) and bind the following
92 additional variables to the values of the respective command line
93 arguments: host, port, database, user, password, use-ssl; and/or
94 aux-host, aux-port, aux-database, aux-user, aux-password,
96 (assert (not (and database aux-database
)) ()
97 "Can't handle connection to both database and aux-database ~
101 (append options
'(host port database user password use-ssl
)))
102 (setf postgresql-credentials
103 '(list database user password host
:port port
104 :use-ssl
(s-sql:from-sql-name use-ssl
))))
107 (append options
'(aux-host aux-port aux-database
108 aux-user aux-password aux-use-ssl
)))
109 (setf postgresql-credentials
110 '(list aux-database aux-user aux-password aux-host
:port aux-port
111 :use-ssl
(s-sql:from-sql-name aux-use-ssl
))))
112 (when log
(setf options
(append options
'(log-dir))))
113 (let* ((db-connected-body
114 (if (or database aux-database
)
115 `((with-connection ,postgresql-credentials
116 (muffle-postgresql-warnings)
121 `((launch-logger log-dir
)
124 `(cli:with-context
(cli:make-context
)
126 for option in
(remove-duplicates options
)
127 if
(symbolp option
) collect
130 `(cli:getopt
:long-name
,(string-downcase option
))
131 `(cli:getopt-mandatory
,(string-downcase option
))))
135 for i
= ,(if tolerate-missing
136 `(cli:getopt
:long-name
,(string-downcase
138 `(cli:getopt-mandatory
,(string-downcase
140 then
(cli:getopt
:long-name
,(string-downcase
142 while i collect i
))))