;; Parts of this file are direct translations of code from 'testgtk.c'
;; distributed with the Gtk+ library, and thus covered by the GNU
;; Lesser General Public License and copyright Peter Mattis, Spencer
-;; Kimball, Josh MacDonald and others.
+;; Kimball, Josh MacDonald and others. To be safe the entire file
+;; should probably be considered as being GPL'ed.
-;; $Id: testgtk.lisp,v 1.36 2006/09/05 13:49:26 espen Exp $
+;; $Id: testgtk.lisp,v 1.44 2008/12/09 19:37:19 espen Exp $
#+sbcl(require :gtk)
#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
(defpackage "TESTGTK"
- (:use "COMMON-LISP" "GTK"))
+ (:use "COMMON-LISP" "CLG"))
(in-package "TESTGTK")
;;; Icon View
+#+(or cmu sbcl)
+(defun get-directory-listing (directory)
+ (let ((dir #+cmu(unix:open-dir directory)
+ #+sbcl(sb-posix:opendir directory)))
+ (unwind-protect
+ (loop
+ as filename = #+cmu(unix:read-dir dir)
+ #+sbcl(let ((dirent (sb-posix:readdir dir)))
+ (unless (sb-grovel::foreign-nullp dirent)
+ (sb-posix:dirent-name dirent)))
+ while filename
+ collect (let* ((pathname (format nil "~A~A" directory filename))
+ (directory-p
+ #+cmu(eq (unix:unix-file-kind pathname) :directory)
+ #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
+ (list filename directory-p)))
+ #+cmu(unix:close-dir dir)
+ #+sbcl(sb-posix:closedir dir))))
+
+#+clisp
+(defun get-directory-listing (directory)
+ (nconc
+ (mapcar #'(lambda (entry)
+ (let ((pathname (namestring (first entry))))
+ (list (subseq pathname (1+ (position #\/ pathname :from-end t))) nil)))
+ (directory (format nil "~A*" directory) :full t))
+ (mapcar #'(lambda (entry)
+ (let ((pathname (namestring entry)))
+ (list (subseq pathname (1+ (position #\/ pathname :from-end t :end (1- (length pathname)))) (1- (length pathname))) nil)))
+
+ (directory (format nil "~A*/" directory)))))
+
+
#?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
(let ((file-pixbuf nil)
(folder-pixbuf nil))
(unless file-pixbuf
(handler-case
(setf
- file-pixbuf (gdk:pixbuf-load #p"/usr/share/icons/gnome/48x48/filesystems/gnome-fs-regular.png")
- folder-pixbuf (gdk:pixbuf-load #p"/usr/share/icons/gnome/48x48/filesystems/gnome-fs-directory.png"))
+ file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
+ folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
(glib:glib-error (condition)
(make-instance 'message-dialog
:message-type :error :visible t
:text "<b>Failed to load an image</b>"
:secondary-text (glib:gerror-message condition)
- :signal (list :close #'widget-destroy :object t))
+ :signal (list :ok #'widget-destroy :object t))
(return-from load-pixbufs nil))))
t)
(defun fill-store (store directory)
- (list-store-clear store)
- (let ((dir-listing
- (mapcar #'namestring
- (nconc
- (directory (format nil "~A*" directory))
- #+clisp(directory (format nil "~A*/" directory))))))
- (loop
- for pathname in dir-listing
- do (let* ((directory-p
- (char= #\/ (char pathname (1- (length pathname)))))
- (filename
- (subseq pathname
- (length directory)
- (if directory-p
- (1- (length pathname))
- (length pathname)))))
- (list-store-append store
- (vector
- filename
- (if directory-p folder-pixbuf file-pixbuf)
- directory-p))))))
+ (list-store-clear store)
+ (loop
+ for (filename directory-p) in (get-directory-listing directory)
+ unless (or (string= filename ".") (string= filename ".."))
+ do (list-store-insert store 0
+ (vector
+ filename
+ (if directory-p folder-pixbuf file-pixbuf)
+ directory-p))))
(defun sort-func (store a b)
(let ((a-dir-p (tree-model-value store a 'directory-p))
:column-names '(filename pixbuf directory-p)))
(icon-view (make-instance 'icon-view
:model store :selection-mode :multiple
- :text-column 0 ;'filename
- :pixbuf-column 1)) ;'pixbuf))
+ :text-column 'filename
+ :pixbuf-column 'pixbuf))
(up (make-instance 'tool-button
:stock "gtk-go-up" :is-important t :sensitive nil))
(home (make-instance 'tool-button
(let ((column (make-instance 'tree-view-column :title "Column 1"))
(cell (make-instance 'cell-renderer-text)))
(cell-layout-pack column cell :expand t)
- (cell-layout-add-attribute column cell 'text (column-index store :foo))
+ (cell-layout-add-attribute column cell 'text (tree-model-column-index store :foo))
(tree-view-append-column tree column))
(let ((column (make-instance 'tree-view-column :title "Column 2"))
(cell (make-instance 'cell-renderer-text :background "orange")))
(cell-layout-pack column cell :expand t)
- (cell-layout-add-attribute column cell 'text (column-index store :bar))
+ (cell-layout-add-attribute column cell 'text (tree-model-column-index store :bar))
(tree-view-append-column tree column))
(let ((column (make-instance 'tree-view-column :title "Column 3"))
(cell (make-instance 'cell-renderer-text)))
(cell-layout-pack column cell :expand t)
- (cell-layout-add-attribute column cell 'text (column-index store :baz))
+ (cell-layout-add-attribute column cell 'text (tree-model-column-index store :baz))
(tree-view-append-column tree column))
(make-instance 'v-box
(define-simple-dialog create-notebook (dialog "Notebook")
(let ((main (make-instance 'v-box :parent dialog)))
- (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
- (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
+ (let ((book-open (make-instance 'gdk:pixbuf :source book-open-xpm))
+ (book-closed (make-instance 'gdk:pixbuf :source book-closed-xpm))
(notebook (make-instance 'notebook
:border-width 10 :tab-pos :top :parent main)))
:child (create-label "Below")))
-;;; Tooltips test
+;;; Tooltips test. Note that GtkTooltips has been deprecated in GTK+ 2.12
(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
(let ((tooltips (make-instance 'tooltips)))
;;; Main window
-(defun create-main-window ()
+(defun create-main-window (&optional display)
(let* ((button-specs
'(("button box" create-button-box)
("buttons" create-buttons)
("UI manager" create-ui-manager)))
(main-window (make-instance 'window
+ :display display
:title "testgtk.lisp" :name "main_window"
:default-width 200 :default-height 400
:allow-grow t :allow-shrink nil))
:border-width 10))
(close-button (make-instance 'button
:stock "gtk-close" :can-default t
- :signal (list 'clicked #'widget-destroy :object main-window))))
+ :signal (list 'clicked #'widget-destroy :object main-window))))
(let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
(setf
main-window))
(clg-init)
-(create-main-window)
-
+(within-main-loop (create-main-window))
~mdw / clg / blobdiff