[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

A clim translator bug ... (how can I get around it)?



;I am presently on a SPARC in Allegro 4.01 and CLIM 1.0.

;Here is a file for illustrating a CLIM BUG that
;is causing me serious problems for my application.  I
;have objects of many levels of subclassess in which I wish
;to use their superclass presentations from various
;levels.  Unfortunately, in all cases where I use
;presentation-to-command translators with *unsupplied-argument*
;the command doesn't interpret the object's class correctly.
;If I do it directly, by keying in the command and then
;clicking on the presentation the command works.  I do
;not want to reiterate the translator for each superclass
;level of the object I have created because there are so
;many.  Any workarounds, other than adding direct accept
;calls within the command after it has been invoked to
;eliminate the need for using *unsupplied-argument*?

;;; -*- Mode: Common-Lisp; Package: User -*-

(in-package common-lisp-user)
(use-package "CLIM")

(defvar obj-list nil)  ;hold the objects
(defvar *root-window* nil)
(defvar *clim-bug* nil)

;;make the mouse clicking work in my terms

(define-gesture-name :middle :button :middle)
(define-gesture-name :right :button :right)

;Simplest class objects to demonstrate problem

(eval-when (compile load eval)
  (defclass a () ())
  (defclass b (a) ())
  (defclass c (b) ())
  (define-presentation-type a ())
  (define-presentation-type b ())
  (define-presentation-type c ()))

(defmethod initialize-instance :after ((self a) &key)
  (push self obj-list))

;we only create one instance of each type so a simple list
;is enough.  The present and accept methods reflect this too!

;;extremely simple present and accept methods just to illustrate problem

(define-presentation-method Present (OBJECT 'a STREAM (view textual-view) &key)
   (write-string "Object A" STREAM))

(define-presentation-method Accept ((type a) STREAM (view textual-view) &key)
   (let* ((token (read-token STREAM))
	  (obj (when (string-equal "Object A" token)
		 (loop for i in obj-list do (when (typep i 'a) (return i))))))
     (when obj (return-from accept obj))
     (input-not-of-required-type token type)))

(define-presentation-method Present (OBJECT 'b STREAM (view textual-view) &key)
   (write-string "Object B" STREAM))

(define-presentation-method Accept ((type b) STREAM (view textual-view) &key)
   (let* ((token (read-token STREAM))
	  (obj (when (string-equal "Object B" token)
		 (loop for i in obj-list do (when (typep i 'b) (return i))))))
     (when obj (return-from accept obj))
     (input-not-of-required-type token type)))

;;Lets setup the application frame

(define-application-frame clim-bug () ()
  (:panes ((io-pane :interactor)
	   (display-pane :application :scroll-bars nil
			 :incremental-redisplay nil :display-after-commands nil)
	   (doc :pointer-documentation)))
  (:layout ((a-layout
	     (:column 1
		      (io-pane 1/10)
		      (display-pane :rest)
		      (doc 1/20))))))

(defun Startup-CLIM-BUG () 
  (declare (special *Clim-Bug* *Root-Window*))
  (when (null *Root-Window*)
    (setq *Root-Window*
      (open-root-window :clx :host "eraserhead:0"))) ;stick in your own host!
  (when (null *Clim-Bug*)
    (setq *clim-bug* (make-application-frame 'Clim-Bug :width 500 :left 100 :bottom 200
			    :height 500 :parent *root-window*))
  (run-frame-top-level *Clim-Bug*))

(define-clim-bug-command (com-exit :name t) ()			 
   (frame-exit *clim-bug*))

;;two dumb commands to illustrate translator bug (first one works, second doesn't!)
;;keying in the commands and then clicking works, but the translator for the
;;second one doesn't.
(define-clim-bug-command (com-no-arg-test :name t) ((obj 'b))
   (format (get-frame-pane *application-frame* 'io-pane) "Got it")
   (force-output (get-frame-pane *application-frame* 'io-pane))
   (sleep 4))

(define-clim-bug-command (com-one-arg-test :name t) ((obj 'b) (arg 'number))
   (format (get-frame-pane *application-frame* 'io-pane) "Got it with args")
   (force-output (get-frame-pane *application-frame* 'io-pane))
   (sleep 4)))

(defun rerun ()  ;lazy way to re-execute this puppy!
  (run-frame-top-level *clim-bug*))

;;alas here are my translators  (why doesn't documentation get echoed in pointer-documentation
;;as the manual says (it echos the translator name). Another foobar in the CLIM documentation!

(define-presentation-to-command-translator
 no-arg-test (c com-no-arg-test clim-bug :gesture :middle
		:documentation "A c object")
 (object) (list object))

;;WHY doesn't this work, when I click on the presentation?????
;;Only difference is *unsupplied-argument* (EL-BUG'o)

(define-presentation-to-command-translator
 one-arg-test (c com-one-arg-test clim-bug :gesture :right
		:documentation "A c object")
 (object) (list object *unsupplied-argument*))

;;create fake-o presentations on display-pane to illustrate problem

(define-clim-bug-command (generate :name t) ()
   (when (null obj-list) (make-instance 'a) (make-instance 'b) (make-instance 'c))
   (loop for i in obj-list for j from 1 do
     (with-output-as-presentation
      (:object i :type (type-of i)
	       :stream (get-frame-pane *application-frame* 'display-pane)
	       :single-box t :allow-sensitive-inferiors nil)
      (draw-rectangle* (get-frame-pane *application-frame* 'display-pane)
		       (* 50 j) (* 50 j) (+ (* 50 j) 20) (+ (* 50 j) 20)
		       :filled t :ink +black+))))

;;First compile and load this file up!
;;Next execute START-UP-CLIM-BUG
;;Once the application is up execute the command "Generate"
;;You will see three black boxes of the various class and subclasses
;;of type a, b, c.  The upper left box is the only highlightable one
;;since that one is the only one with translators written for it
;;(unless you key in the test commands, then both upper boxes are
;;highlightable).

;;Try typing in the commands "No-Arg-Test" and "One-Arg-Test" and
;;then clicking on that c presentation.  IT WORKS ... so far!
;;NOW, TRY CLICKING MIDDLE and RIGHT on that c presentation to invoke
;;those translators.  The no-arg-test one works, but the one-arg-test
;;with *unsupplied-argument* doesn't!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
;;I need this capability bad.  How can I get around this BUG!!!!!!!