- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

[graphic-forms-cvs] r206 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Aug '06

10 Aug '06

Author: junrue Date: Thu Aug 10 18:06:32 2006 New Revision: 206 Modified: trunk/src/uitoolkit/widgets/window.lisp Log: fixed a regression for clisp caused by renaming the child window visitor callback Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 18:06:32 2006 @@ -224,7 +224,7 @@ (cffi:pointer-address hwnd)) #+clisp (gfs::enum-child-windows hwnd - #'child_window_visitor + #'child-window-visitor (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc))))

1 0

[graphic-forms-cvs] r205 - in trunk: . src/external-libraries/sbcl-callback-patch src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Aug '06

10 Aug '06

Author: junrue Date: Thu Aug 10 17:33:31 2006 New Revision: 205 Added: trunk/src/external-libraries/sbcl-callback-patch/ trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp trunk/src/external-libraries/sbcl-callback-patch/readme.txt Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/window.lisp Log: integrated stdcall callback patch for SBCL and implemented various enum procs for SBCL Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 17:33:31 2006 @@ -47,8 +47,13 @@ ((:module "src" :components ((:file "packages") +#+sbcl (:module "external-libraries" + :components + ((:module "sbcl-callback-patch" + :components + ((:file "callback-hacking"))))) (:module "uitoolkit" - :depends-on ("packages") + :depends-on ("packages" #+sbcl "external-libraries") :components ((:module "system" :serial t Added: trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp Thu Aug 10 17:33:31 2006 @@ -0,0 +1,125 @@ +;;;; +;;;; hacking.lisp +;;;; +;;;; Compiler and runtime damage for callbacks +;;;; +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-VM") + +(sb-ext:without-package-locks + (defun alien-callback-assembler-wrapper (index return-type arg-types &optional (stack-offset 0)) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (declare (ignore arg-types)) + (let* ((segment (make-segment)) + (eax eax-tn) + (edx edx-tn) + (ebp ebp-tn) + (esp esp-tn) + ([ebp-8] (make-ea :dword :base ebp :disp -8)) + ([ebp-4] (make-ea :dword :base ebp :disp -4))) + (assemble (segment) + (inst push ebp) ; save old frame pointer + (inst mov ebp esp) ; establish new frame + (inst mov eax esp) ; + (inst sub eax 8) ; place for result + (inst push eax) ; arg2 + (inst add eax 16) ; arguments + (inst push eax) ; arg1 + (inst push (ash index 2)) ; arg0 + (inst push (get-lisp-obj-address #'enter-alien-callback)) ; function + (inst mov eax (foreign-symbol-address "funcall3")) + (inst call eax) + ;; now put the result into the right register + (cond + ((and (alien-integer-type-p return-type) + (eql (alien-type-bits return-type) 64)) + (inst mov eax [ebp-8]) + (inst mov edx [ebp-4])) + ((or (alien-integer-type-p return-type) + (alien-pointer-type-p return-type) + (alien-type-= #.(parse-alien-type 'system-area-pointer nil) + return-type)) + (inst mov eax [ebp-8])) + ((alien-single-float-type-p return-type) + (inst fld [ebp-8])) + ((alien-double-float-type-p return-type) + (inst fldd [ebp-8])) + ((alien-void-type-p return-type)) + (t + (error "unrecognized alien type: ~A" return-type))) + (inst mov esp ebp) ; discard frame + (inst pop ebp) ; restore frame pointer + (inst ret stack-offset)) + (finalize-segment segment) + ;; Now that the segment is done, convert it to a static + ;; vector we can point foreign code to. + (let ((buffer (sb-assem::segment-buffer segment))) + (make-static-vector (length buffer) + :element-type '(unsigned-byte 8) + :initial-contents buffer))))) + +(in-package "SB-ALIEN") + +(defun %alien-callback-sap (specifier result-type argument-types function wrapper &optional (call-type :cdecl)) + (let ((key (list specifier function call-type))) + (or (gethash key *alien-callbacks*) + (setf (gethash key *alien-callbacks*) + (let* ((index (fill-pointer *alien-callback-trampolines*)) + ;; Aside from the INDEX this is known at + ;; compile-time, which could be utilized by + ;; having the two-stage assembler tramp & + ;; wrapper mentioned in [1] above: only the + ;; per-function tramp would need assembler at + ;; runtime. Possibly we could even pregenerate + ;; the code and just patch the index in later. + (assembler-wrapper (alien-callback-assembler-wrapper + index result-type argument-types + (if (eq call-type :stdcall) + (* 4 (length argument-types)) + 0)))) + (vector-push-extend + (alien-callback-lisp-trampoline wrapper function) + *alien-callback-trampolines*) + (let ((sap (vector-sap assembler-wrapper))) + (push (cons sap (make-callback-info :specifier specifier + :function function + :wrapper wrapper + :index index)) + *alien-callback-info*) + sap)))))) + +(sb-ext:without-package-locks + (defmacro alien-callback (specifier function &optional (call-type :cdecl) &environment env) + "Returns an alien-value with of alien ftype SPECIFIER, that can be passed to +an alien function as a pointer to the FUNCTION. If a callback for the given +SPECIFIER and FUNCTION already exists, it is returned instead of consing a new +one." + ;; Pull out as much work as is convenient to macro-expansion time, specifically + ;; everything that can be done given just the SPECIFIER and ENV. + (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env) + `(%sap-alien + (%alien-callback-sap ',specifier ',result-type ',argument-types + ,function + (or (gethash ',specifier *alien-callback-wrappers*) + (setf (gethash ',specifier *alien-callback-wrappers*) + ,(alien-callback-lisp-wrapper-lambda + specifier result-type argument-types env))) ,call-type) + ',(parse-alien-type specifier env))))) + +#| +(sb-alien::alien-callback (function int int int) #'+ :stdcall) + => #<SB-ALIEN-INTERNALS:ALIEN-VAUE :SAP ... :TYPE ...> +(alien-funcall-stdcall * 3 4) => 9 +"Hey everybody, callbacks work!" +|# + +;;; EOF Added: trunk/src/external-libraries/sbcl-callback-patch/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/sbcl-callback-patch/readme.txt Thu Aug 10 17:33:31 2006 @@ -0,0 +1,8 @@ +This directory contains callback-hacking.lisp, authored by +Alastair Bridgewater. This code updates an SBCL image such +that stdcall callbacks are supported. + +The full distribution including sample code is available from: + + http://www.lisphacker.com/files/lisp-winapi.tgz + http://www.lisphacker.com/files/hello-win32.tgz Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Aug 10 17:33:31 2006 @@ -45,9 +45,9 @@ :unicode :ascii)) -(defctype ATOM :unsigned-short) ; shadowed in defpackage +(defctype ATOM :unsigned-short) ; shadowed in gfs: package (defctype BOOL :int) -(defctype BOOLEAN :char) ; shadowed in defpackage +(defctype BOOLEAN :char) ; shadowed in gfs: package (defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) (defctype DWORD :unsigned-long) @@ -73,6 +73,26 @@ (defctype WORD :short) (defctype WPARAM :unsigned-int) +#+sbcl +(sb-alien:define-alien-type enumchildproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long))) + +#+sbcl +(sb-alien:define-alien-type enumthreadwndproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long))) + +#+sbcl +(sb-alien:define-alien-type monitorsenumproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:long))) + (defcstruct actctx (cbsize ULONG) (flags DWORD) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 17:33:31 2006 @@ -223,6 +223,12 @@ (lparam ffi:long)) (:return-type ffi:int)) +#+sbcl +(sb-alien:define-alien-routine ("EnumChildWindows" enum-child-windows) sb-alien:int + (hwnd sb-alien:system-area-pointer) + (func enumchildproc) + (lparam sb-alien:long)) + ;;; FIXME: uncomment this when CFFI callbacks can ;;; be tagged as stdcall or cdecl (only the latter ;;; is supported as of 0.9.0) @@ -264,6 +270,13 @@ (data ffi:c-pointer)) (:return-type ffi:int)) +#+sbcl +(sb-alien:define-alien-routine ("EnumDisplayMonitors" enum-display-monitors) sb-alien:int + (hdc sb-alien:system-area-pointer) + (rect sb-alien:system-area-pointer) + (func monitorsenumproc) + (lparam sb-alien:long)) + ;;; FIXME: uncomment this when CFFI callbacks can ;;; be tagged as stdcall or cdecl (only the latter ;;; is supported as of 0.9.0) @@ -300,6 +313,12 @@ (lparam ffi:long)) (:return-type ffi:int)) +#+sbcl +(sb-alien:define-alien-routine ("EnumThreadWindows" enum-thread-windows) sb-alien:int + (id sb-alien:unsigned-long) + (func enumthreadwndproc) + (lparam sb-alien:unsigned-long)) + (defcfun ("GetAncestor" get-ancestor) HANDLE Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Thu Aug 10 17:33:31 2006 @@ -48,12 +48,22 @@ (call-display-visitor-func (thread-context) hmonitor data) 1) -#+clisp -(defun display_visitor (hmonitor hdc monitorrect data) +(defun display-visitor (hmonitor hdc monitorrect data) (declare (ignore hdc monitorrect)) (call-display-visitor-func (thread-context) hmonitor data) 1) +#+sbcl +(defvar *monitors-enum-proc* + (sb-alien::alien-callback + (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:long) + #'display-visitor + :stdcall)) + (defun query-display-info (hmonitor) (let ((info nil)) (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) @@ -87,9 +97,14 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#+lispworks (let ((ptr (fli:make-pointer :address 0))) +#+sbcl + (let ((ptr (cffi:null-pointer))) + (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0)) +#+lispworks + (let ((ptr (fli:make-pointer :address 0))) (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) -#+clisp (gfs::enum-display-monitors nil nil #'display_visitor nil) +#+clisp + (gfs::enum-display-monitors nil nil #'display-visitor nil) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -104,26 +119,31 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -#+lispworks -(fli:define-foreign-callable - ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) +(defun top-level-window-visitor (hwnd lparam) + (declare (ignore lparam)) (let* ((tc (thread-context)) (win (get-widget tc hwnd))) (unless (null win) (call-top-level-visitor-func tc win))) 1) -#+clisp -(defun top_level_window_visitor (hwnd lparam) - (declare (ignore lparam)) - (let* ((tc (thread-context)) - (win (get-widget tc hwnd))) - (unless (null win) - (call-top-level-visitor-func tc win))) +#+lispworks +(fli:define-foreign-callable + ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) + ((hwnd :pointer) + (lparam :long)) + (top-level-window-visitor hwnd lparam) 1) +#+sbcl +(defvar *enum-thread-wnd-proc* + (sb-alien::alien-callback + (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long) + #'top-level-window-visitor + :stdcall)) + (defun maptoplevels (func) ;; ;; func should expect one parameter: @@ -132,12 +152,18 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#+lispworks (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (fli:make-pointer :symbol-name "top_level_window_visitor") - 0) -#+clisp (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - #'top_level_window_visitor - 0) +#+sbcl + (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (sb-alien:alien-sap *enum-thread-wnd-proc*) + 0) +#+lispworks + (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (fli:make-pointer :symbol-name "top_level_window_visitor") + 0) +#+clisp + (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + #'top-level-window-visitor + 0) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) (setf (top-level-visitor-results tc) nil) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 17:33:31 2006 @@ -60,34 +60,31 @@ (put-kbdnav-widget tc win)) (put-widget tc win)))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro child-visitor-proper (hwnd lparam) - (let ((tc (gensym)) - (tmp-list (gensym)) - (child (gensym)) - (parent (gensym)) - (ancestor-hwnd (gensym))) - `(let* ((,tc (thread-context)) - (,child (get-widget ,tc ,hwnd)) - (,parent (get-widget ,tc (cffi:make-pointer ,lparam)))) - (unless (or (null ,parent) (null ,child)) - (let ((,ancestor-hwnd (gfs::get-ancestor (gfs:handle ,child) gfs::+ga-parent+)) - (,tmp-list (child-visitor-results ,tc))) - (if (cffi:pointer-eq (gfs:handle ,parent) ,ancestor-hwnd) - (setf (child-visitor-results ,tc) (push (call-child-visitor-func ,tc ,parent ,child) ,tmp-list))))))))) +(defun child-window-visitor (hwnd lparam) + (let* ((tc (thread-context)) + (child (get-widget tc hwnd)) + (parent (get-widget tc (cffi:make-pointer lparam)))) + (unless (or (null parent) (null child)) + (let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)) + (tmp-list (child-visitor-results tc))) + (if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd) + (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list)))))) + 1) #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) ((hwnd :pointer) (lparam :long)) - (child-visitor-proper hwnd lparam) + (child-window-visitor hwnd lparam) 1) -#+clisp -(defun child_window_visitor (hwnd lparam) - (child-visitor-proper hwnd lparam) - 1) +#+sbcl +(defvar *enum-child-proc* + (sb-alien::alien-callback + (sb-alien:function sb-alien:int sb-alien:system-area-pointer sb-alien:long) + #'child-window-visitor + :stdcall)) (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) @@ -213,22 +210,22 @@ (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) (defmethod mapchildren ((self window) func) - (let ((tc (thread-context))) + (let ((tc (thread-context)) + (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect +#+sbcl + (gfs::enum-child-windows hwnd + (sb-alien:alien-sap *enum-child-proc*) + (cffi:pointer-address hwnd)) #+lispworks - (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle self))) + (gfs::enum-child-windows hwnd (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address (gfs:handle self))) + (cffi:pointer-address hwnd)) #+clisp - (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) - (setf ptr (ffi:set-foreign-pointer - (ffi:unsigned-foreign-address - (cffi:pointer-address (gfs:handle self))) - ptr)) - (gfs::enum-child-windows ptr - #'child_window_visitor - (cffi:pointer-address (gfs:handle self)))) + (gfs::enum-child-windows hwnd + #'child_window_visitor + (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) (setf (child-visitor-results tc) nil)

1 0

[graphic-forms-cvs] r204 - in trunk: . src src/demos/unblocked src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Aug '06

10 Aug '06

Author: junrue Date: Thu Aug 10 02:08:05 2006 New Revision: 204 Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/clib.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: initial phase of SBCL port completed Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 02:08:05 2006 @@ -51,6 +51,7 @@ :depends-on ("packages") :components ((:module "system" + :serial t :components ((:file "system-constants") (:file "system-classes") @@ -74,8 +75,10 @@ (:file "graphics-generics") (:file "color") (:file "palette") - (:file "image-data") - (:file "image") + (:file "image-data" + :depends-on ("graphics-classes")) + (:file "image" + :depends-on ("graphics-classes")) (:file "icon-bundle" :depends-on ("graphics-constants" "image")) (:file "font-data") @@ -85,10 +88,12 @@ :components ((:file "graphics-plugin-packages") #-skip-default-plugin (:module "default" + :serial t :components ((:file "file-formats") (:file "default-data-plugin"))) #+load-imagemagick-plugin (:module "imagemagick" + :serial t :components ((:file "magick-core-types") (:file "magick-core-api") @@ -96,6 +101,7 @@ :depends-on ("magick-core-types" "magick-core-api")))))))) (:module "widgets" :depends-on ("graphics") + :serial t :components ((:file "widget-constants") (:file "widget-classes") Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Thu Aug 10 02:08:05 2006 @@ -33,9 +33,9 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +level-label+ "Level:") -(defconstant +points-needed-label+ "Points Needed:") -(defconstant +score-label+ "Score:") +(defparameter *level-label* "Level:") +(defparameter *points-needed-label* "Points Needed:") +(defparameter *score-label* "Score:") (defconstant +scoreboard-text-margin+ 2) @@ -73,7 +73,7 @@ (buffer-size (gfs:make-size))) (unwind-protect (progn - (setf (gfs:size-width buffer-size) (* (+ (length +points-needed-label+) + (setf (gfs:size-width buffer-size) (* (+ (length *points-needed-label*) 2 ; space between label and value 9) ; number of value characters (gfg:average-char-width metrics))) @@ -112,9 +112,9 @@ (unwind-protect (progn (clear-buffer self gc) - (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (game-score)) - (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (game-level)) - (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (game-points-needed))) + (draw-scoreboard-row gc 1 image-size label-font *score-label* value-font (game-score)) + (draw-scoreboard-row gc 0 image-size label-font *level-label* value-font (game-level)) + (draw-scoreboard-row gc 2 image-size label-font *points-needed-label* value-font (game-points-needed))) (gfs:dispose gc)))) (defclass scoreboard-panel (gfw:panel) ()) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 10 02:08:05 2006 @@ -233,6 +233,10 @@ (defpackage #:graphic-forms.uitoolkit.widgets (:nicknames #:gfw) (:use #:common-lisp) +#+sbcl + (:import-from :sb-mop :ensure-generic-function) +#-sbcl + (:import-from :clos :ensure-generic-function) (:export ;; classes and structs Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Aug 10 02:08:05 2006 @@ -33,12 +33,13 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defconstant +btn-text-before+ "Push Me") -(defconstant +btn-text-after+ "Again!") -(defconstant +edit-text+ "something to edit") -(defconstant +label-text+ "Label") -(defconstant +margin-delta+ 4) -(defconstant +spacing-delta+ 3) +(defparameter *btn-text-before* "Push Me") +(defparameter *btn-text-after* "Again!") +(defparameter *edit-text* "something to edit") +(defparameter *label-text* "Label") + +(defconstant +margin-delta+ 4) +(defconstant +spacing-delta+ 3) (defvar *widget-counter* 0) @@ -93,10 +94,10 @@ (if (null flag) (progn (setf flag t) - (format nil "~d ~a" (id be) +btn-text-before+)) + (format nil "~d ~a" (id be) *btn-text-before*)) (progn (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) + (format nil "~d ~a" (id be) *btn-text-after*)))))) (defun add-layout-tester-widget (widget-class subtype) (let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) @@ -119,7 +120,7 @@ ((eql subtype :single-line-edit) (setf w (make-instance widget-class :parent *layout-tester-win* - :text (format nil "~d ~a" (id be) +edit-text+)))) + :text (format nil "~d ~a" (id be) *edit-text*)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here @@ -135,7 +136,7 @@ :parent *layout-tester-win* :dispatcher be :style '(:sunken))) - (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+))) + (setf (gfw:text w) (format nil "~d ~a" (id be) *label-text*))) (t (setf w (make-instance widget-class :parent *layout-tester-win* Modified: trunk/src/uitoolkit/system/clib.lisp ============================================================================== --- trunk/src/uitoolkit/system/clib.lisp (original) +++ trunk/src/uitoolkit/system/clib.lisp Thu Aug 10 02:08:05 2006 @@ -36,6 +36,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cffi)) +(load-foreign-library "msvcrt.dll") + (defcfun ("strncpy" strncpy) :pointer Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Thu Aug 10 02:08:05 2006 @@ -167,16 +167,6 @@ (hdc HANDLE)) (defcfun - ("DrawTextExA" draw-text-ex) - INT - (hdc HANDLE) - (text :string) - (count INT) - (rect LPTR) - (format UINT) - (params LPTR)) - -(defcfun ("Ellipse" ellipse) BOOL (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Aug 10 02:08:05 2006 @@ -36,20 +36,20 @@ ;;; ;;; control class names ;;; -(defconstant +button-classname+ "button") -(defconstant +edit-classname+ "edit") -(defconstant +static-classname+ "static") +(defparameter *button-classname* "button") +(defparameter *edit-classname* "edit") +(defparameter *static-classname* "static") ;;; ;;; registered message names ;;; -(defconstant +lbselchstringa+ "commdlg_LBSelChangedNotify") -(defconstant +sharevistringa+ "commdlg_ShareViolation") -(defconstant +fileokstringa+ "commdlg_FileNameOK") -(defconstant +colorokstringa+ "commdlg_ColorOK") -(defconstant +setrgbstringa+ "commdlg_SetRGBColor") -(defconstant +helpmsgstringa+ "commdlg_help") -(defconstant +findmsgstringa+ "commdlg_FindReplace") +(defparameter *lbselchstringa* "commdlg_LBSelChangedNotify") +(defparameter *sharevistringa* "commdlg_ShareViolation") +(defparameter *fileokstringa* "commdlg_FileNameOK") +(defparameter *colorokstringa* "commdlg_ColorOK") +(defparameter *setrgbstringa* "commdlg_SetRGBColor") +(defparameter *helpmsgstringa* "commdlg_help") +(defparameter *findmsgstringa* "commdlg_FindReplace") (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 02:08:05 2006 @@ -154,6 +154,16 @@ (hwnd HANDLE)) (defcfun + ("DrawTextExA" draw-text-ex) + INT + (hdc HANDLE) + (text :string) + (count INT) + (rect LPTR) + (format UINT) + (params LPTR)) + +(defcfun ("EnableMenuItem" enable-menu-item) BOOL (hmenu HANDLE) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Thu Aug 10 02:08:05 2006 @@ -79,7 +79,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::+button-classname+ + (let ((hwnd (create-window gfs::*button-classname* (or text " ") (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu Aug 10 02:08:05 2006 @@ -33,17 +33,18 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +default-dialog-title+ " ") -(defconstant +dlgwindowextra+ 48) +(defparameter *default-dialog-title* " ") -(defvar *disabled-top-levels* nil) +(defconstant +dlgwindowextra+ 48) + +(defvar *disabled-top-levels* nil) ;;; ;;; helper functions ;;; (defun register-dialog-class () - (register-window-class +dialog-classname+ + (register-window-class *dialog-classname* (cffi:get-callback 'uit_widgets_wndproc) (logior gfs::+cs-dblclks+ gfs::+cs-savebits+ @@ -167,7 +168,7 @@ (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) (if (null text) - (setf text +default-dialog-title+)) + (setf text *default-dialog-title*)) ;; NOTE: do not allow apps to specify the desktop window as the ;; owner of the dialog; it would cause the desktop to become ;; disabled. @@ -179,7 +180,7 @@ ;; walk up the ancestors until one is found. Only top level hwnds can ;; be owners. ;; - (init-window self +dialog-classname+ #'register-dialog-class owner text)) + (init-window self *dialog-classname* #'register-dialog-class owner text)) (defmethod show ((self dialog) flag) (let ((app-modal (find :application-modal (style-of self))) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Thu Aug 10 02:08:05 2006 @@ -97,7 +97,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::+edit-classname+ + (let ((hwnd (create-window gfs::*edit-classname* (or text "") (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Thu Aug 10 02:08:05 2006 @@ -33,10 +33,10 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source)) - (gfw:event-arm . (gfw:event-source)) - (gfw:event-modify . (gfw:event-source)) - (gfw:event-select . (gfw:event-source)))) +(defparameter *callback-info* '((gfw:event-activate . (gfw:event-source)) + (gfw:event-arm . (gfw:event-source)) + (gfw:event-modify . (gfw:event-source)) + (gfw:event-select . (gfw:event-source)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) @@ -45,12 +45,12 @@ (defun define-dispatcher-for-callbacks (callbacks) (let ((*print-gensym* nil) - (class (clos:ensure-class (gentemp "EDCLASS" :gfgen) + (class (c2mop:ensure-class (gentemp "EDCLASS" :gfgen) :direct-superclasses '(event-dispatcher)))) (loop for pair in callbacks do (let* ((method-sym (car pair)) (fn (cdr pair)) - (arg-info (cdr (assoc method-sym +callback-info+))) + (arg-info (cdr (assoc method-sym *callback-info*))) (args nil)) `(unless (or (symbolp ,fn) (functionp ,fn)) (error 'gfs:toolkit-error @@ -61,7 +61,7 @@ method-sym))) (dotimes (i (1+ (length arg-info))) (push (gentemp "ARG" :gfgen) args)) - (c2mop:ensure-method (clos:ensure-generic-function method-sym :lambda-list args) + (c2mop:ensure-method (ensure-generic-function method-sym :lambda-list args) `(lambda ,args (funcall ,fn ,@args)) :specializers (make-specializer-list class arg-info)))) class)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Thu Aug 10 02:08:05 2006 @@ -152,7 +152,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags label image separator text) - (let ((hwnd (create-window gfs::+static-classname+ + (let ((hwnd (create-window gfs::*static-classname* (or text " ") (gfs:handle parent) (logior std-style) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Thu Aug 10 02:08:05 2006 @@ -41,7 +41,7 @@ (declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items (let ((info-mask (logior gfs::+miim-id+ (if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+) - (if hchildmenu gfs::+miim-submenu+))) + (if hchildmenu gfs::+miim-submenu+ 0))) (info-type (if label 0 gfs::+mft-separator+)) (info-state (logior (if checked gfs::+mfs-checked+ 0) (if disabled gfs::+mfs-disabled+ 0)))) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Thu Aug 10 02:08:05 2006 @@ -33,14 +33,14 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +panel-window-classname+ "GraphicFormsPanel") +(defparameter *panel-window-classname* "GraphicFormsPanel") ;;; ;;; helper functions ;;; (defun register-panel-window-class () - (register-window-class +panel-window-classname+ + (register-window-class *panel-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ -1)) @@ -70,4 +70,4 @@ (error 'gfs:toolkit-error :detail "parent is required for panel")) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) - (init-window self +panel-window-classname+ #'register-panel-window-class parent "")) + (init-window self *panel-window-classname* #'register-panel-window-class parent "")) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Aug 10 02:08:05 2006 @@ -59,35 +59,42 @@ ;; TODO: change this when CLISP acquires MT support ;; -#+clisp (defvar *the-thread-context* nil) +;; TODO: change this once we understand SBCL MT support +;; +#+(or clisp sbcl) +(defvar *the-thread-context* nil) -#+clisp (defun thread-context () - (when (null *the-thread-context*) - (setf *the-thread-context* (make-instance 'thread-context)) - (init-utility-hwnd *the-thread-context*)) - *the-thread-context*) - -#+clisp (defun dispose-thread-context () - (let ((hwnd (utility-hwnd *the-thread-context*))) - (unless (gfs:null-handle-p hwnd) - (gfs::destroy-window hwnd))) - (setf *the-thread-context* nil)) - -#+lispworks (defun thread-context () - (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) - (when (null tc) - (setf tc (make-instance 'thread-context)) - (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) - (init-utility-hwnd tc)) - tc)) - -#+lispworks (defun dispose-thread-context () - (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) - (if tc - (let ((hwnd (utility-hwnd tc))) - (unless (gfs:null-handle-p hwnd) - (gfs::destroy-window hwnd))))) - (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) +#+(or clisp sbcl) +(defun thread-context () + (when (null *the-thread-context*) + (setf *the-thread-context* (make-instance 'thread-context)) + (init-utility-hwnd *the-thread-context*)) + *the-thread-context*) + +#+(or clisp sbcl) +(defun dispose-thread-context () + (let ((hwnd (utility-hwnd *the-thread-context*))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))) + (setf *the-thread-context* nil)) + +#+lispworks +(defun thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (when (null tc) + (setf tc (make-instance 'thread-context)) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) + (init-utility-hwnd tc)) + tc)) + +#+lispworks +(defun dispose-thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (if tc + (let ((hwnd (utility-hwnd tc))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))))) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) (defmethod init-utility-hwnd ((tc thread-context)) (register-toplevel-noerasebkgnd-window-class) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Aug 10 02:08:05 2006 @@ -33,20 +33,20 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +default-window-title+ "New Window") +(defparameter *default-window-title* "New Window") ;;; ;;; helper functions ;;; (defun register-toplevel-erasebkgnd-window-class () - (register-window-class +toplevel-erasebkgnd-window-classname+ + (register-window-class *toplevel-erasebkgnd-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ gfs::+color-appworkspace+)) (defun register-toplevel-noerasebkgnd-window-class () - (register-window-class +toplevel-noerasebkgnd-window-classname+ + (register-window-class *toplevel-noerasebkgnd-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ -1)) @@ -138,11 +138,11 @@ (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) (if (null text) - (setf text +default-window-title+)) - (let ((classname +toplevel-noerasebkgnd-window-classname+) + (setf text *default-window-title*)) + (let ((classname *toplevel-noerasebkgnd-window-classname*) (register-func #'register-toplevel-noerasebkgnd-window-class)) (when (find :workspace (style-of win)) - (setf classname +toplevel-erasebkgnd-window-classname+) + (setf classname *toplevel-erasebkgnd-window-classname*) (setf register-func #'register-toplevel-erasebkgnd-window-class)) (init-window win classname register-func owner text))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Aug 10 02:08:05 2006 @@ -79,20 +79,22 @@ (translate-and-dispatch msg-ptr) nil))) -#+clisp (defun startup (thread-name start-fn) - (declare (ignore thread-name)) - (funcall start-fn) - (message-loop #'default-message-filter)) - -#+lispworks (defun startup (thread-name start-fn) - (hcl:add-special-free-action 'gfs::native-object-special-action) - (when (null (mp:list-all-processes)) - (mp:initialize-multiprocessing)) - (mp:process-run-function thread-name - nil - (lambda () - (funcall start-fn) - (message-loop #'default-message-filter)))) +#+(or clisp sbcl) +(defun startup (thread-name start-fn) + (declare (ignore thread-name)) + (funcall start-fn) + (message-loop #'default-message-filter)) + +#+lispworks +(defun startup (thread-name start-fn) + (hcl:add-special-free-action 'gfs::native-object-special-action) + (if (null (mp:list-all-processes)) + (mp:initialize-multiprocessing)) + (mp:process-run-function thread-name + nil + (lambda () + (funcall start-fn) + (message-loop #'default-message-filter)))) (defun shutdown (exit-code) (gfs::post-quit-message exit-code)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 02:08:05 2006 @@ -33,10 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +dialog-classname+ "GraphicFormsDialog") - (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") - (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")) +(defparameter *dialog-classname* "GraphicFormsDialog") +(defparameter *toplevel-erasebkgnd-window-classname* "GraphicFormsTopLevelEraseBkgnd") +(defparameter *toplevel-noerasebkgnd-window-classname* "GraphicFormsTopLevelNoEraseBkgnd") ;;; ;;; helper functions @@ -145,7 +144,7 @@ (color nil)) (cffi:with-foreign-pointer-as-string (str-ptr 64) (gfs::get-class-name hwnd str-ptr 64) - (if (string= (cffi:foreign-string-to-lisp str-ptr) +toplevel-erasebkgnd-window-classname+) + (if (string= (cffi:foreign-string-to-lisp str-ptr) *toplevel-erasebkgnd-window-classname*) (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) color))

1 0

[graphic-forms-cvs] r203 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system
by junrue＠common-lisp.net 10 Aug '06

10 Aug '06

Author: junrue Date: Thu Aug 10 00:15:08 2006 New Revision: 203 Added: trunk/src/tests/uitoolkit/default.ico (contents, props changed) trunk/src/uitoolkit/graphics/icon-bundle.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-constants.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp Log: implemented and documented icon-bundle class and related functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Aug 10 00:15:08 2006 @@ -2028,21 +2028,24 @@ in the @code{<Alt><Tab>} task switching dialog, and in the Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN documentation for further discussion of standard icon sizes, color -depths and file format. @code{icon-bundle} derives from @ref{native-object}. +depths and file format.@*@* +@code{icon-bundle} derives from @ref{native-object}. @deffn Initarg :file This initarg accepts a @sc{cl:pathname} identifying a file with @ref{image-data} to be loaded, as described for the @ref{image} -class @code{:file} initarg. Note that the @sc{.ico} format can -store multiple icons, all of which will be loaded. Since +class @code{:file} initarg. Note that the @sc{ico} format can +store multiple icons, all of which will be loaded. Application +code should not assume that load order is preserved. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the proper transparency @ref{color}; by default, the pixel color at -@code{(0, 0)} in each image will be used. @emph{FIXME: link to -documentation of graphics plugins here}. +@code{(0, 0)} in each image will be used. @emph{FIXME: link +to documentation of graphics plugins here}. @end deffn @deffn Initarg :images -This initarg accepts a @sc{cl:list} of image objects. Since +This initarg accepts a @sc{cl:list} of image objects. Application +code should not assume that image order is preserved. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, the application may either @sc{setf} @ref{transparency-pixel} for each image ahead of time (especially @@ -2346,6 +2349,30 @@ Returns a color object corresponding to the current foreground color. @end deffn +@anchor{icon-image} +@defun icon-image @ref{icon-bundle} index => @ref{image} +This function uses an integer or keyword -based @var{index} to address +the images comprising an icon-bundle, either to retrieve an image +or add/replace an image via @sc{setf}. Application code should not +assume that image load order was preserved when this function is called. +@table @var +@item icon-bundle +This is an icon-bundle containing images to be updated or retrieved. +@item index +This argument can be a zero-based, with new images added by +specifying @var{index} 0. Or @var{index} can be one of the following +keywords: +@table @code +@item :large +Specifies the largest image of the icon-bundle. +@item :small +Specifies the smallest image of the icon-bundle. +@end table +@end table +To find out how many images are stored in an icon-bundle, call +@ref{size}. +@end defun + @anchor{load} @deffn GenericFunction load self path => list Certain graphics objects have a persistent representation, which may @@ -2356,6 +2383,13 @@ returns @var{self} plus any additional instances in a @sc{list}, ordered the same as they are read from @var{path}. @emph{Note:} @sc{gfg:load} shadows @sc{cl:load}. +@table @var +@item self +The graphics object that will be populated with data. +@item path +A @sc{cl:pathname} identifying a file with graphics data appropriate +for @var{self}. +@end table @end deffn @deffn GenericFunction metrics self font => @ref{font-metrics} Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 00:15:08 2006 @@ -76,6 +76,8 @@ (:file "palette") (:file "image-data") (:file "image") + (:file "icon-bundle" + :depends-on ("graphics-constants" "image")) (:file "font-data") (:file "font") (:file "graphics-context") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 10 00:15:08 2006 @@ -109,6 +109,7 @@ #:font-data #:font-metrics #:graphics-context + #:icon-bundle #:image #:image-data #:image-data-plugin @@ -123,6 +124,11 @@ #:*color-red* #:*color-white* #:*image-file-types* + #:+application-icon+ + #:+error-icon+ + #:+information-icon+ + #:+question-icon+ + #:+warning-icon+ ;; methods, functions, macros #:accepts-file-p @@ -182,6 +188,7 @@ #:green-mask #:green-shift #:height + #:icon-image #:invert #:leading #:line-cap-style Added: trunk/src/tests/uitoolkit/default.ico ============================================================================== Binary file. No diff available. Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Thu Aug 10 00:15:08 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; classes.lisp +;;;; graphics-classes.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -127,12 +127,15 @@ :initform (cffi:null-pointer))) (:documentation "This class represents the context associated with drawing primitives.")) +(defclass icon-bundle (gfs:native-object) () + (:documentation "This class encapsulates a set of Win32 icon handles.")) + (defclass image (gfs:native-object) ((transparency-pixel :accessor transparency-pixel-of :initarg :transparency-pixel :initform nil)) - (:documentation "This class wraps a native image object.")) + (:documentation "This class encapsulates a Win32 bitmap handle.")) (defmacro blue-mask (data) `(gfg::palette-blue-mask ,data)) Modified: trunk/src/uitoolkit/graphics/graphics-constants.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-constants.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-constants.lisp Thu Aug 10 00:15:08 2006 @@ -57,3 +57,13 @@ (defconstant +russian-charset+ 204) (defconstant +mac-charset+ 77) (defconstant +baltic-charset+ 186) + +;;; The following are from WinUser.h; specify one of +;;; them as the value of the :system keyword arg when +;;; creating an icon-bundle +;;; +(defconstant +application-icon+ 32512) +(defconstant +error-icon+ 32513) +(defconstant +information-icon+ 32516) +(defconstant +question-icon+ 32514) +(defconstant +warning-icon+ 32515) Added: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Thu Aug 10 00:15:08 2006 @@ -0,0 +1,129 @@ +;;;; +;;;; icon-bundle.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.graphics) + +;;; +;;; helper functions +;;; + +(defun hicon->image (hicon) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (if (zerop (gfs::get-icon-info hicon info-ptr)) + (error 'gfs::win32-error :detail "get-icon-info failed")) + (cffi:with-foreign-slots ((gfs::hmask gfs::hcolor) info-ptr gfs::iconinfo) + (gfs::delete-object gfs::hmask) + (make-instance 'image :handle gfs::hcolor)))) + +(defun icon-extent (hicon) + (let ((im (hicon->image hicon)) + (extent 0)) + (unwind-protect + (setf extent (gfs:size-height (gfg:size im))) + (gfs:dispose im)) + extent)) + +(defun icon-handle (bundle index) + (let ((handles (gfs:handle bundle))) + (unless handles + (error 'gfs:disposed-error)) + (cond + ((typep index 'integer) + (if (zerop index) + (if (listp handles) + (elt handles index) + handles))) + ((eql index :small) + (if (listp handles) + (first (stable-sort handles #'< :key #'icon-extent)) + handles)) + ((eql index :large) + (if (listp handles) + (first (last (stable-sort handles #'< :key #'icon-extent))) + handles)) + (t + (error 'gfs:toolkit-error + :detail "an integer index, or one of :small or :large, is required"))))) + +(defun icon-image (bundle index) + (hicon->image (icon-handle bundle index))) + +;;; +;;; methods +;;; + +(defmethod gfs:dispose ((self icon-bundle)) + (let ((handles (gfs:handle self))) + (setf (slot-value self 'gfs:handle) nil) + ;; note: if handles is a cffi:pointer, then self was + ;; instantiated as a system icon and we don't need + ;; to destroy the handle + ;; + (if (and handles (listp handles)) + (loop for hicon in handles do (gfs::destroy-icon hicon))))) + +(defmethod initialize-instance :after ((self icon-bundle) &key file images system transparency-pixel) + (let ((image-list nil) + (resource-id (case system + (#.+application-icon+ (cffi:make-pointer system)) + (#.+error-icon+ (cffi:make-pointer system)) + (#.+information-icon+ (cffi:make-pointer system)) + (#.+question-icon+ (cffi:make-pointer system)) + (#.+warning-icon+ (cffi:make-pointer system)) + (otherwise nil)))) + (cond + (resource-id + (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) + (file + (let ((tmp-image (make-instance 'image))) + (setf image-list (load tmp-image file)))) + (images + (setf image-list images))) + (when image-list + (let ((handles nil) + (default-pnt (gfs:make-point))) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (setf gfs::flag 1) + (loop for tmp-image in image-list + do (with-image-transparency (tmp-image (or transparency-pixel default-pnt)) + (setf gfs::hcolor (gfs:handle tmp-image)) + (setf gfs::hmask (gfs:handle (transparency-mask tmp-image))) + (let ((hicon (gfs::create-icon-indirect info-ptr))) + (unless (gfs:null-handle-p hicon) + (push hicon handles))))))) + (setf (slot-value self 'gfs:handle) handles)))) + (unless (gfs:handle self) + (error 'gfs:toolkit-error :detail "could not initialize icon bundle"))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Thu Aug 10 00:15:08 2006 @@ -83,10 +83,10 @@ (gfs:dispose self)) (setf (slot-value self 'gfs:handle) (data->image id))) -(defmethod initialize-instance :after ((image image) &key file size &allow-other-keys) +(defmethod initialize-instance :after ((self image) &key file size &allow-other-keys) (cond (file - (load image file)) + (load self file)) (size (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) @@ -104,19 +104,19 @@ (cffi:with-foreign-object (buffer :pointer) (gfs::with-compatible-dcs (nptr memdc) (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) - (setf (slot-value image 'gfs:handle) hbmp))))))) + (setf (slot-value self 'gfs:handle) hbmp))))))) -(defmethod load ((im image) path) +(defmethod load ((self image) path) (let ((data (make-instance 'image-data))) (load data path) - (setf (data-object im) data) + (setf (data-object self) data) data)) -(defmethod size ((image image)) - (if (gfs:disposed-p image) +(defmethod size ((self image)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((size (gfs:make-size)) - (himage (gfs:handle image))) + (himage (gfs:handle self))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) @@ -124,17 +124,17 @@ (gfs:size-height size) gfs::height))) size)) -(defmethod transparency-mask ((im image)) - (if (gfs:disposed-p im) +(defmethod transparency-mask ((self image)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((pixel-pnt (transparency-pixel-of im)) - (hbmp (gfs:handle im)) + (let ((pixel-pnt (transparency-pixel-of self)) + (hbmp (gfs:handle self)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer))) (if pixel-pnt (progn (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (gfs::get-object (gfs:handle self) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) (if (gfs:null-handle-p hmask) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Aug 10 00:15:08 2006 @@ -171,8 +171,8 @@ (flag BOOL) (hotspotx DWORD) (hotspoty DWORD) - (maskbm HANDLE) - (colorbm HANDLE)) + (hmask HANDLE) + (hcolor HANDLE)) (defctype iconinfo-pointer :pointer) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 00:15:08 2006 @@ -347,6 +347,12 @@ HANDLE) (defcfun + ("GetIconInfo" get-icon-info) + BOOL + (hicon HANDLE) + (iconinfo LPTR)) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT))

1 0

[graphic-forms-cvs] r202 - in trunk: docs/manual src/uitoolkit/system
by junrue＠common-lisp.net 08 Aug '06

08 Aug '06

Author: junrue Date: Tue Aug 8 01:47:29 2006 New Revision: 202 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp Log: further work towards supporting icon display Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Aug 8 01:47:29 2006 @@ -2020,11 +2020,76 @@ @end deffn @end deftp +@anchor{icon-bundle} +@deftp Class icon-bundle +This class encapsulates a collection of Win32 icon handles. +Icons are used to decorate @ref{window} title bars, to represent +a file or application on the desktop, to represent an application +in the @code{<Alt><Tab>} task switching dialog, and in the +Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN +documentation for further discussion of standard icon sizes, color +depths and file format. @code{icon-bundle} derives from @ref{native-object}. +@deffn Initarg :file +This initarg accepts a @sc{cl:pathname} identifying a file +with @ref{image-data} to be loaded, as described for the @ref{image} +class @code{:file} initarg. Note that the @sc{.ico} format can +store multiple icons, all of which will be loaded. Since +@code{icon-bundle} needs a transparency mask for each image in +order to create Windows icons, a value may be supplied for the +@code{:transparency-pixel} initarg of this class to select the +proper transparency @ref{color}; by default, the pixel color at +@code{(0, 0)} in each image will be used. @emph{FIXME: link to +documentation of graphics plugins here}. +@end deffn +@deffn Initarg :images +This initarg accepts a @sc{cl:list} of image objects. Since +@code{icon-bundle} needs a transparency mask for each image in +order to create Windows icons, the application may either @sc{setf} +@ref{transparency-pixel} for each image ahead of time (especially +important when the pixel location is different from one image +to the next), or provide a value for the @code{:transparency-pixel} +initarg of this class; or else by default, the pixel color at +@code{(0, 0)} in each image will be used. +@end deffn +@deffn Initarg :system +This initarg causes the @code{icon-bundle} to be loaded with a +system-provided standard icon, identified by one of the following +constants: +@table @code +@item +application-icon+ +Default application icon. +@item +error-icon+ +Icon for error notifications. +@item +information-icon+ +Icon for informational notifications. +@item +question-icon+ +Icon to be used when prompting the user for more input. +@item +warning-icon+ +Icon for warning notifications. +@end table +@end deffn +@deffn Initarg :transparency-pixel +This initarg is similar in purpose to the same initarg for +the image class, except that in this case the specified @ref{point} +applies to all images (except pre-defined system icons) +encapsulated by the @code{icon-bundle} object. +@end deffn +@end deftp + @anchor{image} -@deftp Class image -This subclass of @ref{native-object} wraps a native image object. -Instances may be drawn directly via a graphics-context (see -@ref{draw-image}) or set as the content of a @ref{label} control. +@deftp Class image transparency-pixel +This subclass of @ref{native-object} wraps a Win32 bitmap handle. +Instances may be drawn using @ref{draw-image} or displayed within +certain @ref{control}s such as a @ref{label}. Images may originate +from a variety of formats. @emph{FIXME: link to documentation +of graphics plugins here}. +@table @var +@anchor{transparency-pixel} +@item transparency-pixel +This slot holds a @ref{point} that identifies a pixel within the +image whose color will be used by @ref{transparency-mask}. +@xref{with-image-transparency}. +@end table @deffn Initarg :file Supply a path to a file containing image data to be loaded. @end deffn @@ -2036,9 +2101,28 @@ @end deftp @anchor{image-data} -@deftp Class image-data -This subclass of @ref{native-object} maintains image attributes, -color, and pixel data. @xref{image}. +@deftp Class image-data data-plugin +This class represents an image in an external format. Such formats +may be loaded (via the @ref{load} method) and then converted to an +@ref{image} object by the @ref{data-object} @sc{setf} function.@*@* +@code{image-data} serves as an integration point between Graphic-Forms +and third-party graphics libraries such as ImageMagick. @emph{FIXME: +link to documentation of graphics plugins here}. +@table @var +@item data-plugin +This slot holds a subclass of @ref{image-data-plugin} encapsulating +format and functionality from a particular third-party graphics library. +Many of the features offered by @code{image-data} are delegated to +this plugin object. +@end table +@end deftp + +@anchor{image-data-plugin} +@deftp Class image-data-plugin +This is a base class for plugin objects that encapsulate third-party +library representations of images. @emph{FIXME: +link to documentation of graphics plugins here}. It derives from +@ref{native-object}. @end deftp @node graphics functions @@ -2053,6 +2137,7 @@ Returns a color object corresponding to the current background color. @end deffn +@anchor{data-object} @deffn GenericFunction data-object self &optional gc => object Returns the data structure representing the raw data form of the object. The @code{gc} argument must be supplied when calling this @@ -2261,6 +2346,7 @@ Returns a color object corresponding to the current foreground color. @end deffn +@anchor{load} @deffn GenericFunction load self path => list Certain graphics objects have a persistent representation, which may be deserialized with the appropriate implementation of this function. @@ -2296,8 +2382,16 @@ @end table @end deffn -@deffn GenericFunction transparency-mask self +@anchor{transparency-mask} +@deffn GenericFunction transparency-mask self => @ref{image} Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency. @end deffn + +@anchor{with-image-transparency} +@defmac with-image-transparency (image point) &body body +This macro wraps @var{body} in an @sc{unwind-protect} form with +@var{point} set as the @ref{transparency-pixel} for @var{image}. +Any existing point set in @var{image} is restored. +@end defmac Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Aug 8 01:47:29 2006 @@ -167,6 +167,15 @@ (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc (templname :string)) +(defcstruct iconinfo + (flag BOOL) + (hotspotx DWORD) + (hotspoty DWORD) + (maskbm HANDLE) + (colorbm HANDLE)) + +(defctype iconinfo-pointer :pointer) + (defcstruct initcommoncontrolsex (size DWORD) (icc DWORD)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Aug 8 01:47:29 2006 @@ -72,6 +72,11 @@ (ch UINT)) (defcfun + ("CreateIconIndirect" create-icon-indirect) + HANDLE + (iconinfo iconinfo-pointer)) + +(defcfun ("CreateMenu" create-menu) HANDLE) @@ -124,6 +129,11 @@ (lp LPARAM)) (defcfun + ("DestroyIcon" destroy-icon) + BOOL + (hicon HANDLE)) + +(defcfun ("DestroyMenu" destroy-menu) BOOL (hwnd HANDLE)) @@ -487,6 +497,12 @@ (name LPTR)) ; LPTR to make it easier to pass constants like +obm-checkboxes+ (defcfun + ("LoadIconA" load-icon) + HANDLE + (instance HANDLE) + (name LPCTSTR)) + +(defcfun ("LoadImageA" load-image) HANDLE (instance HANDLE)

1 0

[graphic-forms-cvs] r201 - in trunk: . docs/manual src/uitoolkit/graphics src/uitoolkit/graphics/plugins/default src/uitoolkit/graphics/plugins/imagemagick
by junrue＠common-lisp.net 07 Aug '06

07 Aug '06

Author: junrue Date: Mon Aug 7 12:14:19 2006 New Revision: 201 Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: refactored plugin loading to accomodate multiple-image formats Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Aug 7 12:14:19 2006 @@ -2261,12 +2261,24 @@ Returns a color object corresponding to the current foreground color. @end deffn -@deffn GenericFunction metrics self font -Returns a @ref{font-metrics} object describing key attributes of @code{font}. +@deffn GenericFunction load self path => list +Certain graphics objects have a persistent representation, which may +be deserialized with the appropriate implementation of this function. +@var{self} will be re-initialized with data loaded from @var{path}. +Certain serialized object formats (e.g., @sc{ico}) may actually +describe multiple instances. To facilitate such formats, @code{load} +returns @var{self} plus any additional instances in a @sc{list}, +ordered the same as they are read from @var{path}. @emph{Note:} +@sc{gfg:load} shadows @sc{cl:load}. @end deffn -@deffn GenericFunction size self -Returns a size object describing the dimensions of the object. +@deffn GenericFunction metrics self font => @ref{font-metrics} +Returns a font-metrics object describing key attributes of @var{font}, +where @var{self} is a @ref{graphics-context}. +@end deffn + +@deffn GenericFunction size self => @ref{size} +Returns a size object describing the dimensions of @var{self}. @end deffn @deffn GenericFunction text-extent self text &optional style tab-width Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Aug 7 12:14:19 2006 @@ -50,7 +50,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.3.0" + :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cells") Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Aug 7 12:14:19 2006 @@ -39,7 +39,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.3.0" + :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Aug 7 12:14:19 2006 @@ -90,6 +90,7 @@ (defclass image-data () ((data-plugin :reader data-plugin-of + :initarg :data-plugin :initform nil)) (:documentation "This class maintains image attributes, color, and pixel data.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Aug 7 12:14:19 2006 @@ -78,11 +78,11 @@ ;;; helper functions ;;; -(defun find-image-plugin (path) - (loop for acceptor in *image-plugins* - for plugin = (funcall acceptor path) - until plugin - finally (return plugin))) +(defun load-image-data (path) + (loop for loader in *image-plugins* + for data = (funcall loader path) + until data + finally (return data))) (defun image->data (hbmp) (declare (ignore hbmp))) #| @@ -193,14 +193,16 @@ ((typep path 'string) (namestring (merge-pathnames path))) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) - - (let ((plugin (data-plugin-of self))) - (unless plugin - (setf plugin (find-image-plugin path))) - (unless plugin + (let ((plugin (data-plugin-of self)) + (plugins nil)) + (if plugin + (setf plugins (load plugin path)) + (setf plugins (load-image-data path))) + (unless plugins (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path))) - (load plugin path) - (setf (slot-value self 'data-plugin) plugin))) + (setf (slot-value self 'data-plugin) (first plugins)) + (append (list self) (loop for p in (rest plugins) + collect (make-instance 'image-data :data-plugin p))))) (defmethod size ((self image-data)) (size (data-plugin-of self))) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Mon Aug 7 12:14:19 2006 @@ -45,22 +45,66 @@ (defmacro bitmap-pixel-row-length (width bit-count) `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) -(defun accepts-file-p (path) - (cond - ((parse-namestring path)) ; syntax check - ((typep path 'pathname) - (setf path (namestring path))) - (t - (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) - (let ((ext (pathname-type path))) -; (if (or (string-equal ext "ico") (string-equal ext "bmp")) - (if (string-equal ext "bmp") - (let ((plugin (make-instance 'default-data-plugin))) - (gfg:load plugin path) - plugin) - nil))) +(defun load-bmp-data (stream) + (let* ((header (read-value 'BITMAPFILEHEADER stream)) + (info (read-value 'BASE-BITMAPINFOHEADER stream)) + (data (make-instance 'default-data-plugin :handle info))) + (declare (ignore header)) + (unless (= (biCompression info) gfs::+bi-rgb+) + (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + + ;; load color table + ;; + (let ((used (biClrUsed info)) + (rgbs nil)) + (ecase (biBitCount info) + (1 + (setf rgbs (make-array 2))) + (4 + (if (or (= used 0) (= used 16)) + (setf rgbs (make-array 16)) + (setf rgbs (make-array used)))) + (8 + (if (or (= used 0) (= used 256)) + (setf rgbs (make-array 256)) + (setf rgbs (make-array used)))) + (16 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (24 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (32 + (unless (/= used 0) + (setf rgbs (make-array used))))) + (dotimes (i (length rgbs)) + (let ((quad (read-value 'RGBQUAD stream))) + (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) + :green (rgbGreen quad) + :blue (rgbBlue quad))))) + (setf (palette-of data) (gfg:make-palette :direct nil :table rgbs))) + + ;; load pixel bits + ;; + (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) + (setf (pixels-of data) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) + (read-sequence (pixels-of data) stream)) + + (list data))) + +(defun load-icon-data (stream) + (declare (ignore stream))) + +(defun loader (path) + (let* ((file-type (pathname-type path)) + (helper (cond + ((string-equal file-type "bmp") #'load-bmp-data) + ((string-equal file-type "ico") #'load-icon-data) + (t (return-from loader nil))))) + (with-open-file (stream path :element-type '(unsigned-byte 8)) + (funcall helper stream)))) -(push #'accepts-file-p gfg::*image-plugins*) +(push #'loader gfg::*image-plugins*) (defmethod gfg:data->image ((self default-data-plugin)) (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) @@ -99,55 +143,6 @@ (declare (ignore param)) (cffi:foreign-free bi-ptr)) -(defmethod gfg:load ((self default-data-plugin) path) - (with-open-file (in path :element-type '(unsigned-byte 8)) - (let ((header (read-value 'BITMAPFILEHEADER in)) - (info (read-value 'BASE-BITMAPINFOHEADER in))) - (declare (ignore header)) - (unless (= (biCompression info) gfs::+bi-rgb+) - (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) - - ;; load color table - ;; - (let ((used (biClrUsed info)) - (rgbs nil)) - (ecase (biBitCount info) - (1 - (setf rgbs (make-array 2))) - (4 - (if (or (= used 0) (= used 16)) - (setf rgbs (make-array 16)) - (setf rgbs (make-array used)))) - (8 - (if (or (= used 0) (= used 256)) - (setf rgbs (make-array 256)) - (setf rgbs (make-array used)))) - (16 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (24 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (32 - (unless (/= used 0) - (setf rgbs (make-array used))))) - (dotimes (i (length rgbs)) - (let ((quad (read-value 'RGBQUAD in))) - (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) - :green (rgbGreen quad) - :blue (rgbBlue quad))))) - (setf (palette-of self) (gfg:make-palette :direct nil :table rgbs))) - - ;; load pixel bits - ;; - (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) - (setf (pixels-of self) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) - (read-sequence (pixels-of self) in)) - - ;; complete load - ;; - (setf (slot-value self 'gfs:handle) info)))) - (defmethod gfg:size ((self default-data-plugin)) (let ((info (gfs:handle self))) (unless info Modified: trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Mon Aug 7 12:14:19 2006 @@ -138,3 +138,22 @@ (rgbGreen BYTE) (rgbRed BYTE) (rgbReserved BYTE))) + +;;; +;;; Win32 GDI Icon Formats +;;; + +(define-binary-class ICONDIR () + ((idReserved WORD) + (idType WORD) + (idCount WORD))) ; ICONDIRENTRY array read separately + +(define-binary-class ICONDIRENTRY () + ((ideWidth BYTE) + (ideHeight BYTE) + (ideColorCount BYTE) + (ideReserved BYTE) + (idePlanes WORD) + (ideBitCount WORD) + (ideBytesInRes DWORD) + (ideImageOffset DWORD))) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Mon Aug 7 12:14:19 2006 @@ -140,6 +140,20 @@ (floor quant 257)) ;;; +;;; translated from list.h +;;; + +(defcfun + ("GetFirstImageInList" get-first-image-in-list) + :pointer ;; Image* + (images :pointer)) ;; Image* + +(defcfun + ("GetNextImageInList" get-next-image-in-list) + :pointer ;; Image* + (images :pointer)) ;; Image* + +;;; ;;; translated from magick.h ;;; Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Mon Aug 7 12:14:19 2006 @@ -36,23 +36,23 @@ (defclass magick-data-plugin (gfg:image-data-plugin) () (:documentation "ImageMagick library plugin for the graphics package.")) -(defun accepts-file-p (path) +(defun loader (path) (unless *magick-initialized* (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) - (cond - ((parse-namestring path)) ; syntax check - ((typep path 'pathname) - (setf path (namestring path))) - (t - (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) (if (gethash (pathname-type path) gfg:*image-file-types*) - (let ((plugin (make-instance 'magick-data-plugin))) - (gfg:load plugin path) - plugin) + (with-image-path (path info ex) + (let ((images-ptr (read-image info ex))) + (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) + (error 'gfs:toolkit-error :detail (format nil + "exception reason: ~s" + (cffi:foreign-slot-value ex 'exception-info 'reason)))) + (loop for ptr = (get-next-image-in-list images-ptr) + until (cffi:null-pointer-p ptr) + collect (make-instance 'magic-data-plugin :handle ptr)))) nil)) -(push #'accepts-file-p gfg::*image-plugins*) +(push #'loader gfg::*image-plugins*) (defmethod gfg:data->image ((self magick-data-plugin)) (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) @@ -128,22 +128,6 @@ (destroy-image victim))) (setf (slot-value self 'gfs:handle) nil)) -(defmethod gfg:load ((self magick-data-plugin) path) - (let ((handle (gfs:handle self))) - (when (and handle (not (cffi:null-pointer-p handle))) - (destroy-image handle) - (setf (slot-value self 'gfs:handle) nil) - (setf handle nil)) - (with-image-path (path info ex) - (setf handle (read-image info ex)) - (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) - (error 'gfs:toolkit-error :detail (format nil - "exception reason: ~s" - (cffi:foreign-slot-value ex 'exception-info 'reason)))) - (if (cffi:null-pointer-p handle) - (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) - (setf (slot-value self 'gfs:handle) handle)))) - (defmethod gfg:size ((self magick-data-plugin)) (let ((handle (gfs:handle self)) (size (gfs:make-size)))

1 0

[graphic-forms-cvs] r200 - in trunk/src: . uitoolkit/graphics uitoolkit/graphics/plugins/default uitoolkit/graphics/plugins/imagemagick uitoolkit/system
by junrue＠common-lisp.net 05 Aug '06

05 Aug '06

Author: junrue Date: Fri Aug 4 22:50:30 2006 New Revision: 200 Modified: trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-types.lisp Log: default graphics data plugin is now working for BMPs Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Aug 4 22:50:30 2006 @@ -193,6 +193,7 @@ #:make-color #:make-font-data #:make-image-data + #:make-palette #:matrix #:maximum-char-width #:metrics Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Fri Aug 4 22:50:30 2006 @@ -79,7 +79,10 @@ (green-shift 0) (blue-shift 0) (direct nil) - (table nil))) ; vector of COLOR structs + (table nil)) ; vector of COLOR structs + + (defmacro color-table (data) + `(gfg::palette-table ,data))) (defclass image-data-plugin (gfs:native-object) () (:documentation "Graphics library plugin implementation objects.")) @@ -151,9 +154,6 @@ (defmacro red-shift (data) `(gfg::palette-red-shift ,data)) -(defmacro color-table (data) - `(gfg::palette-table ,data)) - (defclass pattern (gfs:native-object) () (:documentation "This class represents a pattern to be used with a brush.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Fri Aug 4 22:50:30 2006 @@ -34,7 +34,9 @@ (in-package :graphic-forms.uitoolkit.graphics) (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *image-plugins* nil)) + (defvar *image-plugins* nil) + + (cffi:defctype bmp-pointer :pointer)) ;; ;; list the superset of file extensions for formats that any @@ -193,10 +195,8 @@ (error 'gfs:toolkit-error :detail "pathname or string required")))) (let ((plugin (data-plugin-of self))) - (when plugin - (gfs:dispose plugin) - (setf (slot-value self 'data-plugin) nil)) - (setf plugin (find-image-plugin path)) + (unless plugin + (setf plugin (find-image-plugin path))) (unless plugin (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path))) (load plugin path) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Fri Aug 4 22:50:30 2006 @@ -33,9 +33,18 @@ (in-package :graphic-forms.uitoolkit.graphics.default) -(defclass default-data-plugin (gfg:image-data-plugin) () +(defclass default-data-plugin (gfg:image-data-plugin) + ((palette + :accessor palette-of + :initform nil) + (pixels + :accessor pixels-of + :initform nil)) (:documentation "Default library plugin for the graphics package.")) +(defmacro bitmap-pixel-row-length (width bit-count) + `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) + (defun accepts-file-p (path) (cond ((parse-namestring path)) ; syntax check @@ -44,10 +53,146 @@ (t (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) (let ((ext (pathname-type path))) - (if (or (string-equal ext "ico") (string-equal ext "bmp")) +; (if (or (string-equal ext "ico") (string-equal ext "bmp")) + (if (string-equal ext "bmp") (let ((plugin (make-instance 'default-data-plugin))) (gfg:load plugin path) plugin) nil))) (push #'accepts-file-p gfg::*image-plugins*) + +(defmethod gfg:data->image ((self default-data-plugin)) + (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) + (hbmp (cffi:null-pointer))) + (unwind-protect + (cffi:with-foreign-object (pix-bits-ptr :pointer) + (setf hbmp (gfs::create-dib-section screen-dc + self + gfs::+dib-rgb-colors+ + pix-bits-ptr + (cffi:null-pointer) + 0)) + (if (gfs:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-dib-section failed")) + (let ((plugin-pixels (pixels-of self)) + (ptr (cffi:mem-ref pix-bits-ptr :pointer))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref ptr :uint8 i) (aref plugin-pixels i))))) + (gfs::release-dc (cffi:null-pointer) screen-dc)) + hbmp)) + +(defmethod gfg:depth ((self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (biBitCount info))) + +(defmethod gfs:dispose ((self default-data-plugin)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod cffi:free-translated-object (pixels-ptr (name (eql 'gfs::bitmap-pixels-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free pixels-ptr)) + +(defmethod cffi:free-translated-object (bi-ptr (name (eql 'gfs::bitmap-info-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free bi-ptr)) + +(defmethod gfg:load ((self default-data-plugin) path) + (with-open-file (in path :element-type '(unsigned-byte 8)) + (let ((header (read-value 'BITMAPFILEHEADER in)) + (info (read-value 'BASE-BITMAPINFOHEADER in))) + (declare (ignore header)) + (unless (= (biCompression info) gfs::+bi-rgb+) + (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + + ;; load color table + ;; + (let ((used (biClrUsed info)) + (rgbs nil)) + (ecase (biBitCount info) + (1 + (setf rgbs (make-array 2))) + (4 + (if (or (= used 0) (= used 16)) + (setf rgbs (make-array 16)) + (setf rgbs (make-array used)))) + (8 + (if (or (= used 0) (= used 256)) + (setf rgbs (make-array 256)) + (setf rgbs (make-array used)))) + (16 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (24 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (32 + (unless (/= used 0) + (setf rgbs (make-array used))))) + (dotimes (i (length rgbs)) + (let ((quad (read-value 'RGBQUAD in))) + (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) + :green (rgbGreen quad) + :blue (rgbBlue quad))))) + (setf (palette-of self) (gfg:make-palette :direct nil :table rgbs))) + + ;; load pixel bits + ;; + (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) + (setf (pixels-of self) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) + (read-sequence (pixels-of self) in)) + + ;; complete load + ;; + (setf (slot-value self 'gfs:handle) info)))) + +(defmethod gfg:size ((self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (gfs:make-size :width (biWidth info) :height (biHeight info)))) + +(defmethod (setf gfg:size) (size (self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (setf (biWidth info) (gfs:size-width size) + (biHeight info) (gfs:size-height size))) + size) + +(defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) + (name (eql 'gfs::bitmap-pixels-pointer))) + (let* ((plugin-pixels (pixels-of lisp-obj)) + (pixels-ptr (cffi:foreign-alloc :uint8 :count (length plugin-pixels)))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref pixels-ptr :uint8 i) (aref plugin-pixels i))) + pixels-ptr)) + +(defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) + (name (eql 'gfs::bitmapinfo-pointer))) + (let ((bi-ptr (cffi:foreign-alloc 'gfs::bitmapinfo))) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes gfs::bibitcount + gfs::bicompression gfs::bmicolors) + bi-ptr gfs::bitmapinfo) + (gfs::zero-mem bi-ptr gfs::bitmapinfo) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biplanes 1 + gfs::bibitcount (gfg:depth lisp-obj) + gfs::bicompression gfs::+bi-rgb+) + (let ((im-size (gfg:size lisp-obj))) + (setf gfs::biwidth (gfs:size-width im-size) + gfs::biheight (gfs:size-height im-size))) + (let ((colors (gfg:color-table (palette-of lisp-obj))) + (ptr (cffi:foreign-slot-pointer bi-ptr 'gfs::bitmapinfo 'gfs::bmicolors))) + (dotimes (i (length colors)) + (let ((clr (aref colors i))) + (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen + gfs::rgbred gfs::rgbreserved) + (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbblue (gfg:color-blue clr) + gfs::rgbgreen (gfg:color-green clr) + gfs::rgbred (gfg:color-red clr) + gfs::rgbreserved 0)))))) + bi-ptr)) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Fri Aug 4 22:50:30 2006 @@ -55,7 +55,6 @@ (push #'accepts-file-p gfg::*image-plugins*) (defmethod gfg:data->image ((self magick-data-plugin)) - "Convert the image-data object to a bitmap and return the native handle." (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth @@ -127,7 +126,7 @@ (let ((victim (gfs:handle self))) (unless (or (null victim) (cffi:null-pointer-p victim)) (destroy-image victim))) - (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) + (setf (slot-value self 'gfs:handle) nil)) (defmethod gfg:load ((self magick-data-plugin) path) (let ((handle (gfs:handle self))) @@ -176,4 +175,5 @@ 'reason)))) (setf (slot-value self 'gfs:handle) new-handle) (destroy-image handle)) - (destroy-exception-info ex)))) + (destroy-exception-info ex))) + size) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Aug 4 22:50:30 2006 @@ -117,7 +117,7 @@ (hdc HANDLE) (pheader LPTR) (option DWORD) - (pinit LPTR) + (pinit bitmap-pixels-pointer) (pbmp LPTR) (usage UINT)) @@ -125,7 +125,7 @@ ("CreateDIBSection" create-dib-section) HANDLE (hdc HANDLE) - (bmi LPTR) + (bmi bitmapinfo-pointer) (usage UINT) (values LPTR) ;; VOID ** (section HANDLE) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Aug 4 22:50:30 2006 @@ -114,6 +114,9 @@ (biclrimp DWORD) (bmicolors BYTE :count 1024)) ; allocate space for max palette (256 RGBQUADs) +(defctype bitmapinfo-pointer :pointer) +(defctype bitmap-pixels-pointer :pointer) + (defcstruct bitmapinfoheader (bisize DWORD) (biwidth LONG)

1 0

[graphic-forms-cvs] r199 - in trunk: . src/external-libraries src/external-libraries/practicals-1.0.3 src/external-libraries/practicals-1.0.3/Chapter08 src/external-libraries/practicals-1.0.3/Chapter24 src/uitoolkit/graphics src/uitoolkit/graphics/plugins src/uitoolkit/graphics/plugins/default
by junrue＠common-lisp.net 02 Aug '06

02 Aug '06

Author: junrue Date: Wed Aug 2 17:37:56 2006 New Revision: 199 Added: trunk/src/external-libraries/ trunk/src/external-libraries/practicals-1.0.3/ trunk/src/external-libraries/practicals-1.0.3/Chapter08/ trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter24/ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp trunk/src/external-libraries/practicals-1.0.3/LICENSE trunk/src/external-libraries/practicals-1.0.3/readme.txt trunk/src/uitoolkit/graphics/plugins/default/ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Modified: trunk/build.lisp trunk/config.lisp trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Log: initial work on default graphics data plugin Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Wed Aug 2 17:37:56 2006 @@ -44,14 +44,16 @@ (defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) (defvar *project-root* "c:/projects/public/") -(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) -(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/")) -(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) -(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) -(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) +(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/")) +(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) +(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) +(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) +(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) +(setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")) -(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) +(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Wed Aug 2 17:37:56 2006 @@ -39,16 +39,20 @@ (in-package #:graphic-forms-system) -(defvar *cells-dir* "cells/") -(defvar *cffi-dir* "cffi-060606/") -(defvar *closer-mop-dir* "closer-mop/") -(defvar *lw-compat-dir* "lw-compat/") -(defvar *gf-dir* "graphic-forms/") +(defvar *binary-data-dir* (merge-pathnames "src/external-libraries/practicals-1.0.3/binary-data/")) +(defvar *cells-dir* "cells/") +(defvar *cffi-dir* "cffi-060606/") +(defvar *closer-mop-dir* "closer-mop/") +(defvar *lw-compat-dir* "lw-compat/") +(defvar *macro-utilities-dir* "macro-utilities/") +(defvar *gf-dir* "graphic-forms/") -(defvar *lisp-unit-file* "lisp-unit") +(defvar *lisp-unit-file* "lisp-unit") (defun configure-asdf () - (pushnew *cells-dir* asdf:*central-registry* :test #'equal) - (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) - (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) - (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal)) + (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) + (pushnew *cells-dir* asdf:*central-registry* :test #'equal) + (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) + (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) + (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal) + (pushnew *macro-utilities-dir* asdf:*central-registry* :test #'equal)) Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Aug 2 17:37:56 2006 @@ -42,7 +42,7 @@ :version "0.3.0" :author "Jack D. Unrue" :licence "BSD" - :depends-on ("cffi" "lw-compat" "closer-mop") + :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") :components ((:module "src" :components @@ -82,14 +82,16 @@ (:module "plugins" :components ((:file "graphics-plugin-packages") -#+load-imagemagick-plugin - (:module "imagemagick" - ; :depends-on ("graphics") - :components - ((:file "magick-core-types") - (:file "magick-core-api") - (:file "magick-data-plugin" - :depends-on ("magick-core-types" "magick-core-api")))))))) +#-skip-default-plugin (:module "default" + :components + ((:file "file-formats") + (:file "default-data-plugin"))) +#+load-imagemagick-plugin (:module "imagemagick" + :components + ((:file "magick-core-types") + (:file "magick-core-api") + (:file "magick-data-plugin" + :depends-on ("magick-core-types" "magick-core-api")))))))) (:module "widgets" :depends-on ("graphics") :components Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,14 @@ +(defpackage :com.gigamonkeys.chapter-8-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.chapter-8-system) + +(defsystem chapter-8 + :name "chapter-8" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Code from Chapter 8 of Practical Common Lisp" + :long-description "" + :depends-on ("macro-utilities")) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,17 @@ +(defpackage :com.gigamonkeys.macro-utilities-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.macro-utilities-system) + +(defsystem macro-utilities + :name "macro-utilities" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Utilities for writing macros" + :long-description "" + :components + ((:file "packages") + (:file "macro-utilities" :depends-on ("packages"))) + :depends-on ()) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,28 @@ +(in-package :com.gigamonkeys.macro-utilities) + +(defmacro with-gensyms ((&rest names) &body body) + `(let ,(loop for n in names collect `(,n (make-symbol ,(string n)))) + ,@body)) + +(defmacro once-only ((&rest names) &body body) + (let ((gensyms (loop for n in names collect (gensym (string n))))) + `(let (,@(loop for g in gensyms collect `(,g (gensym)))) + `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) + ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) + ,@body))))) + +(defun spliceable (value) + (if value (list value))) + +(defmacro ppme (form &environment env) + (progn + (write (macroexpand-1 form env) + :length nil + :level nil + :circle nil + :pretty t + :gensym nil + :right-margin 83 + :case :downcase) + nil)) + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,11 @@ +(in-package :cl-user) + +(defpackage :com.gigamonkeys.macro-utilities + (:use :common-lisp) + (:export + :with-gensyms + :with-gensymed-defuns + :once-only + :spliceable + :ppme)) + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,17 @@ +(defpackage :com.gigamonkeys.binary-data-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.binary-data-system) + +(defsystem binary-data + :name "binary-data" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Parser for binary data files. " + :long-description "" + :components + ((:file "packages") + (:file "binary-data" :depends-on ("packages"))) + :depends-on (:macro-utilities)) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,160 @@ +(in-package :com.gigamonkeys.binary-data) + +(defvar *in-progress-objects* nil) + +(defconstant +null+ (code-char 0)) + +(defgeneric read-value (type stream &key) + (:documentation "Read a value of the given type from the stream.")) + +(defgeneric write-value (type stream value &key) + (:documentation "Write a value as the given type to the stream.")) + +(defgeneric read-object (object stream) + (:method-combination progn :most-specific-last) + (:documentation "Fill in the slots of object from stream.")) + +(defgeneric write-object (object stream) + (:method-combination progn :most-specific-last) + (:documentation "Write out the slots of object to the stream.")) + +(defmethod read-value ((type symbol) stream &key) + (let ((object (make-instance type))) + (read-object object stream) + object)) + +(defmethod write-value ((type symbol) stream value &key) + (assert (typep value type)) + (write-object value stream)) + + +;;; Binary types + +(defmacro define-binary-type (name (&rest args) &body spec) + (with-gensyms (type stream value) + `(progn + (defmethod read-value ((,type (eql ',name)) ,stream &key ,@args) + (declare (ignorable ,@args)) + ,(type-reader-body spec stream)) + (defmethod write-value ((,type (eql ',name)) ,stream ,value &key ,@args) + (declare (ignorable ,@args)) + ,(type-writer-body spec stream value))))) + +(defun type-reader-body (spec stream) + (ecase (length spec) + (1 (destructuring-bind (type &rest args) (mklist (first spec)) + `(read-value ',type ,stream ,@args))) + (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec)) + `(let ((,in ,stream)) ,@body))))) + +(defun type-writer-body (spec stream value) + (ecase (length spec) + (1 (destructuring-bind (type &rest args) (mklist (first spec)) + `(write-value ',type ,stream ,value ,@args))) + (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec)) + `(let ((,out ,stream) (,v ,value)) ,@body))))) + + +;;; Binary classes + +(defmacro define-generic-binary-class (name (&rest superclasses) slots read-method) + (with-gensyms (objectvar streamvar) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get ',name 'slots) ',(mapcar #'first slots)) + (setf (get ',name 'superclasses) ',superclasses)) + + (defclass ,name ,superclasses + ,(mapcar #'slot->defclass-slot slots)) + + ,read-method + + (defmethod write-object progn ((,objectvar ,name) ,streamvar) + (declare (ignorable ,streamvar)) + (with-slots ,(new-class-all-slots slots superclasses) ,objectvar + ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots)))))) + +(defmacro define-binary-class (name (&rest superclasses) slots) + (with-gensyms (objectvar streamvar) + `(define-generic-binary-class ,name ,superclasses ,slots + (defmethod read-object progn ((,objectvar ,name) ,streamvar) + (declare (ignorable ,streamvar)) + (with-slots ,(new-class-all-slots slots superclasses) ,objectvar + ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots)))))) + +(defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options) + (with-gensyms (typevar objectvar streamvar) + `(define-generic-binary-class ,name ,superclasses ,slots + (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key) + (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots) + (let ((,objectvar + (make-instance + ,@(or (cdr (assoc :dispatch options)) + (error "Must supply :disptach form.")) + ,@(mapcan #'slot->keyword-arg slots)))) + (read-object ,objectvar ,streamvar) + ,objectvar)))))) + +(defun as-keyword (sym) (intern (string sym) :keyword)) + +(defun normalize-slot-spec (spec) + (list (first spec) (mklist (second spec)))) + +(defun mklist (x) (if (listp x) x (list x))) + +(defun slot->defclass-slot (spec) + (let ((name (first spec))) + `(,name :initarg ,(as-keyword name) :accessor ,name))) + +(defun slot->read-value (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(setf ,name (read-value ',type ,stream ,@args)))) + +(defun slot->write-value (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(write-value ',type ,stream ,name ,@args))) + +(defun slot->binding (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(,name (read-value ',type ,stream ,@args)))) + +(defun slot->keyword-arg (spec) + (let ((name (first spec))) + `(,(as-keyword name) ,name))) + +;;; Keeping track of inherited slots + +(defun direct-slots (name) + (copy-list (get name 'slots))) + +(defun inherited-slots (name) + (loop for super in (get name 'superclasses) + nconc (direct-slots super) + nconc (inherited-slots super))) + +(defun all-slots (name) + (nconc (direct-slots name) (inherited-slots name))) + +(defun new-class-all-slots (slots superclasses) + "Like all slots but works while compiling a new class before slots +and superclasses have been saved." + (nconc (mapcan #'all-slots superclasses) (mapcar #'first slots))) + +;;; In progress Object stack + +(defun current-binary-object () + (first *in-progress-objects*)) + +(defun parent-of-type (type) + (find-if #'(lambda (x) (typep x type)) *in-progress-objects*)) + +(defmethod read-object :around (object stream) + (declare (ignore stream)) + (let ((*in-progress-objects* (cons object *in-progress-objects*))) + (call-next-method))) + +(defmethod write-object :around (object stream) + (declare (ignore stream)) + (let ((*in-progress-objects* (cons object *in-progress-objects*))) + (call-next-method))) + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,14 @@ +(defpackage :com.gigamonkeys.chapter-24-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.chapter-24-system) + +(defsystem chapter-24 + :name "chapter-24" + :author "Peter Seibel <peter(a)gigamonkeys.com>" + :version "1.0" + :maintainer "Peter Seibel <peter(a)gigamonkeys.com>" + :licence "BSD" + :description "Code from Chapter 24 of Practical Common Lisp" + :long-description "" + :depends-on ("binary-data")) + + Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,13 @@ +(in-package :cl-user) + +(defpackage :com.gigamonkeys.binary-data + (:use :common-lisp :com.gigamonkeys.macro-utilities) + (:export :define-binary-class + :define-tagged-binary-class + :define-binary-type + :read-value + :write-value + :*in-progress-objects* + :parent-of-type + :current-binary-object + :+null+)) Added: trunk/src/external-libraries/practicals-1.0.3/LICENSE ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/LICENSE Wed Aug 2 17:37:56 2006 @@ -0,0 +1,29 @@ +Copyright (c) 2005, Peter Seibel All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the Peter Seibel nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: trunk/src/external-libraries/practicals-1.0.3/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/readme.txt Wed Aug 2 17:37:56 2006 @@ -0,0 +1,12 @@ +This directory contains a subset of the source code for +_Practical Common Lisp_ by Peter Seibel. The subset consists +of the code from two chapters of that book: Chapter 8 defining +a set of macro utilities that is needed by the binary file +input/output library featured in Chapter 24. + +The LICENSE file contains Peter Seibel's license statement +for this code. + +The complete distribution may be downloaded from: + + http://gigamonkeys.com/book/practicals-1.0.3.zip Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Wed Aug 2 17:37:56 2006 @@ -33,7 +33,8 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defvar *image-plugins* nil) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *image-plugins* nil)) ;; ;; list the superset of file extensions for formats that any Added: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,53 @@ +;;;; +;;;; default-data-plugin.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.graphics.default) + +(defclass default-data-plugin (gfg:image-data-plugin) () + (:documentation "Default library plugin for the graphics package.")) + +(defun accepts-file-p (path) + (cond + ((parse-namestring path)) ; syntax check + ((typep path 'pathname) + (setf path (namestring path))) + (t + (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) + (let ((ext (pathname-type path))) + (if (or (string-equal ext "ico") (string-equal ext "bmp")) + (let ((plugin (make-instance 'default-data-plugin))) + (gfg:load plugin path) + plugin) + nil))) + +(push #'accepts-file-p gfg::*image-plugins*) Added: trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,140 @@ +;;;; +;;;; file-formats.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.graphics.default) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :com.gigamonkeys.binary-data)) + +;;; +;;; fundamental binary types used by image definitions +;;; + +;; This utility was copied from Peter Seibel's id3v2 package, +;; renamed to signify that it is for big-endian values. +;; +(define-binary-type unsigned-integer-be (bytes bits-per-byte) + (:reader (in) + (loop with value = 0 + for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do + (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) + finally (return value))) + (:writer (out value) + (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte + do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) + +;; This utility is based on the same unsigned-integer binary type, +;; but this one is for little-endian types. +;; +(define-binary-type unsigned-integer-le (bytes bits-per-byte) + (:reader (in) + (loop with value = 0 + for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte do + (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) + finally (return value))) + (:writer (out value) + (loop for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte + do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) + +;;; aliases for single-byte and 32-bit types with names +;;; matching the GDI docs +;;; +(define-binary-type BYTE () (unsigned-integer-le :bytes 1 :bits-per-byte 8)) +(define-binary-type DWORD () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type FXPT2DOT30 () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type LONG () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type WORD () (unsigned-integer-le :bytes 2 :bits-per-byte 8)) + +;;; +;;; Win32 GDI Bitmap Formats +;;; + +(define-binary-class BITMAPFILEHEADER () + ((bfType WORD) + (bfSize DWORD) + (bfReserved1 WORD) + (bfReserved2 WORD) + (bfOffBits DWORD))) + +(define-binary-class CIEXYZ () + ((ciexyzX FXPT2DOT30) + (ciexyzY FXPT2DOT30) + (ciexyzZ FXPT2DOT30))) + +(define-binary-class CIEXYZTRIPLE () + ((ciexyzRed CIEXYZ) + (ciexyzGreen CIEXYZ) + (ciexyzBlue CIEXYZ))) + +(define-tagged-binary-class BASE-BITMAPINFOHEADER () + ((biSize DWORD) + (biWidth LONG) + (biHeight LONG) + (biPlanes WORD) + (biBitCount WORD) + (biCompression DWORD) + (biSizeImage DWORD) + (biXPelsPerMeter LONG) + (biYPelsPerMeter LONG) + (biClrUsed DWORD) + (biClrImportant DWORD)) + (:dispatch + (ecase biSize + (40 'BITMAPINFOHEADER) + (120 'BITMAPV4HEADER) + (124 'BITMAPV5HEADER)))) + +(define-binary-class BITMAPINFOHEADER (BASE-BITMAPINFOHEADER) ()) + +(define-binary-class BITMAPV4HEADER (BASE-BITMAPINFOHEADER) + ((bv4RedMask DWORD) + (bv4GreenMask DWORD) + (bv4BlueMask DWORD) + (bv4AlphaMask DWORD) + (bv4CSType DWORD) + (bv4Endpoints CIEXYZTRIPLE) + (bv4GammaRed DWORD) + (bv4GammaGreen DWORD) + (bv4GammaBlue DWORD))) + +(define-binary-class BITMAPV5HEADER (BITMAPV4HEADER) + ((bv5Intent DWORD) + (bv5ProfileData DWORD) + (bv5ProfileSize DWORD) + (bv5Reserved DWORD))) + +(define-binary-class RGBQUAD () + ((rgbBlue BYTE) + (rgbGreen BYTE) + (rgbRed BYTE) + (rgbReserved BYTE))) Modified: trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Wed Aug 2 17:37:56 2006 @@ -34,10 +34,10 @@ (in-package #:cl-user) ;;; -;;; package for base Win32 graphics plugin +;;; package for default Win32 graphics plugin ;;; -(defpackage #:graphic-forms.uitoolkit.graphics.win32 - (:nicknames #:gfgw32) +(defpackage #:graphic-forms.uitoolkit.graphics.default + (:nicknames #:gfgd) (:shadow #:load #:type) (:use #:common-lisp) (:export

1 0

[graphic-forms-cvs] r198 - in trunk: . src src/uitoolkit/graphics src/uitoolkit/graphics/plugins src/uitoolkit/graphics/plugins/imagemagick src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Jul '06

17 Jul '06

Author: junrue Date: Mon Jul 17 00:48:13 2006 New Revision: 198 Added: trunk/src/uitoolkit/graphics/plugins/ trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp - copied, changed from r153, trunk/src/uitoolkit/graphics/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp - copied, changed from r58, trunk/src/uitoolkit/graphics/magick-core-types.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Removed: trunk/src/uitoolkit/graphics/magick-core-api.lisp trunk/src/uitoolkit/graphics/magick-core-types.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: created a plugin system for choosing what library code to load for image data processing, moved existing ImageMagick support into such a plugin Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Jul 17 00:48:13 2006 @@ -69,9 +69,7 @@ (:module "graphics" :depends-on ("system") :components - ((:file "magick-core-types") - (:file "magick-core-api") - (:file "graphics-constants") + ((:file "graphics-constants") (:file "graphics-classes") (:file "graphics-generics") (:file "color") @@ -80,7 +78,18 @@ (:file "image") (:file "font-data") (:file "font") - (:file "graphics-context"))) + (:file "graphics-context") + (:module "plugins" + :components + ((:file "graphics-plugin-packages") +#+load-imagemagick-plugin + (:module "imagemagick" + ; :depends-on ("graphics") + :components + ((:file "magick-core-types") + (:file "magick-core-api") + (:file "magick-data-plugin" + :depends-on ("magick-core-types" "magick-core-api")))))))) (:module "widgets" :depends-on ("graphics") :components Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Jul 17 00:48:13 2006 @@ -111,6 +111,7 @@ #:graphics-context #:image #:image-data + #:image-data-plugin #:palette #:pattern #:transform @@ -121,8 +122,10 @@ #:*color-green* #:*color-red* #:*color-white* + #:*image-file-types* ;; methods, functions, macros + #:accepts-file-p #:alpha #:anti-alias #:ascent @@ -142,6 +145,7 @@ #:copy-color #:copy-font-data #:copy-font-metrics + #:data->image #:data-object #:depth #:descent Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Jul 17 00:48:13 2006 @@ -81,7 +81,13 @@ (direct nil) (table nil))) ; vector of COLOR structs -(defclass image-data (gfs:native-object) () +(defclass image-data-plugin (gfs:native-object) () + (:documentation "Graphics library plugin implementation objects.")) + +(defclass image-data () + ((data-plugin + :reader data-plugin-of + :initform nil)) (:documentation "This class maintains image attributes, color, and pixel data.")) (defclass font (gfs:native-object) () Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Jul 17 00:48:13 2006 @@ -36,6 +36,9 @@ (defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) +(defgeneric data->image (self) + (:documentation "Plugins implement this to translate from a data structure to an HGDIOBJ.")) + (defgeneric data-object (self &optional gc) (:documentation "Returns the data structure representing the raw form of the object.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Jul 17 00:48:13 2006 @@ -33,10 +33,54 @@ (in-package :graphic-forms.uitoolkit.graphics) +(defvar *image-plugins* nil) + +;; +;; list the superset of file extensions for formats that any +;; plugin might support (clearly there are more formats than +;; this extant in the world, so add more as needed) +;; +(defvar *image-file-types* (let ((table (make-hash-table :test #'equal))) + (loop for (key value) in '(("bmp" "Microsoft Windows bitmap") + ("cur" "Microsoft Windows cursor") + ("dib" "Microsoft Windows device-independent bitmap") + ("emf" "Microsoft Windows Enhanced Metafile") + ("eps" "Adobe Encapsulated PostScript") + ("fax" "Group 3 TIFF") + ("fig" "FIG graphics format") + ("gif" "CompuServe Graphics Interchange Format") + ("ico" "Microsoft Windows icon") + ("jpeg" "Joint Photographic Experts Group") + ("jpg" "Joint Photographic Experts Group") + ("pbm" "Portable bitmap format (b/w)") + ("pcd" "Photo CD") + ("pcl" "HP Page Control Language") + ("pcx" "ZSoft IBM PC Paintbrush") + ("pdf" "Portable Document Format") + ("pgm" "Portable graymap") + ("pix" "Alias/Wavefront RLE") + ("png" "Portable Network Graphics") + ("ppm" "Portable pixmap (color)") + ("ps" "Adobe PostScript") + ("svg" "Scalable Vector Graphics") + ("tga" "Truevision Targa") + ("tiff" "Tagged Image File") + ("wmf" "Microsoft Windows Metafile") + ("xbm" "X Window System bitmap (b/w)") + ("xpm" "X Window System pixmap (color)")) + do (setf (gethash key table) value)) + table)) + ;;; ;;; helper functions ;;; +(defun find-image-plugin (path) + (loop for acceptor in *image-plugins* + for plugin = (funcall acceptor path) + until plugin + finally (return plugin))) + (defun image->data (hbmp) (declare (ignore hbmp))) #| (defun image->data (hbmp) @@ -124,147 +168,52 @@ data)) |# -(defun data->image (data) - "Convert the image-data object to a bitmap and return the native handle." - (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) - (cffi:with-foreign-slots ((gfs::bisize - gfs::biwidth - gfs::biheight - gfs::biplanes - gfs::bibitcount - gfs::bicompression - gfs::bisizeimage - gfs::bixpels - gfs::biypels - gfs::biclrused - gfs::biclrimp - gfs::bmicolors) - bi-ptr gfs::bitmapinfo) - (let* ((handle (gfs:handle data)) - (sz (size data)) - (pix-count (* (gfs:size-width sz) (gfs:size-height sz))) - (hbmp (cffi:null-pointer)) - (screen-dc (gfs::get-dc (cffi:null-pointer)))) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biwidth (gfs:size-width sz) - gfs::biheight (- 0 (gfs:size-height sz)) - gfs::biplanes 1 - gfs::bibitcount 32 ;; 32bpp even if original image file is not - gfs::bicompression gfs::+bi-rgb+ - gfs::bisizeimage 0 - gfs::bixpels 0 - gfs::biypels 0 - gfs::biclrused 0 - gfs::biclrimp 0) - - ;; create the bitmap - ;; - (cffi:with-foreign-object (pix-bits-ptr :pointer) - (setf hbmp (gfs::create-dib-section screen-dc - bi-ptr - gfs::+dib-rgb-colors+ - pix-bits-ptr - (cffi:null-pointer) - 0)) - (if (gfs:null-handle-p hbmp) - (error 'gfs:win32-error :detail "create-dib-section failed")) - - ;; update the RGBQUADs - ;; - (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz))) - (ptr (cffi:mem-ref pix-bits-ptr :pointer))) - (dotimes (i pix-count) - (cffi:with-foreign-slots ((gfg::blue gfg::green gfg::red gfg::reserved) - (cffi:mem-aref tmp 'gfg::pixel-packet i) - gfg::pixel-packet) - (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved) - (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) - (setf gfs::rgbreserved 0) - (setf gfs::rgbred (scale-quantum-to-byte red)) - (setf gfs::rgbgreen (scale-quantum-to-byte green)) - (setf gfs::rgbblue (scale-quantum-to-byte blue))))))) - (unless (gfs:null-handle-p screen-dc) - (gfs::release-dc (cffi:null-pointer) screen-dc)) - hbmp)))) - ;;; ;;; methods ;;; -(defmethod depth ((data image-data)) - (let ((handle (gfs:handle data))) - (if (null handle) - (error 'gfs:disposed-error)) - (cffi:foreign-slot-value handle 'magick-image 'depth))) - -(defmethod gfs:dispose ((data image-data)) - (let ((victim (gfs:handle data))) - (if (null victim) - (error 'gfs:disposed-error)) - (destroy-image victim)) - (setf (slot-value data 'gfs:handle) nil)) +(defmethod data->image ((self image-data)) + (data->image (data-plugin-of self))) + +(defmethod depth ((self image-data)) + (depth (data-plugin-of self))) -(defmethod load ((data image-data) path) +(defmethod gfs:dispose ((self image-data)) + (let ((victim (data-plugin-of self))) + (unless (null victim) + (gfs:dispose victim))) + (setf (slot-value self 'data-plugin) nil)) + +(defmethod load ((self image-data) path) (setf path (cond ((typep path 'pathname) (namestring (merge-pathnames path))) ((typep path 'string) (namestring (merge-pathnames path))) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) - (let ((handle (gfs:handle data))) - (when (and handle (not (cffi:null-pointer-p handle))) - (destroy-image handle) - (setf (slot-value data 'gfs:handle) nil) - (setf handle nil)) - (with-image-path (path info ex) - (setf handle (read-image info ex)) - (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) - (error 'gfs:toolkit-error :detail (format nil - "exception reason: ~s" - (cffi:foreign-slot-value ex 'exception-info 'reason)))) - (if (cffi:null-pointer-p handle) - (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) - (setf (slot-value data 'gfs:handle) handle)))) - -(defmethod size ((data image-data)) - (let ((handle (gfs:handle data)) - (size (gfs:make-size))) - (if (or (null handle) (cffi:null-pointer-p handle)) - (error 'gfs:disposed-error)) - (cffi:with-foreign-slots ((rows columns) handle magick-image) - (setf (gfs:size-height size) rows) - (setf (gfs:size-width size) columns)) - size)) - -(defmethod (setf size) (size (data image-data)) - (let ((handle (gfs:handle data)) - (new-handle (cffi:null-pointer)) - (ex (acquire-exception-info))) - (if (or (null handle) (cffi:null-pointer-p handle)) - (error 'gfs:disposed-error)) - (unwind-protect - (progn - (setf new-handle (resize-image handle - (gfs:size-width size) - (gfs:size-height size) - (cffi:foreign-enum-value 'filter-types :lanczos) - 1.0 ex)) - (if (gfs:null-handle-p new-handle) - (error 'gfs:toolkit-error :detail (format nil - "could not resize: ~a" - (cffi:foreign-slot-value ex - 'exception-info - 'reason)))) - (setf (slot-value data 'gfs:handle) new-handle) - (destroy-image handle)) - (destroy-exception-info ex)))) -(defmethod print-object ((data image-data) stream) - (if (or (null (gfs:handle data)) (cffi:null-pointer-p (gfs:handle data))) + (let ((plugin (data-plugin-of self))) + (when plugin + (gfs:dispose plugin) + (setf (slot-value self 'data-plugin) nil)) + (setf plugin (find-image-plugin path)) + (unless plugin + (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path))) + (load plugin path) + (setf (slot-value self 'data-plugin) plugin))) + +(defmethod size ((self image-data)) + (size (data-plugin-of self))) + +(defmethod (setf size) (size (self image-data)) + (setf (gfg:size (data-plugin-of self)) size)) + +(defmethod print-object ((self image-data) stream) + (if (or (null (gfs:handle self)) (cffi:null-pointer-p (gfs:handle self))) (error 'gfs:disposed-error)) - (let ((size (size data))) - (print-unreadable-object (data stream :type t) + (let ((size (size self))) + (print-unreadable-object (self stream :type t) ;; FIXME: dump palette info, too ;; (format stream "width: ~a " (gfs:size-width size)) (format stream "height: ~a " (gfs:size-height size)) - (format stream "bits per pixel: ~a " (depth data))))) + (format stream "bits per pixel: ~a " (depth self))))) Added: trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Mon Jul 17 00:48:13 2006 @@ -0,0 +1,70 @@ +;;;; +;;;; packages.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:cl-user) + +;;; +;;; package for base Win32 graphics plugin +;;; +(defpackage #:graphic-forms.uitoolkit.graphics.win32 + (:nicknames #:gfgw32) + (:shadow #:load #:type) + (:use #:common-lisp) + (:export + +;; classes and structs + +;; constants + +;; methods, functions, macros + +;; conditions + )) + +;;; +;;; package for ImageMagick graphics plugin +;;; +(defpackage #:graphic-forms.uitoolkit.graphics.imagemagick + (:nicknames #:gfgim) + (:shadow #:load #:type) + (:use #:common-lisp) + (:export + +;; classes and structs + +;; constants + +;; methods, functions, macros + +;; conditions + )) Copied: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (from r153, trunk/src/uitoolkit/graphics/magick-core-api.lisp) ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Mon Jul 17 00:48:13 2006 @@ -31,12 +31,14 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package :graphic-forms.uitoolkit.graphics) +(in-package :graphic-forms.uitoolkit.graphics.imagemagick) (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cffi) (pushnew cl-user::*magick-library-directory* cffi:*foreign-library-directories* :test #'equal)) +(defvar *magick-initialized* nil) + (load-foreign-library "wsock32.dll") (load-foreign-library "msvcr71.dll") (load-foreign-library "x11.dll") Copied: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp (from r58, trunk/src/uitoolkit/graphics/magick-core-types.lisp) ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-types.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp Mon Jul 17 00:48:13 2006 @@ -31,7 +31,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package :graphic-forms.uitoolkit.graphics) +(in-package :graphic-forms.uitoolkit.graphics.imagemagick) (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cffi)) @@ -55,11 +55,11 @@ (defconstant +yellow-channel+ #x00000004) (defconstant +alpha-channel+ #x00000008) (defconstant +opacity-channel+ #x00000008) -(defconstant +matte-channel+ #x00000008) ;; deprecated +(defconstant +matte-channel+ #x00000008) ; deprecated (defconstant +black-channel+ #x00000020) (defconstant +index-channel+ #x00000020) (defconstant +all-channels+ #x000000FF) -(defconstant +default-channels+ (logand +all-channels+ (lognot +opacity-channel+))) ;; (AllChannels &~ OpacityChannel) +(defconstant +default-channels+ (logand +all-channels+ (lognot +opacity-channel+))) ; (AllChannels &~ OpacityChannel) (defctype quantum :unsigned-short) @@ -373,9 +373,9 @@ (error-number :int) (reason :string) (description :string) - (exceptions :pointer) ;; void* + (exceptions :pointer) ; void* (relinquish boolean-type) - (semaphore :pointer) ;; Semaphore* + (semaphore :pointer) ; Semaphore* (signature :unsigned-long)) (defcstruct primary-info @@ -398,7 +398,7 @@ (defcstruct profile-info (name :string) (length :unsigned-long) - (info :pointer) ;; char* + (info :pointer) ; char* (signature :unsigned-long)) (defcstruct rectangle-info @@ -430,24 +430,24 @@ (rows :unsigned-long) (depth :unsigned-long) (colors :unsigned-long) - (colormap :pointer) ;; PixelPacket* + (colormap :pointer) ; PixelPacket* (background-color pixel-packet) (border-color pixel-packet) (matte-color pixel-packet) (gamma :double) (chromaticity chromaticity-info) (render-intent rendering-intent) - (profiles :pointer) ;; void* + (profiles :pointer) ; void* (units resolution-type) - (montage :pointer) ;; char* - (directory :pointer) ;; char* - (geometry :pointer) ;; char* + (montage :pointer) ; char* + (directory :pointer) ; char* + (geometry :pointer) ; char* (offset :long) (x-resolution :double) (y-resolution :double) (page rectangle-info) (extract-info rectangle-info) - (tile-info rectangle-info) ;; deprecated + (tile-info rectangle-info) ; deprecated (bias :double) (blur :double) (fuzz :double) @@ -457,7 +457,7 @@ (gravity gravity-type) (compose composite-operator) (dispose dispose-type) - (clip-mask :pointer) ;; Image* + (clip-mask :pointer) ; Image* (scene :unsigned-long) (delay :unsigned-long) (ticks-per-second :unsigned-long) @@ -466,27 +466,27 @@ (start-loop :long) (error error-info) (timer timer-info) - (progress-monitor :pointer) ;; MagickBooleanType (*MagickProgressMonitor)(args) - (client-data :pointer) ;; void* - (cache :pointer) ;; void* - (attributes :pointer) ;; void* - (ascii85 :pointer) ;; _Ascii85Info_* - (blob :pointer) ;; _BlobInfo_* + (progress-monitor :pointer) ; MagickBooleanType (*MagickProgressMonitor)(args) + (client-data :pointer) ; void* + (cache :pointer) ; void* + (attributes :pointer) ; void* + (ascii85 :pointer) ; _Ascii85Info_* + (blob :pointer) ; _BlobInfo_* (filename :char :count 4096) (magick-filename :char :count 4096) (magick :char :count 4096) (exception exception-info) (debug boolean-type) (reference-count :long) - (semaphore :pointer) ;; SemaphoreInfo* + (semaphore :pointer) ; SemaphoreInfo* (color-profile profile-info) (iptc-profile profile-info) - (generic-profile :pointer) ;; ProfileInfo* - (generic-profiles :unsigned-long) ;; deprecated (and ProfileInfo too?) + (generic-profile :pointer) ; ProfileInfo* + (generic-profiles :unsigned-long) ; deprecated (and ProfileInfo too?) (signature :unsigned-long) - (previous :pointer) ;; Image* - (list :pointer) ;; Image* - (next :pointer)) ;; Image* + (previous :pointer) ; Image* + (list :pointer) ; Image* + (next :pointer)) ; Image* (defcstruct magick-image-info (compression compression-type) @@ -495,10 +495,10 @@ (adjoin boolean-type) (affirm boolean-type) (antialias boolean-type) - (size :pointer) ;; char* - (extract :pointer) ;; char* - (page :pointer) ;; char* - (scenes :pointer) ;; char* + (size :pointer) ; char* + (extract :pointer) ; char* + (page :pointer) ; char* + (scenes :pointer) ; char* (scene :unsigned-long) (number-scenes :unsigned-long) (depth :unsigned-long) @@ -506,11 +506,11 @@ (endian endian-type) (units resolution-type) (quality :unsigned-long) - (sampling-factor :pointer) ;; char* - (server-name :pointer) ;; char* - (font :pointer) ;; char* - (texture :pointer) ;; char* - (density :pointer) ;; char* + (sampling-factor :pointer) ; char* + (server-name :pointer) ; char* + (font :pointer) ; char* + (texture :pointer) ; char* + (density :pointer) ; char* (point-size :double) (fuzz :double) (background-color pixel-packet) @@ -525,24 +525,24 @@ (group :long) (ping boolean-type) (verbose boolean-type) - (view :pointer) ;; char* - (authenticate :pointer) ;; char* - (channel :unsigned-int) ;; ChannelType - (attributes :pointer) ;; Image* - (options :pointer) ;; void* - (progress-monitor :pointer) ;; MagickBooleanType (*MagickProgressMonitor)(args) - (client-data :pointer) ;; void* - (cache :pointer) ;; void* - (stream :pointer) ;; size_t (*StreamHandler)(args) - (file :pointer) ;; FILE* - (blob :pointer) ;; void* + (view :pointer) ; char* + (authenticate :pointer) ; char* + (channel :unsigned-int) ; ChannelType + (attributes :pointer) ; Image* + (options :pointer) ; void* + (progress-monitor :pointer) ; MagickBooleanType (*MagickProgressMonitor)(args) + (client-data :pointer) ; void* + (cache :pointer) ; void* + (stream :pointer) ; size_t (*StreamHandler)(args) + (file :pointer) ; FILE* + (blob :pointer) ; void* (length :unsigned-int) (magick :char :count 4096) (unique :char :count 4096) (zero :char :count 4096) (filename :char :count 4906) (debug boolean-type) - (tile :pointer) ;; deprecated + (tile :pointer) ; deprecated (subimage :unsigned-long) (subrange :unsigned-long) (pen pixel-packet) Added: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Mon Jul 17 00:48:13 2006 @@ -0,0 +1,179 @@ +;;;; +;;;; magick-data-plugin.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.graphics.imagemagick) + +(defclass magick-data-plugin (gfg:image-data-plugin) () + (:documentation "ImageMagick library plugin for the graphics package.")) + +(defun accepts-file-p (path) + (unless *magick-initialized* + (initialize-magick (cffi:null-pointer)) + (setf *magick-initialized* t)) + (cond + ((parse-namestring path)) ; syntax check + ((typep path 'pathname) + (setf path (namestring path))) + (t + (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) + (if (gethash (pathname-type path) gfg:*image-file-types*) + (let ((plugin (make-instance 'magick-data-plugin))) + (gfg:load plugin path) + plugin) + nil)) + +(push #'accepts-file-p gfg::*image-plugins*) + +(defmethod gfg:data->image ((self magick-data-plugin)) + "Convert the image-data object to a bitmap and return the native handle." + (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) + (cffi:with-foreign-slots ((gfs::bisize + gfs::biwidth + gfs::biheight + gfs::biplanes + gfs::bibitcount + gfs::bicompression + gfs::bisizeimage + gfs::bixpels + gfs::biypels + gfs::biclrused + gfs::biclrimp + gfs::bmicolors) + bi-ptr gfs::bitmapinfo) + (let* ((handle (gfs:handle self)) + (sz (gfg:size self)) + (pix-count (* (gfs:size-width sz) (gfs:size-height sz))) + (hbmp (cffi:null-pointer)) + (screen-dc (gfs::get-dc (cffi:null-pointer)))) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width sz) + gfs::biheight (- 0 (gfs:size-height sz)) + gfs::biplanes 1 + gfs::bibitcount 32 ;; 32bpp even if original image file is not + gfs::bicompression gfs::+bi-rgb+ + gfs::bisizeimage 0 + gfs::bixpels 0 + gfs::biypels 0 + gfs::biclrused 0 + gfs::biclrimp 0) + + ;; create the bitmap + ;; + (cffi:with-foreign-object (pix-bits-ptr :pointer) + (setf hbmp (gfs::create-dib-section screen-dc + bi-ptr + gfs::+dib-rgb-colors+ + pix-bits-ptr + (cffi:null-pointer) + 0)) + (if (gfs:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-dib-section failed")) + + ;; update the RGBQUADs + ;; + (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz))) + (ptr (cffi:mem-ref pix-bits-ptr :pointer))) + (dotimes (i pix-count) + (cffi:with-foreign-slots ((blue green red reserved) + (cffi:mem-aref tmp 'pixel-packet i) + pixel-packet) + (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved) + (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbreserved 0) + (setf gfs::rgbred (scale-quantum-to-byte red)) + (setf gfs::rgbgreen (scale-quantum-to-byte green)) + (setf gfs::rgbblue (scale-quantum-to-byte blue))))))) + (unless (gfs:null-handle-p screen-dc) + (gfs::release-dc (cffi:null-pointer) screen-dc)) + hbmp)))) + +(defmethod gfg:depth ((self magick-data-plugin)) + (let ((handle (gfs:handle self))) + (if (null handle) + (error 'gfs:disposed-error)) + (cffi:foreign-slot-value handle 'magick-image 'depth))) + +(defmethod gfs:dispose ((self magick-data-plugin)) + (let ((victim (gfs:handle self))) + (unless (or (null victim) (cffi:null-pointer-p victim)) + (destroy-image victim))) + (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) + +(defmethod gfg:load ((self magick-data-plugin) path) + (let ((handle (gfs:handle self))) + (when (and handle (not (cffi:null-pointer-p handle))) + (destroy-image handle) + (setf (slot-value self 'gfs:handle) nil) + (setf handle nil)) + (with-image-path (path info ex) + (setf handle (read-image info ex)) + (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) + (error 'gfs:toolkit-error :detail (format nil + "exception reason: ~s" + (cffi:foreign-slot-value ex 'exception-info 'reason)))) + (if (cffi:null-pointer-p handle) + (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) + (setf (slot-value self 'gfs:handle) handle)))) + +(defmethod gfg:size ((self magick-data-plugin)) + (let ((handle (gfs:handle self)) + (size (gfs:make-size))) + (if (or (null handle) (cffi:null-pointer-p handle)) + (error 'gfs:disposed-error)) + (cffi:with-foreign-slots ((rows columns) handle magick-image) + (setf (gfs:size-height size) rows) + (setf (gfs:size-width size) columns)) + size)) + +(defmethod (setf gfg:size) (size (self magick-data-plugin)) + (let ((handle (gfs:handle self)) + (new-handle (cffi:null-pointer)) + (ex (acquire-exception-info))) + (if (or (null handle) (cffi:null-pointer-p handle)) + (error 'gfs:disposed-error)) + (unwind-protect + (progn + (setf new-handle (resize-image handle + (gfs:size-width size) + (gfs:size-height size) + (cffi:foreign-enum-value 'filter-types :lanczos) + 1.0 ex)) + (if (gfs:null-handle-p new-handle) + (error 'gfs:toolkit-error :detail (format nil + "could not resize: ~a" + (cffi:foreign-slot-value ex + 'exception-info + 'reason)))) + (setf (slot-value self 'gfs:handle) new-handle) + (destroy-image handle)) + (destroy-exception-info ex)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Jul 17 00:48:13 2006 @@ -38,7 +38,6 @@ (child-visitor-results :initform nil :accessor child-visitor-results) (display-visitor-func :initform nil :accessor display-visitor-func) (display-visitor-results :initform nil :accessor display-visitor-results) - (image-loaders-by-type :initform (make-hash-table :test #'equal)) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) (event-time :initform 0 :accessor event-time) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Jul 17 00:48:13 2006 @@ -81,13 +81,11 @@ #+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) - (gfg::initialize-magick (cffi:null-pointer)) (funcall start-fn) (message-loop #'default-message-filter)) #+lispworks (defun startup (thread-name start-fn) (hcl:add-special-free-action 'gfs::native-object-special-action) - (gfg::initialize-magick (cffi:null-pointer)) (when (null (mp:list-all-processes)) (mp:initialize-multiprocessing)) (mp:process-run-function thread-name @@ -97,7 +95,6 @@ (message-loop #'default-message-filter)))) (defun shutdown (exit-code) - (gfg::destroy-magick) (gfs::post-quit-message exit-code)) (defun initialize-comctl-classes (icc-flags)

1 0

[graphic-forms-cvs] r197 - in trunk: docs/manual etc src src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 14 Jul '06

14 Jul '06

Author: junrue Date: Thu Jul 13 20:20:12 2006 New Revision: 197 Modified: trunk/docs/manual/api.texinfo trunk/etc/lisp.exe.manifest trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp Log: implemented event-session function, currently untested Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Jul 13 20:20:12 2006 @@ -1172,6 +1172,57 @@ @end table @end deffn +@anchor{event-session} +@deffn GenericFunction event-session dispatcher window phase reason +Implement this method to participate in the system's session shutdown +protocol. When the user chooses to end the session (by logging out or +by shutting down), or if an application calls one of the Win32 +shutdown functions, every application is given a veto option. This +event function will be called at least once for each @ref{top-level} +window in the application.@* + +The MSDN documentation makes the following recommendations for handling +this event: +@itemize @bullet +@item Whenever possible, applications should respect the user's +intentions by allowing the session to end. +@item In the case of a critical operation, provide a @ref{dialog} or +other feedback with information for the user as to consequences +if the application is interrupted at this time. +@item Respond to the @code{:query} event as quickly as possible, leaving +time-consuming cleanup to be done in the session @code{:end} event. +@end itemize + +@table @var +@event-dispatcher-arg +@item window +The @ref{top-level} @ref{window} receiving this event. +@item phase +Identifies which of the two phases this event represents: +@table @code +@item :query +This symbol means that the system is querying the application for +permission to proceed. Return @sc{nil} if there is a reason to veto +the process, or non-@sc{nil} otherwise. +@item :end +This symbol is specified in the subsequent call to @code{event-session}. +It means that the system is going ahead with ending the +session, therefore this is an opportunity for graceful cleanup. +@end table +@item reason +Provides more detail to aid in choosing desired behavior: +@table @code +@item :logoff +The user is logging off. +@item :replacing-file +The application must exit because a file it is using is being +replaced. +@item :shutdown +The system is shutting down or restarting. +@end table +@end table +@end deffn + @anchor{event-timer} @deffn GenericFunction event-timer dispatcher timer Implement this method to respond to expiration of the current Modified: trunk/etc/lisp.exe.manifest ============================================================================== --- trunk/etc/lisp.exe.manifest (original) +++ trunk/etc/lisp.exe.manifest Thu Jul 13 20:20:12 2006 @@ -1,10 +1,10 @@ -<?xml version="1.0" encoding="UTF-8" standalone="yes"?> +<?xml version="1.0" encoding="UTF-8" standalone="yes"?> <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> - <assemblyIdentity version="1.0.0.0" processorArchitecture="X86" name="clisp" type="win32"/> + <assemblyIdentity processorArchitecture="x86" name="clisp" type="win32"/> <description>GNU CLISP</description> <dependency> <dependentAssembly> - <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="X86" publicKeyToken="6595b64144ccf1df" language="*"/> + <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="x86" publicKeyToken="6595b64144ccf1df" language="*"/> </dependentAssembly> </dependency> </assembly> Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Jul 13 20:20:12 2006 @@ -395,7 +395,7 @@ #:event-pre-resize #:event-resize #:event-select - #:event-show + #:event-session #:event-timer #:expand #:expanded-p Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Jul 13 20:20:12 2006 @@ -974,6 +974,24 @@ (defconstant +wm-gettextlength+ #x000E) (defconstant +wm-paint+ #x000F) (defconstant +wm-close+ #x0010) +(defconstant +wm-queryendsession+ #x0011) +(defconstant +wm-queryopen+ #x0013) +(defconstant +wm-endsession+ #x0016) +(defconstant +wm-quit+ #x0012) +(defconstant +wm-erasebkgnd+ #x0014) +(defconstant +wm-syscolorchange+ #x0015) +(defconstant +wm-showwindow+ #x0018) +(defconstant +wm-wininichange+ #x001A) +(defconstant +wm-settingchange+ #x001A) +(defconstant +wm-devmodechange+ #x001B) +(defconstant +wm-activateapp+ #x001C) +(defconstant +wm-fontchange+ #x001D) +(defconstant +wm-timechange+ #x001E) +(defconstant +wm-cancelmode+ #x001F) +(defconstant +wm-setcursor+ #x0020) +(defconstant +wm-mouseactivate+ #x0021) +(defconstant +wm-childactivate+ #x0022) +(defconstant +wm-queuesync+ #x0023) (defconstant +wm-getminmaxinfo+ #x0024) (defconstant +wm-painticon+ #x0026) (defconstant +wm-iconerasebkgnd+ #x0027) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Thu Jul 13 20:20:12 2006 @@ -178,10 +178,10 @@ (:method (dispatcher item) (declare (ignorable dispatcher item)))) -(defgeneric event-show (dispatcher widget) - (:documentation "Implement this to respond to an object being shown.") - (:method (dispatcher widget) - (declare (ignorable dispatcher widget)))) +(defgeneric event-session (dispatcher window phase reason) + (:documentation "Implement this to participate in the session shutdown protocol.") + (:method (dispatcher window phase reason) + (declare (ignorable dispatcher window phase reason)))) (defgeneric event-timer (dispatcher timer) (:documentation "Implement this to respond to a tick from a specific timer.") Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Jul 13 20:20:12 2006 @@ -142,6 +142,18 @@ (defun obtain-event-time () (event-time (thread-context))) +(defun option->reason (lparam) + ;; MSDN says the value is a bitmask, so must be tested bit-wise. + (cond + ((zerop lparam) + :shutdown) + ((oddp lparam) + :replacing-file) + ((= (logand lparam #x80000000) #x80000000) + :logoff) + (t + :shutdown))) + ;;; ;;; process-message methods ;;; @@ -214,6 +226,19 @@ (delete-widget (thread-context) hwnd) 0) +(defmethod process-message (hwnd (msg (eql gfs::+wm-queryendsession+)) wparam lparam) + (declare (ignore wparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (unless (null widget) + (if (event-session (dispatcher widget) widget :query (option->reason lparam)) 1 0)))) + +(defmethod process-message (hwnd (msg (eql gfs::+wm-endsession+)) wparam lparam) + (declare (ignore wparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (unless (null widget) + (event-session (dispatcher widget) widget :end (option->reason lparam)))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context))

1 0