X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/c8ed5c850bba590c598c4b75c6d6111f68d75bbd..bdc6c9af7d393852dcb0c795c94663642d1d5196:/examples/testgtk.lisp diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index 915bba3..858d894 100644 --- a/examples/testgtk.lisp +++ b/examples/testgtk.lisp @@ -26,13 +26,13 @@ ;; Kimball, Josh MacDonald and others. -;; $Id: testgtk.lisp,v 1.36 2006-09-05 13:49:26 espen Exp $ +;; $Id: testgtk.lisp,v 1.41 2007-07-12 09:18:30 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") @@ -497,6 +497,39 @@ (define-toplevel create-font-selection (window "Font Button" :resizable nil) ;;; 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)) @@ -504,39 +537,27 @@ (defun load-pixbufs () (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 "Failed to load an image" :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)) @@ -566,8 +587,8 @@ (define-toplevel create-icon-view (window "Icon View demo" :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 @@ -739,19 +760,19 @@ (define-simple-dialog create-list (dialog "List" :default-height 400) (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 @@ -1888,7 +1909,7 @@ (define-toplevel create-ui-manager (window "UI Manager") ;;; Main window -(defun create-main-window () +(defun create-main-window (&optional display) (let* ((button-specs '(("button box" create-button-box) ("buttons" create-buttons) @@ -1933,6 +1954,7 @@ (defun create-main-window () ("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)) @@ -1942,7 +1964,7 @@ (defun create-main-window () :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 @@ -1986,5 +2008,4 @@ (defun create-main-window () main-window)) (clg-init) -(create-main-window) - +(within-main-loop (create-main-window))