David Krentzlin committed 7e0ef36 Draft

alot of updates to the command logic

  • Participants
  • Parent commits 495fb9e

Comments (0)

Files changed (2)


   (:method ((acl <acl>) ident access-level)
     (setf (gethash ident (level-mapping acl)) access-level)))
+(defun create-acl-from-alist (alist)
+  (let ((acl (make-instance '<acl>)))
+    (loop for (ident level) in alist
+       do (update-access-level acl ident level))
+    acl))
 ;;create and remove can be constructed with update
 ;;(update-access-level acl ident nil) => remove
 ;;(update-access-level acl new-ident level) => create


 (in-package :cl-user)
 (defpackage :mira.core.processor
-  (:use :cl :cl-annot :mira.core.debug)
+  (:use :cl :cl-annot :mira.core.debug :mira.core.acl)
   (:export id documentation)
-  (:import-from :mira.core.acl
-                :<acl>)
   (:import-from :mira.core.message
-                :<message>))
+                :<message>
+		:data))
 (in-package :mira.core.processor)
 (defclass <command-collection> ()
-  ((commands :initform (make-hash-table :test #'equal))
+  ((commands :initform (make-hash-table :test #'equal)
+             :accessor commands)
    (acl      :initarg :acl
+             :accessor acl
              :documentation "The access control list for this commands")))
 (defclass <command> ()
 (defclass <commands-mixin> ()
-  (commands      :documentation "Commands that are associated with this processor"
-                 :initform (make-instance '<command-collection>)))
+  ((self         :documentation "The identity of this bot"
+                 :accessor self
+                 :initarg :self
+                 :initform (error "You need to supply a self if you want to use commands"))
+   (commands     :documentation "Commands that are associated with this processor"
+		 :accessor commands
+                 :initform (make-instance '<command-collection>))))
 (defun answer (&rest arguments)
            (*current-kernel* (slot-value processor 'kernel))
             (lambda (result &key (channels) (sender-id) (receiver (sender message)))
-              (funcall
-               #'skip-following
-               (make-instance '<message>
-                              :receiver receiver
-                              :data result
-                              :sender-identity sender-id
-                              :generator-id (slot-value message 'mira.core.message::generator-id)
-                              :tag (tag message))))))
+	      (let ((messages (mapcar 
+			       (lambda (data)
+				 (make-instance '<message>
+						:receiver receiver
+						:data data
+						:sender-identity sender-id
+						:generator-id (slot-value message 'mira.core.message::generator-id)
+						:tag (tag message))
+				 (if (listp result) result (list result))))))
+		(funcall
+		 #'skip-following
+		 messages)))))
       (when (command-syntax? input self)
         (multiple-value-bind (command arguments) (destructure-command (strip-sender input))
   (:method ((command <command>) arguments (message <message>) quit skip)
     (let ((argument-list (argument-string->argument-list arguments))
           (cmd-closure (body command)))
-      (if (equal? (string-downcase (car argument-list)) "help")
+      (if (equal (string-downcase (car argument-list)) "help")
           (answer (help command))
               (apply cmd-closure argument-list)
   (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>))
 (defmethod add-command ((collection <command-collection>) name command)
-  (setf (gethash (string-downcase (string name)) collection) command))
+  (with-slots (commands) collection
+    (setf (gethash (string-downcase (string name)) commands) command)))
 (defmethod get-command ((collection <command-collection>) name)
-  (gethash (sring-downcase (string name)) collection))
+  (with-slots (commands) collection
+    (gethash (string-downcase (string name)) commands)))
 (defgeneric setup-commands (processor)
 (defmacro defcommand (proc level (command-name (&rest command-lambda-list) &body body))
-  (let ((closure (gensym)))
-    `(labels ((,closure (lambda (&rest arguments)
-                          (destructuring-bind (,@command-lambda-list) arguments
-                            ,@body))))
-       (add-command ,proc
-                    (string ',command-name)
-                    (make-instance '<command>
-                                   :required-access-level ,level
-                                   :body ,closure)))))
+  (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 &rest options)
-  `(with-slots (usage help) ,processor
-     (setf usage banner)
-     (setf help (generate-help
-                 (string ',command-name)
-                 banner
-                 '(,@options)))))
+(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 usage-text
+	      help (generate-help (string command) banner usage-text options))))))
 (defun command-syntax? (input self-ident)
   (cl-ppcre:scan (format nil "^~A:? +~A(.+?)"
        (read-from-string (concatenate 'string "(" argument-string ")")))
     (error () (list))))
-(defun generate-help (&rest args)
-  "Not yet implemented")
+(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))
+	(options-start "Options: ")
+	(options-strings (format-options options)))
+    (if options
+	(list help-string usage-string options-start options-strings)
+	(list help-string usage-string))))
+(defun format-options (options)
+  (mapcar
+   (lambda (option)
+     (format nil "~A: ~A" (string (car option)) (string (car (last option)))))
+   options))