[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!!!!!!!