Clarify defcommand

Writing a command like with a normal labmda-list to indicate
parameters is much clearer than using an `args' parameter that
semmingly comes out of nowhere.
This commit is contained in:
Tom Willemsen 2013-03-28 00:39:29 +01:00
parent 86d7908150
commit dfd6f71c4d

View file

@ -35,31 +35,17 @@
(defmacro call-command (name &rest args) (defmacro call-command (name &rest args)
(let ((command-name (make-command-name (symbol-name name)))) (let ((command-name (make-command-name (symbol-name name))))
`(,command-name ',args))) `(,command-name ,@args)))
(defmacro defcommand (name (&key (min-args 0) (max-args nil)) sdoc ldoc (defmacro defcommand (name (&rest args) sdoc ldoc
&body body) &body body)
"Define a new command usable on the command-line." "Define a new command usable on the command-line."
(let* ((sname (string-downcase (symbol-name name))) (let* ((sname (string-downcase (symbol-name name)))
(command-name (make-command-name (symbol-name name)))) (command-name (make-command-name (symbol-name name))))
`(progn `(progn
(defun ,command-name (args) (defun ,command-name (,@args)
,sdoc ,sdoc
(let ((min-args ,min-args) ,@body)
(max-args ,max-args)
(num-args (length args)))
(cond
((< num-args min-args)
(let ((*standard-output* *error-output*))
(format t "Too few arguments, need at least ~D, got ~D~%"
min-args num-args)
(call-command help ,sname)))
((and max-args (> num-args max-args))
(let ((*standard-output* *error-output*))
(format t "Too many arguments, need at most ~D, got ~D~%"
max-args num-args)
(call-command help ,sname)))
(t ,@body))))
(setf *help-messages* (setf *help-messages*
(nconc *help-messages* '((,sname ,sdoc ,ldoc))) (nconc *help-messages* '((,sname ,sdoc ,ldoc)))
*max-command-name-length* *max-command-name-length*
@ -188,10 +174,17 @@ The executable name should already have been removed."
(if args (if args
(let ((cmd-name (make-command-name (car args)))) (let ((cmd-name (make-command-name (car args))))
(if (fboundp cmd-name) (if (fboundp cmd-name)
(funcall cmd-name (cdr args)) (handler-case (apply cmd-name (cdr args))
(sb-int:simple-program-error (err)
(if (string-equal (format nil "~A" err)
"invalid number of arguments" :end1 27)
(let ((*standard-output* *error-output*))
(format t "Wrong number of arguments given.~%")
(call-command help (car args)))
(signal err))))
(let ((*standard-output* *error-output*)) (let ((*standard-output* *error-output*))
(format t "Unknown command: ~A~%" (car args)) (format t "Unknown command: ~A~%" (car args))
(call-command help)))) (call-command help "help"))))
(map nil #'print-bookmark (get-bookmarks)))) (map nil #'print-bookmark (get-bookmarks))))
(defun print-bookmark (bm) (defun print-bookmark (bm)
@ -204,26 +197,25 @@ bookmark."
(format t "~A~A~A" name description url) (format t "~A~A~A" name description url)
(format t "~A~% ~A~% ~A~%~%" url name description)))) (format t "~A~% ~A~% ~A~%~%" url name description))))
(defcommand add (:min-args 3) (defcommand add (url name description &rest tags)
"Add a new bookmark." "Add a new bookmark."
"Usage: clark add <url> <name> <description> [<tags> ...] "Usage: clark add <url> <name> <description> [<tags> ...]
Add URL with NAME, DESCRIPTION and TAGS to the database. TAGS may be Add URL with NAME, DESCRIPTION and TAGS to the database. TAGS may be
omitted or any number of tag names." omitted or any number of tag names."
(with-transaction *db* (with-transaction *db*
(destructuring-bind (url name description &rest tags) args (insert-bookmark url name description)
(insert-bookmark url name description) (add-tags (last-insert-rowid *db*) tags)))
(add-tags (last-insert-rowid *db*) tags))))
(defcommand edit (:min-args 3) (defcommand edit (url &rest rest)
"Edit a bookmark." "Edit a bookmark."
"Usage: clark edit <url> [--name <name>] \\ "Usage: clark edit <url> [--name <name>] \\
[--description <description>] [--description <description>]
Edit the information for URL, specifying which part(s) to edit. Each Edit the information for URL, specifying which part(s) to edit. Each
option will replace the previous value for that part." option will replace the previous value for that part."
(let ((name-lst (member "--name" args :test #'string=)) (let ((name-lst (member "--name" rest :test #'string=))
(desc-lst (member "--description" args :test #'string=)) (desc-lst (member "--description" rest :test #'string=))
query qargs) query qargs)
(when name-lst (when name-lst
(setf query (concatenate 'string query "name = ? ") (setf query (concatenate 'string query "name = ? ")
@ -235,9 +227,9 @@ option will replace the previous value for that part."
(when qargs (when qargs
(apply #'execute-non-query *db* (apply #'execute-non-query *db*
(format nil "UPDATE bookmark SET ~A WHERE url = ?" query) (format nil "UPDATE bookmark SET ~A WHERE url = ?" query)
(append qargs (list (car args))))))) (append qargs (list url))))))
(defcommand exists (:min-args 1 :max-args 1) (defcommand exists (url)
"Check if a bookmark exists in the database." "Check if a bookmark exists in the database."
"Usage: clark exists <url> "Usage: clark exists <url>
@ -245,32 +237,32 @@ Check if URL exists in the database. Prints `yes' when found and `no'
otherwise." otherwise."
(format t "~:[no~;yes~]~%" (format t "~:[no~;yes~]~%"
(execute-single (execute-single
*db* "SELECT rowid FROM bookmark WHERE url = ?" (car args)))) *db* "SELECT rowid FROM bookmark WHERE url = ?" url)))
(defcommand help (:max-args 1) (defcommand help (&optional command)
"Show help message." "Show help message."
help-message help-message
(if (> (length args) 0) (if command
(let ((ldoc (let ((ldoc
(nth 2 (car (member (nth 2 (car (member
(car args) *help-messages* command *help-messages*
:test #'(lambda (x y) (equal x (car y)))))))) :test #'(lambda (x y) (equal x (car y))))))))
(cond (cond
((null ldoc) (format t "Unkown command: ~A~%" (car args))) ((null ldoc) (format t "Unkown command: ~A~%" command))
((and (symbolp ldoc) (fboundp ldoc)) (funcall ldoc)) ((and (symbolp ldoc) (fboundp ldoc)) (funcall ldoc))
(t (format t "~A~%" ldoc)))) (t (format t "~A~%" ldoc))))
(call-command help "help"))) (call-command help "help")))
(defcommand remove (:min-args 1 :max-args 1) (defcommand remove (url)
"Remove a bookmark from the database." "Remove a bookmark from the database."
"Usage: clark remove <url> "Usage: clark remove <url>
Remove URL from the database." Remove URL from the database."
(clear-tags (car args)) (clear-tags url)
(execute-non-query (execute-non-query
*db* "DELETE FROM bookmark WHERE url = ?" (car args))) *db* "DELETE FROM bookmark WHERE url = ?" url))
(defcommand search (:min-args 1 :max-args 1) (defcommand search (str)
"Search through bookmarks." "Search through bookmarks."
"Usage: clark search <str> "Usage: clark search <str>
@ -286,18 +278,18 @@ bookmark's name or an exact match for a tag."
"FROM tag " "FROM tag "
"JOIN bookmark_tag ON (tag_id = tag.rowid) " "JOIN bookmark_tag ON (tag_id = tag.rowid) "
"WHERE bookmark_id = bookmark.rowid)") "WHERE bookmark_id = bookmark.rowid)")
(format nil "%~A%" (car args)) (car args)))) (format nil "%~A%" str) str)))
(defcommand set-tags (:min-args 1) (defcommand set-tags (url &rest tags)
"Set a bookmark's tags." "Set a bookmark's tags."
"Usage: clark set-tags <url> [<tags> ...] "Usage: clark set-tags <url> [<tags> ...]
Set bookmark URL's tags to the given list, overwriting the previous Set bookmark URL's tags to the given list, overwriting the previous
list of tags." list of tags."
(clear-tags (car args)) (clear-tags url)
(add-tags (car args) (cdr args))) (add-tags url tags))
(defcommand version (:max-args 0) (defcommand version ()
"Show version." "Show version."
"Usage: clark version "Usage: clark version