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
,(delete (intern (string '&mandatory-key
)) lambda-list
)
47 (defmacro logged-query
(message-tag &rest args
)
48 "Act like postmodern:query; additionally log some debug information
49 tagged by the short string message-tag."
50 (cl-utilities:with-unique-names
51 (executed-query query-milliseconds query-result
)
52 `(let* (,executed-query
55 (cl-postgres:*query-callback
*
56 #'(lambda (query-string clock-ticks
)
57 (setf ,query-milliseconds clock-ticks
)
58 (setf ,executed-query query-string
))))
61 (etypecase (car ',args
)
63 (typecase (caar ',args
)
65 (query (sql-compile ',(car args
))
67 (t ;function (supposedly) returning string
75 "[~A] Query ~S~& took ~F seconds and yielded~& ~A."
78 (/ ,query-milliseconds
1000)
81 (defmacro cli
:with-options
((&key log database aux-database tolerate-missing
)
84 &aux postgresql-credentials
)
85 "Evaluate body with options bound to the values of the respective
86 command line arguments. Signal error if tolerate-missing is nil and a
87 command line argument doesn't have a value. Elements of options may
88 be symbols named according to the :long-name argument of the option,
89 or lists shaped like (symbol) which bind symbol to a list of values
90 collected for multiple occurence of that option. If log is t, start
91 logging first. If database or aux-database are t, evaluate body with
92 the appropriate database connection(s) and bind the following
93 additional variables to the values of the respective command line
94 arguments: host, port, database, user, password, use-ssl; and/or
95 aux-host, aux-port, aux-database, aux-user, aux-password,
97 (assert (not (and database aux-database
)) ()
98 "Can't handle connection to both database and aux-database ~
102 (append options
'(host port database user password use-ssl
)))
103 (setf postgresql-credentials
104 '(list database user password host
:port port
105 :use-ssl
(s-sql:from-sql-name use-ssl
))))
108 (append options
'(aux-host aux-port aux-database
109 aux-user aux-password aux-use-ssl
)))
110 (setf postgresql-credentials
111 '(list aux-database aux-user aux-password aux-host
:port aux-port
112 :use-ssl
(s-sql:from-sql-name aux-use-ssl
))))
113 (when log
(setf options
(append options
'(log-dir))))
114 (let* ((db-connected-body
115 (if (or database aux-database
)
116 `((with-connection ,postgresql-credentials
117 (muffle-postgresql-warnings)
122 `((launch-logger log-dir
)
125 `(cli:with-context
(cli:make-context
)
127 for option in
(remove-duplicates options
)
128 if
(symbolp option
) collect
131 `(cli:getopt
:long-name
,(string-downcase option
))
132 `(cli:getopt-mandatory
,(string-downcase option
))))
136 for i
= ,(if tolerate-missing
137 `(cli:getopt
:long-name
,(string-downcase
139 `(cli:getopt-mandatory
,(string-downcase
141 then
(cli:getopt
:long-name
,(string-downcase
143 while i collect i
))))