;; Copyright (C) 2013 Tom Willemsen ;; This file is part of CLark ;; CLark is free software: you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; CLark is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with CLark. If not, see . ;;; Code: (in-package :clark) (defvar *db* nil "The database connection.") (defvar *help-messages* nil "Help texts for commands.") (defvar *max-command-name-length* 0 "Length of the longest command name.") (defvar *script* nil "Whether or not to output in a machine-readable format.") (define-condition exiting () ((exit-code :initform 0 :initarg :code :reader exit-code))) (defmacro call-command (name &rest args) (let ((command-name (make-command-name (symbol-name name)))) `(,command-name ,@args))) (defmacro defcommand (name (&rest args) sdoc ldoc &body body) "Define a new command usable on the command-line." (let* ((sname (string-downcase (symbol-name name))) (command-name (make-command-name (symbol-name name)))) `(progn (defun ,command-name (,@args) ,sdoc ,@body) (setf *help-messages* (nconc *help-messages* '((,sname ,sdoc ,ldoc))) *max-command-name-length* (max *max-command-name-length* (length ,sname)))))) (defmacro with-error-and-help (code cmd fmt &rest args) "Call `with-error-status' with CODE, format FMT with ARGS and call the help command." `(with-error-status ,code (format t ,fmt ,@args) (call-command help ,cmd))) (defmacro with-error-status (code &body body) "Bind `*exit-status*' to CODE, `*standard-output*' to `*error-output*' and execute BODY." `(let ((*standard-output* *error-output*) (exit-status ,code)) ,@body (when (> exit-status 0) (signal 'exiting :code exit-status)))) (defparameter version "0.1.1" "Clark's version.") (defun add-tags (url-or-id tags) "Add tags to the bookmark_tag table and possibly to tag." (when url-or-id (if (integerp url-or-id) (map nil (lambda (tag) (let ((tag-id (handler-case (insert-tag tag) (sqlite-error () (get-tag-id tag))))) (insert-bookmark-tag url-or-id tag-id))) tags) (add-tags (get-bookmark-id url-or-id) tags)))) (defun clear-tags (url-or-id) "Remove all tags from the bookmark URL." (when url-or-id (if (integerp url-or-id) (delete-tags url-or-id) (clear-tags (get-bookmark-id url-or-id))))) (defun ensure-db-exists (name) "Connect to the database, possibly creating it." (let ((db-exists (probe-file name))) (setf *db* (connect name)) (unless db-exists (create-table-bookmark) (create-table-tag) (create-table-bookmark_tag)))) (defun get-db-location () "Get the location of the database." (let ((xdg (sb-ext:posix-getenv "XDG_DATA_HOME")) (home (sb-ext:posix-getenv "HOME"))) (pathname (apply 'concatenate 'string (or xdg home) (unless xdg "/.local/share") '("/clark/bookmarks.db"))))) (defun get-rc-location () "Get the location of the RC file." (let ((xdg (sb-ext:posix-getenv "XDG_CONFIG_HOME")) (home (sb-ext:posix-getenv "HOME"))) (pathname (apply 'concatenate 'string (or xdg home) (unless xdg "/.config") '("/clark/rc.lisp"))))) (defun help-message () (format t (concatenate 'string "Usage: clark [options] [ [ ...]]~%" "~%" "Possible options:~%" "~%" " --script Output in a machine-readable format.~%" "~%" "Possible commands:~%" "~%")) (map nil (lambda (hlp) (destructuring-bind (name short long) hlp (declare (ignore long)) (format t " ~vA ~A~%" *max-command-name-length* name short))) *help-messages*) (format t "~%~A~%" (concatenate 'string "Use `clark help ' to get more " "information on a command."))) (defun load-db () "Load the database." (let ((db-location (get-db-location))) (ensure-directories-exist db-location) (ensure-db-exists db-location))) (defun load-rc () "Load the RC file." (let ((*package* (in-package :clark))) (load (get-rc-location) :if-does-not-exist nil))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-command-name (base) "Turn BASE into the name of a possible command." (intern (concatenate 'string (string-upcase base) "-COMMAND") :clark))) (defun parse-args (args) "Parse command-line arguments ARGS. The executable name should already have been removed." (loop while (and args (char= (char (car args) 0) #\-)) do (case (intern (string-upcase (string-left-trim "-" (car args))) :clark) (script (setf *script* t args (cdr args))) (t (with-error-and-help 1 "help" "Unknown option: ~a~%" (car args))))) (if args (let ((cmd-name (make-command-name (car args)))) (if (fboundp cmd-name) (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) (with-error-and-help 1 (car args) "Wrong number of arguments given.~%") (signal err)))) (with-error-and-help 1 "help" "Unknown command: ~A~%" (car args)))) (map nil #'print-bookmark (bookmark-list)))) (defun print-bookmark (bm) "Print information about bookmark BM. BM should be a list containing the url, name and description of the bookmark." (destructuring-bind (url name description) bm (if *script* (format t "~A~A~A" url name description) (format t "~A~% ~A~% ~A~%~%" url name description)))) (defun clark (args) "Main function. Connect to the database, parse command-line arguments, execute and then disconnect." (load-rc) (load-db) (handler-case (unwind-protect (parse-args (cdr args)) (disconnect *db*)) (exiting (c) (sb-ext:exit :code (exit-code c)))))