David Krentzlin committed 145f2d0 Draft

altered command stuff. The former implementation didn't work out

  • Participants
  • Parent commits a57b1f1

Comments (0)

Files changed (2)

File mira.core/mira.core.asd

 (defsystem :mira.core
     :version "0.1"
     :author "David Krentzlin"
-    :depends-on (:log5 :cl-annot :bordeaux-threads :sb-concurrency :cl-ppcre)
+    :depends-on (:log5 :cl-annot :bordeaux-threads :sb-concurrency :cl-ppcre :getopt :split-sequence)
     :description "Modular multithreaded bot framework"
     :license "BSD"
     :components ((:static-file "mira.core.asd")

File mira.core/src/processor.lisp

 (in-package :cl-user)
 (defpackage :mira.core.processor
-  (:use :cl :cl-annot :mira.core.debug :mira.core.acl :mira.core.message)
+  (:use :cl :cl-annot :mira.core.debug :mira.core.acl :mira.core.message :getopt)
   (:export id documentation command-environment-issuer command-environment-answer-fn command-environment-skip-fn command-environment-quit-fn command-environment-processor))
 (in-package :mira.core.processor)
     :initarg :help
     :reader help
     :initform "")
+   (allow-no-arguments
+    :documentation "Can this command be called without arguments?"
+    :initarg :allow-no-args
+    :reader allow-no-args
+    :initform nil)
+   (command-line-options
+    :documentation "The options to be parsed to getopt"
+    :initarg :command-line-options
+    :accessor command-line-options
+    :initform nil)
     :initarg :required-access-level
     :initform 0
 			      :generator-id (slot-value message 'mira.core.message::generator-id)
 			      :tag (tag message))
 	       (if (listp result) result (list result)))))))
+(defun option-value (value opts &optional (default nil))
+  (or (cdr (assoc value opts :test #'equal)) default))
 (defgeneric process-message (processor message skip-following quit))
 (defgeneric apply-command (command argument-string command-env)
   (:documentation "Applies the command to the given input")
-  (:method ((command <command>) arguments command-env)
-    (let* ((argument-list (argument-string->argument-list arguments))
+  (:method ((command <command>) argument-string command-env)
+    (let* ((argument-list (argument-string->argument-list argument-string))
 	   (cmd-closure   (body command))
+	   (cmd-opts      (command-line-options command))
 	   (first-arg     (car argument-list)))
       (if (and first-arg (stringp first-arg) (equal (string-downcase (car argument-list)) "help"))
           (cmd-answer command-env (help command))
-	 ;; (apply cmd-closure (cons command-env argument-list))
-	   	(apply cmd-closure (cons command-env argument-list)))
-	    (error ()
-	      (cmd-answer command-env (usage command))))
+		(if (and (not argument-list) (not (no-args-allowed command)))
+		    (cmd-answer command-env (usage command))
+		    (if cmd-opts
+			(multiple-value-bind (args options errors) (getopt argument-list cmd-opts)
+			  (if errors
+			      (cmd-answer command-env (usage command))
+			      (apply cmd-closure command-env options args)))
+			(apply cmd-closure command-env nil argument-list))))
+	     (error ()
+	       (format t "Have an error~%")
+	       (cmd-answer command-env (usage command))))
 (defmethod print-object ((object <processor>) stream)
   (print-unreadable-object (object stream :type t)
     (format stream "~A" (id object))))
 (defgeneric add-command (proc command-name command)
   (:method ((proc <commands-mixin>) command-name (command <command>))
   (declare (ignore args))
   (setup-commands processor))
-;; (defcommand processor 0 (echo (content &key (foo  1))
-;; (defmethod setup-commands ((proc <my-procssor>))
-;;   (defcommand proc 0 (echo (content &key (foo  1))
-;;                           (do-sth-with content)))))
-;; (defusage processor echo
-;;     :banner "echo content"
-;;     (foo :required "Sets the frooble")
-;;     (bar :optional "Set the barble"))
-;;   Usage: echo content [options]
-;;    :foo=BAR "Sets the froobl"
-;;    :bar     "Sets the barble"
+;; (defcommand proc 10 'my-command "A basic command"
+;;   '(("option1" :required 5 "This is a required option with default 5")
+;;     ("optons2" :none nil "This is an option that doesn't take an argument")
+;;     ("option3" :optional 10 "This is an option that optionally takes an argument"))
+;;   (lambda (env parsed-options &rest args)
+;;     (cmd-answer env (format nil "I received ~A with ~A" parsed-options args)))
+;;   :no-args-allowed nil
+;;   :usage "My-Command: [options] arg1")
+(defmethod defcommand ((proc <commands-mixin>) level name descr options handler &key (no-args-allowed nil) (usage))
+  (let* ((usage-text (or usage (format nil "Usage: ~A~A [options] [args]" *command-prefix* name)))
+	 (help  (generate-help name descr usage-text options)))
+    (format t "Options: ~S~%" (options-description->getopt-options options))
+    (add-command proc 
+		 (string name)
+		 (make-instance '<command>
+				:required-access-level level
+				:help  help
+				:command-line-options (options-description->getopt-options options)
+				:usage usage-text
+				:body handler))))
-(defmacro defcommand (proc level (command-name (&rest command-lambda-list) &body body))
-  (let ((arguments (gensym)))
-    `(add-command ,proc
-		  (string ',command-name)
-		  (make-instance '<command>
-				 :required-access-level ,level
-				 :body (lambda (&rest ,arguments)
-					 (destructuring-bind (,@command-lambda-list) ,arguments
-					   ,@body))))))
-(defmacro defusage (processor command-name banner usage-text &rest options)
-  `(add-usage ,processor (string ',command-name) ,banner ,usage-text '(,@options)))
-(defmethod add-usage ((processor <commands-mixin>) command banner usage-text options)
-  (let ((cmd (get-command (slot-value processor 'commands) (string command))))
-    (when cmd
-      (with-slots (usage help) cmd
-	(setf usage (format nil "Usage: ~A~A~A" *command-prefix* (string command) usage-text)
-	      help (generate-help (string command) banner usage-text options))))))
+(defun options-description->getopt-options (options)
+  (mapcar #'butlast options))
 (defun command-syntax? (input prefix)
   (cl-ppcre:scan (format nil "^\s*~A(.+?)" (cl-ppcre:quote-meta-chars prefix)) input))
   (:method (cmd (collection <command-collection>) issuer)
     (let ((command (get-command collection cmd))
           (acl     (acl collection)))
-      (or
-       (and
-        (access-allowed? acl issuer (required-access-level command))
-        command)
-       :access-denied))))
+      (if command
+	  (or
+	   (and
+	    (access-allowed? acl issuer (required-access-level command))
+	    command)
+	   :access-denied)
+	  nil))))
 (defun destructure-command (str prefix)
   (let* ((stripped (string-trim '(#\Space #\Tab #\Newline) str))
 		(string-trim " " (subseq stripped (1+ ws))))
 	(values (string-trim prefix stripped) ""))))
-;; foo bar baz -> (list "foo" "bar" "baz")
-;; foo :bar 0  -> (list "foo" :bar 0)
 (defun argument-string->argument-list (argument-string)
-  "Converts an argument string into a argument list, that can be fed into the command."
-  (handler-case
-      (mapcar
-       (lambda (elt)
-         (cond
-           ((keywordp elt) elt)
-           ((symbolp elt) (string elt))
-           (t elt)))
-       (read-from-string (concatenate 'string "(" argument-string ")")))
-    (error () (list))))
+  (split-sequence:split-sequence #\Space argument-string))
 (defun generate-help (command banner usage options)
   (let ((help-string (format nil "~A: ~A" command banner))
-	(usage-string (format nil "Usage: ~A~A ~A" *command-prefix* command usage))
+	(usage-string usage)
 	(options-start "Options: ")
 	(options-strings (format-options options)))
     (if options
 (defun format-options (options)
    (lambda (option)
-     (format nil "~A: ~A" (string (car option)) (string (car (last option)))))
+     (let* ((name (first option))
+	    (maybe/default (third option))
+	    (descr (fourth option)))
+       (if maybe/default
+	   (format nil "~A [Default=~A] ~A" name maybe/default descr)
+	   (format nil "~A: ~A " name descr))))