[cells-gtk-devel] How do I get file-chooser's result as a pathname
Peter Denno
peter.denno at nist.gov
Mon May 14 13:59:45 UTC 2007
On Saturday 12 May 2007 12:46, wagwilk at telusplanet.net wrote:
> I'm trying to use a file-chooser to select mp3 files in this code:
>
> (defmodel audio-panel (vbox)
> ((audio :accessor audio :initform (c-in (make-array 1024 :element-type
> '(signed-byte 16) :adjustable t)))
> (filename :accessor filename :initform (c-in nil)))
> (:default-initargs
>
> :kids (list
>
> (mk-label :text (c? (format nil "~:[No Data Loaded~;~:*~a~]"
> (filename (upper self audio-panel)))))
> (make-instance 'mp3-file-selector))))
>
>
> (defmodel mp3-file-selector (button)
> ()
> (:default-initargs
>
> :stock (c? :open)
>
> ; :label (c? "Load Mp3")
>
> :on-clicked (callback (widget signal data)
>
> (setf (filename (upper self audio-panel))
> (format nil "Set to: ~a"
> (gtk-file-chooser-get-filenames-strs
> (file-chooser :title "Load Mp3"
>
> :select-multiple
0
> :action :open)))))))
>
> I want the callback (reprinted here) to set the string "filename" in the
> audio-panel object
>
> (callback (widget signal data)
> (setf (filename (upper self audio-panel))
> (format nil "Set to: ~a"
> (file-chooser :title "Load Mp3"
>
> :select-multiple 0
> :action :open))))
>
> However, when I run the code, Filename gets set to "Set to
> (#.(SB-SYS:INT-SAP #X0817CF28))" (the pointer address changes)
>
> I've also tried using the method "gtk-file-chooser-get-filenames-strs" from
> gtk-ffi, but it expects a SB-SYS:SYSTEM-AREA-POINTER:
>
> The value (#.(SB-SYS:INT-SAP #X0817CF28))
>
>
> is not of type
>
>
> SB-SYS:SYSTEM-AREA-POINTER.
> [Condition of type TYPE-ERROR]
>
> I've also poured through the test-gtk example code, but I'm not sure how
> they're doing it, and I'm not certain that the result name ever gets fully
> translated on the lisp side. Here is the code from test-gtk:
Hi,
I'm a bit short on time now, so I can't study the details of what you are
doing. But I can assure you that you can get a filename from a file chooser
widget. I'll attach an example (tested on lispworks).
>
> (callback (widget signal data)
> (setf (text (fm^ :file-chooser-response))
> (file-chooser :title (format nil "~a dialog" (action self))
>
> :select-multiple (md-value (fm^
> : :select-multiple-files)) action (action self)))
>
> Where :file-chooser-response is the 'md-name' of a text label elsewhere in
> the program.
>
>
> Cheers,
> Warren Wilkinson
>
> _______________________________________________
> cells-gtk-devel site list
> cells-gtk-devel at common-lisp.net
> http://common-lisp.net/mailman/listinfo/cells-gtk-devel
--
Best regards,
- Peter
-------------- next part --------------
#|
Expresso
Copyright (c) 2005 by Peter Denno <peter.denno at nist.gov>
You have the right to distribute and use this software as governed by
the terms of the Lisp Lesser GNU Public License (LLGPL):
(http://opensource.franz.com/preamble.html)
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
Lisp Lesser GNU Public License for more details.
|#
(in-package "GUI")
(defvar *zippy* nil)
;;; Note: Don't use with-slots (or slot-value) to set cell slots!
;;; Concept of the 'instrumentation of expresso':
;;; Accessors 'schema' and 'dataset' are the values selected by the user from the combo-box.
;;; Accessors 'schemas' and 'datasets' are modified programmatically by reading files, and the
;;; combo-box is updated with the new value by a def-c-output.
(defmodel cgtk-expresso (expo::expresso gtk-app)
((expo:pbar-fraction :initarg :pbar-fraction :initform (c-in 0) :accessor expo:pbar-fraction)
(expo:schemas :initform (c-in nil) :accessor expo:schemas)
(expo:datasets :initform (c-in nil) :accessor expo:datasets)
(expo:current-app :initform (c-in nil) :accessor expo:current-app))
(:default-initargs
:md-name :expresso
:title "Expresso - EXPRESS Tools"
;;:tooltips nil ;;dkwt
;;:tooltips-enable nil ;;dkwt
; :icon (namestring *small-image*)
; :stock-icons (list (list :my-g (namestring *stock-icon-image*)))
:position :center
:splash-screen-image (format nil "~A/cgtk/expresso-splash.png" (expo:install-dir))
:width (if (member :mexico.exe *features*) 600 1350)
:height (if (member :mexico.exe *features*) 550 1050)
:on-delete-event (callback (w e d) ; clean up pseudo-dialogs.
(signal 'cgtk:gtk-user-signals-quit)
0)
:kids
(list
(mk-vbox
:homogeneous nil :fill t :expand t
:kids (list
(make-instance 'main-menubar)
(mk-vpaned :divider-pos 700
:expand t :fill t
:kids
(list
(mk-notebook :md-name :schemas-notebook)
(make-instance 'message-output)))
(make-instance 'status/pbar))))))
;(def-c-output expo:datasets ((self cgtk-expresso))
; (when new-value
; (MS-VARS new-value)
; (break "here")))
(defmodel status/pbar (hbox)
((show :accessor show :initform (c-in :text&pbar))
(old-windows :cell nil :accessor old-windows :initform nil))
(:default-initargs
:md-name :status/pbar
:kids
(c?
(loop for w in (old-windows self) do (cgtk::gtk-object-forget (cgtk::id w) w))
(case (show self)
(:text
(setf (old-windows self)
(list (mk-entry :md-name :message-area :fill t :expand t))))
(:pbar
(setf (old-windows self)
(list (mk-progress-bar
:md-name :pbar :fill t :expand t
:fraction (c? (pbar-fraction (unique-widget :expresso)))))))
(:text&pbar
(setf (old-windows self)
(list (mk-entry :md-name :message-area :fill t :expand t)
(mk-progress-bar
:md-name :pbar :fill t :expand t
:fraction (c? (pbar-fraction (unique-widget :expresso)))))))))))
(defun message-area ()
(text (unique-widget :message-area)))
(defun (setf message-area) (string)
(setf (text (unique-widget :message-area)) string))
(defmethod initialize-instance :around ((self cgtk-expresso) &key)
"Set *expresso* and create a pane-stream for message output."
(setf *expresso* self)
(call-next-method)
(let ((message-textview (unique-widget :message-text)))
(setf *message-stream*
(make-instance 'pane-stream
:buffer (buffer message-textview)
:view message-textview))
(setf *debug-stream* *message-stream*)))
(defmethod print-object ((c model) stream)
"Because I like to know what I'm looking at."
(call-next-method))
(defmodel main-menubar (vbox)
()
(:default-initargs
:kids (list
(mk-menu-bar
:kids (list
(make-instance 'main-file-menu)
(make-instance 'main-tools-menu)
(make-instance 'main-data-menu)
(make-instance 'main-help-menu))))))
#|
(:menus
.... implemented plus
(data "Data"
(#.(menu-comp (:run-all-rules :validation-control-panel... :validation-statistics))
#.(menu-comp (:remove-schema :remove-dataset))))
(options "Options" (#.(menu-comp (:preferences...))))
(help "Help" (#.(menu-comp (:info :patches :report-a-bug)))))
|#
(defmacro choose-and-do ((load-save type char sensitive &key (filters '(("All" "*")))) &body body)
`(mk-image-menu-item
:label ,(if (eql load-save :load) (format nil "Open ~A File..." type) (format nil "Save ~A..." type))
:accel ,(when char `'(,char :alt))
:image (mk-image :stock :open :icon-size :menu) ; pod NYI
:sensitive ,sensitive
:on-activate
(callback (w e d)
(when-bind (file (file-chooser :title ,(format nil "Select ~A File" type)
:select-multiple nil
:filters ,filters
:action ,(if (eql load-save :load) :open :save)))
(setf file (probe-file file)) ; Some calls need a #P pathname
(progn , at body)))))
;;; POD todo: define 'file-action' methods for here and project.lsp.
;;; Better yet, if a gtk-combo-box doesn't have an active (going from nil) set it!!
(defmodel main-file-menu (menu-item)
()
(:default-initargs
:label "File"
:kids (list
(choose-and-do (:load "Project" #\p t :filters '(("Project" "*.pra") ("All" "*")))
(expo::load-project file))
(mk-image-menu-item
:label "Reload Current Project"
:sensitive (c? (current-app *expresso*))
:accel '(#\r :alt)
:image (mk-image :stock :open :icon-size :menu)
:on-activate
(callback (w e d)
(expo::load-project-files (current-app *expresso*))))
(mk-separator-menu-item)
(choose-and-do (:load "EXPRESS" #\e t :filters '(("EXPRESS" "*.exp" "*.p11") ("All" "*")))
(let ((p (make-instance 'expo::project :name "default-project")))
(setf (expo::model-files p)
(list (make-instance 'expo::express-file
:path file
:target-type :lisp
:of-project p)))
(expo::load-project p)))
(choose-and-do (:load "Part 21" #\2 (c? (schema *expresso*))
:filters '(("Part21" "*.p21" "*.stp") ("All" "*")))
(read-data (make-instance 'expo::part21-file :path file)))
(choose-and-do (:load "Express-X" #\x (c? (schema *expresso*))
:filters '(("Express-X" "*.exx") ("All" "*")))
(setf (slot-value *expresso* 'expo::express-x)
(read-schema (make-instance 'expo::express-x-file
:path file))))
(mk-image-menu-item
:label "Quit"
:accel '(#\q :alt)
:image (mk-image :stock :quit :icon-size :menu)
:on-activate (callback (w e d)
(signal 'cgtk:gtk-user-signals-quit))))))
(defmodel main-tools-menu (menu-item)
()
(:default-initargs
:label "Tools"
:kids (list
(mk-menu-item
:label "Express-I Diagram"
:accel '(#\i :alt)
:sensitive nil
:on-activate
(callback (w e d)
(let ((diagram (to-be (make-instance 'instance-diagram))))
(gtk-widget-show-all (widget-id diagram)))))
(mk-menu-item
:label "Data Creator"
:accel '(#\d :alt)
:sensitive nil)
(mk-menu-item
:label "EXPRESS Shell"
:accel '(#\s :alt)
:sensitive nil))))
(defmodel main-data-menu (menu-item)
()
(:default-initargs
:label "Data"
:kids (list
(mk-menu-item
:label "Run All Rules"
:accel '(#\u :alt)
:sensitive nil)
(mk-menu-item
:label "Validation Control Panel"
:accel '(#\v :alt)
:sensitive nil)
(mk-menu-item
:label "Validation Statistics"
:sensitive nil)
(mk-separator-menu-item)
(mk-image-menu-item
:label "Save/Show Dataset..."
:sensitive (c? (datasets *expresso*))
:image (mk-image :stock :save :icon-size :menu)
:on-activate
(callback (w e d)
(handler-bind
((error #'(lambda (err) (abort? *expresso* :condition err))))
(let ((dialog (make-instance 'save-dataset-dialog)))
(to-be dialog)
(when (eql :ok (md-value dialog))
(let ((area (content-area dialog)))
(when-bind (dataset (find (md-value (unique-widget :dataset :root area))
(datasets *expresso*) :key #'name :test #'equal))
(case (md-value (unique-widget :save/show :root area))
(:show
(let ((s (make-string-output-stream)))
(write-db s :p21 :comments nil :raw-data t :dataset dataset)
(write-string (get-output-stream-string s) *message-stream*)))
(:save
(when-bind (fname (md-value (unique-widget :save-fname :root area)))
(let ((fname (string-trim '(#\Space) fname)))
(unless (zerop (length fname)) ; POD would like to remove :raw-data t here...
(with-open-file (s fname :direction :output :if-exists :new-version)
(write-db s :p21 :comments nil :dataset dataset))))))))))))))
(mk-separator-menu-item)
(mk-menu-item
:label "Express-x Maps..."
:accel '(#\x :alt)
:sensitive (c? (some #'(lambda (x) (typep x 'expo:map-schema)) (schemas *expresso*)))
:on-activate (callback (w e d) (let ((dialog (make-instance 'express-x-dialog)))
(to-be dialog)))))))
(defmodel main-help-menu (menu-item)
()
(:default-initargs
:label "Help"
:right-justified t
:kids
(list
(mk-menu-item :label "Quick Help"
:on-activate
(callback (w e d)
(show-message
(format nil
"Expresso is a tool to help develop EXPRESS Schema, and Express-X mappings, and to help validate the conformance of these.
To get started, load in the demonstration project file (.pra file) that ships with the tarball. That project loads two EXPRESS schemas, an Express-X mapping schema, and data. Then try executing the 'Express-X Maps...' entry under the 'Data' toolbar menu item. Doing so brings up a dialog that allows you to execute the Express-X mapping engine. After you run the mapping, use 'Show Instances' (on 'Data' menu) to view the mapped instance in the 'Message Output' buffer.
Don't worry much about 'unresolved attribute ref' messages: The new compiler does far more analysis of the schema than is necessary for running the validation and mapping engines.
Note that as of this writing, (2007-02-10) there are probably some significant bugs remaining and that the tools under the 'Tools' menu item are not yet available. I expect to have time to finish these soon.
Bug reports: peter.denno at nist.gov"))))
(mk-menu-item :label "About"
:on-activate
(callback (w e d)
(show-message
(format nil
"~A~2%Version: ~A~%User: ~A~2%Expresso is built from components of an earlier effort by Craig Lanning and Peter Denno called 'Express Engine'. Express Engine was built on an earlier effort by Peter Denno also called 'Expresso.' Expresso benefits from the development of the EXPRESS metamodel.~%(see http://syseng.nist.gov/se-interop/mexico).
This software is freely available, but not yet on the web. If you are interested in the source, write me: peter.denno at nist.gov.~2%DISCLAIMER: Recipients of this software assume all responsibility associated with its operation, modification, maintenance, and subsequent redistribution."
(expo:ee-version)
#.(or #+Linux "Linux" #+Win32 "Win32" "Unknown")
#.(expo:user-name)
) :title "About Expresso")))
(mk-menu-item :label "Patches"
:on-activate
(callback (w e d)
(show-message
(if-bind (patches (expo::load-expresso-patches :report t))
(format nil "The following patches have been loaded: ~2%~{~a~%~}~%" patches)
(format nil "No patches have been loaded."))
:title "Loaded patches"))))))
;;;================ Message Output =======================================
(defmodel message-output (frame)
()
(:default-initargs
:label "Message Output"
:expand t :fill t
:kids
(list
(mk-vbox
:kids
(list
(mk-hbox
:kids
(list
(mk-button :label "Clear"
:on-clicked
(callback (w e d)
(setf (text (buffer (unique-widget :message-text)))
(format nil "~A" (gensym)))))
(mk-button :label "Save to File"
:on-clicked
(callback (w e d)
(setf (text (buffer (unique-widget :message-text)))
(format nil "~A" (gensym)))))))
(mk-scrolled-window
:kids
(list
(mk-text-view
:md-name :message-text
:buffer (mk-text-buffer
:md-name :message-text-buffer
:tag-table (c? (tv-create-tag-table self))
:text (c-in ""))))))))))
;;;================ Instance Diagram =======================================
(defvar *drawing-area* nil)
(defmodel instance-diagram (window)
()
(:default-initargs
:md-name :instance-diagram :width 700 :height 500 :position :center ))
; :kids
; (list
; (mk-drawing-area
; :md-name :drawing-area :fill t :expand t
; :draw-fn
; #'(lambda (self) )))
; (with-pixmap (p "demo" :widget self :width 100 :height 100)
; (with-gc (p :fg "red") (draw-line p 0 0 100 100))
; (draw-text p "this is text" 10 70)
; (draw-rectangle p 10 10 30 30)
; (draw-rectangle p 1 1 97 97)
; (insert-pixmap p 0 0)
; p))))))
;;;================ Utilities =======================================
(defun kill-gui ()
(when cgtk::*gtk-mailbox*
(mp:mailbox-send cgtk::*gtk-mailbox* :quit)))
(defun gui (&key debug)
(setf cffi:*FOREIGN-LIBRARY-DIRECTORIES*
#+win32(list (format nil "~AGTK\\2\\bin\\" (expo:install-dir)))
#+linux(list (format nil "~AGTK/linux/" (expo:install-dir))))
(VARS cffi:*FOREIGN-LIBRARY-DIRECTORIES*)
(kill-gui)
(cells-gtk-init)
(cgtk:start-app 'cgtk-expresso :debug debug)
(sleep 2)
(when-bind (pos (position "--project" system:*line-arguments-list*
:test #'string-equal))
(when-bind (file (nth (1+ pos) system:*line-arguments-list*))
(when (probe-file (setf file (truename file)))
(expo::load-project file)))))
; (init-graphics-context (widget-id (unique-widget :expresso))))
(defclass bug-mark ()
((condition :initarg :condition)
(mark :initarg :mark)
(line-number :initarg :line-number)))
;;;================================================
;;; Expresso things specialized for the cgtk iface
;;;===============================================
(defmethod expo:abort? ((expresso cgtk-expresso) &key model-file condition text)
"Decide what actions to take (if any) before throwing an error that will
be caught in gtk-app and return control to the gtk event loop."
(typecase condition
(expo:expo-parse-error
(with-slots ((line-number expo::line-number)) condition
(when (and model-file line-number)
(with-slots ((page expo:notebook-page)) model-file
(let ((text-buffer (cells-child-typep page 'cgtk:text-buffer)))
(let ((buf (widget-id text-buffer)))
;; hilite the area
(with-text-iters (start-iter stop-iter) ; gtk line-numbering starts at 0.
(cgtk::gtk-text-buffer-get-iter-at-line buf start-iter (1- line-number))
(cgtk::gtk-text-buffer-get-iter-at-line buf stop-iter line-number)
(let ((start (cgtk::gtk-text-iter-get-offset start-iter))
(stop (1- (cgtk::gtk-text-iter-get-offset stop-iter))))
(apply-markup-at-pos :yellow-background text-buffer start stop))
;; push a bug-mark onto the page's bug marks, so it can be reviewed.
(cells-push
(make-instance 'bug-mark
:condition condition
:mark (cgtk::gtk-text-buffer-create-mark
buf (string (gensym "bug-")) start-iter 1)
:line-number line-number)
(bug-marks page))))))))
(unless text (alert-message (format nil "~A" condition)))
(if-debugging (:any 1)
(break "Break(1) text = ~A" text)
(error 'cgtk:gtk-continuable-error :text (or text "See the message buffer for details."))))
(t
(if-debugging (:any 1)
(break "Break(2) condition = ~A" (format nil "~A" condition))
(error 'cgtk:gtk-continuable-error :text (format nil "~A" condition))))))
(defmethod expo:expo-dot ((iface cgtk-expresso) &key stream (pass 1))
(when-bind (nbp (current-notebook-page))
(when-bind (model-file (notebook-page--model-file nbp))
(with-slots ((size expo::file-size)) model-file
(unless (zerop size)
(when-bind (pos (expo::token-position stream))
(setf (pbar-fraction iface)
(if (= pass 2)
(+ 0.5 (/ pos size 2.0))
(/ pos size 2.0))))))))
(do-gui-events))
More information about the cells-gtk-devel
mailing list