CLIM mail archive
[Prev][Next][Index][Thread]

Accepting values and commands.

    Date: Mon, 19 Oct 1992 12:49 EDT
    From: Brian Anderson <bha@atc.boeing.com>


    | Date: Mon, 19 Oct 1992 11:55-0400
    | From: Scott McKay <SWM@STONY-BROOK.SCRC.Symbolics.COM>
    | 
    |     Date: Thu, 15 Oct 1992 17:58 EDT
    |     From: Brian Anderson <bha@atc.boeing.com>
    | 
    |     CLIM 1.1
    |     ACL 4.1
    |     SunOS 4.1.1
    | 
    |     Is there a way to construct an accepting-values dialog to supply the
    |     required/optional arguments of a command?  What I have in mind is
    |     something like what Genera/DW used to do for Meta-Complete (that was
    |     strictly for completion and would be interesting to know how to do on
    |     ACL also).  I want to pass the name of a command, a command table (and
    |     whatever else) and have an accepting values dialog be put up for the
    |     commands arguments.
    | 
    | Actually, CLIM *does* support meta-Complete to fill in a command dialog.  
    | Here is the magic parameter, which you can extend to include something
    | more useful for ACL:
    | 
    | (in-package :clim)
    | (defparameter *command-previewers* '(#+Genera #\m-Complete))

    Great.  That works.  But can I programatically call something that
    does the same thing?  I want to have a command that is executed from a
    menu item.  This commands task is to put up a command dialog for a
    specific command (as a command previewer would).  I just need to know
    how to call the command previewer knowing the name of the command and
    command table.

Call CLIM:ACCEPT-VALUES-COMMAND-PARSER on four arguments: the
command-name, the command table, a stream, and the "partial" command
object.  E.g.,

  (accept-values-command-parser
    'clim-demo::com-hardcopy-file
    (find-command-table 'clim-demo::lisp-listener)
    *query-io*
    '(clim-demo::com-hardcopy-file))

Note that there is a pretty yucky bug in CLIM 1.1 that causes fields in
the dialog to be reset to their default values inappropriately.  I hope
to fix this in CLIM 2.0

[A bit later]

OK, here is a fix for this for CLIM 1.1.  I have verified that this
works in CLIM 2.0, but not in CLIM 1.1.  It should "just work".

(in-package :clim)
(defun accept-values-command-parser (command-name command-table stream partial-command
				     &key own-window)
  (let ((*original-stream* nil)
	copy-partial-command
	(result nil)
	result-index)
    (flet ((arg-parser (stream presentation-type &rest args)
	     (declare (dynamic-extent args))
	     ;; This code is to handle the case where a partial command has been
	     ;; passed in.  PARSE-NORMAL-ARG needs to be called with a :DEFAULT of
	     ;; the appropriate element of the partial command structure.  
	     (let* ((default (if copy-partial-command
				 (pop copy-partial-command)
				 *unsupplied-argument*)))
	       (incf result-index)
	       (setq result (nconc result (list nil)))
	       (with-presentation-type-decoded (type-name parameters) presentation-type
		 (when (eql type-name 'command-name)
		   (setf (nth result-index result) command-name)
		   (return-from arg-parser (values command-name presentation-type)))
		 (cond ((not (unsupplied-argument-p default))
			(cond ((eql type-name 'keyword-argument-name) 
			       (setf (nth result-index result) default)
			       default)
			      (t (multiple-value-bind (arg type)
				    (apply #'parse-normal-arg
					   stream presentation-type
					   :default default args)
				  (setf (nth result-index result) arg)
				  (values arg type)))))
		       ((eql type-name 'keyword-argument-name)
			(let ((keyword
				(intern (symbol-name (caar parameters)) *keyword-package*)))
			     (setf (nth result-index result) keyword)
			     keyword))
		       (t (multiple-value-bind (arg type)
			     (apply #'parse-normal-arg
				    stream presentation-type
				    :provide-default nil args)
			   (setf (nth result-index result) arg)
			   (values arg type)))))))
	   (separate-args (stream args-to-go)
	     (when (and args-to-go (not (member args-to-go '(:end :keywords))))
	       (fresh-line stream))))
      (declare (dynamic-extent #'arg-parser #'separate-args))
      (let ((command
	      (accepting-values (stream :own-window own-window)
		(fresh-line stream)
		(with-output-recording-options (stream :record-p t)
		  (updating-output (stream :unique-id '#:header :cache-value t)
		    (with-text-face (:italic stream)
		      (format stream "Specify arguments for ")
		      (present command-name `(command-name :command-table ,command-table)
			       :stream stream)
		      (write-char #\: stream))
		    (fresh-line stream)))
		;; This copy is done because the accepting-values may/will run this
		;; body several times.
		(setq copy-partial-command (or result
					       (copy-list partial-command)))
		(setq result nil
		      result-index -1)
		(invoke-command-parser-and-collect
		  command-table #'arg-parser #'separate-args stream)
		result)))
	;; If the person clicked on the <Abort> exit box, the ABORT restart
	;; will be invoked and we'll never get here.
	command))))


0,,
References:
Main Index | Thread Index