;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Modified sample04 in ole/samples to allow other computations
;; which are more suited to our purposes
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :user)

;; Compiling OLE source needs the OLE Development tools.
;; Compiling a local server uses the automation tools.

(eval-when (compile eval)
   (require :ole-dev))

;; Running OLE source requires the OLE Runtime package.

(eval-when (compile eval load)
   (require :ole))



;; Now that we have the OLE package defined, we can require ole modules.
;; A local server needs factory and automaton support.

(eval-when (compile load eval)
  (ole:require-modules :automation-server :factory-server))

;; Here we define a class for our automated objects.  By specifying
;; the metaclass ole:automation-class, we can include dispid specifications
;; in any slot specifications we want, and these will automatically be
;; made available to our clients.

;; The summation is on the numbers x, x+d, x+d+d, x+d+d+d, ...

;; the class for automated objects
;; The metaclass ole:automation-class allows us to include dispid specs
;; Allows for basic functions to be called
(defclass test-evaluator (ole:automaton)
  (
   ;; the function to evaluate
   (fun :initform '(lambda (&rest args) nil) :accessor fun :dispid 3)
   
   ;; this is the list of arguments the function uses
   (args :initform '() :accessor args :dispid 4)
   
   ;; the lisp expression to evaluate
   (expr :initform '() :accessor expr :dispid 5)
   )
  (:metaclass ole:automaton-class))

;; This is an IDispatch method, which performs the evaluates expr
;; The client will access it via "evaluation", and the DispID
;; will be 26

(ole:def-automethod evaluation ((obj test-evaluator) (dispid 26) &rest args)
  (declare (ignore args))
  (let ((expr (if (stringp (expr obj)) (read-from-string (expr obj)) (expr obj))))
    (format nil "~s" (eval expr))))

;; This is another IDispatch method, which applies fun to args
(ole:def-automethod application ((obj test-evaluator) (dispid 27) &rest args)
  (declare (ignore args))
  (let ((fun (if (stringp (fun obj)) (read-from-string (fun obj)) (fun obj)))
        (args (if (stringp (args obj)) (read-from-string (args obj)) (args obj))))
    (format nil "~s" (apply fun args))))

;; now we need a factory to build test-evaluators on demand

;; We'll define our own factory class so we can specialize a
;; factory-idle method on it.

(defclass evaluator-factory (ole:class-factory) ())

;; This factory-idle function wants to shut down the lisp,
;; but it has to return to its caller first, so we start a
;; second process to do the shutdown after a brief wait.

(defmethod ole:factory-idle ((factory evaluator-factory))
  (format t "~2%;; Factory is idle.  Will shut down in 3 seconds.~2%")
  (ole:unregister-factory factory)
  (mp:process-run-function "kill" #'server-exit))

;; This server-exit function shuts down the shop after a delay.

(defun server-exit ()
  (sleep 3)
  (ole:stop-ole)
  (exit 0))

;; We need a class id

(defparameter evaluator-classid
  (ole:code-guid #xdbce6208 #xe0a3 #x11cf #xb565 #x00aa006459ba))

;; Now we can build a factory (we only need one).

(defparameter factory (make-instance 'evaluator-factory
			     :product-class 'test-evaluator
			     :classid evaluator-classid))

;; This is the main application function that will run when this image
;; is loaded.  It either registers (if the argument was -- register)
;;			 unregisters (if the argument was -- unregister)
;;                       or starts a server.

(defun server-main ()
  (let ((cmd-args (sys:command-line-arguments)))
    (format t "Lisp Test Evaluator Server.  Args = ~s~2%"
	    cmd-args)
    (if* (member "-register" cmd-args
		 :test #'string-equal)
       then ;; place registry entries for VBasic
            (ole:register-server "Franz.testeval.1"
				 "Franz Test Evaluator"
				 evaluator-classid
				 :local32 t)
	    (exit 0)
     elseif (member "-unregister" cmd-args
		    :test #'string-equal)
       then ;; remove the registry entries
            (ole:unregister-application "Franz.testeval.1")
	    (exit 0)
     else ;; to start the server we have to do 2 more things

          ;; (1) We need to start the OLE session

          (ole:start-ole)

	  ;; (2) And we should tell OLE we'll accept connections

	  (ole:register-factory factory
				evaluator-classid
				ole:CLSCTX_LOCAL_SERVER
				ole:REGCLS_MULTIPLEUSE)

;; The server is now running, and will run until
;;   (1)  The factory-idle method shuts us down
;;   or
;;   (2)  stop is entered to the server's window

	  (loop
	   (let ((e (read)))
	     (when (eq e 'stop)
		   (ole:unregister-factory factory)
		   (ole:stop-ole)
		   (exit 0)))))))

;; end of file