From: Olof-Joachim Frahm Date: Sun, 26 Aug 2012 13:32:23 +0000 (+0200) Subject: Merge commit 'ae006838093cfeb67b3818526622fb5cb61d5300' of git://github.com/scymtym... X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=df14f83197720a24523af803ea4d287a677534fb;hp=ae006838093cfeb67b3818526622fb5cb61d5300;p=cl-gtk2.git Merge commit 'ae006838093cfeb67b3818526622fb5cb61d5300' of git://github.com/scymtym/cl-gtk2 --- diff --git a/gdk/gdk.objects.lisp b/gdk/gdk.objects.lisp index 3c540be..14cb5be 100644 --- a/gdk/gdk.objects.lisp +++ b/gdk/gdk.objects.lisp @@ -435,6 +435,22 @@ (:bilevel 0) (:full 1)) +(define-g-enum "GdkInterpType" + gdk-interp-type + (:export t :type-initializer "gdk_interp_type_get_type") + (:nearest 0) + (:tiles 1) + (:bilinear 2) + (:hyper 3)) + +(define-g-enum "GdkPixbufRotation" + gdk-pixbuf-rotation + (:export t :type-initializer "gdk_pixbuf_rotation_get_type") + (:none 0) + (:counterclockwise 90) + (:upsidedown 180) + (:clockwise 270)) + (define-g-enum "GdkColorspace" colorspace () :rgb) @@ -937,7 +953,7 @@ ((:cffi visual colormap-visual (g-object visual) "gdk_colormap_get_visual" nil) (:cffi screen colormap-screen (g-object screen) - "gdk_colormap_get_screeen" nil))) + "gdk_colormap_get_screen" nil))) (define-g-object-class "GdkScreen" screen (:type-initializer "gdk_screen_get_type") ((font-options screen-font-options "font-options" "gpointer" t t) diff --git a/gdk/gdk.package.lisp b/gdk/gdk.package.lisp index 3de1687..0e4f12b 100644 --- a/gdk/gdk.package.lisp +++ b/gdk/gdk.package.lisp @@ -8,16 +8,19 @@ (glib:at-init () (eval-when (:compile-toplevel :load-toplevel :execute) (define-foreign-library gdk - (:unix (:or "libgdk-x11-2.0.so.0" "libgdk-x11-2.0.so")) + ((:and :unix (:not :darwin)) (:or "libgdk-x11-2.0.so.0" "libgdk-x11-2.0.so")) + (:darwin (:or "libgdk-x11-2.0.0.dylib" "libgdk-x11-2.0.dylib")) (:windows "libgdk-win32-2.0-0.dll") (t "libgdk-2.0")) (define-foreign-library gdk-pixbuf - (:unix (:or "libgdk_pixbuf-2.0.so.0" "libgdk_pixbuf-2.0.so")) + ((:and :unix (:not :darwin)) (:or "libgdk_pixbuf-2.0.so.0" "libgdk_pixbuf-2.0.so")) + (:darwin (:or "libgdk_pixbuf-2.0.0.dylib" "libgdk_pixbuf-2.0.dylib")) (:windows (:or "libgdk_pixbuf-win32-2.0-0" "libgdk_pixbuf-2.0-0.dll")) (t "libgdk_pixbuf-2.0")) - + (define-foreign-library gtk - (:unix (:or "libgtk-x11-2.0.so.0" "libgtk-x11-2.0.so")) + ((:and :unix (:not :darwin)) (:or "libgtk-x11-2.0.so.0" "libgtk-x11-2.0.so")) + (:darwin (:or "libgtk-x11-2.0.0.dylib" "libgtk-x11-2.0.dylib")) (:windows (:or "libgtk-2.0-0.dll" "libgtk-win32-2.0-0.dll")) (t "libgtk-2.0"))) diff --git a/gdk/gdk.pixbufs.lisp b/gdk/gdk.pixbufs.lisp index 91c7427..1908e96 100644 --- a/gdk/gdk.pixbufs.lisp +++ b/gdk/gdk.pixbufs.lisp @@ -106,3 +106,90 @@ (gdk-pixbuf-get-from-image pixbuf image (null-pointer) src-x src-y dest-x dest-y width height)) (export 'pixbuf-get-from-image) + +(defcfun gdk-pixbuf-scale-simple (g-object pixbuf :already-referenced) + (src (g-object pixbuf)) + (dest-width :int) + (dest-height :int) + (interp-type gdk-interp-type)) + +(defun pixbuf-scale-simple (pixbuf dest-width dest-height &key (interp-type :bilinear)) + (gdk-pixbuf-scale-simple pixbuf dest-width dest-height interp-type)) + +(export 'pixbuf-scale-simple) + +(defcfun (pixbuf-scale "gdk_pixbuf_scale") :void + (src (g-object pixbuf)) + (dest (g-object pixbuf)) + (dest-x :int) + (dest-y :int) + (dest-width :int) + (dest-height :int) + (offset-x :double) + (offset-y :double) + (scale-x :double) + (scale-y :double) + (interp-type gdk-interp-type)) + +(export 'pixbuf-scale) + +(defcfun (pixbuf-composite-color-simple "gdk_pixbuf_composite_color_simple") (g-object pixbuf :already-referenced) + (src (g-object pixbuf)) + (dest-width :int) + (dest-height :int) + (interp-type gdk-interp-type) + (overall-alpha :int) + (check-size :int) + (color-1 :uint32) + (color-2 :uint32)) + +(export 'pixbuf-composite-color-simple) + +(defcfun (pixbuf-composite "gdk_pixbuf_composite") :void + (src (g-object pixbuf)) + (dest (g-object pixbuf)) + (dest-x :int) + (dest-y :int) + (dest-width :int) + (dest-height :int) + (offset-x :double) + (offset-y :double) + (scale-x :double) + (scale-y :double) + (interp-type gdk-interp-type) + (overall-alpha :int)) + +(export 'pixbuf-composite) + +(defcfun (pixbuf-composite-color "gdk_pixbuf_composite_color") :void + (src (g-object pixbuf)) + (dest (g-object pixbuf)) + (dest-x :int) + (dest-y :int) + (dest-width :int) + (dest-height :int) + (offset-x :double) + (offset-y :double) + (scale-x :double) + (scale-y :double) + (interp-type gdk-interp-type) + (overall-alpha :int) + (check-x :int) + (check-y :int) + (check-size :int) + (color-1 :uint32) + (color-2 :uint32)) + +(export 'pixbuf-composite-color) + +(defcfun (pixbuf-rotate-simple "gdk_pixbuf_rotate_simple") (g-object pixbuf :already-referenced) + (src (g-object pixbuf)) + (angle gdk-pixbuf-rotation)) + +(export 'pixbuf-rotate-simple) + +(defcfun (pixbuf-flip "gdk_pixbuf_flip") (g-object pixbuf :already-referenced) + (src (g-object pixbuf)) + (horizontal :boolean)) + +(export 'pixbuf-flip) diff --git a/generating.lisp b/generating.lisp index 16ee694..5115593 100644 --- a/generating.lisp +++ b/generating.lisp @@ -191,6 +191,9 @@ nil "gtk_menu_tool_button_set_arrow_tooltip_text") (:cffi gtk::arrow-tooltip-markup gtk::menu-tool-button-arrow-tooltip-markup :string nil "gtk_menu_tool_button_set_arrow_tooltip_markup")) + ("GtkRadioButton" + (:cffi gtk::group gtk::radio-button-group (gslist gtk::radio-button :free-from-foreign nil :free-to-foreign nil) + nil "gtk_radio_button_set_group")) ("GtkUIManager" (:cffi gtk::accel-group gtk::ui-manager-accel-group g-object "gtk_ui_manager_get_accel_group" nil)) @@ -207,15 +210,27 @@ ("GtkFileChooser" (:cffi gtk::current-name gtk::file-chooser-current-name (:string :free-to-foreign t :encoding :utf-8) nil "gtk_file_chooser_set_current_name") - (:cffi gtk::filename gtk::file-chooser-filename (glib:g-string :free-from-foreign t :free-to-foreign t) + (:cond :+win32 + :cffi gtk::filename gtk::file-chooser-filename (glib:g-string :free-from-foreign t :free-to-foreign t) + "gtk_file_chooser_get_filename_utf8" "gtk_file_chooser_set_filename_utf8") + (:cond :-win32 + :cffi gtk::filename gtk::file-chooser-filename (glib:g-string :free-from-foreign t :free-to-foreign t) "gtk_file_chooser_get_filename" "gtk_file_chooser_set_filename") - (:cffi gtk::current-folder gtk::file-chooser-current-folder (glib:g-string :free-from-foreign t :free-to-foreign t) + (:cond :+win32 + :cffi gtk::current-folder gtk::file-chooser-current-folder (glib:g-string :free-from-foreign t :free-to-foreign t) + "gtk_file_chooser_get_current_folder_utf8" "gtk_file_chooser_set_current_folder_utf8") + (:cond :-win32 + :cffi gtk::current-folder gtk::file-chooser-current-folder (glib:g-string :free-from-foreign t :free-to-foreign t) "gtk_file_chooser_get_current_folder" "gtk_file_chooser_set_current_folder") (:cffi gtk::uri gtk::file-chooser-uri (glib:g-string :free-from-foreign t :free-to-foreign t) "gtk_file_chooser_get_uri" "gtk_file_chooser_set_uri") (:cffi gtk::current-folder-uri gtk::file-chooser-current-folder-uri (glib:g-string :free-from-foreign t :free-to-foreign t) "gtk_file_chooser_get_current_folder_uri" "gtk_file_chooser_set_current_folder_uri") - (:cffi gtk::preview-filename gtk::file-chooser-preview-filename (glib:g-string :free-from-foreign t :free-to-foreign t) + (:cond :+win32 + :cffi gtk::preview-filename gtk::file-chooser-preview-filename (glib:g-string :free-from-foreign t :free-to-foreign t) + "gtk_file_chooser_get_preview_filename_utf8" nil) + (:cond :-win32 + :cffi gtk::preview-filename gtk::file-chooser-preview-filename (glib:g-string :free-from-foreign t :free-to-foreign t) "gtk_file_chooser_get_preview_filename" nil) (:cffi gtk::preview-uri gtk::file-chooser-preview-uri (glib:g-string :free-from-foreign t :free-to-foreign t) "gtk_file_chooser_get_preview_uri" nil)) diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd index 908923f..92dcb35 100644 --- a/glib/cl-gtk2-glib.asd +++ b/glib/cl-gtk2-glib.asd @@ -11,6 +11,7 @@ (:file "glib.quark") (:file "glib.gerror") (:file "glib.utils") + (:file "glib.rand") (:file "gobject.init") (:file "gobject.ffi.package") diff --git a/glib/glib.glist.lisp b/glib/glib.glist.lisp index 22ea6bc..1a8ff3c 100644 --- a/glib/glib.glist.lisp +++ b/glib/glib.glist.lisp @@ -51,6 +51,8 @@ (data :pointer) (next :pointer)) +(defcfun g-slist-alloc (:pointer g-slist)) + (defcfun g-slist-free :void (list (:pointer g-slist))) (defun g-slist-next (list) @@ -64,4 +66,19 @@ (until (null-pointer-p c)) (collect (convert-from-foreign (foreign-slot-value c 'g-slist 'data) (gslist-type-type type)))) (when (gslist-type-free-from-foreign type) - (g-slist-free pointer)))) \ No newline at end of file + (g-slist-free pointer)))) + +(defmethod translate-to-foreign (list (type gslist-type)) + (let ((result (null-pointer)) last) + (iter (for item in list) + (for n = (g-slist-alloc)) + (for ptr = (convert-to-foreign item (gslist-type-type type))) + (setf (foreign-slot-value n 'g-slist 'data) ptr) + (setf (foreign-slot-value n 'g-slist 'next) (null-pointer)) + (when last + (setf (foreign-slot-value last 'g-slist 'next) n)) + (setf last n) + (when (first-iteration-p) + (setf result n))) + result)) + diff --git a/glib/glib.lisp b/glib/glib.lisp index cdd1d1a..bf6e9d6 100644 --- a/glib/glib.lisp +++ b/glib/glib.lisp @@ -101,12 +101,14 @@ In this example, for every @code{class}, @code{(initialize-gobject-class-g-type (at-init () (eval-when (:compile-toplevel :load-toplevel :execute) (define-foreign-library glib - (:unix (:or "libglib-2.0.so.0" "libglib-2.0.so")) + ((:and :unix (:not :darwin)) (:or "libglib-2.0.so.0" "libglib-2.0.so")) + (:darwin (:or "libglib-2.0.0.dylib" "libglib-2.0.dylib")) (:windows "libglib-2.0-0.dll") (t (:default "libglib-2.0")))) (eval-when (:compile-toplevel :load-toplevel :execute) (define-foreign-library gthread - (:unix (:or "libgthread-2.0.so.0" "libgthread-2.0.so")) + ((:and :unix (:not :darwin)) (:or "libgthread-2.0.so.0" "libgthread-2.0.so")) + (:darwin (:or "libgthread-2.0.0.dylib" "libgthread-2.0.dylib")) (:windows "libgthread-2.0-0.dll") (t "libgthread-2.0"))) diff --git a/glib/glib.rand.lisp b/glib/glib.rand.lisp new file mode 100644 index 0000000..4849f73 --- /dev/null +++ b/glib/glib.rand.lisp @@ -0,0 +1,32 @@ +(in-package :glib) + +(defcfun (random-set-seed "g_random_set_seed") :void + (seed :uint32)) + +(export 'random-set-seed) + +(defcfun (random-int "g_random_int") :uint32) + +(export 'random-int) + +(defcfun (random-int-range "g_random_int_range") :int32 + (begin :int32) + (end :int32)) + +(export 'random-int-range) + +(defun random-boolean () + (logtest (random-int) #X8000)) + +(export 'random-boolean) + +(defcfun (random-double "g_random_double") :double) + +(export 'random-double) + +(defcfun (random-double-range "g_random_double_range") :double + (begin :double) + (end :double)) + +(export 'random-double-range) + diff --git a/glib/gobject.generating.lisp b/glib/gobject.generating.lisp index 0560ddb..df57b56 100644 --- a/glib/gobject.generating.lisp +++ b/glib/gobject.generating.lisp @@ -240,6 +240,12 @@ (write-char (char-downcase c) stream)) (write-string "_get_type" stream))) +(defclass print-readtime-condition () + ((condition :initarg :condition))) + +(defmethod print-object ((o print-readtime-condition) stream) + (format stream "#~A" (slot-value o 'condition))) + (defun get-g-class-definition (type &optional lisp-name-package) (when (and (stringp type) (null (ignore-errors (gtype type)))) (let ((type-init-name (probable-type-init-name type))) @@ -269,7 +275,11 @@ (,@(mapcar (lambda (property) (property->property-definition name property)) own-properties) - ,@(cdr (find g-name *additional-properties* :key 'car :test 'string=)))))) + ,@(mapcan (lambda (property-definition) + (if (eq :cond (car property-definition)) + (list (make-instance 'print-readtime-condition :condition (cadr property-definition)) (cddr property-definition)) + (list property-definition))) + (cdr (find g-name *additional-properties* :key 'car :test 'string=))))))) (defun get-g-interface-definition (interface &optional lisp-name-package) (when (and (stringp interface) (null (ignore-errors (gtype interface)))) @@ -292,7 +302,11 @@ ,@(append (mapcar (lambda (property) (property->property-definition name property)) properties) - (cdr (find g-name *additional-properties* :key 'car :test 'string=)))))) + (mapcan (lambda (property-definition) + (if (eq :cond (car property-definition)) + (list (make-instance 'print-readtime-condition :condition (cadr property-definition)) (cddr property-definition)) + (list property-definition))) + (cdr (find g-name *additional-properties* :key 'car :test 'string=))))))) (defun get-g-class-definitions-for-root-1 (type) (unless (member (gtype type) *generation-exclusions* :test 'g-type=) diff --git a/glib/gobject.init.lisp b/glib/gobject.init.lisp index 9c94cf9..aabf1f7 100644 --- a/glib/gobject.init.lisp +++ b/glib/gobject.init.lisp @@ -6,7 +6,8 @@ (at-init () (eval-when (:compile-toplevel :load-toplevel :execute) (cffi:define-foreign-library gobject - (:unix (:or "libgobject-2.0.so.0" "libgobject-2.0.so")) + ((:and :unix (:not :darwin)) (:or "libgobject-2.0.so.0" "libgobject-2.0.so")) + (:darwin (:or "libgobject-2.0.0.dylib" "libgobject-2.0.dylib")) (:windows "libgobject-2.0-0.dll") (t "libgobject-2.0"))) diff --git a/glib/gobject.object.high.lisp b/glib/gobject.object.high.lisp index db156d1..f2b07b2 100644 --- a/glib/gobject.object.high.lisp +++ b/glib/gobject.object.high.lisp @@ -161,11 +161,11 @@ (gethash name *registered-object-types*)) (defun get-g-object-lisp-type (g-type) (setf g-type (gtype g-type)) - (loop - while (not (null g-type)) - for lisp-type = (gethash (gtype-name g-type) *registered-object-types*) - when lisp-type do (return lisp-type) - do (setf g-type (g-type-parent g-type)))) + (iter (while (not (null g-type))) + (for lisp-type = (gethash (gtype-name g-type) *registered-object-types*)) + (when lisp-type + (return lisp-type)) + (setf g-type (g-type-parent g-type)))) (defun make-g-object-from-pointer (pointer) (let* ((g-type (g-type-from-instance pointer)) diff --git a/gtk/cl-gtk2-gtk.asd b/gtk/cl-gtk2-gtk.asd index 6eaf650..7b10475 100644 --- a/gtk/cl-gtk2-gtk.asd +++ b/gtk/cl-gtk2-gtk.asd @@ -24,6 +24,7 @@ (:file "gtk.functions") (:file "gtk.base-classes") (:file "gtk.dialog") + (:file "gtk.about-dialog") (:file "gtk.window") (:file "gtk.window-group") (:file "gtk.icon-factory") @@ -59,6 +60,7 @@ (:file "gtk.paned") (:file "gtk.child-properties") (:file "gtk.widget") + (:file "gtk.tree-view-dnd") (:file "gtk.builder") (:file "gtk.assistant") (:file "gtk.link-button") diff --git a/gtk/gtk.about-dialog.lisp b/gtk/gtk.about-dialog.lisp new file mode 100644 index 0000000..2d36cdc --- /dev/null +++ b/gtk/gtk.about-dialog.lisp @@ -0,0 +1,60 @@ +(in-package :gtk) + +(defvar *about-dialog-url-func* nil) + +(defcallback about-dialog-url-func-cb :void + ((dialog (g-object about-dialog)) (link (:string :free-from-foreign nil)) (user-data :pointer)) + (declare (ignore user-data)) + (funcall *about-dialog-url-func* dialog link)) + +(defcallback about-dialog-url-func-destroy-cb :void + ((data :pointer)) + (declare (ignore data)) + (setf *about-dialog-url-func* nil)) + +(defcfun gtk-about-dialog-set-url-hook :void + (func :pointer) + (data :pointer) + (destroy-notify :pointer)) + +(defun (setf about-dialog-global-url-hook) (new-value) + (if new-value + (gtk-about-dialog-set-url-hook (callback about-dialog-url-func-cb) + (null-pointer) + (callback about-dialog-url-func-destroy-cb)) + (gtk-about-dialog-set-url-hook (null-pointer) + (null-pointer) + (null-pointer))) + (setf *about-dialog-url-func* new-value)) + +(export 'about-dialog-global-url-hook) + +(defvar *about-dialog-email-func* nil) + +(defcallback about-dialog-email-func-cb :void + ((dialog (g-object about-dialog)) (link (:string :free-from-foreign nil)) (user-data :pointer)) + (declare (ignore user-data)) + (funcall *about-dialog-email-func* dialog link)) + +(defcallback about-dialog-email-func-destroy-cb :void + ((data :pointer)) + (declare (ignore data)) + (setf *about-dialog-email-func* nil)) + +(defcfun gtk-about-dialog-set-email-hook :void + (func :pointer) + (data :pointer) + (destroy-notify :pointer)) + +(defun (setf about-dialog-global-email-hook) (new-value) + (if new-value + (gtk-about-dialog-set-email-hook (callback about-dialog-email-func-cb) + (null-pointer) + (callback about-dialog-email-func-destroy-cb)) + (gtk-about-dialog-set-email-hook (null-pointer) + (null-pointer) + (null-pointer))) + (setf *about-dialog-email-func* new-value)) + +(export 'about-dialog-global-email-hook) + diff --git a/gtk/gtk.generated-classes.lisp b/gtk/gtk.generated-classes.lisp index 6c98971..5c27690 100644 --- a/gtk/gtk.generated-classes.lisp +++ b/gtk/gtk.generated-classes.lisp @@ -1084,9 +1084,20 @@ (:cffi current-name file-chooser-current-name (:string :free-to-foreign t :encoding :utf-8) nil "gtk_file_chooser_set_current_name") + #+win32 + (:cffi filename file-chooser-filename + (g-string :free-from-foreign t :free-to-foreign t) + "gtk_file_chooser_get_filename_utf8" "gtk_file_chooser_set_filename_utf8") + #-win32 (:cffi filename file-chooser-filename (g-string :free-from-foreign t :free-to-foreign t) "gtk_file_chooser_get_filename" "gtk_file_chooser_set_filename") + #+win32 + (:cffi current-folder file-chooser-current-folder + (g-string :free-from-foreign t :free-to-foreign t) + "gtk_file_chooser_get_current_folder_utf8" + "gtk_file_chooser_set_current_folder_utf8") + #-win32 (:cffi current-folder file-chooser-current-folder (g-string :free-from-foreign t :free-to-foreign t) "gtk_file_chooser_get_current_folder" "gtk_file_chooser_set_current_folder") @@ -1097,6 +1108,11 @@ (g-string :free-from-foreign t :free-to-foreign t) "gtk_file_chooser_get_current_folder_uri" "gtk_file_chooser_set_current_folder_uri") + #+win32 + (:cffi preview-filename file-chooser-preview-filename + (g-string :free-from-foreign t :free-to-foreign t) + "gtk_file_chooser_get_preview_filename_utf8" nil) + #-win32 (:cffi preview-filename file-chooser-preview-filename (g-string :free-from-foreign t :free-to-foreign t) "gtk_file_chooser_get_preview_filename" nil) @@ -1696,8 +1712,10 @@ (:superclass check-button :export t :interfaces ("AtkImplementorIface" "GtkActivatable" "GtkBuildable") :type-initializer "gtk_radio_button_get_type") - ((group radio-button-group "group" "GtkRadioButton" nil - t))) + ((:cffi group radio-button-group + (gslist g-object :free-from-foreign nil + :free-to-foreign nil) + "gtk_radio_button_get_group" "gtk_radio_button_set_group"))) (define-g-object-class "GtkComboBox" combo-box (:superclass bin :export t :interfaces diff --git a/gtk/gtk.main_loop_events.lisp b/gtk/gtk.main_loop_events.lisp index d3abfde..4bac720 100644 --- a/gtk/gtk.main_loop_events.lisp +++ b/gtk/gtk.main_loop_events.lisp @@ -84,4 +84,4 @@ (defcfun gtk-grab-get-current g-object) (defcfun gtk-grab-remove :void - (widget g-object)) \ No newline at end of file + (widget g-object)) diff --git a/gtk/gtk.selectors.lisp b/gtk/gtk.selectors.lisp index c09a509..f08c6de 100644 --- a/gtk/gtk.selectors.lisp +++ b/gtk/gtk.selectors.lisp @@ -43,13 +43,15 @@ ; TODO: gtk_color_selection_set_change_palette_with_screen_hook -(defcfun (file-chooser-select-filename "gtk_file_chooser_select_filename") :boolean +(defcfun (file-chooser-select-filename #+win32 "gtk_file_chooser_select_filename_utf8" + #-win32 "gtk_file_chooser_select_filename") :boolean (file-chooser g-object) (filename :string)) (export 'file-chooser-select-filename) -(defcfun (file-chooser-unselect-filename "gtk_file_chooser_unselect_filename") :void +(defcfun (file-chooser-unselect-filename #+win32 "gtk_file_chooser_unselect_filename_utf8" + #-win32 "gtk_file_chooser_unselect_filename") :void (file-chooser g-object) (filename :string)) @@ -65,7 +67,8 @@ (export 'file-chooser-unselect-all) -(defcfun (file-chooser-filenames "gtk_file_chooser_get_filenames") (gslist (g-string :free-from-foreign t)) +(defcfun (file-chooser-filenames #+win32 "gtk_file_chooser_get_filenames_utf8" + #-win32 "gtk_file_chooser_get_filenames") (gslist (g-string :free-from-foreign t)) (file-chooser g-object)) (export 'file-chooser-filenames) @@ -104,7 +107,8 @@ (export 'file-chooser-filters) -(defcfun gtk-file-chooser-add-shortcut-folder :boolean +(defcfun (gtk-file-chooser-add-shortcut-folder #+win32 "gtk_file_chooser_add_shortcut_folder_utf8" + #-win32 "gtk_file_chooser_add_shortcut_folder") :boolean (file-chooser g-object) (folder :string) (error :pointer)) @@ -114,7 +118,8 @@ (export 'file-chooser-add-shortcut-folder) -(defcfun gtk-file-chooser-remove-shortcut-folder :boolean +(defcfun (gtk-file-chooser-remove-shortcut-folder #+win32 "gtk_file_chooser_remove_shortcut_folder_utf8" + #-win32 "gtk_file_chooser_remove_shortcut_folder") :boolean (file-chooser g-object) (folder :string) (error :pointer)) @@ -124,7 +129,8 @@ (export 'file-chooser-remove-shortcut-folder) -(defcfun (file-chooser-shortcut-folders "gtk_file_chooser_list_shortcut_folders") (gslist (g-string :free-from-foreign t)) +(defcfun (file-chooser-shortcut-folders #+win32 "gtk_file_chooser_list_shortcut_folders_utf8" + #-win32 "gtk_file_chooser_list_shortcut_folders") (gslist (g-string :free-from-foreign t)) (file-chooser g-object)) (export 'file-chooser-shortcut-folders) diff --git a/gtk/gtk.tree-model.lisp b/gtk/gtk.tree-model.lisp index 4b8f813..edbcbd1 100644 --- a/gtk/gtk.tree-model.lisp +++ b/gtk/gtk.tree-model.lisp @@ -547,10 +547,11 @@ (gethash id (tree-lisp-store-id-map tree))) (defmethod tree-model-get-iter-impl ((store tree-lisp-store) iter path) - (let* ((node (get-node-by-path store path)) - (node-idx (get-assigned-id store node))) - (setf (tree-iter-stamp iter) 0 - (tree-iter-user-data iter) node-idx))) + (ignore-errors + (let* ((node (get-node-by-path store path)) + (node-idx (get-assigned-id store node))) + (setf (tree-iter-stamp iter) 0 + (tree-iter-user-data iter) node-idx)))) (defun get-node-by-iter (tree iter) (get-node-by-id tree (tree-iter-user-data iter))) diff --git a/gtk/gtk.tree-view-column.lisp b/gtk/gtk.tree-view-column.lisp index da1e3a1..ca86c4c 100644 --- a/gtk/gtk.tree-view-column.lisp +++ b/gtk/gtk.tree-view-column.lisp @@ -48,7 +48,7 @@ (free-stable-pointer data)) (defcfun gtk-tree-view-column-set-cell-data-func :void - (tree-column (g-object tree-column)) + (tree-column (g-object tree-view-column)) (cell-renderer (g-object cell-renderer)) (func :pointer) (func-data :pointer) @@ -62,6 +62,8 @@ (allocate-stable-pointer function) (callback gtk-tree-cell-data-func-destroy-cb))) +(export 'tree-view-column-set-cell-data-function) + (defcfun (tree-view-column-clear-attributes "gtk_tree_view_column_clear_attributes") :void (tree-column (g-object tree-column)) (cell-renderer (g-object cell-renderer))) diff --git a/gtk/gtk.tree-view-dnd.lisp b/gtk/gtk.tree-view-dnd.lisp new file mode 100644 index 0000000..224ace6 --- /dev/null +++ b/gtk/gtk.tree-view-dnd.lisp @@ -0,0 +1,28 @@ +(in-package :gtk) + +(define-vtable ("GtkTreeDragSource" tree-drag-source) + (:skip parent-instance g-type-interface) + ;;methods + (row-draggable (:boolean + (tree-drag-source g-object) + (path (g-boxed-foreign tree-path)))) + (drag-data-get (:boolean + (tree-drag-source g-object) + (path (g-boxed-foreign tree-path)) + (selection-data (g-boxed-foreign selection-data)))) + (drag-data-delete (:boolean + (tree-drag-source g-object) + (path (g-boxed-foreign tree-path))))) + +(define-vtable ("GtkTreeDragDest" tree-drag-dest) + (:skip parent-instance g-type-interface) + ;;methods + (drag-data-received (:boolean + (tree-drag-dest g-object) + (path (g-boxed-foreign tree-path)) + (selection-data (g-boxed-foreign selection-data)))) + (row-drop-possible (:boolean + (tree-drag-dest g-object) + (path (g-boxed-foreign tree-path)) + (selection-data (g-boxed-foreign selection-data))))) + diff --git a/gtk/ui-markup.lisp b/gtk/ui-markup.lisp index bb3c090..f64c4d4 100644 --- a/gtk/ui-markup.lisp +++ b/gtk/ui-markup.lisp @@ -45,88 +45,75 @@ (unless (eq (ui-prop-name prop) :var) (appending (list (ui-prop-name prop) (ui-prop-value prop))))))) -(defvar *ui-child-packers* (make-hash-table)) - -(defmacro def-ui-child-packer (class (var child-def child) &body body) - `(setf (gethash ',class *ui-child-packers*) - (lambda (,var ,child-def ,child) ,@body))) - -(def-ui-child-packer container (w d child) - (declare (ignore d)) - `(container-add ,w ,child)) - -(defun get-ui-child-prop-value (d name required-p context) - (let ((prop (find name (ui-child-props d) :key #'ui-prop-name))) - (if (and required-p (null prop)) - (error "~A is a mandatory child property for ~A" name context) - (when prop (ui-prop-value prop))))) - -(def-ui-child-packer box (b d child) - (let ((expand-prop (find :expand (ui-child-props d) :key #'ui-prop-name)) - (fill-prop (find :fill (ui-child-props d) :key #'ui-prop-name)) - (padding-prop (find :padding (ui-child-props d) :key #'ui-prop-name)) - (pack-type-prop (find :pack-type (ui-child-props d) :key #'ui-prop-name))) - `(progn - (box-pack-start ,b ,child - ,@(when expand-prop (list :expand (ui-prop-value expand-prop))) - ,@(when fill-prop (list :fill (ui-prop-value fill-prop))) - ,@(when padding-prop (list :padding (ui-prop-value padding-prop)))) - ,@(when pack-type-prop - (list `(setf (box-child-pack-type ,b ,child) ,(ui-prop-value pack-type-prop))))))) - -(def-ui-child-packer paned (p d child) - (let ((resize-prop (find :resize (ui-child-props d) :key #'ui-prop-name)) - (shrink-prop (find :shrink (ui-child-props d) :key #'ui-prop-name))) - `(if (null (paned-child-1 ,p)) - (paned-pack-1 ,p ,child - ,@(when resize-prop (list :resize (ui-prop-value resize-prop))) - ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop)))) - (paned-pack-2 ,p ,child - ,@(when resize-prop (list :resize (ui-prop-value resize-prop))) - ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop))))))) - -(def-ui-child-packer table (table d child) - `(table-attach ,table ,child - ,(get-ui-child-prop-value d :left t "table packing") - ,(get-ui-child-prop-value d :right t "table packing") - ,(get-ui-child-prop-value d :top t "table packing") - ,(get-ui-child-prop-value d :bottom t "table packing") - ,@(let ((x-options (get-ui-child-prop-value d :x-options nil nil))) - (when x-options - (list :x-options x-options))) - ,@(let ((y-options (get-ui-child-prop-value d :y-options nil nil))) - (when y-options - (list :y-options y-options))) - ,@(let ((x-padding (get-ui-child-prop-value d :x-padding nil nil))) - (when x-padding - (list :x-padding x-padding))) - ,@(let ((y-padding (get-ui-child-prop-value d :y-padding nil nil))) - (when y-padding - (list :y-padding y-padding))))) - -(defun get-child-packer-fn (d) - (iter (for class first (find-class (ui-d-class d)) then (first (c2mop:class-direct-superclasses class))) - (while class) - (for packer = (gethash (class-name class) *ui-child-packers*)) - (when packer (return packer)))) - -(defun get-child-packer (d var) - (let ((fn (get-child-packer-fn d))) - (when fn - (let ((forms (iter (for child in (ui-d-children d)) - (for child-var = (ui-d-var (ui-child-v child))) - (collect (funcall fn var child child-var))))) - (when forms (cons 'progn forms)))))) - -(defun get-ui-d-initializer (d var) - (get-child-packer d var)) +(defgeneric pack-child (container child &key)) + +(defmethod pack-child ((w container) child &key) + (container-add w child)) + +(defmethod pack-child ((b box) child &key (expand t) (fill t) (padding 0) pack-type position) + (box-pack-start b child + :expand expand + :fill fill + :padding padding) + (when pack-type + (setf (box-child-pack-type b child) pack-type)) + (when position + (setf (box-child-position b child) position))) + +(defmethod pack-child ((p paned) child &key (resize 'default) (shrink t)) + (if (null (paned-child-1 p)) + (paned-pack-1 p child + :resize (if (eq resize 'default) nil resize) + :shrink shrink) + (paned-pack-2 p child + :resize (if (eq resize 'default) t resize) + :shrink shrink))) + +(defmethod pack-child ((table table) child &key + left right top bottom + (x-options '(:expand :fill)) (y-options '(:expand :fill)) (x-padding 0) (y-padding 0)) + + (unless left + (error "left is a mandatory child property for table packing")) + (unless right + (error "right is a mandatory child property for table packing")) + (unless top + (error "top is a mandatory child property for table packing")) + (unless bottom + (error "bottom is a mandatory child property for table packing")) + + (table-attach table child + :left left + :right right + :top top + :bottom bottom + :x-options x-options + :y-options y-options + :x-padding x-padding + :y-padding y-padding)) + +(defmethod pack-child ((w tree-view) child &key) + (tree-view-append-column w child)) + +(defmethod pack-child ((w tree-view-column) child &key (expand t) attributes) + (tree-view-column-pack-start w child :expand expand) + (iter (for a on attributes by #'cddr) + (tree-view-column-add-attribute w child + (first a) + (second a)))) + +(defmethod pack-child ((b toolbar) child &key (expand 'default) (homogeneous 'default)) + (toolbar-insert b child -1) + (unless (eq expand 'default) + (container-call-set-property b child "expand" expand +g-type-boolean+)) + (unless (eq homogeneous 'default) + (container-call-set-property b child "homogeneous" homogeneous +g-type-boolean+))) (defun set-ui-expansion-1 (d) (when (ui-d-class d) ;; only direct-vars do not have class (setf (ui-d-var d) (get-ui-d-var d) - (ui-d-initform d) (get-ui-d-initform d)) - (setf (ui-d-initializer d) (get-ui-d-initializer d (ui-d-var d))))) + (ui-d-initform d) (get-ui-d-initform d)))) (defun set-ui-expansion (description) (iter (for child in (ui-d-children description)) @@ -143,10 +130,16 @@ (let* ((description (parse-ui-description ui-description)) (items (flattened-ui-descriptions description))) (set-ui-expansion description) - `(let (,@(iter (for i in items) - (collect (list (ui-d-var i) - (ui-d-initform i))))) - ,@(iter (for i in items) - (when (ui-d-initializer i) - (collect (ui-d-initializer i)))) + `(let (,@(iter (for item in items) + (collect (list (ui-d-var item) + (ui-d-initform item))))) + ,@(iter (for item in items) + (appending (iter (for child in (ui-d-children item)) + (for child-var = (ui-d-var (ui-child-v child))) + (let ((props + (iter (for p in (ui-child-props child)) + (appending (list (ui-prop-name p) (ui-prop-value p)))))) + (collect (list* 'pack-child (ui-d-var item) child-var props)))))) + ,@body))) + diff --git a/pango/pango.init.lisp b/pango/pango.init.lisp index 760e3fe..a64c5ea 100644 --- a/pango/pango.init.lisp +++ b/pango/pango.init.lisp @@ -3,7 +3,8 @@ (glib:at-init () (eval-when (:compile-toplevel :load-toplevel :execute) (define-foreign-library pango - (:unix "libpango-1.0.so.0") + ((:and :unix (:not :darwin)) "libpango-1.0.so.0") + (:darwin (:or "libpango-1.0.0.dylib" "libpango-1.0.dylib")) (:windows "libpango-1.0-0.dll") (t (:default "libgpango-1.0"))))