From: tomo Date: Tue, 13 Aug 2002 07:16:17 +0000 (+0000) Subject: Initial revision X-Git-Tag: r21-2-46-utf-2000-0_19-nc4-b5-1-2~1^2 X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=commitdiff_plain;h=7ee7b9fd0c91842f267cf6e412286d647f68e32a Initial revision --- diff --git a/etc/OXYMORONS b/etc/OXYMORONS new file mode 100644 index 0000000..3528654 --- /dev/null +++ b/etc/OXYMORONS @@ -0,0 +1,42 @@ +The theme of the gamma series of 21.4 releases is "oxymoron", that is, +contradiction in terms. Each patchlevel will be assigned a unique +codename from the list below. The rationale for the first should be +obvious. + +The second and third are my tributes to Richard Stallman and the early +developers of Lucid Emacs/XEmacs (primarily Jamie Zawinski, but it +also fits Ben Wing which is appropriate to the Mule theme), in +chronological order. I cannot list all the debts this release owes +for individual contributions, but I must credit the fundamental +excellence of the design of [X]Emacs for inspiring the audacious +proposal to add both GTK and Windows/MULE to XEmacs over a period of +two months, and for the success of the GTK merge. Without the +prospect of such a big win, I could not have justified trying to +coordinate a release myself. + +The rest of the codenames are in alphabetical order. + +N.B. I expect that the Stable Release Maintainer will choose a new +theme for the releases following the promotion of 21.4 from "gamma" to +"stable". So 15 should be enough.... + +21.4.0: Solid Vapor +21.4.1: Copyleft +21.4.2: Developer-Friendly Unix APIs +21.4.3: Academic Rigor +21.4.3: Artificial Intelligence +21.4.3: Civil Service +21.4.3: Common Lisp +21.4.3: Economic Science +21.4.3: Honest Politician +21.4.3: Informed Management +21.4.3: Military Intelligence +21.4.3: Portable Code +21.4.3: Rational FORTRAN +21.4.3: Reasonable Discussion +21.4.3: Standard C + +N.B. Suggestions welcome until shortly before the release. (The +non-incrementing version number is precisely to make it easy to add +new oxymorons.) + diff --git a/etc/sample.init.el b/etc/sample.init.el new file mode 100644 index 0000000..ef6ec7f --- /dev/null +++ b/etc/sample.init.el @@ -0,0 +1,1384 @@ +;; -*- Mode: Emacs-Lisp -*- + +;; Copyright (C) 2000, 2001 Ben Wing. + +;; Author: Mostly Ben Wing +;; Maintainer: XEmacs Development Team +;; Keywords: sample, initialization + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; #### to do: +;; -- #### figure out how init.el and custom.el interact and put +;; documentation about it here. (perhaps it already exists +;; elsewhere?) + +;;; This is a sample init.el file. It can be used without +;;; modification as your init.el or .emacs. In older versions of +;;; XEmacs, this file was called .emacs and placed in your home +;;; directory. (Under MS Windows, that directory is controlled by the +;;; HOME environment variable and defaults to C:\. You can find out +;;; where XEmacs thinks your home directory is using +;;; +;;; ESC : (expand-file-name "~") +;;; +;;; . This means type ESC, then colon, then the following text, then hit +;;; return.) In more recent versions of XEmacs, this file has migrated to +;;; the .xemacs/ subdirectory and is called init.el. Other files are +;;; also located here, such as custom.el (the auto-generated file +;;; containing Customization options that you saved when using +;;; Options->Save Options). + +;;; Changes to your init.el file will not take effect until the next +;;; time you start up XEmacs, unless you load it explicitly with +;;; +;;; M-x load-file RET ~/.xemacs/init.el RET + +;;; The language that this file (and most other XEmacs init files) is +;;; written in is called "XEmacs Lisp" or more commonly "Elisp". + +;;; There are many sources of further information: + +;;; -- the XEmacs User's Manual (Access using the online Info browser: +;;; Use `Help->Info (Online Docs)->XEmacs User's Manual' (if +;;; there is such an entry); or get to the Info contents page +;;; using `Help->Info Contents' or `C-h i', and then +;;; *middle-click* the XEmacs link or move the cursor into the +;;; link and hit ENTER. This manual contains a great deal of +;;; documentation on customization: Scroll down to the +;;; Customization link and select it in the same fashion as for +;;; the XEmacs link just mentioned.) + +;;; -- the XEmacs FAQ (`C-h F' for the local version; get either the +;;; local version or the very latest version off the net using +;;; the Help menu) + +;;; -- the XEmacs Lisp Reference Manual, containing detailed +;;; documentation on Elisp. (Access using Info, just like for the +;;; XEmacs User's Manual.) + +;;; -- the documentation strings for specific commands, functions, +;;; key sequences, and variables. NOTE: This is *not* the same +;;; information as in the XEmacs User's Manual or XEmacs Lisp +;;; Reference Manual! In general, the doc strings are more +;;; terse and more up-to-date than what is found in the manuals. +;;; Once you understand the general concepts, these doc strings +;;; should be your first point of reference for further +;;; info. (Access using menu entries under `Help->Commands, +;;; Variables, Keys' or using the keyboard: `C-h k' for a key +;;; sequence, `C-h f' for a named command or Elisp function, +;;; `C-h v' for a variable. There is various other useful +;;; information accessible similarly, such as `C-h a' +;;; ["Apropos", i.e. search for a command, function, or variable +;;; by name]; `C-h C-a' ["Apropos Docs", i.e. search through the +;;; text of the doc strings]; `C-h b' to list all key bindings; +;;; `C-h m' to describe the current major and minor modes; etc. +;;; Type `C-h ? ?' for a complete list.) + +;;; -- Getting Started with XEmacs [aka the "New User's Guide"], a +;;; more introductory manual than the XEmacs User's Manual. +;;; (Access using Info, just like for the XEmacs User's Manual. +;;; There are some sections on customization here.) + +;;; -- the XEmacs tutorial, a very simple introduction to XEmacs for +;;; total beginners. (`C-h t' for English; get the version in +;;; various languages from the Help menu) + +;;; -- the XEmacs web site, www.xemacs.org. + +;;; -- the XEmacs mailing lists (xemacs-FOO@xemacs.org; +;;; see http://www.xemacs.org/Lists/ for more info. Before +;;; posting, consider looking through the archives -- they go back +;;; years and there is a powerful searching interface. Currently +;;; the archives are at http://list-archive.xemacs.org/, but if +;;; this doesn't work, you can always access them through +;;; www.xemacs.org.) + +;;; -- the XEmacs newsgroup, comp.emacs.xemacs. This is +;;; bi-directionally gatewayed with xemacs@xemacs.org. WARNING: +;;; The developers do not normally hang out on this newsgroup. If +;;; you need to contact them, use xemacs-beta@xemacs.org. + +;;; -- the XEmacs internals manual, for those interested in working on +;;; the XEmacs C code. (Available through Info.) + +;;; -- `Help->About XEmacs' to find out who the maintainers are. + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Basic Customization ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; TIP: Control-L characters are ignored in Lisp files and are the +;; standard way of indicating major section divisions. You can enter +;; such a character using C-q C-l. + +;; Define a variable to indicate whether we're running XEmacs/Lucid +;; Emacs. (You do not have to defvar a global variable before using +;; it -- you can just call `setq' directly. It's clearer this way, +;; though. Note also how we check if this variable already exists +;; using `boundp', because it's defined in recent versions of +;; XEmacs.) + +(or (boundp 'running-xemacs) + (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version))) + +;; Define a function to make it easier to check which version we're +;; running. This function already exists in recent XEmacs versions, +;; and in fact all we've done is copied the definition. Note again +;; how we check to avoid clobbering an existing definition. (It's good +;; style to do this, in case some improvement was made to the +;; already-existing function -- otherwise we might subsitute an older +;; definition and possibly break some code elsewhere.) +;; +;; NOTE ALSO: It is in general *NOT* a good idea to do what we're +;; doing -- i.e. provide a definition of a function that is present in +;; newer versions of XEmacs but not older ones. The reason is that it +;; may confuse code that notices the presence of the function and +;; proceeds to use it and other functionality that goes along with it +;; -- but which we may not have defined. What's better is to create +;; the function with a different name -- typically, prefix it with the +;; name of your module, which in this case might be `Init-'. For +;; `emacs-version>=' we make an exception because (a) the function has +;; been around a long time, (b) there isn't really any other +;; functionality that is paired with it, (c) it's definition hasn't +;; changed and isn't likely to, and (d) the calls to `emacs-version>=' +;; or its renamed replacement would be scattered throughout the code +;; below, and with a replacement name the code would become +;; significantly less portable into someone else's init.el file. (BUT +;; NOTE BELOW: We do follow the procedure outlined above with renaming +;; in a different case where the specifics are much different.) +;; +;; TIP: At this point you may be wondering how I wrote all these nice, +;; long, nicely-justified textual stretches -- didn't I go crazy +;; sticking in the semicolons everywhere and having to delete them and +;; rearrange everything whenever I wanted to make any corrections to +;; the text? The answer is -- of course not! Use M-q. This does all +;; the magic for you, justifying and breaking lines appropriately and +;; putting any necessary semicolons or whatever at the left (it +;; figures out what this ought to be by looking in a very clever +;; fashion at what's already at the beginning of each line in the +;; paragraph). You may need `filladapt' set up (it's done below in +;; this file) in order for this to work properly. Finally, if you +;; want to turn on automatic filling (like in a word processor, but +;; not quite as automatic), use M-x auto-fill-mode or the binding set +;; up below in this file (Meta-F9). + +(or (fboundp 'emacs-version>=) + (defun emacs-version>= (major &optional minor patch) + "Return true if the Emacs version is >= to the given MAJOR, MINOR, + and PATCH numbers. +The MAJOR version number argument is required, but the other arguments +argument are optional. Only the Non-nil arguments are used in the test." + (let ((emacs-patch (or emacs-patch-level emacs-beta-version -1))) + (cond ((> emacs-major-version major)) + ((< emacs-major-version major) nil) + ((null minor)) + ((> emacs-minor-version minor)) + ((< emacs-minor-version minor) nil) + ((null patch)) + ((>= emacs-patch patch)))))) + +;; 19.13 was released ages ago (Sep. 1995), and lots of graphic and +;; window-system stuff doesn't work before then. + +(or (not running-xemacs) + (emacs-version>= 19 13) + (error "This init file does not support XEmacs before 19.13")) + +;; Here are some example code snippets that you can use if you need to +;; conditionalize on a particular version of Emacs (in general, though, +;; it is much better to use `fboundp', `featurep', or other such +;; feature-specific checks rather than version-specific checks): + +; (cond ((and running-xemacs +; (emacs-version>= 21 2)) +; ;; +; ;; Code requiring XEmacs version 21.2 or newer goes here +; ;; +; )) + +; (cond ((emacs-version >= 19 0) +; ;; +; ;; Code for any vintage-19 Emacs goes here +; ;; +; )) + +; (cond ((and (not running-xemacs) +; (emacs-version>= 20 0)) +; ;; +; ;; Code specific to GNU Emacs 20 or newer (not XEmacs) goes here +; ;; +; )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Key Definitions ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Set up the function keys to do common tasks to reduce Emacs pinky +;;; and such. + +;; You can set a key sequence either to a command or to another key +;; sequence. (Use `C-h k' to map a key sequence to its command. Use +;; `C-h w' to go the other way.) In general, however, it works better +;; to specify the command name. For example, it does not currently +;; work to say + +;; (global-set-key 'f5 "\C-x\C-f") + +;; The reason is that macros (which is what the string on the right +;; really is) can't currently use the minibuffer. This is an +;; extremely longstanding bug in Emacs. Eventually, it will be +;; fixed. (Hopefully ..) + +;; Note also that you may sometimes see the idiom + +;; (define-key global-map ...) + +;; in place of (global-set-key ...). These are exactly the same. + +;; Here I've tried to put all the most common commands on simple +;; non-modifier function keys to take the pressure off your modifier +;; fingers. Furthermore, on my keyboard at least, the function keys +;; are grouped into three groups of four with spaces between them, and +;; so it's easier to hit the keys at the edge of the groups -- +;; i.e. f1, f4, f5, f8, f9, and f12. Finally, you may note that f9, +;; f11, and f12 are purposely left blank. [F6 is defined below.] +;; That's because I use them for _, {, and } -- see below. + +(global-set-key 'f1 'advertised-undo) ;; Undo +(global-set-key 'f2 'kill-primary-selection) ;; Cut +(global-set-key 'f3 'copy-primary-selection) ;; Copy +(global-set-key 'f4 'yank-clipboard-selection) ;; Paste +(global-set-key 'f5 'find-file) ;; C-x C-f +(global-set-key 'f7 'save-buffer) ;; C-x C-s + +;; I considered having this retain the current column after killing +;; the line, but that messes up the common idiom `f8 move-cursor f4'. + +(defun Init-kill-entire-line (&optional arg) + (interactive "*P") + (let ((kill-whole-line t)) + (beginning-of-line) + (call-interactively 'kill-line))) + +(global-set-key 'f8 + (if (fboundp 'kill-entire-line) 'kill-entire-line 'Init-kill-entire-line)) + +;; A keystroke repeated incredible amounts of times. We need to patch +;; into the isearch keymap so that repeat searches while in isearch +;; mode still work. Here we show how to make a key in a keymap have the +;; same binding as another key in the keymap, without knowing what the +;; binding is in advance; instead, we find it with `lookup-key'. This +;; way, if the binding of C-s changes (e.g. to a different function) but +;; the meaning is basically the same, we automatically do the right thing. +;; If we put in the actual binding, which is 'isearch-repeat-forward, +;; this automatic tracking wouldn't happen. +;; +;; TIP: To find out what the (lookup-key ...) expression evaluates to, +;; move just to the right of the closing paren and type C-x C-e. + +(global-set-key 'f10 'isearch-forward) +(define-key isearch-mode-map 'f10 (lookup-key isearch-mode-map "\C-s")) +(define-key minibuffer-local-isearch-map 'f10 + (lookup-key minibuffer-local-isearch-map "\C-s")) +(global-set-key '(shift f10) 'isearch-backward) +(define-key isearch-mode-map '(shift f10) (lookup-key isearch-mode-map "\C-r")) +(define-key minibuffer-local-isearch-map '(shift f10) + (lookup-key minibuffer-local-isearch-map "\C-r")) + +;; Here we define our own function and then bind a key to it. + +(defun start-or-end-kbd-macro () + ;; A doc string. This is optional. + "Start defining a keyboard macro, or stop if we're already defining." + ;; IMPORTANT: Any function bound to a key MUST have an interactive spec, + ;; usually just the following line: + (interactive) + (if defining-kbd-macro + (end-kbd-macro) + (start-kbd-macro nil))) + +;; The macros used to have their place in the function keys, but I +;; find that I use them significantly less than the really basic +;; things on the function keys. When using a macro, you call the +;; macro much more than define it, so the setup below makes some +;; sense. + +(global-set-key '(shift kp-multiply) 'start-or-end-kbd-macro) +(global-set-key 'kp-multiply 'call-last-kbd-macro) ;; C-x e + +;; Note that you can refer to a key sequence either using an ASCII +;; string or the "long way", with vectors and conses. You saw above +;; (in a comment) the string form for specifying the key sequence `C-x +;; C-f', which is "\C-x\C-f". (For those curious, \C-x is just an +;; escape sequence that puts a ^X character into the string. Thus, +;; the string just mentioned really just contains two characters, a ^X +;; and a ^F.) The long way to specify the sequence `C-x C-f' would be +;; +;; [(control x) (control f)] +;; +;; The long format lets you specify all possible key sequences, while the +;; string form only lets you specify sequences involving ASCII characters +;; and/or modifiers and in fact only a subset of them. +;; +;; Other examples are: +;; +;; [(control x) n] +;; +;; (You can leave out the parens when there is no modifier specified in +;; the keystroke, and that's normally done.) +;; +;; [(shift control meta left)] +;; +;; (You can put more than one modifier in a keystroke.) +;; +;; (shift control meta left) +;; +;; (This is the same as the previous. when there's only one keystroke in +;; the sequence, you can leave out the brackets, and that's normally +;; done.) +;; +;; [(control x) (shift button3)] +;; +;; (You can refer to mouse buttons just like keys -- apply modifiers, +;; intermingle them in key sequences, etc. But there's only problem +;; here, which is that with the mouse you don't just have one possible +;; gesture, like with keys. You'd really like to control button-down, +;; button-up, button-click (down and up without selecting anything), +;; button drag, button double-click, etc. This is normally done by +;; binding your key sequence to `mouse-track', and then putting hooks +;; onto `mouse-track-click-hook', `mouse-track-drag-up-hook', etc. to +;; customize the specific behavior.) +;; +;; 'left +;; +;; (Ultimate reductionism -- no brackets, no parens. This is the form, in +;; that, that the 'f1, 'f2, etc. took, which where in fact "long" +;; forms.) +;; +;; '(control C) +;; +;; (You cannot use '(control shift c) here. This applies whenever Shift + +;; key translates to a single character. Note also that you can't use +;; "\C-C" either; this refers to the non-shifted C-c, just like "\C-c" +;; would.) +;; +;; '(control \() +;; (Put a backslash in front of characters used in Lisp syntax.) +;; +;; Also, you can find out the name of a key using C-h c. WARNING: +;; This does not report the correct name of the keys named `delete', +;; `backspace', `return', `tab', `space', `escape', and `linefeed'! +;; (More correct results can be achieved using +;; +;; ESC : (read-key-sequence "foo: ") +;; +;; .) + +;;;;;;;;;;;;;;;;;;;;;;;; + +;; Keystrokes to conveniently switch buffers. + +;; F6 is invaluable for flipping back and forth between two buffers +;; you're working with. + +(global-set-key 'f6 'switch-to-other-buffer) ;; M-C-l +(global-set-key '(meta n) 'switch-to-next-buffer-in-group) +(global-set-key '(meta p) 'switch-to-previous-buffer-in-group) +(global-set-key '(meta N) 'switch-to-next-buffer) +(global-set-key '(meta P) 'switch-to-previous-buffer) + +;; Define our own function to deal with the possibility that the newer +;; stuff in the gutter code may not be present -- i.e. we're running +;; an older XEmacs. Note that we avoid trying to "helpfully" define a +;; function that is present in new versions of XEmacs, but not in +;; older ones. That can very easily screw up code trying to determine +;; what functionality is present using `fboundp' checks. See above, +;; near `emacs-version>=', for a full discussion of this. + +(defun Init-buffers-tab-omit (buf) + ;; a function specifying the buffers to omit from the buffers tab. + ;; This is passed a buffer and should return non-nil if the buffer + ;; should be omitted. If the standard buffers-tab functionality is + ;; there, we just call it to do things "right". Otherwise we just + ;; omit invisible buffers, snarfing the code from + ;; `buffers-menu-omit-invisible-buffers'. + (if (boundp 'buffers-tab-omit-function) + (funcall buffers-tab-omit-function buf) + (not (null (string-match "\\` " (buffer-name buf)))))) + +(defun switch-to-next-buffer (&optional n) + "Switch to the next-most-recent buffer. +This essentially rotates the buffer list forward. +N (interactively, the prefix arg) specifies how many times to rotate +forward, and defaults to 1. Buffers whose name begins with a space +\(i.e. \"invisible\" buffers) are ignored." + ;; Here is a different interactive spec. Look up the function + ;; `interactive' (i.e. `C-h f interactive') to understand how this + ;; all works. + (interactive "p") + (dotimes (n (or n 1)) + (loop + do (bury-buffer (car (buffer-list))) + while (Init-buffers-tab-omit (car (buffer-list)))) + (switch-to-buffer (car (buffer-list))))) + +(defun buffers-menu-omit-invisible-buffers (buf) + "For use as a value of `buffers-menu-omit-function'. +Omits normally invisible buffers (those whose name begins with a space)." + (not (null (string-match "\\` " (buffer-name buf))))) + +(defvar Init-buffers-tab-grouping-regexp + '("^\\(gnus-\\|message-mode\\|mime/viewer-mode\\)" + "^\\(emacs-lisp-\\|lisp-\\)") +;; If non-nil, a list of regular expressions for buffer grouping. +;; Each regular expression is applied to the current major-mode symbol +;; name and mode-name, if it matches then any other buffers that match +;; the same regular expression be added to the current group. This is +;; a copy of `buffers-tab-grouping-regexp'. + ) + +(defun Init-select-buffers-tab-buffers (buffer-to-select buf1) + ;; Specifies the buffers to select from the buffers tab. This is + ;; passed two buffers and should return non-nil if the second buffer + ;; should be selected. If the standard buffers-tab functionality is + ;; there, we just call it to do things "right". Otherwise, we group + ;; buffers by major mode and by `Init-buffers-tab-grouping-regexp'. + ;; [We've copied `select-buffers-tab-buffers-by-mode' and + ;; `buffers-tab-grouping-regexp'.] + (if (boundp 'buffers-tab-selection-function) + (funcall buffers-tab-selection-function buffer-to-select buf1) + (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1))) + (mode2 (symbol-name (symbol-value-in-buffer 'major-mode + buffer-to-select))) + (modenm1 (symbol-value-in-buffer 'mode-name buf1)) + (modenm2 (symbol-value-in-buffer 'mode-name buffer-to-select))) + (cond ((or (eq mode1 mode2) + (eq modenm1 modenm2) + (and (string-match "^[^-]+-" mode1) + (string-match + (concat "^" (regexp-quote + (substring mode1 0 (match-end 0)))) + mode2)) + (and Init-buffers-tab-grouping-regexp + (find-if #'(lambda (x) + (or + (and (string-match x mode1) + (string-match x mode2)) + (and (string-match x modenm1) + (string-match x modenm2)))) + Init-buffers-tab-grouping-regexp))) + t) + (t nil))))) + +(defun switch-to-previous-buffer (&optional n) + "Switch to the previously most-recent buffer. +This essentially rotates the buffer list backward. +N (interactively, the prefix arg) specifies how many times to rotate +backward, and defaults to 1. Buffers whose name begins with a space +\(i.e. \"invisible\" buffers) are ignored." + (interactive "p") + (dotimes (n (or n 1)) + (loop + do (switch-to-buffer (car (last (buffer-list)))) + while (Init-buffers-tab-omit (car (buffer-list)))))) + +(defun switch-to-next-buffer-in-group (&optional n) + "Switch to the next-most-recent buffer in the current group. +This essentially rotates the buffer list forward. +N (interactively, the prefix arg) specifies how many times to rotate +forward, and defaults to 1. Buffers whose name begins with a space +\(i.e. \"invisible\" buffers) are ignored." + (interactive "p") + (dotimes (n (or n 1)) + (let ((curbuf (car (buffer-list)))) + (loop + do (bury-buffer (car (buffer-list))) + while (or (Init-buffers-tab-omit (car (buffer-list))) + (not (Init-select-buffers-tab-buffers + curbuf (car (buffer-list))))))) + (switch-to-buffer (car (buffer-list))))) + +(defun switch-to-previous-buffer-in-group (&optional n) + "Switch to the previously most-recent buffer in the current group. +This essentially rotates the buffer list backward. +N (interactively, the prefix arg) specifies how many times to rotate +backward, and defaults to 1. Buffers whose name begins with a space +\(i.e. \"invisible\" buffers) are ignored." + (interactive "p") + (dotimes (n (or n 1)) + (let ((curbuf (car (buffer-list)))) + (loop + do (switch-to-buffer (car (last (buffer-list)))) + while (or (Init-buffers-tab-omit (car (buffer-list))) + (not (Init-select-buffers-tab-buffers + curbuf (car (buffer-list))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;; + +;; Other text keystrokes. + +;; Make a keystroke to insert a literal TAB character. (`C-q TAB' is +;; annoying because difficult to repeat.) Note that this does not work +;; in TTY frames, where TAB and Shift-TAB are indistinguishable. +(define-key global-map '(shift tab) 'tab-to-tab-stop) + +;; Toggle auto-filling. Useful with text but annoying with code. You +;; can manually fill with M-q. +(global-set-key '(meta f9) 'auto-fill-mode) + +;; You cannot say '(meta shift t) here -- see above. +(if (fboundp 'transpose-line-down) + (global-set-key '(meta T) 'transpose-line-down)) +(if (fboundp 'transpose-line-up) + (global-set-key '(control T) 'transpose-line-up)) + +;;;;;;;;;;;;;;;;;;;;;;;; + +;; Rearrange some inconvenient bindings. + +;; ESC ESC ESC is a useful command, but too long. ESC ESC would be +;; much more logical, but interferes with Meta + keypad/arrow keys on +;; TTY's. But most people only use window systems and no such problem +;; exists there, so set up the more logical binding there. +;; +;; Note also the use of if vs. cond/when/unless/or/and to express +;; conditional statements. The difference is purely stylistic. + +(when (console-on-window-system-p) + (global-set-key '(meta escape) 'keyboard-escape-quit) + (define-key isearch-mode-map '(meta escape) 'isearch-cancel)) + +;; The standard definition of C-z causes iconification on window +;; systems, which is both useless and annoying. Instead, bind it to a +;; useful command that's not on any keys. (This also makes a neat +;; parallelism with M-z, which does zap-to-char.) Don't override the +;; TTY binding, which does "Suspend". If you want this new binding on +;; TTY's, and can train yourself to use C-x C-z to suspend, then +;; remove or comment out the `when' statement. (Here's the proper way +;; to comment out such a statement: +;; +;; ;(when (console-on-window-system-p) +;; (global-set-key "\C-z" 'zap-up-to-char) +;; ; ) +;; +;; To do this, I first moved the closing paren to a new line, +;; reindented with TAB, then added the semicolons.) + +(when (console-on-window-system-p) + (global-set-key "\C-z" 'zap-up-to-char)) + +;; When not on a TTY, remove the binding of C-x C-c, which normally +;; exits XEmacs. It's easy to hit this by mistake, and that can be +;; annoying. You can always quit with the "Exit XEmacs" option on the +;; File menu. + +(when (console-on-window-system-p) + (global-set-key "\C-x\C-c" nil)) + +;; Make C-k always delete the whole line, which is what most people want, +;; anyway. +(setq kill-whole-line 'always) +;; M-k does the old behavior (kill to end of line). +(global-set-key '(meta k) #'(lambda () + (interactive) + (if (fboundp 'historical-kill-line) + (call-interactively #'historical-kill-line) + (let ((kill-whole-line nil)) + (call-interactively #'kill-line))))) +;; and Meta-Shift-K does what used to be on M-k, and should +;; (hopefully) even work under TTY's. +(global-set-key '(meta K) 'kill-sentence) + +;; Make sure we get Windows-like shifted-motion key selection behavior +;; on recent XEmacs versions. +(if (boundp 'shifted-motion-keys-select-region) + (setq shifted-motion-keys-select-region t) + ;; otherwise, try the pc-select package -- + (condition-case nil + (progn + (require 'pc-select) + (pc-select-mode 1)) + (error nil))) + +;; The following commented-out code rearranges the keymap in an +;; unconventional but extremely useful way for programmers. Parens +;; and braces are both available without using the shift key (using +;; the bracket keys and f11/f12, respectively). Brackets (much less +;; used) are the shifted versions of the new paren keys (i.e. where +;; the braces normally are). +;; +;; The idea for this comes from Jamie Zawinski. +;; +;; Also make a convenient keystroke for _, used constantly in C code. +;; +;; NOTE: you can (semi-) conveniently uncomment a region using +;; C-u M-x comment-region, or the "Uncomment Region" menu item on the +;; Lisp menu in new enough versions of XEmacs. + +;(keyboard-translate ?[ ?() +;(keyboard-translate ?] ?)) +;(keyboard-translate ?{ ?[) +;(keyboard-translate ?} ?]) +;;; We don't use `keyboard-translate' for these because it messes up +;;; bindings for M-F9 and the like. +;(define-key key-translation-map 'f11 "{") +;(define-key key-translation-map 'f12 "}") +;(define-key key-translation-map 'f9 "_") + + +;;;;;;;;;;;;;;;;;;;;;;;; + +;; Useful programming-related keystrokes. + +(defun describe-foo-at-point () + (interactive) + (let (sym) + ;; sigh, function-at-point is too clever. we want only the first half. + (cond ((setq sym (ignore-errors + (with-syntax-table emacs-lisp-mode-syntax-table + (save-excursion + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (char-after (point))) ?w) + (eq (char-syntax (char-after (point))) ?_) + (forward-sexp -1)) + (skip-chars-forward "`'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (fboundp obj) obj)))))) + (describe-function sym)) + ((setq sym (variable-at-point)) (describe-variable sym)) + ;; now let it operate fully -- i.e. also check the + ;; surrounding sexp for a function call. + ((setq sym (function-at-point)) (describe-function sym))))) + +(global-set-key '(shift f4) 'next-error) ;; C-x ` +(global-set-key '(control f4) 'previous-error) +(global-set-key '(shift f5) 'find-library) +(global-set-key '(control f5) 'find-function) +(global-set-key '(meta f5) 'find-variable) +(global-set-key '(shift f11) 'describe-foo-at-point) +(global-set-key '(control f11) 'eval-last-sexp) +;; Edebug is a source-level debugger for Emacs Lisp programs. Put +;; the cursor at the end of a function definition and "instrument" it +;; with this command; then, you can single step through it the next +;; time it's run. +(global-set-key '(meta f11) 'edebug-defun) +(global-set-key '(meta f12) 'add-change-log-entry) + +;; This nicely parallels M-*, which pops the tag stack. See below for +;; how to set up tags. +(global-set-key '(control *) 'find-tag-at-point) + +;; Define a function to conveniently determine where time is being +;; spent when executing commands or Lisp code. +(defun toggle-profiling () + "Start profiling, or stop it and print results. +This lets you figure out where time is being spent when executing Lisp code." + (interactive) + (if (profiling-active-p) + (progn + (stop-profiling) + (message "...Finished profiling") + (profile-results)) + (message "Profiling...") + (clear-profiling-info) + (start-profiling))) + +;; Note that sequences of C-c plus a letter are specifically +;; reserved for users and should never be bound by any packages. + +(global-set-key "\C-cp" 'toggle-profiling) + +;; LISPM bindings of Control-Shift-C and Control-Shift-E. +;; See comment above about bindings like this. +(define-key emacs-lisp-mode-map '(control C) 'compile-defun) +(define-key emacs-lisp-mode-map '(control E) 'eval-defun) + +;;;;;;;;;;;;;;;;;;;;;;;; + +;; Numeric keypad. + +;; The numeric keypad as a whole is underused, and it's a good source +;; of keys to bind to commands. Here we add some useful bindings. +;; Because this is a sample file and I want to avoid unpleasant +;; surprises for novices, I don't actually bind the shared +;; numeric/cursor-motion keys because +;; +;; (a) someone keypads don't have separate motion keys (e.g. laptops?), and +;; (b) TTY's and some X servers might not distinguish the regular and +;; numeric-keypad motion keys. + +;; `kill-current-buffer' (defined below) deletes the current +;; buffer. (Don't worry, you will be prompted to save if it's +;; modified.) By repeatedly pressing keypad-minus, you can +;; conveniently reduce the number of open buffers to a manageable size +;; after you've opened a whole bunch of files and finished working on +;; them. Shift plus keypad-minus kills both the current buffer and +;; its window, and Control plus keypad-minus kills just the current +;; window. + +(global-set-key 'kp-subtract 'kill-current-buffer) +(global-set-key '(shift kp-subtract) 'kill-current-buffer-and-window) +(global-set-key '(control kp-subtract) 'delete-window) +;; Ugh, modes that use `suppress-keymap' and are dumped with XEmacs will +;; need their own definition. There is no easy way to fix this. +(define-key help-mode-map 'kp-subtract 'kill-current-buffer) +(define-key help-mode-map '(shift kp-subtract) + 'kill-current-buffer-and-window) +(define-key list-mode-map 'kp-subtract 'kill-current-buffer) +(define-key list-mode-map '(shift kp-subtract) + 'kill-current-buffer-and-window) + +(defun kill-current-buffer () + (interactive) + (kill-buffer (current-buffer))) + +(defun kill-current-buffer-and-window () + (interactive) + (kill-buffer (current-buffer)) + (delete-window)) + +(defun grep-c-files () + (interactive) + (require 'compile) + (let ((grep-command + (cons (concat grep-command " *.[chCH]" + ; i wanted to also use *.cc and *.hh. + ; see long comment below under Perl. + ) + (length grep-command)))) + (call-interactively 'grep))) + +(defun grep-lisp-files () + (interactive) + (require 'compile) + (let ((grep-command + (cons (concat grep-command " *.el" + ; i wanted to also use *.cc and *.hh. + ; see long comment below under Perl. + ) + (length grep-command)))) + (call-interactively 'grep))) + +;; This repeatedly selects larger and larger balanced expressions +;; around the cursor. Once you have such an expression marked, you +;; can expand to the end of the following expression with C-M-SPC and +;; to the beginning of the previous with M-left. + +(defun clear-select () + (interactive "_") ;this means "preserve the active region after this command" + (backward-up-list 1) + (let ((end (save-excursion (forward-sexp) (point)))) + (push-mark end nil t))) + +;; #### no kp-divide because it doesn't (currently) work on MS Windows +;; -- always reports as /. #### this should be fixable. +(global-set-key 'kp-add 'query-replace) +(global-set-key '(shift kp-add) 'query-replace-regexp) +(global-set-key '(control kp-add) 'grep-c-files) +(global-set-key '(meta kp-add) 'grep-lisp-files) +(global-set-key 'clear 'clear-select) +;; Note that you can use a "lambda" expression (an anonymous function) +;; in place of a function name. This function would be called +;; `pop-local-mark' and lets you repeatedly cycle back through recent +;; marks (marks are set whenever you begin a selection, begin a +;; successful search, are about to jump to the beginning or end of the +;; buffer, etc.). +(global-set-key 'kp-enter (lambda () (interactive) (set-mark-command t))) +(global-set-key '(shift kp-enter) 'repeat-complex-command) +(global-set-key 'pause 'repeat-complex-command) ;; useful on Windows-stlye kbds +(global-set-key '(control kp-enter) 'eval-expression) + +;;;;;;;;;;;;;;;;;;;;;;;; + +;; Misc. + +;; If you want button2 to insert the selected text +;; at point (where the text cursor is), instead of at the +;; position clicked, uncomment the following: + +;(setq mouse-yank-at-point t) + +;; If you like the FSF Emacs binding of button3 (single-click +;; extends the selection, double-click kills the selection), +;; uncomment the following: + +;(define-key global-map 'button3 'mouse-track-adjust) + +;(add-hook 'mouse-track-click-hook +; (lambda (event count) +; (if (or (/= (event-button event) 3) +; (/= count 2)) +; nil ;; do the normal operation +; (kill-region (point) (mark)) +; t ;; don't do the normal operations. +; ))) + +;; Uncomment this to enable "sticky modifier keys". With sticky +;; modifier keys enabled, you can press and release a modifier key +;; before pressing the key to be modified, like how the ESC key works +;; always. If you hold the modifier key down, however, you still get +;; the standard behavior. I personally think this is the best thing +;; since sliced bread (and a *major* win when it comes to reducing +;; Emacs pinky), but it's disorienting at first so I'm not enabling it +;; here by default. + +;(setq modifier-keys-are-sticky t) + +;; Enable the command `narrow-to-region' ("C-x n n"). It's a useful +;; command, but possibly confusing to a new user, so it's disabled by +;; default. +(put 'narrow-to-region 'disabled nil) + +;; Enable obvious hyperlink following with button1. +(setq Info-button1-follows-hyperlink t) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Change Some Basic Behaviors ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Change the values of some variables. +;; (t means true; nil means false.) +;; +;; Use C-h v or `Help->Commands, Variables, Keys->Describe Variable...' +;; to find out what these variables mean. +(setq + find-file-compare-truenames t + minibuffer-max-depth nil + ) + +;; When running ispell, consider all 1-3 character words as correct. +(setq ispell-extra-args '("-W" "3")) + +;;; pending-delete-mode causes typed text to replace a selection, +;;; rather than append -- standard behavior under all window systems +;;; nowadays. + +(pending-delete-mode 1) + +;;; enable region selection with shift+arrows (on by default in 21.5 +;;; and up) +(setq shifted-motion-keys-select-region t) + +;;; NOTE: In this context, `windows-nt' actually refers to all MS +;;; Windows operating systems! +(when (eq system-type 'windows-nt) + ;; Get mail working under Windows. + (setq send-mail-function 'smtpmail-send-it) + (setq smtpmail-debug-info t) + ;; Substitute your info here. + ;(setq user-mail-address "ben@xemacs.org") + ;(setq user-full-name "Ben Wing") + ;(setq smtpmail-smtp-server "pop.tcsn.uswest.net") + + ;; Make Alt+accelerator traverse to the menu in new enough XEmacs + ;; versions. Note that this only overrides Meta bindings that would + ;; actually invoke a menu, and that none of the most common commands + ;; are overridden. You can use ESC+key to access the overridden + ;; ones if necessary. + (setq menu-accelerator-enabled 'menu-force) + + ;; Make Cygwin `make' work inside a shell buffer. + (setenv "MAKE_MODE" "UNIX")) + +;; This shows how to set up the XEmacs side of tags. (To create the +;; TAGS table, use the `etags' program found in the XEmacs bin +;; directory. Run it in the root directory of your source tree and +;; specify all source and include files on the command line.) +;(setq tag-table-alist +; '( +; ;; Everywhere in the /src/xemacs/gui/ source tree will use the TAGS +; ;; file in /src/xemacs/gui/. +; ("/src/xemacs/gui/" . "/src/xemacs/gui/") +; ;; Everywhere in the /src/xemacs/mule/ source tree will use the TAGS +; ;; file in /src/xemacs/mule/. +; ("/src/xemacs/mule/" . "/src/xemacs/mule/") +; ;; etc. +; ("/src/xemacs/fixup/" . "/src/xemacs/fixup/") +; ("/src/emacs/emacs-20.6/" . "/src/emacs/emacs-20.6/") +; ("/src/xemacs/latest/" . "/src/xemacs/latest/") +; ;; Everywhere else will use the TAGS file in +; ;; /src/xemacs/fixup/. +; ("" . "/src/xemacs/fixup/") +; )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Change Some Aspects of GUI Appearance ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Changes the text in the window title bar, to switch to MS Windows +;; format (filename goes first, for best identification in icons) and +;; add the version and full executable path. (However, it is not +;; changed unless it currently has the default value, to avoid +;; interfering with a -wn command line argument I may have started +;; XEmacs with.) + +(if (or (equal frame-title-format "%S: %b") + (equal frame-title-format "%b - XEmacs")) + (setq frame-title-format + (concat "%b - XEmacs " + (progn (string-match "\\(.*?\\)\\( XEmacs Lucid\\)?$" + emacs-version) + (match-string 1 emacs-version)) + " [" invocation-directory invocation-name "]"))) + +;; Load some nifty sounds that will replace the default beep. +;; +;; (Note that sampled sounds only work if XEmacs was compiled with +;; sound support and we're running on MS Windows, on a machine which +;; has a NetAudio or ESD server, or on the console of a Linux, Sparc, +;; HP, or SGI machine. Otherwise, you just get the standard beep.) + +(cond ((or (and (getenv "DISPLAY") + (string-match ":0" (getenv "DISPLAY"))) + (and (eq (console-type) 'mswindows) + (device-sound-enabled-p))) + (load-default-sounds) + ;; On Windows, at least, the sound "quiet-beep", which is normally + ;; given the symbolic name `quiet' and is used for Quit and such, + ;; is just totally disgusting. So make this name correspond to a + ;; more innocuous sound. + (load-sound-file "drum-beep" 'quiet 80)) + (t + (setq bell-volume 40) + (setq sound-alist + (append sound-alist '((no-completion :pitch 500)))) + )) + +;; Change the continuation glyph face so it stands out more +(make-face-bold (glyph-face continuation-glyph)) + +;; Change the pointer used during garbage collection. +;; +;; Note that this pointer image is rather large as pointers go, +;; and so it won't work on some X servers (such as the MIT +;; R5 Sun server) because servers may have lamentably small +;; upper limits on pointer size. +;;(if (featurep 'xpm) +;; (set-glyph-image gc-pointer-glyph +;; (expand-file-name "trash.xpm" data-directory))) + +;; Here's another way to do that: it first tries to load the +;; pointer once and traps the error, just to see if it's +;; possible to load that pointer on this system; if it is, +;; then it sets gc-pointer-glyph, because we know that +;; will work. Otherwise, it doesn't change that variable +;; because we know it will just cause some error messages. +(if (featurep 'xpm) + (let ((file (expand-file-name "recycle.xpm" data-directory))) + (if (condition-case nil + ;; check to make sure we can use the pointer. + (make-image-instance file nil + '(pointer)) + (error nil)) ; returns nil if an error occurred. + (set-glyph-image gc-pointer-glyph file)))) + +;(when (featurep 'menubar) +; ;; Add `dired' to the File menu +; (add-menu-button '("File") ["Edit Directory" dired]) + +; ;; Here's a way to add scrollbar-like buttons to the menubar +; (add-menu-button nil ["Top" beginning-of-buffer]) +; (add-menu-button nil ["<<<" scroll-down]) +; (add-menu-button nil [" . " recenter]) +; (add-menu-button nil [">>>" scroll-up]) +; (add-menu-button nil ["Bot" end-of-buffer])) + +;; Here's a cute hack that shows how to programmatically change some +;; text colors. It changes the background color of the window if it's +;; not on the local machine, or if it's running as root: + +;; local emacs background: whitesmoke [i.e. the default color] +;; remote emacs background: palegreen1 +;; root emacs background: coral2 + +;; Uncomment to enable. + +;(cond +; ((and running-xemacs +; (console-on-window-system-p) +; ;; this does not make much sense on Windows. +; (not (eq system-type 'windows-nt))) +; (let* ((root-p (eq 0 (user-uid))) +; (dpy (or (getenv "DISPLAY") "")) +; (remote-p (not +; (or (string-match "^\\(\\|unix\\|localhost\\):" dpy) +; (let ((s (system-name))) +; (if (string-match "\\.\\(netscape\\|mcom\\)\\.com" s) +; (setq s (substring s 0 (match-beginning 0)))) +; (string-match (concat "^" (regexp-quote s)) dpy))))) +; (bg (cond (root-p "coral2") +; (remote-p "palegreen1") +; (t nil)))) +; (cond (bg +; (let ((def (color-name (face-background 'default))) +; (faces (face-list))) +; (while faces +; (let ((obg (face-background (car faces)))) +; (if (and obg (equal def (color-name obg))) +; (set-face-background (car faces) bg))) +; (setq faces (cdr faces))))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Changing the Modeline ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Enable line numbers and column numbers. This is done in C code now +;; and is very fast. +(line-number-mode 1) +(column-number-mode 1) + +;; Rearrange the modeline so that everything is to the left of the +;; long list of minor modes, which is relatively unimportant but takes +;; up so much room that anything to the right is obliterated. + +(setq-default + modeline-format + (list + "" + (if (boundp 'modeline-multibyte-status) 'modeline-multibyte-status "") + (cons modeline-modified-extent 'modeline-modified) + (cons modeline-buffer-id-extent + (list (cons modeline-buffer-id-left-extent + (cons 15 (list + (list 'line-number-mode "L%l ") + (list 'column-number-mode "C%c ") + (cons -3 "%p")))) + (cons modeline-buffer-id-right-extent "%17b"))) + " " + 'global-mode-string + " %[(" + (cons modeline-minor-mode-extent + (list "" 'mode-name 'minor-mode-alist)) + (cons modeline-narrowed-extent "%n") + 'modeline-process + ")%]----" + "%-" + )) + +;; Get rid of modeline information taking up too much space -- in +;; particular, minor modes that are always enabled. +(setq pending-delete-modeline-string "") +(setq filladapt-mode-line-string "") +;; lazy-lock doesn't have a variable for its modeline name, so we have +;; to do a bit of surgery. +(and (assoc 'lazy-lock-mode minor-mode-alist) + (setcdr (cdr (cadr (assoc 'lazy-lock-mode minor-mode-alist))) "")) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Customization of Specific Packages ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; ******************** +;;; Load gnuserv, which will allow you to connect to XEmacs sessions +;;; using `gnuclient'. + +;; If you never run more than one XEmacs at a time, you might want to +;; always start gnuserv. Otherwise it is preferable to specify +;; `-f gnuserv-start' on the command line to one of the XEmacsen. +; (gnuserv-start) + + +;;; ******************** +;;; Load efs, which uses the FTP protocol as a pseudo-filesystem. +;;; When this is loaded, the pathname syntax /user@host:/remote/path +;;; refers to files accessible through ftp. +;;; +(require 'dired) +;; compatible ange-ftp/efs initialization derived from code +;; from John Turner +;; +;; The environment variable EMAIL_ADDRESS is used as the password +;; for access to anonymous ftp sites, if it is set. If not, one is +;; constructed using the environment variables USER and DOMAINNAME +;; (e.g. turner@lanl.gov), if set. + +(condition-case nil + (progn + (require 'efs-auto) + (if (getenv "USER") + (setq efs-default-user (getenv "USER"))) + (if (getenv "EMAIL_ADDRESS") + (setq efs-generate-anonymous-password (getenv "EMAIL_ADDRESS")) + (if (and (getenv "USER") + (getenv "DOMAINNAME")) + (setq efs-generate-anonymous-password + (concat (getenv "USER")"@"(getenv "DOMAINNAME"))))) + (setq efs-auto-save 1)) + (error + (require 'ange-ftp) + (if (getenv "USER") + (setq ange-ftp-default-user (getenv "USER"))) + (if (getenv "EMAIL_ADDRESS") + (setq ange-ftp-generate-anonymous-password (getenv "EMAIL_ADDRESS")) + (if (and (getenv "USER") + (getenv "DOMAINNAME")) + (setq ange-ftp-generate-anonymous-password + (concat (getenv "USER")"@"(getenv "DOMAINNAME"))))) + (setq ange-ftp-auto-save 1) + )) + + +;;; ******************** +;;; Load the default-dir.el package which installs fancy handling of +;;; the initial contents in the minibuffer when reading file names. + +;(condition-case nil +; (require 'default-dir) +; (error nil)) + + +;;; ******************** +;;; Put all of your autosave files in one place, instead of scattering +;;; them around the file system. This has many advantages -- e.g. it +;;; will eliminate slowdowns caused by editing files on a slow NFS +;;; server. (*Provided* that your home directory is local or on a +;;; fast server! If not, pick a value for `auto-save-directory' that +;;; is fast fast fast!) +;;; +;;; Unfortunately, the code that implements this (auto-save.el) is +;;; broken on Windows in 21.4 and earlier. +(unless (and (eq system-type 'windows-nt) + (not (emacs-version>= 21 5))) + (setq auto-save-directory (expand-file-name "~/.autosave/") + auto-save-directory-fallback auto-save-directory + auto-save-hash-p nil + efs-auto-save t + efs-auto-save-remotely nil + ;; now that we have auto-save-timeout, let's crank this up + ;; for better interactive response. + auto-save-interval 2000 + ) + ;; We load this afterwards because it checks to make sure the + ;; auto-save-directory exists (creating it if not) when it's loaded. + (require 'auto-save) + ) + + +;;; ******************** +;;; cc-mode (the mode you're in when editing C, C++, and Objective C files) + +;; Tell cc-mode not to check for old-style (K&R) function declarations. +;; This speeds up indenting a lot. +(setq c-recognize-knr-p nil) + +;; Change the indentation amount to 4 spaces instead of 2. +;; You have to do it in this complicated way because of the +;; strange way the cc-mode initializes the value of `c-basic-offset'. +;; (add-hook 'c-mode-hook (lambda () (setq c-basic-offset 4))) + + +;;; ******************** +;;; Load a partial-completion mechanism, which makes minibuffer completion +;;; search multiple words instead of just prefixes; for example, the command +;;; `M-x byte-compile-and-load-file RET' can be abbreviated as `M-x b-c-a RET' +;;; because there are no other commands whose first three words begin with +;;; the letters `b', `c', and `a' respectively. +;;; +(load-library "completer") + + +;;; ******************** +;;; Load crypt, which is a package for automatically decoding and reencoding +;;; files by various methods - for example, you can visit a .Z or .gz file, +;;; edit it, and have it automatically re-compressed when you save it again. +;;; +(setq crypt-encryption-type 'pgp ; default encryption mechanism + crypt-confirm-password t ; make sure new passwords are correct + ;crypt-never-ever-decrypt t ; if you don't encrypt anything, set this to + ; tell it not to assume that "binary" files + ; are encrypted and require a password. + ) +(require 'crypt) + + +;;; ******************** +;;; Filladapt is a syntax-highlighting package. When it is enabled it +;;; makes filling (e.g. using M-q) much much smarter about paragraphs +;;; that are indented and/or are set off with semicolons, dashes, etc. + +(require 'filladapt) +(setq-default filladapt-mode t) +(add-hook 'c-mode-hook 'turn-off-filladapt-mode) + + +;;; ******************** +;;; Font-Lock is a syntax-highlighting package. When it is enabled and you +;;; are editing a program, different parts of your program will appear in +;;; different fonts or colors. For example, with the code below, comments +;;; appear in red italics, function names in function definitions appear in +;;; blue bold, etc. The code below will cause font-lock to automatically be +;;; enabled when you edit C, C++, Emacs-Lisp, and many other kinds of +;;; programs. +;;; +;;; The "Options" menu has some commands for controlling this as well. +;;; +(cond (running-xemacs + +;; The commented-out code below is an example of setting up custom +;; font-lock colors. + +; ;; If you want the default colors, you could do this: +; ;; (setq font-lock-use-default-fonts nil) +; ;; (setq font-lock-use-default-colors t) +; ;; but I want to specify my own colors, so I turn off all +; ;; default values. +; (setq font-lock-use-default-fonts nil) +; (setq font-lock-use-default-colors nil) + + (require 'font-lock) + +; ;; Mess around with the faces a bit. Note that you have +; ;; to change the font-lock-use-default-* variables *before* +; ;; loading font-lock, and wait till *after* loading font-lock +; ;; to customize the faces. + +; ;; string face is green +; (set-face-foreground 'font-lock-string-face "forest green") + +; ;; comments are italic and red; doc strings are italic +; (set-face-font 'font-lock-comment-face [italic]) +; ;; Underlining comments looks terrible on tty's +; (set-face-underline-p 'font-lock-comment-face nil 'global 'tty) +; (set-face-highlight-p 'font-lock-comment-face t 'global 'tty) +; (copy-face 'font-lock-comment-face 'font-lock-doc-string-face) +; (set-face-foreground 'font-lock-comment-face "red") + +; ;; function names are bold and blue +; (set-face-font 'font-lock-function-name-face [bold]) +; (set-face-foreground 'font-lock-function-name-face "blue") + +; ;; misc. faces +; (set-face-font 'font-lock-preprocessor-face [bold]) +; (set-face-font 'font-lock-type-face [italic]) +; (set-face-font 'font-lock-keyword-face [bold]) + )) + + +;;; ******************** +;;; lazy-lock is a package which speeds up the highlighting of files +;;; by doing it "on-the-fly" -- only the visible portion of the +;;; buffer is fontified. The results may not always be quite as +;;; accurate as using full font-lock or fast-lock, but it's *much* +;;; faster. No more annoying pauses when you load files. + +(add-hook 'font-lock-mode-hook 'turn-on-lazy-lock) +;; I personally don't like "stealth mode" (where lazy-lock starts +;; fontifying in the background if you're idle for 30 seconds) +;; because it takes too long to wake up again on my piddly Sparc 1+. +(setq lazy-lock-stealth-time nil) + + +;;; ******************** +;;; func-menu is a package that scans your source file for function +;;; definitions and makes a menubar entry that lets you jump to any +;;; particular function definition by selecting it from the menu. The +;;; following code turns this on for all of the recognized languages. +;;; Scanning the buffer takes some time, but not much. +;;; +;;; Send bug reports, enhancements etc to: +;;; David Hughes +;;; +(cond (running-xemacs + (require 'func-menu) + (global-set-key '(shift f12) 'function-menu) + (add-hook 'find-file-hooks 'fume-add-menubar-entry) + (global-set-key "\C-cl" 'fume-list-functions) + (global-set-key "\C-cg" 'fume-prompt-function-goto) + + ;; The Hyperbole information manager package uses (shift button2) and + ;; (shift button3) to provide context-sensitive mouse keys. If you + ;; use this next binding, it will conflict with Hyperbole's setup. + ;; Choose another mouse key if you use Hyperbole. + (global-set-key '(shift button3) 'mouse-function-menu) + + ;; For descriptions of the following user-customizable variables, + ;; type C-h v + (setq fume-max-items 25 + fume-fn-window-position 3 + fume-auto-position-popup t + fume-display-in-modeline-p t + fume-menubar-menu-name + (if (fboundp 'submenu-generate-accelerator-spec) + "Function%_s" "Functions") + fume-buffer-name "*Function List*" + fume-no-prompt-on-valid-default nil) + )) + + +;;; ******************** +;;; MH is a mail-reading system from the Rand Corporation that relies on a +;;; number of external filter programs (which do not come with emacs.) +;;; Emacs provides a nice front-end onto MH, called "mh-e". +;;; +;; Bindings that let you send or read mail using MH +;(global-set-key "\C-xm" 'mh-smail) +;(global-set-key "\C-x4m" 'mh-smail-other-window) +;(global-set-key "\C-cr" 'mh-rmail) + +;; Customization of MH behavior. +(setq mh-delete-yanked-msg-window t) +(setq mh-yank-from-start-of-msg 'body) +(setq mh-summary-height 11) + +;; Use lines like the following if your version of MH +;; is in a special place. +;(setq mh-progs "/usr/dist/pkgs/mh/bin.svr4/") +;(setq mh-lib "/usr/dist/pkgs/mh/lib.svr4/") + + +;;; ******************** +;;; resize-minibuffer-mode makes the minibuffer automatically +;;; resize as necessary when it's too big to hold its contents. + +(autoload 'resize-minibuffer-mode "rsz-minibuf" nil t) +(resize-minibuffer-mode) +(setq resize-minibuffer-window-exactly nil) + + +;;; ******************** +;;; scroll-in-place is a package that keeps the cursor on the same line (and in the same column) when scrolling by a page using PgUp/PgDn. + +(require 'scroll-in-place) +(turn-on-scroll-in-place) + + +;;; ******************** +;;; W3 is a browser for the World Wide Web, and takes advantage of the very +;;; latest redisplay features in XEmacs. You can access it simply by typing +;;; 'M-x w3'; however, if you're unlucky enough to be on a machine that is +;;; behind a firewall, you will have to do something like this first: + +;(setq w3-use-telnet t +; ;; +; ;; If the Telnet program you use to access the outside world is +; ;; not called "telnet", specify its name like this. +; w3-telnet-prog "itelnet" +; ;; +; ;; If your Telnet program adds lines of junk at the beginning +; ;; of the session, specify the number of lines here. +; w3-telnet-header-length 4 +; ) diff --git a/info/standards.info-4 b/info/standards.info-4 new file mode 100644 index 0000000..750a7b4 --- /dev/null +++ b/info/standards.info-4 @@ -0,0 +1,150 @@ +This is ../info/standards.info, produced by makeinfo version 4.0 from +standards.texi. + +START-INFO-DIR-ENTRY +* Standards: (standards). GNU coding standards. +END-INFO-DIR-ENTRY + + GNU Coding Standards Copyright (C) 1992, 1993, 1994, 1995, 1996, +1997, 1998, 1999, 2000 Free Software Foundation, Inc. + + Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + + Permission is granted to copy and distribute modified versions of +this manual under the conditions for verbatim copying, provided that +the entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + + Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be stated in a +translation approved by the Free Software Foundation. + + +File: standards.info, Node: Index, Prev: References, Up: Top + +Index +***** + +* Menu: + +* #endif, commenting: Comments. +* --help option: Command-Line Interfaces. +* --version option: Command-Line Interfaces. +* -Wall compiler option: Syntactic Conventions. +* accepting contributions: Contributions. +* address for bug reports: Command-Line Interfaces. +* ANSI C standard: Standard C. +* arbitrary limits on data: Semantics. +* autoconf: System Portability. +* avoiding proprietary code: Reading Non-Free Code. +* behavior, dependent on program's name: User Interfaces. +* binary packages: Install Command Categories. +* bindir: Directory Variables. +* braces, in C source: Formatting. +* bug reports: Command-Line Interfaces. +* canonical name of a program: Command-Line Interfaces. +* casting pointers to integers: CPU Portability. +* change logs: Change Logs. +* change logs, conditional changes: Conditional Changes. +* change logs, style: Style of Change Logs. +* command-line arguments, decoding: Semantics. +* command-line interface: Command-Line Interfaces. +* commenting: Comments. +* compatibility with C and POSIX standards: Compatibility. +* compiler warnings: Syntactic Conventions. +* conditional changes, and change logs: Conditional Changes. +* conditionals, comments for: Comments. +* configure: Configuration. +* control-L: Formatting. +* conventions for makefiles: Makefile Conventions. +* corba: Graphical Interfaces. +* credits for manuals: Manual Credits. +* data types, and portability: CPU Portability. +* declaration for system functions: System Functions. +* documentation: Documentation. +* doschk: Names. +* downloading this manual: Preface. +* error messages: Semantics. +* error messages, formatting: Errors. +* exec_prefix: Directory Variables. +* expressions, splitting: Formatting. +* file usage: File Usage. +* file-name limitations: Names. +* formatting error messages: Errors. +* formatting source code: Formatting. +* formfeed: Formatting. +* function argument, declaring: Syntactic Conventions. +* function prototypes: Standard C. +* getopt: Command-Line Interfaces. +* gettext: Internationalization. +* gnome: Graphical Interfaces. +* graphical user interface: Graphical Interfaces. +* gtk: Graphical Interfaces. +* GUILE: Source Language. +* implicit int: Syntactic Conventions. +* impossible conditions: Semantics. +* internationalization: Internationalization. +* legal aspects: Legal Issues. +* legal papers: Contributions. +* libexecdir: Directory Variables. +* libraries: Libraries. +* library functions, and portability: System Functions. +* license for manuals: License for Manuals. +* lint: Syntactic Conventions. +* long option names: Option Table. +* long-named options: Command-Line Interfaces. +* makefile, conventions for: Makefile Conventions. +* malloc return value: Semantics. +* man pages: Man Pages. +* manual structure: Manual Structure Details. +* memory allocation failure: Semantics. +* memory usage: Memory Usage. +* message text, and internationalization: Internationalization. +* mmap: Mmap. +* multiple variables in a line: Syntactic Conventions. +* names of variables and functions: Names. +* NEWS file: NEWS File. +* non-POSIX systems, and portability: System Portability. +* non-standard extensions: Using Extensions. +* NUL characters: Semantics. +* open brace: Formatting. +* optional features, configure-time: Configuration. +* options for compatibility: Compatibility. +* output device and program's behavior: User Interfaces. +* packaging: Releases. +* portability, and data types: CPU Portability. +* portability, and library functions: System Functions. +* portability, between system types: System Portability. +* POSIX compatibility: Compatibility. +* POSIXLY_CORRECT, environment variable: Compatibility. +* post-installation commands: Install Command Categories. +* pre-installation commands: Install Command Categories. +* prefix: Directory Variables. +* program configuration: Configuration. +* program design: Design Advice. +* program name and its behavior: User Interfaces. +* program's canonical name: Command-Line Interfaces. +* programming languges: Source Language. +* proprietary programs: Reading Non-Free Code. +* README file: Releases. +* references to non-free material: References. +* releasing: Managing Releases. +* sbindir: Directory Variables. +* signal handling: Semantics. +* spaces before open-paren: Formatting. +* standard command-line options: Command-Line Interfaces. +* standards for makefiles: Makefile Conventions. +* string library functions: System Functions. +* syntactic conventions: Syntactic Conventions. +* table of long options: Option Table. +* temporary files: Semantics. +* temporary variables: Syntactic Conventions. +* texinfo.tex, in a distribution: Releases. +* TMPDIR environment variable: Semantics. +* trademarks: Trademarks. +* where to obtain standards.texi: Preface. + + diff --git a/lisp/ChangeLog.GTK b/lisp/ChangeLog.GTK new file mode 100644 index 0000000..c81508f --- /dev/null +++ b/lisp/ChangeLog.GTK @@ -0,0 +1,249 @@ +2000-09-12 William M. Perry + + * dialog-gtk.el (popup-builtin-open-dialog): Went back to + using our lisp implementation of the file dialog. Much more + featureful. + + * ui/gtk-file-dialog.el: Reworked to use CList instead of Tree + elements (more like the `real' GTK file selector. + +2000-09-10 William M. Perry + + * gtk-iso8859-1.el (gtk-iso8859-1): Need to actually provide + the feature + +2000-09-09 William M. Perry + + * dialog-gtk.el (popup-builtin-open-dialog): Guard against + calling gtk-main-quit too many times when destroying the + file-selection dialog. + +2000-09-08 William M. Perry + + * gtk-init.el (gtk-initialize-compose): Initialize the compose + map like X does. + +2000-09-03 William M. Perry + + * menubar-items.el (default-menubar): Include the font & size + menus when running under GTK. + + * gtk-faces.el (x-font-regexp-*): Added variable aliases for + the x-font-regexp-* variables. x-font-menu works now. + + * x-font-menu.el (font-menu-set-font): When setting the font, make + sure we don't set the type to 'x' blithely. This code is shared + with GTK now. + +2000-08-30 William M. Perry + + * dialog-gtk.el (popup-builtin-open-dialog): Signal 'quit' if the + user hits the cancel button. This gets rid of the 'wrong type + argument: stringp, nil' error. + +2000-08-28 William M. Perry + + * menubar-items.el (default-menubar): Disable the GTK font menu + item. + + * dialog-gtk.el (popup-builtin-open-dialog): Reimplemented the + file-open dialog to use the normal GTK selector. + +2000-07-26 William M. Perry + + * gtk-init.el (init-post-gtk-win): Define the mule-fonts specifier + tag and default fonts for it when mule is provided. This will + make x-symbol.el work. + +2000-07-24 William M. Perry + + * ui/gdk.el: Ditto. + + * ui/gnome-widgets.el: Ditto. + + * ui/gtk-widgets.el: Updated all gtk-import-function calls to pass + a symbol instead of a quoted string. + + * ui/gtk-ffi.el (gtk-import-variable): Make gtk-import-variable + able to take symbols instead of just strings. More consistent + with gtk-import-function this way. + +2000-07-22 William M. Perry + + * gtk-init.el (init-pre-gtk-win): Did not realize I had to do lisp + hackery to get '-unmapped' to work. + +2000-07-12 William M. Perry + + * ui/gtk-widgets.el (gtk-ctree-post-recursive): + (gtk-ctree-post-recursive-to-depth): + (gtk-ctree-pre-recursive): + (gtk-ctree-pre-recursive-to-depth): Added wrappers around the + combined gtk-ctree-recurse to make things easier on GTK authors + porting other code. + +2000-07-11 William M. Perry + + * gtk-init.el (init-gtk-win): Set gtk-initial-geometry out of + command-line-args-left. + (gtk-filter-arguments): New function to filter out only GTK/GNOME + approved command line arguments. + (init-gtk-win): Set gtk-initial-argv-list by filtering it. This + way we get session management/etc from GNOME. + +2000-07-07 William M. Perry + + * gtk-faces.el (gtk-init-global-faces): Make sure to pass in a GTK + device (any GTK device) try-font-name when initializing the global + faces or it gets confused and cannot find a font, so the code in + faces.el ends up setting device-specific faces, which are hard (or + at least non-obvious) for users to work around. + +2000-07-01 William M. Perry + + * ui/gtk-widgets.el (GtkType): Added GtkCTree finally. + + * ui/gtk-ffi.el (gtk-ffi-check-function): New function that will + try to call a newly defined FFI function and report on whether we + need to define any new marshallers for it. + (gtk-ffi-debug): If non-nil, then we will check ALL functions that + come through gtk-import-function. All existing imported functions + have been checked, and a few missings ones were added. + + * ui/glade.el: New file to import libglade functions. + +2000-06-30 William M. Perry + + * ui/gdk.el: Added most of the GDK drawing primitives. + +2000-06-27 William M. Perry + + * ui/gtk-widgets.el: Import gtk-major-version, gtk-minor-version, + gtk-micro-version, gtk-interface-age, and gtk-binary-age. + + * ui/gtk-ffi.el (gtk-import-variable): New macro to import a + variable. Needed to do it as a function, otherwise you could not + byte compile / dump the file in a non-windowed XEmacs. + +2000-06-23 William M. Perry + + * menubar-items.el (default-menubar): Disable + make-frame-on-display if the function is not available. + +2000-06-02 William M. Perry + + * gtk-mouse.el (gtk-init-pointers): Make sure we set a toolbar + pointer. Looked kind of silly to have the 'xterm' cursor in + there by default. + +2000-06-01 William M. Perry + + * ui/gtk-widgets.el: Imported GtkStatusbar + + * ui/gtk-marshal.el (define-marshaller): All marshalling functions + are now static. + * ui/gtk-marshal.el: Now outputs a function to populate a + hashtable with mappings from function name -> function pointer. + Also emits the find_marshaller () function that looks at this + hashtable. + +2000-05-29 William M. Perry + + * ui/gtk-ffi.el (gtk-import-function): Allow passing in of a + symbol for the function name, as well as a string. + + * ui/gtk-widgets.el: Import the GtkSpinButton widget. + +2000-05-26 William M. Perry + + * ui/gtk-ffi.el (gtk-import-function): Rewrote as a macro so that + teh file can be safely byte-compiled. Argument values no longer + need to be quoted, and the function is not actually imported until + the function is called. Should save even more on loadup time. + (gtk-import-function): Do not defvar `lisp-name' - put the FFI + object on the symbols plist. Makes the lisp variable namespace + that much cleaner. + + * ui/gtk-widgets.el: New uber-file containing all the GTK imported + functions. Load time is significantly faster than requiring ~90 + different (usually 5 line) .el files, and polluting the 'features' + variable. + +2000-05-23 William M. Perry + + * ui/gtk-widget-accessors.el (define-widget-accessors): Fixed + bogus handling of GTkListOfString and GtkListOfObject slots. + These need to have the FULL type, not the fundamental type. And + _POINTER was just plain wrong for them - cause beautiful crashes + on linux. :) + + * gtk-faces.el (gtk-choose-font): New function to change fonts + based on a GTK font selection dialog. + + * menubar-items.el (default-menubar): Only show the font/size + submenus when we are in an X frame. + (default-menubar): Show a gtk-specific item when on GTK frames. + + * ui/gtk-marshal.el (define-marshaller): We need to special case + anything with FLOAT in the argument list or the parameters get + screwed up royally. + +2000-05-21 William M. Perry + + * ui/gtk-file-dialog.el (gtk-file-dialog-fill-file-list): New file + dialog that is actually useful and much prettier than the default + GTK one. + +2000-05-20 William M. Perry + + * ui/gtk-ffi.el (gtk-import-function): Auto-run gnome-*-get-type + routines as well as the gtk-*-get-type ones. + + * minibuf.el (mouse-read-file-name-1): Now tries to use the new + builtin dialog spec ben wrote about. Uses the GTK file selection + dialog. We should be able to come up with something much sexier + though - the default dialog box for GTK sucks hard. + +2000-05-17 William M. Perry + + * gtk-faces.el (gtk-init-device-faces): Make use of the extended + return values of gtk-style-info. Set the 'highlight' face to look + like GTK_STATE_PRELIGHT and 'zmacs-region' to be + GTK_STATE_SELECTED. Unfortunately these two faces will not + automatically be updated because they are not exposed to lisp + like Vdefault_face and friends. + +2000-05-16 William M. Perry + + * gtk-faces.el (gtk-init-device-faces): Removed a whole bunch of + face munging that is now done down in the guts of the GtkXEmacs + widget. + + * gnuserv.el (gnuserv-edit-files): Handle GTK devices. + + * ui/gtk-ffi.el (gtk-import-function): Make this a noop if + noninteractive. This allows us to compile the files during the + make process. + +2000-05-10 William M. Perry + + * dialog-gtk.el: New file implementing popup dialogs in Lisp using + GTK primitives. Called from dialog-gtk.c + + * dumped-lisp.el (preloaded-file-list): Make sure we load up + menubar-items under GTK. + (preloaded-file-list): Load up dialog-gtk when using GTK. + +2000-05-08 William M. Perry + + * ui/gtk-widget-accessors.el (define-widget-accessors): New file + to define C functions that go into + ../../src/emacs-widget-accessors.c. This is a hack to get around + the lack of accessor/settor functions in GTK for a LOT of things + that are required for full functionality (like dialogs) + +2000-05-07 William M. Perry + + * gtk-faces.el (gtk-init-face-from-resources): Set the highlight + face as well. + diff --git a/lisp/dialog-gtk.el b/lisp/dialog-gtk.el new file mode 100644 index 0000000..5cf81c1 --- /dev/null +++ b/lisp/dialog-gtk.el @@ -0,0 +1,297 @@ +;;; dialog-gtk.el --- Dialog-box support for XEmacs w/GTK primitives + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Maintainer: William M. Perry +;; Keywords: extensions, internal, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs (when dialog boxes are compiled in). + +(require 'cl) +(require 'gtk-password-dialog) +(require 'gtk-file-dialog) + +(defun popup-builtin-open-dialog (keys) + ;; Allowed keywords are: + ;; + ;; :initial-filename fname + ;; :initial-directory dir + ;; :filter-list (filter-desc filter ...) + ;; :directory t/nil + ;; :title string + ;; :allow-multi-select t/nil + ;; :create-prompt-on-nonexistent t/nil + ;; :overwrite-prompt t/nil + ;; :file-must-exist t/nil + ;; :no-network-button t/nil + ;; :no-read-only-return t/nil + (let ((initial-filename (plist-get keys :initial-filename)) + (clicked-ok nil) + (filename nil) + (widget nil)) + (setq widget (gtk-file-dialog-new + :directory (plist-get keys :directory) + :callback `(lambda (f) + (setq clicked-ok t + filename f)) + :initial-directory (or (plist-get keys :initial-directory nil) + (if initial-filename + (file-name-directory initial-filename) + default-directory)) + :filter-list (plist-to-alist + (plist-get keys :filter-list nil)) + :file-must-exist (plist-get keys :file-must-exist nil))) + + (gtk-signal-connect widget 'destroy (lambda (obj data) (gtk-main-quit))) + + (gtk-window-set-transient-for widget (frame-property nil 'shell-widget)) + (gtk-widget-show-all widget) + (gtk-main) + (if (not clicked-ok) + (signal 'quit nil)))) + +(defalias 'popup-builtin-save-as-dialog 'popup-builtin-open-dialog) + +(defun popup-builtin-color-dialog (keys) + ;; Allowed keys: + ;; :initial-color COLOR + (let ((initial-color (or (plist-get keys :initial-color) "white")) + (title (or (plist-get keys :title "Select color..."))) + (dialog nil) + (clicked-ok nil) + (color nil)) + (setq dialog (gtk-color-selection-dialog-new title)) + (gtk-signal-connect + (gtk-color-selection-dialog-ok-button dialog) 'clicked + (lambda (button colorsel) + (gtk-widget-hide-all dialog) + (setq color (gtk-color-selection-get-color colorsel) + clicked-ok t) + (gtk-main-quit)) + (gtk-color-selection-dialog-colorsel dialog)) + + (gtk-signal-connect + (gtk-color-selection-dialog-cancel-button dialog) 'clicked + (lambda (&rest ignored) + (gtk-main-quit))) + + (put dialog 'modal t) + (put dialog 'type 'dialog) + (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget)) + + (unwind-protect + (progn + (gtk-widget-show-now dialog) + (gtk-main)) + '(gtk-widget-destroy dialog)) + (if (not clicked-ok) + (signal 'quit nil)) + ;; Need to convert from (R G B A) to #rrggbb + (format "#%02x%02x%02x" + (* 256 (nth 0 color)) + (* 256 (nth 1 color)) + (* 256 (nth 2 color))))) + +(defun popup-builtin-password-dialog (keys) + ;; Format is (default callback :keyword value) + ;; Allowed keywords are: + ;; + ;; :title string + :; :prompt string + ;; :default string + ;; :verify boolean + ;; :verify-prompt string + (let* ((default (plist-get keys :default)) + (dialog nil) + (clicked-ok nil) + (passwd nil) + (info nil) + (generic-cb (lambda (x) + (setq clicked-ok t + passwd x)))) + + ;; Convert the descriptor to keywords and create the dialog + (setq info (copy-list keys) + info (plist-put info :callback generic-cb) + info (plist-put info :default default) + dialog (apply 'gtk-password-dialog-new info)) + + ;; Clicking any button or closing the box exits the main loop. + (gtk-signal-connect (gtk-password-dialog-ok-button dialog) + 'clicked + (lambda (&rest ignored) + (gtk-main-quit))) + + (gtk-signal-connect (gtk-password-dialog-cancel-button dialog) + 'clicked + (lambda (&rest ignored) + (gtk-main-quit))) + + (gtk-signal-connect dialog + 'delete-event + (lambda (&rest ignored) + (gtk-main-quit))) + + (gtk-widget-grab-focus (gtk-password-dialog-entry-widget dialog)) + + ;; Make us modal... + (put dialog 'modal t) + (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget)) + + ;; Realize the damn thing & wait for some action... + (gtk-widget-show-all dialog) + (gtk-main) + + (if (not clicked-ok) + (signal 'quit nil)) + + (gtk-widget-destroy dialog) + passwd)) + +(defun popup-builtin-question-dialog (keys) + ;; Allowed keywords: + ;; :question STRING + ;; :buttons BUTTONDESC + (let ((title (or (plist-get keys :title) "Question")) + (buttons-descr (plist-get keys :buttons)) + (question (or (plist-get keys :question) "Question goes here...")) + (dialog nil) ; GtkDialog + (buttons nil) ; List of GtkButton objects + (activep t) + (flushrightp nil) + (errp t)) + (if (not buttons-descr) + (error 'syntax-error + "Dialog descriptor must supply at least one button")) + + ;; Do the basics - create the dialog, set the window title, and + ;; add the label asking the question. + (unwind-protect + (progn + (setq dialog (gtk-dialog-new)) + (gtk-window-set-title dialog title) + (gtk-container-set-border-width dialog 3) + (gtk-box-set-spacing (gtk-dialog-vbox dialog) 5) + (gtk-container-add (gtk-dialog-vbox dialog) (gtk-label-new question)) + + ;; Create the buttons. + (mapc (lambda (button) + ;; Handle flushright buttons + (if (null button) + (setq flushrightp t) + + ;; More sanity checking first of all. + (if (not (vectorp button)) + (error "Button descriptor is not a vector: %S" button)) + + (if (< (length button) 3) + (error "Button descriptor is too small: %S" button)) + + (push (gtk-button-new-with-label (aref button 0)) buttons) + + ;; Need to detect what flavor of descriptor it is. + (if (not (keywordp (aref button 2))) + ;; Simple style... just [ name callback activep ] + ;; We ignore the 'suffix' entry, because that is what + ;; the X code does. + (setq activep (aref button 2)) + (let ((ctr 2) + (len (length button))) + (if (logand len 1) + (error + "Button descriptor has an odd number of keywords and values: %S" + button)) + (while (< ctr len) + (if (eq (aref button ctr) :active) + (setq activep (aref button (1+ ctr)) + ctr len)) + (setq ctr (+ ctr 2))))) + (gtk-widget-set-sensitive (car buttons) (eval activep)) + + ;; Apply the callback + (gtk-signal-connect + (car buttons) 'clicked + (lambda (button data) + (push (make-event 'misc-user + (list 'object (car data) + 'function + (if (symbolp (car data)) + 'call-interactively + 'eval))) + unread-command-events) + (gtk-main-quit) + t) + (cons (aref button 1) dialog)) + + (gtk-widget-show (car buttons)) + (funcall (if flushrightp 'gtk-box-pack-end 'gtk-box-pack-start) + (gtk-dialog-action-area dialog) (car buttons) + nil t 2))) + buttons-descr) + + ;; Make sure they can't close it with the window manager + (gtk-signal-connect dialog 'delete-event (lambda (&rest ignored) t)) + (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget)) + (put dialog 'type 'dialog) + (put dialog 'modal t) + (gtk-widget-show-all dialog) + (gtk-main) + (gtk-widget-destroy dialog) + (setq errp nil)) + (if (not errp) + ;; Nothing, we successfully showed the dialog + nil + ;; We need to destroy all the widgets, just in case. + (mapc 'gtk-widget-destroy buttons) + (gtk-widget-destroy dialog))))) + +(defun gtk-make-dialog-box-internal (type keys) + (case type + (file + (popup-builtin-open-dialog keys)) + (password + (popup-builtin-password-dialog keys)) + (question + (popup-builtin-question-dialog keys)) + (color + (popup-builtin-color-dialog keys)) + (find + ) + (font + ) + (replace + ) + (mswindows-message + ;; This should really be renamed! + ) + (print + ) + (page-setup + ) + (print-setup + ) + (default + (error "Unknown type of dialog: %S" type)))) + +(provide 'dialog-gtk) diff --git a/lisp/gdk.el b/lisp/gdk.el new file mode 100644 index 0000000..865fb2d --- /dev/null +++ b/lisp/gdk.el @@ -0,0 +1,149 @@ +;;; gdk.el --- Import GDK functions into XEmacs + +;; Copyright (C) 2000 Free Software Foundation + +;; Maintainer: William Perry +;; Keywords: extensions, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; This file is dumped with XEmacs. + +(eval-and-compile + (require 'gtk-ffi)) + +(gtk-import-function nil gdk_set_show_events (gboolean . show_events)) +(gtk-import-function nil gdk_set_use_xshm (gboolean . use_xshm)) +(gtk-import-function GtkString gdk_get_display) +(gtk-import-function nil gdk_flush) +(gtk-import-function nil gdk_beep) + +(gtk-import-function nil gdk_key_repeat_disable) +(gtk-import-function nil gdk_key_repeat_restore) + +(gtk-import-function gint gdk_visual_get_best_depth) +(gtk-import-function GdkVisualType gdk_visual_get_best_type) +(gtk-import-function GdkVisual gdk_visual_get_system) +(gtk-import-function GdkVisual gdk_visual_get_best) +(gtk-import-function GdkVisual gdk_visual_get_best_with_depth (gint . depth)) +(gtk-import-function GdkVisual gdk_visual_get_best_with_type (GdkVisualType . visual_type)) +(gtk-import-function GdkVisual gdk_visual_get_best_with_both + (gint . depth) + (GdkVisualType . visual_type)) + +(gtk-import-function gboolean gdk_window_is_visible (GdkWindow . window)) +(gtk-import-function gboolean gdk_window_is_viewable (GdkWindow . window)) + +(gtk-import-function gboolean gdk_window_set_static_gravities + (GdkWindow . window) + (gboolean . use_static)) + +(gtk-import-function nil gdk_window_set_cursor + (GdkWindow . window) + (GdkCursor . cursor)) + +(gtk-import-function GdkVisual gdk_window_get_visual (GdkWindow . window)) +(gtk-import-function GdkWindowType gdk_window_get_type (GdkWindow . window)) +(gtk-import-function GdkWindow gdk_window_get_parent (GdkWindow . window)) +(gtk-import-function GdkWindow gdk_window_get_toplevel (GdkWindow . window)) +(gtk-import-function GdkEventMask gdk_window_get_events (GdkWindow . window)) +(gtk-import-function none gdk_window_set_events (GdkWindow . window) (GdkEventMask . events)) +(gtk-import-function none gdk_window_set_icon + (GdkWindow . window) + (GdkWindow . icon_window) + (GdkPixmap . pixmap) + (GdkBitmap . mask)) +(gtk-import-function none gdk_window_set_icon_name (GdkWindow . window) (GtkString . name)) +(gtk-import-function none gdk_window_set_group (GdkWindow . window) (GdkWindow . leader)) +(gtk-import-function none gdk_window_set_decorations + (GdkWindow . window) + (GdkWMDecoration . decorations)) +(gtk-import-function none gdk_window_set_functions + (GdkWindow . window) + (GdkWMFunction . functions)) + +;; Cursors are handled by glyphs in XEmacs +;; GCs are handled by faces in XEmacs +;; Pixmaps are handled by glyphs in XEmacs +;; Images are handled by glyphs in XEmacs +;; Colors are handled natively by XEmacs +;; Fonts are handled natively by XEmacs + +(gtk-import-function none gdk_draw_point + (GdkDrawable . drawable) + (GdkGC . gc) + (gint . x) + (gint . y)) +(gtk-import-function none gdk_draw_line + (GdkDrawable . drawable) + (GdkGC . gc) + (gint . x1) + (gint . y1) + (gint . x2) + (gint . y2)) +(gtk-import-function none gdk_draw_rectangle + (GdkDrawable . drawable) + (GdkGC . gc) + (gboolean . filled) + (gint . x) + (gint . y) + (gint . width) + (gint . height)) +(gtk-import-function none gdk_draw_arc + (GdkDrawable . drawable) + (GdkGC . gc) + (gboolean . filled) + (gint . x) + (gint . y) + (gint . width) + (gint . height) + (gint . angle1) + (gint . angle2)) +(gtk-import-function none gdk_draw_string + (GdkDrawable . drawable) + (GdkFont . font) + (GdkGC . gc) + (gint . x) + (gint . y) + (GtkString . string)) +(gtk-import-function none gdk_draw_text + (GdkDrawable . drawable) + (GdkFont . font) + (GdkGC . gc) + (gint . x) + (gint . y) + (GtkString . string) + (gint . text_length)) +(gtk-import-function none gdk_draw_pixmap + (GdkDrawable . drawable) + (GdkGC . gc) + (GdkImage . image) + (gint . xsrc) + (gint . ysrc) + (gint . xdest) + (gint . ydest) + (gint . width) + (gint . height)) + +;; Selections are handled natively by XEmacs + +(provide 'gdk) diff --git a/lisp/generic-widgets.el b/lisp/generic-widgets.el new file mode 100644 index 0000000..d918c90 --- /dev/null +++ b/lisp/generic-widgets.el @@ -0,0 +1,330 @@ +;;; generic-widgets.el --- Generic UI building + +;; Copyright (C) 2000 Free Software Foundation + +;; Maintainer: William Perry +;; Keywords: extensions, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; This file is dumped with XEmacs. + +(defun build-ui (ui) + (if (null ui) + (gtk-label-new "[empty]") + (let ((builder-func (intern-soft (format "build-ui::%s" (car ui)))) + (widget nil)) + (if (and builder-func (fboundp builder-func)) + (progn + (setq widget (funcall builder-func ui)) + (setcdr ui (plist-put (cdr ui) :x-internal-widget widget)) + widget) + (error "Unknown ui element: %s" (car ui)))))) + +(defun show-ui (ui) + (let ((widget (plist-get (cdr ui) :x-internal-widget))) + (if (not widget) + (error "Attempting to show unrealized UI")) + (gtk-widget-show-all widget) + (gtk-signal-connect widget 'destroy + (lambda (widget ui) + (setcdr ui (plist-put (cdr ui) :x-internal-widget nil))) ui))) + + +(defun build-ui::window (spec) + "Create a top-level window for containing other widgets. +Properties: +:items list A list of child UI specs. Only the first is used. +:type toplevel/dialog/popup What type of window to create. Window managers + can (and usually do) treat each type differently. +" + (let ((plist (cdr spec)) + (window nil) + (child nil)) + (setq window (gtk-window-new (plist-get plist :type 'toplevel)) + child (build-ui (car (plist-get plist :items)))) + (gtk-container-add window child) + window)) + +(defun build-ui::box (spec) + "Create a box for containing other widgets. +Properties: +:items list A list of child UI specs. +:homogeneous t/nil Whether all children are the same width/height. +:spacing number Spacing between children. +:orientation horizontal/vertical How the widgets are stacked. + +Additional properties on child widgets: +:expand t/nil Whether the new child is to be given extra space + allocated to box. The extra space will be divided + evenly between all children of box that use this + option. +:fill t/nil Whether space given to child by the expand option is + actually allocated to child, rather than just padding + it. This parameter has no effect if :expand is set to + nil. A child is always allocated the full height of a + horizontal box and the full width of a vertical box. + This option affects the other dimension. +:padding number Extra padding around this widget. +" + (let* ((plist (cdr spec)) + (orientation (plist-get plist :orientation 'horizontal)) + (children (plist-get plist :items)) + (box nil) + (child-widget nil) + (child-plist nil)) + (case orientation + (vertical (setq box (gtk-vbox-new (plist-get plist :homogeneous) + (plist-get plist :spacing)))) + (horizontal (setq box (gtk-hbox-new (plist-get plist :homogeneous) + (plist-get plist :spacing)))) + (otherwise (error "Unknown orientation for box: %s" orientation))) + (mapc + (lambda (child) + (setq child-plist (cdr child) + child-widget (build-ui child)) + (if (listp child-widget) + (mapc (lambda (w) + (gtk-box-pack-start box w + (plist-get child-plist :expand) + (plist-get child-plist :fill) + (plist-get child-plist :padding))) child-widget) + (gtk-box-pack-start box child-widget + (plist-get child-plist :expand) + (plist-get child-plist :fill) + (plist-get child-plist :padding)))) + children) + box)) + +(defun build-ui::tab-control (spec) + "Create a notebook widget. +Properties: +:items list A list of UI specs to use as notebook pages. +:homogeneous t/nil Whether all tabs are the same width. +:orientation top/bottom/left/right Position of tabs +:show-tabs t/nil Show the tabs on screen? +:scrollable t/nil Allow scrolling to view all tab widgets? + +Additional properties on child widgets: +:tab-label ui A UI spec to use for the tab label. +" + (let* ((plist (cdr spec)) + (notebook (gtk-notebook-new)) + (children (plist-get plist :items)) + (page-counter 1) + (label-widget nil) + (child-widget nil) + (child-plist nil)) + ;; Set all the properties + (gtk-notebook-set-homogeneous-tabs notebook (plist-get plist :homogeneous)) + (gtk-notebook-set-scrollable notebook (plist-get plist :scrollable t)) + (gtk-notebook-set-show-tabs notebook (plist-get plist :show-tabs t)) + (gtk-notebook-set-tab-pos notebook (plist-get plist :orientation 'top)) + + ;; Now fill in the tabs + (mapc + (lambda (child) + (setq child-plist (cdr child) + child-widget (build-ui child) + label-widget (build-ui (plist-get child-plist :tab-label + (list 'label :text (format "tab %d" page-counter)))) + page-counter (1+ page-counter)) + (gtk-notebook-append-page notebook child-widget label-widget)) + children) + notebook)) + +(defun build-ui::text (spec) + "Create a multi-line text widget. +Properties: +:editable t/nil Whether the user can change the contents +:word-wrap t/nil Automatic word wrapping? +:line-wrap t/nil Automatic line wrapping? +:text string Initial contents of the widget +:file filename File for initial contents (takes precedence over :text) +:face facename XEmacs face to use in the widget. +" + (let* ((plist (cdr spec)) + (text (gtk-text-new nil nil)) + (face (plist-get plist :face 'default)) + (info (plist-get plist :text)) + (file (plist-get plist :file))) + (gtk-text-set-editable text (plist-get plist :editable)) + (gtk-text-set-word-wrap text (plist-get plist :word-wrap)) + (gtk-text-set-line-wrap text (plist-get plist :line-wrap)) + (gtk-widget-set-style text 'default) + + ;; Possible convert the file portion + (if (and file (not (stringp file))) + (setq file (eval file))) + + (if (and info (not (stringp info))) + (setq info (eval info))) + + (if (and file (file-exists-p file) (file-readable-p file)) + (save-excursion + (set-buffer (get-buffer-create " *improbable buffer name*")) + (insert-file-contents file) + (setq info (buffer-string)))) + + (gtk-text-insert text + (face-font face) + (face-foreground face) + (face-background face) + info (length info)) + text)) + +(defun build-ui::label (spec) + "Create a label widget. +Properties: +:text string Text inside the label +:face facename XEmacs face to use in the widget. +:justification right/left/center How to justify the text. +" + (let* ((plist (cdr spec)) + (label (gtk-label-new (plist-get plist :text)))) + (gtk-label-set-line-wrap label t) + (gtk-label-set-justify label (plist-get plist :justification)) + (gtk-widget-set-style label (plist-get plist :face 'default)) + label)) + +(defun build-ui::pixmap (spec) + "Create a multi-line text widget. +Properties: +:text string Text inside the label +:face facename XEmacs face to use in the widget. +:justification right/left/center How to justify the text. +" + (let* ((plist (cdr spec)) + (label (gtk-label-new (plist-get plist :text)))) + (gtk-label-set-line-wrap label t) + (gtk-label-set-justify label (plist-get plist :justification)) + (gtk-widget-set-style label (plist-get plist :face 'default)) + label)) + +(defun build-ui::radio-group (spec) + "A convenience when specifying a group of radio buttons." + (let ((build-ui::radio-group nil)) + (mapcar 'build-ui (plist-get (cdr spec) :items)))) + +(defun build-ui::button (spec) + "Create a button widget. +Properties: +:type radio/check/toggle/nil What type of button to create. +:text string Text in the button. +:glyph glyph Image in the button. +:label ui A UI spec to use for the label. +:relief normal/half/none How to draw button edges. + +NOTE: Radio buttons must be in a radio-group object for them to work. +" + (let ((plist (cdr spec)) + (button nil) + (button-type (plist-get plist :type 'normal)) + (label nil)) + (case button-type + (radio + (if (not (boundp 'build-ui::radio-group)) + (error "Attempt to use a radio button outside a radio-group")) + (setq button (gtk-radio-button-new build-ui::radio-group) + build-ui::radio-group (gtk-radio-button-group button))) + (check + (setq button (gtk-check-button-new))) + (toggle + (setq button (gtk-toggle-button-new))) + (normal + (setq button (gtk-button-new))) + (otherwise + (error "Unknown button type: %s" button-type))) + (gtk-container-add + button + (build-ui (plist-get plist :label + (list 'label :text + (plist-get plist + :text (format "%s button" button-type)))))) + button)) + +(defun build-ui::progress-gauge (spec) + "Create a progress meter. +Properties: +:orientation left-to-right/right-to-left/top-to-bottom/bottom-to-top +:type discrete/continuous + +" + (let ((plist (cdr spec)) + (gauge (gtk-progress-bar-new))) + (gtk-progress-bar-set-orientation gauge (plist-get plist :orientation 'left-to-right)) + (gtk-progress-bar-set-bar-style gauge (plist-get plist :type 'continuous)) + gauge)) + +(provide 'generic-widgets) + +(when (featurep 'gtk) ; just loading this file should be OK +(gtk-widget-show-all + (build-ui + '(window :type dialog + :items ((tab-control + :homogeneous t + :orientation bottom + :items ((box :orientation vertical + :tab-label (label :text "vertical") + :items ((label :text "Vertical") + (progress-gauge) + (label :text "Box stacking"))) + (box :orientation horizontal + :spacing 10 + :items ((label :text "Horizontal box") + (label :text "stacking"))) + + (box :orientation vertical + :items + ((radio-group + :items ((button :type radio + :expand nil + :fill nil + :text "Item 1") + (button :type radio + :expand nil + :fill nil + :text "Item 2") + (button :type radio + :expand nil + :fill nil + :text "Item 3") + (button :type radio + :expand nil + :fill nil))))) + (box :orientation vertical + :items ((button :type check + :text "Item 1") + (button :type check + :text "Item 2") + (button :type normal + :text "Item 3") + (button :type toggle))) + (text :editable t + :word-wrap t + :file (locate-data-file "COPYING")) + (text :editable t + :face display-time-mail-balloon-enhance-face + :word-wrap t + :text "Text with a face on it"))))))) +) diff --git a/lisp/glade.el b/lisp/glade.el new file mode 100644 index 0000000..ec4dcd0 --- /dev/null +++ b/lisp/glade.el @@ -0,0 +1,65 @@ +;;; glade.el --- Import libglade functions into XEmacs + +;; Copyright (C) 2000 Free Software Foundation + +;; Maintainer: William Perry +;; Keywords: extensions, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; This file is dumped with XEmacs (if glade was detected) + +(eval-and-compile + (require 'gtk-ffi)) + +(gtk-import-function none glade_init) +(gtk-import-function none glade_gnome_init) +(gtk-import-function none glade_bonobo_init) +(gtk-import-function none glade_load_module (GtkString . module)) +(gtk-import-function GtkType glade_xml_get_type) +(gtk-import-function GtkObject glade_xml_new + (GtkString . filename) + (GtkString . root)) +(gtk-import-function GladeXML glade_xml_new_with_domain + (GtkString . filename) + (GtkString . root) + (GtkString . domain)) +(gtk-import-function GladeXML glade_xml_new_from_memory + (GtkString . buffer) + (gint . size) + (GtkString . root) + (GtkString . domain)) +(gtk-import-function gboolean glade_xml_construct + (GladeXML . self) + (GtkString . filename) + (GtkString . root) + (GtkString . domain)) +(gtk-import-function GtkWidget glade_xml_get_widget + (GladeXML . xml) + (GtkString . name)) +(gtk-import-function GtkWidget glade_xml_get_widget_by_long_name + (GladeXML . xml) + (GtkString . longname)) + +(gtk-import-function GtkString glade_get_widget_name (GtkWidget . widget)) +(gtk-import-function GtkString glade_get_widget_long_name (GtkWidget . widget)) +(gtk-import-function GladeXML glade_get_widget_tree (GtkWidget . widget)) diff --git a/lisp/gnome-widgets.el b/lisp/gnome-widgets.el new file mode 100644 index 0000000..0816644 --- /dev/null +++ b/lisp/gnome-widgets.el @@ -0,0 +1,1006 @@ +;;; gnome-widgets.el --- Import GNOME functions into XEmacs + +;; Copyright (C) 2000 Free Software Foundation + +;; Maintainer: William Perry +;; Keywords: extensions, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; This file is dumped with XEmacs. + +(eval-and-compile + (require 'gtk-ffi)) + +(gtk-import-function GtkType gnome_about_get_type) +(gtk-import-function GtkWidget gnome_about_new + (GtkString . title) + (GtkString . version) + (GtkString . copyright) + (GtkArrayOfString . authors) + (GtkString . comments) + (GtkString . logo)) + + +(gtk-import-function GtkType gnome_app_get_type) + +;; Create a new (empty) application window. You must specify the +;; application's name (used internally as an identifier). The window +;; title can be left as NULL, in which case the window's title will +;; not be set. +(gtk-import-function GtkWidget gnome_app_new + (GtkString . appname) + (GtkString . title)) + +;; Constructor for language bindings; you don't normally need this. +(gtk-import-function nil gnome_app_construct + (GnomeApp . app) + (GtkString . appname) + (GtkString . title)) + +;; Sets the menu bar of the application window +(gtk-import-function nil gnome_app_set_menus + (GnomeApp . app) + (GtkMenuBar . menubar)) + +;; Sets the main toolbar of the application window +(gtk-import-function nil gnome_app_set_toolbar + (GnomeApp . app) + (GtkToolbar . toolbar)) + +;; Sets the status bar of the application window +(gtk-import-function nil gnome_app_set_statusbar + (GnomeApp . app) + (GtkWidget . statusbar)) + +;; Sets the status bar of the application window, but uses the given +;; container widget rather than creating a new one. +(gtk-import-function nil gnome_app_set_statusbar_custom + (GnomeApp . app) + (GtkWidget . container) + (GtkWidget . statusbar)) + +;; Sets the content area of the application window +(gtk-import-function nil gnome_app_set_contents + (GnomeApp . app) + (GtkWidget . contents)) + +(gtk-import-function nil gnome_app_add_toolbar + (GnomeApp . app) + (GtkToolbar . toolbar) + (GtkString . name) + (GnomeDockItemBehavior . behavior) + (GnomeDockPlacement . placement) + (gint . band_num) + (gint . band_position) + (gint . offset)) + +(gtk-import-function nil gnome_app_add_docked + (GnomeApp . app) + (GtkWidget . toolbar) + (GtkString . name) + (GnomeDockItemBehavior . behavior) + (GnomeDockPlacement . placement) + (gint . band_num) + (gint . band_position) + (gint . offset)) + +(gtk-import-function nil gnome_app_add_dock_item + (GnomeApp . app) + (GnomeDockItem . item) + (GnomeDockPlacement . placement) + (gint . band_num) + (gint . band_position) + (gint . offset)) + +(gtk-import-function nil gnome_app_enable_layout_config + (GnomeApp . app) + (gboolean . enable)) + +(gtk-import-function GnomeDock gnome_app_get_dock + (GnomeApp . app)) +(gtk-import-function GnomeDockItem gnome_app_get_dock_item_by_name + (GnomeApp . app) + (GtkString . name)) + + +(gtk-import-function GtkType gnome_appbar_get_type) + +(gtk-import-function GtkWidget gnome_appbar_new + (gboolean . has_progress) + (gboolean . has_status) + (GnomePreferencesType . interactivity)) + +;; Sets the status label without changing widget state; next set or push +;; will destroy this permanently. +(gtk-import-function nil gnome_appbar_set_status + (GnomeAppBar . appbar) + (GtkString . status)) + +;; What to show when showing nothing else; defaults to nothing +(gtk-import-function nil gnome_appbar_set_default + (GnomeAppBar . appbar) + (GtkString . default_status)) + +(gtk-import-function nil gnome_appbar_push + (GnomeAppBar . appbar) + (GtkString . status)) + +;; OK to call on empty stack +(gtk-import-function nil gnome_appbar_pop + (GnomeAppBar . appbar)) + +;; Nuke the stack. +(gtk-import-function nil gnome_appbar_clear_stack + (GnomeAppBar . appbar)) + +;; pure sugar - with a bad name, in light of the get_progress name +;; which is not the opposite of set_progress. Maybe this function +;; should die +(gtk-import-function nil gnome_appbar_set_progress + (GnomeAppBar . appbar) + (gfloat . percentage)) + +;; use GtkProgress functions on returned value +(gtk-import-function GtkProgress gnome_appbar_get_progress + (GnomeAppBar . appbar)) + +;; Reflect the current state of stack/default. Useful to force a set_status +;; to disappear. +(gtk-import-function nil gnome_appbar_refresh + (GnomeAppBar . appbar)) + +;; Put a prompt in the appbar and wait for a response. When the +;; user responds or cancels, a user_response signal is emitted. +(gtk-import-function nil gnome_appbar_set_prompt + (GnomeAppBar . appbar) + (GtkString . prompt) + (gboolean . modal)) + +;; Remove any prompt +(gtk-import-function nil gnome_appbar_clear_prompt + (GnomeAppBar . appbar)) + +;; Get the response to the prompt, if any. Result must be g_free'd. +(gtk-import-function GtkString gnome_appbar_get_response + (GnomeAppBar . appbar)) + + +(gtk-import-function GtkType gnome_calculator_get_type) +(gtk-import-function GtkWidget gnome_calculator_new) +(gtk-import-function nil gnome_calculator_clear + (GnomeCalculator . gc) + (gboolean . reset)) + +(gtk-import-function nil gnome_calculator_set + (GnomeCalculator . gc) + (gdouble . result)) + + +;; Standard Gtk function +(gtk-import-function GtkType gnome_color_picker_get_type) + +;; Creates a new color picker widget +(gtk-import-function GtkWidget gnome_color_picker_new) + +;; Set/get the color in the picker. Values are in [0.0, 1.0] +(gtk-import-function nil gnome_color_picker_set_d + (GnomeColorPicker . cp) + (gdouble . r) + (gdouble . g) + (gdouble . b) + (gdouble . a)) + +;; #### BILL!!! Need multiple return values +;; void gnome_color_picker_get_d (GnomeColorPicker *cp, gdouble *r, gdouble *g, gdouble *b, gdouble *a) + +;; Set/get the color in the picker. Values are in [0, 255] +(gtk-import-function nil gnome_color_picker_set_i8 + (GnomeColorPicker . cp) + (guint . r) + (guint . g) + (guint . b) + (guint . a)) + +;; #### BILL!!! Need multiple return values +;; void gnome_color_picker_get_i8 (GnomeColorPicker *cp, guint8 *r, guint8 *g, guint8 *b, guint8 *a); + +;; Set/get the color in the picker. Values are in [0, 65535] +(gtk-import-function nil gnome_color_picker_set_i16 + (GnomeColorPicker . cp) + (guint . r) + (guint . g) + (guint . b) + (guint . a)) + +;; #### BILL!!! Need multiple return values +;; void gnome_color_picker_get_i16 (GnomeColorPicker *cp, gushort *r, gushort *g, gushort *b, gushort *a); + +;; Sets whether the picker should dither the color sample or just paint a solid rectangle +(gtk-import-function nil gnome_color_picker_set_dither + (GnomeColorPicker . cp) + (gboolean . dither)) + +;; Sets whether the picker should use the alpha channel or not +(gtk-import-function nil gnome_color_picker_set_use_alpha + (GnomeColorPicker . cp) + (gboolean . use_alpha)) + +;; Sets the title for the color selection dialog +(gtk-import-function nil gnome_color_picker_set_title + (GnomeColorPicker . cp) + (GtkString . title)) + + +(gtk-import-function GtkType gnome_date_edit_get_type) +(gtk-import-function GtkWidget gnome_date_edit_new + (time_t . the_time) + (gboolean . show_time) + (gboolean . use_24_format)) + +(gtk-import-function GtkWidget gnome_date_edit_new_flags + (time_t . the_time) + (GnomeDateEditFlags . flags)) + +(gtk-import-function nil gnome_date_edit_set_time + (GnomeDateEdit . gde) + (time_t . the_time)) + +(gtk-import-function nil gnome_date_edit_set_popup_range + (GnomeDateEdit . gde) + (guint . low_hour) + (guint . up_hour)) + +(gtk-import-function 'time_t gnome_date_edit_get_date + (GnomeDateEdit . gde)) + +(gtk-import-function nil gnome_date_edit_set_flags + (GnomeDateEdit . gde) + (GnomeDateEditFlags . flags)) + +(gtk-import-function GnomeDateEditFlags gnome_date_edit_get_flags + (GnomeDateEdit . gde)) + + +(gtk-import-function GtkType gnome_dentry_edit_get_type) + +;; create a new dentry and get the children using the below macros +;; or use the utility new_notebook below +(gtk-import-function GtkObject gnome_dentry_edit_new) + +;;#define gnome_dentry_edit_child1(d) (GNOME_DENTRY_EDIT(d)->child1) +;;#define gnome_dentry_edit_child2(d) (GNOME_DENTRY_EDIT(d)->child2) + +;; Create a new edit in this notebook - appends two pages to the +;; notebook. +(gtk-import-function GtkObject gnome_dentry_edit_new_notebook + (GtkNotebook . notebook)) + +(gtk-import-function nil gnome_dentry_edit_clear + (GnomeDEntryEdit . dee)) + +;; The GnomeDEntryEdit does not store a dentry, and it does not keep +;; track of the location field of GnomeDesktopEntry which will always +;; be NULL. + +;; Make the display reflect dentry at path +(gtk-import-function nil gnome_dentry_edit_load_file + (GnomeDEntryEdit . dee) + (GtkString . path)) + +;; Copy the contents of this dentry into the display +'(gtk-import-function nil gnome_dentry_edit_set_dentry + (GnomeDEntryEdit . dee) + (GnomeDesktopEntry . dentry)) + +;; Generate a dentry based on the contents of the display +'(gtk-import-function GnomeDesktopEntry gnome_dentry_edit_get_dentry + (GnomeDEntryEdit . dee)) + +;; Return an allocated string, you need to g_free it. +(gtk-import-function GtkString gnome_dentry_edit_get_icon + (GnomeDEntryEdit . dee)) +(gtk-import-function GtkString gnome_dentry_edit_get_name + (GnomeDEntryEdit . dee)) + +;; These are accessor functions for the widgets that make up the +;; GnomeDEntryEdit widget. +(gtk-import-function GtkWidget gnome_dentry_get_name_entry (GnomeDEntryEdit . dee)) +(gtk-import-function GtkWidget gnome_dentry_get_comment_entry (GnomeDEntryEdit . dee)) +(gtk-import-function GtkWidget gnome_dentry_get_exec_entry (GnomeDEntryEdit . dee)) +(gtk-import-function GtkWidget gnome_dentry_get_tryexec_entry (GnomeDEntryEdit . dee)) +(gtk-import-function GtkWidget gnome_dentry_get_doc_entry (GnomeDEntryEdit . dee)) +(gtk-import-function GtkWidget gnome_dentry_get_icon_entry (GnomeDEntryEdit . dee)) + + +;; The GtkWidget * return values were added in retrospect; sometimes +;; you might want to connect to the "close" signal of the dialog, or +;; something, the return value makes the functions more +;; flexible. However, there is nothing especially guaranteed about +;; these dialogs except that they will be dialogs, so don't count on +;; anything. + +;; A little OK box +(gtk-import-function GtkWidget gnome_ok_dialog (GtkString . message)) +(gtk-import-function GtkWidget gnome_ok_dialog_parented + (GtkString . message) + (GtkWindow . parent)) + +;; Operation failed fatally. In an OK dialog. +(gtk-import-function GtkWidget gnome_error_dialog '(GtkString . error)) +(gtk-import-function GtkWidget gnome_error_dialog_parented + (GtkString . error) + (GtkWindow . parent)) + +;; Just a warning. +(gtk-import-function GtkWidget gnome_warning_dialog '(GtkString . warning)) +(gtk-import-function GtkWidget gnome_warning_dialog_parented + (GtkString . warning) + (GtkWindow . parent)) + +;;;/* Look in gnome-types.h for the callback types. */ + +;;;/* Ask a yes or no question, and call the callback when it's answered. */ +;;;GtkWidget * gnome_question_dialog (const gchar * question, +;;; GnomeReplyCallback callback, +;;; gpointer data); + +;;;GtkWidget * gnome_question_dialog_parented (const gchar * question, +;;; GnomeReplyCallback callback, +;;; gpointer data, +;;; GtkWindow * parent); + +;;;GtkWidget * gnome_question_dialog_modal (const gchar * question, +;;; GnomeReplyCallback callback, +;;; gpointer data); + +;;;GtkWidget * gnome_question_dialog_modal_parented (const gchar * question, +;;; GnomeReplyCallback callback, +;;; gpointer data, +;;; GtkWindow * parent); + + +;;;/* OK-Cancel question. */ +;;;GtkWidget * gnome_ok_cancel_dialog (const gchar * message, +;;; GnomeReplyCallback callback, +;;; gpointer data); + +;;;GtkWidget * gnome_ok_cancel_dialog_parented (const gchar * message, +;;; GnomeReplyCallback callback, +;;; gpointer data, +;;; GtkWindow * parent); + +;;;GtkWidget * gnome_ok_cancel_dialog_modal (const gchar * message, +;;; GnomeReplyCallback callback, +;;; gpointer data); + +;;;GtkWidget * gnome_ok_cancel_dialog_modal_parented (const gchar * message, +;;; GnomeReplyCallback callback, +;;; gpointer data, +;;; GtkWindow * parent); + + +(gtk-import-function GtkType gnome_file_entry_get_type) +(gtk-import-function GtkWidget gnome_file_entry_new + (GtkString . history_id) + (GtkString . browse_dialog_title)) + +(gtk-import-function nil gnome_file_entry_construct + (GnomeFileEntry . fentry) + (GtkString . history_id) + (GtkString . browse_dialog_title)) + +(gtk-import-function GtkWidget gnome_file_entry_gnome_entry + (GnomeFileEntry .fentry)) + +(gtk-import-function GtkWidget gnome_file_entry_gtk_entry + (GnomeFileEntry . fentry)) + +(gtk-import-function nil gnome_file_entry_set_title + (GnomeFileEntry . fentry) + (GtkString . browse_dialog_title)) + +;; set default path for the browse dialog +(gtk-import-function nil gnome_file_entry_set_default_path + (GnomeFileEntry . fentry) + (GtkString . path)) + +;; sets up the file entry to be a directory picker rather then a file picker +(gtk-import-function nil gnome_file_entry_set_directory + (GnomeFileEntry . fentry) + (gboolean . directory_entry)) + +;; returns a filename which is a full path with WD or the default +;; directory prepended if it's not an absolute path, returns +;; NULL on empty entry or if the file doesn't exist and that was +;; a requirement +(gtk-import-function GtkString gnome_file_entry_get_full_path + (GnomeFileEntry . fentry) + (gboolean . file_must_exist)) + +;; set modality of the file browse dialog, only applies for the +;; next time a dialog is created +(gtk-import-function nil gnome_file_entry_set_modal + (GnomeFileEntry . fentry) + (gboolean . is_modal)) + + +;; Standard Gtk function +(gtk-import-function GtkType gnome_font_picker_get_type) + +;; Creates a new font picker widget +(gtk-import-function GtkWidget gnome_font_picker_new) + +;; Sets the title for the font selection dialog +(gtk-import-function nil gnome_font_picker_set_title + (GnomeFontPicker . gfp) + (GtkString . title)) + +;; Button mode +(gtk-import-function GnomeFontPickerMode gnome_font_picker_get_mode + (GnomeFontPicker . gfp)) + +(gtk-import-function nil gnome_font_picker_set_mode + (GnomeFontPicker . gfp) + (GnomeFontPickerMode . mode)) + +;; With GNOME_FONT_PICKER_MODE_FONT_INFO +;; If use_font_in_label is true, font name will be writen using font choosed by user and +;; using size passed to this function +(gtk-import-function nil gnome_font_picker_fi_set_use_font_in_label + (GnomeFontPicker . gfp) + (gboolean . use_font_in_label) + (gint . size)) + +(gtk-import-function nil gnome_font_picker_fi_set_show_size + (GnomeFontPicker . gfp) + (gboolean . show_size)) + +;; With GNOME_FONT_PICKER_MODE_USER_WIDGET +(gtk-import-function nil gnome_font_picker_uw_set_widget + (GnomeFontPicker . gfp) + (GtkWidget . widget)) + +;; Functions to interface with GtkFontSelectionDialog +(gtk-import-function GtkString gnome_font_picker_get_font_name + (GnomeFontPicker . gfp)) + +;;;GdkFont* gnome_font_picker_get_font (GnomeFontPicker *gfp); + +(gtk-import-function gboolean gnome_font_picker_set_font_name + (GnomeFontPicker . gfp) + (GtkString . fontname)) + +(gtk-import-function GtkString gnome_font_picker_get_preview_text + (GnomeFontPicker . gfp)) + +(gtk-import-function nil gnome_font_picker_set_preview_text + (GnomeFontPicker . gfp) + (GtkString . text)) + + +(gtk-import-function GtkType gnome_href_get_type) +(gtk-import-function GtkWidget gnome_href_new + (GtkString . url) + (GtkString . label)) + +(gtk-import-function nil gnome_href_set_url + (GnomeHRef . href) + (GtkString . url)) +(gtk-import-function GtkString gnome_href_get_url + (GnomeHRef . href)) + +(gtk-import-function nil gnome_href_set_label + (GnomeHRef . href) + (GtkString . label)) + +(gtk-import-function GtkString gnome_href_get_label + (GnomeHRef . href)) + + +;; Stock icons, buttons, and menu items. + +;; A short description: + +;; These functions provide an applications programmer with default +;; icons for toolbars, menu pixmaps, etc. One such `icon' should have +;; at least three pixmaps to reflect it's state. There is a `regular' +;; pixmap, a `disabled' pixmap and a `focused' pixmap. You can get +;; either each of these pixmaps by calling gnome_stock_pixmap or you +;; can get a widget by calling gnome_stock_pixmap_widget. This widget +;; is a container which gtk_widget_shows the pixmap, that is +;; reflecting the current state of the widget. If for example you +;; gtk_container_add this widget to a button, which is currently not +;; sensitive, the widget will just show the `disabled' pixmap. If the +;; state of the button changes to sensitive, the widget will change to +;; the `regular' pixmap. The `focused' pixmap will be shown, when the +;; mouse pointer enters the widget. + +;; To support themability, we use (char *) to call those functions. A +;; new theme might register new icons by calling +;; gnome_stock_pixmap_register, or may change existing icons by +;; calling gnome_stock_pixmap_change. An application should check (by +;; calling gnome_stock_pixmap_checkfor), if the current theme supports +;; an uncommon icon, before using it. The only icons an app can rely +;; on, are those defined in this header file. + +;; We now have stock buttons too. To use them, just replace any +;; gtk_button_new{_with_label} with +;; gnome_stock_button(GNOME_STOCK_BUTTON_...). This function returns +;; a GtkButton with a gettexted default text and an icon. + +;; There's an additional feature, which might be interesting. If an +;; application calls gnome_stock_pixmap_register and uses it by +;; calling gnome_stock_pixmap_widget, it doesn't have to care about +;; the state_changed signal to display the appropriate pixmap +;; itself. Additionally gnome-stock generates a disabled version of a +;; pixmap automatically, when no pixmap for a disabled state is +;; provided. + + +;; State: + +;; currently implemented: +;; - gnome_stock_pixmap +;; - gnome_stock_pixmap_widget +;; - gnome_stock_pixmap_checkfor +;; - GnomeStockPixmapWidget +;; - gnome_stock_button +;; - gnome_stock_pixmap_register + +;; not implemented: +;; - gnome_stock_pixmap_change + +;; The names of `well known' icons. I define these strings mainly to +;; prevent errors due to typos. + +(defvar gnome-stock-pixmaps '( + (new . "New") + (open . "Open") + (close . "Close") + (revert . "Revert") + (save . "Save") + (save-as . "Save As") + (cut . "Cut") + (copy . "Copy") + (paste . "Paste") + (clear . "Clear") + (properties . "Properties") + (preferences . "Preferences") + (help . "Help") + (scores . "Scores") + (print . "Print") + (search . "Search") + (srchrpl . "Search/Replace") + (back . "Back") + (forward . "Forward") + (first . "First") + (last . "Last") + (home . "Home") + (stop . "Stop") + (refresh . "Refresh") + (undo . "Undo") + (redo . "Redo") + (timer . "Timer") + (timer-stop . "Timer Stopped") + (mail . "Mail") + (mail-rcv . "Receive Mail") + (mail-snd . "Send Mail") + (mail-rpl . "Reply to Mail") + (mail-fwd . "Forward Mail") + (mail-new . "New Mail") + (trash . "Trash") + (trash-full . "Trash Full") + (undelete . "Undelete") + (spellcheck . "Spellchecker") + (mic . "Microphone") + (line-in . "Line In") + (cdrom . "Cdrom") + (volume . "Volume") + (midi . "Midi") + (book-red . "Book Red") + (book-green . "Book Green") + (book-blue . "Book Blue") + (BOOK-YELLOW . "Book Yellow") + (BOOK-OPEN . "Book Open") + (ABOUT . "About") + (QUIT . "Quit") + (MULTIPLE . "Multiple") + (NOT . "Not") + (CONVERT . "Convert") + (JUMP-TO . "Jump To") + (UP . "Up") + (DOWN . "Down") + (TOP . "Top") + (BOTTOM . "Bottom") + (ATTACH . "Attach") + (INDEX . "Index") + (FONT . "Font") + (EXEC . "Exec") + + (ALIGN-LEFT . "Left") + (ALIGN-RIGHT . "Right") + (ALIGN-CENTER . "Center") + (ALIGN-JUSTIFY . "Justify") + + (TEXT-BOLD . "Bold") + (TEXT-ITALIC . "Italic") + (TEXT-UNDERLINE . "Underline") + (TEXT-STRIKEOUT . "Strikeout") + + (TEXT-INDENT . "Text Indent") + (TEXT-UNINDENT . "Text Unindent") + + (EXIT . "Quit") + + (COLORSELECTOR . "Color Select") + + (ADD . "Add") + (REMOVE . "Remove") + + (TABLE-BORDERS . "Table Borders") + (TABLE-FILL . "Table Fill") + + (TEXT-BULLETED-LIST . "Text Bulleted List") + (TEXT-NUMBERED-LIST . "Text Numbered List") + )) + +;; The basic pixmap version of an icon. + +;;#define GNOME_STOCK_PIXMAP_REGULAR "regular" +;;#define GNOME_STOCK_PIXMAP_DISABLED "disabled" +;;#define GNOME_STOCK_PIXMAP_FOCUSED "focused" + +(defvar gnome-stock-pixmap-widget-new nil) + +(defun gnome-stock-pixmap-widget-new (window symbol) + "Load a stock pixmap named SYMBOL using WINDOW as the parent." + (if (not gnome-stock-pixmap-widget-new) + (setq gnome-stock-pixmap-widget-new (gtk-import-function-internal + 'GtkWidget + "gnome_stock_pixmap_widget_new" + '(GtkWidget GtkString)))) + (let ((translation (assq symbol gnome-stock-pixmaps))) + (if (not translation) + (error "Unknown stock pixmap: %S" symbol)) + (gtk-call-function gnome-stock-pixmap-widget-new (list window (cdr translation))))) + +(gtk-import-function GtkType gnome_stock_get_type) +(gtk-import-function GtkWidget gnome_stock_new) +(gtk-import-function GtkWidget gnome_stock_new_with_icon '(GtkString . icon)) +(gtk-import-function gboolean gnome_stock_set_icon + (GnomeStock . stock) + (GtkString . icon)) + +;; just fetch a GnomeStock(PixmapWidget) +;; It is possible to specify a filename instead of an icon name. Gnome stock +;; will use gnome_pixmap_file to find the pixmap and return a GnomeStock widget +;; from that file. +(gtk-import-function GtkWidget gnome_stock_pixmap_widget + (GtkWidget . window) + (GtkString . icon)) + +;; This function loads that file scaled to the specified size. Unlike +;; gnome_pixmap_new_from_file_at_size this function uses antializing and stuff +;; to scale the pixmap +(gtk-import-function GtkWidget gnome_stock_pixmap_widget_at_size + (GtkWidget . window) + (GtkString . icon) + (guint . width) + (guint . height)) + +(gtk-import-function nil gnome_stock_pixmap_widget_set_icon + (GnomeStock . widget) + (GtkString . icon)) + +;;;gint gnome_stock_pixmap_register (const char *icon, +;;; const char *subtype, +;;; GnomeStockPixmapEntry *entry); + +;; change an existing entry. returns non-zero on success +;;;gint gnome_stock_pixmap_change (const char *icon, +;;; const char *subtype, +;;; GnomeStockPixmapEntry *entry); + +;; check for the existance of an entry. returns the entry if it +;; exists, or NULL otherwise +;;;GnomeStockPixmapEntry *gnome_stock_pixmap_checkfor (const char *icon, +;;; const char *subtype); + +;; buttons + +(defvar gnome-stock-buttons '((ok . "Button_Ok") + (cancel . "Button_Cancel") + (yes . "Button_Yes") + (no . "Button_No") + (close . "Button_Close") + (apply . "Button_Apply") + (help . "Button_Help") + (next . "Button_Next") + (prev . "Button_Prev") + (up . "Button_Up") + (down . "Button_Down") + (font . "Button_Font"))) + +;; this function returns a button with a pixmap (if ButtonUseIcons is enabled) +;; and the provided text + +(gtk-import-function GtkWidget gnome_pixmap_button + (GtkWidget . pixmap) + (GtkString . text)) +(gtk-import-function nil gnome_button_can_default + (GtkButton . button) + (gboolean . can_default)) + +(defvar gnome-stock-button nil) + +(defun gnome-stock-button (symbol) + "Returns a default button widget for dialogs." + (if (not gnome-stock-button) + (setq gnome-stock-button (gtk-import-function-internal + 'GtkWidget "gnome_stock_button" + '(GtkString)))) + (let ((translation (assq symbol gnome-stock-buttons))) + (if (not translation) + (error "Unknown stock button: %S" symbol)) + (gtk-call-function gnome-stock-button (list (cdr translation))))) + +(defun gnome-stock-or-ordinary-button (type) + "Returns a button widget. If the TYPE argument matches a +GNOME_STOCK_BUTTON_* define, then a stock button is created. +Otherwise, an ordinary button is created, and TYPE is given as the +label." + (if (stringp type) (setq type (intern type))) + (condition-case () + (gnome-stock-button type) + (error (gtk-button-new-with-label (symbol-name type))))) + +;;/* menus */ + +;;#define GNOME_STOCK_MENU_BLANK "Menu_" +;;#define GNOME_STOCK_MENU_NEW "Menu_New" +;;#define GNOME_STOCK_MENU_SAVE "Menu_Save" +;;#define GNOME_STOCK_MENU_SAVE_AS "Menu_Save As" +;;#define GNOME_STOCK_MENU_REVERT "Menu_Revert" +;;#define GNOME_STOCK_MENU_OPEN "Menu_Open" +;;#define GNOME_STOCK_MENU_CLOSE "Menu_Close" +;;#define GNOME_STOCK_MENU_QUIT "Menu_Quit" +;;#define GNOME_STOCK_MENU_CUT "Menu_Cut" +;;#define GNOME_STOCK_MENU_COPY "Menu_Copy" +;;#define GNOME_STOCK_MENU_PASTE "Menu_Paste" +;;#define GNOME_STOCK_MENU_PROP "Menu_Properties" +;;#define GNOME_STOCK_MENU_PREF "Menu_Preferences" +;;#define GNOME_STOCK_MENU_ABOUT "Menu_About" +;;#define GNOME_STOCK_MENU_SCORES "Menu_Scores" +;;#define GNOME_STOCK_MENU_UNDO "Menu_Undo" +;;#define GNOME_STOCK_MENU_REDO "Menu_Redo" +;;#define GNOME_STOCK_MENU_PRINT "Menu_Print" +;;#define GNOME_STOCK_MENU_SEARCH "Menu_Search" +;;#define GNOME_STOCK_MENU_SRCHRPL "Menu_Search/Replace" +;;#define GNOME_STOCK_MENU_BACK "Menu_Back" +;;#define GNOME_STOCK_MENU_FORWARD "Menu_Forward" +;;#define GNOME_STOCK_MENU_FIRST "Menu_First" +;;#define GNOME_STOCK_MENU_LAST "Menu_Last" +;;#define GNOME_STOCK_MENU_HOME "Menu_Home" +;;#define GNOME_STOCK_MENU_STOP "Menu_Stop" +;;#define GNOME_STOCK_MENU_REFRESH "Menu_Refresh" +;;#define GNOME_STOCK_MENU_MAIL "Menu_Mail" +;;#define GNOME_STOCK_MENU_MAIL_RCV "Menu_Receive Mail" +;;#define GNOME_STOCK_MENU_MAIL_SND "Menu_Send Mail" +;;#define GNOME_STOCK_MENU_MAIL_RPL "Menu_Reply to Mail" +;;#define GNOME_STOCK_MENU_MAIL_FWD "Menu_Forward Mail" +;;#define GNOME_STOCK_MENU_MAIL_NEW "Menu_New Mail" +;;#define GNOME_STOCK_MENU_TRASH "Menu_Trash" +;;#define GNOME_STOCK_MENU_TRASH_FULL "Menu_Trash Full" +;;#define GNOME_STOCK_MENU_UNDELETE "Menu_Undelete" +;;#define GNOME_STOCK_MENU_TIMER "Menu_Timer" +;;#define GNOME_STOCK_MENU_TIMER_STOP "Menu_Timer Stopped" +;;#define GNOME_STOCK_MENU_SPELLCHECK "Menu_Spellchecker" +;;#define GNOME_STOCK_MENU_MIC "Menu_Microphone" +;;#define GNOME_STOCK_MENU_LINE_IN "Menu_Line In" +;;#define GNOME_STOCK_MENU_CDROM "Menu_Cdrom" +;;#define GNOME_STOCK_MENU_VOLUME "Menu_Volume" +;;#define GNOME_STOCK_MENU_MIDI "Menu_Midi" +;;#define GNOME_STOCK_MENU_BOOK_RED "Menu_Book Red" +;;#define GNOME_STOCK_MENU_BOOK_GREEN "Menu_Book Green" +;;#define GNOME_STOCK_MENU_BOOK_BLUE "Menu_Book Blue" +;;#define GNOME_STOCK_MENU_BOOK_YELLOW "Menu_Book Yellow" +;;#define GNOME_STOCK_MENU_BOOK_OPEN "Menu_Book Open" +;;#define GNOME_STOCK_MENU_CONVERT "Menu_Convert" +;;#define GNOME_STOCK_MENU_JUMP_TO "Menu_Jump To" +;;#define GNOME_STOCK_MENU_UP "Menu_Up" +;;#define GNOME_STOCK_MENU_DOWN "Menu_Down" +;;#define GNOME_STOCK_MENU_TOP "Menu_Top" +;;#define GNOME_STOCK_MENU_BOTTOM "Menu_Bottom" +;;#define GNOME_STOCK_MENU_ATTACH "Menu_Attach" +;;#define GNOME_STOCK_MENU_INDEX "Menu_Index" +;;#define GNOME_STOCK_MENU_FONT "Menu_Font" +;;#define GNOME_STOCK_MENU_EXEC "Menu_Exec" + +;;#define GNOME_STOCK_MENU_ALIGN_LEFT "Menu_Left" +;;#define GNOME_STOCK_MENU_ALIGN_RIGHT "Menu_Right" +;;#define GNOME_STOCK_MENU_ALIGN_CENTER "Menu_Center" +;;#define GNOME_STOCK_MENU_ALIGN_JUSTIFY "Menu_Justify" + +;;#define GNOME_STOCK_MENU_TEXT_BOLD "Menu_Bold" +;;#define GNOME_STOCK_MENU_TEXT_ITALIC "Menu_Italic" +;;#define GNOME_STOCK_MENU_TEXT_UNDERLINE "Menu_Underline" +;;#define GNOME_STOCK_MENU_TEXT_STRIKEOUT "Menu_Strikeout" + +;;#define GNOME_STOCK_MENU_EXIT GNOME_STOCK_MENU_QUIT + + +;;/* returns a GtkMenuItem with an stock icon and text */ +;;GtkWidget *gnome_stock_menu_item (const char *type, +;; const char *text); + + +;; Creates a toplevel window with a shaped mask. Useful for making the DnD +;; windows +;; GtkWidget *gnome_stock_transparent_window (const char *icon, const char *subtype); + +;;;/* +;;; * Return a GdkPixmap and GdkMask for a stock pixmap +;;; */ +;;;void gnome_stock_pixmap_gdk (const char *icon, +;;; const char *subtype, +;;; GdkPixmap **pixmap, +;;; GdkPixmap **mask); + + +(gtk-import-function GtkType gnome_druid_get_type) +(gtk-import-function GtkWidget gnome_druid_new) +(gtk-import-function void gnome_druid_set_buttons_sensitive + (GnomeDruid . druid) + (gboolean . back_sensitive) + (gboolean . next_sensitive) + (gboolean . cancel_sensitive)) +(gtk-import-function void gnome_druid_set_show_finish + (GnomeDruid . druid) + (gboolean . show_finish)) +(gtk-import-function void gnome_druid_prepend_page + (GnomeDruid . druid) + (GnomeDruidPage . page)) +(gtk-import-function void gnome_druid_insert_page + (GnomeDruid . druid) + (GnomeDruidPage . back_page) + (GnomeDruidPage . page)) +(gtk-import-function void gnome_druid_append_page + (GnomeDruid . druid) + (GnomeDruidPage . page)) +(gtk-import-function void gnome_druid_set_page + (GnomeDruid . druid) + (GnomeDruidPage . page)) + +(gtk-import-function GtkType gnome_druid_page_get_type) +(gtk-import-function gboolean gnome_druid_page_next (GnomeDruidPage . druid_page)) +(gtk-import-function gboolean gnome_druid_page_prepare (GnomeDruidPage . druid_page)) +(gtk-import-function gboolean gnome_druid_page_back (GnomeDruidPage . druid_page)) +(gtk-import-function gboolean gnome_druid_page_cancel (GnomeDruidPage . druid_page)) +(gtk-import-function gboolean gnome_druid_page_finish (GnomeDruidPage . druid_page)) + + +(gtk-import-function GtkType gnome_druid_page_start_get_type) +(gtk-import-function GtkWidget gnome_druid_page_start_new) + +;; #### BOGUS! +'(gtk-import-function GtkWidget gnome_druid_page_start_new_with_vals + (GtkString . title) + (GtkString . text) + (GdkImlibImage . logo) + (GdkImlibImage . watermark)) + +(gtk-import-function void gnome_druid_page_start_set_bg_color + (GnomeDruidPageStart . druid_page_start) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_start_set_textbox_color + (GnomeDruidPageStart . druid_page_start) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_start_set_logo_bg_color + (GnomeDruidPageStart . druid_page_start) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_start_set_title_color + (GnomeDruidPageStart . druid_page_start) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_start_set_text_color + (GnomeDruidPageStart . druid_page_start) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_start_set_text + (GnomeDruidPageStart . druid_page_start) + (GtkString . text)) +(gtk-import-function void gnome_druid_page_start_set_title + (GnomeDruidPageStart . druid_page_start) + (GtkString . title)) + +;; #### BOGUS! +'(gtk-import-function void gnome_druid_page_start_set_logo + (GnomeDruidPageStart . druid_page_start) + (GdkImlibImage . logo_image)) +;; #### BOGUS! +'(gtk-import-function void gnome_druid_page_start_set_watermark + (GnomeDruidPageStart . druid_page_start) + (GdkImlibImage . watermark)) + + +(gtk-import-function GtkType gnome_druid_page_standard_get_type) +(gtk-import-function GtkWidget gnome_druid_page_standard_new) +;; #### BOGUS! +'(gtk-import-function GtkWidget gnome_druid_page_standard_new_with_vals + (GtkString . title) + (GdkImlibImage . logo)) +(gtk-import-function void gnome_druid_page_standard_set_bg_color + (GnomeDruidPageStandard . druid_page_standard) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_standard_set_logo_bg_color + (GnomeDruidPageStandard . druid_page_standard) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_standard_set_title_color + (GnomeDruidPageStandard . druid_page_standard) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_standard_set_title + (GnomeDruidPageStandard . druid_page_standard) + (GtkString . title)) +;; #### BOGUS! +'(gtk-import-function void gnome_druid_page_standard_set_logo + (GnomeDruidPageStandard . druid_page_standard) + (GdkImlibImage . logo_image)) + + +(gtk-import-function GtkType gnome_druid_page_finish_get_type) +(gtk-import-function GtkWidget gnome_druid_page_finish_new) +(gtk-import-function GtkWidget gnome_druid_page_finish_new_with_vals + (GtkString . title) + (GtkString . text) + (GdkImlibImage . logo) + (GdkImlibImage . watermark)) + +(gtk-import-function void gnome_druid_page_finish_set_bg_color + (GnomeDruidPageFinish . druid_page_finish) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_finish_set_textbox_color + (GnomeDruidPageFinish . druid_page_finish) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_finish_set_logo_bg_color + (GnomeDruidPageFinish . druid_page_finish) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_finish_set_title_color + (GnomeDruidPageFinish . druid_page_finish) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_finish_set_text_color + (GnomeDruidPageFinish . druid_page_finish) + (GdkColor . color)) +(gtk-import-function void gnome_druid_page_finish_set_text + (GnomeDruidPageFinish . druid_page_finish) + (GtkString . text)) +(gtk-import-function void gnome_druid_page_finish_set_title + (GnomeDruidPageFinish . druid_page_finish) + (GtkString . title)) +;; #### BOGUS! +'(gtk-import-function void gnome_druid_page_finish_set_logo + (GnomeDruidPageFinish . druid_page_finish) + (GdkImlibImage . logo_image)) +;; #### BOGUS! +'(gtk-import-function void gnome_druid_page_finish_set_watermark + (GnomeDruidPageFinish . druid_page_finish) + (GdkImlibImage . watermark)) + +(provide 'gnome-widgets) diff --git a/lisp/gnome.el b/lisp/gnome.el new file mode 100644 index 0000000..7cdb723 --- /dev/null +++ b/lisp/gnome.el @@ -0,0 +1,20 @@ +(defvar gnome-init-called nil) + +(defun gnome-init (app-id app-version argv) + (mapc 'dll-load + '("libgnomesupport.so" + "libgnome.so" + "libgnomeui.so" + "libesd.so" + "libaudiofile.so" + "libart_lgpl.so")) + (if (and (not (noninteractive)) (not gnome-init-called) + (= (gtk-type-from-name "GnomeApp") 0)) + (prog1 + (gtk-call-function (gtk-import-function-internal + 'gint "gnome_init" '(GtkString GtkString gint GtkArrayOfString)) + (list app-id app-version (length argv) argv)) + (setq gnome-init-called t)))) + +(require 'gnome-widgets) +(provide 'gnome) diff --git a/lisp/gtk-compose.el b/lisp/gtk-compose.el new file mode 100644 index 0000000..003169d --- /dev/null +++ b/lisp/gtk-compose.el @@ -0,0 +1,4 @@ +(require 'gtk-iso8859-1) +(require 'x-compose) + +(provide 'gtk-compose) diff --git a/lisp/gtk-extra.el b/lisp/gtk-extra.el new file mode 100644 index 0000000..10525fc --- /dev/null +++ b/lisp/gtk-extra.el @@ -0,0 +1,117 @@ +;;; gtk-extra.el --- Import `GTK+ Extra' widgets into XEmacs + +;; Copyright (C) 2000 Free Software Foundation + +;; Maintainer: William Perry +;; Keywords: extensions, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; GTK+ Extra can be retrieved from http://magnet.fsu.edu/~feiguin/gtk + +(eval-and-compile + (require 'gtk-ffi)) + +;;; gtkbordercombo.h +(gtk-import-function GtkType gtk_border_combo_get_type) +(gtk-import-function GtkWidget gtk_border_combo_new) + +;;; gtkcheckitem.h +(gtk-import-function GtkType gtk_check_item_get_type) +(gtk-import-function GtkWidget gtk_check_item_new) +(gtk-import-function GtkWidget gtk_check_item_new_with_label + (GtkString . label)) + +;;; gtkcolorcombo.h +(gtk-import-function GtkType gtk_color_combo_get_type) +(gtk-import-function GtkWidget gtk_color_combo_new) +(gtk-import-function GtkWidget gtk_color_combo_new_with_values + (gint . nrows) + (gint . ncols) + (GtkArrayOfString . color_names)) +(gtk-import-function GtkString gtk_color_combo_get_color_at + (GtkColorCombo . combo) + (gint . row) + (gint . col)) +;;;(gtk-import-function none gtk_color_combo_find_color +;;; (GtkColorCombo . combo) +;;; (GdkColor . color) +;;; ((gint . out) . row) +;;; ((gint . out) . col)) + +;;; gtkcombobox.h +(gtk-import-function GtkType gtk_combobox_get_type) +(gtk-import-function GtkWidget gtk_combobox_new) +(gtk-import-function none gtk_combobox_hide_popdown_window) + +;;; gtkdirtree.h +(gtk-import-function GtkType gtk_dir_tree_get_type) +(gtk-import-function GtkWidget gtk_dir_tree_new) +(gtk-import-function gint gtk_dir_tree_open_dir + (GtkDirTree . tree) + (GtkString . path)) + +;;; gtkfilelist.h +(gtk-import-function GtkType gtk_file_list_get_type) +(gtk-import-function GtkWidget gtk_file_list_new + (guint . icon_width) + (gint . mode) + (GtkString . path)) +(gtk-import-function none gtk_file_list_set_filter + (GtkFileList . file_list) + (GtkString . filter)) +(gtk-import-function none gtk_file_list_open_dir + (GtkFileList . file_list) + (GtkString . path)) +(gtk-import-function GtkString gtk_file_list_get_path + (GtkFileList . file_list)) +(gtk-import-function GtkString gtk_file_list_get_filename + (GtkFileList . file_list)) + +;;; gtkfontcombo.h +(gtk-import-function GtkType gtk_font_combo_get_type) +(gtk-import-function GtkWidget gtk_font_combo_new) +(gtk-import-function none gtk_font_combo_select + (GtkFontCombo . font_combo) + (GtkString . family) + (gboolean . bold) + (gboolean . italic) + (gint . height)) +(gtk-import-function none gtk_font_combo_select_nth + (GtkFontCombo . font_combo) + (gint . n) + (gboolean . bold) + (gboolean . italic) + (gint . height)) + +;;; gtkiconfilesel.h +;;; gtkiconlist.h +;;; gtkitementry.h +;;; gtkplot.h +;;; gtkplotcanvas.h +;;; gtkplotpc.h +;;; gtkplotprint.h +;;; gtkplotps.h +;;; gtkpsfont.h +;;; gtksheet.h + +(provide 'gtk-extra) diff --git a/lisp/gtk-faces.el b/lisp/gtk-faces.el new file mode 100644 index 0000000..3a6824c --- /dev/null +++ b/lisp/gtk-faces.el @@ -0,0 +1,297 @@ +;;; gtk-faces.el --- GTK-specific face frobnication, aka black magic. + +;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing. +;; Copyright (c) 2000 William Perry + +;; Author: William M. Perry +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, internal, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not synched. + +;;; Commentary: + +;; This file is dumped with XEmacs (when GTK support is compiled in). + + +(defun gtk-init-find-device () + (let ((dev nil) + (devices (device-list))) + (while (and (not dev) devices) + (if (eq (device-type (car devices)) 'gtk) + (setq dev (car devices))) + (setq devices (cdr devices))) + dev)) + +;;; gtk-init-device-faces is responsible for initializing default +;;; values for faces on a newly created device. +;;; +(defun gtk-init-device-faces (device) + ;; + ;; If the "default" face didn't have a font specified, try to pick one. + ;; + (if (not (eq (device-type device) 'gtk)) + nil + (gtk-init-pointers) + '(let* ((style (gtk-style-info device)) + ;;(normal 0) ; GTK_STATE_NORMAL + ;;(active 1) ; GTK_STATE_ACTIVE + (prelight 2) ; GTK_STATE_PRELIGHT + (selected 3) ; GTK_STATE_SELECTED + ;;(insensitive 4) ; GTK_STATE_INSENSITIVE + ) + (set-face-foreground 'highlight + (nth prelight (plist-get style 'text)) + device) + (set-face-background 'highlight + (nth prelight (plist-get style 'background)) + device) + (set-face-foreground 'zmacs-region + (nth selected (plist-get style 'text)) + device) + (set-face-background 'zmacs-region + (nth selected (plist-get style 'background)) + device)) + (set-face-background 'text-cursor "red3" device))) + +;;; This is called from `init-frame-faces', which is called from +;;; init_frame_faces() which is called from Fmake_frame(), to perform +;;; any device-specific initialization. +;;; +(defun gtk-init-frame-faces (frame) + ) + +;;; gtk-init-global-faces is responsible for ensuring that the +;;; default face has some reasonable fallbacks if nothing else is +;;; specified. +;;; +(defun gtk-init-global-faces () + (let* ((dev (gtk-init-find-device)) + (default-font (or (face-font 'default 'global) + ;(plist-get (gtk-style-info dev) 'font) + "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*")) + (italic-font (or (gtk-make-font-italic default-font dev) default-font)) + (bold-font (or (gtk-make-font-bold default-font dev) default-font)) + (bi-font (or (gtk-make-font-bold-italic default-font dev) default-font))) + + (or (face-font 'default 'global) + (set-face-font 'default default-font 'global '(gtk default))) + + (or (face-font 'bold 'global) + (set-face-font 'bold bold-font 'global '(gtk default))) + + (or (face-font 'bold-italic 'global) + (set-face-font 'bold-italic bi-font 'global '(gtk default))) + + (or (face-font 'italic 'global) + (set-face-font 'italic italic-font 'global '(gtk default))))) + + +;;; Lots of this stolen from x-faces.el - I'm not sure if this will +;;; require a rewrite for win32 or not? +(defconst gtk-font-regexp nil) +(defconst gtk-font-regexp-head nil) +(defconst gtk-font-regexp-head-2 nil) +(defconst gtk-font-regexp-weight nil) +(defconst gtk-font-regexp-slant nil) +(defconst gtk-font-regexp-pixel nil) +(defconst gtk-font-regexp-point nil) +(defconst gtk-font-regexp-foundry-and-family nil) +(defconst gtk-font-regexp-registry-and-encoding nil) +(defconst gtk-font-regexp-spacing nil) + +;;; Regexps matching font names in "Host Portable Character Representation." +;;; +(let ((- "[-?]") + (foundry "[^-]*") + (family "[^-]*") + (weight "\\(bold\\|demibold\\|medium\\|black\\)") ; 1 +; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1 + (weight\? "\\([^-]*\\)") ; 1 + (slant "\\([ior]\\)") ; 2 +; (slant\? "\\([ior?*]?\\)") ; 2 + (slant\? "\\([^-]?\\)") ; 2 +; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3 + (swidth "\\([^-]*\\)") ; 3 +; (adstyle "\\(\\*\\|sans\\|\\)") ; 4 + (adstyle "\\([^-]*\\)") ; 4 + (pixelsize "\\(\\*\\|[0-9]+\\)") ; 5 + (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)") ; 6 +; (resx "\\(\\*\\|[0-9][0-9]+\\)") ; 7 +; (resy "\\(\\*\\|[0-9][0-9]+\\)") ; 8 + (resx "\\([*0]\\|[0-9][0-9]+\\)") ; 7 + (resy "\\([*0]\\|[0-9][0-9]+\\)") ; 8 + (spacing "[cmp?*]") + (avgwidth "\\(\\*\\|[0-9]+\\)") ; 9 + (registry "[^-]*") ; some fonts have omitted registries +; (encoding ".+") ; note that encoding may contain "-"... + (encoding "[^-]+") ; false! + ) + (setq gtk-font-regexp + (purecopy + (concat "\\`\\*?[-?*]" + foundry - family - weight\? - slant\? - swidth - adstyle - + pixelsize - pointsize - resx - resy - spacing - avgwidth - + registry - encoding "\\'" + ))) + (setq gtk-font-regexp-head + (purecopy + (concat "\\`[-?*]" foundry - family - weight\? - slant\? + "\\([-*?]\\|\\'\\)"))) + (setq gtk-font-regexp-head-2 + (purecopy + (concat "\\`[-?*]" foundry - family - weight\? - slant\? + - swidth - adstyle - pixelsize - pointsize + "\\([-*?]\\|\\'\\)"))) + (setq gtk-font-regexp-slant (purecopy (concat - slant -))) + (setq gtk-font-regexp-weight (purecopy (concat - weight -))) + ;; if we can't match any of the more specific regexps (unfortunate) then + ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits + ;; is pixels. Bogus as hell. + (setq gtk-font-regexp-pixel (purecopy "[-?*]\\([0-9][0-9]?\\)[-?*]")) + (setq gtk-font-regexp-point (purecopy "[-?*]\\([0-9][0-9]+\\)[-?*]")) + ;; the following two are used by x-font-menu.el. + (setq gtk-font-regexp-foundry-and-family + (purecopy (concat "\\`[-?*]" foundry - "\\(" family "\\)" -))) + (setq gtk-font-regexp-registry-and-encoding + (purecopy (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))) + (setq gtk-font-regexp-spacing + (purecopy (concat - "\\(" spacing "\\)" - avgwidth + - registry - encoding "\\'"))) + ) + +(defvaralias 'x-font-regexp 'gtk-font-regexp) +(defvaralias 'x-font-regexp-head 'gtk-font-regexp-head) +(defvaralias 'x-font-regexp-head-2 'gtk-font-regexp-head-2) +(defvaralias 'x-font-regexp-weight 'gtk-font-regexp-weight) +(defvaralias 'x-font-regexp-slant 'gtk-font-regexp-slant) +(defvaralias 'x-font-regexp-pixel 'gtk-font-regexp-pixel) +(defvaralias 'x-font-regexp-point 'gtk-font-regexp-point) +(defvaralias 'x-font-regexp-foundry-and-family 'gtk-font-regexp-foundry-and-family) +(defvaralias 'x-font-regexp-registry-and-encoding 'gtk-font-regexp-registry-and-encoding) +(defvaralias 'x-font-regexp-spacing 'gtk-font-regexp-spacing) + +(defun gtk-frob-font-weight (font which) + (if (font-instance-p font) (setq font (font-instance-name font))) + (cond ((null font) nil) + ((or (string-match gtk-font-regexp font) + (string-match gtk-font-regexp-head font) + (string-match gtk-font-regexp-weight font)) + (concat (substring font 0 (match-beginning 1)) which + (substring font (match-end 1)))) + (t nil))) + +(defun gtk-frob-font-slant (font which) + (if (font-instance-p font) (setq font (font-instance-name font))) + (cond ((null font) nil) + ((or (string-match gtk-font-regexp font) + (string-match gtk-font-regexp-head font)) + (concat (substring font 0 (match-beginning 2)) which + (substring font (match-end 2)))) + ((string-match gtk-font-regexp-slant font) + (concat (substring font 0 (match-beginning 1)) which + (substring font (match-end 1)))) + (t nil))) + +(defun gtk-make-font-bold (font &optional device) + (or (try-font-name (gtk-frob-font-weight font "bold") device) + (try-font-name (gtk-frob-font-weight font "black") device) + (try-font-name (gtk-frob-font-weight font "demibold") device))) + +(defun gtk-make-font-unbold (font &optional device) + (try-font-name (gtk-frob-font-weight font "medium") device)) + +(defcustom *try-oblique-before-italic-fonts* t + "*If nil, italic fonts are searched before oblique fonts. +If non-nil, oblique fonts are tried before italic fonts. This is mostly +applicable to adobe-courier fonts" + :type 'boolean + :tag "Try Oblique Before Italic Fonts" + :group 'x) + +(defun gtk-make-font-italic (font &optional device) + (if *try-oblique-before-italic-fonts* + (or (try-font-name (gtk-frob-font-slant font "o") device) + (try-font-name (gtk-frob-font-slant font "i") device)) + (or (try-font-name (gtk-frob-font-slant font "i") device) + (try-font-name (gtk-frob-font-slant font "o") device)))) + +(defun gtk-make-font-unitalic (font &optional device) + (try-font-name (gtk-frob-font-slant font "r") device)) + +(defun gtk-make-font-bold-italic (font &optional device) + (if *try-oblique-before-italic-fonts* + (or (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "o") device) + (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "i") device) + (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "black") "o") device) + (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "black") "i") device) + (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "o") device) + (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "i") device)) + (or (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "i") device) + (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "bold") "o") device) + (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "black") "i") device) + (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "black") "o") device) + (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "i") device) + (try-font-name + (gtk-frob-font-slant (gtk-frob-font-weight font "demibold") "o") device)))) + +(defun gtk-choose-font () + (interactive) + (require 'x-font-menu) + (require 'font) + (let ((locale (if font-menu-this-frame-only-p + (selected-frame) + nil)) + (dialog nil)) + (setq dialog (gtk-font-selection-dialog-new "Choose default font...")) + (put dialog 'modal t) + (put dialog 'type 'dialog) + + (gtk-widget-set-sensitive (gtk-font-selection-dialog-apply-button dialog) nil) + (gtk-signal-connect dialog 'destroy (lambda (&rest ignored) (gtk-main-quit))) + (gtk-signal-connect (gtk-font-selection-dialog-ok-button dialog) + 'clicked + (lambda (button data) + (let* ((dialog (car data)) + (locale (cdr data)) + (font (font-create-object + (gtk-font-selection-dialog-get-font-name dialog)))) + (gtk-widget-destroy dialog) + (font-menu-set-font (car (font-family font)) nil (* 10 (font-size font))))) + (cons dialog locale)) + (gtk-signal-connect (gtk-font-selection-dialog-cancel-button dialog) + 'clicked + (lambda (button dialog) + (gtk-widget-destroy dialog)) dialog) + + (gtk-widget-show-all dialog) + (gtk-main))) diff --git a/lisp/gtk-ffi.el b/lisp/gtk-ffi.el new file mode 100644 index 0000000..2d01f4b --- /dev/null +++ b/lisp/gtk-ffi.el @@ -0,0 +1,104 @@ +;;; gtk-ffi.el --- Foreign function interface for the GTK object system + +;; Copyright (C) 2000 Free Software Foundation + +;; Maintainer: William Perry +;; Keywords: extensions, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; This file is dumped with XEmacs. + +(defvar gtk-type-aliases '((GtkType . guint) + (GdkAtom . gulong) + (GdkBitmap . GdkWindow) + (time_t . guint) + (none . void) + (GdkDrawable . GdkWindow) + (GdkBitmap . GdkWindow) + (GdkPixmap . GdkWindow)) + "An assoc list of aliases for commonly used GTK types that are not +really part of the object system.") + +(defvar gtk-ffi-debug nil + "If non-nil, all functions defined wiht `gtk-import-function' will be checked +for missing marshallers.") + +(defun gtk-ffi-check-function (func) + ;; We don't call gtk-main or gtk-main-quit because it thoroughly + ;; hoses us (locks up xemacs handling events, but no lisp). + (if (not (memq func '(gtk-main gtk-main-quit))) + (condition-case err + (funcall func) + (error + (case (car err) + (wrong-number-of-arguments nil) + (error + (if (string= "Could not locate marshaller function" (nth 1 err)) + (progn + (set-buffer (get-buffer-create "needed marshallers")) + (display-buffer (current-buffer)) + (goto-char (point-max)) + (insert + (format "%S\n" + (split-string + (substring (nth 2 err) (length "emacs_gtk_marshal_")) "_+"))))))))))) + +(defmacro gtk-import-function (retval name &rest args) + (if (symbolp name) + (setq name (symbol-name name))) + (let ((lisp-name (intern (replace-in-string name "_" "-"))) + (doc-string nil)) + (setq retval (or (cdr-safe (assoc retval gtk-type-aliases)) retval) + doc-string (concat "The lisp version of " name ".\n" + (if args + (concat "Prototype: " (prin1-to-string args))))) + + ;; Drop off any naming of arguments, etc. + (if (and args (consp (car args))) + (setq args (mapcar 'car args))) + + ;; Get rid of any type aliases. + (setq args (mapcar (lambda (x) + (or (cdr-safe (assoc x gtk-type-aliases)) x)) args)) + + `(progn + (defun ,lisp-name (&rest args) + ,doc-string + (if (not (get (quote ,lisp-name) 'gtk-ffi nil)) + (put (quote ,lisp-name) 'gtk-ffi + (gtk-import-function-internal (quote ,retval) ,name + (quote ,args)))) + (gtk-call-function (get (quote ,lisp-name) 'gtk-ffi 'ignore) args)) + (and gtk-ffi-debug (gtk-ffi-check-function (quote ,lisp-name)))))) + +(defmacro gtk-import-variable (type name) + (if (symbolp name) (setq name (symbol-name name))) + (let ((lisp-name (intern (replace-in-string name "_" "-"))) + (doc-string nil)) + (setq type (or (cdr-safe (assoc type gtk-type-aliases)) type) + doc-string (concat "Retrieve the variable " name " (type: " (symbol-name type) ").\n")) + `(defun ,lisp-name () + ,doc-string + (gtk-import-variable-internal (quote ,type) ,name)))) + +(provide 'gtk-ffi) diff --git a/lisp/gtk-file-dialog.el b/lisp/gtk-file-dialog.el new file mode 100644 index 0000000..d844cf9 --- /dev/null +++ b/lisp/gtk-file-dialog.el @@ -0,0 +1,277 @@ +;;; gtk-file-dialog.el --- A nicer file selection dialog for XEmacs w/GTK primitives + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Maintainer: William M. Perry +;; Keywords: extensions, internal + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; The default GTK file selection dialog is not sufficient for our +;; needs. Limitations include: +;; +;; - not derived from GtkDialog +;; - no support for filters based on file types +;; - no support for setting an initial directory +;; - no way to tell it 'file must exist' +;; - no easy way to tell it to look at directories only +;; - ugly as sin +;; +;; This attempts to rectify the situation. + +(defun gtk-file-dialog-fill-file-list (dialog dir) + (if (not dir) + (setq dir (get dialog 'x-file-dialog-current-dir nil))) + + (put dialog 'x-file-dialog-current-dir dir) + + (let ((list (get dialog 'x-file-dialog-files-list nil)) + (remotep (file-remote-p dir))) + (if (not list) + nil + (gtk-clist-clear list) + (gtk-clist-freeze list) + ;; NOTE: Current versions of efs / ange-ftp do not honor the + ;; files-only flag to directory-files, but actually DOING these + ;; checks is hideously expensive. Leave it turned off for now. + (mapc (lambda (f) + (if (or t ; Lets just wait for EFS to + (not remotep) ; fix itself, shall we? + (not (file-directory-p (expand-file-name f dir)))) + (gtk-clist-append list (list f)))) + (directory-files dir nil + (get dialog 'x-file-dialog-active-filter nil) + nil t)) + (gtk-clist-thaw list)))) + +(defun gtk-file-dialog-fill-directory-list (dialog dir) + (let ((subdirs (directory-files dir nil nil nil 5)) + (remotep (file-remote-p dir)) + (selected-dir (get dialog 'x-file-dialog-current-dir "/")) + (directory-list (get dialog 'x-file-dialog-directory-list))) + + (gtk-clist-freeze directory-list) + (gtk-clist-clear directory-list) + + (while subdirs + (if (equal "." (car subdirs)) + nil + ;; NOTE: Current versions of efs / ange-ftp do not honor the + ;; files-only flag to directory-files, but actually DOING these + ;; checks is hideously expensive. Leave it turned off for now. + (if (or t ; Lets just wait for EFS to + (not remotep) ; fix itself, shall we? + (file-directory-p (expand-file-name (car subdirs) dir))) + (gtk-clist-append directory-list (list (car subdirs))))) + (pop subdirs)) + (gtk-clist-thaw directory-list))) + +(defun gtk-file-dialog-update-dropdown (dialog dir) + (let ((combo-box (get dialog 'x-file-dialog-select-list)) + (components (reverse + (delete "" + (split-string dir + (concat "[" (char-to-string directory-sep-char) "]"))))) + (entries nil)) + + (while components + (push (concat "/" (mapconcat 'identity (reverse components) + (char-to-string directory-sep-char))) + entries) + (pop components)) + (push (expand-file-name "." "~/") entries) + (gtk-combo-set-popdown-strings combo-box (nreverse entries)))) + +(defun gtk-file-dialog-select-directory (dialog dir) + (gtk-file-dialog-fill-directory-list dialog dir) + (gtk-file-dialog-fill-file-list dialog dir) + (gtk-file-dialog-update-dropdown dialog dir)) + +(defun gtk-file-dialog-new (&rest keywords) + "Create a XEmacs file selection dialog. +Optional keyword arguments allowed: + +:title The title of the dialog +:initial-directory Initial directory to show +:filter-list List of filter descriptions and filters +:file-must-exist Whether the file must exist or not +:directory Look for a directory instead +:callback Function to call with one arg, the selection +" + (let* ((dialog (gtk-dialog-new)) + (vbox (gtk-dialog-vbox dialog)) + (dir (plist-get keywords :initial-directory default-directory)) + (button-area (gtk-dialog-action-area dialog)) + (initializing-gtk-file-dialog t) + (select-box nil) + button hbox) + + (put dialog 'type 'dialog) + + (gtk-window-set-title dialog (plist-get keywords :title "Select a file...")) + + (setq button (gtk-button-new-with-label "OK")) + (gtk-container-add button-area button) + (gtk-signal-connect button 'clicked + (lambda (button dialog) + (funcall + (get dialog 'x-file-dialog-callback 'ignore) + (gtk-entry-get-text + (get dialog 'x-file-dialog-entry nil))) + (gtk-widget-destroy dialog)) + dialog) + (put dialog 'x-file-dialog-ok-button button) + + (setq button (gtk-button-new-with-label "Cancel")) + (gtk-container-add button-area button) + (gtk-signal-connect button 'clicked + (lambda (button dialog) + (gtk-widget-destroy dialog)) dialog) + + (put dialog 'x-file-dialog-cancel-button button) + (put dialog 'x-file-dialog-callback (plist-get keywords :callback 'ignore)) + (put dialog 'x-file-dialog-construct-args keywords) + (put dialog 'x-file-dialog-current-dir dir) + + ;; Dropdown list of directories... + (setq select-box (gtk-combo-new)) + (gtk-combo-disable-activate select-box) + (gtk-box-pack-start vbox select-box nil nil 5) + (put dialog 'x-file-dialog-select-list select-box) + + ;; Hitting return in the entry will change dirs... + (gtk-signal-connect (gtk-combo-entry select-box) 'activate + (lambda (entry dialog) + (gtk-file-dialog-select-directory dialog + (gtk-entry-get-text entry))) + dialog) + + ;; Start laying out horizontally... + (setq hbox (gtk-hbox-new nil 0)) + (gtk-box-pack-start vbox hbox t t 5) + + ;; Directory listing + (let ((directories (gtk-clist-new-with-titles 1 '("Directories"))) + (scrolled (gtk-scrolled-window-new nil nil)) + (item nil)) + (gtk-container-add scrolled directories) + (gtk-widget-set-usize scrolled 200 300) + (gtk-box-pack-start hbox scrolled t t 0) + (put dialog 'x-file-dialog-directory-list directories) + (put dialog 'x-file-dialog-directory-scrolled scrolled) + + (gtk-signal-connect directories 'select-row + (lambda (list row column event dialog) + (let ((dir (expand-file-name + (gtk-clist-get-text + (get dialog 'x-file-dialog-directory-list) + row column) + (get dialog 'x-file-dialog-current-dir)))) + (if (and (misc-user-event-p event) + (event-function event)) + (gtk-file-dialog-select-directory dialog dir) + (gtk-entry-set-text + (get dialog 'x-file-dialog-entry) + dir)))) + dialog) + ) + + (if (plist-get keywords :directory nil) + ;; Directory listings only do not need the file or filters buttons. + nil + ;; File listing + (let ((list (gtk-clist-new-with-titles 1 '("Files"))) + (scrolled (gtk-scrolled-window-new nil nil))) + (gtk-container-add scrolled list) + (gtk-widget-set-usize scrolled 200 300) + (gtk-box-pack-start hbox scrolled t t 0) + + (gtk-signal-connect list 'select-row + (lambda (list row column event dialog) + (gtk-entry-set-text + (get dialog 'x-file-dialog-entry nil) + (expand-file-name + (gtk-clist-get-text list row column) + (get dialog 'x-file-dialog-current-dir nil))) + (if (and (misc-user-event-p event) + (event-function event)) + ;; Got a double or triple click event... + (gtk-button-clicked + (get dialog 'x-file-dialog-ok-button nil)))) + dialog) + + (put dialog 'x-file-dialog-files-list list)) + + ;; Filters + (if (not (plist-get keywords :filter-list nil)) + ;; Don't need to bother packing this + nil + (setq hbox (gtk-hbox-new nil 0)) + (gtk-box-pack-start vbox hbox nil nil 0) + + (let ((label nil) + (options (plist-get keywords :filter-list nil)) + (omenu nil) + (menu nil) + (item nil)) + (setq omenu (gtk-option-menu-new) + menu (gtk-menu-new) + label (gtk-label-new "Filter: ")) + + (put dialog 'x-file-dialog-active-filter (cdr (car options))) + (mapc (lambda (o) + (setq item (gtk-menu-item-new-with-label (car o))) + (gtk-signal-connect item 'activate + (lambda (obj data) + (put (car data) 'x-file-dialog-active-filter (cdr data)) + (gtk-file-dialog-fill-file-list (car data) nil)) + (cons dialog (cdr o))) + (gtk-menu-append menu item) + (gtk-widget-show item)) options) + (gtk-option-menu-set-menu omenu menu) + (gtk-box-pack-end hbox omenu nil nil 0) + (gtk-box-pack-end hbox label nil nil 0)))) + + ;; Entry + (let ((entry (gtk-entry-new))) + (if (plist-get keywords :directory nil) + nil + (gtk-box-pack-start vbox entry nil nil 0)) + (if (plist-get keywords :file-must-exist nil) + (progn + (gtk-widget-set-sensitive (get dialog 'x-file-dialog-ok-button nil) nil) + (gtk-signal-connect entry 'changed + (lambda (entry dialog) + (gtk-widget-set-sensitive + (get dialog 'x-file-dialog-ok-button) + (file-exists-p (gtk-entry-get-text entry)))) + dialog))) + (put dialog 'x-file-dialog-entry entry)) + + (gtk-widget-realize dialog) + + + ;; Populate the file list if necessary + (gtk-file-dialog-select-directory dialog dir) + dialog)) + +(provide 'gtk-file-dialog) diff --git a/lisp/gtk-font-menu.el b/lisp/gtk-font-menu.el new file mode 100644 index 0000000..3d15e1e --- /dev/null +++ b/lisp/gtk-font-menu.el @@ -0,0 +1,248 @@ +;; gtk-font-menu.el --- Managing menus of GTK fonts. + +;; Copyright (C) 1994 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 1997 Sun Microsystems + +;; Author: Jamie Zawinski +;; Restructured by: Jonathan Stigelman +;; Mule-ized by: Martin Buchholz +;; More restructuring for MS-Windows by Andy Piper +;; GTK-ized by: William Perry + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. +;;; Code: + +;; #### - implement these... +;; +;;; (defvar font-menu-ignore-proportional-fonts nil +;;; "*If non-nil, then the font menu will only show fixed-width fonts.") + +(require 'font-menu) + +(defvar gtk-font-menu-registry-encoding nil + "Registry and encoding to use with font menu fonts.") + +(defvar gtk-fonts-menu-junk-families + (mapconcat + #'identity + '("cursor" "glyph" "symbol" ; Obvious losers. + "\\`Ax...\\'" ; FrameMaker fonts - there are just way too + ; many of these, and there is a different + ; font family for each font face! Losers. + ; "Axcor" -> "Applix Courier Roman", + ; "Axcob" -> "Applix Courier Bold", etc. + ) + "\\|") + "A regexp matching font families which are uninteresting (e.g. cursor fonts).") + +(defun hack-font-truename (fn) + "Filter the output of `font-instance-truename' to deal with Japanese fontsets." + (if (string-match "," (font-instance-truename fn)) + (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-"))) + (flist (split-string (font-instance-truename fn) ",")) + ret) + (while flist + (if (string-equal fpnt (nth 8 (split-string (car flist) "-"))) + (progn (setq ret (car flist)) (setq flist nil)) + (setq flist (cdr flist)) + )) + ret) + (font-instance-truename fn))) + +(defvar gtk-font-regexp-ascii nil + "This is used to filter out font families that can't display ASCII text. +It must be set at run-time.") + +;;;###autoload +(defun gtk-reset-device-font-menus (device &optional debug) + "Generates the `Font', `Size', and `Weight' submenus for the Options menu. +This is run the first time that a font-menu is needed for each device. +If you don't like the lazy invocation of this function, you can add it to +`create-device-hook' and that will make the font menus respond more quickly +when they are selected for the first time. If you add fonts to your system, +or if you change your font path, you can call this to re-initialize the menus." + ;; by Stig@hackvan.com + ;; #### - this should implement a `menus-only' option, which would + ;; recalculate the menus from the cache w/o having to do list-fonts again. + (unless gtk-font-regexp-ascii + (setq gtk-font-regexp-ascii (if (featurep 'mule) + (charset-registry 'ascii) + "iso8859-1"))) + (setq gtk-font-menu-registry-encoding + (if (featurep 'mule) "*-*" "iso8859-1")) + (let ((case-fold-search t) + family size weight entry monospaced-p + dev-cache cache families sizes weights) + (dolist (name (cond ((null debug) ; debugging kludge + (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device)) + ((stringp debug) (split-string debug "\n")) + (t debug))) + (when (and (string-match gtk-font-regexp-ascii name) + (string-match gtk-font-regexp name)) + (setq weight (capitalize (match-string 1 name)) + size (string-to-int (match-string 6 name))) + (or (string-match gtk-font-regexp-foundry-and-family name) + (error "internal error")) + (setq family (capitalize (match-string 1 name))) + (or (string-match gtk-font-regexp-spacing name) + (error "internal error")) + (setq monospaced-p (string= "m" (match-string 1 name))) + (unless (string-match gtk-fonts-menu-junk-families family) + (setq entry (or (vassoc family cache) + (car (setq cache + (cons (vector family nil nil t) + cache))))) + (or (member family families) (push family families)) + (or (member weight weights) (push weight weights)) + (or (member size sizes) (push size sizes)) + (or (member weight (aref entry 1)) (push weight (aref entry 1))) + (or (member size (aref entry 2)) (push size (aref entry 2))) + (aset entry 3 (and (aref entry 3) monospaced-p))))) + ;; + ;; Hack scalable fonts. + ;; Some fonts come only in scalable versions (the only size is 0) + ;; and some fonts come in both scalable and non-scalable versions + ;; (one size is 0). If there are any scalable fonts at all, make + ;; sure that the union of all point sizes contains at least some + ;; common sizes - it's possible that some sensible sizes might end + ;; up not getting mentioned explicitly. + ;; + (if (member 0 sizes) + (let ((common '(60 80 100 120 140 160 180 240))) + (while common + (or;;(member (car common) sizes) ; not enough slack + (let ((rest sizes) + (done nil)) + (while (and (not done) rest) + (if (and (> (car common) (- (car rest) 5)) + (< (car common) (+ (car rest) 5))) + (setq done t)) + (setq rest (cdr rest))) + done) + (setq sizes (cons (car common) sizes))) + (setq common (cdr common))) + (setq sizes (delq 0 sizes)))) + + (setq families (sort families 'string-lessp) + weights (sort weights 'string-lessp) + sizes (sort sizes '<)) + + (dolist (entry cache) + (aset entry 1 (sort (aref entry 1) 'string-lessp)) + (aset entry 2 (sort (aref entry 2) '<))) + + (setq dev-cache (assq device device-fonts-cache)) + (or dev-cache + (setq dev-cache (car (push (list device) device-fonts-cache)))) + (setcdr + dev-cache + (vector + cache + (mapcar (lambda (x) + (vector x + (list 'font-menu-set-font x nil nil) + ':style 'radio ':active nil ':selected nil)) + families) + (mapcar (lambda (x) + (vector (if (/= 0 (% x 10)) + ;; works with no LISP_FLOAT_TYPE + (concat (int-to-string (/ x 10)) "." + (int-to-string (% x 10))) + (int-to-string (/ x 10))) + (list 'font-menu-set-font nil nil x) + ':style 'radio ':active nil ':selected nil)) + sizes) + (mapcar (lambda (x) + (vector x + (list 'font-menu-set-font nil x nil) + ':style 'radio ':active nil ':selected nil)) + weights))) + (cdr dev-cache))) + +;; Extract font information from a face. We examine both the +;; user-specified font name and the canonical (`true') font name. +;; These can appear to have totally different properties. +;; For examples, see the prolog above. + +;; We use the user-specified one if possible, else use the truename. +;; If the user didn't specify one (with "-dt-*-*", for example) +;; get the truename and use the possibly suboptimal data from that. +;;;###autoload +(defun* gtk-font-menu-font-data (face dcache) + (defvar gtk-font-regexp) + (defvar gtk-font-regexp-foundry-and-family) + (let* ((case-fold-search t) + (domain (if font-menu-this-frame-only-p + (selected-frame) + (selected-device))) + (name (font-instance-name (face-font-instance face domain))) + (truename (font-instance-truename + (face-font-instance face domain + (if (featurep 'mule) 'ascii)))) + family size weight entry slant) + (when (string-match gtk-font-regexp-foundry-and-family name) + (setq family (capitalize (match-string 1 name))) + (setq entry (vassoc family (aref dcache 0)))) + (when (and (null entry) + (string-match gtk-font-regexp-foundry-and-family truename)) + (setq family (capitalize (match-string 1 truename))) + (setq entry (vassoc family (aref dcache 0)))) + (when (null entry) + (return-from gtk-font-menu-font-data (make-vector 5 nil))) + + (when (string-match gtk-font-regexp name) + (setq weight (capitalize (match-string 1 name))) + (setq size (string-to-int (match-string 6 name)))) + + (when (string-match gtk-font-regexp truename) + (when (not (member weight (aref entry 1))) + (setq weight (capitalize (match-string 1 truename)))) + (when (not (member size (aref entry 2))) + (setq size (string-to-int (match-string 6 truename)))) + (setq slant (capitalize (match-string 2 truename)))) + + (vector entry family size weight slant))) + +(defun gtk-font-menu-load-font (family weight size slant resolution) + "Try to load a font with the requested properties. +The weight, slant and resolution are only hints." + (when (integerp size) (setq size (int-to-string size))) + (let (font) + (catch 'got-font + (dolist (weight (list weight "*")) + (dolist (slant + (cond ((string-equal slant "O") '("O" "I" "*")) + ((string-equal slant "I") '("I" "O" "*")) + ((string-equal slant "*") '("*")) + (t (list slant "*")))) + (dolist (resolution + (if (string-equal resolution "*-*") + (list resolution) + (list resolution "*-*"))) + (when (setq font + (make-font-instance + (concat "-*-" family "-" weight "-" slant "-*-*-*-" + size "-" resolution "-*-*-" + gtk-font-menu-registry-encoding) + nil t)) + (throw 'got-font font)))))))) + +(provide 'gtk-font-menu) + +;;; gtk-font-menu.el ends here diff --git a/lisp/gtk-glyphs.el b/lisp/gtk-glyphs.el new file mode 100644 index 0000000..cc9c501 --- /dev/null +++ b/lisp/gtk-glyphs.el @@ -0,0 +1,76 @@ +;;; gtk-glyphs.el --- Support for glyphs in Gtk + +;; Copyright (C) 1994, 1997 Free Software Foundation, Inc. + +;; Author: Kirill M. Katsnelson +;; Maintainer: XEmacs Development Team +;; Keywords: extensions, internal, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file contains temporary definitions for 'gtk glyphs. +;; Since there currently is no image support, the glyps are defined +;; TTY-style. This file has to be removed or reworked completely +;; when we have images. + +;; This file is dumped with XEmacs. + +;;; Code: + +(progn + (if (featurep 'gtk) + (set-console-type-image-conversion-list + 'gtk + `(,@(if (featurep 'xpm) '(("\\.xpm\\'" [xpm :file nil] 2))) + ("\\.xbm\\'" [xbm :file nil] 2) + ,@(if (featurep 'xpm) '(("\\`/\\* XPM \\*/" [xpm :data nil] 2))) + ,@(if (featurep 'xface) '(("\\`X-Face:" [xface :data nil] 2))) + ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2) + ("\\`GIF8[79]" [gif :data nil] 2))) + ,@(if (featurep 'jpeg) '(("\\.jpe?g\\'" [jpeg :file nil] 2))) + ;; all of the JFIF-format JPEG's that I've seen begin with + ;; the following. I have no idea if this is standard. + ,@(if (featurep 'jpeg) '(("\\`\377\330\377\340\000\020JFIF" + [jpeg :data nil] 2))) + ,@(if (featurep 'png) '(("\\.png\\'" [png :file nil] 2))) + ,@(if (featurep 'png) '(("\\`\211PNG" [png :data nil] 2))) + ("" [autodetect :data nil] 2)))) + (cond ((featurep 'xpm) + (set-glyph-image frame-icon-glyph + (concat "../etc/" "xemacs-icon3.xpm") + 'global 'gtk) + (set-glyph-image xemacs-logo + (concat "../etc/" + (if emacs-beta-version + "xemacs-beta.xpm" + "xemacs.xpm")) + 'global 'gtk)) + (t + (set-glyph-image xemacs-logo + "XEmacs " + 'global 'gtk))) + (set-glyph-image octal-escape-glyph "\\") + (set-glyph-image control-arrow-glyph "^") + (set-glyph-image invisible-text-glyph " ...") + ) + +;;; gtk-glyphs.el ends here diff --git a/lisp/gtk-init.el b/lisp/gtk-init.el new file mode 100644 index 0000000..9fc1dea --- /dev/null +++ b/lisp/gtk-init.el @@ -0,0 +1,332 @@ +;;; gtk-init.el --- initialization code for mswindows +;; Copyright (C) 1990, 1993, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1995 Board of Trustees, University of Illinois. +;; Copyright (C) 1995, 1996 Ben Wing. + +;; Author: various +;; Rewritten for Gtk by: William Perry + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +(defvar gtk-win-initted nil) +(defvar gtk-pre-win-initted nil) +(defvar gtk-post-win-initted nil) + +(defvar gtk-command-switch-alist + '( + ;; GNOME Options + ("--disable-sound" . nil) + ("--enable-sound" . nil) + ("--espeaker" . t) + + ;; GTK Options + ("--gdk-debug" . t) + ("--gdk-no-debug" . t) + ("--display" . t) + ("--sync" . nil) + ("--no-xshm" . nil) + ("--name" . t) + ("--class" . t) + ("--gxid_host" . t) + ("--gxid_port" . t) + ("--xim-preedit" . t) + ("--xim-status" . t) + ("--gtk-debug" . t) + ("--gtk-no-debug" . t) + ("--gtk-module" . t) + + ;; Glib options + ("--g-fatal-warnings" . nil) + + ;; Session management options + ("--sm-client-id" . t) + ("--sm-config-prefix" . t) + ("--sm-disable" . t) + ) + + "An assoc list of command line arguments that should in gtk-initial-argv-list. +This is necessary because GTK and GNOME consider it a fatal error if they receive +unknown command line arguments (perfectly reasonable). But this means that if +the user specifies a file name on the command line they will be unable to start. +So we filter the command line and allow only items in this list in. + +The CDR of the assoc list is whether it accepts an argument. All options are in +GNU long form though.") + +(defun init-pre-gtk-win () + "Initialize Gtk GUI at startup (pre). Don't call this." + (when (not gtk-pre-win-initted) + (setq initial-frame-plist (if initial-frame-unmapped-p + '(initially-unmapped t) + nil) + gtk-pre-win-initted t))) + +(defun gtk-init-handle-geometry (arg) + "Set up initial geometry info for GTK devices." + (setq gtk-initial-geometry (pop command-line-args-left))) + +(defun gtk-filter-arguments () + (let ((accepted nil) + (rejected nil) + (todo nil)) + (setq todo (mapcar (lambda (argdesc) + (if (cdr argdesc) + ;; Need to look for --foo=bar + (concat "^" (car argdesc) "=") + ;; Just a simple arg + (concat "^" (regexp-quote (car argdesc)) "$"))) + gtk-command-switch-alist)) + + (while command-line-args-left + (if (catch 'found + (mapc (lambda (r) + (if (string-match r (car command-line-args-left)) + (throw 'found t))) todo) + (mapc (lambda (argdesc) + (if (cdr argdesc) + ;; This time we only care about argument items + ;; that take an argument. We'll check to see if + ;; someone used --foo bar instead of --foo=bar + (if (string-match (concat "^" (car argdesc) "$") (car command-line-args-left)) + ;; Yup! Need to push + (progn + (push (pop command-line-args-left) accepted) + (throw 'found t))))) + gtk-command-switch-alist) + nil) + (push (pop command-line-args-left) accepted) + (push (pop command-line-args-left) rejected))) + (setq command-line-args-left (nreverse rejected)) + (nreverse accepted))) + +(defun init-gtk-win () + "Initialize Gtk GUI at startup. Don't call this." + (unless gtk-win-initted + (init-pre-gtk-win) + (setq gtk-initial-argv-list (cons (car command-line-args) (gtk-filter-arguments)) + gtk-initial-geometry (nth 1 (member "-geometry" command-line-args-left))) + (make-gtk-device) + (init-post-gtk-win) + (setq gtk-win-initted t))) + +(defun init-post-gtk-win () + (unless gtk-post-win-initted + (if (and (not (featurep 'infodock)) (featurep 'toolbar)) + (init-x-toolbar)) + (if (and (featurep 'infodock) (featurep 'toolbar)) + (require 'id-x-toolbar)) + + (when (featurep 'mule) + (define-specifier-tag 'mule-fonts + (lambda (device) (eq 'gtk (device-type device)))) + (set-face-font + 'default + '("-*-fixed-medium-r-*--16-*-iso8859-1" + "-*-fixed-medium-r-*--*-iso8859-1" + "-*-fixed-medium-r-*--*-iso8859-2" + "-*-fixed-medium-r-*--*-iso8859-3" + "-*-fixed-medium-r-*--*-iso8859-4" + "-*-fixed-medium-r-*--*-iso8859-7" + "-*-fixed-medium-r-*--*-iso8859-8" + "-*-fixed-medium-r-*--*-iso8859-5" + "-*-fixed-medium-r-*--*-iso8859-9" + + ;; Following 3 fonts proposed by Teruhiko.Kurosaka@Japan.eng.sun + "-sun-gothic-medium-r-normal--14-120-75-75-c-60-jisx0201.1976-0" + "-sun-gothic-medium-r-normal--14-120-75-75-c-120-jisx0208.1983-0" + "-wadalab-gothic-medium-r-normal--14-120-75-75-c-120-jisx0212.1990-0" + ;; Other Japanese fonts + "-*-fixed-medium-r-*--*-jisx0201.1976-*" + "-*-fixed-medium-r-*--*-jisx0208.1983-*" + "-*-fixed-medium-r-*--*-jisx0212*-*" + + ;; Chinese fonts + "-*-*-medium-r-*--*-gb2312.1980-*" + + ;; Use One font specification for CNS chinese + ;; Too many variations in font naming + "-*-fixed-medium-r-*--*-cns11643*-*" + ;; "-*-fixed-medium-r-*--*-cns11643*2" + ;; "-*-fixed-medium-r-*--*-cns11643*3" + ;; "-*-fixed-medium-r-*--*-cns11643*4" + ;; "-*-fixed-medium-r-*--*-cns11643.5-0" + ;; "-*-fixed-medium-r-*--*-cns11643.6-0" + ;; "-*-fixed-medium-r-*--*-cns11643.7-0" + + "-*-fixed-medium-r-*--*-big5*-*" + "-*-fixed-medium-r-*--*-sisheng_cwnn-0" + + ;; Other fonts + + ;; "-*-fixed-medium-r-*--*-viscii1.1-1" + + ;; "-*-fixed-medium-r-*--*-mulearabic-0" + ;; "-*-fixed-medium-r-*--*-mulearabic-1" + ;; "-*-fixed-medium-r-*--*-mulearabic-2" + + ;; "-*-fixed-medium-r-*--*-muleipa-1" + ;; "-*-fixed-medium-r-*--*-ethio-*" + + "-*-mincho-medium-r-*--*-ksc5601.1987-*" ; Korean + "-*-fixed-medium-r-*--*-tis620.2529-1" ; Thai + ) + 'global '(mule-fonts) 'append)) + + (add-hook 'zmacs-deactivate-region-hook + (lambda () + (if (console-on-window-system-p) + (disown-selection)))) + (add-hook 'zmacs-activate-region-hook + (lambda () + (if (console-on-window-system-p) + (activate-region-as-selection)))) + (add-hook 'zmacs-update-region-hook + (lambda () + (if (console-on-window-system-p) + (activate-region-as-selection)))) + + (define-key global-map 'menu 'popup-mode-menu) + (setq gtk-post-win-initted t))) + +(push '("-geometry" . gtk-init-handle-geometry) command-switch-alist) + +;;; Stuff to get compose keys working on GTK +(eval-when-compile + (defmacro gtk-define-dead-key (key map) + `(when (gtk-keysym-on-keyboard-p ',key) + (define-key function-key-map [,key] ',map)))) + +(defun gtk-initialize-compose () + "Enable compose processing" + (autoload 'compose-map "gtk-compose" nil t 'keymap) + (autoload 'compose-acute-map "gtk-compose" nil t 'keymap) + (autoload 'compose-grave-map "gtk-compose" nil t 'keymap) + (autoload 'compose-cedilla-map "gtk-compose" nil t 'keymap) + (autoload 'compose-diaeresis-map "gtk-compose" nil t 'keymap) + (autoload 'compose-circumflex-map "gtk-compose" nil t 'keymap) + (autoload 'compose-tilde-map "gtk-compose" nil t 'keymap) + + (when (gtk-keysym-on-keyboard-p 'multi-key) + (define-key function-key-map [multi-key] 'compose-map)) + + ;; The dead keys might really be called just about anything, depending + ;; on the vendor. MIT thinks that the prefixes are "SunFA_", "D", and + ;; "hpmute_" for Sun, DEC, and HP respectively. However, OpenWindows 3 + ;; thinks that the prefixes are "SunXK_FA_", "DXK_", and "hpXK_mute_". + ;; And HP (who don't mention Sun and DEC at all) use "XK_mute_". + ;; Go figure. + + ;; Presumably if someone is running OpenWindows, they won't be using + ;; the DEC or HP keysyms, but if they are defined then that is possible, + ;; so in that case we accept them all. + + ;; If things seem not to be working, you might want to check your + ;; /usr/lib/X11/XKeysymDB file to see if your vendor has an equally + ;; mixed up view of what these keys should be called. + + ;; Canonical names: + (gtk-define-dead-key acute compose-acute-map) + (gtk-define-dead-key grave compose-grave-map) + (gtk-define-dead-key cedilla compose-cedilla-map) + (gtk-define-dead-key diaeresis compose-diaeresis-map) + (gtk-define-dead-key circumflex compose-circumflex-map) + (gtk-define-dead-key tilde compose-tilde-map) + (gtk-define-dead-key degree compose-ring-map) + + ;; Sun according to MIT: + (gtk-define-dead-key SunFA_Acute compose-acute-map) + (gtk-define-dead-key SunFA_Grave compose-grave-map) + (gtk-define-dead-key SunFA_Cedilla compose-cedilla-map) + (gtk-define-dead-key SunFA_Diaeresis compose-diaeresis-map) + (gtk-define-dead-key SunFA_Circum compose-circumflex-map) + (gtk-define-dead-key SunFA_Tilde compose-tilde-map) + + ;; Sun according to OpenWindows 2: + (gtk-define-dead-key Dead_Grave compose-grave-map) + (gtk-define-dead-key Dead_Circum compose-circumflex-map) + (gtk-define-dead-key Dead_Tilde compose-tilde-map) + + ;; Sun according to OpenWindows 3: + (gtk-define-dead-key SunXK_FA_Acute compose-acute-map) + (gtk-define-dead-key SunXK_FA_Grave compose-grave-map) + (gtk-define-dead-key SunXK_FA_Cedilla compose-cedilla-map) + (gtk-define-dead-key SunXK_FA_Diaeresis compose-diaeresis-map) + (gtk-define-dead-key SunXK_FA_Circum compose-circumflex-map) + (gtk-define-dead-key SunXK_FA_Tilde compose-tilde-map) + + ;; DEC according to MIT: + (gtk-define-dead-key Dacute_accent compose-acute-map) + (gtk-define-dead-key Dgrave_accent compose-grave-map) + (gtk-define-dead-key Dcedilla_accent compose-cedilla-map) + (gtk-define-dead-key Dcircumflex_accent compose-circumflex-map) + (gtk-define-dead-key Dtilde compose-tilde-map) + (gtk-define-dead-key Dring_accent compose-ring-map) + + ;; DEC according to OpenWindows 3: + (gtk-define-dead-key DXK_acute_accent compose-acute-map) + (gtk-define-dead-key DXK_grave_accent compose-grave-map) + (gtk-define-dead-key DXK_cedilla_accent compose-cedilla-map) + (gtk-define-dead-key DXK_circumflex_accent compose-circumflex-map) + (gtk-define-dead-key DXK_tilde compose-tilde-map) + (gtk-define-dead-key DXK_ring_accent compose-ring-map) + + ;; HP according to MIT: + (gtk-define-dead-key hpmute_acute compose-acute-map) + (gtk-define-dead-key hpmute_grave compose-grave-map) + (gtk-define-dead-key hpmute_diaeresis compose-diaeresis-map) + (gtk-define-dead-key hpmute_asciicircum compose-circumflex-map) + (gtk-define-dead-key hpmute_asciitilde compose-tilde-map) + + ;; Empirically discovered on Linux XFree86 MetroX: + (gtk-define-dead-key usldead_acute compose-acute-map) + (gtk-define-dead-key usldead_grave compose-grave-map) + (gtk-define-dead-key usldead_diaeresis compose-diaeresis-map) + (gtk-define-dead-key usldead_asciicircum compose-circumflex-map) + (gtk-define-dead-key usldead_asciitilde compose-tilde-map) + + ;; HP according to OpenWindows 3: + (gtk-define-dead-key hpXK_mute_acute compose-acute-map) + (gtk-define-dead-key hpXK_mute_grave compose-grave-map) + (gtk-define-dead-key hpXK_mute_diaeresis compose-diaeresis-map) + (gtk-define-dead-key hpXK_mute_asciicircum compose-circumflex-map) + (gtk-define-dead-key hpXK_mute_asciitilde compose-tilde-map) + + ;; HP according to HP-UX 8.0: + (gtk-define-dead-key XK_mute_acute compose-acute-map) + (gtk-define-dead-key XK_mute_grave compose-grave-map) + (gtk-define-dead-key XK_mute_diaeresis compose-diaeresis-map) + (gtk-define-dead-key XK_mute_asciicircum compose-circumflex-map) + (gtk-define-dead-key XK_mute_asciitilde compose-tilde-map) + + ;; Xfree86 seems to use lower case and a hyphen + (gtk-define-dead-key dead-acute compose-acute-map) + (gtk-define-dead-key dead-grave compose-grave-map) + (gtk-define-dead-key dead-cedilla compose-cedilla-map) + (gtk-define-dead-key dead-diaeresis compose-diaeresis-map) + (gtk-define-dead-key dead-circum compose-circumflex-map) + (gtk-define-dead-key dead-circumflex compose-circumflex-map) + (gtk-define-dead-key dead-tilde compose-tilde-map) + ) + +(when (featurep 'gtk) + (add-hook + 'create-console-hook + (lambda (console) + (letf (((selected-console) console)) + (when (eq 'gtk (console-type console)) + (gtk-initialize-compose)))))) diff --git a/lisp/gtk-iso8859-1.el b/lisp/gtk-iso8859-1.el new file mode 100644 index 0000000..4e3190b --- /dev/null +++ b/lisp/gtk-iso8859-1.el @@ -0,0 +1,5 @@ +;; We can just cheat and use the same code that X does. + +(setq character-set-property 'x-iso8859/1) ; see x-iso8859-1.el +(require 'x-iso8859-1) +(provide 'gtk-iso8859-1) diff --git a/lisp/gtk-marshal.el b/lisp/gtk-marshal.el new file mode 100644 index 0000000..2a1a81e --- /dev/null +++ b/lisp/gtk-marshal.el @@ -0,0 +1,289 @@ +(defconst name-to-return-type + '(("INT" . "guint") + ("CALLBACK" . "GtkCallback") + ("OBJECT" . "GtkObject *") + ("POINTER" . "void *") + ("STRING" . "gchar *") + ("BOOL" . "gboolean") + ("DOUBLE" . "gdouble") + ("FLOAT" . "gfloat") + ("LIST" . "void *") + ("NONE" . nil))) + +(defvar defined-marshallers nil) + +(defun get-marshaller-name (rval args) + (concat "emacs_gtk_marshal_" rval "__" + (mapconcat 'identity (or args '("NONE")) "_"))) + +(defun define-marshaller (rval &rest args) + (let ((name nil) + (internal-rval (assoc rval name-to-return-type)) + (ctr 0) + (func-proto (format "__%s_fn" rval))) + (if (not internal-rval) + (error "Do not know return type of `%s'" rval)) + (setq name (get-marshaller-name rval args)) + + (if (member name defined-marshallers) + (error "Attempe to define the same marshaller more than once! %s" name)) + + (set-buffer (get-buffer-create "emacs-marshals.c")) + (goto-char (point-max)) + + (if (or (member "FLOAT" args) (member "DOUBLE" args)) + ;; We need to special case anything with FLOAT in the argument + ;; list or the parameters get screwed up royally. + (progn + (setq func-proto (concat (format "__%s__" rval) + (mapconcat 'identity args "_") + "_fn")) + (insert "typedef " + (or (cdr internal-rval) "void") + " (*" + func-proto ")(" + (mapconcat (lambda (x) + (cdr (assoc x name-to-return-type))) args ", ") + ");\n"))) + + (insert "\n" + "static void\n" + name " (ffi_actual_function func, GtkArg *args)\n" + "{\n" + (format " %s rfunc = (%s) func;\n" func-proto func-proto)) + + (if (string= "LIST" rval) (setq rval "POINTER")) + + (if (cdr internal-rval) + ;; It has a return type to worry about + (insert " " (cdr internal-rval) " *return_val;\n\n" + (format " return_val = GTK_RETLOC_%s (args[%d]);\n" rval (length args)) + " *return_val = ") + (insert " ")) + (insert "(*rfunc) (") + (while args + (if (/= ctr 0) + (insert ", ")) + (insert (format "GTK_VALUE_%s (args[%d])" (car args) ctr)) + (setq args (cdr args) + ctr (1+ ctr))) + (insert ");\n") + (insert "}\n"))) + +(save-excursion + (find-file "../../src/emacs-marshals.c") + (erase-buffer) + (setq defined-marshallers nil) + + (insert "#define GTK_VALUE_ARRAY(x) GTK_VALUE_POINTER(x)\n\n") + (insert "#define GTK_VALUE_LIST(x) GTK_VALUE_POINTER(x)\n\n") + + (let ((todo '( + ("BOOL" "OBJECT" "INT") + ("BOOL" "OBJECT" "OBJECT" "OBJECT") + ("BOOL" "OBJECT" "OBJECT") + ("BOOL" "OBJECT" "POINTER") + ("BOOL" "OBJECT" "STRING") + ("BOOL" "OBJECT") + ("BOOL" "POINTER" "BOOL") + ("BOOL" "POINTER") + ("BOOL") + ("FLOAT" "OBJECT" "FLOAT") + ("FLOAT" "OBJECT") + ("INT" "BOOL") + ("INT" "OBJECT" "ARRAY") + ("INT" "OBJECT" "INT" "ARRAY") + ("INT" "OBJECT" "INT" "INT") + ("INT" "OBJECT" "INT" "STRING") + ("INT" "OBJECT" "INT") + ("INT" "OBJECT" "OBJECT") + ("INT" "OBJECT" "POINTER" "INT" "INT") + ("INT" "OBJECT" "POINTER" "INT") + ("INT" "OBJECT" "POINTER") + ("INT" "OBJECT" "STRING") + ("INT" "OBJECT") + ("INT" "POINTER" "INT") + ("INT" "POINTER" "STRING" "INT") + ("INT" "POINTER" "STRING" "STRING") + ("INT" "POINTER" "STRING") + ("INT" "POINTER") + ("INT" "STRING" "STRING" "INT" "ARRAY") + ("INT" "STRING") + ("INT") + ("LIST" "OBJECT") + ("LIST") + ("NONE" "BOOL") + ("NONE" "INT" "INT" "INT" "INT") + ("NONE" "INT" "INT") + ("NONE" "INT") + ("NONE" "OBJECT" "BOOL" "INT") + ("NONE" "OBJECT" "BOOL") + ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT" "BOOL") + ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") + ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT") + ("NONE" "OBJECT" "FLOAT" "FLOAT") + ("NONE" "OBJECT" "FLOAT") + ("NONE" "OBJECT" "INT" "BOOL") + ("NONE" "OBJECT" "INT" "FLOAT" "BOOL") + ("NONE" "OBJECT" "INT" "FLOAT") + ("NONE" "OBJECT" "INT" "INT" "ARRAY" "ARRAY" "ARRAY" "ARRAY" "ARRAY" "ARRAY") + ("NONE" "OBJECT" "INT" "INT" "ARRAY") + ("NONE" "OBJECT" "INT" "INT" "FLOAT" "FLOAT") + ("NONE" "OBJECT" "INT" "INT" "INT" "INT") + ("NONE" "OBJECT" "INT" "INT" "INT") + ("NONE" "OBJECT" "INT" "INT" "POINTER" "POINTER") + ("NONE" "OBJECT" "INT" "INT" "POINTER") + ("NONE" "OBJECT" "INT" "INT" "STRING" "INT" "POINTER" "POINTER") + ("NONE" "OBJECT" "INT" "INT" "STRING") + ("NONE" "OBJECT" "INT" "INT") + ("NONE" "OBJECT" "INT" "OBJECT") + ("NONE" "OBJECT" "INT" "POINTER") + ("NONE" "OBJECT" "INT" "STRING") + ("NONE" "OBJECT" "INT") + ("NONE" "OBJECT" "LIST" "INT") + ("NONE" "OBJECT" "LIST") + ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL" "INT" "INT") + ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL" "INT") + ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL") + ("NONE" "OBJECT" "OBJECT" "FLOAT" "INT") + ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT" "INT" "INT" "INT" "INT" "INT") + ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT" "INT") + ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT") + ("NONE" "OBJECT" "OBJECT" "INT" "INT") + ("NONE" "OBJECT" "OBJECT" "INT") + ("NONE" "OBJECT" "OBJECT" "OBJECT" "INT") + ("NONE" "OBJECT" "OBJECT" "OBJECT" "OBJECT" "INT") + ("NONE" "OBJECT" "OBJECT" "OBJECT" "OBJECT") + ("NONE" "OBJECT" "OBJECT" "OBJECT" "POINTER" "POINTER" "INT" "INT") + ("NONE" "OBJECT" "OBJECT" "OBJECT") + ("NONE" "OBJECT" "OBJECT" "POINTER") + ("NONE" "OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT" "INT") + ("NONE" "OBJECT" "OBJECT" "STRING" "STRING" "INT") + ("NONE" "OBJECT" "OBJECT" "STRING" "STRING") + ("NONE" "OBJECT" "OBJECT" "STRING") + ("NONE" "OBJECT" "OBJECT") + ("NONE" "OBJECT" "POINTER" "BOOL") + ("NONE" "OBJECT" "POINTER" "INT" "FLOAT" "FLOAT") + ("NONE" "OBJECT" "POINTER" "INT" "INT" "INT") + ("NONE" "OBJECT" "POINTER" "INT" "INT") + ("NONE" "OBJECT" "POINTER" "INT" "POINTER" "POINTER") + ("NONE" "OBJECT" "POINTER" "INT" "POINTER") + ("NONE" "OBJECT" "POINTER" "INT" "STRING" "INT" "POINTER" "POINTER") + ("NONE" "OBJECT" "POINTER" "INT" "STRING") + ("NONE" "OBJECT" "POINTER" "INT") + ("NONE" "OBJECT" "POINTER" "POINTER" "INT" "INT" "INT" "INT" "INT" "INT") + ("NONE" "OBJECT" "POINTER" "POINTER" "POINTER" "STRING" "INT") + ("NONE" "OBJECT" "POINTER" "POINTER" "POINTER") + ("NONE" "OBJECT" "POINTER" "POINTER") + ("NONE" "OBJECT" "POINTER" "STRING" "INT" "POINTER" "POINTER" "POINTER" "POINTER" "BOOL" "BOOL") + ("NONE" "OBJECT" "POINTER") + ("NONE" "OBJECT" "STRING" "BOOL") + ("NONE" "OBJECT" "STRING" "INT" "INT" "INT") + ("NONE" "OBJECT" "STRING" "POINTER" "INT" "INT" "INT") + ("NONE" "OBJECT" "STRING" "POINTER" "INT" "INT") + ("NONE" "OBJECT" "STRING" "STRING") + ("NONE" "OBJECT" "STRING") + ("NONE" "OBJECT") + ("NONE" "POINTER" "INT") + ("NONE" "POINTER" "INT" "INT") + ("NONE" "POINTER" "POINTER" "BOOL" "INT" "INT" "INT" "INT" "INT" "INT") + ("NONE" "POINTER" "POINTER" "BOOL" "INT" "INT" "INT" "INT") + ("NONE" "POINTER" "POINTER" "INT" "INT" "INT" "INT") + ("NONE" "POINTER" "POINTER" "INT" "INT") + ("NONE" "POINTER" "POINTER" "POINTER" "INT" "INT" "STRING" "INT") + ("NONE" "POINTER" "POINTER" "POINTER" "INT" "INT" "STRING") + ("NONE" "POINTER" "POINTER" "POINTER" "POINTER") + ("NONE" "POINTER" "POINTER") + ("NONE" "POINTER" "STRING" "STRING") + ("NONE" "POINTER" "STRING") + ("NONE" "POINTER") + ("NONE") + ("OBJECT" "BOOL" "BOOL" "INT") + ("OBJECT" "BOOL" "INT") + ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") + ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") + ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") + ("OBJECT" "INT" "ARRAY") + ("OBJECT" "INT" "BOOL" "BOOL") + ("OBJECT" "INT" "INT" "ARRAY") + ("OBJECT" "INT" "INT" "BOOL") + ("OBJECT" "INT" "INT" "STRING") + ("OBJECT" "INT" "INT") + ("OBJECT" "INT") + ("OBJECT" "OBJECT" "FLOAT" "INT") + ("OBJECT" "OBJECT" "INT") + ("OBJECT" "OBJECT" "OBJECT") + ("OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT" "INT") + ("OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT") + ("OBJECT" "OBJECT" "STRING" "INT" "INT") + ("OBJECT" "OBJECT" "STRING") + ("OBJECT" "OBJECT") + ("OBJECT" "POINTER" "POINTER") + ("OBJECT" "POINTER" "STRING") + ("OBJECT" "POINTER") + ("OBJECT" "STRING" "FLOAT" "FLOAT" "FLOAT" "BOOL") + ("OBJECT" "STRING" "INT" "STRING" "STRING") + ("OBJECT" "STRING" "OBJECT") + ("OBJECT" "STRING" "STRING" "STRING" "ARRAY" "STRING" "STRING") + ("OBJECT" "STRING" "STRING") + ("OBJECT" "STRING") + ("OBJECT") + ("POINTER" "INT" "INT") + ("POINTER" "INT") + ("POINTER" "OBJECT" "INT" "INT") + ("POINTER" "OBJECT" "INT") + ("POINTER" "OBJECT" "POINTER" "INT") + ("POINTER" "OBJECT" "POINTER" "POINTER" "ARRAY" "INT" "POINTER" "POINTER" "POINTER" "POINTER" "BOOL" "BOOL") + ("POINTER" "OBJECT" "POINTER") + ("POINTER" "OBJECT") + ("POINTER" "POINTER") + ("POINTER") + ("STRING" "INT" "INT" "INT") + ("STRING" "INT") + ("STRING" "OBJECT" "BOOL") + ("STRING" "OBJECT" "FLOAT") + ("STRING" "OBJECT" "INT" "INT") + ("STRING" "OBJECT" "INT") + ("STRING" "OBJECT") + ("STRING" "POINTER" "STRING") + ("STRING" "POINTER") + ("STRING") + ) + ) + ) + (mapc (lambda (x) (apply 'define-marshaller x)) todo) + + (insert "\n +#include \"hash.h\" +static c_hashtable marshaller_hashtable; + +static void initialize_marshaller_storage (void) +{ + if (!marshaller_hashtable) + { + marshaller_hashtable = make_strings_hashtable (100); +") + + (mapc (lambda (x) + (let ((name (get-marshaller-name (car x) (cdr x)))) + (insert (format "\t\tputhash (\"%s\", (void *) %s, marshaller_hashtable);\n" name name)))) + todo) + (insert "\t};\n" + "}\n" + " +static void *find_marshaller (const char *func_name) +{ + void *fn = NULL; + initialize_marshaller_storage (); + + if (gethash (func_name, marshaller_hashtable, (CONST void **)&fn)) + { + return (fn); + } + + return (NULL); +} +")) + + (save-buffer) + (kill-buffer "emacs-marshals.c")) diff --git a/lisp/gtk-mouse.el b/lisp/gtk-mouse.el new file mode 100644 index 0000000..61eca21 --- /dev/null +++ b/lisp/gtk-mouse.el @@ -0,0 +1,72 @@ +;;; gtk-mouse.el --- Mouse support for GTK window system. + +;; Copyright (C) 1985, 1992-4, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996 Ben Wing. +;; Copyright (C) 2000 William Perry + +;; Maintainer: XEmacs Development Team +;; Keywords: mouse, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not synched. + +;;; Commentary: + +;; This file is dumped with XEmacs (when GTK support is compiled in). + +;;; Code: + +(defvar gtk-pointers-initialized nil) + +(defun gtk-init-pointers () + (if gtk-pointers-initialized + nil + (set-glyph-image text-pointer-glyph + [gtk-resource :resource-type cursor :resource-id xterm] + 'gtk) + (set-glyph-image nontext-pointer-glyph + [gtk-resource :resource-type cursor :resource-id xterm] + 'gtk) + (set-glyph-image selection-pointer-glyph + [gtk-resource :resource-type cursor :resource-id top-left-arrow] + 'gtk) + (set-glyph-image modeline-pointer-glyph + [gtk-resource :resource-type cursor :resource-id sb-v-double-arrow] + 'gtk) + (set-glyph-image divider-pointer-glyph + [gtk-resource :resource-type cursor :resource-id sb-h-double-arrow] + 'gtk) + (set-glyph-image busy-pointer-glyph + [gtk-resource :resource-type cursor :resource-id watch] + 'gtk) + (set-glyph-image gc-pointer-glyph + [gtk-resource :resource-type cursor :resource-id watch] + 'gtk) + + (when (featurep 'toolbar) + (set-glyph-image toolbar-pointer-glyph + [gtk-resource :resource-type cursor :resource-id top-left-arrow] + 'gtk)) + + (when (featurep 'scrollbar) + (set-glyph-image scrollbar-pointer-glyph + [gtk-resource :resource-type cursor :resource-id top-left-arrow] + 'gtk)) + + (setq gtk-pointers-initialized t))) diff --git a/lisp/gtk-package.el b/lisp/gtk-package.el new file mode 100644 index 0000000..1da2db9 --- /dev/null +++ b/lisp/gtk-package.el @@ -0,0 +1,10 @@ +;; A GTK version of package-ui.el + +(require 'package-get) +(require 'package-ui) + +(defun package-gtk-edit-sites () + (let ((window (gtk-window-new 'toplevel)) + (box (gtk-hbox-new nil 5))) + (gtk-container-add window box) + (gtk-widget-show-all window))) diff --git a/lisp/gtk-password-dialog.el b/lisp/gtk-password-dialog.el new file mode 100644 index 0000000..c503495 --- /dev/null +++ b/lisp/gtk-password-dialog.el @@ -0,0 +1,122 @@ +;;; gtk-password-dialog.el --- Reading passwords in a dialog + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Maintainer: William M. Perry +;; Keywords: extensions, internal + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +(defun gtk-password-dialog-ok-button (dlg) + (get dlg 'x-ok-button)) + +(defun gtk-password-dialog-cancel-button (dlg) + (get dlg 'x-cancel-button)) + +(defun gtk-password-dialog-entry-widget (dlg) + (get dlg 'x-initial-entry)) + +(defun gtk-password-dialog-confirmation-widget (dlg) + (get dlg 'x-verify-entry)) + +(defun gtk-password-dialog-new (&rest keywords) + ;; Format is (:keyword value ...) + ;; Allowed keywords are: + ;; + ;; :callback function + ;; :default string + ;; :title string + :; :prompt string + ;; :default string + ;; :verify boolean + ;; :verify-prompt string + (let* ((callback (plist-get keywords :callback 'ignore)) + (dialog (gtk-dialog-new)) + (vbox (gtk-dialog-vbox dialog)) + (button-area (gtk-dialog-action-area dialog)) + (default (plist-get keywords :default)) + (widget nil)) + (gtk-window-set-title dialog (plist-get keywords :title "Enter password...")) + + ;; Make us modal... + (put dialog 'type 'dialog) + + ;; Put the buttons in the bottom + (setq widget (gtk-button-new-with-label "OK")) + (gtk-container-add button-area widget) + (gtk-signal-connect widget 'clicked + (lambda (button data) + (funcall (car data) + (gtk-entry-get-text + (get (cdr data) 'x-initial-entry)))) + (cons callback dialog)) + (put dialog 'x-ok-button widget) + + (setq widget (gtk-button-new-with-label "Cancel")) + (gtk-container-add button-area widget) + (gtk-signal-connect widget 'clicked + (lambda (button dialog) + (gtk-widget-destroy dialog)) + dialog) + (put dialog 'x-cancel-button widget) + + ;; Now the entry area... + (gtk-container-set-border-width vbox 5) + (setq widget (gtk-label-new (plist-get keywords :prompt "Password:"))) + (gtk-misc-set-alignment widget 0.0 0.5) + (gtk-container-add vbox widget) + + (setq widget (gtk-entry-new)) + (put widget 'visibility nil) + (gtk-container-add vbox widget) + (put dialog 'x-initial-entry widget) + + (if (plist-get keywords :verify) + (let ((changed-cb (lambda (editable dialog) + (gtk-widget-set-sensitive + (get dialog 'x-ok-button) + (equal (gtk-entry-get-text + (get dialog 'x-initial-entry)) + (gtk-entry-get-text + (get dialog 'x-verify-entry))))))) + (gtk-container-set-border-width vbox 5) + (setq widget (gtk-label-new (plist-get keywords :verify-prompt "Verify:"))) + (gtk-misc-set-alignment widget 0.0 0.5) + (gtk-container-add vbox widget) + + (setq widget (gtk-entry-new)) + (put widget 'visibility nil) + (gtk-container-add vbox widget) + (put dialog 'x-verify-entry widget) + + (gtk-signal-connect (get dialog 'x-initial-entry) + 'changed changed-cb dialog) + (gtk-signal-connect (get dialog 'x-verify-entry) + 'changed changed-cb dialog) + (gtk-widget-set-sensitive (get dialog 'x-ok-button) nil))) + + (if default + (progn + (gtk-entry-set-text (get dialog 'x-initial-entry) default) + (gtk-entry-select-region (get dialog 'x-initial-entry) + 0 (length default)))) + dialog)) + +(provide 'gtk-password-dialog) diff --git a/lisp/gtk-select.el b/lisp/gtk-select.el new file mode 100644 index 0000000..76b30df --- /dev/null +++ b/lisp/gtk-select.el @@ -0,0 +1,65 @@ +;;; gtk-select.el --- Lisp interface to GTK selections. + +;; Copyright (C) 1990, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Sun Microsystems. +;; Copyright (C) 2000 Free Software Foundation + +;; Maintainer: William Perry +;; Keywords: extensions, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; This file is dumped with XEmacs (when GTK support is compiled in). +;; #### Only copes with copying/pasting text + +;;; Code: + +(defun gtk-get-secondary-selection () + "Return text selected from some GTK window." + (get-selection 'SECONDARY)) + +(defun gtk-own-secondary-selection (selection &optional type) + "Make a secondary GTK Selection of the given argument. The argument may be a +string or a cons of two markers (in which case the selection is considered to +be the text between those markers)." + (interactive (if (not current-prefix-arg) + (list (read-string "Store text for pasting: ")) + (list (cons ;; these need not be ordered. + (copy-marker (point-marker)) + (copy-marker (mark-marker)))))) + (own-selection selection 'SECONDARY)) + +(defun gtk-notice-selection-requests (selection type successful) + "for possible use as the value of `gtk-sent-selection-hooks'." + (if (not successful) + (message "Selection request failed to convert %s to %s" + selection type) + (message "Sent selection %s as %s" selection type))) + +(defun gtk-notice-selection-failures (selection type successful) + "for possible use as the value of `gtk-sent-selection-hooks'." + (or successful + (message "Selection request failed to convert %s to %s" + selection type))) + +;(setq gtk-sent-selection-hooks 'gtk-notice-selection-requests) +;(setq gtk-sent-selection-hooks 'gtk-notice-selection-failures) diff --git a/lisp/gtk-widget-accessors.el b/lisp/gtk-widget-accessors.el new file mode 100644 index 0000000..fd56920 --- /dev/null +++ b/lisp/gtk-widget-accessors.el @@ -0,0 +1,258 @@ +(require 'gtk-ffi) + +(defconst GTK_TYPE_INVALID 0) +(defconst GTK_TYPE_NONE 1) +(defconst GTK_TYPE_CHAR 2) +(defconst GTK_TYPE_UCHAR 3) +(defconst GTK_TYPE_BOOL 4) +(defconst GTK_TYPE_INT 5) +(defconst GTK_TYPE_UINT 6) +(defconst GTK_TYPE_LONG 7) +(defconst GTK_TYPE_ULONG 8) +(defconst GTK_TYPE_FLOAT 9) +(defconst GTK_TYPE_DOUBLE 10) +(defconst GTK_TYPE_STRING 11) +(defconst GTK_TYPE_ENUM 12) +(defconst GTK_TYPE_FLAGS 13) +(defconst GTK_TYPE_BOXED 14) +(defconst GTK_TYPE_POINTER 15) +(defconst GTK_TYPE_SIGNAL 16) +(defconst GTK_TYPE_ARGS 17) +(defconst GTK_TYPE_CALLBACK 18) +(defconst GTK_TYPE_C_CALLBACK 19) +(defconst GTK_TYPE_FOREIGN 20) +(defconst GTK_TYPE_OBJECT 21) + +(defconst gtk-value-accessor-names + '("INVALID" "NONE" "CHAR" "UCHAR" "BOOL" "INT" "UINT" "LONG" "ULONG" "FLOAT" "DOUBLE" + "STRING" "ENUM" "FLAGS" "BOXED" "POINTER" "SIGNAL" "ARGS" "CALLBACK" "C_CALLBACK" + "FOREIGN" "OBJECT")) + +(defun define-widget-accessors (gtk-class + wrapper + prefix args) + "Output stub C code to access parts of a widget from lisp. +GTK-CLASS is the GTK class to grant access to. +WRAPPER is a fragment to construct GTK C macros for typechecking/etc. (ie: WIDGET) +ARGS is a list of (type . name) cons cells. +Defines a whole slew of functions to access & set the slots in the +structure." + (set-buffer (get-buffer-create "emacs-widget-accessors.c")) + (goto-char (point-max)) + (let ((arg) + (base-arg-type nil) + (lisp-func-name nil) + (c-func-name nil) + (func-names nil)) + (setq gtk-class (symbol-name gtk-class) + wrapper (upcase wrapper)) + (while (setq arg (pop args)) + (setq lisp-func-name (format "gtk-%s-%s" prefix (cdr arg)) + lisp-func-name (replace-in-string lisp-func-name "_" "-") + c-func-name (concat "F" (replace-in-string lisp-func-name "-" "_"))) + (insert + "DEFUN (\"" lisp-func-name "\", " c-func-name ", 1, 1, 0, /*\n" + "Access the `" (symbol-name (cdr arg)) "' slot of OBJ, a " gtk-class " object.\n" + "*/\n" + "\t(obj))\n" + "{\n" + (format "\t%s *the_obj = NULL;\n" gtk-class) + "\tGtkArg arg;\n" + "\n" + "\tCHECK_GTK_OBJECT (obj);\n" + "\n" + (format "\tif (!GTK_IS_%s (XGTK_OBJECT (obj)->object))\n" wrapper) + "\t{\n" + (format "\t\tsignal_simple_error (\"Object is not a %s\", obj);\n" gtk-class) + "\t};\n" + "\n" + (format "\tthe_obj = GTK_%s (XGTK_OBJECT (obj)->object);\n" wrapper) + + (format "\targ.type = gtk_type_from_name (\"%s\");\n" (symbol-name (car arg)))) +; (format "\targ.type = GTK_TYPE_%s;\n" (or +; (nth (gtk-fundamental-type (car arg)) +; gtk-value-accessor-names) +; (case (car arg) +; (GtkListOfString "STRING_LIST") +; (GtkListOfObject "OBJECT_LIST") +; (otherwise +; "POINTER"))))) + + (setq base-arg-type (gtk-fundamental-type (car arg))) + (cond + ((= base-arg-type GTK_TYPE_OBJECT) + (insert + (format "\tGTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->%s);" + (cdr arg)))) + ((or (= base-arg-type GTK_TYPE_POINTER) + (= base-arg-type GTK_TYPE_BOXED)) + (insert + (format "\tGTK_VALUE_%s (arg) = (void *)the_obj->%s;" + (nth (gtk-fundamental-type (car arg)) gtk-value-accessor-names) + (cdr arg)))) + (t + (insert + (format "\tGTK_VALUE_%s (arg) = the_obj->%s;" + (or (nth (gtk-fundamental-type (car arg)) gtk-value-accessor-names) "POINTER") + (cdr arg))))) + (insert + "\n" + "\treturn (gtk_type_to_lisp (&arg));\n" + "}\n\n") + (push c-func-name func-names)) + func-names)) + +(defun import-widget-accessors (file syms-function-name &rest description) + "Import multiple widgets, and emit a suitable vars_of_foo() function for them.\n" + (let ((c-mode-common-hook nil) + (c-mode-hook nil)) + (find-file file)) + (erase-buffer) + (let ((c-funcs nil)) + (while description + (setq c-funcs (nconc (define-widget-accessors + (pop description) (pop description) + (pop description) (pop description)) c-funcs))) + (goto-char (point-max)) + (insert "void " syms-function-name " (void)\n" + "{\n\t" + (mapconcat (lambda (x) + (concat "DEFSUBR (" x ");")) c-funcs "\n\t") + "\n}")) + (save-buffer)) + +;; Because the new FFI layer imports GTK types lazily, we need to load +;; up all of the gtk types we know about, or we get errors about +;; unknown GTK types later on. +(mapatoms (lambda (sym) + (if (string-match "gtk-[^-]+-get-type" (symbol-name sym)) + (funcall sym)))) + +(import-widget-accessors + "../../src/emacs-widget-accessors.c" + "syms_of_widget_accessors " + + 'GtkAdjustment "ADJUSTMENT" "adjustment" + '((gfloat . lower) + (gfloat . upper) + (gfloat . value) + (gfloat . step_increment) + (gfloat . page_increment) + (gfloat . page_size)) + + 'GtkWidget "WIDGET" "widget" + '((GtkStyle . style) + (GdkWindow . window) + (GtkStateType . state) + (GtkString . name) + (GtkWidget . parent)) + + 'GtkButton "BUTTON" "button" + '((GtkWidget . child) + (gboolean . in_button) + (gboolean . button_down)) + + 'GtkCombo "COMBO" "combo" + '((GtkWidget . entry) + (GtkWidget . button) + (GtkWidget . popup) + (GtkWidget . popwin) + (GtkWidget . list)) + + 'GtkGammaCurve "GAMMA_CURVE" "gamma-curve" + '((GtkWidget . table) + (GtkWidget . curve) + (gfloat . gamma) + (GtkWidget . gamma_dialog) + (GtkWidget . gamma_text)) + + 'GtkCheckMenuItem "CHECK_MENU_ITEM" "check-menu-item" + '((gboolean . active)) + + 'GtkNotebook "NOTEBOOK" "notebook" + '((GtkPositionType . tab_pos)) + + 'GtkText "TEXT" "text" + '((GtkAdjustment . hadj) + (GtkAdjustment . vadj)) + + 'GtkFileSelection "FILE_SELECTION" "file-selection" + '((GtkWidget . dir_list) + (GtkWidget . file_list) + (GtkWidget . selection_entry) + (GtkWidget . selection_text) + (GtkWidget . main_vbox) + (GtkWidget . ok_button) + (GtkWidget . cancel_button) + (GtkWidget . help_button) + (GtkWidget . action_area)) + + 'GtkFontSelectionDialog "FONT_SELECTION_DIALOG" "font-selection-dialog" + '((GtkWidget . fontsel) + (GtkWidget . main_vbox) + (GtkWidget . action_area) + (GtkWidget . ok_button) + (GtkWidget . apply_button) + (GtkWidget . cancel_button)) + + 'GtkColorSelectionDialog "COLOR_SELECTION_DIALOG" "color-selection-dialog" + '((GtkWidget . colorsel) + (GtkWidget . main_vbox) + (GtkWidget . ok_button) + (GtkWidget . reset_button) + (GtkWidget . cancel_button) + (GtkWidget . help_button)) + + 'GtkDialog "DIALOG" "dialog" + '((GtkWidget . vbox) + (GtkWidget . action_area)) + + 'GtkInputDialog "INPUT_DIALOG" "input-dialog" + '((GtkWidget . close_button) + (GtkWidget . save_button)) + + 'GtkPlug "PLUG" "plug" + '((GdkWindow . socket_window) + (gint . same_app)) + + 'GtkObject "OBJECT" "object" + '((guint . flags) + (guint . ref_count)) + + 'GtkPaned "PANED" "paned" + '((GtkWidget . child1) + (GtkWidget . child2) + (gboolean . child1_resize) + (gboolean . child2_resize) + (gboolean . child1_shrink) + (gboolean . child2_shrink)) + + 'GtkCList "CLIST" "clist" + '((gint . rows) + (gint . columns) + (GtkAdjustment . hadjustment) + (GtkAdjustment . vadjustment) + (GtkSortType . sort_type) + (gint . focus_row) + (gint . sort_column)) + + 'GtkList "LIST" "list" + '((GtkListOfObject . children) + (GtkListOfObject . selection)) + + 'GtkTree "TREE" "tree" + '((GtkListOfObject . children) + (GtkTree . root_tree) + (GtkWidget . tree_owner) + (GtkListOfObject . selection)) + + 'GtkTreeItem "TREE_ITEM" "tree-item" + '((GtkWidget . subtree)) + + 'GtkScrolledWindow "SCROLLED_WINDOW" "scrolled-window" + '((GtkWidget . hscrollbar) + (GtkWidget . vscrollbar) + (gboolean . hscrollbar_visible) + (gboolean . vscrollbar_visible)) + + ) diff --git a/lisp/gtk-widgets.el b/lisp/gtk-widgets.el new file mode 100644 index 0000000..075594c --- /dev/null +++ b/lisp/gtk-widgets.el @@ -0,0 +1,2080 @@ +;;; gtk-widgets.el --- Import GTK functions into XEmacs + +;; Copyright (C) 2000 Free Software Foundation + +;; Maintainer: William Perry +;; Keywords: extensions, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; This file is dumped with XEmacs. + +(eval-and-compile + (require 'gtk-ffi)) + +(gtk-import-function GtkType gtk_accel_label_get_type) +(gtk-import-function GtkWidget gtk_accel_label_new GtkString) +(gtk-import-function guint gtk_accel_label_get_accel_width GtkAccelLabel) +(gtk-import-function nil gtk_accel_label_set_accel_widget GtkAccelLabel GtkWidget) +(gtk-import-function gboolean gtk_accel_label_refetch GtkAccelLabel) + + +(gtk-import-function GtkType gtk_adjustment_get_type) +(gtk-import-function GtkObject gtk_adjustment_new gfloat gfloat gfloat gfloat gfloat gfloat) +(gtk-import-function nil gtk_adjustment_changed GtkAdjustment) +(gtk-import-function nil gtk_adjustment_value_changed GtkAdjustment) +(gtk-import-function nil gtk_adjustment_clamp_page GtkAdjustment gfloat gfloat) +(gtk-import-function nil gtk_adjustment_set_value GtkAdjustment gfloat) + + +(gtk-import-function GtkType gtk_alignment_get_type) +(gtk-import-function GtkWidget gtk_alignment_new gfloat gfloat gfloat gfloat) +(gtk-import-function nil gtk_alignment_set GtkAlignment gfloat gfloat gfloat gfloat) + + +(gtk-import-function GtkType gtk_arrow_get_type) +(gtk-import-function GtkWidget gtk_arrow_new GtkArrowType GtkShadowType) +(gtk-import-function nil gtk_arrow_set GtkArrow GtkArrowType GtkShadowType) + + +(gtk-import-function GtkType gtk_aspect_frame_get_type) +(gtk-import-function GtkWidget gtk_aspect_frame_new GtkString gfloat gfloat gfloat gboolean) +(gtk-import-function nil gtk_aspect_frame_set GtkAspectFrame gfloat gfloat gfloat gboolean) + + +(gtk-import-function GtkType gtk_bin_get_type) + + +(gtk-import-function GtkType gtk_box_get_type) +(gtk-import-function nil gtk_box_pack_start + (GtkBox . box) + (GtkWidget . child) + (gboolean . expand) + (gboolean . fill) + (guint . padding)) + +(gtk-import-function nil gtk_box_pack_end + (GtkBox . box) + (GtkWidget . child) + (gboolean . expand) + (gboolean . fill) + (guint . padding)) + +(gtk-import-function nil gtk_box_pack_start_defaults + (GtkBox . box) + (GtkWidget . child)) + +(gtk-import-function nil gtk_box_pack_end_defaults + (GtkBox . box) + (GtkWidget . child)) + +(gtk-import-function nil gtk_box_set_homogeneous + (GtkBox . box) + (gboolean . homogeneous)) + +(gtk-import-function nil gtk_box_set_spacing + (GtkBox . box) + (gint . spacing)) + +(gtk-import-function nil gtk_box_reorder_child + (GtkBox . box) + (GtkWidget . child) + (gint . position)) + +;;;Handcoded in ui-byhand.c... #### FIXME +;;;void gtk_box_query_child_packing (GtkBox *box, +;;; GtkWidget *child, +;;; gboolean *expand, +;;; gboolean *fill, +;;; guint *padding, +;;; GtkPackType *pack_type); + +(gtk-import-function nil gtk_box_set_child_packing + (GtkBox . box) + (GtkWidget . child) + (gboolean . expand) + (gboolean . fill) + (guint . padding) + (GtkPackType . pack_type)) + + +(gtk-import-function GtkType gtk_button_get_type) +(gtk-import-function GtkWidget gtk_button_new) +(gtk-import-function GtkWidget gtk_button_new_with_label GtkString) +(gtk-import-function nil gtk_button_pressed GtkButton) +(gtk-import-function nil gtk_button_released GtkButton) +(gtk-import-function nil gtk_button_clicked GtkButton) +(gtk-import-function nil gtk_button_enter GtkButton) +(gtk-import-function nil gtk_button_leave GtkButton) +(gtk-import-function nil gtk_button_set_relief GtkButton GtkReliefStyle) +(gtk-import-function GtkReliefStyle gtk_button_get_relief GtkButton) + +(defun gtk-button-new-with-pixmap (glyph) + "Construct a new GtkButton object with a pixmap." + (let ((button (gtk-button-new)) + (pixmap nil)) + (if (glyphp glyph) + (setq pixmap (gtk-pixmap-new glyph nil)) + (setq pixmap glyph)) + (gtk-widget-show pixmap) + (gtk-container-add button pixmap) + button)) + + +(gtk-import-function GtkType gtk_button_box_get_type) + +;Handcoded in ui-byhand.c... #### FIXME +;;;void gtk_button_box_get_child_size_default (gint *min_width, gint *min_height); +;;;void gtk_button_box_get_child_ipadding_default (gint *ipad_x, gint *ipad_y); + +(gtk-import-function nil gtk_button_box_set_child_size_default gint gint) +(gtk-import-function nil gtk_button_box_set_child_ipadding_default gint gint) +(gtk-import-function gint gtk_button_box_get_spacing GtkButtonBox) +(gtk-import-function GtkButtonBoxStyle gtk_button_box_get_layout GtkButtonBox) + +;Handcoded in ui-byhand.c... #### FIXME +;;;void gtk_button_box_get_child_size (GtkButtonBox *widget, +;;; gint *min_width, gint *min_height); +;;;void gtk_button_box_get_child_ipadding (GtkButtonBox *widget, gint *ipad_x, gint *ipad_y); + +(gtk-import-function nil gtk_button_box_set_spacing GtkButtonBox gint) +(gtk-import-function nil gtk_button_box_set_layout GtkButtonBox GtkButtonBoxStyle) +(gtk-import-function nil gtk_button_box_set_child_size GtkButtonBox gint gint) +(gtk-import-function nil gtk_button_box_set_child_ipadding GtkButtonBox gint gint) + + +(gtk-import-function GtkType gtk_calendar_get_type) +(gtk-import-function GtkWidget gtk_calendar_new) +(gtk-import-function gint gtk_calendar_select_month GtkCalendar guint guint) +(gtk-import-function nil gtk_calendar_select_day GtkCalendar guint) +(gtk-import-function gint gtk_calendar_mark_day GtkCalendar guint) +(gtk-import-function gint gtk_calendar_unmark_day GtkCalendar guint) +(gtk-import-function nil gtk_calendar_clear_marks GtkCalendar) +(gtk-import-function nil gtk_calendar_display_options GtkCalendar GtkCalendarDisplayOptions) + +;Handcoded in ui-byhand.c... #### FIXME +;void gtk_calendar_get_date (GtkCalendar *calendar, +; guint *year, +; guint *month, +; guint *day); + +(gtk-import-function nil gtk_calendar_freeze GtkCalendar) +(gtk-import-function nil gtk_calendar_thaw GtkCalendar) + + +(gtk-import-function GtkType gtk_check_button_get_type) +(gtk-import-function GtkWidget gtk_check_button_new) +(gtk-import-function GtkWidget gtk_check_button_new_with_label GtkString) + + +(gtk-import-function GtkType gtk_check_menu_item_get_type) +(gtk-import-function GtkWidget gtk_check_menu_item_new) +(gtk-import-function GtkWidget gtk_check_menu_item_new_with_label GtkString) +(gtk-import-function nil gtk_check_menu_item_set_active GtkCheckMenuItem gboolean) +(gtk-import-function nil gtk_check_menu_item_set_show_toggle GtkCheckMenuItem gboolean) +(gtk-import-function nil gtk_check_menu_item_toggled GtkCheckMenuItem) + + +(gtk-import-function GtkType gtk_clist_get_type) +(gtk-import-function GtkWidget gtk_clist_new gint) + +(gtk-import-function GtkWidget gtk_clist_new_with_titles + (gint . columns) + (GtkArrayOfString . titles)) + +;; set adjustments of clist +(gtk-import-function nil gtk_clist_set_hadjustment GtkCList GtkAdjustment) +(gtk-import-function nil gtk_clist_set_vadjustment GtkCList GtkAdjustment) + +;; get adjustments of clist +(gtk-import-function GtkAdjustment gtk_clist_get_hadjustment GtkCList) +(gtk-import-function GtkAdjustment gtk_clist_get_vadjustment GtkCList) + +;; set the border style of the clist +(gtk-import-function nil gtk_clist_set_shadow_type GtkCList GtkShadowType) + +;; set the clist's selection mode +(gtk-import-function nil gtk_clist_set_selection_mode GtkCList GtkSelectionMode) + +;; enable clists reorder ability +(gtk-import-function nil gtk_clist_set_reorderable GtkCList gboolean) +(gtk-import-function nil gtk_clist_set_use_drag_icons GtkCList gboolean) +(gtk-import-function nil gtk_clist_set_button_actions GtkCList guint guint) + +;; freeze all visual updates of the list, and then thaw the list after +;; you have made a number of changes and the updates wil occure in a +;; more efficent mannor than if you made them on a unfrozen list +(gtk-import-function nil gtk_clist_freeze GtkCList) +(gtk-import-function nil gtk_clist_thaw GtkCList) + +;; show and hide the column title buttons +(gtk-import-function nil gtk_clist_column_titles_show GtkCList) +(gtk-import-function nil gtk_clist_column_titles_hide GtkCList) + +;; set the column title to be a active title (responds to button presses, +;; prelights, and grabs keyboard focus), or passive where it acts as just +;; a title +(gtk-import-function nil gtk_clist_column_title_active GtkCList gint) +(gtk-import-function nil gtk_clist_column_title_passive GtkCList gint) +(gtk-import-function nil gtk_clist_column_titles_active GtkCList) +(gtk-import-function nil gtk_clist_column_titles_passive GtkCList) + +;; set the title in the column title button +(gtk-import-function nil gtk_clist_set_column_title GtkCList gint GtkString) + +;; returns the title of column. Returns NULL if title is not set */ +(gtk-import-function GtkString gtk_clist_get_column_title GtkCList gint) + +;; set a widget instead of a title for the column title button +(gtk-import-function nil gtk_clist_set_column_widget GtkCList gint GtkWidget) + +;; returns the column widget +(gtk-import-function GtkWidget gtk_clist_get_column_widget GtkCList gint) + +;; set the justification on a column +(gtk-import-function nil gtk_clist_set_column_justification GtkCList gint GtkJustification) + +;; set visibility of a column +(gtk-import-function nil gtk_clist_set_column_visibility GtkCList gint gboolean) + +;; enable/disable column resize operations by mouse +(gtk-import-function nil gtk_clist_set_column_resizeable GtkCList gint gboolean) + +;; resize column automatically to its optimal width +(gtk-import-function nil gtk_clist_set_column_auto_resize GtkCList gint gboolean) +(gtk-import-function gint gtk_clist_columns_autosize GtkCList) + +;; return the optimal column width, i.e. maximum of all cell widths +(gtk-import-function gint gtk_clist_optimal_column_width GtkCList gint) + +;; set the pixel width of a column; this is a necessary step in +;; creating a CList because otherwise the column width is chozen from +;; the width of the column title, which will never be right + +(gtk-import-function nil gtk_clist_set_column_width GtkCList gint gint) + +;; set column minimum/maximum width. min/max_width < 0 => no restriction +(gtk-import-function nil gtk_clist_set_column_min_width GtkCList gint gint) +(gtk-import-function nil gtk_clist_set_column_max_width GtkCList gint gint) + +;; change the height of the rows, the default (height=0) is +;; the hight of the current font. +(gtk-import-function nil gtk_clist_set_row_height GtkCList guint) + +;; scroll the viewing area of the list to the given column and row; +;; row_align and col_align are between 0-1 representing the location the +;; row should appear on the screnn, 0.0 being top or left, 1.0 being +;; bottom or right; if row or column is -1 then then there is no change +(gtk-import-function nil gtk_clist_moveto GtkCList gint gint gfloat gfloat) + +;; returns whether the row is visible +(gtk-import-function GtkVisibility gtk_clist_row_is_visible GtkCList gint) + +;; returns the cell type +(gtk-import-function GtkCellType gtk_clist_get_cell_type GtkCList gint gint) + +;; sets a given cell's text, replacing it's current contents +(gtk-import-function nil gtk_clist_set_text GtkCList gint gint GtkString) + +;; for the "get" functions, any of the return pointer can be +;; NULL if you are not interested +;; +;;;Handcoded in ui-byhand.c... #### FIXME +;;;gint gtk_clist_get_text (GtkCList *clist, +;;; gint row, +;;; gint column, +;;; gchar **text); + +;; #### BILL!!! Implement these! +;; (gtk-import-function nil gtk_clist_get_pixmap) +;; (gtk-import-function nil gtk_clist_get_pixtext) + +(gtk-import-function nil gtk_clist_set_pixmap + (GtkCList . clist) + (gint . row) + (gint . column) + (GdkPixmap . pixmap) + (GdkBitmap . mask)) +(gtk-import-function nil gtk_clist_set_pixtext + (GtkCList . clist) + (gint . row) + (gint . column) + (GtkString . text) + (gint . spacing) + (GdkPixmap . pixmap) + (GdkBitmap . mask)) + +;; sets the foreground color of a row, the color must already +;; be allocated +(gtk-import-function nil gtk_clist_set_foreground GtkCList gint GdkColor) + +;; sets the background color of a row, the color must already +;; be allocated +(gtk-import-function nil gtk_clist_set_background GtkCList gint GdkColor) + +;; set / get cell styles +(gtk-import-function nil gtk_clist_set_cell_style GtkCList gint gint GtkStyle) +(gtk-import-function GtkStyle gtk_clist_get_cell_style GtkCList gint gint) +(gtk-import-function nil gtk_clist_set_row_style GtkCList gint GtkStyle) +(gtk-import-function GtkStyle gtk_clist_get_row_style GtkCList gint) + +;; this sets a horizontal and vertical shift for drawing +;; the contents of a cell; it can be positive or negitive; +;; this is particulary useful for indenting items in a column +(gtk-import-function nil gtk_clist_set_shift GtkCList gint gint gint gint) + +;; set/get selectable flag of a single row +(gtk-import-function nil gtk_clist_set_selectable GtkCList gint gboolean) +(gtk-import-function gboolean gtk_clist_get_selectable GtkCList gint) + +;; prepend/append returns the index of the row you just added, +;; making it easier to append and modify a row + +(gtk-import-function gint gtk_clist_prepend + (GtkCList . clist) + (GtkArrayOfString . text)) + +(gtk-import-function gint gtk_clist_append + (GtkCList . clist) + (GtkArrayOfString . text)) + +;; inserts a row at index row and returns the row where it was +;; actually inserted (may be different from "row" in auto_sort mode) +(gtk-import-function gint gtk_clist_insert + (GtkCList . clist) + (gint . row) + (GtkArrayOfString . text)) + +;; removes row at index row +(gtk-import-function nil gtk_clist_remove GtkCList gint) + +;; sets a arbitrary data pointer for a given row +(gtk-import-function nil gtk_clist_set_row_data GtkCList gint gpointer) + +;; sets a data pointer for a given row with destroy notification +;; #### Need to handle callbacks. +;;;void gtk_clist_set_row_data_full (GtkCList *clist, +;;; gint row, +;;; gpointer data, +;;; GtkDestroyNotify destroy); + +;; returns the data set for a row +(gtk-import-function gpointer gtk_clist_get_row_data GtkCList gint) + +;; givin a data pointer, find the first (and hopefully only!) +;; row that points to that data, or -1 if none do +(gtk-import-function gint gtk_clist_find_row_from_data GtkCList gpointer) + +;; force selection of a row +(gtk-import-function nil gtk_clist_select_row GtkCList gint gint) + +;; force unselection of a row +(gtk-import-function nil gtk_clist_unselect_row GtkCList gint gint) + +;; undo the last select/unselect operation +(gtk-import-function nil gtk_clist_undo_selection GtkCList) + +;; clear the entire list -- this is much faster than removing +;; each item with gtk_clist_remove +(gtk-import-function nil gtk_clist_clear GtkCList) + +;; return the row column corresponding to the x and y coordinates, +;; the returned values are only valid if the x and y coordinates +;; are respectively to a window == clist->clist_window +;; +;;;Handcoded in ui-byhand.c... #### FIXME +;;;gint gtk_clist_get_selection_info (GtkCList *clist, +;;; gint x, +;;; gint y, +;;; gint *row, +;;; gint *column); + +;; in multiple or extended mode, select all rows +(gtk-import-function nil gtk_clist_select_all GtkCList) + +;; in all modes except browse mode, deselect all rows +(gtk-import-function nil gtk_clist_unselect_all GtkCList) + +;; swap the position of two rows +(gtk-import-function nil gtk_clist_swap_rows GtkCList gint gint) + +;; move row from source_row position to dest_row position +(gtk-import-function nil gtk_clist_row_move GtkCList gint gint) + +;; sets a compare function different to the default +;;;void gtk_clist_set_compare_func (GtkCList *clist, +;;; GtkCListCompareFunc cmp_func); + +;; the column to sort by +(gtk-import-function nil gtk_clist_set_sort_column GtkCList gint) + +;; how to sort : ascending or descending +(gtk-import-function nil gtk_clist_set_sort_type GtkCList GtkSortType) + +;; sort the list with the current compare function +(gtk-import-function nil gtk_clist_sort GtkCList) + +;; Automatically sort upon insertion +(gtk-import-function nil gtk_clist_set_auto_sort GtkCList gboolean) + + +;; ColorSelection + +(gtk-import-function GtkType gtk_color_selection_get_type) +(gtk-import-function GtkWidget gtk_color_selection_new) +(gtk-import-function nil gtk_color_selection_set_update_policy GtkColorSelection GtkUpdateType) +(gtk-import-function nil gtk_color_selection_set_opacity GtkColorSelection gint) +(gtk-import-function nil gtk_color_selection_set_color GtkColorSelection gdouble) + +;;;Handcoded in ui-byhand.c... #### FIXME +;void gtk_color_selection_get_color (GtkColorSelection *colorsel, +; gdouble *color); + +;; ColorSelectionDialog +(gtk-import-function GtkType gtk_color_selection_dialog_get_type) +(gtk-import-function GtkWidget gtk_color_selection_dialog_new GtkString) + + +(gtk-import-function GtkType gtk_combo_get_type) +(gtk-import-function GtkWidget gtk_combo_new) + +;; the text in the entry must be or not be in the list +(gtk-import-function nil gtk_combo_set_value_in_list GtkCombo gint gint) + +;; set/unset arrows working for changing the value (can be annoying) +(gtk-import-function nil gtk_combo_set_use_arrows GtkCombo gint) + +;; up/down arrows change value if current value not in list +(gtk-import-function nil gtk_combo_set_use_arrows_always GtkCombo gint) + +;; perform case-sensitive compares +(gtk-import-function nil gtk_combo_set_case_sensitive GtkCombo gint) + +;; call this function on an item if it isn't a label or you +;; want it to have a different value to be displayed in the entry +(gtk-import-function nil gtk_combo_set_item_string GtkCombo GtkItem GtkString) + +(gtk-import-function nil gtk_combo_set_popdown_strings + (GtkCombo . combo) + (GtkListOfString . strings)) + +(gtk-import-function nil gtk_combo_disable_activate GtkCombo) + + +(gtk-import-function GtkType gtk_container_get_type) +(gtk-import-function nil gtk_container_set_border_width GtkContainer guint) +(gtk-import-function nil gtk_container_add GtkContainer GtkWidget) +(gtk-import-function nil gtk_container_remove GtkContainer GtkWidget) +(gtk-import-function nil gtk_container_set_resize_mode GtkContainer GtkResizeMode) +(gtk-import-function nil gtk_container_check_resize GtkContainer) + +;; You can emulate this with (mapcar (lambda (x) ..) (gtk-container-children)) + +;;(gtk-import-function nil gtk_container_foreach GtkContainer GtkCallback) + +; I don't think we really want to deal with this... ever. #### FIXME? +;void gtk_container_foreach_full (GtkContainer *container, +; GtkCallback callback, +; GtkCallbackMarshal marshal, +; gpointer callback_data, +; GtkDestroyNotify notify); + +(gtk-import-function GtkListOfObject gtk_container_children + (GtkContainer . container)) + +(gtk-import-function gint gtk_container_focus GtkContainer GtkDirectionType) + +;;; Widget-level methods +(gtk-import-function nil gtk_container_set_reallocate_redraws GtkContainer gboolean) +(gtk-import-function nil gtk_container_set_focus_child GtkContainer GtkWidget) +(gtk-import-function nil gtk_container_set_focus_vadjustment GtkContainer GtkAdjustment) +(gtk-import-function nil gtk_container_set_focus_hadjustment GtkContainer GtkAdjustment) +(gtk-import-function nil gtk_container_register_toplevel GtkContainer) +(gtk-import-function nil gtk_container_unregister_toplevel GtkContainer) + +(gtk-import-function GtkListOfObject gtk_container_get_toplevels) + +(gtk-import-function nil gtk_container_resize_children GtkContainer) +(gtk-import-function guint gtk_container_child_type GtkContainer) + +; the `arg_name' argument needs to be a const static string */ +;void gtk_container_add_child_arg_type (const gchar *arg_name, +; GtkType arg_type, +; guint arg_flags, +; guint arg_id); + +;/* Allocate a GtkArg array of size nargs that hold the +; * names and types of the args that can be used with +; * gtk_container_child_getv/gtk_container_child_setv. +; * if (arg_flags!=NULL), +; * (*arg_flags) will be set to point to a newly allocated +; * guint array that holds the flags of the args. +; * It is the callers response to do a +; * g_free (returned_args); g_free (*arg_flags). +; */ +;GtkArg* gtk_container_query_child_args (GtkType class_type, +; guint32 **arg_flags, +; guint *nargs); + +;/* gtk_container_child_getv() sets an arguments type and value, or just +; * its type to GTK_TYPE_INVALID. +; * if GTK_FUNDAMENTAL_TYPE (arg->type) == GTK_TYPE_STRING, it's the callers +; * response to do a g_free (GTK_VALUE_STRING (arg)); +; */ +;void gtk_container_child_getv (GtkContainer *container, +; GtkWidget *child, +; guint n_args, +; GtkArg *args); +;void gtk_container_child_setv (GtkContainer *container, +; GtkWidget *child, +; guint n_args, +; GtkArg *args); + +;/* gtk_container_add_with_args() takes a variable argument list of the form: +; * (..., gchar *arg_name, ARG_VALUES, [repeatedly name/value pairs,] NULL) +; * where ARG_VALUES type depend on the argument and can consist of +; * more than one c-function argument. +; */ +;void gtk_container_add_with_args (GtkContainer *container, +; GtkWidget *widget, +; const gchar *first_arg_name, +; ...); +;void gtk_container_addv (GtkContainer *container, +; GtkWidget *widget, +; guint n_args, +; GtkArg *args); +;void gtk_container_child_set (GtkContainer *container, +; GtkWidget *child, +; const gchar *first_arg_name, +; ...); + + +(gtk-import-function GtkType gtk_curve_get_type) +(gtk-import-function GtkWidget gtk_curve_new) +(gtk-import-function nil gtk_curve_reset GtkCurve) +(gtk-import-function nil gtk_curve_set_gamma GtkCurve gfloat) +(gtk-import-function nil gtk_curve_set_range GtkCurve gfloat gfloat gfloat gfloat) + +;Handcoded in ui-byhand.c... #### FIXME +;;void gtk_curve_get_vector (GtkCurve *curve, +;; int veclen, gfloat vector[]); +;; +;;void gtk_curve_set_vector (GtkCurve *curve, +;; int veclen, gfloat vector[]); + +(gtk-import-function nil gtk_curve_set_curve_type GtkCurve GtkCurveType) + + +(gtk-import-function GtkType gtk_data_get_type) + + +(gtk-import-function GtkType gtk_dialog_get_type) +(gtk-import-function GtkWidget gtk_dialog_new) + + +(gtk-import-function GtkType gtk_drawing_area_get_type) +(gtk-import-function GtkWidget gtk_drawing_area_new) +(gtk-import-function nil gtk_drawing_area_size GtkDrawingArea gint gint) + + +(gtk-import-function GtkType gtk_editable_get_type) +(gtk-import-function nil gtk_editable_select_region GtkEditable gint gint) + +;;;Handcoded in ui-byhand.c... #### FIXME +;;;(gtk-import-function nil gtk_editable_insert_text GtkEditable GtkString gint pointer-to-gint) + +(gtk-import-function nil gtk_editable_delete_text GtkEditable gint gint) +(gtk-import-function GtkString gtk_editable_get_chars GtkEditable gint gint) +(gtk-import-function nil gtk_editable_cut_clipboard GtkEditable) +(gtk-import-function nil gtk_editable_copy_clipboard GtkEditable) +(gtk-import-function nil gtk_editable_paste_clipboard GtkEditable) +(gtk-import-function nil gtk_editable_claim_selection GtkEditable gboolean guint) +(gtk-import-function nil gtk_editable_delete_selection GtkEditable) +(gtk-import-function nil gtk_editable_changed GtkEditable) +(gtk-import-function nil gtk_editable_set_position GtkEditable gint) +(gtk-import-function gint gtk_editable_get_position GtkEditable) +(gtk-import-function nil gtk_editable_set_editable GtkEditable gboolean) + + +(gtk-import-function GtkType gtk_entry_get_type) +(gtk-import-function GtkWidget gtk_entry_new) +(gtk-import-function GtkWidget gtk_entry_new_with_max_length guint) +(gtk-import-function nil gtk_entry_set_text GtkEntry GtkString) +(gtk-import-function nil gtk_entry_append_text GtkEntry GtkString) +(gtk-import-function nil gtk_entry_prepend_text GtkEntry GtkString) +(gtk-import-function nil gtk_entry_set_position GtkEntry gint) + +;; returns a reference to the text +(gtk-import-function GtkString gtk_entry_get_text GtkEntry) +(gtk-import-function nil gtk_entry_select_region GtkEntry gint gint) +(gtk-import-function nil gtk_entry_set_visibility GtkEntry gboolean) +(gtk-import-function nil gtk_entry_set_editable GtkEntry gboolean) + +;; text is truncated if needed +(gtk-import-function nil gtk_entry_set_max_length GtkEntry guint) + + +(gtk-import-function GtkType gtk_event_box_get_type) +(gtk-import-function GtkWidget gtk_event_box_new) + + +(gtk-import-function GtkType gtk_file_selection_get_type) +(gtk-import-function GtkWidget gtk_file_selection_new GtkString) +(gtk-import-function nil gtk_file_selection_set_filename GtkFileSelection GtkString) +(gtk-import-function GtkString gtk_file_selection_get_filename GtkFileSelection) +(gtk-import-function nil gtk_file_selection_complete GtkFileSelection GtkString) +(gtk-import-function nil gtk_file_selection_show_fileop_buttons GtkFileSelection) +(gtk-import-function nil gtk_file_selection_hide_fileop_buttons GtkFileSelection) + + +(gtk-import-function GtkType gtk_fixed_get_type) +(gtk-import-function GtkWidget gtk_fixed_new) +(gtk-import-function nil gtk_fixed_put GtkFixed GtkWidget gint gint) +(gtk-import-function nil gtk_fixed_move GtkFixed GtkWidget gint gint) + + +(gtk-import-function GtkType gtk_font_selection_get_type) +(gtk-import-function GtkWidget gtk_font_selection_new) +(gtk-import-function GtkString gtk_font_selection_get_font_name GtkFontSelection) +;(gtk-import-function GdkFont gtk_font_selection_get_font GtkFontSelection) +(gtk-import-function gboolean gtk_font_selection_set_font_name GtkFontSelection GtkString) + + +(gtk-import-function nil gtk_font_selection_set_filter + (GtkFontSelection . fontsel) + (GtkFontFilterType . filter_type) + (GtkFontType . font_type) + (GtkArrayOfString . foundries) + (GtkArrayOfString . weights) + (GtkArrayOfString . slants) + (GtkArrayOfString . setwidths) + (GtkArrayOfString . spacings) + (GtkArrayOfString . charsets)) + +(gtk-import-function GtkString gtk_font_selection_get_preview_text GtkFontSelection) +(gtk-import-function nil gtk_font_selection_set_preview_text GtkFontSelection GtkString) + +;; GtkFontSelectionDialog functions. +;; most of these functions simply call the corresponding function in the +;; GtkFontSelection. + +(gtk-import-function GtkType gtk_font_selection_dialog_get_type) +(gtk-import-function GtkWidget gtk_font_selection_dialog_new GtkString) + +;; This returns the X Logical Font Description fontname, or NULL if no font +;; is selected. Note that there is a slight possibility that the font might not +;; have been loaded OK. You should call gtk_font_selection_dialog_get_font() +;; to see if it has been loaded OK. +(gtk-import-function GtkString gtk_font_selection_dialog_get_font_name GtkFontSelectionDialog) + +;; This will return the current GdkFont, or NULL if none is selected or there +;; was a problem loading it. Remember to use gdk_font_ref/unref() if you want +;; to use the font (in a style, for example) +;; GdkFont* gtk_font_selection_dialog_get_font (GtkFontSelectionDialog *fsd); + +;; This sets the currently displayed font. It should be a valid X Logical +;; Font Description font name (anything else will be ignored), e.g. +;; "-adobe-courier-bold-o-normal--25-*-*-*-*-*-*-*" +;; It returns TRUE on success. +(gtk-import-function gboolean gtk_font_selection_dialog_set_font_name GtkFontSelectionDialog GtkString) + +;; This sets one of the font filters, to limit the fonts shown. The filter_type +;; is GTK_FONT_FILTER_BASE or GTK_FONT_FILTER_USER. The font type is a +;; combination of the bit flags GTK_FONT_BITMAP, GTK_FONT_SCALABLE and +;; GTK_FONT_SCALABLE_BITMAP (or GTK_FONT_ALL for all font types). +;; The foundries, weights etc. are arrays of strings containing property +;; values, e.g. 'bold', 'demibold', and *MUST* finish with a NULL. +;; Standard long names are also accepted, e.g. 'italic' instead of 'i'. +;; +;; e.g. to allow only fixed-width fonts ('char cell' or 'monospaced') to be +;; selected use: +;; +;;gchar *spacings[] = { "c", "m", NULL }; +;;gtk_font_selection_dialog_set_filter (GTK_FONT_SELECTION_DIALOG (fontsel), +;; GTK_FONT_FILTER_BASE, GTK_FONT_ALL, +;; NULL, NULL, NULL, NULL, spacings, NULL); +;; +;; to allow only true scalable fonts to be selected use: +;; +;; gtk_font_selection_dialog_set_filter (GTK_FONT_SELECTION_DIALOG (fontsel), +;; GTK_FONT_FILTER_BASE, GTK_FONT_SCALABLE, +;; NULL, NULL, NULL, NULL, NULL, NULL); + +;;; #### BILL!!! You can do this by just call +;;; gtk_font_selection_set_filter on the appropriate slot of the +;;; dialog. Why bother with another function? +;;;void gtk_font_selection_dialog_set_filter (GtkFontSelectionDialog *fsd, +;;; GtkFontFilterType filter_type, +;;; GtkFontType font_type, +;;; gchar **foundries, +;;; gchar **weights, +;;; gchar **slants, +;;; gchar **setwidths, +;;; gchar **spacings, +;;; gchar **charsets); + +;; This returns the text in the preview entry. +(gtk-import-function GtkString gtk_font_selection_dialog_get_preview_text GtkFontSelectionDialog) + +;; This sets the text in the preview entry. It will be copied by the entry, +;; so there's no need to g_strdup() it first. +(gtk-import-function nil gtk_font_selection_dialog_set_preview_text GtkFontSelectionDialog GtkString) + + +(gtk-import-function GtkType gtk_frame_get_type) +(gtk-import-function GtkWidget gtk_frame_new GtkString) +(gtk-import-function nil gtk_frame_set_label GtkFrame GtkString) +(gtk-import-function nil gtk_frame_set_label_align GtkFrame gfloat gfloat) +(gtk-import-function nil gtk_frame_set_shadow_type GtkFrame GtkShadowType) + + +(gtk-import-function GtkType gtk_gamma_curve_get_type) +(gtk-import-function GtkWidget gtk_gamma_curve_new) + + +(gtk-import-function GtkType gtk_handle_box_get_type) +(gtk-import-function GtkWidget gtk_handle_box_new) +(gtk-import-function nil gtk_handle_box_set_shadow_type GtkHandleBox GtkShadowType) +(gtk-import-function nil gtk_handle_box_set_handle_position GtkHandleBox GtkPositionType) +(gtk-import-function nil gtk_handle_box_set_snap_edge GtkHandleBox GtkPositionType) + + +(gtk-import-function GtkType gtk_hbox_get_type) +(gtk-import-function GtkWidget gtk_hbox_new gboolean gint) + + +(gtk-import-function GtkType gtk_hbutton_box_get_type) +(gtk-import-function GtkWidget gtk_hbutton_box_new) + +;; buttons can be added by gtk_container_add() +(gtk-import-function gint gtk_hbutton_box_get_spacing_default) +(gtk-import-function nil gtk_hbutton_box_set_spacing_default gint) + +(gtk-import-function GtkButtonBoxStyle gtk_hbutton_box_get_layout_default) +(gtk-import-function nil gtk_hbutton_box_set_layout_default GtkButtonBoxStyle) + + +(gtk-import-function GtkType gtk_hpaned_get_type) +(gtk-import-function GtkWidget gtk_hpaned_new) + + +(gtk-import-function GtkType gtk_hruler_get_type) +(gtk-import-function GtkWidget gtk_hruler_new) + + +(gtk-import-function GtkType gtk_hscale_get_type) +(gtk-import-function GtkWidget gtk_hscale_new GtkAdjustment) + + +(gtk-import-function GtkType gtk_hscrollbar_get_type) +(gtk-import-function GtkWidget gtk_hscrollbar_new GtkAdjustment) + + +(gtk-import-function GtkType gtk_hseparator_get_type) +(gtk-import-function GtkWidget gtk_hseparator_new) + + +(gtk-import-function GtkType gtk_input_dialog_get_type) +(gtk-import-function GtkWidget gtk_input_dialog_new) + + +(gtk-import-function GtkType gtk_invisible_get_type) +(gtk-import-function GtkWidget gtk_invisible_new) + + +(gtk-import-function GtkType gtk_item_get_type) +(gtk-import-function nil gtk_item_select GtkItem) +(gtk-import-function nil gtk_item_deselect GtkItem) +(gtk-import-function nil gtk_item_toggle GtkItem) + + +(gtk-import-function GtkType gtk_label_get_type) +(gtk-import-function GtkWidget gtk_label_new GtkString) +(gtk-import-function nil gtk_label_set_text GtkLabel GtkString) +(gtk-import-function nil gtk_label_set_justify GtkLabel GtkJustification) +(gtk-import-function nil gtk_label_set_pattern GtkLabel GtkString) +(gtk-import-function nil gtk_label_set_line_wrap GtkLabel gboolean) + +;;;Handcoded in ui-byhand.c... #### FIXME +;void gtk_label_get (GtkLabel *label, +; gchar **str); + +;; Convenience function to set the name and pattern by parsing +;; a string with embedded underscores, and return the appropriate +;; key symbol for the accelerator. +(gtk-import-function guint gtk_label_parse_uline GtkLabel GtkString) + + +(gtk-import-function GtkType gtk_layout_get_type) +(gtk-import-function GtkWidget gtk_layout_new GtkAdjustment GtkAdjustment) +(gtk-import-function nil gtk_layout_put GtkLayout GtkWidget gint gint) +(gtk-import-function nil gtk_layout_move GtkLayout GtkWidget gint gint) +(gtk-import-function nil gtk_layout_set_size GtkLayout guint guint) + +(gtk-import-function GtkAdjustment gtk_layout_get_hadjustment GtkLayout) +(gtk-import-function GtkAdjustment gtk_layout_get_vadjustment GtkLayout) +(gtk-import-function nil gtk_layout_set_hadjustment GtkLayout GtkAdjustment) +(gtk-import-function nil gtk_layout_set_vadjustment GtkLayout GtkAdjustment) + +;; These disable and enable moving and repainting the scrolling window +;; of the GtkLayout, respectively. If you want to update the layout's +;; offsets but do not want it to repaint itself, you should use these +;; functions. + +;; - I don't understand these are supposed to work, so I suspect +;; - they don't now. OWT 1/20/98 + +(gtk-import-function nil gtk_layout_freeze GtkLayout) +(gtk-import-function nil gtk_layout_thaw GtkLayout) + + +(gtk-import-function GtkType gtk_list_get_type) +(gtk-import-function GtkWidget gtk_list_new) + +(gtk-import-function nil gtk_list_insert_items + (GtkList . list) + (GtkListOfObject . items) + (gint . position)) + +(gtk-import-function nil gtk_list_append_items + (GtkList . list) + (GtkListOfObject . items)) +(gtk-import-function nil gtk_list_prepend_items + (GtkList . list) + (GtkListOfObject . items)) +(gtk-import-function nil gtk_list_remove_items + (GtkList . list) + (GtkListOfObject . items)) +(gtk-import-function nil gtk_list_remove_items_no_unref + (GtkList . list) + (GtkListOfObject . items)) + +(gtk-import-function nil gtk_list_clear_items GtkList gint gint) +(gtk-import-function nil gtk_list_select_item GtkList gint) +(gtk-import-function nil gtk_list_unselect_item GtkList gint) +(gtk-import-function nil gtk_list_select_child GtkList GtkWidget) +(gtk-import-function nil gtk_list_unselect_child GtkList GtkWidget) +(gtk-import-function gint gtk_list_child_position GtkList GtkWidget) +(gtk-import-function nil gtk_list_set_selection_mode GtkList GtkSelectionMode) +(gtk-import-function nil gtk_list_extend_selection GtkList GtkScrollType gfloat gboolean) +(gtk-import-function nil gtk_list_start_selection GtkList) +(gtk-import-function nil gtk_list_end_selection GtkList) +(gtk-import-function nil gtk_list_select_all GtkList) +(gtk-import-function nil gtk_list_unselect_all GtkList) +(gtk-import-function nil gtk_list_scroll_horizontal GtkList GtkScrollType gfloat) +(gtk-import-function nil gtk_list_scroll_vertical GtkList GtkScrollType gfloat) +(gtk-import-function nil gtk_list_toggle_add_mode GtkList) +(gtk-import-function nil gtk_list_toggle_focus_row GtkList) +(gtk-import-function nil gtk_list_toggle_row GtkList GtkWidget) +(gtk-import-function nil gtk_list_undo_selection GtkList) +(gtk-import-function nil gtk_list_end_drag_selection GtkList) + + +(gtk-import-function GtkType gtk_list_item_get_type) +(gtk-import-function GtkWidget gtk_list_item_new) +(gtk-import-function GtkWidget gtk_list_item_new_with_label GtkString) +(gtk-import-function nil gtk_list_item_select GtkListItem) +(gtk-import-function nil gtk_list_item_deselect GtkListItem) + + +(gtk-import-variable guint gtk_major_version) +(gtk-import-variable guint gtk_minor_version) +(gtk-import-variable guint gtk_micro_version) +(gtk-import-variable guint gtk_interface_age) +(gtk-import-variable guint gtk_binary_age) + +(gtk-import-function GtkString gtk_check_version + (guint . required_major) + (guint . required_minor) + (guint . required_micro)) + +(gtk-import-function gboolean gtk_events_pending) +(gtk-import-function guint gtk_main_level) +(gtk-import-function nil gtk_main) +(gtk-import-function nil gtk_main_quit) +(gtk-import-function gint gtk_main_iteration) +(gtk-import-function gint gtk_main_iteration_do (gboolean . blocking)) +(gtk-import-function gint gtk_true) +(gtk-import-function gint gtk_false) + + +(gtk-import-function GtkType gtk_menu_get_type) +(gtk-import-function GtkWidget gtk_menu_new) + +;; Wrappers for the Menu Shell operations +(gtk-import-function nil gtk_menu_append GtkMenu GtkWidget) +(gtk-import-function nil gtk_menu_prepend GtkMenu GtkWidget) +(gtk-import-function nil gtk_menu_insert GtkMenu GtkWidget gint) + +;; Display the menu onscreen +(gtk-import-function nil gtk_menu_popup GtkMenu GtkWidget GtkWidget + gpointer ;; GtkMenuPositionFunc func + gpointer + guint + guint) + +;; Position the menu according to it's position function. Called +;; from gtkmenuitem.c when a menu-item changes its allocation +(gtk-import-function nil gtk_menu_reposition GtkMenu) +(gtk-import-function nil gtk_menu_popdown GtkMenu) + +;; Keep track of the last menu item selected. (For the purposes +;; of the option menu +(gtk-import-function GtkWidget gtk_menu_get_active GtkMenu) +(gtk-import-function nil gtk_menu_set_active GtkMenu guint) + +;; set/get the acclerator group that holds global accelerators (should +;; be added to the corresponding toplevel with gtk_window_add_accel_group(). +(gtk-import-function nil gtk_menu_set_accel_group GtkMenu GtkAccelGroup) +(gtk-import-function GtkAccelGroup gtk_menu_get_accel_group GtkMenu) + +;; get the accelerator group that is used internally by the menu for +;; underline accelerators while the menu is popped up. +(gtk-import-function GtkAccelGroup gtk_menu_get_uline_accel_group GtkMenu) +(gtk-import-function GtkAccelGroup gtk_menu_ensure_uline_accel_group GtkMenu) + +;; A reference count is kept for a widget when it is attached to +;; a particular widget. This is typically a menu item; it may also +;; be a widget with a popup menu - for instance, the Notebook widget. +(gtk-import-function nil gtk_menu_attach_to_widget GtkMenu GtkWidget gpointer) +(gtk-import-function nil gtk_menu_detach GtkMenu) + +;; This should be dumped in favor of data set when the menu is popped +;; up - that is currently in the ItemFactory code, but should be +;; in the Menu code. +(gtk-import-function GtkWidget gtk_menu_get_attach_widget GtkMenu) +(gtk-import-function nil gtk_menu_set_tearoff_state GtkMenu gboolean) + +;; This sets the window manager title for the window that +;; appears when a menu is torn off +(gtk-import-function nil gtk_menu_set_title GtkMenu GtkString) + +(gtk-import-function nil gtk_menu_reorder_child GtkMenu GtkWidget gint) + + +(gtk-import-function GtkType gtk_menu_bar_get_type) +(gtk-import-function GtkWidget gtk_menu_bar_new) +(gtk-import-function nil gtk_menu_bar_append GtkMenuBar GtkWidget) +(gtk-import-function nil gtk_menu_bar_prepend GtkMenuBar GtkWidget) +(gtk-import-function nil gtk_menu_bar_insert GtkMenuBar GtkWidget gint) +(gtk-import-function nil gtk_menu_bar_set_shadow_type GtkMenuBar GtkShadowType) + + +(gtk-import-function GtkType gtk_menu_item_get_type) +(gtk-import-function GtkWidget gtk_menu_item_new) +(gtk-import-function GtkWidget gtk_menu_item_new_with_label GtkString) +(gtk-import-function nil gtk_menu_item_set_submenu GtkMenuItem GtkWidget) +(gtk-import-function nil gtk_menu_item_remove_submenu GtkMenuItem) +(gtk-import-function nil gtk_menu_item_set_placement GtkMenuItem GtkSubmenuPlacement) +(gtk-import-function nil gtk_menu_item_configure GtkMenuItem gint gint) +(gtk-import-function nil gtk_menu_item_select GtkMenuItem) +(gtk-import-function nil gtk_menu_item_deselect GtkMenuItem) +(gtk-import-function nil gtk_menu_item_activate GtkMenuItem) +(gtk-import-function nil gtk_menu_item_right_justify GtkMenuItem) + + +(gtk-import-function GtkType gtk_misc_get_type) +(gtk-import-function nil gtk_misc_set_alignment + (GtkMisc . misc) + (gfloat . xalign) + (gfloat . yalign)) + +(gtk-import-function nil gtk_misc_set_padding + (GtkMisc . misc) + (gint . xpad) + (gint . ypad)) + + +(gtk-import-function GtkType gtk_notebook_get_type) +(gtk-import-function GtkWidget gtk_notebook_new) +(gtk-import-function nil gtk_notebook_append_page GtkNotebook GtkWidget GtkWidget) +(gtk-import-function nil gtk_notebook_append_page_menu GtkNotebook GtkWidget GtkWidget GtkWidget) +(gtk-import-function nil gtk_notebook_prepend_page GtkNotebook GtkWidget GtkWidget) +(gtk-import-function nil gtk_notebook_prepend_page_menu GtkNotebook GtkWidget GtkWidget GtkWidget) +(gtk-import-function nil gtk_notebook_insert_page GtkNotebook GtkWidget GtkWidget gint) +(gtk-import-function nil gtk_notebook_insert_page_menu GtkNotebook GtkWidget GtkWidget GtkWidget gint) +(gtk-import-function nil gtk_notebook_remove_page GtkNotebook gint) + +;;query, set current NoteebookPage +(gtk-import-function gint gtk_notebook_get_current_page GtkNotebook) +(gtk-import-function GtkWidget gtk_notebook_get_nth_page GtkNotebook gint) +(gtk-import-function gint gtk_notebook_page_num GtkNotebook GtkWidget) +(gtk-import-function nil gtk_notebook_set_page GtkNotebook gint) +(gtk-import-function nil gtk_notebook_next_page GtkNotebook) +(gtk-import-function nil gtk_notebook_prev_page GtkNotebook) + +;; set Notebook, NotebookTab style +(gtk-import-function nil gtk_notebook_set_show_border GtkNotebook gboolean) +(gtk-import-function nil gtk_notebook_set_show_tabs GtkNotebook gboolean) +(gtk-import-function nil gtk_notebook_set_tab_pos GtkNotebook GtkPositionType) +(gtk-import-function nil gtk_notebook_set_homogeneous_tabs GtkNotebook gboolean) +(gtk-import-function nil gtk_notebook_set_tab_border GtkNotebook guint) +(gtk-import-function nil gtk_notebook_set_tab_hborder GtkNotebook guint) +(gtk-import-function nil gtk_notebook_set_tab_vborder GtkNotebook guint) +(gtk-import-function nil gtk_notebook_set_scrollable GtkNotebook gboolean) + +;; enable/disable PopupMenu +(gtk-import-function nil gtk_notebook_popup_enable GtkNotebook) +(gtk-import-function nil gtk_notebook_popup_disable GtkNotebook) + +;; query/set NotebookPage Properties +(gtk-import-function GtkWidget gtk_notebook_get_tab_label GtkNotebook GtkWidget) +(gtk-import-function nil gtk_notebook_set_tab_label GtkNotebook GtkWidget GtkWidget) +(gtk-import-function nil gtk_notebook_set_tab_label_text GtkNotebook GtkWidget GtkString) +(gtk-import-function GtkWidget gtk_notebook_get_menu_label GtkNotebook GtkWidget) +(gtk-import-function nil gtk_notebook_set_menu_label GtkNotebook GtkWidget GtkWidget) +(gtk-import-function nil gtk_notebook_set_menu_label_text GtkNotebook GtkWidget GtkString) + +;;;Handcoded in ui-byhand.c... #### FIXME +;;;void gtk_notebook_query_tab_label_packing (GtkNotebook *notebook, +;;; GtkWidget *child, +;;; gboolean *expand, +;;; gboolean *fill, +;;; GtkPackType *pack_type); +(gtk-import-function nil gtk_notebook_set_tab_label_packing GtkNotebook GtkWidget gboolean gboolean GtkPackType) + +(gtk-import-function nil gtk_notebook_reorder_child GtkNotebook GtkWidget gint) + + +(gtk-import-function GtkType gtk_object_get_type) +;(gtk-import-function 'GtkObject gtk_object_newv 'guint 'guint 'GtkArg) +(gtk-import-function nil gtk_object_sink GtkObject) +(gtk-import-function nil gtk_object_ref GtkObject) +(gtk-import-function nil gtk_object_unref GtkObject) + +;; Need to implement callbacks better before I can do this. +;;void gtk_object_weakref (GtkObject *object, +;; GtkDestroyNotify notify, +;; gpointer data); +;;void gtk_object_weakunref (GtkObject *object, +;; GtkDestroyNotify notify, +;; gpointer data); + +(gtk-import-function nil gtk_object_destroy GtkObject) + +;; gtk_object_[gs]etv* () are handled by our generic 'get' and 'put' +;; handlers for types of GtkObject + + +(gtk-import-function GtkType gtk_option_menu_get_type) +(gtk-import-function GtkWidget gtk_option_menu_new) +(gtk-import-function GtkWidget gtk_option_menu_get_menu GtkOptionMenu) +(gtk-import-function nil gtk_option_menu_set_menu GtkOptionMenu GtkWidget) +(gtk-import-function nil gtk_option_menu_remove_menu GtkOptionMenu) +(gtk-import-function nil gtk_option_menu_set_history GtkOptionMenu guint) + + +(gtk-import-function GtkType gtk_packer_get_type) +(gtk-import-function GtkWidget gtk_packer_new) +(gtk-import-function nil gtk_packer_add_defaults GtkPacker GtkWidget + GtkSideType GtkAnchorType GtkPackerOptions) +(gtk-import-function nil gtk_packer_add GtkPacker + GtkWidget + GtkSideType + GtkAnchorType + GtkPackerOptions + guint + guint + guint + guint + guint) + +(gtk-import-function nil gtk_packer_set_child_packing GtkPacker + GtkWidget + GtkSideType + GtkAnchorType + GtkPackerOptions + guint + guint + guint + guint + guint) + +(gtk-import-function nil gtk_packer_reorder_child GtkPacker GtkWidget gint) +(gtk-import-function nil gtk_packer_set_spacing GtkPacker guint) +(gtk-import-function nil gtk_packer_set_default_border_width GtkPacker guint) +(gtk-import-function nil gtk_packer_set_default_pad GtkPacker guint guint) +(gtk-import-function nil gtk_packer_set_default_ipad GtkPacker guint guint) + + +(gtk-import-function GtkType gtk_paned_get_type) +(gtk-import-function nil gtk_paned_add1 GtkPaned GtkWidget) +(gtk-import-function nil gtk_paned_add2 GtkPaned GtkWidget) +(gtk-import-function nil gtk_paned_pack1 GtkPaned GtkWidget gboolean gboolean) +(gtk-import-function nil gtk_paned_pack2 GtkPaned GtkWidget gboolean gboolean) +(gtk-import-function nil gtk_paned_set_position GtkPaned gint) +(gtk-import-function nil gtk_paned_set_handle_size GtkPaned guint) +(gtk-import-function nil gtk_paned_set_gutter_size GtkPaned guint) + +;; Internal function... do we need to expose this? +(gtk-import-function nil gtk_paned_compute_position GtkPaned gint gint gint) + + +(gtk-import-function GtkType gtk_pixmap_get_type) +(gtk-import-function GtkWidget gtk_pixmap_new + (GdkPixmap . pixmap) + (GdkPixmap . mask)) +(gtk-import-function nil gtk_pixmap_set + (GtkPixmap . object) + (GdkPixmap . pixmap) + (GdkPixmap . mask)) + +;Handcoded in ui-byhand.c... #### FIXME +;;;void gtk_pixmap_get (GtkPixmap *pixmap, +;;; GdkPixmap **val, +;;; GdkBitmap **mask); + +(gtk-import-function nil gtk_pixmap_set_build_insensitive + (GtkPixmap . pixmap) + (guint . build)) + + +(gtk-import-function GtkType gtk_plug_get_type) +(gtk-import-function GtkWidget gtk_plug_new guint) +(gtk-import-function nil gtk_plug_construct GtkPlug guint) + + +(gtk-import-function GtkType gtk_progress_get_type) +(gtk-import-function nil gtk_progress_set_show_text GtkProgress gint) +(gtk-import-function nil gtk_progress_set_text_alignment GtkProgress gfloat gfloat) +(gtk-import-function nil gtk_progress_set_format_string GtkProgress GtkString) +(gtk-import-function nil gtk_progress_set_adjustment GtkProgress GtkAdjustment) +(gtk-import-function nil gtk_progress_configure GtkProgress gfloat gfloat gfloat) +(gtk-import-function nil gtk_progress_set_percentage GtkProgress gfloat) +(gtk-import-function nil gtk_progress_set_value GtkProgress gfloat) +(gtk-import-function gfloat gtk_progress_get_value GtkProgress) +(gtk-import-function nil gtk_progress_set_activity_mode GtkProgress guint) +(gtk-import-function GtkString gtk_progress_get_current_text GtkProgress) +(gtk-import-function GtkString gtk_progress_get_text_from_value GtkProgress gfloat) +(gtk-import-function gfloat gtk_progress_get_current_percentage GtkProgress) +(gtk-import-function gfloat gtk_progress_get_percentage_from_value GtkProgress gfloat) + + +(gtk-import-function GtkType gtk_progress_bar_get_type) +(gtk-import-function GtkWidget gtk_progress_bar_new) +(gtk-import-function GtkWidget gtk_progress_bar_new_with_adjustment GtkAdjustment) +(gtk-import-function nil gtk_progress_bar_set_bar_style GtkProgressBar GtkProgressBarStyle) +(gtk-import-function nil gtk_progress_bar_set_discrete_blocks GtkProgressBar guint) +(gtk-import-function nil gtk_progress_bar_set_activity_step GtkProgressBar guint) +(gtk-import-function nil gtk_progress_bar_set_activity_blocks GtkProgressBar guint) +(gtk-import-function nil gtk_progress_bar_set_orientation GtkProgressBar GtkProgressBarOrientation) +(gtk-import-function nil gtk_progress_bar_update GtkProgressBar gfloat) + + +;; All of the gpointers below really need to be `GSList *' +;; For now, need to create the first radio button with 'nil' and then use +;; (gtk-radio-button-group first-radio) for the rest. +(gtk-import-function GtkType gtk_radio_button_get_type) +(gtk-import-function GtkWidget gtk_radio_button_new gpointer) +(gtk-import-function GtkWidget gtk_radio_button_new_from_widget GtkRadioButton) +(gtk-import-function GtkWidget gtk_radio_button_new_with_label gpointer GtkString) +(gtk-import-function GtkWidget gtk_radio_button_new_with_label_from_widget GtkRadioButton GtkString) +(gtk-import-function gpointer gtk_radio_button_group GtkRadioButton) +(gtk-import-function nil gtk_radio_button_set_group GtkRadioButton gpointer) + + +(gtk-import-function GtkType gtk_radio_menu_item_get_type) + +;; #### BILLL!! +;; All of these gpointer args should be GList * +(gtk-import-function GtkWidget gtk_radio_menu_item_new gpointer) +(gtk-import-function GtkWidget gtk_radio_menu_item_new_with_label gpointer GtkString) +(gtk-import-function gpointer gtk_radio_menu_item_group GtkRadioMenuItem) +(gtk-import-function nil gtk_radio_menu_item_set_group GtkRadioMenuItem gpointer) + + +(gtk-import-function GtkType gtk_range_get_type) +(gtk-import-function GtkAdjustment gtk_range_get_adjustment GtkRange) +(gtk-import-function nil gtk_range_set_update_policy GtkRange GtkUpdateType) +(gtk-import-function nil gtk_range_set_adjustment GtkRange GtkAdjustment) + +(gtk-import-function nil gtk_range_draw_background GtkRange) +(gtk-import-function nil gtk_range_clear_background GtkRange) +(gtk-import-function nil gtk_range_draw_trough GtkRange) +(gtk-import-function nil gtk_range_draw_slider GtkRange) +(gtk-import-function nil gtk_range_draw_step_forw GtkRange) +(gtk-import-function nil gtk_range_draw_step_back GtkRange) +(gtk-import-function nil gtk_range_slider_update GtkRange) + +;;; #### BILL!!! I think all of these are just for subclassing +;;; widgets, which we will not be able to do. Maybe much later. +;;;gint gtk_range_trough_click (GtkRange *range, +;;; gint x, +;;; gint y, +;;; gfloat *jump_perc); + +(gtk-import-function nil gtk_range_default_hslider_update GtkRange) +(gtk-import-function nil gtk_range_default_vslider_update GtkRange) + +;;;gint gtk_range_default_htrough_click (GtkRange *range, +;;; gint x, +;;; gint y, +;;; gfloat *jump_perc); +;;;gint gtk_range_default_vtrough_click (GtkRange *range, +;;; gint x, +;;; gint y, +;;; gfloat *jump_perc); + +(gtk-import-function nil gtk_range_default_hmotion GtkRange gint gint) +(gtk-import-function nil gtk_range_default_vmotion GtkRange gint gint) + + +(gtk-import-function GtkType gtk_ruler_get_type) +(gtk-import-function nil gtk_ruler_set_metric GtkRuler GtkMetricType) +(gtk-import-function nil gtk_ruler_set_range GtkRuler gfloat gfloat gfloat gfloat) +(gtk-import-function nil gtk_ruler_draw_ticks GtkRuler) +(gtk-import-function nil gtk_ruler_draw_pos GtkRuler) + + +(gtk-import-function GtkType gtk_scale_get_type) +(gtk-import-function nil gtk_scale_set_digits GtkScale gint) +(gtk-import-function nil gtk_scale_set_draw_value GtkScale gboolean) +(gtk-import-function nil gtk_scale_set_value_pos GtkScale GtkPositionType) +(gtk-import-function gint gtk_scale_get_value_width GtkScale) +(gtk-import-function nil gtk_scale_draw_value GtkScale) + + +(gtk-import-function GtkType gtk_scrollbar_get_type) + + +(gtk-import-function GtkType gtk_scrolled_window_get_type) +(gtk-import-function GtkWidget gtk_scrolled_window_new GtkAdjustment GtkAdjustment) +(gtk-import-function nil gtk_scrolled_window_set_hadjustment GtkScrolledWindow GtkAdjustment) +(gtk-import-function nil gtk_scrolled_window_set_vadjustment GtkScrolledWindow GtkAdjustment) +(gtk-import-function GtkAdjustment gtk_scrolled_window_get_hadjustment GtkScrolledWindow) +(gtk-import-function GtkAdjustment gtk_scrolled_window_get_vadjustment GtkScrolledWindow) +(gtk-import-function nil gtk_scrolled_window_set_policy GtkScrolledWindow GtkPolicyType GtkPolicyType) +(gtk-import-function nil gtk_scrolled_window_set_placement GtkScrolledWindow GtkCornerType) +(gtk-import-function nil gtk_scrolled_window_add_with_viewport GtkScrolledWindow GtkWidget) + + +(gtk-import-function GtkType gtk_separator_get_type) + + +(gtk-import-function GtkType gtk_socket_get_type) +(gtk-import-function GtkWidget gtk_socket_new) +(gtk-import-function nil gtk_socket_steal GtkSocket guint) + + +(gtk-import-function GtkType gtk_table_get_type) +(gtk-import-function GtkWidget gtk_table_new guint guint gboolean) +(gtk-import-function nil gtk_table_resize GtkTable guint guint) + +(gtk-import-function nil gtk_table_attach GtkTable GtkWidget + guint guint guint guint GtkAttachOptions GtkAttachOptions guint + guint) + +(gtk-import-function nil gtk_table_attach_defaults GtkTable GtkWidget guint guint guint guint) +(gtk-import-function nil gtk_table_set_row_spacing GtkTable guint guint) +(gtk-import-function nil gtk_table_set_col_spacing GtkTable guint guint) +(gtk-import-function nil gtk_table_set_row_spacings GtkTable guint) +(gtk-import-function nil gtk_table_set_col_spacings GtkTable guint) +(gtk-import-function nil gtk_table_set_homogeneous GtkTable gboolean) + + +(gtk-import-function GtkType gtk_tearoff_menu_item_get_type) +(gtk-import-function GtkWidget gtk_tearoff_menu_item_new) + + +(gtk-import-function GtkType gtk_text_get_type) +(gtk-import-function GtkWidget gtk_text_new GtkAdjustment GtkAdjustment) +(gtk-import-function nil gtk_text_set_editable GtkText gboolean) +(gtk-import-function nil gtk_text_set_word_wrap GtkText gint) +(gtk-import-function nil gtk_text_set_line_wrap GtkText gint) +(gtk-import-function nil gtk_text_set_adjustments GtkText GtkAdjustment GtkAdjustment) +(gtk-import-function nil gtk_text_set_point GtkText guint) +(gtk-import-function guint gtk_text_get_point GtkText) +(gtk-import-function guint gtk_text_get_length GtkText) +(gtk-import-function nil gtk_text_freeze GtkText) +(gtk-import-function nil gtk_text_thaw GtkText) +(gtk-import-function nil gtk_text_insert GtkText GdkFont GdkColor GdkColor GtkString gint) +(gtk-import-function nil gtk_text_backward_delete GtkText guint) +(gtk-import-function nil gtk_text_forward_delete GtkText guint) + + +(gtk-import-function GtkType gtk_tips_query_get_type) +(gtk-import-function GtkWidget gtk_tips_query_new) +(gtk-import-function nil gtk_tips_query_start_query GtkTipsQuery) +(gtk-import-function nil gtk_tips_query_stop_query GtkTipsQuery) +(gtk-import-function nil gtk_tips_query_set_caller GtkTipsQuery GtkWidget) +(gtk-import-function nil gtk_tips_query_set_labels GtkTipsQuery GtkString GtkString) + + +(gtk-import-function GtkType gtk_toggle_button_get_type) +(gtk-import-function GtkWidget gtk_toggle_button_new) +(gtk-import-function GtkWidget gtk_toggle_button_new_with_label GtkString) +(gtk-import-function nil gtk_toggle_button_set_mode GtkToggleButton gboolean) +(gtk-import-function nil gtk_toggle_button_set_active GtkToggleButton gboolean) +(gtk-import-function gboolean gtk_toggle_button_get_active GtkToggleButton) +(gtk-import-function nil gtk_toggle_button_toggled GtkToggleButton) + + +(gtk-import-function GtkType gtk_toolbar_get_type) +(gtk-import-function GtkWidget gtk_toolbar_new GtkOrientation GtkToolbarStyle) + +;; Simple button items +;;; Handcoded in ui-byhand.c... #### FIXME +;;;GtkWidget* gtk_toolbar_append_item (GtkToolbar *toolbar, +;;; const char *text, +;;; const char *tooltip_text, +;;; const char *tooltip_private_text, +;;; GtkWidget *icon, +;;; GtkSignalFunc callback, +;;; gpointer user_data); +;;;GtkWidget* gtk_toolbar_prepend_item (GtkToolbar *toolbar, +;;; const char *text, +;;; const char *tooltip_text, +;;; const char *tooltip_private_text, +;;; GtkWidget *icon, +;;; GtkSignalFunc callback, +;;; gpointer user_data); +;;;GtkWidget* gtk_toolbar_insert_item (GtkToolbar *toolbar, +;;; const char *text, +;;; const char *tooltip_text, +;;; const char *tooltip_private_text, +;;; GtkWidget *icon, +;;; GtkSignalFunc callback, +;;; gpointer user_data, +;;; gint position); + +;; Space Items +(gtk-import-function nil gtk_toolbar_append_space GtkToolbar) +(gtk-import-function nil gtk_toolbar_prepend_space GtkToolbar) +(gtk-import-function nil gtk_toolbar_insert_space GtkToolbar gint) + +;; Any element type +;; Cannot currently do this! Need to have something similar to +;; GtkCallback in order to deal with this. +;; Of what possible use are these functions? I don't see the +;; difference between them and the _item functions. +;; +;; From looking at the code in gtktoolbar.c, the GtkWidget argument +;; here is ignored!!! +'(gtk-import-function GtkWidget gtk_toolbar_append_element GtkToolbar + GtkToolbarChildType + GtkWidget + GtkString + GtkString + GtkString + GtkWidget + GtkSignal + gpointer) + +'(gtk-import-function GtkWidget gtk_toolbar_prepend_element GtkToolbar + GtkToolbarChildType + GtkWidget + GtkString + GtkString + GtkString + GtkWidget + GtkSignal + gpointer) + +'(gtk-import-function GtkWidget gtk_toolbar_insert_element GtkToolbar + GtkToolbarChildType + GtkWidget + GtkString + GtkString + GtkString + GtkWidget + GtkSignal + gpointer + gint) + +;; Generic Widgets +(gtk-import-function nil gtk_toolbar_append_widget GtkToolbar GtkWidget GtkString GtkString) +(gtk-import-function nil gtk_toolbar_prepend_widget GtkToolbar GtkWidget GtkString GtkString) +(gtk-import-function nil gtk_toolbar_insert_widget GtkToolbar GtkWidget GtkString GtkString gint) + +;; Style functions +(gtk-import-function nil gtk_toolbar_set_orientation GtkToolbar GtkOrientation) +(gtk-import-function nil gtk_toolbar_set_style GtkToolbar GtkToolbarStyle) +(gtk-import-function nil gtk_toolbar_set_space_size GtkToolbar gint) +(gtk-import-function nil gtk_toolbar_set_space_style GtkToolbar GtkToolbarSpaceStyle) +(gtk-import-function nil gtk_toolbar_set_tooltips GtkToolbar gint) +(gtk-import-function nil gtk_toolbar_set_button_relief GtkToolbar GtkReliefStyle) +(gtk-import-function GtkReliefStyle gtk_toolbar_get_button_relief GtkToolbar) + + +(gtk-import-function GtkType gtk_tooltips_get_type) +(gtk-import-function GtkObject gtk_tooltips_new) +(gtk-import-function nil gtk_tooltips_enable GtkTooltips) +(gtk-import-function nil gtk_tooltips_disable GtkTooltips) +(gtk-import-function nil gtk_tooltips_set_delay GtkTooltips guint) +(gtk-import-function nil gtk_tooltips_set_tip GtkTooltips GtkWidget GtkString GtkString) +(gtk-import-function nil gtk_tooltips_set_colors GtkTooltips GdkColor GdkColor) + +;;;GtkTooltipsData* gtk_tooltips_data_get (GtkWidget *widget); + +(gtk-import-function nil gtk_tooltips_force_window GtkTooltips) + + +(gtk-import-function GtkType gtk_tree_get_type) +(gtk-import-function GtkWidget gtk_tree_new) + +(gtk-import-function nil gtk_tree_append + (GtkTree . tree) + (GtkWidget . tree_item)) +(gtk-import-function nil gtk_tree_prepend + (GtkTree . tree) + (GtkWidget . tree_item)) + +(gtk-import-function nil gtk_tree_insert + (GtkTree . tree) + (GtkWidget . tree_item) + (gint . position)) + +(gtk-import-function nil gtk_tree_remove_items + (GtkTree . tree) + (GtkListOfObject . items)) + +(gtk-import-function nil gtk_tree_clear_items + (GtkTree . tree) + (gint . start) + (gint . end)) + +(gtk-import-function nil gtk_tree_select_item + (GtkTree . tree) + (gint . item)) + +(gtk-import-function nil gtk_tree_unselect_item + (GtkTree . tree) + (gint . item)) + +(gtk-import-function nil gtk_tree_select_child + (GtkTree . tree) + (GtkWidget . tree_item)) + +(gtk-import-function nil gtk_tree_unselect_child + (GtkTree . tree) + (GtkWidget . tree_item)) + +(gtk-import-function gint gtk_tree_child_position + (GtkTree . tree) + (GtkWidget . child)) + +(gtk-import-function nil gtk_tree_set_selection_mode + (GtkTree . tree) + (GtkSelectionMode . mode)) + +(gtk-import-function nil gtk_tree_set_view_mode + (GtkTree . tree) + (GtkTreeViewMode . mode)) + +(gtk-import-function nil gtk_tree_set_view_lines + (GtkTree . tree) + (gboolean . flag)) + +;; deprecated function, use gtk_container_remove instead. +(gtk-import-function nil gtk_tree_remove_item + (GtkTree . tree) + (GtkWidget . child)) + + +(gtk-import-function GtkType gtk_tree_item_get_type) +(gtk-import-function GtkWidget gtk_tree_item_new) +(gtk-import-function GtkWidget gtk_tree_item_new_with_label GtkString) +(gtk-import-function nil gtk_tree_item_set_subtree GtkTreeItem GtkWidget) +(gtk-import-function nil gtk_tree_item_remove_subtree GtkTreeItem) +(gtk-import-function nil gtk_tree_item_select GtkTreeItem) +(gtk-import-function nil gtk_tree_item_deselect GtkTreeItem) +(gtk-import-function nil gtk_tree_item_expand GtkTreeItem) +(gtk-import-function nil gtk_tree_item_collapse GtkTreeItem) + + +(gtk-import-function GtkString gtk_type_name GtkType) +(gtk-import-function guint gtk_type_from_name GtkString) + + +(gtk-import-function GtkType gtk_vbox_get_type) +(gtk-import-function GtkWidget gtk_vbox_new gboolean gint) + + +(gtk-import-function GtkType gtk_vbutton_box_get_type) +(gtk-import-function GtkWidget gtk_vbutton_box_new) + +;; buttons can be added by gtk_container_add() +(gtk-import-function gint gtk_vbutton_box_get_spacing_default) +(gtk-import-function nil gtk_vbutton_box_set_spacing_default gint) + +(gtk-import-function GtkButtonBoxStyle gtk_vbutton_box_get_layout_default) +(gtk-import-function nil gtk_vbutton_box_set_layout_default GtkButtonBoxStyle) + + +(gtk-import-function GtkType gtk_viewport_get_type) +(gtk-import-function GtkWidget gtk_viewport_new GtkAdjustment GtkAdjustment) +(gtk-import-function GtkAdjustment gtk_viewport_get_hadjustment GtkViewport) +(gtk-import-function GtkAdjustment gtk_viewport_get_vadjustment GtkViewport) +(gtk-import-function nil gtk_viewport_set_hadjustment GtkViewport GtkAdjustment) +(gtk-import-function nil gtk_viewport_set_vadjustment GtkViewport GtkAdjustment) +(gtk-import-function nil gtk_viewport_set_shadow_type GtkViewport GtkShadowType) + + +(gtk-import-function GtkType gtk_vpaned_get_type) +(gtk-import-function GtkWidget gtk_vpaned_new) + + +(gtk-import-function GtkType gtk_vruler_get_type) +(gtk-import-function GtkWidget gtk_vruler_new) + + +(gtk-import-function GtkType gtk_vscale_get_type) +(gtk-import-function GtkWidget gtk_vscale_new GtkAdjustment) + + +(gtk-import-function GtkType gtk_vscrollbar_get_type) +(gtk-import-function GtkWidget gtk_vscrollbar_new GtkAdjustment) + + +(gtk-import-function GtkType gtk_vseparator_get_type) +(gtk-import-function GtkWidget gtk_vseparator_new) + + +(gtk-import-function GtkType gtk_widget_get_type) +(gtk-import-function nil gtk_widget_ref GtkWidget) +(gtk-import-function nil gtk_widget_unref GtkWidget) +(gtk-import-function nil gtk_widget_destroy GtkWidget) +(gtk-import-function nil gtk_widget_unparent GtkWidget) +(gtk-import-function nil gtk_widget_show GtkWidget) +(gtk-import-function nil gtk_widget_show_now GtkWidget) +(gtk-import-function nil gtk_widget_hide GtkWidget) +(gtk-import-function nil gtk_widget_show_all GtkWidget) +(gtk-import-function nil gtk_widget_hide_all GtkWidget) +(gtk-import-function nil gtk_widget_map GtkWidget) +(gtk-import-function nil gtk_widget_unmap GtkWidget) +(gtk-import-function nil gtk_widget_realize GtkWidget) +(gtk-import-function nil gtk_widget_unrealize GtkWidget) + +(gtk-import-function nil gtk_widget_queue_draw GtkWidget) +(gtk-import-function nil gtk_widget_queue_draw_area GtkWidget gint gint gint gint) +(gtk-import-function nil gtk_widget_queue_clear GtkWidget) +(gtk-import-function nil gtk_widget_queue_clear_area GtkWidget gint gint gint gint) +(gtk-import-function nil gtk_widget_queue_resize GtkWidget) + +;;; #### BILL!!! +;(gtk-import-function nil gtk_widget_draw 'GtkWidget 'GdkRectangle) +;(gtk-import-function nil gtk_widget_size_request 'GtkWidget 'GtkRequisition) +;(gtk-import-function nil gtk_widget_size_allocate 'GtkWidget 'GtkAllocation) +;(gtk-import-function nil gtk_widget_get_child_requisition 'GtkWidget 'GtkRequisition) +;(gtk-import-function 'gint gtk_widget_intersect 'GtkWidget 'GdkRectangle 'GdkRectangle) + +(gtk-import-function nil gtk_widget_draw_focus GtkWidget) +(gtk-import-function nil gtk_widget_draw_default GtkWidget) +(gtk-import-function nil gtk_widget_add_accelerator GtkWidget GtkString GtkAccelGroup + guint guint GtkAccelFlags) +(gtk-import-function nil gtk_widget_remove_accelerator GtkWidget GtkAccelGroup guint guint) +(gtk-import-function nil gtk_widget_remove_accelerators GtkWidget GtkString gboolean) +(gtk-import-function guint gtk_widget_accelerator_signal GtkWidget GtkAccelGroup guint guint) +(gtk-import-function nil gtk_widget_lock_accelerators GtkWidget) +(gtk-import-function nil gtk_widget_unlock_accelerators GtkWidget) +(gtk-import-function gboolean gtk_widget_accelerators_locked GtkWidget) +(gtk-import-function gint gtk_widget_event GtkWidget GdkEvent) +(gtk-import-function gboolean gtk_widget_activate GtkWidget) +(gtk-import-function gboolean gtk_widget_set_scroll_adjustments GtkWidget GtkAdjustment GtkAdjustment) +(gtk-import-function nil gtk_widget_reparent GtkWidget GtkWidget) +(gtk-import-function nil gtk_widget_popup GtkWidget gint gint) +(gtk-import-function nil gtk_widget_grab_focus GtkWidget) +(gtk-import-function nil gtk_widget_grab_default GtkWidget) +(gtk-import-function nil gtk_widget_set_name GtkWidget GtkString) +(gtk-import-function GtkString gtk_widget_get_name GtkWidget) +(gtk-import-function nil gtk_widget_set_state GtkWidget GtkStateType) +(gtk-import-function nil gtk_widget_set_sensitive GtkWidget gboolean) +(gtk-import-function nil gtk_widget_set_app_paintable GtkWidget gboolean) +(gtk-import-function nil gtk_widget_set_parent GtkWidget GtkWidget) +(gtk-import-function nil gtk_widget_set_parent_window GtkWindow GdkWindow) +(gtk-import-function GdkWindow gtk_widget_get_parent_window GtkWidget) +(gtk-import-function nil gtk_widget_set_uposition GtkWidget gint gint) +(gtk-import-function nil gtk_widget_set_usize GtkWidget gint gint) +(gtk-import-function nil gtk_widget_set_events GtkWidget GdkEventMask) +(gtk-import-function nil gtk_widget_add_events GtkWidget GdkEventMask) +(gtk-import-function nil gtk_widget_set_extension_events GtkWidget GdkExtensionMode) +(gtk-import-function GdkExtensionMode gtk_widget_get_extension_events GtkWidget) +(gtk-import-function GtkWidget gtk_widget_get_toplevel GtkWidget) +(gtk-import-function GtkWidget gtk_widget_get_ancestor GtkWidget guint) +(gtk-import-function GdkColormap gtk_widget_get_colormap GtkWidget) +(gtk-import-function GdkVisual gtk_widget_get_visual GtkWidget) + +(gtk-import-function nil gtk_widget_set_colormap GtkWidget GdkColormap) +(gtk-import-function nil gtk_widget_set_visual GtkWidget GdkVisual) +(gtk-import-function GdkEventMask gtk_widget_get_events GtkWidget) + +;;; Hrm - this should return a cons cell. +;;; Handcoded in ui-byhand.c... #### FIXME +;;void gtk_widget_get_pointer (GtkWidget *widget, +;; gint *x, +;; gint *y); + +(gtk-import-function gboolean gtk_widget_is_ancestor GtkWidget GtkWidget) +(gtk-import-function gboolean gtk_widget_hide_on_delete GtkWidget) + +;;; Widget styles +(gtk-import-function nil gtk_widget_set_style GtkWidget GtkStyle) +(gtk-import-function nil gtk_widget_set_rc_style GtkWidget) +(gtk-import-function nil gtk_widget_ensure_style GtkWidget) +(gtk-import-function GtkStyle gtk_widget_get_style GtkWidget) +(gtk-import-function nil gtk_widget_restore_default_style GtkWidget) +(gtk-import-function nil gtk_widget_modify_style GtkWidget GtkStyle) + +(gtk-import-function nil gtk_widget_set_composite_name GtkWidget GtkString) +(gtk-import-function GtkString gtk_widget_get_composite_name GtkWidget) +(gtk-import-function nil gtk_widget_reset_rc_styles GtkWidget) + +;; Push/pop pairs, to change default values upon a widget's creation. +;; This will override the values that got set by the +;; gtk_widget_set_default_* () functions. +(gtk-import-function nil gtk_widget_push_style GtkStyle) +(gtk-import-function nil gtk_widget_push_colormap GdkColormap) +(gtk-import-function nil gtk_widget_push_visual GdkVisual) +(gtk-import-function nil gtk_widget_push_composite_child) +(gtk-import-function nil gtk_widget_pop_composite_child) +(gtk-import-function nil gtk_widget_pop_style) +(gtk-import-function nil gtk_widget_pop_colormap) +(gtk-import-function nil gtk_widget_pop_visual) + +;; Set certain default values to be used at widget creation time. +(gtk-import-function nil gtk_widget_set_default_style GtkStyle) +(gtk-import-function nil gtk_widget_set_default_colormap GdkColormap) +(gtk-import-function nil gtk_widget_set_default_visual GdkVisual) +(gtk-import-function GtkStyle gtk_widget_get_default_style) +(gtk-import-function GdkColormap gtk_widget_get_default_colormap) +(gtk-import-function GdkVisual gtk_widget_get_default_visual) + +;; Counterpart to gdk_window_shape_combine_mask. +(gtk-import-function nil gtk_widget_shape_combine_mask GtkWidget GdkBitmap gint gint) + +;; internal function +(gtk-import-function nil gtk_widget_reset_shapes GtkWidget) + +;; Compute a widget's path in the form "GtkWindow.MyLabel", and +;; return newly alocated strings. +;; Ignored for now #### BILL!!! +;void gtk_widget_path (GtkWidget *widget, +; guint *path_length, +; gchar **path, +; gchar **path_reversed); +;void gtk_widget_class_path (GtkWidget *widget, +; guint *path_length, +; gchar **path, +; gchar **path_reversed); + + +(gtk-import-function GtkType gtk_window_get_type) +(gtk-import-function GtkWidget gtk_window_new GtkWindowType) +(gtk-import-function nil gtk_window_set_title GtkWindow GtkString) +(gtk-import-function nil gtk_window_set_wmclass GtkWindow GtkString GtkString) +(gtk-import-function nil gtk_window_set_policy GtkWindow gint gint gint) +(gtk-import-function nil gtk_window_add_accel_group GtkWindow GtkAccelGroup) +(gtk-import-function nil gtk_window_remove_accel_group GtkWindow GtkAccelGroup) +(gtk-import-function nil gtk_window_set_position GtkWindow GtkWindowPosition) +(gtk-import-function gint gtk_window_activate_focus GtkWindow) +(gtk-import-function gint gtk_window_activate_default GtkWindow) +(gtk-import-function nil gtk_window_set_transient_for GtkWindow GtkWindow) +;(gtk-import-function nil gtk_window_set_geometry_hints GtkWindow GtkWidget GdkGeometry GdkWindowHints) +(gtk-import-function nil gtk_window_set_default_size GtkWindow gint gint) +(gtk-import-function nil gtk_window_set_modal GtkWindow gboolean) + +;; Internal functions - do we really want to expose these? +;; NO +'(gtk-import-function nil gtk_window_set_focus GtkWindow GtkWidget) +'(gtk-import-function nil gtk_window_set_default GtkWindow GtkWidget) +'(gtk-import-function nil gtk_window_remove_embedded_xid GtkWindow guint) +'(gtk-import-function nil gtk_window_add_embedded_xid GtkWindow guint) +'(gtk-import-function nil gtk_window_reposition GtkWindow gint gint) + + +(gtk-import-function GtkType gtk_spin_button_get_type) +(gtk-import-function nil gtk_spin_button_configure + (GtkSpinButton . spin_button) + (GtkAdjustment . adjustment) + (gfloat . climb_rate) + (guint . digits)) +(gtk-import-function GtkWidget gtk_spin_button_new + (GtkAdjustment . adjustment) + (gfloat . climb_rate) + (guint . digits)) +(gtk-import-function nil gtk_spin_button_set_adjustment + (GtkSpinButton . spin_button) + (GtkAdjustment . adjustment)) +(gtk-import-function GtkAdjustment gtk_spin_button_get_adjustment + (GtkSpinButton . spin_button)) +(gtk-import-function nil gtk_spin_button_set_digits + (GtkSpinButton . spin_button) + (guint . digits)) +(gtk-import-function gfloat gtk_spin_button_get_value_as_float + (GtkSpinButton . spin_button)) +(gtk-import-function gint gtk_spin_button_get_value_as_int + (GtkSpinButton . spin_button)) +(gtk-import-function nil gtk_spin_button_set_value + (GtkSpinButton . spin_button) + (gfloat . value)) +(gtk-import-function nil gtk_spin_button_set_update_policy + (GtkSpinButton . spin_button) + (GtkSpinButtonUpdatePolicy . policy)) +(gtk-import-function nil gtk_spin_button_set_numeric + (GtkSpinButton . spin_button) + (gboolean . numeric)) +(gtk-import-function nil gtk_spin_button_spin + (GtkSpinButton . spin_button) + (GtkSpinType . direction) + (gfloat . increment)) +(gtk-import-function nil gtk_spin_button_set_wrap + (GtkSpinButton . spin_button) + (gboolean . wrap)) +(gtk-import-function nil gtk_spin_button_set_shadow_type + (GtkSpinButton . spin_button) + (GtkShadowType . shadow_type)) +(gtk-import-function nil gtk_spin_button_set_snap_to_ticks + (GtkSpinButton . spin_button) + (gboolean . snap_to_ticks)) +(gtk-import-function nil gtk_spin_button_update + (GtkSpinButton . spin_button)) + + +(gtk-import-function GtkType gtk_statusbar_get_type) +(gtk-import-function GtkWidget gtk_statusbar_new) +(gtk-import-function guint gtk_statusbar_get_context_id + (GtkStatusbar . statusbar) + (GtkString . context_description)) + +;; Returns message_id used for gtk_statusbar_remove +(gtk-import-function guint gtk_statusbar_push + (GtkStatusbar . statusbar) + (guint . context_id) + (GtkString . text)) +(gtk-import-function nil gtk_statusbar_pop + (GtkStatusbar . statusbar) + (guint . context_id)) +(gtk-import-function nil gtk_statusbar_remove + (GtkStatusbar . statusbar) + (guint . context_id) + (guint . message_id)) + + +(gtk-import-function GtkType gtk_ctree_get_type) +(gtk-import-function none gtk_ctree_construct + (GtkCTree . ctree) + (gint . columns) + (gint . tree_column) + (GtkArrayOfString . titles)) +(gtk-import-function GtkWidget gtk_ctree_new_with_titles + (gint . columns) + (gint . tree_column) + (GtkArrayOfString . titles)) +(gtk-import-function GtkWidget gtk_ctree_new + (gint . columns) + (gint . tree_column)) + +(gtk-import-function GtkCTreeNode gtk_ctree_insert_node + (GtkCTree . ctree) + (GtkCTreeNode . parent) + (GtkCTreeNode . sibling) + (GtkArrayOfString . text) + (guint . spacing) + (GdkPixmap . pixmap_closed) + (GdkBitmap . mask_closed) + (GdkPixmap . pixmap_opened) + (GdkBitmap . mask_opened) + (gboolean . is_leaf) + (gboolean . expanded)) + +(gtk-import-function none gtk_ctree_remove_node + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function none gtk_ctree_expand + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function none gtk_ctree_move + (GtkCTree . ctree) + (GtkCTreeNode . node) + (GtkCTreeNode . new_parent) + (GtkCTreeNode . new_sibling)) + +(gtk-import-function void gtk_ctree_expand_recursive + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function void gtk_ctree_expand_to_depth + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gint . depth)) + +(gtk-import-function void gtk_ctree_collapse + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function void gtk_ctree_collapse_recursive + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function void gtk_ctree_collapse_to_depth + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gint . depth)) + +(gtk-import-function void gtk_ctree_toggle_expansion + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function void gtk_ctree_toggle_expansion_recursive + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function void gtk_ctree_select + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function void gtk_ctree_select_recursive + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function void gtk_ctree_unselect + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function void gtk_ctree_unselect_recursive + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +;; NOTE!!! The header file here was WRONG! It had a third arg 'gint state' +(gtk-import-function void gtk_ctree_real_select_recursive + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +;; Analogs of GtkCList functions +(gtk-import-function void gtk_ctree_node_set_text + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gint . column) + (GtkString . text)) + +(gtk-import-function void gtk_ctree_node_set_pixmap + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gint . column) + (GdkPixmap . pixmap) + (GdkBitmap . mask)) + +(gtk-import-function void gtk_ctree_node_set_pixtext + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gint . column) + (GtkString . text) + (guint . spacing) + (GdkPixmap . pixmap) + (GdkBitmap . mask)) + +(gtk-import-function void gtk_ctree_set_node_info + (GtkCTree . ctree) + (GtkCTreeNode . node) + (GtkString . text) + (guint . spacing) + (GdkPixmap . pixmap_closed) + (GdkBitmap . mask_closed) + (GdkPixmap . pixmap_opened) + (GdkBitmap . mask_opened) + (gboolean . is_leaf) + (gboolean . expanded)) + +(gtk-import-function void gtk_ctree_node_set_shift + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gint . column) + (gint . vertical) + (gint . horizontal)) + +(gtk-import-function void gtk_ctree_node_set_selectable + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gboolean . selectable)) + +(gtk-import-function gboolean gtk_ctree_node_get_selectable + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function GtkCellType gtk_ctree_node_get_cell_type + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gint . column)) + +(gtk-import-function void gtk_ctree_node_set_row_style + (GtkCTree . ctree) + (GtkCTreeNode . node) + (GtkStyle . style)) + +(gtk-import-function GtkStyle gtk_ctree_node_get_row_style + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function void gtk_ctree_node_set_cell_style + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gint . column) + (GtkStyle . style)) + +(gtk-import-function GtkStyle gtk_ctree_node_get_cell_style + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gint . column)) + +(gtk-import-function void gtk_ctree_node_set_foreground + (GtkCTree . ctree) + (GtkCTreeNode . node) + (GdkColor . color)) + +(gtk-import-function void gtk_ctree_node_set_background + (GtkCTree . ctree) + (GtkCTreeNode . node) + (GdkColor . color)) + +(gtk-import-function void gtk_ctree_node_moveto + (GtkCTree . ctree) + (GtkCTreeNode . node) + (gint . column) + (gfloat . row_align) + (gfloat . col_align)) + +(gtk-import-function GtkVisibility gtk_ctree_node_is_visible + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +;; GtkCTree specific functions +(gtk-import-function void gtk_ctree_set_indent + (GtkCTree . ctree) + (gint . indent)) + +(gtk-import-function void gtk_ctree_set_spacing + (GtkCTree . ctree) + (gint . spacing)) + +(gtk-import-function void gtk_ctree_set_show_stub + (GtkCTree . ctree) + (gboolean . show_stub)) + +(gtk-import-function void gtk_ctree_set_line_style + (GtkCTree . ctree) + (GtkCTreeLineStyle . line_style)) + +(gtk-import-function void gtk_ctree_set_expander_style + (GtkCTree . ctree) + (GtkCTreeExpanderStyle . expander_style)) + +;; Tree sorting functions +(gtk-import-function void gtk_ctree_sort_node + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +(gtk-import-function void gtk_ctree_sort_recursive + (GtkCTree . ctree) + (GtkCTreeNode . node)) + +;; Finding tree information +(gtk-import-function gboolean gtk_ctree_is_viewable + (GtkCTree . ctree) + (GtkCTreeNode . node)) +(gtk-import-function GtkCTreeNode gtk_ctree_last + (GtkCTree . ctree) + (GtkCTreeNode . node)) +(gtk-import-function GtkCTreeNode gtk_ctree_find_node_ptr + (GtkCTree . ctree) + (GtkCTreeRow . ctree_row)) +(gtk-import-function GtkCTreeNode gtk_ctree_node_nth + (GtkCTree . ctree) + (guint . row)) +(gtk-import-function gboolean gtk_ctree_find + (GtkCTree . ctree) + (GtkCTreeNode . node) + (GtkCTreeNode . child)) +(gtk-import-function gboolean gtk_ctree_is_ancestor + (GtkCTree . ctree) + (GtkCTreeNode . node) + (GtkCTreeNode . child)) +(gtk-import-function gboolean gtk_ctree_is_hot_spot + (GtkCTree . ctree) + (gint . x) + (gint . y)) + +(defun gtk-ctree-post-recursive (ctree node func data) + (gtk-ctree-recurse ctree node func data t nil)) + +(defun gtk-ctree-post-recursive-to-depth (ctree node depth func data) + (gtk-ctree-recurse ctree node func data t depth)) + +(defun gtk-ctree-pre-recursive (ctree node func data) + (gtk-ctree-recurse ctree node func data nil nil)) + +(defun gtk-ctree-pre-recursive-to-depth (ctree node depth func data) + (gtk-ctree-recurse ctree node func data nil depth)) + + +(gtk-import-function GtkType gtk_preview_get_type) +(gtk-import-function void gtk_preview_uninit) +(gtk-import-function GtkWidget gtk_preview_new + (GtkPreviewType . type)) +(gtk-import-function void gtk_preview_size + (GtkPreview . preview) + (gint . width) + (gint . height)) +(gtk-import-function void gtk_preview_put + (GtkPreview . preview) + (GdkWindow . window) + (GdkGC . gc) + (gint . srcx) + (gint . srcy) + (gint . destx) + (gint . desty) + (gint . width) + (gint . height)) +(gtk-import-function void gtk_preview_draw_row + (GtkPreview . preview) + (GtkString . data) + (gint . x) + (gint . y) + (gint . w)) +(gtk-import-function void gtk_preview_set_expand + (GtkPreview . preview) + (gboolean . expand)) +(gtk-import-function void gtk_preview_set_gamma + (double . gamma)) +(gtk-import-function void gtk_preview_set_color_cube + (guint . nred_shades) + (guint . ngreen_shades) + (guint . nblue_shades) + (guint . ngray_shades)) +(gtk-import-function void gtk_preview_set_install_cmap + (gboolean . install_cmap)) +(gtk-import-function void gtk_preview_set_reserved + (gint . nreserved)) +;;;(gtk-import-function void gtk_preview_set_dither +;;; (GtkPreview . preview) +;;; (GdkRgbDither . dither)) + +(gtk-import-function GdkVisual gtk_preview_get_visual) +(gtk-import-function GdkColormap gtk_preview_get_cmap) +(gtk-import-function GtkPreviewInfo gtk_preview_get_info) + +;; This function reinitializes the preview colormap and visual from +;; the current gamma/color_cube/install_cmap settings. It must only +;; be called if there are no previews or users's of the preview +;; colormap in existence. +(gtk-import-function void gtk_preview_reset) diff --git a/lisp/gtk.el b/lisp/gtk.el new file mode 100644 index 0000000..f7cd3bf --- /dev/null +++ b/lisp/gtk.el @@ -0,0 +1,19 @@ +(gtk-import-function nil "gdk_flush") + +(defun gtk-describe-enumerations () + "Show a list of all GtkEnum or GtkFlags objects available from lisp." + (interactive) + (set-buffer (get-buffer-create "*GTK Enumerations*")) + (erase-buffer) + (let ((separator (make-string (- (window-width) 3) ?-))) + (maphash (lambda (key val) + (insert + separator "\n" + (if (stringp key) + key + (gtk-type-name key)) "\n") + (mapc (lambda (cell) + (insert (format "\t%40s == %d\n" (car cell) (cdr cell)))) val)) + gtk-enumeration-info)) + (goto-char (point-min)) + (display-buffer (current-buffer))) diff --git a/lisp/widgets-gtk.el b/lisp/widgets-gtk.el new file mode 100644 index 0000000..38a151a --- /dev/null +++ b/lisp/widgets-gtk.el @@ -0,0 +1,135 @@ +;;; widgets-gtk.el --- Embedded widget support for XEmacs w/GTK primitives + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; Maintainer: William M. Perry +;; Keywords: extensions, internal, dumped + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs (when embedded widgets are compiled in). + +(defvar foo) + +(defun gtk-widget-instantiate-button-internal (plist callback) + (let* ((type (or (plist-get plist :style) 'button)) + (label (or (plist-get plist :descriptor) (symbol-name type))) + (widget nil)) + (case type + (button + (setq widget (gtk-button-new-with-label label)) + (gtk-signal-connect widget 'clicked (lambda (wid real-cb) + (if (functionp real-cb) + (funcall real-cb) + (eval real-cb))) + callback)) + (radio + (let ((aux nil) + (selected-p (plist-get plist :selected))) + (setq widget (gtk-radio-button-new-with-label nil label) + aux (gtk-radio-button-new-with-label + (gtk-radio-button-group widget) + "bogus sibling")) + (gtk-toggle-button-set-active widget (eval selected-p)) + (gtk-signal-connect widget 'toggled + (lambda (wid data) + ;; data is (real-cb . sibling) + ) + (cons callback aux)))) + (otherwise + ;; Check boxes + (setq widget (gtk-check-button-new-with-label label)) + (gtk-toggle-button-set-active widget + (eval (plist-get plist :selected))) + (gtk-signal-connect widget 'toggled + (lambda (wid real-cb) + (if (functionp real-cb) + (funcall real-cb) + (eval real-cb))) + callback))) + + (gtk-widget-show-all widget) + widget)) + +(defun gtk-widget-instantiate-notebook-internal (plist callback) + (let ((widget (gtk-notebook-new)) + (items (plist-get plist :items))) + (while items + (gtk-notebook-append-page widget + (gtk-vbox-new nil 3) + (gtk-label-new (aref (car items) 0))) + (setq items (cdr items))) + widget)) + +(defun gtk-widget-instantiate-progress-internal (plist callback) + (let* ((adj (gtk-adjustment-new 0.0 0.0 100.0 1.0 5.0 5.0)) + (widget (gtk-progress-bar-new-with-adjustment adj))) + (gtk-adjustment-set-value adj (or (plist-get plist :value) 0.0)) + widget)) + +(defun gtk-widget-instantiate-entry-internal (plist callback) + (let* ((widget (gtk-entry-new)) + (default (plist-get plist :descriptor))) + (cond + ((stringp default) + nil) + ((sequencep default) + (setq default (mapconcat 'identity default ""))) + (t + (error "Invalid default value: %S" default))) + (gtk-entry-set-text widget default) + widget)) + +(put 'button 'instantiator 'gtk-widget-instantiate-button-internal) +(put 'tab-control 'instantiator 'gtk-widget-instantiate-notebook-internal) +(put 'progress-gauge 'instantiator 'gtk-widget-instantiate-progress-internal) +(put 'tree-view 'instantiator 'ignore) +(put 'edit-field 'instantiator 'gtk-widget-instantiate-entry-internal) +(put 'combo-box 'instantiator 'ignore) +(put 'label 'instantiator 'ignore) +(put 'layout 'instantiator 'ignore) + +(defun gtk-widget-instantiate-internal (instance + instantiator + pointer-fg + pointer-bg + domain) + "The lisp side of widget/glyph instantiation code." + (let* ((type (aref instantiator 0)) + (plist (cdr (map 'list 'identity instantiator))) + (widget (funcall (or (get type 'instantiator) 'ignore) + plist (or (plist-get plist :callback) 'ignore)))) + (add-timeout 0.1 (lambda (obj) + (gtk-widget-set-style obj + (gtk-widget-get-style + (frame-property nil 'text-widget)))) + widget) + (setq x widget) + widget)) + +(defun gtk-widget-property-internal () + nil) + +(defun gtk-widget-redisplay-internal () + nil) + +(provide 'widgets-gtk) diff --git a/src/ChangeLog.GTK b/src/ChangeLog.GTK new file mode 100644 index 0000000..c72b1ba --- /dev/null +++ b/src/ChangeLog.GTK @@ -0,0 +1,868 @@ +2000-10-03 William M. Perry + + * objects-gtk.c (gtk_font_instance_truename): Make sure we get the + fully expanded version of the font. + + * device-gtk.c (convert_font): Ditto. + + * gtk-xemacs.c (convert_font): Tell __get_gtk_font_truename to not + expand wildcards. + + * objects-gtk.c (__get_gtk_font_truename): Use the internal + name-list in a GdkFont structure to find the truename of the + font. This protects us from crashing if we get a FontSet + instead of a Font. + + (__get_gtk_font_truename): Accept new argument 'expandp' for + whether to return the FULL font name or the wildcarded version. + +2000-09-21 William M. Perry + + * device-gtk.c (Fgtk_init): Moved calls to gtk_init or gnome_init + to separate function, and expose it to lisp. It is now possible + to create GTK applications from batch mode. + (gtk_init_device): Use the new function. + +2000-09-12 William M. Perry + + * gtk-glue.c (gdk_event_to_emacs_event): Special case double + and triple clicks when converting events to lisp objects. + This allows something like GtkCList to treat double-clicks + differently in the 'select_row' signal. + +2000-09-11 William M. Perry + + * menubar-gtk.c (menu_create_menubar): Set a special name for + GtkMenuItems directly in the menubar. + +2000-09-10 William M. Perry + + * gtk-xemacs.c (gtk_xemacs_size_request): Deal with frame + being NULL. + + * gtk-xemacs.c (gtk_xemacs_size_allocate): Ditto. + +2000-09-09 William M. Perry + + * sound.c (init_native_sound): Enable sound for GTK devices. + + * device-gtk.c (gtk_init_device): Attempt to load a default + gtkrc file from the data directory. This way we can enable + the default face font handling in gtk-faces.el but not screw + the majority of users with a proportional font by default. + + * device-gtk.c (gtk_init_device): Attempt to load + ~/.xemacs/gtk-options.el when GTK devices are created. This + allows for setting a persistent geometry without requiring GNOME. + + * gtk-xemacs.c (gtk_xemacs_style_set): Deal with NULL frame. + + * device-gtk.c (gtk_init_device): Make app_shell a GtkXEmacs + widget so that style information is retrieved correctly. + + * menubar-gtk.c (gtk_xemacs_menubar_get_type): New subclass of + GtkMenuBar that always requests the same width as the text + widget. This fixes the spurious frame resizes when there were too + many menu items to display in the desired width. + (create_menubar_widget): Use the new subclass. + +2000-09-08 William M. Perry + + * device-gtk.c (Fgtk_keysym_on_keyboard_p): Ported function from + the X side of things. + + * device-gtk.c (gtk_mark_device): Make sure that we mark the + keysym hashtable or things go boom. + +2000-09-07 William M. Perry + + * menubar-gtk.c (gtk_update_frame_menubars): Don't actually + update the menubars if the menu is up. This fixes the weird + problem where if you had a menu up and 'message' was called + (this happens a lot with the 'customize' menu), the menu would + disappear. This is because XEmacs is fairly lame about when + it updates the menus - the message logging code eventually + does a (save-excursion (set-buffer " *Message Log*") ...). + The set-buffer caused magic variable current-menubar to be + evaluated, which calls gtk_update_frame_menubars, which would + nuke the menus. Gack. + +2000-09-06 William M. Perry + + * event-gtk.c (gtk_event_to_emacs_event): Reworked how we handle + removing the shift modifier of normal keys (a & A, etc) to be more + like MS-windows. This makes everything work pretty happily with + query-replace and apropos now. + +2000-09-05 William M. Perry + + * select-gtk.c (emacs_gtk_selection_received): Signal a fake + event here so that the event loop will wake up. Should fix + the strange pause seen when pasting. + + * select-gtk.c (Fgtk_get_clipboard): Signal an error if no + selections are available. This is more meaningful than 'insert' + throwing an error when it gets 'nil'. + + * select-gtk.c (emacs_gtk_selection_received): Don't bother + checking whether the data returned as the selection is a string. + If it is not, we convert it to binary data anyway. This fixes the + bug where you could not paste between two separate XEmacs + instances w/mule enabled (it sends selections as COMPOUND_TEXT). + + * device-gtk.c (Fgtk_style_info): Return the default font name as + part of the style info. + + * menubar-gtk.c (__generic_button_callback): make sure that we + provide a channel for our menu events. This fixes things like + get-dialog-box-response that rely on event-channel !nilp + +2000-09-05 William M. Perry + + * glyphs-gtk.c (__downcase): Actually return the downcased string! + Thanks to Michael Altenhofen for + spotting this. + +2000-09-05 William M. Perry + + * menubar-gtk.c (gtk_popup_menu): Make sure we call + __activate_menu correctly if the menu is dynamic. This fixes + popup menus with :filter effects. + +2000-09-01 William M. Perry + + * gpmevent.c, gpmevent.h: Updated to the latest XEmacs 21.2 + version of gpmevent.c. This means that GPM support works + with GTK now. + + * console-tty.c, console-tty.h: Removed old GPM support. + + * device-tty.c, emacs.c, event-Xt.c: Ditto. + + * event-unixoid.c, frame-tty.c: Ditto. + +2000-08-30 William M. Perry + + * gtk-xemacs.c (smash_scrollbar_specifiers): Don't bother looking + for nextstep themed scrollbars - didn't work anyway. + + * glade.c (Fglade_xml_textdomain): deal with old versions of Glade + that use 'textdomain' instead of 'txtdomain' in the structure. + + * menubar-gtk.c (gtk_popup_menu): use gtk_widget_show instead of + gtk_widget_show_all so that the magic `space-saver' menu item does + not get shown on popups. + +2000-08-27 William M. Perry + + * scrollbar-gtk.c (gtk_update_scrollbar_instance_status): Fiddle + with scrollbar_values -> GtkAdjustment conversion and scrolling up + with the arrows works correctly now. + + * event-gtk.c (gtk_event_to_emacs_event): Fixed the shifted key + lossage (pc-select works now). + +2000-08-11 William M. Perry + + * scrollbar-gtk.c (scrollbar_cb): Need to make sure we look at the + appropriate scrollbar instances from the mirror. Was looking only + at the vertical scrollbar instance. Don't know if this has + anything to do with the weird scrolling behaviour, but it is worth + a shot. + +2000-07-26 William M. Perry + + * menubar-gtk.c (run_menubar_hook): New function that runs + activate-menubar-hook if the menu shell it was invoked by is + currently inactive. + (create_menubar_widget): Hook up the button-press-event to + run_menubar_hook to cater to broken packages. + +2000-07-22 William M. Perry + + * frame-gtk.c (gtk_popup_frame): When the window is supposed to be + initially unmapped, we need to make sure we realize the text + widget (to avoid lossage in redisplay assuming there is a valid + window), but NOT show it. + +2000-07-12 William M. Perry + + * menubar-gtk.c (__kill_stupid_gtk_timer): New function to kill + the timer on a GtkMenuItem widget. This timer and its callback + appear to be what was causing heavily filtered menus (like + customize and other things under 'options') to crash. The GTK + code installs a timer when the user is moving the mouse around to + scan menus. Submenus are only popped up when this timer expires. + But if the filters are constantly running and creating/destroying + submenus, then you can blow up when they unconditionally check + GTK_WIDGET_FLAGS(menu_item->submenu), when submenu is NULL. + +2000-07-11 William M. Perry + + * device-gtk.c (gtk_init_device): Can now pass the entire argv + array that is in gtk-initial-argv-list, since gtk-init filters out + unknown options that may cause GTK to puke for us. This means + that GNOME session management works now. + + * frame-gtk.c (gnome_parse_geometry): Ripped this out of the GNOME + libraries to parse geometry settings, in case the user did not + compile with GNOME. + (gtk_initialize_frame_size): If gtk_initial_geometry is !NILP, + then try to parse it and use that. If the geometry cannot be + parsed, fall back to using 80x30. + + * device-gtk.c (Vgtk_initial_geometry): New variable exposed to + lisp holding the desired geometry of initial frames. + +2000-07-09 William M. Perry + + * ui-gtk.c (Fgtk_call_function): Outlined possible `enhancement' + if someone calls gtk-call-function with too few arguments. After + I implemented it I realized it was probably a bad idea, so I + commented it out. Maybe for the future... + + * menubar-gtk.c (menu_convert): Can now pass in a GtkWidget to + reuse. It detaches submenus, cleans up any GCPROs on it, and + attaches a new submenu. All done in an effort to stop the menubar + flickering. + (menu_create_menubar): No longer willy-nilly deletes all of the + items in the top-level menubar. We now check to see if the widget + already existing at the desired position has the same label as + this menu. If it does, we pass it in to menu_convert. This + drastically reduces the flickering menu problem that most people + have been seeing (try speedbar now). + +2000-07-04 William M. Perry + + * event-gtk.c (gtk_event_to_emacs_event): If FRAME is NULL, then + default to the selected frame on Vdefault_gtk_device. This will + only happen when being called from gtk-glue.c + + * ui-gtk.c (gtk_type_to_lisp): Properly convert GTK_TYPE_GDK_EVENT + objects to lisp events. + + * event-gtk.c (gtk_event_to_emacs_event): Made this non-static so + that gtk-glue.c can use it. + + * gtk-glue.c (gdk_event_to_emacs_event): New function to convert a + GDK event into something sensible for lisp. Just uses + gtk_event_to_emacs_event() from event-gtk.c to avoid code + duplication. Not perfect (the channel is set to the selected + frame, not the GtkObject it actually happened on). + + * event-gtk.c (gtk_event_to_emacs_event): Finally fixed the weird + selection problem where if you released the mouse button over the + root window, XEmacs would get confused and still think the + selection was going on. + + * ui-gtk.c (Fgtk_describe_type): New function to return the + signals and magic properties of an object given its name or type + identifier. + +2000-07-03 William M. Perry + + * ui-byhand.c (Fgtk_ctree_recurse): New function gtk-ctree-recurse + that encompasses gtk_ctree_post_recursive, + gtk_ctree_pre_recursive, gtk_ctree_post_recursive_to_depth, and + gtk_ctree_pre_recursive_to_depth. All hail lisp bindings with + variable number of arguments. + (Fgtk_ctree_recurse): Allow nil for the node. + + * ui-gtk.c (emacs_gtk_boxed_equality): New function for comparing + two GtkBoxed objects. This is needed because there is no way to + store a `user_data' or equivalent on them, so we cannot resurrect + it like a GtkObject so we always get the same Lisp_Object. This + allows callbacks to use `equal' on two GtkBoxed types and get sane + results. + (emacs_gtk_boxed_hash): New function for hashing GtkBoxed + objects. + +2000-07-01 William M. Perry + + * glade.c: New file to implement glue code for libglade. + +2000-06-30 William M. Perry + + * ui-gtk.c (lisp_to_gtk_type): Know how to deal with + GTK_TYPE_GDK_GC. + + * gtk-glue.c: Need to defien a GTK type for GdkGC so that we can + import all the GDK drawing primitives. + (face_to_gc): New function to convert a face object to a GC. + +2000-06-27 William M. Perry + + * ui-gtk.c (Fgtk_import_variable_internal): Renamed to -internal. + +2000-06-25 Vladimir Vukicevic + + * frame-gtk.c (gtk_set_initial_frame_size): Added in a call to + gtk_window_set_policy so that you can resize the window down below + the minimum size of the menubar. + +2000-06-23 William M. Perry + + * emacs.c (Fkill_emacs): Make sure we clean up the .saves* files + on normal exit. + +2000-06-13 William M. Perry + + * menubar-gtk.c (__activate_filtermenu): Put in some of the same + protections for filter menus that the normal menus have for widget + deletion and selected menu items, etc. + +2000-06-12 William M. Perry + + * scrollbar-gtk.c (gtk_create_scrollbar_instance): hide a + scrollbar widget until we are absolutely sure we need to see it. + Fixes the problem we were seeing with mouse-avoidance-mode causing + severe scrollbar breakage. + (update_one_widget_scrollbar_pointer): Move the call to + gtk_widget_realize() here instead of in the upper code. Isolates + the dependency-on-having-a-window logic. + + * gtk-xemacs.c (smash_scrollbar_specifiers): When setting the + scrollbar specifiers, need to take the x/y thickness of the border + into account. Horizontal scrollbar placement is much much nicer + now. Some themes would cause them to get positioned partially on + top of the modeline. + +2000-06-08 William M. Perry + + * console.c (select_console_1): Duh, forgot to put in an 'else' + statement, so Vwindow_system was getting set to Qnil all the + time. *sigh*. + +2000-06-02 William M. Perry + + * glyphs-gtk.c (gtk_xpm_instantiate): Do not allow pixmaps to be + instantiated as pointers under GTK. The pixmap and cursor + routines under GDK do not expose enough information to let use do + the same magic that glyphs-x.c does. *sigh* + + * ui-byhand.c (Fgtk_toolbar_insert_item): Hand-rolled function. + (Fgtk_toolbar_prepend_item): Ditto. + (generic_toolbar_insert_item): Utility function to take care of + all the common code for the Fgtk_toolbar_*_item functions. + +2000-06-01 William M. Perry + + * gtk-glue.c (face_to_style): DOH! You should only load it if + IMAGE_INSTANCEP, not !IMAGE_INSTANCEP you doofus. + + * ui-byhand.c (Fgtk_toolbar_append_item): Hand-rolled function. + + * ui-gtk.c (Fgtk_import_function_internal): No longer need to use + dll_function() to get the marshallers. They are now stored in a + hashtable. Lookups should be a bit quicker, and it will work on + platforms where you cannot do a dll_open (NULL) to look at your + own symbol table. + +2000-05-31 William M. Perry + + * select-gtk.c (emacs_gtk_selection_handle): Better MULE string + handling. + + * gtk-xemacs.c (gtk_xemacs_realize): Make sure we set the style on + the widget from the realize function. Otherwise for some themes + the color slots are not allocated yet, and we end up with icky + looking colors for things like the modeline/toolbar. + + * select-gtk.c (Fgtk_get_clipboard): If we cannot get the + selection from anyone, return the last selection we received. + This make us work more like the X selection behaviour with + cutbuffers enabled. + +2000-05-30 William M. Perry + + * ui-byhand.c: Removed definitions of gtk-clist-prepend, + gtk-clist-append, and gtk-clist-insert. + + * ui-gtk.c (lisp_to_gtk_type): Use it. + + * gtk-glue.c (face_to_style): Routine to convert from faces to + GtkStyle + + * menubar-gtk.c (gtk_popup_menu): Honor popup_up_p here. + (popdown_menu_cb): and here. + +2000-05-29 William M. Perry + + * frame-gtk.c (gtk_popup_frame): Do not show the widgets if we + were told to be initially unmapped. + (gtk_init_frame_1): Remember whether we were told to be initially + unmapped. Balloon help looks a little better now. + +2000-05-28 William M. Perry + + * redisplay-gtk.c (gtk_output_string): Fixed multi-dimensional + text run drawing. gdk_draw_text does too much, by dividing the + length by 2. So we fake them out my multiplying the length by the + dimension of the text. This will do the right thing for + single-dimension runs as well of course. + +2000-05-26 William M. Perry + + * ui-gtk.c (get_enumeration): Utility function that does its best + to import unknown enumeration types. + + * glyphs-gtk.c (resource_symbol_to_type): Fixed pointer + instantiation. + + * gtk-xemacs.c (FROB_FACE): Make sure to pass the device to + Fmake_image_instance or the initial background pixmaps would not + show up. + +2000-05-25 William M. Perry + + * device-gtk.c (gtk_init_device): Call gnome_init if available. + + * menubar-gtk.c (create_menubar_widget): Use gnome_app_set_menus + instead of dealing with all the handlebox/menu crap ourselves. + + * frame-gtk.c (gtk_create_widgets): Use GnomeApp if it is + available. Looks much sexier. :) + + * glyphs-gtk.c (gtk_resource_instantiate): New image instantiator + gtk-resource, similar to the mswindows-resource stuff. This + allows you to get to the stock cursors defined in GDK. May + eventually allow you access to things like stock gnome pixmaps, + not sure. + + * frame-gtk.c (gtk_set_frame_pointer): Actually handle setting the + frame cursor. + + * redisplay-gtk.c (gdk_draw_bitmap): New function to output a + bitmap using XCopyPlane instead of XCopyArea. + (gtk_output_gdk_pixmap): Use it when PIXMAP_DEPTH == 0. This + means bitmaps look correct now. + +2000-05-24 William M. Perry + + * ui-gtk.c (flags_to_list): New function to convert a GtkFlags + argument to a list of symbols. + (gtk_type_to_lisp): Use it for converting from a flag. + +2000-05-23 William M. Perry + + * frame-gtk.c (gtk_set_frame_position): Do not use + gtk_window_reposition - this apparently does not exist in some + versions of GTK 1.2 + + * gtk-glue.c (xemacs_gtklist_to_list): Don't call g_list_foreach + on a NULL list, just in case. + + * redisplay-gtk.c (gtk_text_width_single_run): Use gdk_text_width + instead of gdk_text_measure. Proportional fonts appear to work + now. + + * objects-gtk.c (gtk_initialize_font_instance): Use X specific + crap lifted from objects-x.c to figure out proportionality of a + font, and better location of the default character. + +2000-05-22 William M. Perry + + * ui-gtk.c (enum_to_symbol): Routine to convert an enum to a lisp + symbol. We now return this instead of an integer for GtkFlags or + GtkEnum types. + (lisp_to_flag): Routine to convert from a symbol or list of + symbols to a GtkEnum or GtkFlags type. + (lisp_to_gtk_type): Use it exclusively. No more sending integers + to functions. + (import_gtk_enumeration_internal): Do not import the GTK_FOO_BAR + flags/enums into the lisp namespace. We now store mappings from + symbol names (both the 'real' and nickname fields) to the actual + internal values. Much more lispy way of doing things. + + * menubar-gtk.c (__maybe_destroy): If we delete the menu item that + was 'active' when the menu was cancelled, GTK gets upset because + it tries to remove the focus rectangle from a (now) dead widget. + This widget will eventually get killed because it will not be + `precious' the next time the window is shown, because it is + unselectable. + + * frame-gtk.c (delete_event_cb): Signal a fake event to make the + event loop wake up and notice we've been destroyed. + +2000-05-20 William M. Perry + + * ui-gtk.c (object_putprop): Allow `put'ing of arbitrary slots on + gtk objects. This will be useful for tacking lisp shit onto + composite widgets, etc. + (object_getprop): Ditto for `get'ing. + + * frame-gtk.c (gtk_set_initial_frame_size): Don't delay when + changing the frame size, or creating initially unmapped frames is + screwed up. This showed up when trying to use the cheesy XEmacs + file selector dialog implemented using frames. + + * ui-byhand.c: Removed a lot of functions that can now be imported + directly by gtk-import-function using the + Gtk(Array|List)Of(String|Object) types. + + * ui-gtk.c (type_to_marshaller_type): Deal with new array/list + types. + (Fgtk_call_function): Need to free array and list storage after + calling functions. + (lisp_to_gtk_type): Deal with the new list and array types when + converting to GTK types. + + * gtk-glue.c: New file to deal with lists of strings or + GtkObjects. Defines new types GtkArrayOf, GtkListOf, + GtkArrayOfString, GtkListOfString, and GtkListOfObject. + (xemacs_list_to_array): Convert from a lisp list to a GtkArrayOf + of items. + (xemacs_list_to_list): Convert from a lisp list to a GtkListOf of + items. + + * dialog.c (Fpopup_dialog_box): Don't crap out if the car of + dbox_desc is not a string... this allows us to follow ben's + system/native dialog box specification. + +2000-05-19 William M. Perry + + * ui-gtk.c (lisp_to_gtk_type): Can now convert to GDK colors. Can + deal with color specifiers or instances. + (lisp_to_gtk_type): Can now convert to GDK fonts. Can deal with + face names, actual faces, font specifiers, or font instances. + +2000-05-18 William M. Perry + + * gtk-xemacs.c (smash_scrollbar_specifiers): Function that + attempts to set the scrollbar width/height correctly, but does not + do a very good job. Commented out for now. + + * redisplay-gtk.c (gtk_output_vertical_divider): Got rid of lots + of useless code, since we ended up just calling gtk_output_shadows + anyway. + (gtk_output_vertical_divider): Make sure we fill the rectangle + completely, otherwise the transparent background shows thru. + + * menubar-gtk.c: Don't nuke menus all the time... should speed up + submenu traversal a bit, and save on the GtkMenuItem creation. + + * device-gtk.c (Fgtk_style_info): Return a list of all the + pixmaps, not just GTK_STATE_NORMAL. + + * menubar-gtk.c (menu_descriptor_to_widget_1): Better menu labels + with keybindings. + + * frame-gtk.c (gtk_set_frame_size): This function actually works + now. + (gtk_set_initial_frame_size): Better default sizing method. + + * event-gtk.c (init_event_gtk_late): Push an error trap handler so + that XEmacs won't abort at the drop of a hat on X errors. We + could get X specific here and override the default GDK XError and + XIOError handlers to be more like those in device-x.c. Not sure + if that is worth it or not - you would at least get information + that an error occurred. + + * scrollbar-gtk.c (gtk_update_scrollbar_instance_status): Don't + always call gtk_widget_set_usize because that causes the widget to + redraw itself, which can cause some annoying flicker. + (gtk_update_scrollbar_instance_status): Don't always move it + either, because that can cause the GtkFixed container to get a + resize event. + (update_one_widget_scrollbar_pointer): Try to set the cursor + +2000-05-17 William M. Perry + + * device-gtk.c (Fgtk_style_info): Back to taking only 1 argument - + the device. + (Fgtk_style_info): Now returns ALL of the information about + colors. Returns a list of colors instead of just the one + associated with GTK_STATE_NORMAL. + +2000-05-16 William M. Perry + + * gtk-xemacs.c (smash_face_fallbacks): New function to reset the + gtk-specific fallbacks on various face specifiers. This means + that if the user has not changed the face, when a theme or style + is changed, the faces will automatically change as well. + (gtk_xemacs_style_set): Call it. + + * toolbar-gtk.c (get_toolbar_gc): Swap the fg/bg of the toolbar + face when getting the GC. It looks better this way. + + * gtk-xemacs.c (gtk_xemacs_style_set): Override the style-set + method so that we can nuke the pixmaps again. + (__nuke_background_items): Moved the voodoo out into its own + function so that it can be called from both style_set and + realize. + + * console-gtk.h (struct gtk_frame): Removed hardcoded GCs ala X. + + * toolbar-gtk.c (get_toolbar_gc): New function that dynamically + creates a GC from the `toolbar' face. + (gtk_draw_blank_toolbar_button): Use it instead of the hardcoded + GC. + (gtk_output_toolbar_button): Ditto. + (gtk_output_toolbar): Ditto. + + * event-gtk.c (gtk_check_for_quit_char): Quit handling actually + works now. Feh! + + * device-gtk.c (gtk_device_init_x_specific_cruft): New function + that gets the socket we are listening to the X server on so that + the SIGIO lossage works correctly for GTK devices. + (gtk_init_device): Call it at device creation time. + +2000-05-15 William M. Perry + + * ui-gtk.c (__internal_callback_marshal): We now correctly handle + the 'data' argument. This is an arbitrary lisp object passed to + the callback routine as its last argument. + +2000-05-14 William M. Perry + + * event-gtk.c (gtk_event_to_emacs_event): Needed to reinstate the + magic to NOT differentiate betwen ! and shift-!. *sigh* + + * ui-gtk.c (lisp_to_gtk_type): Allow 'nil' for string types so + that we can pass NULL to gtk-frame-new. + +2000-05-13 William M. Perry + + * gtk-xemacs.c (gtk_xemacs_size_request): Needed to override the + size_request method to get frame sizing correct. Whoo hoo! + (gtk_xemacs_realize): Don't set the background on the GtkXEmacs + window - this reduces the flicker even more. + + * device-gtk.c (gtk_init_device): Don't use shared memory under + FreeBSD - it is apparently flaky as hell and causes lots of themes + to crash and burn quite prettily. + + * gtk-xemacs.c (gtk_xemacs_realize): Added new widget method that + makes sure to nuke the background pixmap of the XEmacs text area + and its parent (the GtkWindow it is contained in). This fixes the + flashing you would see with themes/styles that define a background + pixmap. + +2000-05-12 William M. Perry + + * menubar-gtk.c (gtk_update_frame_menubar_internal): Duh, should + actually pay attention to menubar_will_be_visible instead of just + calling gtk_widget_show_all in both branches. :) + +2000-05-11 William M. Perry + + * menubar-gtk.c (vars_of_menubar_gtk): New variable + menubar-dockable-p that controls whether to use the GtkHandleBox + or not. + + * select-gtk.c: Implemented all of the selection callbacks for GTK + + * frame-gtk.c (resize_event_cb): Force a redisplay when the frame + is resized. + + * event-gtk.c (gtk_event_to_emacs_event): When we are doing our + hackery to make sure we don't see button events inside the + scrollbar, make sure we correctly forward events that did not + happen over ANY widget, otherwise selection gets royally screwed + and thinks you still have the mouse button down. + + * redisplay-gtk.c (gtk_output_string): Don't bother calling + gdk_draw_text_wc - I misunderstood what XDrawString16 did - + gdk_draw_text encapsulates this nicely for us. + +2000-05-10 William M. Perry + + * menubar-gtk.c: Changed how the menubar is created and managed. + We no longer create and destroy it at will. Only one GtkMenuBar + is ever created, and the children are just added/removed from it. + Much less flickering when switching buffers - cleaner in general. + (create_menubar_widget): Wheee - menubars are now detachable. + + * ui-gtk.c (Fgtk_import_function_internal): Don't drop everything + down to its fundamental type just yet - we need to know specifics + about boxed types. + (object_putprop): Duh, actually SET the property. + (Fgtk_fundamental_type): New function that does the obvious. + (Fgtk_object_type): New function that does the obvious. + (lisp_to_gtk_type): Implement glyph handling! GtkPixmap works! + + * ui-byhand.c (Fgtk_pixmap_get): Implemented by hand. *sigh* + + * dialog-gtk.c: Call into lisp to do dialog boxes. + +2000-05-08 William M. Perry + + * make-src-depend (PrintPatternDeps): Make sure we generate the + xx-gtk.* dependencies. + + * depend: Regenerated + + * make-src-depend: Handle inclusion of .c files. + + * Makefile.in.in (extra_doc_files): Need to include ui-byhand.c + here as well. + + * ui-gtk.c (type_to_marshaller_type): Don't abort if we don't know + about the marshaller. Just return Qnil and let the caller figure + it out. + (Fgtk_import_function_internal): Deal with new return value of + Qnil for error signalling from type_to_marshaller_type(). + (lisp_to_gtk_type): Half-assed implementation of dealing with + callbacks. + (gtk_type_to_lisp): Ditto. + + * ui-byhand.c: New file that hand-codes some annoying functions in + Gtk. *sigh* + + * emacs-widget-accessors.c (Fgtk_adjustment_lower): New + auto-generated file that spits out all the widget slot accessor + functions. + + * ui-gtk.c (Fgtk_signal_connect_internal): Holy shit, signals work! + (lisp_to_gtk_type): Allow ints to be passed in as arguments to + functions that expect floats, otherwise you have to write stupid + code like 9.0 instead of just passing in '9'. + +2000-05-07 William M. Perry + + * ui-gtk.c (gtk_type_to_lisp): Return Qnil if we get a NULL + pointer/object/boxed. + (lisp_to_gtk_type): Allow Qnil to be passed in to mean a NULL + pointer/object/boxed. + + * event-gtk.c (gtk_event_to_emacs_event): Make sure a button press + focuses on the text widget, otherwise if someone packs a widget + into the container from lisp, we end up not getting keyboard focus + quite a bit. Eek. + + * frame-gtk.c (gtk_create_widgets): Set the name of the xemacs + shell so we can control sylte issues from .gtkrc + (gtk_set_initial_frame_size): Set the default size of the frame + correctly. + (gtk_create_widgets): Expose the frame shell and container widgets + to lisp. + + * emacs-marshals.c: Added a whole shitload of marshallers - don't + edit this file by hand if you need to add one. Check out + ../lisp/ui/gtk-marshal.el for a script that auto-generates them + for you. + +2000-05-05 William M. Perry + + * ui-gtk.c (describe_gtk_arg): Debugging function to spit out + human-readable version a GtkArg. + (lisp_to_gtk_type): Made this function much more sane. + (Fgtk_call_function): New function to allow calling generic + functions from DLLs in lisp. + (CONVERT_RETVAL): New macro (ugh) to convert a pointer that the + return value filled in back into a valid GtkArg. + (Fgtk_call_function): This actually works now! Scary stuff. + +2000-05-04 William M. Perry + + * ui-gtk.c (Fgtk_import_type): New function to import a GtkType + into the XEmacs namespace. For starters this only fully imports + enumerations and flags. Importing a GtkObject or subclass results + in getting a list back of possible signals and argument lists. + + * scrollbar-gtk.c (gtk_create_scrollbar_instance): Fixed some + compiler warnings. + (scrollbar_cb): Aha! Thanks to the magic of reading the + gtkrange.c source code, we now have better behaving scrollbars. + Clicking in the trough/end arrows now works correctly instead of + the semi-hackish way it did earlier today. + + * ui-gtk.c (Fgtk_define_enumeration): New function that can + + * scrollbar-gtk.c (scrollbar_cb): Combined the horizontal and + vertical scrolling callbacks. Differentiate between them by + user_data. + (scrollbar_cb): Don't bother trying to figure out whether this is + a line-by-line or page-wide scrolling operation. Just go by what + is in the value of the adjustment and issue a scrollbar_*_drag + event. This is not 100% correct, but it at least gets it + working. Doing it 'right' might not be possible with standard Gtk + scrollbars. + (scrollbar_drag_hack_cb): New function to set + vertical_drag_in_progress and inhibit_slider_change when we might + be starting a drag in the scrollbar. + (gtk_update_scrollbar_instance_status): Better setting of the + adjustment variables. Scrolling by pages (clicking in the trough) + works now. Line-by-line seems to work too. + +2000-05-03 William M. Perry + + * scrollbar-gtk.c (gtk_update_scrollbar_instance_status): Got the + thumb sizing correct finally. Thanks to scrollbar-msw.c for + showing how to do it sanely - scrollbar-x.c is a mess. + + * window.c (specifier_vars_of_window): Added GTK specific fallback + for Vvertical_divider_line_width. + + * toolbar.c (specifier_vars_of_toolbar): Handle specifier + fallbacks for GTK toolbars. + + * gui-gtk.c (button_item_to_widget): Compiles under Gtk at least - + more than likely completely broken. + + * glyphs-gtk.c (write_lisp_string_to_temp_file): Resurrected this + blasphemous function to deal with XPMs. + (gtk_xpm_instantiate): Now writes the XPM to a temp file, since + GTK cannot deal with XPMs from memory. Lame, but not fixable for + gtk 1.2 - maybe for 1.4. + (gtk_xpm_instantiate): Transparency works now. + + * gccache-gtk.c (gc_cache_lookup): Made non-hash based code + compile. It is not used, but what the hell. + + * faces.c (complex_vars_of_faces): Do GTK specific mucking about + with face property fallbacks (fonts and colors) + + * events.c (event_equal): Added special case for GTK. + (event_hash): Added special case for GTK. + (format_event_object): Added special case for GTK events. + + * event-gtk.c (event_name): Use gtk_event_name helper function + here. + (handle_focus_event_1): Got rid of gtk-redisplay-hack variable and + usage. + + * device.c (delete_device_internal): Delete 'popup' frames under + Gtk as well as X. Should this happen for HAVE_MSWINDOWS as well? + + * console.c (select_console_1): Make sure we set Vwindow_system + like all the others. + + * frame-gtk.c (gtk_update_frame_external_traits): Added comments + about why I didn't implement some portions of this function. + + * redisplay-gtk.c (gtk_output_string): Fixed the bizarre redisplay + problem where all the default text would be drawn twice - once + with the normal background colour, and once with the text-cursor + background. This was caused by a stupid typo and using the wrong + GdkGC in the second call to gdk_draw_text_image... basically no + clipping was being done on the image, so the whole thing was + redrawn. + (gtk_output_string): Call gdk_draw_text if we have a background + pixmap, otherwise things look REALLY weird. + (gtk_clear_region): Had a misplaced brace that caused the non-text + area of a frame not to get the correct background. + +2000-05-02 William M. Perry + + * glyphs-gtk.c (gtk_xpm_instantiate): Need to write pixmaps to a + temp file and then read with gdk_pixmap_create_from_xpm () - there + is no way to read from a memory buffer (yet - I might write one + for Gtk 1.4) + + * glyphs.c: Don't include xpm.h when building with Gtk. + (pixmap_to_lisp_data): Alternate implementation for Gtk. + + * device-gtk.c (gtk_init_device): Call gdk_imlib_init if + available, otherwise the 'Pixmap' theme engine doesn't work. + Losers. + + * glyphs-gtk.c (gtk_xpm_instantiate): Now at least tries to + instantiate XPM images. + (init_image_instance_from_gdk_pixmap): Utility function to create + a glyph from an existing GdkPixmap. + + * device-gtk.c (Fgtk_style_info): Attempt to expose the background + pixmaps from a Gtk style. + diff --git a/src/console-gtk.c b/src/console-gtk.c new file mode 100644 index 0000000..d5343cc --- /dev/null +++ b/src/console-gtk.c @@ -0,0 +1,129 @@ +/* Console functions for X windows. + Copyright (C) 1996 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* Authorship: + + Ben Wing: January 1996, for 19.14. + William Perry: April 2000, for 21.1 (Gtk version) + */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "process.h" /* canonicalize_host_name */ +#include "redisplay.h" /* for display_arg */ + +DEFINE_CONSOLE_TYPE (gtk); + +static int +gtk_initially_selected_for_input (struct console *con) +{ + return 1; +} + +/* Remember, in all of the following functions, we have to verify + the integrity of our input, because the generic functions don't. */ + +static Lisp_Object +gtk_device_to_console_connection (Lisp_Object connection, Error_behavior errb) +{ + /* Strip the trailing .# off of the connection, if it's there. */ + + if (NILP (connection)) + return Qnil; + else + { + connection = build_string ("gtk"); + } + return connection; +} + +static Lisp_Object +gtk_semi_canonicalize_console_connection (Lisp_Object connection, + Error_behavior errb) +{ + struct gcpro gcpro1; + + GCPRO1 (connection); + + connection = build_string ("gtk"); + + RETURN_UNGCPRO (connection); +} + +static Lisp_Object +gtk_canonicalize_console_connection (Lisp_Object connection, Error_behavior errb) +{ + Lisp_Object hostname = Qnil; + struct gcpro gcpro1, gcpro2; + + GCPRO2 (connection, hostname); + + connection = build_string ("gtk"); + + RETURN_UNGCPRO (connection); +} + +static Lisp_Object +gtk_semi_canonicalize_device_connection (Lisp_Object connection, + Error_behavior errb) +{ + struct gcpro gcpro1; + + GCPRO1 (connection); + + connection = build_string("gtk"); + + RETURN_UNGCPRO (connection); +} + +static Lisp_Object +gtk_canonicalize_device_connection (Lisp_Object connection, Error_behavior errb) +{ + struct gcpro gcpro1; + + GCPRO1 (connection); + connection = build_string("gtk"); + + RETURN_UNGCPRO (connection); +} + +void +console_type_create_gtk (void) +{ + INITIALIZE_CONSOLE_TYPE (gtk, "gtk", "console-gtk-p"); + + CONSOLE_HAS_METHOD (gtk, semi_canonicalize_console_connection); + CONSOLE_HAS_METHOD (gtk, canonicalize_console_connection); + CONSOLE_HAS_METHOD (gtk, semi_canonicalize_device_connection); + CONSOLE_HAS_METHOD (gtk, canonicalize_device_connection); + CONSOLE_HAS_METHOD (gtk, device_to_console_connection); + CONSOLE_HAS_METHOD (gtk, initially_selected_for_input); + /* CONSOLE_HAS_METHOD (gtk, delete_console); */ +} + +void +reinit_console_type_create_gtk (void) +{ + REINITIALIZE_CONSOLE_TYPE (gtk); +} diff --git a/src/console-gtk.h b/src/console-gtk.h new file mode 100644 index 0000000..31c5055 --- /dev/null +++ b/src/console-gtk.h @@ -0,0 +1,243 @@ +/* Define X specific console, device, and frame object for XEmacs. + Copyright (C) 1989, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + + +/* Authorship: + + Ultimately based on FSF, then later on JWZ work for Lemacs. + Rewritten over time by Ben Wing and Chuck Thompson (original + multi-device work by Chuck Thompson). + */ + +#ifndef _XEMACS_CONSOLE_GTK_H_ +#define _XEMACS_CONSOLE_GTK_H_ + +#ifdef HAVE_GTK + +#include "console.h" +#include + +#define GDK_DRAWABLE(x) (GdkDrawable *) (x) +#define GET_GTK_WIDGET_WINDOW(x) (GTK_WIDGET (x)->window) +#define GET_GTK_WIDGET_PARENT(x) (GTK_WIDGET (x)->parent) + +DECLARE_CONSOLE_TYPE (gtk); + +struct gtk_device +{ + /* Gtk application info. */ + GtkWidget *gtk_app_shell; + + /* Cache of GC's for frame's on this device. */ + struct gc_cache *gc_cache; + + /* Selected visual, depth and colormap for this device */ + GdkVisual *visual; + int depth; + GdkColormap *device_cmap; + + /* Used by x_bevel_modeline in redisplay-x.c */ + GdkBitmap *gray_pixmap; + + /* frame that holds the WM_COMMAND property; there should be exactly + one of these per device. */ + Lisp_Object WM_COMMAND_frame; + + /* The following items are all used exclusively in event-gtk.c. */ + int MetaMask, HyperMask, SuperMask, AltMask, ModeMask; + guint lock_interpretation; + + void *x_modifier_keymap; /* Really an (XModifierKeymap *)*/ + + guint *x_keysym_map; + int x_keysym_map_min_code; + int x_keysym_map_max_code; + int x_keysym_map_keysyms_per_code; + Lisp_Object x_keysym_map_hashtable; + + /* #### It's not clear that there is much distinction anymore + between mouse_timestamp and global_mouse_timestamp, now that + Emacs doesn't see most (all?) events not destined for it. */ + + /* The timestamp of the last button or key event used by emacs itself. + This is used for asserting selections and input focus. */ + guint32 mouse_timestamp; + + /* This is the timestamp the last button or key event whether it was + dispatched to emacs or widgets. */ + guint32 global_mouse_timestamp; + + /* This is the last known timestamp received from the server. It is + maintained by x_event_to_emacs_event and used to patch bogus + WM_TAKE_FOCUS messages sent by Mwm. */ + guint32 last_server_timestamp; + + GdkAtom atom_WM_PROTOCOLS; + GdkAtom atom_WM_TAKE_FOCUS; + GdkAtom atom_WM_STATE; + +#if 0 + /* #### BILL!!! */ + /* stuff for sticky modifiers: */ + unsigned int need_to_add_mask, down_mask; + KeyCode last_downkey; + guint32 release_time; +#endif +}; + +#define DEVICE_GTK_DATA(d) DEVICE_TYPE_DATA (d, gtk) + +#define DEVICE_GTK_VISUAL(d) (DEVICE_GTK_DATA (d)->visual) +#define DEVICE_GTK_DEPTH(d) (DEVICE_GTK_DATA (d)->depth) +#define DEVICE_GTK_COLORMAP(d) (DEVICE_GTK_DATA (d)->device_cmap) +#define DEVICE_GTK_APP_SHELL(d) (DEVICE_GTK_DATA (d)->gtk_app_shell) +#define DEVICE_GTK_GC_CACHE(d) (DEVICE_GTK_DATA (d)->gc_cache) +#define DEVICE_GTK_GRAY_PIXMAP(d) (DEVICE_GTK_DATA (d)->gray_pixmap) +#define DEVICE_GTK_WM_COMMAND_FRAME(d) (DEVICE_GTK_DATA (d)->WM_COMMAND_frame) +#define DEVICE_GTK_MOUSE_TIMESTAMP(d) (DEVICE_GTK_DATA (d)->mouse_timestamp) +#define DEVICE_GTK_GLOBAL_MOUSE_TIMESTAMP(d) (DEVICE_GTK_DATA (d)->global_mouse_timestamp) +#define DEVICE_GTK_LAST_SERVER_TIMESTAMP(d) (DEVICE_GTK_DATA (d)->last_server_timestamp) + +/* The maximum number of widgets that can be displayed above the text + area at one time. Currently no more than 3 will ever actually be + displayed (menubar, psheet, debugger panel). */ +#define MAX_CONCURRENT_TOP_WIDGETS 8 + +struct gtk_frame +{ + /* The widget of this frame. */ + GtkWidget *widget; /* This is really a GtkWindow */ + + /* The layout manager */ + GtkWidget *container; /* actually a GtkVBox. */ + + /* The widget of the menubar */ + GtkWidget *menubar_widget; + + /* The widget of the edit portion of this frame; this is a GtkDrawingArea, + and the window of this widget is what the redisplay code draws on. */ + GtkWidget *edit_widget; + + /* Lists the widgets above the text area, in the proper order. */ + GtkWidget *top_widgets[MAX_CONCURRENT_TOP_WIDGETS]; + int num_top_widgets; + + /* Our container widget as a Lisp_Object */ + Lisp_Object lisp_visible_widgets[10]; + + /*************************** Miscellaneous **************************/ + + /* The icon pixmaps; these are Lisp_Image_Instance objects, or Qnil. */ + Lisp_Object icon_pixmap; + Lisp_Object icon_pixmap_mask; + + /* geometry string that ought to be freed. */ + char *geom_free_me_please; + + /* 1 if the frame is completely visible on the display, 0 otherwise. + if 0 the frame may have been iconified or may be totally + or partially hidden by another X window */ + unsigned int totally_visible_p :1; + + /* Is it visible at all? */ + unsigned int visible_p :1; + + /* Are we a top-level frame? This means that our shell is a + TopLevelShell, and we should do certain things to interact with + the window manager. */ + unsigned int top_level_frame_p :1; + + /* Are we iconfied right now? */ + unsigned int iconified_p :1; + +}; + +#define FRAME_GTK_DATA(f) FRAME_TYPE_DATA (f, gtk) + +#define FRAME_GTK_SHELL_WIDGET(f) (FRAME_GTK_DATA (f)->widget) +#define FRAME_GTK_CONTAINER_WIDGET(f) (FRAME_GTK_DATA (f)->container) +#define FRAME_GTK_MENUBAR_WIDGET(f) (FRAME_GTK_DATA (f)->menubar_widget) +#define FRAME_GTK_TEXT_WIDGET(f) (FRAME_GTK_DATA (f)->edit_widget) +#define FRAME_GTK_TOP_WIDGETS(f) (FRAME_GTK_DATA (f)->top_widgets) +#define FRAME_GTK_NUM_TOP_WIDGETS(f) (FRAME_GTK_DATA (f)->num_top_widgets) +#define FRAME_GTK_ICONIFIED_P(f) (FRAME_GTK_DATA (f)->iconfigied_p) + +#define FRAME_GTK_LISP_WIDGETS(f) (FRAME_GTK_DATA (f)->lisp_visible_widgets) +#define FRAME_GTK_ICON_PIXMAP(f) (FRAME_GTK_DATA (f)->icon_pixmap) +#define FRAME_GTK_ICON_PIXMAP_MASK(f) (FRAME_GTK_DATA (f)->icon_pixmap_mask) + +#define FRAME_GTK_GEOM_FREE_ME_PLEASE(f) (FRAME_GTK_DATA (f)->geom_free_me_please) + +#define FRAME_GTK_TOTALLY_VISIBLE_P(f) (FRAME_GTK_DATA (f)->totally_visible_p) +#define FRAME_GTK_VISIBLE_P(f) (FRAME_GTK_DATA (f)->visible_p) +#define FRAME_GTK_TOP_LEVEL_FRAME_P(f) (FRAME_GTK_DATA (f)->top_level_frame_p) + +/* Variables associated with the X display frame this emacs is using. */ + +extern Lisp_Object Vx_gc_pointer_shape; +extern Lisp_Object Vx_scrollbar_pointer_shape; + +extern struct console_type *gtk_console_type; +extern Lisp_Object Vdefault_gtk_device; + +/* Number of pixels below each line. */ +extern int gtk_interline_space; + +extern int gtk_selection_timeout; + +struct frame *gtk_any_window_to_frame (struct device *d, GdkWindow *); +struct frame *gtk_window_to_frame (struct device *d, GdkWindow *); +struct frame *gtk_any_widget_or_parent_to_frame (struct device *d, GtkWidget *widget); +struct frame *decode_gtk_frame (Lisp_Object); +struct device *gtk_any_window_to_device (GdkWindow *); +struct device *decode_gtk_device (Lisp_Object); +void gtk_handle_property_notify (GdkEventProperty *event); + +void signal_special_gtk_user_event (Lisp_Object channel, Lisp_Object function, + Lisp_Object object); +void gtk_redraw_exposed_area (struct frame *f, int x, int y, + int width, int height); +void gtk_output_string (struct window *w, struct display_line *dl, + Emchar_dynarr *buf, int xpos, int xoffset, + int start_pixpos, int width, face_index findex, + int cursor, int cursor_start, int cursor_width, + int cursor_height); +void gtk_output_gdk_pixmap (struct frame *f, struct Lisp_Image_Instance *p, + int x, int y, int clip_x, int clip_y, + int clip_width, int clip_height, int width, + int height, int pixmap_offset, + GdkColor *fg, GdkColor *bg, + GdkGC *override_gc); +void gtk_output_shadows (struct frame *f, int x, int y, int width, + int height, int shadow_thickness); + +int gtk_initialize_frame_menubar (struct frame *f); +void gtk_init_modifier_mapping (struct device *d); + +void Initialize_Locale (void); + +extern Lisp_Object Vgtk_initial_argv_list; /* #### ugh! */ + +const char *gtk_event_name (GdkEventType event_type); +#endif /* HAVE_GTK */ +#endif /* _XEMACS_DEVICE_X_H_ */ diff --git a/src/device-gtk.c b/src/device-gtk.c new file mode 100644 index 0000000..408bc7f --- /dev/null +++ b/src/device-gtk.c @@ -0,0 +1,755 @@ +/* Device functions for X windows. + Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + Copyright (C) 1994, 1995 Free Software Foundation, Inc. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* Original authors: Jamie Zawinski and the FSF */ +/* Rewritten by Ben Wing and Chuck Thompson. */ +/* Gtk flavor written by William Perry */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "gccache-gtk.h" +#include "glyphs-gtk.h" +#include "objects-gtk.h" +#include "gtk-xemacs.h" + +#include "buffer.h" +#include "events.h" +#include "faces.h" +#include "frame.h" +#include "redisplay.h" +#include "sysdep.h" +#include "window.h" +#include "elhash.h" + +#include "sysfile.h" +#include "systime.h" + +#ifdef HAVE_GNOME +#include +#endif + +#ifdef HAVE_BONOBO +#include +#endif + +Lisp_Object Vdefault_gtk_device; + +/* Qdisplay in general.c */ +Lisp_Object Qinit_pre_gtk_win, Qinit_post_gtk_win; + +/* The application class of Emacs. */ +Lisp_Object Vgtk_emacs_application_class; + +Lisp_Object Vgtk_initial_argv_list; /* #### ugh! */ +Lisp_Object Vgtk_initial_geometry; + +static void gtk_device_init_x_specific_cruft (struct device *d); + + +/************************************************************************/ +/* helper functions */ +/************************************************************************/ + +struct device * +decode_gtk_device (Lisp_Object device) +{ + XSETDEVICE (device, decode_device (device)); + CHECK_GTK_DEVICE (device); + return XDEVICE (device); +} + + +/************************************************************************/ +/* initializing a GTK connection */ +/************************************************************************/ +extern Lisp_Object +xemacs_gtk_convert_color(GdkColor *c, GtkWidget *w); + +extern Lisp_Object __get_gtk_font_truename (GdkFont *gdk_font, int expandp); + +#define convert_font(f) __get_gtk_font_truename (f, 0) + +static void +allocate_gtk_device_struct (struct device *d) +{ + d->device_data = xnew_and_zero (struct gtk_device); + DEVICE_GTK_DATA (d)->x_keysym_map_hashtable = Qnil; +} + +static void +gtk_init_device_class (struct device *d) +{ + if (DEVICE_GTK_DEPTH(d) > 2) + { + switch (DEVICE_GTK_VISUAL(d)->type) + { + case GDK_VISUAL_STATIC_GRAY: + case GDK_VISUAL_GRAYSCALE: + DEVICE_CLASS (d) = Qgrayscale; + break; + default: + DEVICE_CLASS (d) = Qcolor; + } + } + else + DEVICE_CLASS (d) = Qmono; +} + +#ifdef HAVE_GDK_IMLIB_INIT +extern void gdk_imlib_init(void); +#endif + +extern void emacs_gtk_selection_handle (GtkWidget *, + GtkSelectionData *selection_data, + guint info, + guint time_stamp, + gpointer data); +extern void emacs_gtk_selection_received (GtkWidget *widget, + GtkSelectionData *selection_data, + gpointer user_data); + +#ifdef HAVE_BONOBO +static CORBA_ORB orb; +#endif + +DEFUN ("gtk-init", Fgtk_init, 1, 1, 0, /* +Initialize the GTK subsystem. +ARGS is a standard list of command-line arguments. + +No effect if called more than once. Called automatically when +creating the first GTK device. Must be called manually from batch +mode. +*/ + (args)) +{ + int argc; + char **argv; + static int done; + + if (done) + { + return (Qt); + } + + make_argc_argv (args, &argc, &argv); + + slow_down_interrupts (); +#ifdef HAVE_GNOME +#ifdef INFODOCK + gnome_init ("InfoDock", EMACS_VERSION, argc, argv); +#else + gnome_init ("XEmacs", EMACS_VERSION, argc, argv); +#endif /* INFODOCK */ +#else + gtk_init (&argc, &argv); +#endif + +#ifdef HAVE_BONOBO + orb = oaf_init (argc, argv); + + if (bonobo_init (orb, NULL, NULL) == FALSE) + { + g_warning ("Could not initialize bonobo..."); + } + + bonobo_activate (); +#endif + + speed_up_interrupts (); + + free_argc_argv (argv); + return (Qt); +} + +static void +gtk_init_device (struct device *d, Lisp_Object props) +{ + Lisp_Object device; + Lisp_Object display; + GtkWidget *app_shell = NULL; + GdkVisual *visual = NULL; + GdkColormap *cmap = NULL; + + XSETDEVICE (device, d); + + /* gtk_init() and even gtk_check_init() are so brain dead that + getting an empty argv array causes them to abort. */ + if (NILP (Vgtk_initial_argv_list)) + { + signal_simple_error ("gtk-initial-argv-list must be set before creating Gtk devices", Vgtk_initial_argv_list); + return; + } + + allocate_gtk_device_struct (d); + display = DEVICE_CONNECTION (d); + + /* Attempt to load a site-specific gtkrc */ + { + Lisp_Object gtkrc = Fexpand_file_name (build_string ("gtkrc"), Vdata_directory); + gchar **default_files = gtk_rc_get_default_files (); + gint num_files; + + if (STRINGP (gtkrc)) + { + /* Found one, load it up! */ + gchar **new_rc_files = NULL; + int ctr; + + for (num_files = 0; default_files[num_files]; num_files++); + + new_rc_files = xnew_array_and_zero (gchar *, num_files + 3); + + new_rc_files[0] = XSTRING_DATA (gtkrc); + for (ctr = 1; default_files[ctr-1]; ctr++) + new_rc_files[ctr] = g_strdup (default_files[ctr-1]); + + gtk_rc_set_default_files (new_rc_files); + + for (ctr = 1; new_rc_files[ctr]; ctr++) + free(new_rc_files[ctr]); + + xfree (new_rc_files); + } + } + + Fgtk_init (Vgtk_initial_argv_list); + +#ifdef __FreeBSD__ + gdk_set_use_xshm (FALSE); +#endif + + /* We attempt to load this file so that the user can set + ** gtk-initial-geometry and not need GNOME & session management to + ** set their default frame size. It also avoids the flicker + ** associated with setting the frame size in your .emacs file. + */ + call4 (Qload, build_string ("~/.xemacs/gtk-options.el"), Qt, Qt, Qt); + +#ifdef HAVE_GDK_IMLIB_INIT + /* Some themes in Gtk are so lame (most notably the Pixmap theme) + that they rely on gdk_imlib, but don't call its initialization + routines. This makes them USELESS for non-gnome applications. + So we bend over backwards to try and make them work. Losers. */ + gdk_imlib_init (); +#endif + + if (NILP (DEVICE_NAME (d))) + DEVICE_NAME (d) = display; + + /* Always search for the best visual */ + visual = gdk_visual_get_best(); + cmap = gdk_colormap_new (visual, TRUE); + + DEVICE_GTK_VISUAL (d) = visual; + DEVICE_GTK_COLORMAP (d) = cmap; + DEVICE_GTK_DEPTH (d) = visual->depth; + + { + GtkWidget *w = gtk_window_new (GTK_WINDOW_TOPLEVEL); + + app_shell = gtk_xemacs_new (NULL); + gtk_container_add (GTK_CONTAINER (w), app_shell); + + gtk_widget_realize (w); + } + + DEVICE_GTK_APP_SHELL (d) = app_shell; + + /* Realize the app_shell so that its window exists for GC creation + purposes */ + gtk_widget_realize (GTK_WIDGET (app_shell)); + + /* Need to set up some selection handlers */ + gtk_selection_add_target (GTK_WIDGET (app_shell), GDK_SELECTION_PRIMARY, + GDK_SELECTION_TYPE_STRING, 0); + + gtk_signal_connect (GTK_OBJECT (app_shell), "selection_get", + GTK_SIGNAL_FUNC (emacs_gtk_selection_handle), NULL); + gtk_signal_connect (GTK_OBJECT (app_shell), "selection_received", + GTK_SIGNAL_FUNC (emacs_gtk_selection_received), NULL); + + DEVICE_GTK_WM_COMMAND_FRAME (d) = Qnil; + + gtk_init_modifier_mapping (d); + + gtk_device_init_x_specific_cruft (d); + + init_baud_rate (d); + init_one_device (d); + + DEVICE_GTK_GC_CACHE (d) = make_gc_cache (GTK_WIDGET (app_shell)); + DEVICE_GTK_GRAY_PIXMAP (d) = NULL; + + gtk_init_device_class (d); + + /* Run the elisp side of the X device initialization. */ + call0 (Qinit_pre_gtk_win); +} + +static void +gtk_finish_init_device (struct device *d, Lisp_Object props) +{ + call0 (Qinit_post_gtk_win); +} + +static void +gtk_mark_device (struct device *d) +{ + mark_object (DEVICE_GTK_WM_COMMAND_FRAME (d)); + mark_object (DEVICE_GTK_DATA (d)->x_keysym_map_hashtable); +} + + +/************************************************************************/ +/* closing an X connection */ +/************************************************************************/ + +static void +free_gtk_device_struct (struct device *d) +{ + xfree (d->device_data); +} + +static void +gtk_delete_device (struct device *d) +{ + Lisp_Object device; + +#ifdef FREE_CHECKING + extern void (*__free_hook)(); + int checking_free; +#endif + + XSETDEVICE (device, d); + if (1) + { +#ifdef FREE_CHECKING + checking_free = (__free_hook != 0); + + /* Disable strict free checking, to avoid bug in X library */ + if (checking_free) + disable_strict_free_check (); +#endif + + free_gc_cache (DEVICE_GTK_GC_CACHE (d)); + +#ifdef FREE_CHECKING + if (checking_free) + enable_strict_free_check (); +#endif + } + + if (EQ (device, Vdefault_gtk_device)) + { + Lisp_Object devcons, concons; + /* #### handle deleting last X device */ + Vdefault_gtk_device = Qnil; + DEVICE_LOOP_NO_BREAK (devcons, concons) + { + if (DEVICE_GTK_P (XDEVICE (XCAR (devcons))) && + !EQ (device, XCAR (devcons))) + { + Vdefault_gtk_device = XCAR (devcons); + goto double_break; + } + } + } + double_break: + free_gtk_device_struct (d); +} + + +/************************************************************************/ +/* handle X errors */ +/************************************************************************/ + +const char * +gtk_event_name (GdkEventType event_type) +{ + GtkEnumValue *vals = gtk_type_enum_get_values (GTK_TYPE_GDK_EVENT_TYPE); + + while (vals && (vals->value != event_type)) vals++; + + if (vals) + return (vals->value_nick); + + return (NULL); +} + + +/************************************************************************/ +/* display information functions */ +/************************************************************************/ + +DEFUN ("default-gtk-device", Fdefault_gtk_device, 0, 0, 0, /* +Return the default GTK device for resourcing. +This is the first-created GTK device that still exists. +*/ + ()) +{ + return Vdefault_gtk_device; +} + +DEFUN ("gtk-display-visual-class", Fgtk_display_visual_class, 0, 1, 0, /* +Return the visual class of the GTK display DEVICE is using. +The returned value will be one of the symbols `static-gray', `gray-scale', +`static-color', `pseudo-color', `true-color', or `direct-color'. +*/ + (device)) +{ + GdkVisual *vis = DEVICE_GTK_VISUAL (decode_gtk_device (device)); + switch (vis->type) + { + case GDK_VISUAL_STATIC_GRAY: return intern ("static-gray"); + case GDK_VISUAL_GRAYSCALE: return intern ("gray-scale"); + case GDK_VISUAL_STATIC_COLOR: return intern ("static-color"); + case GDK_VISUAL_PSEUDO_COLOR: return intern ("pseudo-color"); + case GDK_VISUAL_TRUE_COLOR: return intern ("true-color"); + case GDK_VISUAL_DIRECT_COLOR: return intern ("direct-color"); + default: + error ("display has an unknown visual class"); + return Qnil; /* suppress compiler warning */ + } +} + +DEFUN ("gtk-display-visual-depth", Fgtk_display_visual_depth, 0, 1, 0, /* +Return the bitplane depth of the visual the GTK display DEVICE is using. +*/ + (device)) +{ + return make_int (DEVICE_GTK_DEPTH (decode_gtk_device (device))); +} + +static Lisp_Object +gtk_device_system_metrics (struct device *d, + enum device_metrics m) +{ +#if 0 + GtkStyle *style = gtk_widget_get_style (GTK_WIDGET (DEVICE_GTK_APP_SHELL (d))); + + style = gtk_style_attach (style, w); +#endif + + switch (m) + { + case DM_size_device: + return Fcons (make_int (gdk_screen_width ()), + make_int (gdk_screen_height ())); + case DM_size_device_mm: + return Fcons (make_int (gdk_screen_width_mm ()), + make_int (gdk_screen_height_mm ())); + case DM_num_color_cells: + return make_int (gdk_colormap_get_system_size ()); + case DM_num_bit_planes: + return make_int (DEVICE_GTK_DEPTH (d)); + +#if 0 + case DM_color_default: + case DM_color_select: + case DM_color_balloon: + case DM_color_3d_face: + case DM_color_3d_light: + case DM_color_3d_dark: + case DM_color_menu: + case DM_color_menu_highlight: + case DM_color_menu_button: + case DM_color_menu_disabled: + case DM_color_toolbar: + case DM_color_scrollbar: + case DM_color_desktop: + case DM_color_workspace: + case DM_font_default: + case DM_font_menubar: + case DM_font_dialog: + case DM_size_cursor: + case DM_size_scrollbar: + case DM_size_menu: + case DM_size_toolbar: + case DM_size_toolbar_button: + case DM_size_toolbar_border: + case DM_size_icon: + case DM_size_icon_small: + case DM_size_workspace: + case DM_device_dpi: + case DM_mouse_buttons: + case DM_swap_buttons: + case DM_show_sounds: + case DM_slow_device: + case DM_security: +#endif + default: /* No such device metric property for GTK devices */ + return Qunbound; + } +} + +DEFUN ("gtk-keysym-on-keyboard-p", Fgtk_keysym_on_keyboard_p, 1, 2, 0, /* +Return true if KEYSYM names a key on the keyboard of DEVICE. +More precisely, return true if some keystroke (possibly including modifiers) +on the keyboard of DEVICE keys generates KEYSYM. +Valid keysyms are listed in the files /usr/include/X11/keysymdef.h and in +/usr/lib/X11/XKeysymDB, or whatever the equivalents are on your system. +The keysym name can be provided in two forms: +- if keysym is a string, it must be the name as known to X windows. +- if keysym is a symbol, it must be the name as known to XEmacs. +The two names differ in capitalization and underscoring. +*/ + (keysym, device)) +{ + struct device *d = decode_device (device); + + if (!DEVICE_GTK_P (d)) + signal_simple_error ("Not a GTK device", device); + + return (NILP (Fgethash (keysym, DEVICE_GTK_DATA (d)->x_keysym_map_hashtable, Qnil)) ? + Qnil : Qt); +} + + +/************************************************************************/ +/* grabs and ungrabs */ +/************************************************************************/ + +DEFUN ("gtk-grab-pointer", Fgtk_grab_pointer, 0, 3, 0, /* +Grab the pointer and restrict it to its current window. +If optional DEVICE argument is nil, the default device will be used. +If optional CURSOR argument is non-nil, change the pointer shape to that + until `gtk-ungrab-pointer' is called (it should be an object returned by the + `make-cursor-glyph' function). +If the second optional argument IGNORE-KEYBOARD is non-nil, ignore all + keyboard events during the grab. +Returns t if the grab is successful, nil otherwise. +*/ + (device, cursor, ignore_keyboard)) +{ + GdkWindow *w; + int result; + struct device *d = decode_gtk_device (device); + + if (!NILP (cursor)) + { + CHECK_POINTER_GLYPH (cursor); + cursor = glyph_image_instance (cursor, device, ERROR_ME, 0); + } + + /* We should call gdk_pointer_grab() and (possibly) gdk_keyboard_grab() here instead */ + w = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (device_selected_frame (d))); + + result = gdk_pointer_grab (w, FALSE, + GDK_POINTER_MOTION_MASK | + GDK_POINTER_MOTION_HINT_MASK | + GDK_BUTTON1_MOTION_MASK | + GDK_BUTTON2_MOTION_MASK | + GDK_BUTTON3_MOTION_MASK | + GDK_BUTTON_PRESS_MASK | + GDK_BUTTON_RELEASE_MASK, + w, + NULL, /* #### BILL!!! Need to create a GdkCursor * as necessary! */ + GDK_CURRENT_TIME); + + return (result == 0) ? Qt : Qnil; +} + +DEFUN ("gtk-ungrab-pointer", Fgtk_ungrab_pointer, 0, 1, 0, /* +Release a pointer grab made with `gtk-grab-pointer'. +If optional first arg DEVICE is nil the default device is used. +If it is t the pointer will be released on all GTK devices. +*/ + (device)) +{ + if (!EQ (device, Qt)) + { + gdk_pointer_ungrab (GDK_CURRENT_TIME); + } + else + { + Lisp_Object devcons, concons; + + DEVICE_LOOP_NO_BREAK (devcons, concons) + { + struct device *d = XDEVICE (XCAR (devcons)); + + if (DEVICE_GTK_P (d)) + gdk_pointer_ungrab (GDK_CURRENT_TIME); + } + } + return Qnil; +} + +DEFUN ("gtk-grab-keyboard", Fgtk_grab_keyboard, 0, 1, 0, /* +Grab the keyboard on the given device (defaulting to the selected one). +So long as the keyboard is grabbed, all keyboard events will be delivered +to emacs -- it is not possible for other clients to eavesdrop on them. +Ungrab the keyboard with `gtk-ungrab-keyboard' (use an unwind-protect). +Returns t if the grab is successful, nil otherwise. +*/ + (device)) +{ + struct device *d = decode_gtk_device (device); + GdkWindow *w = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (device_selected_frame (d))); + + gdk_keyboard_grab (w, FALSE, GDK_CURRENT_TIME ); + + return Qt; +} + +DEFUN ("gtk-ungrab-keyboard", Fgtk_ungrab_keyboard, 0, 1, 0, /* +Release a keyboard grab made with `gtk-grab-keyboard'. +*/ + (device)) +{ + gdk_keyboard_ungrab (GDK_CURRENT_TIME); + return Qnil; +} + + +/************************************************************************/ +/* Style Info */ +/************************************************************************/ +DEFUN ("gtk-style-info", Fgtk_style_info, 0, 1, 0, /* +Get the style information for a Gtk device. +*/ + (device)) +{ + struct device *d = decode_device (device); + GtkStyle *style = NULL; + Lisp_Object result = Qnil; + GtkWidget *app_shell = GTK_WIDGET (DEVICE_GTK_APP_SHELL (d)); + GdkWindow *w = GET_GTK_WIDGET_WINDOW (app_shell); + + if (!DEVICE_GTK_P (d)) + return (Qnil); + + style = gtk_widget_get_style (app_shell); + style = gtk_style_attach (style, w); + + if (!style) return (Qnil); + +#define FROB_COLOR(slot, name) \ + result = nconc2 (result, \ + list2 (intern (name), \ + list5 (xemacs_gtk_convert_color (&style->slot[GTK_STATE_NORMAL], app_shell),\ + xemacs_gtk_convert_color (&style->slot[GTK_STATE_ACTIVE], app_shell),\ + xemacs_gtk_convert_color (&style->slot[GTK_STATE_PRELIGHT], app_shell),\ + xemacs_gtk_convert_color (&style->slot[GTK_STATE_SELECTED], app_shell),\ + xemacs_gtk_convert_color (&style->slot[GTK_STATE_INSENSITIVE], app_shell)))) + + FROB_COLOR (fg, "foreground"); + FROB_COLOR (bg, "background"); + FROB_COLOR (light, "light"); + FROB_COLOR (dark, "dark"); + FROB_COLOR (mid, "mid"); + FROB_COLOR (text, "text"); + FROB_COLOR (base, "base"); +#undef FROB_COLOR + + result = nconc2 (result, list2 (Qfont, convert_font (style->font))); + +#define FROB_PIXMAP(state) (style->rc_style->bg_pixmap_name[state] ? build_string (style->rc_style->bg_pixmap_name[state]) : Qnil) + + if (style->rc_style) + result = nconc2 (result, list2 (Qbackground, + list5 ( FROB_PIXMAP (GTK_STATE_NORMAL), + FROB_PIXMAP (GTK_STATE_ACTIVE), + FROB_PIXMAP (GTK_STATE_PRELIGHT), + FROB_PIXMAP (GTK_STATE_SELECTED), + FROB_PIXMAP (GTK_STATE_INSENSITIVE)))); +#undef FROB_PIXMAP + + return (result); +} + +static unsigned int +gtk_device_implementation_flags (void) +{ + return 0; /* XDEVIMPF_PIXEL_GEOMETRY; */ +} + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +syms_of_device_gtk (void) +{ + DEFSUBR (Fdefault_gtk_device); + DEFSUBR (Fgtk_keysym_on_keyboard_p); + DEFSUBR (Fgtk_display_visual_class); + DEFSUBR (Fgtk_display_visual_depth); + DEFSUBR (Fgtk_style_info); + DEFSUBR (Fgtk_grab_pointer); + DEFSUBR (Fgtk_ungrab_pointer); + DEFSUBR (Fgtk_grab_keyboard); + DEFSUBR (Fgtk_ungrab_keyboard); + DEFSUBR (Fgtk_init); + + defsymbol (&Qinit_pre_gtk_win, "init-pre-gtk-win"); + defsymbol (&Qinit_post_gtk_win, "init-post-gtk-win"); +} + +void +console_type_create_device_gtk (void) +{ + CONSOLE_HAS_METHOD (gtk, init_device); + CONSOLE_HAS_METHOD (gtk, finish_init_device); + CONSOLE_HAS_METHOD (gtk, mark_device); + CONSOLE_HAS_METHOD (gtk, delete_device); + CONSOLE_HAS_METHOD (gtk, device_system_metrics); + CONSOLE_HAS_METHOD (gtk, device_implementation_flags); +} + +void +vars_of_device_gtk (void) +{ + Fprovide (Qgtk); + + staticpro (&Vdefault_gtk_device); + + DEFVAR_LISP ("gtk-initial-argv-list", &Vgtk_initial_argv_list /* +You don't want to know. +This is used during startup to communicate the remaining arguments in +`command-line-args-left' to the C code, which passes the args to +the GTK initialization code, which removes some args, and then the +args are placed back into `gtk-initial-arg-list' and thence into +`command-line-args-left'. Perhaps `command-line-args-left' should +just reside in C. +*/ ); + + DEFVAR_LISP ("gtk-initial-geometry", &Vgtk_initial_geometry /* +You don't want to know. +This is used during startup to communicate the default geometry to GTK. +*/ ); + + Vdefault_gtk_device = Qnil; + Vgtk_initial_geometry = Qnil; + Vgtk_initial_argv_list = Qnil; +} + +#include +static void +gtk_device_init_x_specific_cruft (struct device *d) +{ + DEVICE_INFD (d) = DEVICE_OUTFD (d) = ConnectionNumber (GDK_DISPLAY ()); +} diff --git a/src/dialog-gtk.c b/src/dialog-gtk.c new file mode 100644 index 0000000..048d186 --- /dev/null +++ b/src/dialog-gtk.c @@ -0,0 +1,63 @@ +/* Implements elisp-programmable dialog boxes -- Gtk interface. + Copyright (C) 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1995 Tinker Systems and INS Engineering Corp. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "gui-gtk.h" + +#include "buffer.h" +#include "commands.h" /* zmacs_regions */ +#include "events.h" +#include "frame.h" +#include "gui.h" +#include "opaque.h" +#include "window.h" + +Lisp_Object Qgtk_make_dialog_box_internal; + +/* We just bounce up into lisp here... see $(srcdir)/lisp/dialog-gtk.el */ +static Lisp_Object +gtk_make_dialog_box_internal (struct frame* f, Lisp_Object type, Lisp_Object keys) +{ + return (call2 (Qgtk_make_dialog_box_internal, type, keys)); +} + +void +syms_of_dialog_gtk (void) +{ + defsymbol (&Qgtk_make_dialog_box_internal, "gtk-make-dialog-box-internal"); +} + +void +console_type_create_dialog_gtk (void) +{ + CONSOLE_HAS_METHOD (gtk, make_dialog_box_internal); +} + +void +vars_of_dialog_gtk (void) +{ + Fprovide (intern ("gtk-dialogs")); +} diff --git a/src/emacs-marshals.c b/src/emacs-marshals.c new file mode 100644 index 0000000..3ddc7a4 --- /dev/null +++ b/src/emacs-marshals.c @@ -0,0 +1,1597 @@ +#define GTK_VALUE_ARRAY(x) GTK_VALUE_POINTER(x) + +#define GTK_VALUE_LIST(x) GTK_VALUE_POINTER(x) + + +static void +emacs_gtk_marshal_BOOL__OBJECT_INT (ffi_actual_function func, GtkArg *args) +{ + __BOOL_fn rfunc = (__BOOL_fn) func; + gboolean *return_val; + + return_val = GTK_RETLOC_BOOL (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1])); +} + +static void +emacs_gtk_marshal_BOOL__OBJECT_OBJECT_OBJECT (ffi_actual_function func, GtkArg *args) +{ + __BOOL_fn rfunc = (__BOOL_fn) func; + gboolean *return_val; + + return_val = GTK_RETLOC_BOOL (args[3]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_OBJECT (args[2])); +} + +static void +emacs_gtk_marshal_BOOL__OBJECT_OBJECT (ffi_actual_function func, GtkArg *args) +{ + __BOOL_fn rfunc = (__BOOL_fn) func; + gboolean *return_val; + + return_val = GTK_RETLOC_BOOL (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1])); +} + +static void +emacs_gtk_marshal_BOOL__OBJECT_POINTER (ffi_actual_function func, GtkArg *args) +{ + __BOOL_fn rfunc = (__BOOL_fn) func; + gboolean *return_val; + + return_val = GTK_RETLOC_BOOL (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1])); +} + +static void +emacs_gtk_marshal_BOOL__OBJECT_STRING (ffi_actual_function func, GtkArg *args) +{ + __BOOL_fn rfunc = (__BOOL_fn) func; + gboolean *return_val; + + return_val = GTK_RETLOC_BOOL (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1])); +} + +static void +emacs_gtk_marshal_BOOL__OBJECT (ffi_actual_function func, GtkArg *args) +{ + __BOOL_fn rfunc = (__BOOL_fn) func; + gboolean *return_val; + + return_val = GTK_RETLOC_BOOL (args[1]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0])); +} + +static void +emacs_gtk_marshal_BOOL__POINTER_BOOL (ffi_actual_function func, GtkArg *args) +{ + __BOOL_fn rfunc = (__BOOL_fn) func; + gboolean *return_val; + + return_val = GTK_RETLOC_BOOL (args[2]); + *return_val = (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_BOOL (args[1])); +} + +static void +emacs_gtk_marshal_BOOL__POINTER (ffi_actual_function func, GtkArg *args) +{ + __BOOL_fn rfunc = (__BOOL_fn) func; + gboolean *return_val; + + return_val = GTK_RETLOC_BOOL (args[1]); + *return_val = (*rfunc) (GTK_VALUE_POINTER (args[0])); +} + +static void +emacs_gtk_marshal_BOOL__NONE (ffi_actual_function func, GtkArg *args) +{ + __BOOL_fn rfunc = (__BOOL_fn) func; + gboolean *return_val; + + return_val = GTK_RETLOC_BOOL (args[0]); + *return_val = (*rfunc) (); +} +typedef gfloat (*__FLOAT__OBJECT_FLOAT_fn)(GtkObject *, gfloat); + +static void +emacs_gtk_marshal_FLOAT__OBJECT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __FLOAT__OBJECT_FLOAT_fn rfunc = (__FLOAT__OBJECT_FLOAT_fn) func; + gfloat *return_val; + + return_val = GTK_RETLOC_FLOAT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_FLOAT (args[1])); +} + +static void +emacs_gtk_marshal_FLOAT__OBJECT (ffi_actual_function func, GtkArg *args) +{ + __FLOAT_fn rfunc = (__FLOAT_fn) func; + gfloat *return_val; + + return_val = GTK_RETLOC_FLOAT (args[1]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0])); +} + +static void +emacs_gtk_marshal_INT__BOOL (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[1]); + *return_val = (*rfunc) (GTK_VALUE_BOOL (args[0])); +} + +static void +emacs_gtk_marshal_INT__OBJECT_ARRAY (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_ARRAY (args[1])); +} + +static void +emacs_gtk_marshal_INT__OBJECT_INT_ARRAY (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[3]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_ARRAY (args[2])); +} + +static void +emacs_gtk_marshal_INT__OBJECT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[3]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_INT__OBJECT_INT_STRING (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[3]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_STRING (args[2])); +} + +static void +emacs_gtk_marshal_INT__OBJECT_INT (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1])); +} + +static void +emacs_gtk_marshal_INT__OBJECT_OBJECT (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1])); +} + +static void +emacs_gtk_marshal_INT__OBJECT_POINTER_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[4]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3])); +} + +static void +emacs_gtk_marshal_INT__OBJECT_POINTER_INT (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[3]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_INT__OBJECT_POINTER (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1])); +} + +static void +emacs_gtk_marshal_INT__OBJECT_STRING (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1])); +} + +static void +emacs_gtk_marshal_INT__OBJECT (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[1]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0])); +} + +static void +emacs_gtk_marshal_INT__POINTER (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[1]); + *return_val = (*rfunc) (GTK_VALUE_POINTER (args[0])); +} + +static void +emacs_gtk_marshal_INT__STRING_STRING_INT_ARRAY (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[4]); + *return_val = (*rfunc) (GTK_VALUE_STRING (args[0]), GTK_VALUE_STRING (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_ARRAY (args[3])); +} + +static void +emacs_gtk_marshal_INT__STRING (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[1]); + *return_val = (*rfunc) (GTK_VALUE_STRING (args[0])); +} + +static void +emacs_gtk_marshal_INT__NONE (ffi_actual_function func, GtkArg *args) +{ + __INT_fn rfunc = (__INT_fn) func; + guint *return_val; + + return_val = GTK_RETLOC_INT (args[0]); + *return_val = (*rfunc) (); +} + +static void +emacs_gtk_marshal_LIST__OBJECT (ffi_actual_function func, GtkArg *args) +{ + __LIST_fn rfunc = (__LIST_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[1]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0])); +} + +static void +emacs_gtk_marshal_LIST__NONE (ffi_actual_function func, GtkArg *args) +{ + __LIST_fn rfunc = (__LIST_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[0]); + *return_val = (*rfunc) (); +} + +static void +emacs_gtk_marshal_NONE__BOOL (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_BOOL (args[0])); +} + +static void +emacs_gtk_marshal_NONE__INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_INT (args[0]), GTK_VALUE_INT (args[1])); +} + +static void +emacs_gtk_marshal_NONE__INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_INT (args[0])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_BOOL_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_BOOL (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_BOOL (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_BOOL (args[1])); +} +typedef void (*__NONE__OBJECT_FLOAT_FLOAT_FLOAT_BOOL_fn)(GtkObject *, gfloat, gfloat, gfloat, gboolean); + +static void +emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT_FLOAT_BOOL (ffi_actual_function func, GtkArg *args) +{ + __NONE__OBJECT_FLOAT_FLOAT_FLOAT_BOOL_fn rfunc = (__NONE__OBJECT_FLOAT_FLOAT_FLOAT_BOOL_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_FLOAT (args[1]), GTK_VALUE_FLOAT (args[2]), GTK_VALUE_FLOAT (args[3]), GTK_VALUE_BOOL (args[4])); +} +typedef void (*__NONE__OBJECT_FLOAT_FLOAT_FLOAT_FLOAT_fn)(GtkObject *, gfloat, gfloat, gfloat, gfloat); + +static void +emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT_FLOAT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __NONE__OBJECT_FLOAT_FLOAT_FLOAT_FLOAT_fn rfunc = (__NONE__OBJECT_FLOAT_FLOAT_FLOAT_FLOAT_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_FLOAT (args[1]), GTK_VALUE_FLOAT (args[2]), GTK_VALUE_FLOAT (args[3]), GTK_VALUE_FLOAT (args[4])); +} +typedef void (*__NONE__OBJECT_FLOAT_FLOAT_FLOAT_fn)(GtkObject *, gfloat, gfloat, gfloat); + +static void +emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __NONE__OBJECT_FLOAT_FLOAT_FLOAT_fn rfunc = (__NONE__OBJECT_FLOAT_FLOAT_FLOAT_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_FLOAT (args[1]), GTK_VALUE_FLOAT (args[2]), GTK_VALUE_FLOAT (args[3])); +} +typedef void (*__NONE__OBJECT_FLOAT_FLOAT_fn)(GtkObject *, gfloat, gfloat); + +static void +emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __NONE__OBJECT_FLOAT_FLOAT_fn rfunc = (__NONE__OBJECT_FLOAT_FLOAT_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_FLOAT (args[1]), GTK_VALUE_FLOAT (args[2])); +} +typedef void (*__NONE__OBJECT_FLOAT_fn)(GtkObject *, gfloat); + +static void +emacs_gtk_marshal_NONE__OBJECT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __NONE__OBJECT_FLOAT_fn rfunc = (__NONE__OBJECT_FLOAT_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_FLOAT (args[1])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_BOOL (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_BOOL (args[2])); +} +typedef void (*__NONE__OBJECT_INT_FLOAT_BOOL_fn)(GtkObject *, guint, gfloat, gboolean); + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_FLOAT_BOOL (ffi_actual_function func, GtkArg *args) +{ + __NONE__OBJECT_INT_FLOAT_BOOL_fn rfunc = (__NONE__OBJECT_INT_FLOAT_BOOL_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_FLOAT (args[2]), GTK_VALUE_BOOL (args[3])); +} +typedef void (*__NONE__OBJECT_INT_FLOAT_fn)(GtkObject *, guint, gfloat); + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __NONE__OBJECT_INT_FLOAT_fn rfunc = (__NONE__OBJECT_INT_FLOAT_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_FLOAT (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_INT_ARRAY_ARRAY_ARRAY_ARRAY_ARRAY_ARRAY (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_ARRAY (args[3]), GTK_VALUE_ARRAY (args[4]), GTK_VALUE_ARRAY (args[5]), GTK_VALUE_ARRAY (args[6]), GTK_VALUE_ARRAY (args[7]), GTK_VALUE_ARRAY (args[8])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_INT_ARRAY (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_ARRAY (args[3])); +} +typedef void (*__NONE__OBJECT_INT_INT_FLOAT_FLOAT_fn)(GtkObject *, guint, guint, gfloat, gfloat); + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_INT_FLOAT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __NONE__OBJECT_INT_INT_FLOAT_FLOAT_fn rfunc = (__NONE__OBJECT_INT_INT_FLOAT_FLOAT_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_FLOAT (args[3]), GTK_VALUE_FLOAT (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_INT_POINTER_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_POINTER (args[3]), GTK_VALUE_POINTER (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_INT_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_POINTER (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_INT_STRING_INT_POINTER_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_STRING (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_POINTER (args[5]), GTK_VALUE_POINTER (args[6])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_INT_STRING (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_STRING (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_OBJECT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_OBJECT (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_POINTER (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT_STRING (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_STRING (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_LIST_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_LIST (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_LIST (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_LIST (args[1])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_BOOL_BOOL_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_BOOL (args[2]), GTK_VALUE_BOOL (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_BOOL_BOOL_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_BOOL (args[2]), GTK_VALUE_BOOL (args[3]), GTK_VALUE_INT (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_BOOL_BOOL (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_BOOL (args[2]), GTK_VALUE_BOOL (args[3])); +} +typedef void (*__NONE__OBJECT_OBJECT_FLOAT_INT_fn)(GtkObject *, GtkObject *, gfloat, guint); + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_FLOAT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE__OBJECT_OBJECT_FLOAT_INT_fn rfunc = (__NONE__OBJECT_OBJECT_FLOAT_INT_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_FLOAT (args[2]), GTK_VALUE_INT (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT_INT_INT_INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5]), GTK_VALUE_INT (args[6]), GTK_VALUE_INT (args[7]), GTK_VALUE_INT (args[8]), GTK_VALUE_INT (args[9])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_OBJECT (args[2]), GTK_VALUE_INT (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_OBJECT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_OBJECT (args[2]), GTK_VALUE_OBJECT (args[3]), GTK_VALUE_INT (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_OBJECT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_OBJECT (args[2]), GTK_VALUE_OBJECT (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_POINTER_POINTER_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_OBJECT (args[2]), GTK_VALUE_POINTER (args[3]), GTK_VALUE_POINTER (args[4]), GTK_VALUE_INT (args[5]), GTK_VALUE_INT (args[6])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_OBJECT (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_POINTER (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING_INT_INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_STRING (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5]), GTK_VALUE_INT (args[6]), GTK_VALUE_INT (args[7])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING_STRING_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_STRING (args[2]), GTK_VALUE_STRING (args[3]), GTK_VALUE_INT (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING_STRING (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_STRING (args[2]), GTK_VALUE_STRING (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1]), GTK_VALUE_STRING (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_OBJECT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_BOOL (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_BOOL (args[2])); +} +typedef void (*__NONE__OBJECT_POINTER_INT_FLOAT_FLOAT_fn)(GtkObject *, void *, guint, gfloat, gfloat); + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_FLOAT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __NONE__OBJECT_POINTER_INT_FLOAT_FLOAT_fn rfunc = (__NONE__OBJECT_POINTER_INT_FLOAT_FLOAT_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_FLOAT (args[3]), GTK_VALUE_FLOAT (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_POINTER_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_POINTER (args[3]), GTK_VALUE_POINTER (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_POINTER (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_STRING_INT_POINTER_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_STRING (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_POINTER (args[5]), GTK_VALUE_POINTER (args[6])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_STRING (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_STRING (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER_POINTER_STRING_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_POINTER (args[2]), GTK_VALUE_POINTER (args[3]), GTK_VALUE_STRING (args[4]), GTK_VALUE_INT (args[5])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_POINTER (args[2]), GTK_VALUE_POINTER (args[3])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_POINTER (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_STRING_INT_POINTER_POINTER_POINTER_POINTER_BOOL_BOOL (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_STRING (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_POINTER (args[4]), GTK_VALUE_POINTER (args[5]), GTK_VALUE_POINTER (args[6]), GTK_VALUE_POINTER (args[7]), GTK_VALUE_BOOL (args[8]), GTK_VALUE_BOOL (args[9])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_STRING_BOOL (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1]), GTK_VALUE_BOOL (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_STRING_POINTER_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1]), GTK_VALUE_POINTER (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_STRING_POINTER_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1]), GTK_VALUE_POINTER (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_STRING_STRING (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1]), GTK_VALUE_STRING (args[2])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_STRING (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0])); +} + +static void +emacs_gtk_marshal_NONE__POINTER_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_INT (args[1])); +} + +static void +emacs_gtk_marshal_NONE__POINTER_POINTER_BOOL_INT_INT_INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_BOOL (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5]), GTK_VALUE_INT (args[6]), GTK_VALUE_INT (args[7]), GTK_VALUE_INT (args[8])); +} + +static void +emacs_gtk_marshal_NONE__POINTER_POINTER_BOOL_INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_BOOL (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5]), GTK_VALUE_INT (args[6])); +} + +static void +emacs_gtk_marshal_NONE__POINTER_POINTER_INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5])); +} + +static void +emacs_gtk_marshal_NONE__POINTER_POINTER_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3])); +} + +static void +emacs_gtk_marshal_NONE__POINTER_POINTER_POINTER_INT_INT_STRING_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_POINTER (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_STRING (args[5]), GTK_VALUE_INT (args[6])); +} + +static void +emacs_gtk_marshal_NONE__POINTER_POINTER_POINTER_INT_INT_STRING (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_POINTER (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_STRING (args[5])); +} + +static void +emacs_gtk_marshal_NONE__POINTER_POINTER_POINTER_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_POINTER (args[2]), GTK_VALUE_POINTER (args[3])); +} + +static void +emacs_gtk_marshal_NONE__POINTER_POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_POINTER (args[1])); +} + +static void +emacs_gtk_marshal_NONE__POINTER_STRING (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_STRING (args[1])); +} + +static void +emacs_gtk_marshal_NONE__POINTER (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_POINTER (args[0])); +} + +static void +emacs_gtk_marshal_NONE__NONE (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (); +} + +static void +emacs_gtk_marshal_OBJECT__BOOL_BOOL_INT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[3]); + *return_val = (*rfunc) (GTK_VALUE_BOOL (args[0]), GTK_VALUE_BOOL (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_OBJECT__BOOL_INT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_BOOL (args[0]), GTK_VALUE_INT (args[1])); +} +typedef GtkObject * (*__OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_fn)(gfloat, gfloat, gfloat, gfloat, gfloat, gfloat); + +static void +emacs_gtk_marshal_OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_fn rfunc = (__OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[6]); + *return_val = (*rfunc) (GTK_VALUE_FLOAT (args[0]), GTK_VALUE_FLOAT (args[1]), GTK_VALUE_FLOAT (args[2]), GTK_VALUE_FLOAT (args[3]), GTK_VALUE_FLOAT (args[4]), GTK_VALUE_FLOAT (args[5])); +} +typedef GtkObject * (*__OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_fn)(gfloat, gfloat, gfloat, gfloat, gfloat); + +static void +emacs_gtk_marshal_OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_fn rfunc = (__OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[5]); + *return_val = (*rfunc) (GTK_VALUE_FLOAT (args[0]), GTK_VALUE_FLOAT (args[1]), GTK_VALUE_FLOAT (args[2]), GTK_VALUE_FLOAT (args[3]), GTK_VALUE_FLOAT (args[4])); +} +typedef GtkObject * (*__OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_fn)(gfloat, gfloat, gfloat, gfloat); + +static void +emacs_gtk_marshal_OBJECT__FLOAT_FLOAT_FLOAT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_fn rfunc = (__OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[4]); + *return_val = (*rfunc) (GTK_VALUE_FLOAT (args[0]), GTK_VALUE_FLOAT (args[1]), GTK_VALUE_FLOAT (args[2]), GTK_VALUE_FLOAT (args[3])); +} + +static void +emacs_gtk_marshal_OBJECT__INT_ARRAY (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0]), GTK_VALUE_ARRAY (args[1])); +} + +static void +emacs_gtk_marshal_OBJECT__INT_BOOL_BOOL (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[3]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0]), GTK_VALUE_BOOL (args[1]), GTK_VALUE_BOOL (args[2])); +} + +static void +emacs_gtk_marshal_OBJECT__INT_INT_ARRAY (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[3]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_ARRAY (args[2])); +} + +static void +emacs_gtk_marshal_OBJECT__INT_INT_BOOL (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[3]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_BOOL (args[2])); +} + +static void +emacs_gtk_marshal_OBJECT__INT_INT_STRING (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[3]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_STRING (args[2])); +} + +static void +emacs_gtk_marshal_OBJECT__INT_INT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0]), GTK_VALUE_INT (args[1])); +} + +static void +emacs_gtk_marshal_OBJECT__INT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[1]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0])); +} +typedef GtkObject * (*__OBJECT__OBJECT_FLOAT_INT_fn)(GtkObject *, gfloat, guint); + +static void +emacs_gtk_marshal_OBJECT__OBJECT_FLOAT_INT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT__OBJECT_FLOAT_INT_fn rfunc = (__OBJECT__OBJECT_FLOAT_INT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[3]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_FLOAT (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_OBJECT__OBJECT_INT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1])); +} + +static void +emacs_gtk_marshal_OBJECT__OBJECT_OBJECT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_OBJECT (args[1])); +} + +static void +emacs_gtk_marshal_OBJECT__OBJECT_STRING_INT_INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[7]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5]), GTK_VALUE_INT (args[6])); +} + +static void +emacs_gtk_marshal_OBJECT__OBJECT_STRING_INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[6]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5])); +} + +static void +emacs_gtk_marshal_OBJECT__OBJECT_STRING_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[4]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3])); +} + +static void +emacs_gtk_marshal_OBJECT__OBJECT_STRING (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1])); +} + +static void +emacs_gtk_marshal_OBJECT__OBJECT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[1]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0])); +} + +static void +emacs_gtk_marshal_OBJECT__POINTER_POINTER (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_POINTER (args[1])); +} + +static void +emacs_gtk_marshal_OBJECT__POINTER_STRING (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_POINTER (args[0]), GTK_VALUE_STRING (args[1])); +} + +static void +emacs_gtk_marshal_OBJECT__POINTER (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[1]); + *return_val = (*rfunc) (GTK_VALUE_POINTER (args[0])); +} +typedef GtkObject * (*__OBJECT__STRING_FLOAT_FLOAT_FLOAT_BOOL_fn)(gchar *, gfloat, gfloat, gfloat, gboolean); + +static void +emacs_gtk_marshal_OBJECT__STRING_FLOAT_FLOAT_FLOAT_BOOL (ffi_actual_function func, GtkArg *args) +{ + __OBJECT__STRING_FLOAT_FLOAT_FLOAT_BOOL_fn rfunc = (__OBJECT__STRING_FLOAT_FLOAT_FLOAT_BOOL_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[5]); + *return_val = (*rfunc) (GTK_VALUE_STRING (args[0]), GTK_VALUE_FLOAT (args[1]), GTK_VALUE_FLOAT (args[2]), GTK_VALUE_FLOAT (args[3]), GTK_VALUE_BOOL (args[4])); +} + +static void +emacs_gtk_marshal_OBJECT__STRING_INT_STRING_STRING (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[4]); + *return_val = (*rfunc) (GTK_VALUE_STRING (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_STRING (args[2]), GTK_VALUE_STRING (args[3])); +} + +static void +emacs_gtk_marshal_OBJECT__STRING_OBJECT (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_STRING (args[0]), GTK_VALUE_OBJECT (args[1])); +} + +static void +emacs_gtk_marshal_OBJECT__STRING_STRING_STRING_ARRAY_STRING_STRING (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[6]); + *return_val = (*rfunc) (GTK_VALUE_STRING (args[0]), GTK_VALUE_STRING (args[1]), GTK_VALUE_STRING (args[2]), GTK_VALUE_ARRAY (args[3]), GTK_VALUE_STRING (args[4]), GTK_VALUE_STRING (args[5])); +} + +static void +emacs_gtk_marshal_OBJECT__STRING_STRING (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[2]); + *return_val = (*rfunc) (GTK_VALUE_STRING (args[0]), GTK_VALUE_STRING (args[1])); +} + +static void +emacs_gtk_marshal_OBJECT__STRING (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[1]); + *return_val = (*rfunc) (GTK_VALUE_STRING (args[0])); +} + +static void +emacs_gtk_marshal_OBJECT__NONE (ffi_actual_function func, GtkArg *args) +{ + __OBJECT_fn rfunc = (__OBJECT_fn) func; + GtkObject * *return_val; + + return_val = GTK_RETLOC_OBJECT (args[0]); + *return_val = (*rfunc) (); +} + +static void +emacs_gtk_marshal_POINTER__INT_INT (ffi_actual_function func, GtkArg *args) +{ + __POINTER_fn rfunc = (__POINTER_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[2]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0]), GTK_VALUE_INT (args[1])); +} + +static void +emacs_gtk_marshal_POINTER__INT (ffi_actual_function func, GtkArg *args) +{ + __POINTER_fn rfunc = (__POINTER_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[1]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0])); +} + +static void +emacs_gtk_marshal_POINTER__OBJECT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __POINTER_fn rfunc = (__POINTER_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[3]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_POINTER__OBJECT_INT (ffi_actual_function func, GtkArg *args) +{ + __POINTER_fn rfunc = (__POINTER_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1])); +} + +static void +emacs_gtk_marshal_POINTER__OBJECT_POINTER_INT (ffi_actual_function func, GtkArg *args) +{ + __POINTER_fn rfunc = (__POINTER_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[3]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_POINTER__OBJECT_POINTER_POINTER_ARRAY_INT_POINTER_POINTER_POINTER_POINTER_BOOL_BOOL (ffi_actual_function func, GtkArg *args) +{ + __POINTER_fn rfunc = (__POINTER_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[11]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_POINTER (args[2]), GTK_VALUE_ARRAY (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_POINTER (args[5]), GTK_VALUE_POINTER (args[6]), GTK_VALUE_POINTER (args[7]), GTK_VALUE_POINTER (args[8]), GTK_VALUE_BOOL (args[9]), GTK_VALUE_BOOL (args[10])); +} + +static void +emacs_gtk_marshal_POINTER__OBJECT_POINTER (ffi_actual_function func, GtkArg *args) +{ + __POINTER_fn rfunc = (__POINTER_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1])); +} + +static void +emacs_gtk_marshal_POINTER__OBJECT (ffi_actual_function func, GtkArg *args) +{ + __POINTER_fn rfunc = (__POINTER_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[1]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0])); +} + +static void +emacs_gtk_marshal_POINTER__POINTER (ffi_actual_function func, GtkArg *args) +{ + __POINTER_fn rfunc = (__POINTER_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[1]); + *return_val = (*rfunc) (GTK_VALUE_POINTER (args[0])); +} + +static void +emacs_gtk_marshal_POINTER__NONE (ffi_actual_function func, GtkArg *args) +{ + __POINTER_fn rfunc = (__POINTER_fn) func; + void * *return_val; + + return_val = GTK_RETLOC_POINTER (args[0]); + *return_val = (*rfunc) (); +} + +static void +emacs_gtk_marshal_STRING__INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __STRING_fn rfunc = (__STRING_fn) func; + gchar * *return_val; + + return_val = GTK_RETLOC_STRING (args[3]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_STRING__INT (ffi_actual_function func, GtkArg *args) +{ + __STRING_fn rfunc = (__STRING_fn) func; + gchar * *return_val; + + return_val = GTK_RETLOC_STRING (args[1]); + *return_val = (*rfunc) (GTK_VALUE_INT (args[0])); +} + +static void +emacs_gtk_marshal_STRING__OBJECT_BOOL (ffi_actual_function func, GtkArg *args) +{ + __STRING_fn rfunc = (__STRING_fn) func; + gchar * *return_val; + + return_val = GTK_RETLOC_STRING (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_BOOL (args[1])); +} +typedef gchar * (*__STRING__OBJECT_FLOAT_fn)(GtkObject *, gfloat); + +static void +emacs_gtk_marshal_STRING__OBJECT_FLOAT (ffi_actual_function func, GtkArg *args) +{ + __STRING__OBJECT_FLOAT_fn rfunc = (__STRING__OBJECT_FLOAT_fn) func; + gchar * *return_val; + + return_val = GTK_RETLOC_STRING (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_FLOAT (args[1])); +} + +static void +emacs_gtk_marshal_STRING__OBJECT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __STRING_fn rfunc = (__STRING_fn) func; + gchar * *return_val; + + return_val = GTK_RETLOC_STRING (args[3]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2])); +} + +static void +emacs_gtk_marshal_STRING__OBJECT_INT (ffi_actual_function func, GtkArg *args) +{ + __STRING_fn rfunc = (__STRING_fn) func; + gchar * *return_val; + + return_val = GTK_RETLOC_STRING (args[2]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_INT (args[1])); +} + +static void +emacs_gtk_marshal_STRING__OBJECT (ffi_actual_function func, GtkArg *args) +{ + __STRING_fn rfunc = (__STRING_fn) func; + gchar * *return_val; + + return_val = GTK_RETLOC_STRING (args[1]); + *return_val = (*rfunc) (GTK_VALUE_OBJECT (args[0])); +} + +static void +emacs_gtk_marshal_STRING__NONE (ffi_actual_function func, GtkArg *args) +{ + __STRING_fn rfunc = (__STRING_fn) func; + gchar * *return_val; + + return_val = GTK_RETLOC_STRING (args[0]); + *return_val = (*rfunc) (); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER_INT_INT_INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_POINTER (args[1]), GTK_VALUE_POINTER (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4]), GTK_VALUE_INT (args[5]), GTK_VALUE_INT (args[6]), GTK_VALUE_INT (args[7]), GTK_VALUE_INT (args[8])); +} + +static void +emacs_gtk_marshal_NONE__OBJECT_STRING_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_OBJECT (args[0]), GTK_VALUE_STRING (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3]), GTK_VALUE_INT (args[4])); +} + +static void +emacs_gtk_marshal_NONE__INT_INT_INT_INT (ffi_actual_function func, GtkArg *args) +{ + __NONE_fn rfunc = (__NONE_fn) func; + (*rfunc) (GTK_VALUE_INT (args[0]), GTK_VALUE_INT (args[1]), GTK_VALUE_INT (args[2]), GTK_VALUE_INT (args[3])); +} + + +#include "hash.h" +static struct hash_table * marshaller_hashtable; + +extern unsigned long string_hash (const char *xv); + +static int +our_string_eq (const void *st1, const void *st2) +{ + if (!st1) + return st2 ? 0 : 1; + else if (!st2) + return 0; + else + return !strcmp ( (const char *) st1, (const char *) st2); +} + +unsigned long +our_string_hash (const void *xv) +{ + unsigned int h = 0; + unsigned const char *x = (unsigned const char *) xv; + + if (!x) return 0; + + while (*x) + { + unsigned int g; + h = (h << 4) + *x++; + if ((g = h & 0xf0000000) != 0) + h = (h ^ (g >> 24)) ^ g; + } + + return h; +} + +static void initialize_marshaller_storage (void) +{ + if (!marshaller_hashtable) + { + marshaller_hashtable = make_general_hash_table (100, our_string_hash, our_string_eq); + puthash ("emacs_gtk_marshal_BOOL__OBJECT_INT", (void *) emacs_gtk_marshal_BOOL__OBJECT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_BOOL__OBJECT_OBJECT_OBJECT", (void *) emacs_gtk_marshal_BOOL__OBJECT_OBJECT_OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_BOOL__OBJECT_OBJECT", (void *) emacs_gtk_marshal_BOOL__OBJECT_OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_BOOL__OBJECT_POINTER", (void *) emacs_gtk_marshal_BOOL__OBJECT_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_BOOL__OBJECT_STRING", (void *) emacs_gtk_marshal_BOOL__OBJECT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_BOOL__OBJECT", (void *) emacs_gtk_marshal_BOOL__OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_BOOL__POINTER_BOOL", (void *) emacs_gtk_marshal_BOOL__POINTER_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_BOOL__POINTER", (void *) emacs_gtk_marshal_BOOL__POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_BOOL__NONE", (void *) emacs_gtk_marshal_BOOL__NONE, marshaller_hashtable); + puthash ("emacs_gtk_marshal_FLOAT__OBJECT_FLOAT", (void *) emacs_gtk_marshal_FLOAT__OBJECT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_FLOAT__OBJECT", (void *) emacs_gtk_marshal_FLOAT__OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__BOOL", (void *) emacs_gtk_marshal_INT__BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT_ARRAY", (void *) emacs_gtk_marshal_INT__OBJECT_ARRAY, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT_INT_ARRAY", (void *) emacs_gtk_marshal_INT__OBJECT_INT_ARRAY, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT_INT_INT", (void *) emacs_gtk_marshal_INT__OBJECT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT_INT_STRING", (void *) emacs_gtk_marshal_INT__OBJECT_INT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT_INT", (void *) emacs_gtk_marshal_INT__OBJECT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT_OBJECT", (void *) emacs_gtk_marshal_INT__OBJECT_OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT_POINTER_INT_INT", (void *) emacs_gtk_marshal_INT__OBJECT_POINTER_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT_POINTER_INT", (void *) emacs_gtk_marshal_INT__OBJECT_POINTER_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT_POINTER", (void *) emacs_gtk_marshal_INT__OBJECT_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT_STRING", (void *) emacs_gtk_marshal_INT__OBJECT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__OBJECT", (void *) emacs_gtk_marshal_INT__OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__POINTER", (void *) emacs_gtk_marshal_INT__POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__STRING_STRING_INT_ARRAY", (void *) emacs_gtk_marshal_INT__STRING_STRING_INT_ARRAY, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__STRING", (void *) emacs_gtk_marshal_INT__STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_INT__NONE", (void *) emacs_gtk_marshal_INT__NONE, marshaller_hashtable); + puthash ("emacs_gtk_marshal_LIST__OBJECT", (void *) emacs_gtk_marshal_LIST__OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_LIST__NONE", (void *) emacs_gtk_marshal_LIST__NONE, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__BOOL", (void *) emacs_gtk_marshal_NONE__BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__INT_INT", (void *) emacs_gtk_marshal_NONE__INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__INT", (void *) emacs_gtk_marshal_NONE__INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_BOOL_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_BOOL_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_BOOL", (void *) emacs_gtk_marshal_NONE__OBJECT_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT_FLOAT_BOOL", (void *) emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT_FLOAT_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT_FLOAT_FLOAT", (void *) emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT_FLOAT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT_FLOAT", (void *) emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT", (void *) emacs_gtk_marshal_NONE__OBJECT_FLOAT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_FLOAT", (void *) emacs_gtk_marshal_NONE__OBJECT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_BOOL", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_FLOAT_BOOL", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_FLOAT_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_FLOAT", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_INT_ARRAY_ARRAY_ARRAY_ARRAY_ARRAY_ARRAY", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_INT_ARRAY_ARRAY_ARRAY_ARRAY_ARRAY_ARRAY, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_INT_ARRAY", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_INT_ARRAY, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_INT_FLOAT_FLOAT", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_INT_FLOAT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_INT_POINTER_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_INT_POINTER_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_INT_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_INT_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_INT_STRING_INT_POINTER_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_INT_STRING_INT_POINTER_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_INT_STRING", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_INT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_OBJECT", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT_STRING", (void *) emacs_gtk_marshal_NONE__OBJECT_INT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_LIST_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_LIST_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_LIST", (void *) emacs_gtk_marshal_NONE__OBJECT_LIST, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_BOOL_BOOL_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_BOOL_BOOL_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_BOOL_BOOL_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_BOOL_BOOL_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_BOOL_BOOL", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_BOOL_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_FLOAT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_FLOAT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT_INT_INT_INT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT_INT_INT_INT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_OBJECT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_OBJECT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_OBJECT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_POINTER_POINTER_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT_POINTER_POINTER_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING_INT_INT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING_INT_INT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING_STRING_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING_STRING_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING_STRING", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_OBJECT", (void *) emacs_gtk_marshal_NONE__OBJECT_OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_BOOL", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_FLOAT_FLOAT", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_FLOAT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_POINTER_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_POINTER_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_STRING_INT_POINTER_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_STRING_INT_POINTER_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_STRING", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_INT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER_POINTER_STRING_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER_POINTER_STRING_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_STRING_INT_POINTER_POINTER_POINTER_POINTER_BOOL_BOOL", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_STRING_INT_POINTER_POINTER_POINTER_POINTER_BOOL_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_STRING_BOOL", (void *) emacs_gtk_marshal_NONE__OBJECT_STRING_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_STRING_POINTER_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_STRING_POINTER_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_STRING_POINTER_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_STRING_POINTER_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_STRING_STRING", (void *) emacs_gtk_marshal_NONE__OBJECT_STRING_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_STRING", (void *) emacs_gtk_marshal_NONE__OBJECT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT", (void *) emacs_gtk_marshal_NONE__OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER_INT", (void *) emacs_gtk_marshal_NONE__POINTER_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER_POINTER_BOOL_INT_INT_INT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__POINTER_POINTER_BOOL_INT_INT_INT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER_POINTER_BOOL_INT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__POINTER_POINTER_BOOL_INT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER_POINTER_INT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__POINTER_POINTER_INT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER_POINTER_INT_INT", (void *) emacs_gtk_marshal_NONE__POINTER_POINTER_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER_POINTER_POINTER_INT_INT_STRING_INT", (void *) emacs_gtk_marshal_NONE__POINTER_POINTER_POINTER_INT_INT_STRING_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER_POINTER_POINTER_INT_INT_STRING", (void *) emacs_gtk_marshal_NONE__POINTER_POINTER_POINTER_INT_INT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER_POINTER_POINTER_POINTER", (void *) emacs_gtk_marshal_NONE__POINTER_POINTER_POINTER_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER_POINTER", (void *) emacs_gtk_marshal_NONE__POINTER_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER_STRING", (void *) emacs_gtk_marshal_NONE__POINTER_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__POINTER", (void *) emacs_gtk_marshal_NONE__POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__NONE", (void *) emacs_gtk_marshal_NONE__NONE, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__BOOL_BOOL_INT", (void *) emacs_gtk_marshal_OBJECT__BOOL_BOOL_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__BOOL_INT", (void *) emacs_gtk_marshal_OBJECT__BOOL_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_FLOAT", (void *) emacs_gtk_marshal_OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT", (void *) emacs_gtk_marshal_OBJECT__FLOAT_FLOAT_FLOAT_FLOAT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__FLOAT_FLOAT_FLOAT_FLOAT", (void *) emacs_gtk_marshal_OBJECT__FLOAT_FLOAT_FLOAT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__INT_ARRAY", (void *) emacs_gtk_marshal_OBJECT__INT_ARRAY, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__INT_BOOL_BOOL", (void *) emacs_gtk_marshal_OBJECT__INT_BOOL_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__INT_INT_ARRAY", (void *) emacs_gtk_marshal_OBJECT__INT_INT_ARRAY, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__INT_INT_BOOL", (void *) emacs_gtk_marshal_OBJECT__INT_INT_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__INT_INT_STRING", (void *) emacs_gtk_marshal_OBJECT__INT_INT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__INT_INT", (void *) emacs_gtk_marshal_OBJECT__INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__INT", (void *) emacs_gtk_marshal_OBJECT__INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__OBJECT_FLOAT_INT", (void *) emacs_gtk_marshal_OBJECT__OBJECT_FLOAT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__OBJECT_INT", (void *) emacs_gtk_marshal_OBJECT__OBJECT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__OBJECT_OBJECT", (void *) emacs_gtk_marshal_OBJECT__OBJECT_OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__OBJECT_STRING_INT_INT_INT_INT_INT", (void *) emacs_gtk_marshal_OBJECT__OBJECT_STRING_INT_INT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__OBJECT_STRING_INT_INT_INT_INT", (void *) emacs_gtk_marshal_OBJECT__OBJECT_STRING_INT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__OBJECT_STRING_INT_INT", (void *) emacs_gtk_marshal_OBJECT__OBJECT_STRING_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__OBJECT_STRING", (void *) emacs_gtk_marshal_OBJECT__OBJECT_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__OBJECT", (void *) emacs_gtk_marshal_OBJECT__OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__POINTER_POINTER", (void *) emacs_gtk_marshal_OBJECT__POINTER_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__POINTER_STRING", (void *) emacs_gtk_marshal_OBJECT__POINTER_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__POINTER", (void *) emacs_gtk_marshal_OBJECT__POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__STRING_FLOAT_FLOAT_FLOAT_BOOL", (void *) emacs_gtk_marshal_OBJECT__STRING_FLOAT_FLOAT_FLOAT_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__STRING_INT_STRING_STRING", (void *) emacs_gtk_marshal_OBJECT__STRING_INT_STRING_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__STRING_OBJECT", (void *) emacs_gtk_marshal_OBJECT__STRING_OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__STRING_STRING_STRING_ARRAY_STRING_STRING", (void *) emacs_gtk_marshal_OBJECT__STRING_STRING_STRING_ARRAY_STRING_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__STRING_STRING", (void *) emacs_gtk_marshal_OBJECT__STRING_STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__STRING", (void *) emacs_gtk_marshal_OBJECT__STRING, marshaller_hashtable); + puthash ("emacs_gtk_marshal_OBJECT__NONE", (void *) emacs_gtk_marshal_OBJECT__NONE, marshaller_hashtable); + puthash ("emacs_gtk_marshal_POINTER__INT_INT", (void *) emacs_gtk_marshal_POINTER__INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_POINTER__INT", (void *) emacs_gtk_marshal_POINTER__INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_POINTER__OBJECT_INT_INT", (void *) emacs_gtk_marshal_POINTER__OBJECT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_POINTER__OBJECT_INT", (void *) emacs_gtk_marshal_POINTER__OBJECT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_POINTER__OBJECT_POINTER_INT", (void *) emacs_gtk_marshal_POINTER__OBJECT_POINTER_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_POINTER__OBJECT_POINTER_POINTER_ARRAY_INT_POINTER_POINTER_POINTER_POINTER_BOOL_BOOL", (void *) emacs_gtk_marshal_POINTER__OBJECT_POINTER_POINTER_ARRAY_INT_POINTER_POINTER_POINTER_POINTER_BOOL_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_POINTER__OBJECT_POINTER", (void *) emacs_gtk_marshal_POINTER__OBJECT_POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_POINTER__OBJECT", (void *) emacs_gtk_marshal_POINTER__OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_POINTER__POINTER", (void *) emacs_gtk_marshal_POINTER__POINTER, marshaller_hashtable); + puthash ("emacs_gtk_marshal_POINTER__NONE", (void *) emacs_gtk_marshal_POINTER__NONE, marshaller_hashtable); + puthash ("emacs_gtk_marshal_STRING__INT_INT_INT", (void *) emacs_gtk_marshal_STRING__INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_STRING__INT", (void *) emacs_gtk_marshal_STRING__INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_STRING__OBJECT_BOOL", (void *) emacs_gtk_marshal_STRING__OBJECT_BOOL, marshaller_hashtable); + puthash ("emacs_gtk_marshal_STRING__OBJECT_FLOAT", (void *) emacs_gtk_marshal_STRING__OBJECT_FLOAT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_STRING__OBJECT_INT_INT", (void *) emacs_gtk_marshal_STRING__OBJECT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_STRING__OBJECT_INT", (void *) emacs_gtk_marshal_STRING__OBJECT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_STRING__OBJECT", (void *) emacs_gtk_marshal_STRING__OBJECT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_STRING__NONE", (void *) emacs_gtk_marshal_STRING__NONE, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER_INT_INT_INT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_POINTER_POINTER_INT_INT_INT_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__OBJECT_STRING_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__OBJECT_STRING_INT_INT_INT, marshaller_hashtable); + puthash ("emacs_gtk_marshal_NONE__INT_INT_INT_INT", (void *) emacs_gtk_marshal_NONE__INT_INT_INT_INT, marshaller_hashtable); + }; +} + +static void *find_marshaller (const char *func_name) +{ + void *fn = NULL; + initialize_marshaller_storage (); + + if (gethash (func_name, marshaller_hashtable, (const void **)&fn)) + { + return (fn); + } + + return (NULL); +} diff --git a/src/emacs-widget-accessors.c b/src/emacs-widget-accessors.c new file mode 100644 index 0000000..4d16970 --- /dev/null +++ b/src/emacs-widget-accessors.c @@ -0,0 +1,1785 @@ +DEFUN ("gtk-adjustment-lower", Fgtk_adjustment_lower, 1, 1, 0, /* +Access the `lower' slot of OBJ, a GtkAdjustment object. +*/ + (obj)) +{ + GtkAdjustment *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_ADJUSTMENT (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkAdjustment", obj); + }; + + the_obj = GTK_ADJUSTMENT (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gfloat"); + GTK_VALUE_FLOAT (arg) = the_obj->lower; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-adjustment-upper", Fgtk_adjustment_upper, 1, 1, 0, /* +Access the `upper' slot of OBJ, a GtkAdjustment object. +*/ + (obj)) +{ + GtkAdjustment *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_ADJUSTMENT (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkAdjustment", obj); + }; + + the_obj = GTK_ADJUSTMENT (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gfloat"); + GTK_VALUE_FLOAT (arg) = the_obj->upper; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-adjustment-value", Fgtk_adjustment_value, 1, 1, 0, /* +Access the `value' slot of OBJ, a GtkAdjustment object. +*/ + (obj)) +{ + GtkAdjustment *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_ADJUSTMENT (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkAdjustment", obj); + }; + + the_obj = GTK_ADJUSTMENT (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gfloat"); + GTK_VALUE_FLOAT (arg) = the_obj->value; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-adjustment-step-increment", Fgtk_adjustment_step_increment, 1, 1, 0, /* +Access the `step_increment' slot of OBJ, a GtkAdjustment object. +*/ + (obj)) +{ + GtkAdjustment *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_ADJUSTMENT (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkAdjustment", obj); + }; + + the_obj = GTK_ADJUSTMENT (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gfloat"); + GTK_VALUE_FLOAT (arg) = the_obj->step_increment; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-adjustment-page-increment", Fgtk_adjustment_page_increment, 1, 1, 0, /* +Access the `page_increment' slot of OBJ, a GtkAdjustment object. +*/ + (obj)) +{ + GtkAdjustment *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_ADJUSTMENT (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkAdjustment", obj); + }; + + the_obj = GTK_ADJUSTMENT (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gfloat"); + GTK_VALUE_FLOAT (arg) = the_obj->page_increment; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-adjustment-page-size", Fgtk_adjustment_page_size, 1, 1, 0, /* +Access the `page_size' slot of OBJ, a GtkAdjustment object. +*/ + (obj)) +{ + GtkAdjustment *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_ADJUSTMENT (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkAdjustment", obj); + }; + + the_obj = GTK_ADJUSTMENT (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gfloat"); + GTK_VALUE_FLOAT (arg) = the_obj->page_size; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-widget-style", Fgtk_widget_style, 1, 1, 0, /* +Access the `style' slot of OBJ, a GtkWidget object. +*/ + (obj)) +{ + GtkWidget *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_WIDGET (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkWidget", obj); + }; + + the_obj = GTK_WIDGET (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkStyle"); + GTK_VALUE_BOXED (arg) = (void *)the_obj->style; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-widget-window", Fgtk_widget_window, 1, 1, 0, /* +Access the `window' slot of OBJ, a GtkWidget object. +*/ + (obj)) +{ + GtkWidget *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_WIDGET (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkWidget", obj); + }; + + the_obj = GTK_WIDGET (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GdkWindow"); + GTK_VALUE_BOXED (arg) = (void *)the_obj->window; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-widget-state", Fgtk_widget_state, 1, 1, 0, /* +Access the `state' slot of OBJ, a GtkWidget object. +*/ + (obj)) +{ + GtkWidget *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_WIDGET (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkWidget", obj); + }; + + the_obj = GTK_WIDGET (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkStateType"); + GTK_VALUE_ENUM (arg) = the_obj->state; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-widget-name", Fgtk_widget_name, 1, 1, 0, /* +Access the `name' slot of OBJ, a GtkWidget object. +*/ + (obj)) +{ + GtkWidget *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_WIDGET (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkWidget", obj); + }; + + the_obj = GTK_WIDGET (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkString"); + GTK_VALUE_STRING (arg) = the_obj->name; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-widget-parent", Fgtk_widget_parent, 1, 1, 0, /* +Access the `parent' slot of OBJ, a GtkWidget object. +*/ + (obj)) +{ + GtkWidget *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_WIDGET (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkWidget", obj); + }; + + the_obj = GTK_WIDGET (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->parent); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-button-child", Fgtk_button_child, 1, 1, 0, /* +Access the `child' slot of OBJ, a GtkButton object. +*/ + (obj)) +{ + GtkButton *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_BUTTON (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkButton", obj); + }; + + the_obj = GTK_BUTTON (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->child); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-button-in-button", Fgtk_button_in_button, 1, 1, 0, /* +Access the `in_button' slot of OBJ, a GtkButton object. +*/ + (obj)) +{ + GtkButton *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_BUTTON (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkButton", obj); + }; + + the_obj = GTK_BUTTON (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gboolean"); + GTK_VALUE_BOOL (arg) = the_obj->in_button; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-button-button-down", Fgtk_button_button_down, 1, 1, 0, /* +Access the `button_down' slot of OBJ, a GtkButton object. +*/ + (obj)) +{ + GtkButton *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_BUTTON (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkButton", obj); + }; + + the_obj = GTK_BUTTON (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gboolean"); + GTK_VALUE_BOOL (arg) = the_obj->button_down; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-combo-entry", Fgtk_combo_entry, 1, 1, 0, /* +Access the `entry' slot of OBJ, a GtkCombo object. +*/ + (obj)) +{ + GtkCombo *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COMBO (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCombo", obj); + }; + + the_obj = GTK_COMBO (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->entry); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-combo-button", Fgtk_combo_button, 1, 1, 0, /* +Access the `button' slot of OBJ, a GtkCombo object. +*/ + (obj)) +{ + GtkCombo *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COMBO (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCombo", obj); + }; + + the_obj = GTK_COMBO (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-combo-popup", Fgtk_combo_popup, 1, 1, 0, /* +Access the `popup' slot of OBJ, a GtkCombo object. +*/ + (obj)) +{ + GtkCombo *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COMBO (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCombo", obj); + }; + + the_obj = GTK_COMBO (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->popup); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-combo-popwin", Fgtk_combo_popwin, 1, 1, 0, /* +Access the `popwin' slot of OBJ, a GtkCombo object. +*/ + (obj)) +{ + GtkCombo *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COMBO (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCombo", obj); + }; + + the_obj = GTK_COMBO (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->popwin); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-combo-list", Fgtk_combo_list, 1, 1, 0, /* +Access the `list' slot of OBJ, a GtkCombo object. +*/ + (obj)) +{ + GtkCombo *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COMBO (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCombo", obj); + }; + + the_obj = GTK_COMBO (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->list); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-gamma-curve-table", Fgtk_gamma_curve_table, 1, 1, 0, /* +Access the `table' slot of OBJ, a GtkGammaCurve object. +*/ + (obj)) +{ + GtkGammaCurve *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_GAMMA_CURVE (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkGammaCurve", obj); + }; + + the_obj = GTK_GAMMA_CURVE (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->table); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-gamma-curve-curve", Fgtk_gamma_curve_curve, 1, 1, 0, /* +Access the `curve' slot of OBJ, a GtkGammaCurve object. +*/ + (obj)) +{ + GtkGammaCurve *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_GAMMA_CURVE (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkGammaCurve", obj); + }; + + the_obj = GTK_GAMMA_CURVE (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->curve); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-gamma-curve-gamma", Fgtk_gamma_curve_gamma, 1, 1, 0, /* +Access the `gamma' slot of OBJ, a GtkGammaCurve object. +*/ + (obj)) +{ + GtkGammaCurve *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_GAMMA_CURVE (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkGammaCurve", obj); + }; + + the_obj = GTK_GAMMA_CURVE (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gfloat"); + GTK_VALUE_FLOAT (arg) = the_obj->gamma; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-gamma-curve-gamma-dialog", Fgtk_gamma_curve_gamma_dialog, 1, 1, 0, /* +Access the `gamma_dialog' slot of OBJ, a GtkGammaCurve object. +*/ + (obj)) +{ + GtkGammaCurve *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_GAMMA_CURVE (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkGammaCurve", obj); + }; + + the_obj = GTK_GAMMA_CURVE (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->gamma_dialog); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-gamma-curve-gamma-text", Fgtk_gamma_curve_gamma_text, 1, 1, 0, /* +Access the `gamma_text' slot of OBJ, a GtkGammaCurve object. +*/ + (obj)) +{ + GtkGammaCurve *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_GAMMA_CURVE (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkGammaCurve", obj); + }; + + the_obj = GTK_GAMMA_CURVE (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->gamma_text); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-check-menu-item-active", Fgtk_check_menu_item_active, 1, 1, 0, /* +Access the `active' slot of OBJ, a GtkCheckMenuItem object. +*/ + (obj)) +{ + GtkCheckMenuItem *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_CHECK_MENU_ITEM (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCheckMenuItem", obj); + }; + + the_obj = GTK_CHECK_MENU_ITEM (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gboolean"); + GTK_VALUE_BOOL (arg) = the_obj->active; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-notebook-tab-pos", Fgtk_notebook_tab_pos, 1, 1, 0, /* +Access the `tab_pos' slot of OBJ, a GtkNotebook object. +*/ + (obj)) +{ + GtkNotebook *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_NOTEBOOK (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkNotebook", obj); + }; + + the_obj = GTK_NOTEBOOK (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkPositionType"); + GTK_VALUE_ENUM (arg) = the_obj->tab_pos; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-text-hadj", Fgtk_text_hadj, 1, 1, 0, /* +Access the `hadj' slot of OBJ, a GtkText object. +*/ + (obj)) +{ + GtkText *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_TEXT (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkText", obj); + }; + + the_obj = GTK_TEXT (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkAdjustment"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->hadj); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-text-vadj", Fgtk_text_vadj, 1, 1, 0, /* +Access the `vadj' slot of OBJ, a GtkText object. +*/ + (obj)) +{ + GtkText *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_TEXT (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkText", obj); + }; + + the_obj = GTK_TEXT (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkAdjustment"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->vadj); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-file-selection-dir-list", Fgtk_file_selection_dir_list, 1, 1, 0, /* +Access the `dir_list' slot of OBJ, a GtkFileSelection object. +*/ + (obj)) +{ + GtkFileSelection *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FILE_SELECTION (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFileSelection", obj); + }; + + the_obj = GTK_FILE_SELECTION (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->dir_list); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-file-selection-file-list", Fgtk_file_selection_file_list, 1, 1, 0, /* +Access the `file_list' slot of OBJ, a GtkFileSelection object. +*/ + (obj)) +{ + GtkFileSelection *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FILE_SELECTION (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFileSelection", obj); + }; + + the_obj = GTK_FILE_SELECTION (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->file_list); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-file-selection-selection-entry", Fgtk_file_selection_selection_entry, 1, 1, 0, /* +Access the `selection_entry' slot of OBJ, a GtkFileSelection object. +*/ + (obj)) +{ + GtkFileSelection *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FILE_SELECTION (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFileSelection", obj); + }; + + the_obj = GTK_FILE_SELECTION (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->selection_entry); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-file-selection-selection-text", Fgtk_file_selection_selection_text, 1, 1, 0, /* +Access the `selection_text' slot of OBJ, a GtkFileSelection object. +*/ + (obj)) +{ + GtkFileSelection *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FILE_SELECTION (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFileSelection", obj); + }; + + the_obj = GTK_FILE_SELECTION (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->selection_text); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-file-selection-main-vbox", Fgtk_file_selection_main_vbox, 1, 1, 0, /* +Access the `main_vbox' slot of OBJ, a GtkFileSelection object. +*/ + (obj)) +{ + GtkFileSelection *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FILE_SELECTION (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFileSelection", obj); + }; + + the_obj = GTK_FILE_SELECTION (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->main_vbox); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-file-selection-ok-button", Fgtk_file_selection_ok_button, 1, 1, 0, /* +Access the `ok_button' slot of OBJ, a GtkFileSelection object. +*/ + (obj)) +{ + GtkFileSelection *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FILE_SELECTION (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFileSelection", obj); + }; + + the_obj = GTK_FILE_SELECTION (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->ok_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-file-selection-cancel-button", Fgtk_file_selection_cancel_button, 1, 1, 0, /* +Access the `cancel_button' slot of OBJ, a GtkFileSelection object. +*/ + (obj)) +{ + GtkFileSelection *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FILE_SELECTION (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFileSelection", obj); + }; + + the_obj = GTK_FILE_SELECTION (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->cancel_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-file-selection-help-button", Fgtk_file_selection_help_button, 1, 1, 0, /* +Access the `help_button' slot of OBJ, a GtkFileSelection object. +*/ + (obj)) +{ + GtkFileSelection *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FILE_SELECTION (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFileSelection", obj); + }; + + the_obj = GTK_FILE_SELECTION (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->help_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-file-selection-action-area", Fgtk_file_selection_action_area, 1, 1, 0, /* +Access the `action_area' slot of OBJ, a GtkFileSelection object. +*/ + (obj)) +{ + GtkFileSelection *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FILE_SELECTION (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFileSelection", obj); + }; + + the_obj = GTK_FILE_SELECTION (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->action_area); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-font-selection-dialog-fontsel", Fgtk_font_selection_dialog_fontsel, 1, 1, 0, /* +Access the `fontsel' slot of OBJ, a GtkFontSelectionDialog object. +*/ + (obj)) +{ + GtkFontSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFontSelectionDialog", obj); + }; + + the_obj = GTK_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->fontsel); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-font-selection-dialog-main-vbox", Fgtk_font_selection_dialog_main_vbox, 1, 1, 0, /* +Access the `main_vbox' slot of OBJ, a GtkFontSelectionDialog object. +*/ + (obj)) +{ + GtkFontSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFontSelectionDialog", obj); + }; + + the_obj = GTK_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->main_vbox); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-font-selection-dialog-action-area", Fgtk_font_selection_dialog_action_area, 1, 1, 0, /* +Access the `action_area' slot of OBJ, a GtkFontSelectionDialog object. +*/ + (obj)) +{ + GtkFontSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFontSelectionDialog", obj); + }; + + the_obj = GTK_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->action_area); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-font-selection-dialog-ok-button", Fgtk_font_selection_dialog_ok_button, 1, 1, 0, /* +Access the `ok_button' slot of OBJ, a GtkFontSelectionDialog object. +*/ + (obj)) +{ + GtkFontSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFontSelectionDialog", obj); + }; + + the_obj = GTK_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->ok_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-font-selection-dialog-apply-button", Fgtk_font_selection_dialog_apply_button, 1, 1, 0, /* +Access the `apply_button' slot of OBJ, a GtkFontSelectionDialog object. +*/ + (obj)) +{ + GtkFontSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFontSelectionDialog", obj); + }; + + the_obj = GTK_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->apply_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-font-selection-dialog-cancel-button", Fgtk_font_selection_dialog_cancel_button, 1, 1, 0, /* +Access the `cancel_button' slot of OBJ, a GtkFontSelectionDialog object. +*/ + (obj)) +{ + GtkFontSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkFontSelectionDialog", obj); + }; + + the_obj = GTK_FONT_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->cancel_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-color-selection-dialog-colorsel", Fgtk_color_selection_dialog_colorsel, 1, 1, 0, /* +Access the `colorsel' slot of OBJ, a GtkColorSelectionDialog object. +*/ + (obj)) +{ + GtkColorSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkColorSelectionDialog", obj); + }; + + the_obj = GTK_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->colorsel); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-color-selection-dialog-main-vbox", Fgtk_color_selection_dialog_main_vbox, 1, 1, 0, /* +Access the `main_vbox' slot of OBJ, a GtkColorSelectionDialog object. +*/ + (obj)) +{ + GtkColorSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkColorSelectionDialog", obj); + }; + + the_obj = GTK_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->main_vbox); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-color-selection-dialog-ok-button", Fgtk_color_selection_dialog_ok_button, 1, 1, 0, /* +Access the `ok_button' slot of OBJ, a GtkColorSelectionDialog object. +*/ + (obj)) +{ + GtkColorSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkColorSelectionDialog", obj); + }; + + the_obj = GTK_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->ok_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-color-selection-dialog-reset-button", Fgtk_color_selection_dialog_reset_button, 1, 1, 0, /* +Access the `reset_button' slot of OBJ, a GtkColorSelectionDialog object. +*/ + (obj)) +{ + GtkColorSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkColorSelectionDialog", obj); + }; + + the_obj = GTK_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->reset_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-color-selection-dialog-cancel-button", Fgtk_color_selection_dialog_cancel_button, 1, 1, 0, /* +Access the `cancel_button' slot of OBJ, a GtkColorSelectionDialog object. +*/ + (obj)) +{ + GtkColorSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkColorSelectionDialog", obj); + }; + + the_obj = GTK_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->cancel_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-color-selection-dialog-help-button", Fgtk_color_selection_dialog_help_button, 1, 1, 0, /* +Access the `help_button' slot of OBJ, a GtkColorSelectionDialog object. +*/ + (obj)) +{ + GtkColorSelectionDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkColorSelectionDialog", obj); + }; + + the_obj = GTK_COLOR_SELECTION_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->help_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-dialog-vbox", Fgtk_dialog_vbox, 1, 1, 0, /* +Access the `vbox' slot of OBJ, a GtkDialog object. +*/ + (obj)) +{ + GtkDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkDialog", obj); + }; + + the_obj = GTK_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->vbox); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-dialog-action-area", Fgtk_dialog_action_area, 1, 1, 0, /* +Access the `action_area' slot of OBJ, a GtkDialog object. +*/ + (obj)) +{ + GtkDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkDialog", obj); + }; + + the_obj = GTK_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->action_area); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-input-dialog-close-button", Fgtk_input_dialog_close_button, 1, 1, 0, /* +Access the `close_button' slot of OBJ, a GtkInputDialog object. +*/ + (obj)) +{ + GtkInputDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_INPUT_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkInputDialog", obj); + }; + + the_obj = GTK_INPUT_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->close_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-input-dialog-save-button", Fgtk_input_dialog_save_button, 1, 1, 0, /* +Access the `save_button' slot of OBJ, a GtkInputDialog object. +*/ + (obj)) +{ + GtkInputDialog *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_INPUT_DIALOG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkInputDialog", obj); + }; + + the_obj = GTK_INPUT_DIALOG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->save_button); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-plug-socket-window", Fgtk_plug_socket_window, 1, 1, 0, /* +Access the `socket_window' slot of OBJ, a GtkPlug object. +*/ + (obj)) +{ + GtkPlug *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_PLUG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkPlug", obj); + }; + + the_obj = GTK_PLUG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GdkWindow"); + GTK_VALUE_BOXED (arg) = (void *)the_obj->socket_window; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-plug-same-app", Fgtk_plug_same_app, 1, 1, 0, /* +Access the `same_app' slot of OBJ, a GtkPlug object. +*/ + (obj)) +{ + GtkPlug *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_PLUG (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkPlug", obj); + }; + + the_obj = GTK_PLUG (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gint"); + GTK_VALUE_INT (arg) = the_obj->same_app; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-object-flags", Fgtk_object_flags, 1, 1, 0, /* +Access the `flags' slot of OBJ, a GtkObject object. +*/ + (obj)) +{ + GtkObject *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_OBJECT (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkObject", obj); + }; + + the_obj = GTK_OBJECT (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("guint"); + GTK_VALUE_UINT (arg) = the_obj->flags; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-object-ref-count", Fgtk_object_ref_count, 1, 1, 0, /* +Access the `ref_count' slot of OBJ, a GtkObject object. +*/ + (obj)) +{ + GtkObject *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_OBJECT (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkObject", obj); + }; + + the_obj = GTK_OBJECT (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("guint"); + GTK_VALUE_UINT (arg) = the_obj->ref_count; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-paned-child1", Fgtk_paned_child1, 1, 1, 0, /* +Access the `child1' slot of OBJ, a GtkPaned object. +*/ + (obj)) +{ + GtkPaned *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_PANED (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkPaned", obj); + }; + + the_obj = GTK_PANED (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->child1); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-paned-child2", Fgtk_paned_child2, 1, 1, 0, /* +Access the `child2' slot of OBJ, a GtkPaned object. +*/ + (obj)) +{ + GtkPaned *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_PANED (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkPaned", obj); + }; + + the_obj = GTK_PANED (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->child2); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-paned-child1-resize", Fgtk_paned_child1_resize, 1, 1, 0, /* +Access the `child1_resize' slot of OBJ, a GtkPaned object. +*/ + (obj)) +{ + GtkPaned *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_PANED (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkPaned", obj); + }; + + the_obj = GTK_PANED (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gboolean"); + GTK_VALUE_BOOL (arg) = the_obj->child1_resize; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-paned-child2-resize", Fgtk_paned_child2_resize, 1, 1, 0, /* +Access the `child2_resize' slot of OBJ, a GtkPaned object. +*/ + (obj)) +{ + GtkPaned *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_PANED (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkPaned", obj); + }; + + the_obj = GTK_PANED (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gboolean"); + GTK_VALUE_BOOL (arg) = the_obj->child2_resize; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-paned-child1-shrink", Fgtk_paned_child1_shrink, 1, 1, 0, /* +Access the `child1_shrink' slot of OBJ, a GtkPaned object. +*/ + (obj)) +{ + GtkPaned *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_PANED (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkPaned", obj); + }; + + the_obj = GTK_PANED (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gboolean"); + GTK_VALUE_BOOL (arg) = the_obj->child1_shrink; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-paned-child2-shrink", Fgtk_paned_child2_shrink, 1, 1, 0, /* +Access the `child2_shrink' slot of OBJ, a GtkPaned object. +*/ + (obj)) +{ + GtkPaned *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_PANED (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkPaned", obj); + }; + + the_obj = GTK_PANED (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gboolean"); + GTK_VALUE_BOOL (arg) = the_obj->child2_shrink; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-clist-rows", Fgtk_clist_rows, 1, 1, 0, /* +Access the `rows' slot of OBJ, a GtkCList object. +*/ + (obj)) +{ + GtkCList *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_CLIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCList", obj); + }; + + the_obj = GTK_CLIST (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gint"); + GTK_VALUE_INT (arg) = the_obj->rows; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-clist-columns", Fgtk_clist_columns, 1, 1, 0, /* +Access the `columns' slot of OBJ, a GtkCList object. +*/ + (obj)) +{ + GtkCList *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_CLIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCList", obj); + }; + + the_obj = GTK_CLIST (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gint"); + GTK_VALUE_INT (arg) = the_obj->columns; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-clist-hadjustment", Fgtk_clist_hadjustment, 1, 1, 0, /* +Access the `hadjustment' slot of OBJ, a GtkCList object. +*/ + (obj)) +{ + GtkCList *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_CLIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCList", obj); + }; + + the_obj = GTK_CLIST (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkAdjustment"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->hadjustment); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-clist-vadjustment", Fgtk_clist_vadjustment, 1, 1, 0, /* +Access the `vadjustment' slot of OBJ, a GtkCList object. +*/ + (obj)) +{ + GtkCList *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_CLIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCList", obj); + }; + + the_obj = GTK_CLIST (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkAdjustment"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->vadjustment); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-clist-sort-type", Fgtk_clist_sort_type, 1, 1, 0, /* +Access the `sort_type' slot of OBJ, a GtkCList object. +*/ + (obj)) +{ + GtkCList *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_CLIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCList", obj); + }; + + the_obj = GTK_CLIST (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkSortType"); + GTK_VALUE_ENUM (arg) = the_obj->sort_type; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-clist-focus-row", Fgtk_clist_focus_row, 1, 1, 0, /* +Access the `focus_row' slot of OBJ, a GtkCList object. +*/ + (obj)) +{ + GtkCList *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_CLIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCList", obj); + }; + + the_obj = GTK_CLIST (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gint"); + GTK_VALUE_INT (arg) = the_obj->focus_row; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-clist-sort-column", Fgtk_clist_sort_column, 1, 1, 0, /* +Access the `sort_column' slot of OBJ, a GtkCList object. +*/ + (obj)) +{ + GtkCList *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_CLIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCList", obj); + }; + + the_obj = GTK_CLIST (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gint"); + GTK_VALUE_INT (arg) = the_obj->sort_column; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-list-children", Fgtk_list_children, 1, 1, 0, /* +Access the `children' slot of OBJ, a GtkList object. +*/ + (obj)) +{ + GtkList *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_LIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkList", obj); + }; + + the_obj = GTK_LIST (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkListOfObject"); + GTK_VALUE_POINTER (arg) = the_obj->children; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-list-selection", Fgtk_list_selection, 1, 1, 0, /* +Access the `selection' slot of OBJ, a GtkList object. +*/ + (obj)) +{ + GtkList *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_LIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkList", obj); + }; + + the_obj = GTK_LIST (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkListOfObject"); + GTK_VALUE_POINTER (arg) = the_obj->selection; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-tree-children", Fgtk_tree_children, 1, 1, 0, /* +Access the `children' slot of OBJ, a GtkTree object. +*/ + (obj)) +{ + GtkTree *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_TREE (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkTree", obj); + }; + + the_obj = GTK_TREE (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkListOfObject"); + GTK_VALUE_POINTER (arg) = the_obj->children; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-tree-root-tree", Fgtk_tree_root_tree, 1, 1, 0, /* +Access the `root_tree' slot of OBJ, a GtkTree object. +*/ + (obj)) +{ + GtkTree *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_TREE (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkTree", obj); + }; + + the_obj = GTK_TREE (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkTree"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->root_tree); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-tree-tree-owner", Fgtk_tree_tree_owner, 1, 1, 0, /* +Access the `tree_owner' slot of OBJ, a GtkTree object. +*/ + (obj)) +{ + GtkTree *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_TREE (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkTree", obj); + }; + + the_obj = GTK_TREE (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->tree_owner); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-tree-selection", Fgtk_tree_selection, 1, 1, 0, /* +Access the `selection' slot of OBJ, a GtkTree object. +*/ + (obj)) +{ + GtkTree *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_TREE (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkTree", obj); + }; + + the_obj = GTK_TREE (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkListOfObject"); + GTK_VALUE_POINTER (arg) = the_obj->selection; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-tree-item-subtree", Fgtk_tree_item_subtree, 1, 1, 0, /* +Access the `subtree' slot of OBJ, a GtkTreeItem object. +*/ + (obj)) +{ + GtkTreeItem *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_TREE_ITEM (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkTreeItem", obj); + }; + + the_obj = GTK_TREE_ITEM (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->subtree); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-scrolled-window-hscrollbar", Fgtk_scrolled_window_hscrollbar, 1, 1, 0, /* +Access the `hscrollbar' slot of OBJ, a GtkScrolledWindow object. +*/ + (obj)) +{ + GtkScrolledWindow *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_SCROLLED_WINDOW (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkScrolledWindow", obj); + }; + + the_obj = GTK_SCROLLED_WINDOW (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->hscrollbar); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-scrolled-window-vscrollbar", Fgtk_scrolled_window_vscrollbar, 1, 1, 0, /* +Access the `vscrollbar' slot of OBJ, a GtkScrolledWindow object. +*/ + (obj)) +{ + GtkScrolledWindow *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_SCROLLED_WINDOW (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkScrolledWindow", obj); + }; + + the_obj = GTK_SCROLLED_WINDOW (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("GtkWidget"); + GTK_VALUE_OBJECT (arg) = GTK_OBJECT (the_obj->vscrollbar); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-scrolled-window-hscrollbar-visible", Fgtk_scrolled_window_hscrollbar_visible, 1, 1, 0, /* +Access the `hscrollbar_visible' slot of OBJ, a GtkScrolledWindow object. +*/ + (obj)) +{ + GtkScrolledWindow *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_SCROLLED_WINDOW (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkScrolledWindow", obj); + }; + + the_obj = GTK_SCROLLED_WINDOW (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gboolean"); + GTK_VALUE_BOOL (arg) = the_obj->hscrollbar_visible; + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-scrolled-window-vscrollbar-visible", Fgtk_scrolled_window_vscrollbar_visible, 1, 1, 0, /* +Access the `vscrollbar_visible' slot of OBJ, a GtkScrolledWindow object. +*/ + (obj)) +{ + GtkScrolledWindow *the_obj = NULL; + GtkArg arg; + + CHECK_GTK_OBJECT (obj); + + if (!GTK_IS_SCROLLED_WINDOW (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkScrolledWindow", obj); + }; + + the_obj = GTK_SCROLLED_WINDOW (XGTK_OBJECT (obj)->object); + arg.type = gtk_type_from_name ("gboolean"); + GTK_VALUE_BOOL (arg) = the_obj->vscrollbar_visible; + return (gtk_type_to_lisp (&arg)); +} + +void syms_of_widget_accessors (void) +{ + DEFSUBR (Fgtk_scrolled_window_vscrollbar_visible); + DEFSUBR (Fgtk_scrolled_window_hscrollbar_visible); + DEFSUBR (Fgtk_scrolled_window_vscrollbar); + DEFSUBR (Fgtk_scrolled_window_hscrollbar); + DEFSUBR (Fgtk_tree_item_subtree); + DEFSUBR (Fgtk_tree_selection); + DEFSUBR (Fgtk_tree_tree_owner); + DEFSUBR (Fgtk_tree_root_tree); + DEFSUBR (Fgtk_tree_children); + DEFSUBR (Fgtk_list_selection); + DEFSUBR (Fgtk_list_children); + DEFSUBR (Fgtk_clist_sort_column); + DEFSUBR (Fgtk_clist_focus_row); + DEFSUBR (Fgtk_clist_sort_type); + DEFSUBR (Fgtk_clist_vadjustment); + DEFSUBR (Fgtk_clist_hadjustment); + DEFSUBR (Fgtk_clist_columns); + DEFSUBR (Fgtk_clist_rows); + DEFSUBR (Fgtk_paned_child2_shrink); + DEFSUBR (Fgtk_paned_child1_shrink); + DEFSUBR (Fgtk_paned_child2_resize); + DEFSUBR (Fgtk_paned_child1_resize); + DEFSUBR (Fgtk_paned_child2); + DEFSUBR (Fgtk_paned_child1); + DEFSUBR (Fgtk_object_ref_count); + DEFSUBR (Fgtk_object_flags); + DEFSUBR (Fgtk_plug_same_app); + DEFSUBR (Fgtk_plug_socket_window); + DEFSUBR (Fgtk_input_dialog_save_button); + DEFSUBR (Fgtk_input_dialog_close_button); + DEFSUBR (Fgtk_dialog_action_area); + DEFSUBR (Fgtk_dialog_vbox); + DEFSUBR (Fgtk_color_selection_dialog_help_button); + DEFSUBR (Fgtk_color_selection_dialog_cancel_button); + DEFSUBR (Fgtk_color_selection_dialog_reset_button); + DEFSUBR (Fgtk_color_selection_dialog_ok_button); + DEFSUBR (Fgtk_color_selection_dialog_main_vbox); + DEFSUBR (Fgtk_color_selection_dialog_colorsel); + DEFSUBR (Fgtk_font_selection_dialog_cancel_button); + DEFSUBR (Fgtk_font_selection_dialog_apply_button); + DEFSUBR (Fgtk_font_selection_dialog_ok_button); + DEFSUBR (Fgtk_font_selection_dialog_action_area); + DEFSUBR (Fgtk_font_selection_dialog_main_vbox); + DEFSUBR (Fgtk_font_selection_dialog_fontsel); + DEFSUBR (Fgtk_file_selection_action_area); + DEFSUBR (Fgtk_file_selection_help_button); + DEFSUBR (Fgtk_file_selection_cancel_button); + DEFSUBR (Fgtk_file_selection_ok_button); + DEFSUBR (Fgtk_file_selection_main_vbox); + DEFSUBR (Fgtk_file_selection_selection_text); + DEFSUBR (Fgtk_file_selection_selection_entry); + DEFSUBR (Fgtk_file_selection_file_list); + DEFSUBR (Fgtk_file_selection_dir_list); + DEFSUBR (Fgtk_text_vadj); + DEFSUBR (Fgtk_text_hadj); + DEFSUBR (Fgtk_notebook_tab_pos); + DEFSUBR (Fgtk_check_menu_item_active); + DEFSUBR (Fgtk_gamma_curve_gamma_text); + DEFSUBR (Fgtk_gamma_curve_gamma_dialog); + DEFSUBR (Fgtk_gamma_curve_gamma); + DEFSUBR (Fgtk_gamma_curve_curve); + DEFSUBR (Fgtk_gamma_curve_table); + DEFSUBR (Fgtk_combo_list); + DEFSUBR (Fgtk_combo_popwin); + DEFSUBR (Fgtk_combo_popup); + DEFSUBR (Fgtk_combo_button); + DEFSUBR (Fgtk_combo_entry); + DEFSUBR (Fgtk_button_button_down); + DEFSUBR (Fgtk_button_in_button); + DEFSUBR (Fgtk_button_child); + DEFSUBR (Fgtk_widget_parent); + DEFSUBR (Fgtk_widget_name); + DEFSUBR (Fgtk_widget_state); + DEFSUBR (Fgtk_widget_window); + DEFSUBR (Fgtk_widget_style); + DEFSUBR (Fgtk_adjustment_page_size); + DEFSUBR (Fgtk_adjustment_page_increment); + DEFSUBR (Fgtk_adjustment_step_increment); + DEFSUBR (Fgtk_adjustment_value); + DEFSUBR (Fgtk_adjustment_upper); + DEFSUBR (Fgtk_adjustment_lower); +} diff --git a/src/event-gtk.c b/src/event-gtk.c new file mode 100644 index 0000000..9dd0394 --- /dev/null +++ b/src/event-gtk.c @@ -0,0 +1,2165 @@ +/* The event_stream interface for X11 with gtk, and/or tty frames. + Copyright (C) 1991-5, 1997 Free Software Foundation, Inc. + Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 1996 Ben Wing. + Copyright (C) 2000 William Perry. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* This file is heavily based upon event-Xt.c */ + +/* Synched up with: Not in FSF. */ + +#include +#include "lisp.h" + +#include "console-gtk.h" + +#include "blocktype.h" +#include "buffer.h" +#include "commands.h" +#include "console.h" +#include "console-tty.h" +#include "events.h" +#include "frame.h" +#include "objects-gtk.h" +#include "process.h" +#include "redisplay.h" +#include "elhash.h" + +#include "gtk-xemacs.h" + +#include "systime.h" +#include "sysproc.h" /* for MAXDESC */ + +#ifdef FILE_CODING +#include "lstream.h" +#include "file-coding.h" +#endif + +#include + +#ifdef HAVE_DRAGNDROP +#include "dragdrop.h" +#endif + +#if defined (HAVE_OFFIX_DND) +#include "offix.h" +#endif + +#include "events-mod.h" + +#include + +static struct event_stream *gtk_event_stream; + +/* Do we accept events sent by other clients? */ +int gtk_allow_sendevents; + +static int process_events_occurred; +static int tty_events_occurred; + +/* Mask of bits indicating the descriptors that we wait for input on */ +extern SELECT_TYPE input_wait_mask, process_only_mask, tty_only_mask; + +static Lisp_Object gtk_keysym_to_emacs_keysym (); +void debug_process_finalization (struct Lisp_Process *p); +gboolean emacs_gtk_event_handler (GtkWidget *wid /* unused */, + GdkEvent *event, + gpointer closure /* unused */); + +static int last_quit_check_signal_tick_count; + +Lisp_Object Qkey_mapping; +Lisp_Object Qsans_modifiers; + +static void enqueue_gtk_dispatch_event (Lisp_Object event); + +#define IS_MODIFIER_KEY(keysym) \ + ((((keysym) >= GDK_Shift_L) && ((keysym) <= GDK_Hyper_R)) \ + || ((keysym) == GDK_Mode_switch) \ + || ((keysym) == GDK_Num_Lock)) + + + +/************************************************************************/ +/* magic-event handling */ +/************************************************************************/ +static void +handle_focus_event_1 (struct frame *f, int in_p) +{ + /* We don't want to handle the focus change now, because we might + be in an accept-process-output, sleep-for, or sit-for. So + we enqueue it. + + Actually, we half handle it: we handle it as far as changing the + box cursor for redisplay, but we don't call any hooks or do any + select-frame stuff until after the sit-for. + */ + + if (in_p) + { + GTK_WIDGET_SET_FLAGS (FRAME_GTK_TEXT_WIDGET (f), GTK_HAS_FOCUS); + } + else + { + GTK_WIDGET_UNSET_FLAGS (FRAME_GTK_TEXT_WIDGET (f), GTK_HAS_FOCUS); + } + gtk_widget_grab_focus (FRAME_GTK_TEXT_WIDGET (f)); + gtk_widget_draw_focus (FRAME_GTK_TEXT_WIDGET (f)); + + { + Lisp_Object frm; + Lisp_Object conser; + struct gcpro gcpro1; + + XSETFRAME (frm, f); + conser = Fcons (frm, Fcons (FRAME_DEVICE (f), in_p ? Qt : Qnil)); + GCPRO1 (conser); + + emacs_handle_focus_change_preliminary (conser); + enqueue_magic_eval_event (emacs_handle_focus_change_final, + conser); + UNGCPRO; + } +} + +/* both GDK_MAP and GDK_VISIBILITY_NOTIFY can cause this + JV is_visible has the same semantics as f->visible*/ +static void +change_frame_visibility (struct frame *f, int is_visible) +{ + Lisp_Object frame; + + XSETFRAME (frame, f); + + if (!FRAME_VISIBLE_P (f) && is_visible) + { + FRAME_VISIBLE_P (f) = is_visible; + /* This improves the double flicker when uniconifying a frame + some. A lot of it is not showing a buffer which has changed + while the frame was iconified. To fix it further requires + the good 'ol double redisplay structure. */ + MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (f); + va_run_hook_with_args (Qmap_frame_hook, 1, frame); + } + else if (FRAME_VISIBLE_P (f) && !is_visible) + { + FRAME_VISIBLE_P (f) = 0; + va_run_hook_with_args (Qunmap_frame_hook, 1, frame); + } + else if (FRAME_VISIBLE_P (f) * is_visible < 0) + { + FRAME_VISIBLE_P(f) = - FRAME_VISIBLE_P(f); + if (FRAME_REPAINT_P (f)) + MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (f); + va_run_hook_with_args (Qmap_frame_hook, 1, frame); + } +} + +static void +handle_map_event (struct frame *f, GdkEvent *event) +{ + Lisp_Object frame; + + XSETFRAME (frame, f); + if (event->any.type == GDK_MAP) + { + FRAME_GTK_TOTALLY_VISIBLE_P (f) = 1; + change_frame_visibility (f, 1); + } + else + { + FRAME_GTK_TOTALLY_VISIBLE_P (f) = 0; + change_frame_visibility (f, 0); + /* Calling Fframe_iconified_p is the only way we have to + correctly update FRAME_ICONIFIED_P */ + Fframe_iconified_p (frame); + } +} + +static void +handle_client_message (struct frame *f, GdkEvent *event) +{ + Lisp_Object frame; + + XSETFRAME (frame, f); + + /* The event-Xt code used to handle WM_DELETE_WINDOW here, but we + handle that directly in frame-gtk.c */ + + if (event->client.message_type == gdk_atom_intern ("WM_PROTOCOLS", 0) && + (GdkAtom) event->client.data.l[0] == gdk_atom_intern ("WM_TAKE_FOCUS", 0)) + { + handle_focus_event_1 (f, 1); + } +} + +static void +emacs_gtk_handle_magic_event (struct Lisp_Event *emacs_event) +{ + /* This function can GC */ + GdkEvent *event = &emacs_event->event.magic.underlying_gdk_event; + struct frame *f = XFRAME (EVENT_CHANNEL (emacs_event)); + + if (!FRAME_LIVE_P (f)) + return; + + switch (event->any.type) + { + case GDK_CLIENT_EVENT: + handle_client_message (f, event); + break; + + case GDK_FOCUS_CHANGE: + handle_focus_event_1 (f, event->focus_change.in); + break; + + case GDK_MAP: + case GDK_UNMAP: + handle_map_event (f, event); + break; + + case GDK_ENTER_NOTIFY: + if (event->crossing.detail != GDK_NOTIFY_INFERIOR) + { + Lisp_Object frame; + + XSETFRAME (frame, f); + /* FRAME_X_MOUSE_P (f) = 1; */ + va_run_hook_with_args (Qmouse_enter_frame_hook, 1, frame); + } + break; + + case GDK_LEAVE_NOTIFY: + if (event->crossing.detail != GDK_NOTIFY_INFERIOR) + { + Lisp_Object frame; + + XSETFRAME (frame, f); + /* FRAME_X_MOUSE_P (f) = 0; */ + va_run_hook_with_args (Qmouse_leave_frame_hook, 1, frame); + } + break; + + case GDK_VISIBILITY_NOTIFY: /* window visiblity has changed */ + if (event->visibility.window == GET_GTK_WIDGET_WINDOW (FRAME_GTK_SHELL_WIDGET (f))) + { + FRAME_GTK_TOTALLY_VISIBLE_P (f) = + (event->visibility.state == GDK_VISIBILITY_UNOBSCURED); + /* Note that the fvwm pager only sends VisibilityNotify when + changing pages. Is this all we need to do ? JV */ + /* Nope. We must at least trigger a redisplay here. + Since this case seems similar to MapNotify, I've + factored out some code to change_frame_visibility(). + This triggers the necessary redisplay and runs + (un)map-frame-hook. - dkindred@cs.cmu.edu */ + /* Changed it again to support the tristate visibility flag */ + change_frame_visibility (f, (event->visibility.state + != GDK_VISIBILITY_FULLY_OBSCURED) ? 1 : -1); + } + break; + + default: + break; + } +} + +/************************************************************************/ +/* Gtk to Emacs event conversion */ +/************************************************************************/ + +static int +keysym_obeys_caps_lock_p (guint sym, struct device *d) +{ + struct gtk_device *gd = DEVICE_GTK_DATA (d); + /* Eeeeevil hack. Don't apply Caps_Lock to things that aren't alphabetic + characters, where "alphabetic" means something more than simply A-Z. + That is, if Caps_Lock is down, typing ESC doesn't produce Shift-ESC. + But if shift-lock is down, then it does. */ + if (gd->lock_interpretation == GDK_Shift_Lock) + return 1; + + return + ((sym >= GDK_A) && (sym <= GDK_Z)) || + ((sym >= GDK_a) && (sym <= GDK_z)) || + ((sym >= GDK_Agrave) && (sym <= GDK_Odiaeresis)) || + ((sym >= GDK_agrave) && (sym <= GDK_odiaeresis)) || + ((sym >= GDK_Ooblique) && (sym <= GDK_Thorn)) || + ((sym >= GDK_oslash) && (sym <= GDK_thorn)); +} + +static void +set_last_server_timestamp (struct device *d, GdkEvent *gdk_event) +{ + guint32 t; + switch (gdk_event->type) + { + case GDK_KEY_PRESS: + case GDK_KEY_RELEASE: t = gdk_event->key.time; break; + case GDK_BUTTON_PRESS: + case GDK_2BUTTON_PRESS: + case GDK_3BUTTON_PRESS: + case GDK_BUTTON_RELEASE: t = gdk_event->button.time; break; + case GDK_ENTER_NOTIFY: + case GDK_LEAVE_NOTIFY: t = gdk_event->crossing.time; break; + case GDK_MOTION_NOTIFY: t = gdk_event->motion.time; break; + case GDK_PROPERTY_NOTIFY: t = gdk_event->property.time; break; + case GDK_SELECTION_CLEAR: + case GDK_SELECTION_REQUEST: + case GDK_SELECTION_NOTIFY: t = gdk_event->selection.time; break; + default: return; + } + DEVICE_GTK_LAST_SERVER_TIMESTAMP (d) = t; +} + +static Lisp_Object +gtk_keysym_to_emacs_keysym (guint keysym, int simple_p) +{ + char *name; + if (keysym >= GDK_exclam && keysym <= GDK_asciitilde) + /* We must assume that the X keysym numbers for the ASCII graphic + characters are the same as their ASCII codes. */ + return make_char (keysym); + + switch (keysym) + { + /* These would be handled correctly by the default case, but by + special-casing them here we don't garbage a string or call + intern(). */ + case GDK_BackSpace: return QKbackspace; + case GDK_Tab: return QKtab; + case GDK_Linefeed: return QKlinefeed; + case GDK_Return: return QKreturn; + case GDK_Escape: return QKescape; + case GDK_space: return QKspace; + case GDK_Delete: return QKdelete; + case 0: return Qnil; + default: + if (simple_p) return Qnil; + /* !!#### not Mule-ized */ + name = gdk_keyval_name (keysym); + if (!name || !name[0]) + /* This happens if there is a mismatch between the Xlib of + XEmacs and the Xlib of the X server... + + Let's hard-code in some knowledge of common keysyms introduced + in recent X11 releases. Snarfed from X11/keysymdef.h + + Probably we should add some stuff here for X11R6. */ + switch (keysym) + { + case 0xFF95: return KEYSYM ("kp-home"); + case 0xFF96: return KEYSYM ("kp-left"); + case 0xFF97: return KEYSYM ("kp-up"); + case 0xFF98: return KEYSYM ("kp-right"); + case 0xFF99: return KEYSYM ("kp-down"); + case 0xFF9A: return KEYSYM ("kp-prior"); + case 0xFF9B: return KEYSYM ("kp-next"); + case 0xFF9C: return KEYSYM ("kp-end"); + case 0xFF9D: return KEYSYM ("kp-begin"); + case 0xFF9E: return KEYSYM ("kp-insert"); + case 0xFF9F: return KEYSYM ("kp-delete"); + + case 0x1005FF10: return KEYSYM ("SunF36"); /* labeled F11 */ + case 0x1005FF11: return KEYSYM ("SunF37"); /* labeled F12 */ + default: + { + char buf [64]; + sprintf (buf, "unknown-keysym-0x%X", (int) keysym); + return KEYSYM (buf); + } + } + /* If it's got a one-character name, that's good enough. */ + if (!name[1]) + return make_char (name[0]); + + /* If it's in the "Keyboard" character set, downcase it. + The case of those keysyms is too totally random for us to + force anyone to remember them. + The case of the other character sets is significant, however. + */ + if ((((unsigned int) keysym) & (~0x1FF)) == ((unsigned int) 0xFE00)) + { + char buf [255]; + char *s1, *s2; + for (s1 = name, s2 = buf; *s1; s1++, s2++) { + if (*s1 == '_') { + *s2 = '-'; + } else { + *s2 = tolower (* (unsigned char *) s1); + } + } + *s2 = 0; + return KEYSYM (buf); + } + return KEYSYM (name); + } +} + +static Lisp_Object +gtk_to_emacs_keysym (struct device *d, GdkEventKey *event, int simple_p) + /* simple_p means don't try too hard (ASCII only) */ +{ + if (event->length != 1) + { +#ifdef FILE_CODING + /* Generate multiple emacs events */ + Emchar ch; + Lisp_Object instream, fb_instream; + Lstream *istr; + struct gcpro gcpro1, gcpro2; + + fb_instream = + make_fixed_buffer_input_stream ((unsigned char *) event->string, event->length); + + /* ### Use Fget_coding_system (Vcomposed_input_coding_system) */ + instream = + make_decoding_input_stream (XLSTREAM (fb_instream), + Fget_coding_system (Qundecided)); + + istr = XLSTREAM (instream); + + GCPRO2 (instream, fb_instream); + while ((ch = Lstream_get_emchar (istr)) != EOF) + { + Lisp_Object emacs_event = Fmake_event (Qnil, Qnil); + struct Lisp_Event *ev = XEVENT (emacs_event); + ev->channel = DEVICE_CONSOLE (d); + ev->event_type = key_press_event; + ev->timestamp = event->time; + ev->event.key.modifiers = 0; + ev->event.key.keysym = make_char (ch); + enqueue_gtk_dispatch_event (emacs_event); + } + Lstream_close (istr); + UNGCPRO; + Lstream_delete (istr); + Lstream_delete (XLSTREAM (fb_instream)); +#else + int i; + for (i = 0; i < event->length; i++) + { + Lisp_Object emacs_event = Fmake_event (Qnil, Qnil); + struct Lisp_Event *ev = XEVENT (emacs_event); + ev->channel = DEVICE_CONSOLE (d); + ev->event_type = key_press_event; + ev->timestamp = event->time; + ev->event.key.modifiers = 0; + ev->event.key.keysym = make_char (event->string[i]); + enqueue_gtk_dispatch_event (emacs_event); + } +#endif + if (IS_MODIFIER_KEY (event->keyval) || (event->keyval == GDK_Mode_switch)) + return (Qnil); + return (gtk_keysym_to_emacs_keysym (event->keyval, simple_p)); + } + else + { + if (IS_MODIFIER_KEY (event->keyval) || (event->keyval == GDK_Mode_switch)) + return (Qnil); + return (gtk_keysym_to_emacs_keysym (event->keyval, simple_p)); + } +} + + +/************************************************************************/ +/* timeout events */ +/************************************************************************/ + +static int timeout_id_tick; + +struct GTK_timeout { + int id; + guint timeout_id; + struct GTK_timeout *next; +} *pending_timeouts, *completed_timeouts; + +struct GTK_timeout_blocktype +{ + Blocktype_declare (struct GTK_timeout); +} *the_GTK_timeout_blocktype; + +/* called by the gtk main loop */ +static gint +gtk_timeout_callback (gpointer closure) +{ + struct GTK_timeout *timeout = (struct GTK_timeout *) closure; + struct GTK_timeout *t2 = pending_timeouts; + + /* Remove this one from the list of pending timeouts */ + if (t2 == timeout) + pending_timeouts = pending_timeouts->next; + else + { + while (t2->next && t2->next != timeout) t2 = t2->next; + assert (t2->next); + t2->next = t2->next->next; + } + /* Add this one to the list of completed timeouts */ + timeout->next = completed_timeouts; + completed_timeouts = timeout; + return(FALSE); +} + +static int +emacs_gtk_add_timeout (EMACS_TIME thyme) +{ + struct GTK_timeout *timeout = Blocktype_alloc (the_GTK_timeout_blocktype); + EMACS_TIME current_time; + int milliseconds; + + timeout->id = timeout_id_tick++; + timeout->next = pending_timeouts; + pending_timeouts = timeout; + EMACS_GET_TIME (current_time); + EMACS_SUB_TIME (thyme, thyme, current_time); + milliseconds = EMACS_SECS (thyme) * 1000 + + EMACS_USECS (thyme) / 1000; + if (milliseconds < 1) + milliseconds = 1; + timeout->timeout_id = gtk_timeout_add (milliseconds, + gtk_timeout_callback, + (gpointer) timeout); + return timeout->id; +} + +static void +emacs_gtk_remove_timeout (int id) +{ + struct GTK_timeout *timeout, *t2; + + timeout = NULL; + + /* Find the timeout on the list of pending ones, if it's still there. */ + if (pending_timeouts) + { + if (id == pending_timeouts->id) + { + timeout = pending_timeouts; + pending_timeouts = pending_timeouts->next; + } + else + { + t2 = pending_timeouts; + while (t2->next && t2->next->id != id) t2 = t2->next; + if ( t2->next) /*found it */ + { + timeout = t2->next; + t2->next = t2->next->next; + } + } + /* if it was pending, we have removed it from the list */ + if (timeout) + gtk_timeout_remove (timeout->timeout_id); + } + + /* It could be that the call back was already called but we didn't convert + into an Emacs event yet */ + if (!timeout && completed_timeouts) + { + /* Code duplication! */ + if (id == completed_timeouts->id) + { + timeout = completed_timeouts; + completed_timeouts = completed_timeouts->next; + } + else + { + t2 = completed_timeouts; + while (t2->next && t2->next->id != id) t2 = t2->next; + if ( t2->next) /*found it */ + { + timeout = t2->next; + t2->next = t2->next->next; + } + } + } + + /* If we found the thing on the lists of timeouts, + and removed it, deallocate + */ + if (timeout) + Blocktype_free (the_GTK_timeout_blocktype, timeout); +} + +static void +gtk_timeout_to_emacs_event (struct Lisp_Event *emacs_event) +{ + struct GTK_timeout *timeout = completed_timeouts; + assert (timeout); + completed_timeouts = completed_timeouts->next; + emacs_event->event_type = timeout_event; + /* timeout events have nil as channel */ + emacs_event->timestamp = 0; /* #### wrong!! */ + emacs_event->event.timeout.interval_id = timeout->id; + Blocktype_free (the_GTK_timeout_blocktype, timeout); +} + + +/************************************************************************/ +/* process and tty events */ +/************************************************************************/ + +struct what_is_ready_closure +{ + int fd; + Lisp_Object what; + gint id; +}; + +static Lisp_Object *filedesc_with_input; +static struct what_is_ready_closure **filedesc_to_what_closure; + +static void +init_what_input_once (void) +{ + int i; + + filedesc_with_input = xnew_array (Lisp_Object, MAXDESC); + filedesc_to_what_closure = + xnew_array (struct what_is_ready_closure *, MAXDESC); + + for (i = 0; i < MAXDESC; i++) + { + filedesc_to_what_closure[i] = 0; + filedesc_with_input[i] = Qnil; + } + + process_events_occurred = 0; + tty_events_occurred = 0; +} + +static void +mark_what_as_being_ready (struct what_is_ready_closure *closure) +{ + if (NILP (filedesc_with_input[closure->fd])) + { + SELECT_TYPE temp_mask; + FD_ZERO (&temp_mask); + FD_SET (closure->fd, &temp_mask); + /* Check to make sure there's *really* input available. + Sometimes things seem to get confused and this gets called + for the tty fd when there's really only input available + on some process's fd. (It will subsequently get called + for that process's fd, so returning without setting any + flags will take care of it.) To see the problem, uncomment + the stderr_out below, turn NORMAL_QUIT_CHECK_TIMEOUT_MSECS + down to 25, do sh -c 'xemacs -nw -q -f shell 2>/tmp/log' + and press return repeatedly. (Seen under AIX & Linux.) + -dkindred@cs.cmu.edu */ + if (!poll_fds_for_input (temp_mask)) + { +#if 0 + stderr_out ("mark_what_as_being_ready: no input available (fd=%d)\n", + closure->fd); +#endif + return; + } + filedesc_with_input[closure->fd] = closure->what; + if (PROCESSP (closure->what)) + { + /* Don't increment this if the current process is already marked + * as having input. */ + process_events_occurred++; + } + else + { + tty_events_occurred++; + } + } +} + +static void +gtk_what_callback (gpointer closure, gint source, GdkInputCondition why) +{ + /* If closure is 0, then we got a fake event from a signal handler. + The only purpose of this is to make XtAppProcessEvent() stop + blocking. */ + if (closure) + mark_what_as_being_ready ((struct what_is_ready_closure *) closure); + else + { + fake_event_occurred++; + drain_signal_event_pipe (); + } +} + +static void +select_filedesc (int fd, Lisp_Object what) +{ + struct what_is_ready_closure *closure; + + /* If somebody is trying to select something that's already selected + for, then something went wrong. The generic routines ought to + detect this and error before here. */ + assert (!filedesc_to_what_closure[fd]); + + closure = xnew (struct what_is_ready_closure); + closure->fd = fd; + closure->what = what; + closure->id = gdk_input_add (fd, GDK_INPUT_READ, + (GdkInputFunction) gtk_what_callback, closure); + filedesc_to_what_closure[fd] = closure; +} + +static void +unselect_filedesc (int fd) +{ + struct what_is_ready_closure *closure = filedesc_to_what_closure[fd]; + + assert (closure); + if (!NILP (filedesc_with_input[fd])) + { + /* We are unselecting this process before we have drained the rest of + the input from it, probably from status_notify() in the command loop. + This can happen like so: + + - We are waiting in XtAppNextEvent() + - Process generates output + - Process is marked as being ready + - Process dies, SIGCHLD gets generated before we return (!?) + It could happen I guess. + - sigchld_handler() marks process as dead + - Somehow we end up getting a new KeyPress event on the queue + at the same time (I'm really so sure how that happens but I'm + not sure it can't either so let's assume it can...). + - Key events have priority so we return that instead of the proc. + - Before dispatching the lisp key event we call status_notify() + - Which deselects the process that SIGCHLD marked as dead. + + Thus we never remove it from _with_input and turn it into a lisp + event, so we need to do it here. But this does not mean that we're + throwing away the last block of output - status_notify() has already + taken care of running the proc filter or whatever. + */ + filedesc_with_input[fd] = Qnil; + if (PROCESSP (closure->what)) + { + assert (process_events_occurred > 0); + process_events_occurred--; + } + else + { + assert (tty_events_occurred > 0); + tty_events_occurred--; + } + } + gdk_input_remove (closure->id); + xfree (closure); + filedesc_to_what_closure[fd] = 0; +} + +static void +emacs_gtk_select_process (struct Lisp_Process *p) +{ + Lisp_Object process; + int infd = event_stream_unixoid_select_process (p); + + XSETPROCESS (process, p); + select_filedesc (infd, process); +} + +static void +emacs_gtk_unselect_process (struct Lisp_Process *p) +{ + int infd = event_stream_unixoid_unselect_process (p); + + unselect_filedesc (infd); +} + +static USID +emacs_gtk_create_stream_pair (void* inhandle, void* outhandle, + Lisp_Object* instream, Lisp_Object* outstream, int flags) +{ + USID u = event_stream_unixoid_create_stream_pair + (inhandle, outhandle, instream, outstream, flags); + if (u != USID_ERROR) + u = USID_DONTHASH; + return u; +} + +static USID +emacs_gtk_delete_stream_pair (Lisp_Object instream, Lisp_Object outstream) +{ + event_stream_unixoid_delete_stream_pair (instream, outstream); + return USID_DONTHASH; +} + +/* This is called from GC when a process object is about to be freed. + If we've still got pointers to it in this file, we're gonna lose hard. + */ +void +debug_process_finalization (struct Lisp_Process *p) +{ +#if 0 /* #### */ + int i; + Lisp_Object instr, outstr; + + get_process_streams (p, &instr, &outstr); + /* if it still has fds, then it hasn't been killed yet. */ + assert (NILP(instr)); + assert (NILP(outstr)); + /* Better not still be in the "with input" table; we know it's got no fds. */ + for (i = 0; i < MAXDESC; i++) + { + Lisp_Object process = filedesc_fds_with_input [i]; + assert (!PROCESSP (process) || XPROCESS (process) != p); + } +#endif +} + +static void +gtk_process_to_emacs_event (struct Lisp_Event *emacs_event) +{ + int i; + Lisp_Object process; + + assert (process_events_occurred > 0); + for (i = 0; i < MAXDESC; i++) + { + process = filedesc_with_input[i]; + if (PROCESSP (process)) + break; + } + assert (i < MAXDESC); + filedesc_with_input[i] = Qnil; + process_events_occurred--; + /* process events have nil as channel */ + emacs_event->event_type = process_event; + emacs_event->timestamp = 0; /* #### */ + emacs_event->event.process.process = process; +} + +static void +emacs_gtk_select_console (struct console *con) +{ + Lisp_Object console; + int infd; + + if (CONSOLE_GTK_P (con)) + return; /* Gtk consoles are automatically selected for when we initialize them */ + infd = event_stream_unixoid_select_console (con); + XSETCONSOLE (console, con); + select_filedesc (infd, console); +} + +static void +emacs_gtk_unselect_console (struct console *con) +{ + Lisp_Object console; + int infd; + + if (CONSOLE_GTK_P (con)) + return; /* X consoles are automatically selected for when we initialize them */ + infd = event_stream_unixoid_unselect_console (con); + XSETCONSOLE (console, con); + unselect_filedesc (infd); +} + +/* read an event from a tty, if one is available. Returns non-zero + if an event was available. Note that when this function is + called, there should always be a tty marked as ready for input. + However, the input condition might actually be EOF, so there + may not really be any input available. (In this case, + read_event_from_tty_or_stream_desc() will arrange for the TTY device + to be deleted.) */ + +static int +gtk_tty_to_emacs_event (struct Lisp_Event *emacs_event) +{ + int i; + + assert (tty_events_occurred > 0); + for (i = 0; i < MAXDESC; i++) + { + Lisp_Object console = filedesc_with_input[i]; + if (CONSOLEP (console)) + { + assert (tty_events_occurred > 0); + tty_events_occurred--; + filedesc_with_input[i] = Qnil; + if (read_event_from_tty_or_stream_desc + (emacs_event, XCONSOLE (console), i)) + return 1; + } + } + + return 0; +} + + +/************************************************************************/ +/* Drag 'n Drop handling */ +/************************************************************************/ +#ifdef HAVE_DRAGNDROP +#define TARGET_URI_LIST 0x00 +#define TARGET_TEXT_PLAIN 0x01 +#define TARGET_FILE_NAME 0x02 +#define TARGET_NETSCAPE 0x03 + +static GdkAtom preferred_targets[10]; + +void +dragndrop_data_received (GtkWidget *widget, + GdkDragContext *context, + gint x, + gint y, + GtkSelectionData *data, + guint info, + guint time) +{ + Lisp_Object event = Fmake_event (Qnil, Qnil); + struct device *d = gtk_any_window_to_device (widget->window); + struct frame *f = gtk_any_widget_or_parent_to_frame (d, widget); + struct Lisp_Event *ev = XEVENT (event); + Lisp_Object l_type = Qnil, l_data = Qnil; + Lisp_Object l_dndlist = Qnil, l_item = Qnil; + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; + + GCPRO4 (l_type, l_data, l_dndlist, l_item); + + ev->event_type = misc_user_event; + ev->timestamp = time; + + XSETFRAME (ev->channel, f); + + ev->event.misc.x = x; + ev->event.misc.y = y; + + if (data->type == preferred_targets[TARGET_URI_LIST]) + { + /* newline-separated list of URLs */ + int start, end; + const char *string_data = (char *) data->data; + + l_type = Qdragdrop_URL; + + for (start = 0, end = 0; string_data && string_data[end]; end++) + { + if ((string_data[end] == '\r') && (string_data[end+1] == '\n')) + { + l_item = make_string (&string_data[start], end - start); + l_dndlist = Fcons (l_item, l_dndlist); + ++end; + start = ++end; + } + } + } + else if (data->type == preferred_targets[TARGET_TEXT_PLAIN]) + { + /* Arbitrary string */ + l_type = Qdragdrop_MIME; + l_dndlist = list1 (list3 (list1 (build_string ("text/plain")), + build_string ("8_bit"), + make_ext_string (data->data, + strlen ((char *)data->data), + Qctext))); + } + else if (data->type == preferred_targets[TARGET_FILE_NAME]) + { + /* Random filename */ + char *hurl = dnd_url_hexify_string (data->data, "file:"); + + l_dndlist = list1 (make_string ((Bufbyte *)hurl, strlen (hurl))); + l_type = Qdragdrop_URL; + + xfree (hurl); + } + else if (data->type == preferred_targets[TARGET_NETSCAPE]) + { + /* Single URL */ + l_dndlist = list1 (make_string ((Extbyte *)data->data, + strlen ((char *)data->data))); + l_type = Qdragdrop_URL; + } + else + { + /* Unknown type - what to do? + We just pass it up to lisp - we already have a mime type. + */ + l_type = Qdragdrop_MIME; + l_dndlist = list1 (list3 (list1 (build_string (gdk_atom_name (data->type))), + build_string ("8bit"), + make_ext_string ((Extbyte *) data->data, + data->length, Qbinary))); + } + + ev->event.misc.function = Qdragdrop_drop_dispatch; + ev->event.misc.object = Fcons (l_type, l_dndlist); + + UNGCPRO; + + gtk_drag_finish (context, TRUE, FALSE, time); + enqueue_gtk_dispatch_event (event); +} + +gboolean +dragndrop_dropped (GtkWidget *widget, + GdkDragContext *drag_context, + gint x, + gint y, + guint time, + gpointer user_data) +{ + /* Netscape drops things like: + STRING + _SGI_ICON + _SGI_ICON_TYPE + SGI_FILE + FILE_NAME + _NETSCAPE_URL + + gmc drops things like + application/x-mc-desktop-icon + text/uri-list + text/plain + _NETSCAPE_URL + + We prefer: + text/uri-list + text/plain + FILE_NAME + _NETSCAPE_URL + first one + */ + GdkAtom found = 0; + GList *list = drag_context->targets; + + int i; + + if (!preferred_targets[0]) + { + preferred_targets[TARGET_URI_LIST] = gdk_atom_intern ("text/uri-list", FALSE); + preferred_targets[TARGET_TEXT_PLAIN] = gdk_atom_intern ("text/plain", FALSE); + preferred_targets[TARGET_FILE_NAME] = gdk_atom_intern ("FILE_NAME", FALSE); + preferred_targets[TARGET_NETSCAPE] = gdk_atom_intern ("_NETSCAPE_URL", FALSE); + } + +#if 0 + stderr_out ("Drop info available in the following formats: \n"); + while (list) + { + stderr_out ("\t%s\n", gdk_atom_name ((GdkAtom)list->data)); + list = list->next; + } + list = drag_context->targets; +#endif + + while (list && !found) + { + for (i = 0; preferred_targets[i] && !found; i++) + { + if ((GdkAtom) list->data == preferred_targets[i]) + { + found = (GdkAtom) list->data; + } + } + list = list->next; + } + + if (!found) + { + found = (GdkAtom) drag_context->targets->data; + } + + gtk_drag_get_data (GTK_WIDGET (user_data), drag_context, found, time); + return (TRUE); +} +#endif /* HAVE_DRAGNDROP */ + + +/************************************************************************/ +/* get the next event from gtk */ +/************************************************************************/ + +static Lisp_Object dispatch_event_queue, dispatch_event_queue_tail; + +static void +enqueue_gtk_dispatch_event (Lisp_Object event) +{ + enqueue_event (event, &dispatch_event_queue, &dispatch_event_queue_tail); +} + +static Lisp_Object +dequeue_gtk_dispatch_event (void) +{ + return dequeue_event (&dispatch_event_queue, &dispatch_event_queue_tail); +} + +/* This business exists because menu events "happen" when + menubar_selection_callback() is called from somewhere deep + within XtAppProcessEvent in emacs_Xt_next_event(). The + callback needs to terminate the modal loop in that function + or else it will continue waiting until another event is + received. + + Same business applies to scrollbar events. */ + +void +signal_special_gtk_user_event (Lisp_Object channel, Lisp_Object function, + Lisp_Object object) +{ + Lisp_Object event = Fmake_event (Qnil, Qnil); + + XEVENT (event)->event_type = misc_user_event; + XEVENT (event)->channel = channel; + XEVENT (event)->event.eval.function = function; + XEVENT (event)->event.eval.object = object; + + enqueue_gtk_dispatch_event (event); +} + +static void +emacs_gtk_next_event (struct Lisp_Event *emacs_event) +{ + we_didnt_get_an_event: + + while (NILP (dispatch_event_queue) && + !completed_timeouts && + !fake_event_occurred && + !process_events_occurred && + !tty_events_occurred) + { + gtk_main_iteration(); + } + + if (!NILP (dispatch_event_queue)) + { + Lisp_Object event, event2; + XSETEVENT (event2, emacs_event); + event = dequeue_gtk_dispatch_event (); + Fcopy_event (event, event2); + Fdeallocate_event (event); + } + else if (tty_events_occurred) + { + if (!gtk_tty_to_emacs_event (emacs_event)) + goto we_didnt_get_an_event; + } + else if (completed_timeouts) + gtk_timeout_to_emacs_event (emacs_event); + else if (fake_event_occurred) + { + /* A dummy event, so that a cycle of the command loop will occur. */ + fake_event_occurred = 0; + /* eval events have nil as channel */ + emacs_event->event_type = eval_event; + emacs_event->event.eval.function = Qidentity; + emacs_event->event.eval.object = Qnil; + } + else /* if (process_events_occurred) */ + gtk_process_to_emacs_event (emacs_event); +} + +int +gtk_event_to_emacs_event (struct frame *frame, GdkEvent *gdk_event, struct Lisp_Event *emacs_event) +{ + struct device *d = NULL; + struct gtk_device *gd = NULL; + gboolean accept_any_window = FALSE; + + if (!frame) + { + frame = XFRAME (Fselected_frame (Vdefault_gtk_device)); + accept_any_window = TRUE; + } + + d = XDEVICE (FRAME_DEVICE (frame)); + gd = DEVICE_GTK_DATA (d); + + set_last_server_timestamp (d, gdk_event); + + switch (gdk_event->type) + { + /* XEmacs handles double and triple clicking on its own, and if + we capture these events, it royally confuses the code in + ../lisp/mouse.el */ + case GDK_2BUTTON_PRESS: + case GDK_3BUTTON_PRESS: + return (0); + + case GDK_BUTTON_PRESS: + case GDK_BUTTON_RELEASE: + /* We need to ignore button events outside our main window or + things get ugly. The standard scrollbars in Gtk try to be + nice and pass the button press events up to the parent + widget. This causes us no end of grief though. Effects + range from setting point to the wrong place to selecting + new windows. */ + { + GdkWindow *w = gdk_window_at_pointer (NULL, NULL); + + /* If you press mouse button and drag it around, and release + it outside the window, you will get a NULL GdkWindow at + pointer. We need to forward these events on to XEmacs so + that the mouse selection voodoo works. + */ + if (w && (w != gdk_window_lookup (GDK_ROOT_WINDOW ()))) + { + GdkEvent ev; + GtkWidget *wid = NULL; + + ev.any.window = w; + wid = gtk_get_event_widget (&ev); + + if (!GTK_IS_XEMACS (wid) && !accept_any_window) + { + return (0); + } + } + if (!accept_any_window) + gtk_widget_grab_focus (FRAME_GTK_TEXT_WIDGET (frame)); + } + /* Fall through */ + case GDK_KEY_PRESS: + { + unsigned int modifiers = 0; + int shift_p, lock_p; + gboolean key_event_p = (gdk_event->type == GDK_KEY_PRESS); + unsigned int *state = + key_event_p ? &gdk_event->key.state : &gdk_event->button.state; + + /* If this is a synthetic KeyPress or Button event, and the user + has expressed a disinterest in this security hole, then drop + it on the floor. */ + /* #### BILL!!! Should this be a generic check for ANY synthetic + event? */ + if ((gdk_event->any.send_event) && !gtk_allow_sendevents) + return 0; + + DEVICE_GTK_MOUSE_TIMESTAMP (d) = + DEVICE_GTK_GLOBAL_MOUSE_TIMESTAMP (d) = + key_event_p ? gdk_event->key.time : gdk_event->button.time; + + if (*state & GDK_CONTROL_MASK) modifiers |= XEMACS_MOD_CONTROL; + if (*state & gd->MetaMask) modifiers |= XEMACS_MOD_META; + if (*state & gd->SuperMask) modifiers |= XEMACS_MOD_SUPER; + if (*state & gd->HyperMask) modifiers |= XEMACS_MOD_HYPER; + if (*state & gd->AltMask) modifiers |= XEMACS_MOD_ALT; + + /* Ignore the Caps_Lock key if: + - any other modifiers are down, so that Caps_Lock doesn't + turn C-x into C-X, which would suck. + - the event was a mouse event. */ + if (modifiers || ! key_event_p) + *state &= (~GDK_LOCK_MASK); + + shift_p = *state & GDK_SHIFT_MASK; + lock_p = *state & GDK_LOCK_MASK; + + if (shift_p || lock_p) + modifiers |= XEMACS_MOD_SHIFT; + + if (key_event_p) + { + GdkEventKey *key_event = &gdk_event->key; + Lisp_Object keysym; + + /* This used to compute the frame from the given X window and + store it here, but we really don't care about the frame. */ + emacs_event->channel = DEVICE_CONSOLE (d); + + /* Keysym mucking has already been done inside the + GdkEventKey parsing */ + keysym = gtk_to_emacs_keysym (d, key_event, 0); + + /* If the emacs keysym is nil, then that means that the X + keysym was either a Modifier or NoSymbol, which + probably means that we're in the midst of reading a + Multi_key sequence, or a "dead" key prefix, or XIM + input. Ignore it. */ + if (NILP (keysym)) + return 0; + + /* More Caps_Lock garbage: Caps_Lock should *only* add the + shift modifier to two-case keys (that is, A-Z and + related characters). So at this point (after looking up + the keysym) if the keysym isn't a dual-case alphabetic, + and if the caps lock key was down but the shift key + wasn't, then turn off the shift modifier. Gag barf */ + /* #### type lossage: assuming equivalence of emacs and + X keysyms */ + /* !!#### maybe fix for Mule */ + if (lock_p && !shift_p && + ! (CHAR_OR_CHAR_INTP (keysym) + && keysym_obeys_caps_lock_p + ((guint) XCHAR_OR_CHAR_INT (keysym), d))) + modifiers &= (~XEMACS_MOD_SHIFT); + + /* If this key contains two distinct keysyms, that is, + "shift" generates a different keysym than the + non-shifted key, then don't apply the shift modifier + bit: it's implicit. Otherwise, if there would be no + other way to tell the difference between the shifted + and unshifted version of this key, apply the shift bit. + Non-graphics, like Backspace and F1 get the shift bit + in the modifiers slot. Neither the characters "a", + "A", "2", nor "@" normally have the shift bit set. + However, "F1" normally does. */ + if (modifiers & XEMACS_MOD_SHIFT) + { + if (CHAR_OR_CHAR_INTP (keysym)) + { + modifiers &= ~XEMACS_MOD_SHIFT; + } + } + + emacs_event->event_type = key_press_event; + emacs_event->timestamp = key_event->time; + emacs_event->event.key.modifiers = modifiers; + emacs_event->event.key.keysym = keysym; + } + else /* Mouse press/release event */ + { + GdkEventButton *button_event = &gdk_event->button; + XSETFRAME (emacs_event->channel, frame); + + emacs_event->event_type = (button_event->type == GDK_BUTTON_RELEASE) ? + button_release_event : button_press_event; + + emacs_event->event.button.modifiers = modifiers; + emacs_event->timestamp = button_event->time; + emacs_event->event.button.button = button_event->button; + emacs_event->event.button.x = button_event->x; + emacs_event->event.button.y = button_event->y; + } + } + break; + case GDK_KEY_RELEASE: + return 0; + break; + case GDK_MOTION_NOTIFY: + { + GdkEventMotion *ev = &gdk_event->motion; + unsigned int modifiers = 0; + gint x,y; + GdkModifierType mask; + + /* We use MOTION_HINT_MASK, so we will get only one motion + event until the next time we call gdk_window_get_pointer or + the user clicks the mouse. So call gdk_window_get_pointer + now (meaning that the event will be in sync with the server + just before Fnext_event() returns). If the mouse is still + in motion, then the server will immediately generate + exactly one more motion event, which will be on the queue + waiting for us next time around. */ + gdk_window_get_pointer (ev->window, &x, &y, &mask); + + DEVICE_GTK_MOUSE_TIMESTAMP (d) = ev->time; + + XSETFRAME (emacs_event->channel, frame); + emacs_event->event_type = pointer_motion_event; + emacs_event->timestamp = ev->time; + emacs_event->event.motion.x = x; + emacs_event->event.motion.y = y; + if (mask & GDK_SHIFT_MASK) modifiers |= XEMACS_MOD_SHIFT; + if (mask & GDK_CONTROL_MASK) modifiers |= XEMACS_MOD_CONTROL; + if (mask & gd->MetaMask) modifiers |= XEMACS_MOD_META; + if (mask & gd->SuperMask) modifiers |= XEMACS_MOD_SUPER; + if (mask & gd->HyperMask) modifiers |= XEMACS_MOD_HYPER; + if (mask & gd->AltMask) modifiers |= XEMACS_MOD_ALT; + /* Currently ignores Shift_Lock but probably shouldn't + (but it definitely should ignore Caps_Lock). */ + emacs_event->event.motion.modifiers = modifiers; + } + break; + + default: /* it's a magic event */ + return (0); + break; + } + return 1; +} + +static const char *event_name (GdkEvent *); + +static gboolean +generic_event_handler (GtkWidget *widget, GdkEvent *event) +{ + Lisp_Object emacs_event = Qnil; + if (!GTK_IS_XEMACS (widget)) + { + stderr_out ("Got a %s event for a non-XEmacs widget\n",event_name (event)); + return (FALSE); + } + + emacs_event = Fmake_event (Qnil, Qnil); + + if (gtk_event_to_emacs_event (GTK_XEMACS_FRAME (widget), event, XEVENT (emacs_event))) + { + enqueue_gtk_dispatch_event (emacs_event); + return (TRUE); + } + else + { + Fdeallocate_event (emacs_event); + } + return (FALSE); +} + +gint emacs_gtk_key_event_handler(GtkWidget *widget, GdkEventKey *event) +{ + return (generic_event_handler (widget, (GdkEvent *) event)); +} + +gint emacs_gtk_button_event_handler(GtkWidget *widget, GdkEventButton *event) +{ + return (generic_event_handler (widget, (GdkEvent *) event)); +} + +gint emacs_gtk_motion_event_handler (GtkWidget *widget, GdkEventMotion *event) +{ + return (generic_event_handler (widget, (GdkEvent *) event)); +} + +gboolean +emacs_shell_event_handler (GtkWidget *wid /* unused */, + GdkEvent *event, + gpointer closure) +{ + struct frame *frame = (struct frame *) closure; + Lisp_Object lisp_event = Fmake_event (Qnil, Qnil); + struct Lisp_Event *emacs_event = XEVENT (lisp_event); + GdkEvent *gdk_event_copy = &emacs_event->event.magic.underlying_gdk_event; + struct device *d = XDEVICE (FRAME_DEVICE (frame)); + gboolean ignore_p = FALSE; + + set_last_server_timestamp (d, event); + +#define FROB(event_member) gdk_event_copy->event_member = event->event_member + + switch (event->type) + { + case GDK_SELECTION_REQUEST: + case GDK_SELECTION_CLEAR: + case GDK_SELECTION_NOTIFY: FROB(selection); break; + case GDK_PROPERTY_NOTIFY: FROB(property); break; + case GDK_CLIENT_EVENT: FROB(client); break; + case GDK_MAP: + case GDK_UNMAP: FROB(any); break; + case GDK_CONFIGURE: FROB(configure); break; + case GDK_ENTER_NOTIFY: + case GDK_LEAVE_NOTIFY: FROB(crossing); break; + case GDK_FOCUS_CHANGE: FROB(focus_change); break; + case GDK_VISIBILITY_NOTIFY: FROB(visibility); break; + default: + ignore_p = TRUE; + /* Hrmm... do we really want to swallow all the other events as magic? */ + *gdk_event_copy = *event; + break; + } +#undef FROB + + emacs_event->event_type = magic_event; + XSETFRAME (emacs_event->channel, frame); + + if (ignore_p) + { + stderr_out ("Ignoring event... (%s)\n", event_name (event)); + Fdeallocate_event (lisp_event); + return (FALSE); + } + else + { + enqueue_gtk_dispatch_event (lisp_event); + return (TRUE); + } +} + + +/************************************************************************/ +/* input pending / C-g checking */ +/************************************************************************/ +static void +gtk_check_for_quit_char (struct device *d); + +static void +check_for_tty_quit_char (struct device *d) +{ + SELECT_TYPE temp_mask; + int infd = DEVICE_INFD (d); + struct console *con = XCONSOLE (DEVICE_CONSOLE (d)); + Emchar quit_char = CONSOLE_QUIT_CHAR (con); + + FD_ZERO (&temp_mask); + FD_SET (infd, &temp_mask); + + while (1) + { + Lisp_Object event; + Emchar the_char; + + if (!poll_fds_for_input (temp_mask)) + return; + + event = Fmake_event (Qnil, Qnil); + if (!read_event_from_tty_or_stream_desc (XEVENT (event), con, infd)) + /* EOF, or something ... */ + return; + /* #### bogus. quit-char should be allowed to be any sort + of event. */ + the_char = event_to_character (XEVENT (event), 1, 0, 0); + if (the_char >= 0 && the_char == quit_char) + { + Vquit_flag = Qt; + /* do not queue the C-g. See above. */ + return; + } + + /* queue the read event to be read for real later. */ + enqueue_gtk_dispatch_event (event); + } +} + +static void +emacs_gtk_quit_p (void) +{ + Lisp_Object devcons, concons; + + CONSOLE_LOOP (concons) + { + struct console *con = XCONSOLE (XCAR (concons)); + if (!con->input_enabled) + continue; + + CONSOLE_DEVICE_LOOP (devcons, con) + { + struct device *d; + d = XDEVICE (XCAR (devcons)); + + if (DEVICE_GTK_P (d)) + /* emacs may be exiting */ + gtk_check_for_quit_char (d); + else if (DEVICE_TTY_P (d)) + check_for_tty_quit_char (d); + } + } +} + +#include + +static void +drain_gtk_queue (void) + +{ + /* We can't just spin through here and wait for GTKs idea of the + event queue to get empty, or the queue never gets drained. The + situation is as follows. A process event gets signalled, we put + it on the queue, then we go into Fnext_event(), which calls + drain_gtk_queue(). But gtk_events_pending() will always return + TRUE if there are file-descriptor (aka our process) events + pending. Using GDK_events_pending() only shows us windowing + system events. + */ + if (GDK_DISPLAY ()) + while (gdk_events_pending ()) + gtk_main_iteration (); +} + +static int +emacs_gtk_event_pending_p (int user_p) +{ + Lisp_Object event; + int tick_count_val; + + /* If `user_p' is false, then this function returns whether there are any + X, timeout, or fd events pending (that is, whether emacs_gtk_next_event() + would return immediately without blocking). + + if `user_p' is true, then this function returns whether there are any + *user generated* events available (that is, whether there are keyboard + or mouse-click events ready to be read). This also implies that + emacs_Xt_next_event() would not block. + + In a non-SIGIO world, this also checks whether the user has typed ^G, + since this is a convenient place to do so. We don't need to do this + in a SIGIO world, since input causes an interrupt. + */ + + /* This function used to simply check whether there were any X + events (or if user_p was 1, it iterated over all the pending + X events using XCheckIfEvent(), looking for keystrokes and + button events). That worked in the old cheesoid event loop, + which didn't go through XtAppDispatchEvent(), but it doesn't + work any more -- X events may not result in anything. For + example, a button press in a blank part of the menubar appears + as an X event but will not result in any Emacs events (a + button press that activates the menubar results in an Emacs + event through the stop_next_event mechanism). + + The only accurate way of determining whether these X events + translate into Emacs events is to go ahead and dispatch them + until there's something on the dispatch queue. */ + + /* See if there are any user events already on the queue. */ + EVENT_CHAIN_LOOP (event, dispatch_event_queue) + if (!user_p || command_event_p (event)) + return 1; + + /* See if there's any TTY input available. + */ + if (poll_fds_for_input (tty_only_mask)) + return 1; + + if (!user_p) + { + /* If not user_p and there are any timer or file-desc events + pending, we know there will be an event so we're through. */ +/* XtInputMask pending_value; */ + + /* Note that formerly we just checked the value of XtAppPending() + to determine if there was file-desc input. This doesn't + work any more with the signal_event_pipe; XtAppPending() + will says "yes" in this case but there isn't really any + input. Another way of fixing this problem is for the + signal_event_pipe to generate actual input in the form + of an identity eval event or something. (#### maybe this + actually happens?) */ + + if (poll_fds_for_input (process_only_mask)) + return 1; + + /* #### Is there any way to do this in Gtk? I don't think there + is a 'peek' for events */ +#if 0 + pending_value = XtAppPending (Xt_app_con); + + if (pending_value & XtIMTimer) + return 1; +#endif + } + + /* XtAppPending() can be super-slow, esp. over a network connection. + Quantify results have indicated that in some cases the + call to detect_input_pending() completely dominates the + running time of redisplay(). Fortunately, in a SIGIO world + we can more quickly determine whether there are any X events: + if an event has happened since the last time we checked, then + a SIGIO will have happened. On a machine with broken SIGIO, + we'll still be in an OK state -- the sigio_happened flag + will get set at least once a second, so we'll be no more than + one second behind reality. (In general it's OK if we + erroneously report no input pending when input is actually + pending() -- preemption is just a bit less efficient, that's + all. It's bad bad bad if you err the other way -- you've + promised that `next-event' won't block but it actually will, + and some action might get delayed until the next time you + hit a key.) + */ + + /* quit_check_signal_tick_count is volatile so try to avoid race conditions + by using a temporary variable */ + tick_count_val = quit_check_signal_tick_count; + if (last_quit_check_signal_tick_count != tick_count_val) + { + last_quit_check_signal_tick_count = tick_count_val; + + /* We need to drain the entire queue now -- if we only + drain part of it, we may later on end up with events + actually pending but detect_input_pending() returning + false because there wasn't another SIGIO. */ + + drain_gtk_queue (); + + EVENT_CHAIN_LOOP (event, dispatch_event_queue) + if (!user_p || command_event_p (event)) + return 1; + } + + return 0; +} + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +syms_of_event_gtk (void) +{ + defsymbol (&Qkey_mapping, "key-mapping"); + defsymbol (&Qsans_modifiers, "sans-modifiers"); +} + +void reinit_vars_of_event_gtk (void) +{ + gtk_event_stream = xnew (struct event_stream); + gtk_event_stream->event_pending_p = emacs_gtk_event_pending_p; + gtk_event_stream->next_event_cb = emacs_gtk_next_event; + gtk_event_stream->handle_magic_event_cb= emacs_gtk_handle_magic_event; + gtk_event_stream->add_timeout_cb = emacs_gtk_add_timeout; + gtk_event_stream->remove_timeout_cb = emacs_gtk_remove_timeout; + gtk_event_stream->select_console_cb = emacs_gtk_select_console; + gtk_event_stream->unselect_console_cb = emacs_gtk_unselect_console; + gtk_event_stream->select_process_cb = emacs_gtk_select_process; + gtk_event_stream->unselect_process_cb = emacs_gtk_unselect_process; + gtk_event_stream->quit_p_cb = emacs_gtk_quit_p; + gtk_event_stream->create_stream_pair_cb= emacs_gtk_create_stream_pair; + gtk_event_stream->delete_stream_pair_cb= emacs_gtk_delete_stream_pair; + + the_GTK_timeout_blocktype = Blocktype_new (struct GTK_timeout_blocktype); + + /* this function only makes safe calls */ + init_what_input_once (); +} + +void +vars_of_event_gtk (void) +{ + reinit_vars_of_event_gtk (); + + dispatch_event_queue = Qnil; + staticpro (&dispatch_event_queue); + dispatch_event_queue_tail = Qnil; + + DEFVAR_BOOL ("gtk-allow-sendevents", >k_allow_sendevents /* +*Non-nil means to allow synthetic events. Nil means they are ignored. +Beware: allowing emacs to process SendEvents opens a big security hole. +*/ ); + gtk_allow_sendevents = 0; + + last_quit_check_signal_tick_count = 0; +} + +void +init_event_gtk_late (void) /* called when already initialized */ +{ + timeout_id_tick = 1; + pending_timeouts = 0; + completed_timeouts = 0; + + event_stream = gtk_event_stream; + +#if 0 + /* Shut GDK the hell up */ + gdk_error_trap_push (); +#endif + + gdk_input_add (signal_event_pipe[0], GDK_INPUT_READ, + (GdkInputFunction) gtk_what_callback, NULL); +} + +/* Bogus utility routines */ +static const char *event_name (GdkEvent *ev) +{ + return (gtk_event_name (ev->any.type)); +} + +/* This is down at the bottom of the file so I can avoid polluting the + generic code with this X specific CRAP! */ + +#include +#include +/* #### BILL!!! Fix this please! */ + + +/************************************************************************/ +/* keymap handling */ +/************************************************************************/ + +/* X bogusly doesn't define the interpretations of any bits besides + ModControl, ModShift, and ModLock; so the Interclient Communication + Conventions Manual says that we have to bend over backwards to figure + out what the other modifier bits mean. According to ICCCM: + + - Any keycode which is assigned ModControl is a "control" key. + + - Any modifier bit which is assigned to a keycode which generates Meta_L + or Meta_R is the modifier bit meaning "meta". Likewise for Super, Hyper, + etc. + + - Any keypress event which contains ModControl in its state should be + interpreted as a "control" character. + + - Any keypress event which contains a modifier bit in its state which is + generated by a keycode whose corresponding keysym is Meta_L or Meta_R + should be interpreted as a "meta" character. Likewise for Super, Hyper, + etc. + + - It is illegal for a keysym to be associated with more than one modifier + bit. + + This means that the only thing that emacs can reasonably interpret as a + "meta" key is a key whose keysym is Meta_L or Meta_R, and which generates + one of the modifier bits Mod1-Mod5. + + Unfortunately, many keyboards don't have Meta keys in their default + configuration. So, if there are no Meta keys, but there are "Alt" keys, + emacs will interpret Alt as Meta. If there are both Meta and Alt keys, + then the Meta keys mean "Meta", and the Alt keys mean "Alt" (it used to + mean "Symbol," but that just confused the hell out of way too many people). + + This works with the default configurations of the 19 keyboard-types I've + checked. + + Emacs detects keyboard configurations which violate the above rules, and + prints an error message on the standard-error-output. (Perhaps it should + use a pop-up-window instead.) + */ + +static void +gtk_reset_key_mapping (struct device *d) +{ + Display *display = GDK_DISPLAY (); + struct gtk_device *xd = DEVICE_GTK_DATA (d); + XModifierKeymap *map = (XModifierKeymap *) xd->x_keysym_map; + KeySym *keysym, *keysym_end; + Lisp_Object hashtable; + int key_code_count, keysyms_per_code; + + if (map) + XFree ((char *) map); + XDisplayKeycodes (display, + &xd->x_keysym_map_min_code, + &xd->x_keysym_map_max_code); + key_code_count = xd->x_keysym_map_max_code - xd->x_keysym_map_min_code + 1; + map = (XModifierKeymap *) + XGetKeyboardMapping (display, xd->x_keysym_map_min_code, key_code_count, + &xd->x_keysym_map_keysyms_per_code); + + xd->x_keysym_map = (void *)map; + hashtable = xd->x_keysym_map_hashtable; + if (HASH_TABLEP (hashtable)) + { + Fclrhash (hashtable); + } + else + { + xd->x_keysym_map_hashtable = hashtable = + make_lisp_hash_table (128, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + } + + for (keysym = (KeySym *) map, + keysyms_per_code = xd->x_keysym_map_keysyms_per_code, + keysym_end = keysym + (key_code_count * keysyms_per_code); + keysym < keysym_end; + keysym += keysyms_per_code) + { + int j; + + if (keysym[0] == NoSymbol) + continue; + + { + char *name = XKeysymToString (keysym[0]); + Lisp_Object sym = gtk_keysym_to_emacs_keysym (keysym[0], 0); + if (name) + { + Fputhash (build_string (name), Qsans_modifiers, hashtable); + Fputhash (sym, Qsans_modifiers, hashtable); + } + } + + for (j = 1; j < keysyms_per_code; j++) + { + if (keysym[j] != keysym[0] && + keysym[j] != NoSymbol) + { + char *name = XKeysymToString (keysym[j]); + Lisp_Object sym = gtk_keysym_to_emacs_keysym (keysym[j], 0); + if (name && NILP (Fgethash (sym, hashtable, Qnil))) + { + Fputhash (build_string (name), Qt, hashtable); + Fputhash (sym, Qt, hashtable); + } + } + } + } +} + +static const char * +index_to_name (int indice) +{ + switch (indice) + { + case ShiftMapIndex: return "ModShift"; + case LockMapIndex: return "ModLock"; + case ControlMapIndex: return "ModControl"; + case Mod1MapIndex: return "Mod1"; + case Mod2MapIndex: return "Mod2"; + case Mod3MapIndex: return "Mod3"; + case Mod4MapIndex: return "Mod4"; + case Mod5MapIndex: return "Mod5"; + default: return "???"; + } +} + +/* Boy, I really wish C had local functions... */ +struct c_doesnt_have_closures /* #### not yet used */ +{ + int warned_about_overlapping_modifiers; + int warned_about_predefined_modifiers; + int warned_about_duplicate_modifiers; + int meta_bit; + int hyper_bit; + int super_bit; + int alt_bit; + int mode_bit; +}; + +static void +gtk_reset_modifier_mapping (struct device *d) +{ + Display *display = GDK_DISPLAY (); + struct gtk_device *xd = DEVICE_GTK_DATA (d); + int modifier_index, modifier_key, column, mkpm; + int warned_about_overlapping_modifiers = 0; + /* int warned_about_predefined_modifiers = 0; */ + /* int warned_about_duplicate_modifiers = 0; */ + int meta_bit = 0; + int hyper_bit = 0; + int super_bit = 0; + int alt_bit = 0; + int mode_bit = 0; + XModifierKeymap *map = (XModifierKeymap *) xd->x_modifier_keymap; + + xd->lock_interpretation = 0; + + if (map) + XFreeModifiermap (map); + + gtk_reset_key_mapping (d); + + xd->x_modifier_keymap = map = XGetModifierMapping (display); + + /* Boy, I really wish C had local functions... + */ + + /* The call to warn_when_safe must be on the same line as the string or + make-msgfile won't pick it up properly (the newline doesn't confuse + it, but the backslash does). */ + +#define store_modifier(name,old) \ + old = modifier_index; + + mkpm = map->max_keypermod; + for (modifier_index = 0; modifier_index < 8; modifier_index++) + for (modifier_key = 0; modifier_key < mkpm; modifier_key++) { + KeySym last_sym = 0; + for (column = 0; column < 4; column += 2) { + KeyCode code = map->modifiermap[modifier_index * mkpm + + modifier_key]; + KeySym sym = (code ? XKeycodeToKeysym (display, code, column) : 0); + if (sym == last_sym) continue; + last_sym = sym; + switch (sym) { + case XK_Mode_switch:store_modifier ("Mode_switch", mode_bit); break; + case XK_Meta_L: store_modifier ("Meta_L", meta_bit); break; + case XK_Meta_R: store_modifier ("Meta_R", meta_bit); break; + case XK_Super_L: store_modifier ("Super_L", super_bit); break; + case XK_Super_R: store_modifier ("Super_R", super_bit); break; + case XK_Hyper_L: store_modifier ("Hyper_L", hyper_bit); break; + case XK_Hyper_R: store_modifier ("Hyper_R", hyper_bit); break; + case XK_Alt_L: store_modifier ("Alt_L", alt_bit); break; + case XK_Alt_R: store_modifier ("Alt_R", alt_bit); break; +#if 0 + case XK_Control_L: check_modifier ("Control_L", ControlMask); break; + case XK_Control_R: check_modifier ("Control_R", ControlMask); break; + case XK_Shift_L: check_modifier ("Shift_L", ShiftMask); break; + case XK_Shift_R: check_modifier ("Shift_R", ShiftMask); break; +#endif + case XK_Shift_Lock: /* check_modifier ("Shift_Lock", LockMask); */ + xd->lock_interpretation = XK_Shift_Lock; break; + case XK_Caps_Lock: /* check_modifier ("Caps_Lock", LockMask); */ + xd->lock_interpretation = XK_Caps_Lock; break; + + /* It probably doesn't make any sense for a modifier bit to be + assigned to a key that is not one of the above, but OpenWindows + assigns modifier bits to a couple of random function keys for + no reason that I can discern, so printing a warning here would + be annoying. */ + } + } + } +#undef store_modifier +#undef check_modifier +#undef modwarn +#undef modbarf + + /* If there was no Meta key, then try using the Alt key instead. + If there is both a Meta key and an Alt key, then the Alt key + is not disturbed and remains an Alt key. */ + if (! meta_bit && alt_bit) + meta_bit = alt_bit, alt_bit = 0; + + /* mode_bit overrides everything, since it's processed down inside of + XLookupString() instead of by us. If Meta and Mode_switch both + generate the same modifier bit (which is an error), then we don't + interpret that bit as Meta, because we can't make XLookupString() + not interpret it as Mode_switch; and interpreting it as both would + be totally wrong. */ + if (mode_bit) + { + const char *warn = 0; + if (mode_bit == meta_bit) warn = "Meta", meta_bit = 0; + else if (mode_bit == hyper_bit) warn = "Hyper", hyper_bit = 0; + else if (mode_bit == super_bit) warn = "Super", super_bit = 0; + else if (mode_bit == alt_bit) warn = "Alt", alt_bit = 0; + if (warn) + { + warn_when_safe + (Qkey_mapping, Qwarning, + "XEmacs: %s is being used for both Mode_switch and %s.", + index_to_name (mode_bit), warn), + warned_about_overlapping_modifiers = 1; + } + } +#undef index_to_name + + xd->MetaMask = (meta_bit ? (1 << meta_bit) : 0); + xd->HyperMask = (hyper_bit ? (1 << hyper_bit) : 0); + xd->SuperMask = (super_bit ? (1 << super_bit) : 0); + xd->AltMask = (alt_bit ? (1 << alt_bit) : 0); + xd->ModeMask = (mode_bit ? (1 << mode_bit) : 0); /* unused */ + +} + +void +gtk_init_modifier_mapping (struct device *d) +{ + struct gtk_device *gd = DEVICE_GTK_DATA (d); + gd->x_keysym_map_hashtable = Qnil; + gd->x_keysym_map = NULL; + gd->x_modifier_keymap = NULL; + gtk_reset_modifier_mapping (d); +} + +#if 0 +static int +gtk_key_is_modifier_p (KeyCode keycode, struct device *d) +{ + struct gtk_device *xd = DEVICE_GTK_DATA (d); + KeySym *syms; + KeySym *map = (KeySym *) xd->x_keysym_map; + int i; + + if (keycode < xd->x_keysym_map_min_code || + keycode > xd->x_keysym_map_max_code) + return 0; + + syms = &map [(keycode - xd->x_keysym_map_min_code) * + xd->x_keysym_map_keysyms_per_code]; + for (i = 0; i < xd->x_keysym_map_keysyms_per_code; i++) + if (IsModifierKey (syms [i]) || + syms [i] == XK_Mode_switch) /* why doesn't IsModifierKey count this? */ + return 1; + return 0; +} +#endif + +struct _quit_predicate_closure { + struct device *device; + Bool *critical; +}; + +static Bool +quit_char_predicate (Display *display, XEvent *event, XPointer data) +{ + struct _quit_predicate_closure *cl = (struct _quit_predicate_closure *) data; + struct device *d = cl->device; + struct frame *f = NULL; + struct gtk_device *gd = DEVICE_GTK_DATA (d); + char c, quit_char; + Bool *critical = cl->critical; + Lisp_Object keysym; + GdkWindow *window = gdk_window_lookup (event->xany.window); + guint32 keycode = 0; + GdkEventKey gdk_event; + + if (window) + f = gtk_any_window_to_frame (d, window); + + if (critical) + *critical = False; + + if ((event->type != KeyPress) || + (! window) || + (! f) || + (event->xkey.state + & (gd->MetaMask | gd->HyperMask | gd->SuperMask | gd->AltMask))) + { + return 0; + } + + { + char dummy[256]; + XLookupString (&(event->xkey), dummy, 200, (KeySym *)&keycode, 0); + } + + memset (&gdk_event, 0, sizeof (gdk_event)); + gdk_event.type = GDK_KEY_PRESS; + gdk_event.window = window; + gdk_event.keyval = keycode; + gdk_event.state = event->xkey.state; + + /* This duplicates some code that exists elsewhere, but it's relatively + fast and doesn't cons. */ + keysym = gtk_to_emacs_keysym (d, &gdk_event, 1); + if (NILP (keysym)) return 0; + if (CHAR_OR_CHAR_INTP (keysym)) + c = XCHAR_OR_CHAR_INT (keysym); + /* Highly doubtful that these are the quit character, but... */ + else if (EQ (keysym, QKbackspace)) c = '\b'; + else if (EQ (keysym, QKtab)) c = '\t'; + else if (EQ (keysym, QKlinefeed)) c = '\n'; + else if (EQ (keysym, QKreturn)) c = '\r'; + else if (EQ (keysym, QKescape)) c = 27; + else if (EQ (keysym, QKspace)) c = ' '; + else if (EQ (keysym, QKdelete)) c = 127; + else return 0; + + if (event->xkey.state & gd->MetaMask) c |= 0x80; + if ((event->xkey.state & ControlMask) && !(c >= 'A' && c <= 'Z')) + c &= 0x1F; /* unshifted control characters */ + quit_char = CONSOLE_QUIT_CHAR (XCONSOLE (DEVICE_CONSOLE (d))); + + if (c == quit_char) + return True; + /* If we've got Control-Shift-G instead of Control-G, that means + we have a critical_quit. Caps_Lock is its own modifier, so it + won't cause ^G to act differently than before. */ + if (event->xkey.state & ControlMask) c &= 0x1F; + if (c == quit_char) + { + if (critical) *critical = True; + return True; + } + return False; +} + +static void +gtk_check_for_quit_char (struct device *d) +{ + XEvent event; + int queued; + Bool critical_quit = False; + struct _quit_predicate_closure closure; + + XEventsQueued (GDK_DISPLAY (), QueuedAfterReading); + + closure.device = d; + closure.critical = &critical_quit; + + queued = XCheckIfEvent (GDK_DISPLAY (), &event, quit_char_predicate, (char *) &closure); + + if (queued) + { + Vquit_flag = (critical_quit ? Qcritical : Qt); + } +} diff --git a/src/frame-gtk.c b/src/frame-gtk.c new file mode 100644 index 0000000..963d259 --- /dev/null +++ b/src/frame-gtk.c @@ -0,0 +1,1498 @@ +/* Functions for the X window system. + Copyright (C) 1989, 1992-5, 1997 Free Software Foundation, Inc. + Copyright (C) 1995, 1996 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not synched with FSF. */ + +/* Substantially rewritten for XEmacs. */ +/* Revamped to use Gdk/Gtk by William Perry */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "ui-gtk.h" +#include "glyphs-gtk.h" +#include "objects-gtk.h" +#include "scrollbar-gtk.h" + +#include "gtk-xemacs.h" + +#include "buffer.h" +#include "events.h" +#include "extents.h" +#include "faces.h" +#include "frame.h" +#include "window.h" + +#ifdef HAVE_GNOME +#include +#endif + +#ifdef HAVE_DRAGNDROP +#include "dragdrop.h" +#endif + +#define BORDER_WIDTH 0 +#define INTERNAL_BORDER_WIDTH 0 + +#define TRANSIENT_DATA_IDENTIFIER "xemacs::transient_for" +#define FRAME_DATA_IDENTIFIER "xemacs::frame" +#define UNMAPPED_DATA_IDENTIFIER "xemacs::initially_unmapped" + +#define STUPID_X_SPECIFIC_GTK_STUFF + +#ifdef STUPID_X_SPECIFIC_GTK_STUFF +#include +#endif + +/* Default properties to use when creating frames. */ +Lisp_Object Vdefault_gtk_frame_plist; + +Lisp_Object Qwindow_id; +Lisp_Object Qdetachable_menubar; +Lisp_Object Qtext_widget; +Lisp_Object Qcontainer_widget; +Lisp_Object Qshell_widget; + +#ifdef STUPID_X_SPECIFIC_GTK_STUFF +EXFUN (Fgtk_window_id, 1); +#endif + +#ifdef HAVE_DRAGNDROP +enum { + TARGET_TYPE_STRING, + TARGET_TYPE_URI_LIST, +}; + +static GtkTargetEntry dnd_target_table[] = { + { "STRING", 0, TARGET_TYPE_STRING }, + { "text/plain", 0, TARGET_TYPE_STRING }, + { "text/uri-list", 0, TARGET_TYPE_URI_LIST }, + { "_NETSCAPE_URL", 0, TARGET_TYPE_STRING } +}; + +static guint dnd_n_targets = sizeof(dnd_target_table) / sizeof(dnd_target_table[0]); + +#endif + + +/************************************************************************/ +/* helper functions */ +/************************************************************************/ + +/* Return the Emacs frame-object corresponding to an X window */ +struct frame * +gtk_window_to_frame (struct device *d, GdkWindow *wdesc) +{ + Lisp_Object tail, frame; + struct frame *f; + + /* This function was previously written to accept only a window argument + (and to loop over all devices looking for a matching window), but + that is incorrect because window ID's are not unique across displays. */ + + for (tail = DEVICE_FRAME_LIST (d); CONSP (tail); tail = XCDR (tail)) + { + frame = XCAR (tail); + if (!FRAMEP (frame)) + continue; + f = XFRAME (frame); + if (FRAME_GTK_P (f) && GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)) == wdesc) + return f; + } + return 0; +} + +/* Like gtk_window_to_frame but also compares the window with the widget's + windows */ +struct frame * +gtk_any_window_to_frame (struct device *d, GdkWindow *w) +{ + do + { + Lisp_Object frmcons; + + DEVICE_FRAME_LOOP (frmcons, d) + { + struct frame *fr = XFRAME (XCAR (frmcons)); + if ((w == GET_GTK_WIDGET_WINDOW (FRAME_GTK_SHELL_WIDGET (fr))) || + (w == GET_GTK_WIDGET_WINDOW (FRAME_GTK_CONTAINER_WIDGET (fr))) || +#ifdef HAVE_MENUBARS + (w == GET_GTK_WIDGET_WINDOW (FRAME_GTK_MENUBAR_WIDGET (fr))) || +#endif + (w == GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (fr)))) + { + return (fr); + } + } + w = gdk_window_get_parent (w); + } while (w); + + return (0); +} + +struct frame * +gtk_any_widget_or_parent_to_frame (struct device *d, GtkWidget *widget) +{ + return (gtk_any_window_to_frame (d, GET_GTK_WIDGET_WINDOW (widget))); +} + +struct device * +gtk_any_window_to_device (GdkWindow *w) +{ + struct device *d = NULL; + Lisp_Object devcons, concons; + + DEVICE_LOOP_NO_BREAK (devcons, concons) + { + d = XDEVICE (XCAR (devcons)); + if (!DEVICE_GTK_P (d)) continue; + if (gtk_any_window_to_frame (d, w)) + return (d); + } + return (NULL); +} + +struct frame * +decode_gtk_frame (Lisp_Object frame) +{ + if (NILP (frame)) + XSETFRAME (frame, selected_frame ()); + CHECK_LIVE_FRAME (frame); + /* this will also catch dead frames, but putting in the above check + results in a more useful error */ + CHECK_GTK_FRAME (frame); + return XFRAME (frame); +} + + +/************************************************************************/ +/* window-manager interactions */ +/************************************************************************/ +static int +gtk_frame_iconified_p (struct frame *f) +{ + return (f->iconified); +} + + +/************************************************************************/ +/* frame properties */ +/************************************************************************/ + +static Lisp_Object +gtk_frame_property (struct frame *f, Lisp_Object property) +{ + GtkWidget *shell = FRAME_GTK_SHELL_WIDGET (f); + + if (EQ (Qleft, property) || EQ (Qtop, property)) + { + gint x, y; + if (!GET_GTK_WIDGET_WINDOW(shell)) + return Qzero; + gdk_window_get_deskrelative_origin (GET_GTK_WIDGET_WINDOW (shell), &x, &y); + if (EQ (Qleft, property)) return make_int (x); + if (EQ (Qtop, property)) return make_int (y); + } + if (EQ (Qshell_widget, property)) + { + return (FRAME_GTK_LISP_WIDGETS (f)[0]); + } + if (EQ (Qcontainer_widget, property)) + { + return (FRAME_GTK_LISP_WIDGETS (f)[1]); + } + if (EQ (Qtext_widget, property)) + { + return (FRAME_GTK_LISP_WIDGETS (f)[2]); + } +#ifdef STUPID_X_SPECIFIC_GTK_STUFF + if (EQ (Qwindow_id, property)) + return Fgtk_window_id (make_frame (f)); +#endif + + return Qunbound; +} + +static int +gtk_internal_frame_property_p (struct frame *f, Lisp_Object property) +{ + return EQ (property, Qleft) + || EQ (property, Qtop) + || EQ (Qshell_widget, property) + || EQ (Qcontainer_widget, property) + || EQ (Qtext_widget, property) + || EQ (property, Qwindow_id) + || STRINGP (property); +} + +static Lisp_Object +gtk_frame_properties (struct frame *f) +{ + Lisp_Object props = Qnil; + GtkWidget *shell = FRAME_GTK_SHELL_WIDGET (f); + gint x, y; + + props = cons3 (Qshell_widget, FRAME_GTK_LISP_WIDGETS (f)[0], props); + props = cons3 (Qcontainer_widget, FRAME_GTK_LISP_WIDGETS (f)[1], props); + props = cons3 (Qtext_widget, FRAME_GTK_LISP_WIDGETS (f)[2], props); + +#ifdef STUPID_X_SPECIFIC_GTK_STUFF + props = cons3 (Qwindow_id, Fgtk_window_id (make_frame (f)), props); +#endif + + if (!GET_GTK_WIDGET_WINDOW (shell)) + x = y = 0; + else + gdk_window_get_deskrelative_origin (GET_GTK_WIDGET_WINDOW (shell), &x, &y); + + props = cons3 (Qtop, make_int (y), props); + props = cons3 (Qleft, make_int (x), props); + + return props; +} + + +/* Functions called only from `gtk_set_frame_properties' to set + individual properties. */ + +static void +gtk_set_frame_text_value (struct frame *f, Bufbyte *value, + void (*func) (gpointer, gchar *), + gpointer arg) +{ + gchar *the_text = (gchar *) value; + + /* Programmer fuckup or window is not realized yet. */ + if (!func || !arg) return; + +#ifdef MULE + { + Bufbyte *ptr; + + /* Optimize for common ASCII case */ + for (ptr = value; *ptr; ptr++) + if (!BYTE_ASCII_P (*ptr)) + { + char *tmp; + C_STRING_TO_EXTERNAL (value, tmp, Qctext); + the_text = tmp; + break; + } + } +#endif /* MULE */ + + (*func) (arg, (gchar *) the_text); +} + +static void +gtk_set_title_from_bufbyte (struct frame *f, Bufbyte *name) +{ + if (GTK_IS_WINDOW (FRAME_GTK_SHELL_WIDGET (f))) + gtk_set_frame_text_value (f, name, + (void (*)(gpointer, gchar *)) + gtk_window_set_title, FRAME_GTK_SHELL_WIDGET (f)); +} + +static void +gtk_set_icon_name_from_bufbyte (struct frame *f, Bufbyte *name) +{ + gtk_set_frame_text_value (f, name, + (void (*)(gpointer, gchar *)) + gdk_window_set_icon_name, FRAME_GTK_SHELL_WIDGET (f)->window); +} + +/* Set the initial frame size as specified. This function is used + when the frame's widgets have not yet been realized. +*/ +static void +gtk_set_initial_frame_size (struct frame *f, int x, int y, + unsigned int w, unsigned int h) +{ + GtkWidget *shell = FRAME_GTK_SHELL_WIDGET (f); + GdkGeometry geometry; + GdkWindowHints geometry_mask = 0x00; + + if (GTK_IS_WINDOW (shell)) + { + /* Deal with the cell size */ + default_face_height_and_width (make_frame (f), &geometry.height_inc, &geometry.width_inc); + geometry_mask |= GDK_HINT_RESIZE_INC; + + gtk_window_set_geometry_hints (GTK_WINDOW (shell), + FRAME_GTK_TEXT_WIDGET (f), &geometry, geometry_mask); + gdk_window_set_hints (GET_GTK_WIDGET_WINDOW (shell), x, y, 0, 0, 0, 0, GDK_HINT_POS); + gtk_window_set_policy (GTK_WINDOW (shell), TRUE, TRUE, FALSE); + } + + FRAME_HEIGHT (f) = h; + FRAME_WIDTH (f) = w; + + change_frame_size (f, h, w, 0); + { + GtkRequisition req; + + gtk_widget_size_request (FRAME_GTK_SHELL_WIDGET (f), &req); + gtk_widget_set_usize (FRAME_GTK_SHELL_WIDGET (f), req.width, req.height); + } +} + +/* Report that a frame property of frame S is being set or changed. + If the property is not specially recognized, do nothing. + */ + +static void +gtk_set_frame_properties (struct frame *f, Lisp_Object plist) +{ + gint x, y; + gint width = 0, height = 0; + gboolean width_specified_p = FALSE; + gboolean height_specified_p = FALSE; + gboolean x_position_specified_p = FALSE; + gboolean y_position_specified_p = FALSE; + Lisp_Object tail; + + for (tail = plist; !NILP (tail); tail = Fcdr (Fcdr (tail))) + { + Lisp_Object prop = Fcar (tail); + Lisp_Object val = Fcar (Fcdr (tail)); + + if (SYMBOLP (prop)) + { + if (EQ (prop, Qfont)) + { + /* If the value is not a string we silently ignore it. */ + if (STRINGP (val)) + { + Lisp_Object frm, font_spec; + + XSETFRAME (frm, f); + font_spec = Fget (Fget_face (Qdefault), Qfont, Qnil); + + Fadd_spec_to_specifier (font_spec, val, frm, Qnil, Qnil); + update_frame_face_values (f); + } + continue; + } + else if (EQ (prop, Qwidth)) + { + CHECK_INT (val); + width = XINT (val); + width_specified_p = TRUE; + continue; + } + else if (EQ (prop, Qheight)) + { + CHECK_INT (val); + height = XINT (val); + height_specified_p = TRUE; + continue; + } + /* Further kludge the x/y. */ + else if (EQ (prop, Qx)) + { + CHECK_INT (val); + x = (gint) XINT (val); + x_position_specified_p = TRUE; + continue; + } + else if (EQ (prop, Qy)) + { + CHECK_INT (val); + y = (gint) XINT (val); + y_position_specified_p = TRUE; + continue; + } + } + } + + /* Kludge kludge kludge. We need to deal with the size and position + specially. */ + { + int size_specified_p = width_specified_p || height_specified_p; + int position_specified_p = x_position_specified_p || y_position_specified_p; + + if (!width_specified_p) + width = 80; + if (!height_specified_p) + height = 30; + + /* Kludge kludge kludge kludge. */ + if (position_specified_p && + (!x_position_specified_p || !y_position_specified_p)) + { + gint dummy; + GtkWidget *shell = FRAME_GTK_SHELL_WIDGET (f); + gdk_window_get_deskrelative_origin (GET_GTK_WIDGET_WINDOW (shell), + (x_position_specified_p ? &dummy : &x), + (y_position_specified_p ? &dummy : &y)); + } + + if (!f->init_finished) + { + if (size_specified_p || position_specified_p) + gtk_set_initial_frame_size (f, x, y, width, height); + } + else + { + if (size_specified_p) + { + Lisp_Object frame; + XSETFRAME (frame, f); + Fset_frame_size (frame, make_int (width), make_int (height), Qnil); + } + if (position_specified_p) + { + Lisp_Object frame; + XSETFRAME (frame, f); + Fset_frame_position (frame, make_int (x), make_int (y)); + } + } + } +} + + +/************************************************************************/ +/* widget creation */ +/************************************************************************/ +/* Figure out what size the shell widget should initially be, + and set it. Should be called after the default font has been + determined but before the widget has been realized. */ + +extern Lisp_Object Vgtk_initial_geometry; + +#ifndef HAVE_GNOME +static int +get_number (const char **geometry) +{ + int value = 0; + int mult = 1; + + if (**geometry == '-'){ + mult = -1; + (*geometry)++; + } + while (**geometry && isdigit (**geometry)){ + value = value * 10 + (**geometry - '0'); + (*geometry)++; + } + return value * mult; +} + +/* + */ + +/** + * gnome_parse_geometry + * @geometry: geometry string to be parsed + * @xpos: X position geometry component + * @ypos: Y position geometry component + * @width: pixel width geometry component + * @height: pixel height geometry component + * + * Description: + * Parses the geometry string passed in @geometry, and fills + * @xpos, @ypos, @width, and @height with + * the corresponding values upon completion of the parse. + * If the parse fails, it should be assumed that @xpos, @ypos, @width, + * and @height contain undefined values. + * + * Returns: + * %TRUE if the geometry was successfully parsed, %FALSE otherwise. + **/ + +static gboolean +gnome_parse_geometry (const gchar *geometry, gint *xpos, + gint *ypos, gint *width, gint *height) +{ + int subtract; + + g_return_val_if_fail (xpos != NULL, FALSE); + g_return_val_if_fail (ypos != NULL, FALSE); + g_return_val_if_fail (width != NULL, FALSE); + g_return_val_if_fail (height != NULL, FALSE); + + *xpos = *ypos = *width = *height = -1; + + if (!geometry) + return FALSE; + + if (*geometry == '=') + geometry++; + if (!*geometry) + return FALSE; + if (isdigit (*geometry)) + *width = get_number (&geometry); + if (!*geometry) + return TRUE; + if (*geometry == 'x' || *geometry == 'X'){ + geometry++; + *height = get_number (&geometry); + } + if (!*geometry) + return 1; + if (*geometry == '+'){ + subtract = 0; + geometry++; + } else if (*geometry == '-'){ + subtract = gdk_screen_width (); + geometry++; + } else + return FALSE; + *xpos = get_number (&geometry); + if (subtract) + *xpos = subtract - *xpos; + if (!*geometry) + return TRUE; + if (*geometry == '+'){ + subtract = 0; + geometry++; + } else if (*geometry == '-'){ + subtract = gdk_screen_height (); + geometry++; + } else + return FALSE; + *ypos = get_number (&geometry); + if (subtract) + *ypos = subtract - *ypos; + return TRUE; +} +#endif + +static void +gtk_initialize_frame_size (struct frame *f) +{ + gint x = 10, y = 10, w = 80, h = 30; + + if (STRINGP (Vgtk_initial_geometry)) + { + if (!gnome_parse_geometry (XSTRING_DATA (Vgtk_initial_geometry), &x,&y,&w,&h)) + { + x = y = 10; + w = 80; + h = 30; + } + } + + /* set the position of the frame's root window now. When the + frame was created, the position was initialized to (0,0). */ + { + struct window *win = XWINDOW (f->root_window); + + WINDOW_LEFT (win) = FRAME_LEFT_BORDER_END (f); + WINDOW_TOP (win) = FRAME_TOP_BORDER_END (f); + + if (!NILP (f->minibuffer_window)) + { + win = XWINDOW (f->minibuffer_window); + WINDOW_LEFT (win) = FRAME_LEFT_BORDER_END (f); + } + } + + gtk_set_initial_frame_size (f, x, y, w, h); +} + +static gboolean +resize_event_cb (GtkWidget *w, GtkAllocation *allocation, gpointer user_data) +{ + struct frame *f = (struct frame *) user_data; + + f->pixwidth = allocation->width; + f->pixheight = allocation->height; + + if (FRAME_GTK_TEXT_WIDGET (f)->window) + { + Lisp_Object frame; + XSETFRAME (frame, f); + Fredraw_frame (frame, Qt); + } + + return (FALSE); +} + +static gboolean +delete_event_cb (GtkWidget *w, GdkEvent *ev, gpointer user_data) +{ + struct frame *f = (struct frame *) user_data; + Lisp_Object frame; + + XSETFRAME (frame, f); + enqueue_misc_user_event (frame, Qeval, list3 (Qdelete_frame, frame, Qt)); + + /* See if tickling the event queue helps us with our delays when + clicking 'close' */ + signal_fake_event (); + + return (TRUE); +} + +extern gboolean emacs_shell_event_handler (GtkWidget *wid, GdkEvent *event, gpointer closure); +extern Lisp_Object build_gtk_object (GtkObject *obj); + +#ifndef GNOME_IS_APP +#define GNOME_IS_APP(x) 0 +#define gnome_app_set_contents(x,y) 0 +#endif + +static void +cleanup_deleted_frame (gpointer data) +{ + struct frame *f = (struct frame *) data; + Lisp_Object frame; + + XSETFRAME (frame, f); + Fdelete_frame (frame, Qt); +} + +#ifdef HAVE_DRAGNDROP +extern void +dragndrop_data_received (GtkWidget *widget, + GdkDragContext *context, + gint x, + gint y, + GtkSelectionData *data, + guint info, + guint time); + +extern gboolean +dragndrop_dropped (GtkWidget *widget, + GdkDragContext *drag_context, + gint x, + gint y, + guint time, + gpointer user_data); + +Lisp_Object Vcurrent_drag_object; + +#define DRAG_SELECTION_DATA_ERROR "Error converting drag data to external format" +static void +dragndrop_get_drag (GtkWidget *widget, + GdkDragContext *drag_context, + GtkSelectionData *data, + guint info, + guint time, + gpointer user_data) +{ + gtk_selection_data_set (data, GDK_SELECTION_TYPE_STRING, 8, + DRAG_SELECTION_DATA_ERROR, + strlen (DRAG_SELECTION_DATA_ERROR)); + + switch (info) + { + case TARGET_TYPE_STRING: + { + Lisp_Object string = Vcurrent_drag_object; + + if (!STRINGP (Vcurrent_drag_object)) + { + string = Fprin1_to_string (string, Qnil); + /* Convert to a string */ + } + + gtk_selection_data_set (data, GDK_SELECTION_TYPE_STRING, + 8, XSTRING_DATA (string), XSTRING_LENGTH (string)); + } + break; + case TARGET_TYPE_URI_LIST: + break; + default: + break; + } + Vcurrent_drag_object = Qnil; +} + +DEFUN ("gtk-start-drag-internal", Fgtk_start_drag_internal, 2, 3, 0, /* +Start a GTK drag from a buffer. +First arg is the event that started the drag, +second arg should be some string, and the third +is the type of the data (this should be a MIME type as a string (ie: text/plain)). +The type defaults to text/plain. +*/ + (event, data, dtyp)) +{ + if (EVENTP(event)) + { + struct frame *f = decode_gtk_frame (Fselected_frame (Qnil)); + GtkWidget *wid = FRAME_GTK_TEXT_WIDGET (f); + struct Lisp_Event *lisp_event = XEVENT(event); + GdkAtom dnd_typ; + GtkTargetList *tl = gtk_target_list_new (dnd_target_table, dnd_n_targets); + + /* only drag if this is really a press */ + if (EVENT_TYPE(lisp_event) != button_press_event) + return Qnil; + + /* get the desired type */ + if (!NILP (dtyp) && STRINGP (dtyp)) + dnd_typ = gdk_atom_intern (XSTRING_DATA (dtyp), FALSE); + + gtk_drag_begin (wid, tl, GDK_ACTION_COPY, lisp_event->event.button.button, NULL); + + Vcurrent_drag_object = data; + + gtk_target_list_unref (tl); + } + return Qnil; +} +#endif + +/* Creates the widgets for a frame. + lisp_window_id is a Lisp description of an X window or Xt + widget to parse. + + This function does not map the windows. (That is + done by gtk_popup_frame().) +*/ +static void +gtk_create_widgets (struct frame *f, Lisp_Object lisp_window_id, Lisp_Object parent) +{ + const char *name; + GtkWidget *text, *container, *shell; + gboolean embedded_p = !NILP (lisp_window_id); +#ifdef HAVE_MENUBARS + int menubar_visible; +#endif + + if (STRINGP (f->name)) + TO_EXTERNAL_FORMAT (LISP_STRING, f->name, C_STRING_ALLOCA, name, Qctext); + else + name = "emacs"; + + FRAME_GTK_TOP_LEVEL_FRAME_P (f) = 1; + + if (embedded_p) + { + CHECK_GTK_OBJECT (lisp_window_id); + + if (!GTK_IS_CONTAINER (XGTK_OBJECT (lisp_window_id)->object)) + { + signal_simple_error ("Window ID must be a GtkContainer subclass", lisp_window_id); + } + + shell = gtk_vbox_new (FALSE, 0); + + gtk_object_weakref (GTK_OBJECT (shell), cleanup_deleted_frame, f); + gtk_container_add (GTK_CONTAINER (XGTK_OBJECT (lisp_window_id)->object), shell); + } + else + { +#ifdef HAVE_GNOME + shell = GTK_WIDGET (gnome_app_new ("XEmacs", "XEmacs/GNOME")); +#else + shell = GTK_WIDGET (gtk_window_new (GTK_WINDOW_TOPLEVEL)); +#endif + } + + if (!NILP (parent)) + { + /* If this is a transient window, keep the parent info around */ + GtkWidget *parentwid = FRAME_GTK_SHELL_WIDGET (XFRAME (parent)); + gtk_object_set_data (GTK_OBJECT (shell), TRANSIENT_DATA_IDENTIFIER, parentwid); + gtk_window_set_transient_for (GTK_WINDOW (shell), GTK_WINDOW (parentwid)); + } + + gtk_container_set_border_width (GTK_CONTAINER (shell), 0); + + gtk_object_set_data (GTK_OBJECT (shell), FRAME_DATA_IDENTIFIER, f); + + FRAME_GTK_SHELL_WIDGET (f) = shell; + + text = GTK_WIDGET (gtk_xemacs_new (f)); + + if (!GNOME_IS_APP (shell)) + container = GTK_WIDGET (gtk_vbox_new (FALSE, INTERNAL_BORDER_WIDTH)); + else + container = shell; + + FRAME_GTK_CONTAINER_WIDGET (f) = container; + FRAME_GTK_TEXT_WIDGET (f) = text; + +#ifdef HAVE_DRAGNDROP + gtk_drag_dest_set (text, GTK_DEST_DEFAULT_MOTION | GTK_DEST_DEFAULT_HIGHLIGHT, + dnd_target_table, dnd_n_targets, + GDK_ACTION_COPY | GDK_ACTION_LINK | GDK_ACTION_ASK); + gtk_signal_connect (GTK_OBJECT (text), "drag_drop", + GTK_SIGNAL_FUNC (dragndrop_dropped), text); + gtk_signal_connect (GTK_OBJECT (text), "drag_data_received", + GTK_SIGNAL_FUNC (dragndrop_data_received), text); + gtk_signal_connect (GTK_OBJECT (text), "drag_data_get", + GTK_SIGNAL_FUNC (dragndrop_get_drag), NULL); +#endif + +#ifdef HAVE_MENUBARS + /* Create the initial menubar widget. */ + menubar_visible = gtk_initialize_frame_menubar (f); + + if (menubar_visible) + { + gtk_widget_show_all (FRAME_GTK_MENUBAR_WIDGET (f)); + } +#endif /* HAVE_MENUBARS */ + + if (GNOME_IS_APP (shell)) + gnome_app_set_contents (GNOME_APP (shell), text); + else + /* Now comes the drawing area, which should fill the rest of the + ** frame completely. + */ + gtk_box_pack_end (GTK_BOX (container), text, TRUE, TRUE, 0); + + /* Connect main event handler */ + gtk_signal_connect (GTK_OBJECT (shell), "delete-event", GTK_SIGNAL_FUNC (delete_event_cb), f); + + { + static char *events_to_frob[] = { "focus-in-event", + "focus-out-event", + "enter-notify-event", + "leave-notify-event", + "map-event", + "unmap-event", + "property-notify-event", + "selection-clear-event", + "selection-request-event", + "selection-notify-event", + "client-event", + /* "configure-event", */ + "visibility-notify-event", + NULL }; + int i; + + for (i = 0; events_to_frob[i]; i++) + { + gtk_signal_connect (GTK_OBJECT (shell), events_to_frob[i], + GTK_SIGNAL_FUNC (emacs_shell_event_handler), f); + } + } + + gtk_signal_connect (GTK_OBJECT (shell), "size-allocate", GTK_SIGNAL_FUNC (resize_event_cb), f); + + /* This might be safe to call now... */ + /* gtk_signal_connect (GTK_OBJECT (shell), "event", GTK_SIGNAL_FUNC (emacs_shell_event_handler), f); */ + + /* Let's make sure we get all the events we can */ + gtk_widget_set_events (text, GDK_ALL_EVENTS_MASK); + + if (shell != container) + gtk_container_add (GTK_CONTAINER (shell), container); + + gtk_widget_set_name (shell, "XEmacs::shell"); + gtk_widget_set_name (container, "XEmacs::container"); + gtk_widget_set_name (text, "XEmacs::text"); + + FRAME_GTK_LISP_WIDGETS(f)[0] = build_gtk_object (GTK_OBJECT (shell)); + FRAME_GTK_LISP_WIDGETS(f)[1] = build_gtk_object (GTK_OBJECT (container)); + FRAME_GTK_LISP_WIDGETS(f)[2] = build_gtk_object (GTK_OBJECT (text)); + + gtk_widget_realize (shell); +} + +/* create the windows for the specified frame and display them. + Note that the widgets have already been created, and any + necessary geometry calculations have already been done. */ +static void +gtk_popup_frame (struct frame *f) +{ + /* */ + + if (gtk_object_get_data (GTK_OBJECT (FRAME_GTK_SHELL_WIDGET (f)), UNMAPPED_DATA_IDENTIFIER)) + { + FRAME_GTK_TOTALLY_VISIBLE_P (f) = 0; + f->visible = 0; + gtk_widget_realize (FRAME_GTK_SHELL_WIDGET (f)); + gtk_widget_realize (FRAME_GTK_TEXT_WIDGET (f)); + gtk_widget_hide_all (FRAME_GTK_SHELL_WIDGET (f)); + } + else + { + gtk_widget_show_all (FRAME_GTK_SHELL_WIDGET (f)); + } +} + +static void +allocate_gtk_frame_struct (struct frame *f) +{ + /* zero out all slots. */ + f->frame_data = xnew_and_zero (struct gtk_frame); + + /* yeah, except the lisp ones */ + FRAME_GTK_ICON_PIXMAP (f) = Qnil; + FRAME_GTK_ICON_PIXMAP_MASK (f) = Qnil; +} + + +/************************************************************************/ +/* Lisp functions */ +/************************************************************************/ + +static void +gtk_init_frame_1 (struct frame *f, Lisp_Object props) +{ + /* This function can GC */ + Lisp_Object initially_unmapped; + Lisp_Object device = FRAME_DEVICE (f); + Lisp_Object lisp_window_id = Fplist_get (props, Qwindow_id, Qnil); + Lisp_Object popup = Fplist_get (props, Qpopup, Qnil); + + if (!NILP (popup)) + { + if (EQ (popup, Qt)) + popup = Fselected_frame (device); + CHECK_LIVE_FRAME (popup); + if (!EQ (device, FRAME_DEVICE (XFRAME (popup)))) + signal_simple_error_2 ("Parent must be on same device as frame", + device, popup); + } + + initially_unmapped = Fplist_get (props, Qinitially_unmapped, Qnil); + + /* + * Previously we set this only if NILP (DEVICE_SELECTED_FRAME (d)) + * to make sure that messages were displayed as soon as possible + * if we're creating the first frame on a device. But it is + * better to just set this all the time, so that when a new frame + * is created that covers the selected frame, echo area status + * messages can still be seen. f->visible is reset later if the + * initially-unmapped property is found to be non-nil in the + * frame properties. + */ + f->visible = 1; + + allocate_gtk_frame_struct (f); + gtk_create_widgets (f, lisp_window_id, popup); + + if (!NILP (initially_unmapped)) + { + gtk_object_set_data (GTK_OBJECT (FRAME_GTK_SHELL_WIDGET (f)), + UNMAPPED_DATA_IDENTIFIER, (gpointer) 1); + } +} + +static void +gtk_init_frame_2 (struct frame *f, Lisp_Object props) +{ + /* Set up the values of the widget/frame. A case could be made for putting + this inside of the widget's initialize method. */ + + update_frame_face_values (f); + gtk_initialize_frame_size (f); + /* Kyle: + * update_frame_title() can't be done here, because some of the + * modeline specs depend on the frame's device having a selected + * frame, and that may not have been set up yet. The redisplay + * will update the frame title anyway, so nothing is lost. + * JV: + * It turns out it gives problems with FVWMs name based mapping. + * We'll just need to be carefull in the modeline specs. + */ + update_frame_title (f); +} + +static void +gtk_init_frame_3 (struct frame *f) +{ + /* Pop up the frame. */ + gtk_popup_frame (f); +} + +static void +gtk_mark_frame (struct frame *f) +{ + mark_object (FRAME_GTK_ICON_PIXMAP (f)); + mark_object (FRAME_GTK_ICON_PIXMAP_MASK (f)); + mark_object (FRAME_GTK_LISP_WIDGETS (f)[0]); + mark_object (FRAME_GTK_LISP_WIDGETS (f)[1]); + mark_object (FRAME_GTK_LISP_WIDGETS (f)[2]); +} + +static void +gtk_set_frame_icon (struct frame *f) +{ + GdkPixmap *gtk_pixmap = NULL, *gtk_mask = NULL; + + if (IMAGE_INSTANCEP (f->icon) + && IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (f->icon))) + { + gtk_pixmap = XIMAGE_INSTANCE_GTK_PIXMAP (f->icon); + gtk_mask = XIMAGE_INSTANCE_GTK_MASK (f->icon); + } + else + { + gtk_pixmap = 0; + gtk_mask = 0; + } + + gdk_window_set_icon (GET_GTK_WIDGET_WINDOW (FRAME_GTK_SHELL_WIDGET (f)), NULL, gtk_pixmap, gtk_mask); +} + +static void +gtk_set_frame_pointer (struct frame *f) +{ + GtkWidget *w = FRAME_GTK_TEXT_WIDGET (f); + GdkCursor *c = XIMAGE_INSTANCE_GTK_CURSOR (f->pointer); + + if (POINTER_IMAGE_INSTANCEP (f->pointer)) + { + gdk_window_set_cursor (GET_GTK_WIDGET_WINDOW (w), c); + gdk_flush (); + } + else + { + /* abort()? */ + stderr_out ("POINTER_IMAGE_INSTANCEP (f->pointer) failed!\n"); + } +} + +static Lisp_Object +gtk_get_frame_parent (struct frame *f) +{ + GtkWidget *parentwid = gtk_object_get_data (GTK_OBJECT (FRAME_GTK_SHELL_WIDGET (f)), + TRANSIENT_DATA_IDENTIFIER); + + /* find the frame whose wid is parentwid */ + if (parentwid) + { + Lisp_Object frmcons; + DEVICE_FRAME_LOOP (frmcons, XDEVICE (FRAME_DEVICE (f))) + { + Lisp_Object frame = XCAR (frmcons); + if (FRAME_GTK_SHELL_WIDGET (XFRAME (frame)) == parentwid) + return frame; + } + } + return Qnil; +} + +#ifdef STUPID_X_SPECIFIC_GTK_STUFF +DEFUN ("gtk-window-id", Fgtk_window_id, 0, 1, 0, /* +Get the ID of the Gtk window. +This gives us a chance to manipulate the Emacs window from within a +different program. Since the ID is an unsigned long, we return it as +a string. +*/ + (frame)) +{ + char str[255]; + struct frame *f = decode_gtk_frame (frame); + + /* Arrrrggghhh... this defeats the whole purpose of using Gdk... do we really need this? */ + sprintf (str, "%lu", GDK_WINDOW_XWINDOW( GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)))); + return build_string (str); +} +#endif + + +/************************************************************************/ +/* manipulating the X window */ +/************************************************************************/ + +static void +gtk_set_frame_position (struct frame *f, int xoff, int yoff) +{ + gtk_widget_set_uposition (FRAME_GTK_SHELL_WIDGET (f), xoff, yoff); +} + +/* Call this to change the size of frame S's x-window. */ + +static void +gtk_set_frame_size (struct frame *f, int cols, int rows) +{ + GtkWidget *shell = FRAME_GTK_SHELL_WIDGET (f); + GdkGeometry geometry; + GdkWindowHints geometry_mask = 0x00; + + if (GTK_IS_WINDOW (shell)) + { + /* Update the cell size */ + default_face_height_and_width (make_frame (f), &geometry.height_inc, &geometry.width_inc); + geometry_mask |= GDK_HINT_RESIZE_INC; + + gtk_window_set_geometry_hints (GTK_WINDOW (shell), + FRAME_GTK_TEXT_WIDGET (f), &geometry, geometry_mask); + } + + change_frame_size (f, rows, cols, 0); + + { + GtkRequisition req; + + gtk_widget_size_request (FRAME_GTK_SHELL_WIDGET (f), &req); + gtk_widget_set_usize (FRAME_GTK_SHELL_WIDGET (f), req.width, req.height); + } +} + +#ifdef STUPID_X_SPECIFIC_GTK_STUFF +/* There is NO equivalent to XWarpPointer under Gtk */ +static void +gtk_set_mouse_position (struct window *w, int x, int y) +{ + struct frame *f = XFRAME (w->frame); + Display *display = GDK_DISPLAY (); + XWarpPointer (display, None, + GDK_WINDOW_XWINDOW (GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f))), + 0, 0, 0, 0, w->pixel_left + x, w->pixel_top + y); +} +#endif /* STUPID_X_SPECIFIC_GTK_STUFF */ + +static int +gtk_get_mouse_position (struct device *d, Lisp_Object *frame, int *x, int *y) +{ + /* Returns the pixel position within the editor text widget */ + gint win_x, win_y; + GdkWindow *w = gdk_window_at_pointer (&win_x, &win_y); + struct frame *f = NULL; + + if (!w) return (0); + + /* At this point, w is the innermost GdkWindow containing the + ** pointer and win_x and win_y are the coordinates of that window. + */ + f = gtk_any_window_to_frame (d, w); + + if (!f) return (0); + + XSETFRAME (*frame, f); + + gdk_window_get_pointer (GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)), + &win_x, &win_y, NULL); + + *x = win_x; + *y = win_y; + + return (1); +} + +static void +gtk_cant_notify_wm_error (void) +{ + error ("Can't notify window manager of iconification."); +} + +/* Raise frame F. */ +static void +gtk_raise_frame_1 (struct frame *f, int force) +{ + if (FRAME_VISIBLE_P (f) || force) + { + GdkWindow *emacs_window = GET_GTK_WIDGET_WINDOW (FRAME_GTK_SHELL_WIDGET (f)); + + gdk_window_raise (emacs_window); + } +} + +static void +gtk_raise_frame (struct frame *f) +{ + gtk_raise_frame_1 (f, 1); +} + +/* Lower frame F. */ +static void +gtk_lower_frame (struct frame *f) +{ + if (FRAME_VISIBLE_P (f)) + { + gdk_window_lower (GET_GTK_WIDGET_WINDOW (FRAME_GTK_SHELL_WIDGET (f))); + } +} + +/* Change from withdrawn state to mapped state. */ +static void +gtk_make_frame_visible (struct frame *f) +{ + gtk_widget_show_all (FRAME_GTK_SHELL_WIDGET (f)); + gtk_raise_frame_1 (f, 0); +} + +/* Change from mapped state to withdrawn state. */ +static void +gtk_make_frame_invisible (struct frame *f) +{ + gtk_widget_hide (FRAME_GTK_SHELL_WIDGET (f)); +} + +static int +gtk_frame_visible_p (struct frame *f) +{ + GtkWidget *w = FRAME_GTK_SHELL_WIDGET (f); + + f->visible = (GTK_OBJECT_FLAGS (w) & GTK_VISIBLE); + + return f->visible; +} + +static int +gtk_frame_totally_visible_p (struct frame *f) +{ + return FRAME_GTK_TOTALLY_VISIBLE_P (f); +} + +/* Change window state from mapped to iconified. */ +static void +gtk_iconify_frame (struct frame *f) +{ + GdkWindow *w = GET_GTK_WIDGET_WINDOW (FRAME_GTK_SHELL_WIDGET (f)); + + /* There is no equivalent to XIconifyWindow in Gtk/Gdk. */ + if (!XIconifyWindow (GDK_WINDOW_XDISPLAY (w), + GDK_WINDOW_XWINDOW (w), + DefaultScreen (GDK_WINDOW_XDISPLAY (w)))) + gtk_cant_notify_wm_error (); + + f->iconified = 1; +} + +/* Sets the X focus to frame f. */ +static void +gtk_focus_on_frame (struct frame *f) +{ + GtkWidget *shell_widget; + + assert (FRAME_GTK_P (f)); + + shell_widget = FRAME_GTK_SHELL_WIDGET (f); + if (!GET_GTK_WIDGET_WINDOW (shell_widget)) + return; + + gtk_widget_grab_focus (shell_widget); +} + +/* Destroy the window of frame S. */ +static void +gtk_delete_frame (struct frame *f) +{ + GtkWidget *w = FRAME_GTK_SHELL_WIDGET (f); + + gtk_widget_destroy (w); + + if (FRAME_GTK_GEOM_FREE_ME_PLEASE (f)) + xfree (FRAME_GTK_GEOM_FREE_ME_PLEASE (f)); + xfree (f->frame_data); + f->frame_data = 0; +} + +static void +gtk_recompute_cell_sizes (struct frame *frm) +{ + if (GTK_IS_WINDOW (FRAME_GTK_SHELL_WIDGET (frm))) + { + GtkWindow *w = GTK_WINDOW (FRAME_GTK_SHELL_WIDGET (frm)); + GdkGeometry geometry; + GdkWindowHints geometry_mask; + gint width_inc = 10; + gint height_inc = 10; + + default_face_height_and_width (make_frame (frm), &height_inc, &width_inc); + geometry_mask = GDK_HINT_RESIZE_INC; + geometry.width_inc = width_inc; + geometry.height_inc = height_inc; + + gtk_window_set_geometry_hints (w, FRAME_GTK_TEXT_WIDGET (frm), &geometry, geometry_mask); + } +} + +static void +gtk_update_frame_external_traits (struct frame* frm, Lisp_Object name) +{ + Lisp_Object frame = Qnil; + + XSETFRAME(frame, frm); + + if (EQ (name, Qforeground)) + { + Lisp_Object color = FACE_FOREGROUND (Vdefault_face, frame); + GdkColor *fgc; + + if (!EQ (color, Vthe_null_color_instance)) + { + fgc = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (color)); + /* #### BILL!!! The X code set the XtNforeground property of + the text widget here. Why did they bother? All that type + of thing is done down in the guts of the redisplay code, + not in the Emacs* widgets. */ + } + } + else if (EQ (name, Qbackground)) + { + Lisp_Object color = FACE_BACKGROUND (Vdefault_face, frame); + GdkColor *bgc; + + if (!EQ (color, Vthe_null_color_instance)) + { + bgc = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (color)); + if (FRAME_GTK_SHELL_WIDGET (frm)->window) + { + gdk_window_set_background (FRAME_GTK_SHELL_WIDGET (frm)->window, bgc); + } + if (FRAME_GTK_TEXT_WIDGET (frm)->window) + { + gdk_window_set_background (FRAME_GTK_TEXT_WIDGET (frm)->window, bgc); + } + } + + /* Really crappy way to force the modeline shadows to be + redrawn. But effective. */ + MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (frm); + MARK_FRAME_CHANGED (frm); + } + else if (EQ (name, Qfont)) + { + Lisp_Object font = FACE_FONT (Vdefault_face, frame, Vcharset_ascii); + + if (!EQ (font, Vthe_null_font_instance)) + { + /* #### BILL!!! The X code set the XtNfont property of the + text widget here. Why did they bother? All that type of + thing is done down in the guts of the redisplay code, not + in the Emacs* widgets. */ + } + } + else + abort (); + +#ifdef HAVE_TOOLBARS + /* Setting the background clears the entire frame area + including the toolbar so we force an immediate redraw of + it. */ + if (EQ (name, Qbackground)) + MAYBE_DEVMETH (XDEVICE (frm->device), redraw_frame_toolbars, (frm)); +#endif /* HAVE_TOOLBARS */ + + /* Set window manager resize increment hints according to + the new character size */ + if (EQ (name, Qfont) && FRAME_GTK_TOP_LEVEL_FRAME_P (frm)) + gtk_recompute_cell_sizes (frm); +} + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +syms_of_frame_gtk (void) +{ + defsymbol (&Qwindow_id, "window-id"); + defsymbol (&Qtext_widget, "text-widget"); + defsymbol (&Qcontainer_widget, "container-widget"); + defsymbol (&Qshell_widget, "shell-widget"); + defsymbol (&Qdetachable_menubar, "detachable-menubar"); + +#ifdef HAVE_DRAGNDROP + staticpro (&Vcurrent_drag_object); + Vcurrent_drag_object = Qnil; + DEFSUBR (Fgtk_start_drag_internal); +#endif +#ifdef STUPID_X_SPECIFIC_GTK_STUFF + DEFSUBR (Fgtk_window_id); +#endif +} + +void +console_type_create_frame_gtk (void) +{ + /* frame methods */ + CONSOLE_HAS_METHOD (gtk, init_frame_1); + CONSOLE_HAS_METHOD (gtk, init_frame_2); + CONSOLE_HAS_METHOD (gtk, init_frame_3); + CONSOLE_HAS_METHOD (gtk, mark_frame); + CONSOLE_HAS_METHOD (gtk, focus_on_frame); + CONSOLE_HAS_METHOD (gtk, delete_frame); + CONSOLE_HAS_METHOD (gtk, get_mouse_position); +#ifdef STUPID_X_SPECIFIC_GTK_STUFF + CONSOLE_HAS_METHOD (gtk, set_mouse_position); +#endif + CONSOLE_HAS_METHOD (gtk, raise_frame); + CONSOLE_HAS_METHOD (gtk, lower_frame); + CONSOLE_HAS_METHOD (gtk, make_frame_visible); + CONSOLE_HAS_METHOD (gtk, make_frame_invisible); + CONSOLE_HAS_METHOD (gtk, iconify_frame); + CONSOLE_HAS_METHOD (gtk, set_frame_size); + CONSOLE_HAS_METHOD (gtk, set_frame_position); + CONSOLE_HAS_METHOD (gtk, frame_property); + CONSOLE_HAS_METHOD (gtk, internal_frame_property_p); + CONSOLE_HAS_METHOD (gtk, frame_properties); + CONSOLE_HAS_METHOD (gtk, set_frame_properties); + CONSOLE_HAS_METHOD (gtk, set_title_from_bufbyte); + CONSOLE_HAS_METHOD (gtk, set_icon_name_from_bufbyte); + CONSOLE_HAS_METHOD (gtk, frame_visible_p); + CONSOLE_HAS_METHOD (gtk, frame_totally_visible_p); + CONSOLE_HAS_METHOD (gtk, frame_iconified_p); + CONSOLE_HAS_METHOD (gtk, set_frame_pointer); + CONSOLE_HAS_METHOD (gtk, set_frame_icon); + CONSOLE_HAS_METHOD (gtk, get_frame_parent); + CONSOLE_HAS_METHOD (gtk, update_frame_external_traits); +} + +void +vars_of_frame_gtk (void) +{ + DEFVAR_LISP ("default-gtk-frame-plist", &Vdefault_gtk_frame_plist /* +Plist of default frame-creation properties for Gtk frames. +These override what is specified in the resource database and in +`default-frame-plist', but are overridden by the arguments to the +particular call to `make-frame'. + +Note: In many cases, properties of a frame are available as specifiers +instead of through the frame-properties mechanism. + +Here is a list of recognized frame properties, other than those +documented in `set-frame-properties' (they can be queried and +set at any time, except as otherwise noted): + + initially-unmapped If non-nil, the frame will not be visible + when it is created. In this case, you + need to call `make-frame-visible' to make + the frame appear. + popup If non-nil, it should be a frame, and this + frame will be created as a "popup" frame + whose parent is the given frame. This + will make the window manager treat the + frame as a dialog box, which may entail + doing different things (e.g. not asking + for positioning, and not iconifying + separate from its parent). + inter-line-space Not currently implemented. + toolbar-shadow-thickness Thickness of toolbar shadows. + background-toolbar-color Color of toolbar background. + bottom-toolbar-shadow-color Color of bottom shadows on toolbars. + (*Not* specific to the bottom-toolbar.) + top-toolbar-shadow-color Color of top shadows on toolbars. + (*Not* specific to the top-toolbar.) + internal-border-width Width of internal border around text area. + border-width Width of external border around text area. + top Y position (in pixels) of the upper-left + outermost corner of the frame (i.e. the + upper-left of the window-manager + decorations). + left X position (in pixels) of the upper-left + outermost corner of the frame (i.e. the + upper-left of the window-manager + decorations). + border-color Color of external border around text area. + cursor-color Color of text cursor. + +See also `default-frame-plist', which specifies properties which apply +to all frames, not just Gtk frames. +*/ ); + Vdefault_gtk_frame_plist = Qnil; + + gtk_console_methods->device_specific_frame_props = &Vdefault_gtk_frame_plist; +} diff --git a/src/gccache-gtk.c b/src/gccache-gtk.c new file mode 100644 index 0000000..afc5830 --- /dev/null +++ b/src/gccache-gtk.c @@ -0,0 +1,276 @@ +/* Efficient caching of Gtk GCs (graphics contexts). + Copyright (C) 1993 Free Software Foundation, Inc. + Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* Emacs uses a lot of different display attributes; for example, assume + that only four fonts are in use (normal, bold, italic, and bold-italic). + Then assume that one stipple or background is used for text selections, + and another is used for highlighting mousable regions. That makes 16 + GCs already. Add in the fact that another GC may be needed to display + the text cursor in any of those regions, and you've got 32. Add in + more fonts, and it keeps increasing exponentially. + + We used to keep these GCs in a cache of merged (fully qualified) faces. + However, a lot of other code in xterm.c used XChangeGC of existing GCs, + which is kind of slow and kind of random. Also, managing the face cache + was tricky because it was hard to know when a face was no longer visible + on the frame -- we had to mark all frames as garbaged whenever a face + was changed, which caused an unpleasant amount of flicker (since faces are + created/destroyed (= changed) whenever a frame is created/destroyed. + + So this code maintains a cache at the GC level instead of at the face + level. There is an upper limit on the size of the cache, after which we + will stop creating GCs and start reusing them (reusing the least-recently- + used ones first). So if faces get changed, their GCs will eventually be + recycled. Also more sharing of GCs is possible. + + This code uses hashtables. It could be that, if the cache size is small + enough, a linear search might be faster; but I doubt it, since we need + `equal' comparisons, not `eq', and I expect that the optimal cache size + will be ~100. + + Written by jwz, 14 jun 93 + Hacked by William Perry, apr 2000 + */ + +#include +#include +#include "lisp.h" +#include "gccache-gtk.h" + +#define GC_CACHE_SIZE 100 + +#define GCCACHE_HASH + +#ifdef GCCACHE_HASH +#include "lisp.h" +#include "hash.h" +#endif + +struct gcv_and_mask { + GdkGCValues gcv; + GdkGCValuesMask mask; +}; + +struct gc_cache_cell { + GdkGC *gc; + struct gcv_and_mask gcvm; + struct gc_cache_cell *prev, *next; +}; + +struct gc_cache { + GdkWindow *window; /* used only as arg to XCreateGC */ + int size; + struct gc_cache_cell *head; + struct gc_cache_cell *tail; +#ifdef GCCACHE_HASH + struct hash_table * table; +#endif + + int create_count; + int delete_count; +}; + +#ifdef GCCACHE_HASH +static unsigned long +gc_cache_hash (const void *arg) +{ + const struct gcv_and_mask *gcvm = (const struct gcv_and_mask *) arg; + unsigned long *longs = (unsigned long *) &gcvm->gcv; + unsigned long hash = gcvm->mask; + int i; + /* This could look at the mask and only use the used slots in the + hash code. That would win in that we wouldn't have to initialize + every slot of the gcv when calling gc_cache_lookup. But we need + the hash function to be as fast as possible; some timings should + be done. */ + for (i = 0; i < (sizeof (GdkGCValues) / sizeof (unsigned long)); i++) + hash = (hash<<1) ^ *longs++; + return hash; +} + +#endif /* GCCACHE_HASH */ + +static int +gc_cache_eql (const void *arg1, const void *arg2) +{ + /* See comment in gc_cache_hash */ + const struct gcv_and_mask *gcvm1 = (const struct gcv_and_mask *) arg1; + const struct gcv_and_mask *gcvm2 = (const struct gcv_and_mask *) arg2; + + return !memcmp(&gcvm1->gcv, &gcvm2->gcv, sizeof(gcvm1->gcv)) + && gcvm1->mask == gcvm2->mask; +} + +struct gc_cache * +make_gc_cache (GtkWidget *widget) +{ + struct gc_cache *cache = xnew (struct gc_cache); + cache->window = widget->window; + cache->size = 0; + cache->head = cache->tail = 0; + cache->create_count = cache->delete_count = 0; +#ifdef GCCACHE_HASH + cache->table = + make_general_hash_table (GC_CACHE_SIZE, gc_cache_hash, gc_cache_eql); +#endif + return cache; +} + +void +free_gc_cache (struct gc_cache *cache) +{ + struct gc_cache_cell *rest, *next; + rest = cache->head; + while (rest) + { + gdk_gc_destroy(rest->gc); + next = rest->next; + xfree (rest); + rest = next; + } +#ifdef GCCACHE_HASH + free_hash_table (cache->table); +#endif + xfree (cache); +} + +GdkGC * +gc_cache_lookup (struct gc_cache *cache, GdkGCValues *gcv, GdkGCValuesMask mask) +{ + struct gc_cache_cell *cell, *next, *prev; + struct gcv_and_mask gcvm; + + if ((!!cache->head) != (!!cache->tail)) abort (); + if (cache->head && (cache->head->prev || cache->tail->next)) abort (); + + /* Gdk does not have the equivalent of 'None' for the clip_mask, so + we need to check it carefully, or gdk_gc_new_with_values will + coredump */ + if ((mask & GDK_GC_CLIP_MASK) && !gcv->clip_mask) + { + mask &= ~GDK_GC_CLIP_MASK; + } + + gcvm.mask = mask; + gcvm.gcv = *gcv; /* this copies... */ + +#ifdef GCCACHE_HASH + + if (gethash (&gcvm, cache->table, (const void **) &cell)) + +#else /* !GCCACHE_HASH */ + + cell = cache->tail; /* start at the end (most recently used) */ + while (cell) + { + if (gc_cache_eql (&gcvm, &cell->gcvm)) + break; + else + cell = cell->prev; + } + + /* #### This whole file needs some serious overhauling. */ + if (!(mask | GDK_GC_TILE) && cell->gcvm.gcv.tile) + cell = 0; + else if (!(mask | GDK_GC_STIPPLE) && cell->gcvm.gcv.stipple) + cell = 0; + + if (cell) + +#endif /* !GCCACHE_HASH */ + + { + /* Found a cell. Move this cell to the end of the list, so that it + will be less likely to be collected than a cell that was accessed + less recently. + */ + if (cell == cache->tail) + return cell->gc; + + next = cell->next; + prev = cell->prev; + if (prev) prev->next = next; + if (next) next->prev = prev; + if (cache->head == cell) cache->head = next; + cell->next = 0; + cell->prev = cache->tail; + cache->tail->next = cell; + cache->tail = cell; + if (cache->head == cell) abort (); + if (cell->next) abort (); + if (cache->head->prev) abort (); + if (cache->tail->next) abort (); + return cell->gc; + } + + /* else, cache miss. */ + + if (cache->size == GC_CACHE_SIZE) + /* Reuse the first cell on the list (least-recently-used). + Remove it from the list, and unhash it from the table. + */ + { + cell = cache->head; + cache->head = cell->next; + cache->head->prev = 0; + if (cache->tail == cell) cache->tail = 0; /* only one */ + gdk_gc_destroy (cell->gc); + cache->delete_count++; +#ifdef GCCACHE_HASH + remhash (&cell->gcvm, cache->table); +#endif + } + else if (cache->size > GC_CACHE_SIZE) + abort (); + else + { + /* Allocate a new cell (don't put it in the list or table yet). */ + cell = xnew (struct gc_cache_cell); + cache->size++; + } + + /* Now we've got a cell (new or reused). Fill it in. */ + memcpy (&cell->gcvm.gcv, gcv, sizeof (GdkGCValues)); + cell->gcvm.mask = mask; + + /* Put the cell on the end of the list. */ + cell->next = 0; + cell->prev = cache->tail; + if (cache->tail) cache->tail->next = cell; + cache->tail = cell; + if (! cache->head) cache->head = cell; + + cache->create_count++; +#ifdef GCCACHE_HASH + /* Hash it in the table */ + puthash (&cell->gcvm, cell, cache->table); +#endif + + /* Now make and return the GC. */ + cell->gc = gdk_gc_new_with_values (cache->window, gcv, mask); + + /* debug */ + assert (cell->gc == gc_cache_lookup (cache, gcv, mask)); + + return cell->gc; +} diff --git a/src/gccache-gtk.h b/src/gccache-gtk.h new file mode 100644 index 0000000..41c9bf6 --- /dev/null +++ b/src/gccache-gtk.h @@ -0,0 +1,35 @@ +/* Efficient caching of X GCs (graphics contexts). + Copyright (C) 1993 Free Software Foundation, Inc. + + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* Written by jwz, 14 jun 93 */ +/* Hacked by wmperry, apr 2000 */ + +#ifndef _GCCACHE_GTK_H_ +#define _GCCACHE_GTK_H_ + +struct gc_cache; +struct gc_cache *make_gc_cache (GtkWidget *); +void free_gc_cache (struct gc_cache *cache); +GdkGC *gc_cache_lookup (struct gc_cache *, GdkGCValues *, GdkGCValuesMask mask); + +#endif /* _XGCCACHE_H_ */ diff --git a/src/glade.c b/src/glade.c new file mode 100644 index 0000000..b314f20 --- /dev/null +++ b/src/glade.c @@ -0,0 +1,136 @@ +/* glade.c +** +** Description: Interface to `libglade' for XEmacs/GTK +** +** Created by: William M. Perry +** +** Copyright (C) 1999 John Harper +** Copyright (c) 2000 Free Software Foundation +** +*/ + +#if defined(HAVE_GLADE_H) || defined(HAVE_GLADE_GLADE_H) + +/* For COMPILED_FUNCTIONP */ +#include "bytecode.h" + +#ifdef HAVE_GLADE_GLADE_H +#include +#endif + +#ifdef HAVE_GLADE_H +#include +#endif + +/* This is based on the code from rep-gtk 0.11 in libglade-support.c */ + +static void +connector (const gchar *handler_name, GtkObject *object, + const gchar *signal_name, const gchar *signal_data, + GtkObject *connect_object, gboolean after, gpointer user_data) +{ + Lisp_Object func; + Lisp_Object lisp_data = Qnil; + + VOID_TO_LISP (func, user_data); + + if (NILP (func)) + { + /* Look for a lisp function called HANDLER_NAME */ + func = intern (handler_name); + } + + if (signal_data && signal_data[0]) + { + lisp_data = Feval (Fread (build_string (signal_data))); + } + + /* obj, name, func, cb_data, object_signal, after_p */ + Fgtk_signal_connect (build_gtk_object (object), + intern (signal_name), + func, + lisp_data, + connect_object ? Qt : Qnil, + after ? Qt : Qnil); +} + +/* This differs from lisp/subr.el (functionp) definition by allowing +** symbol names that may not necessarily be fboundp yet. +*/ +static int __almost_functionp (Lisp_Object obj) +{ + return (SYMBOLP (obj) || + SUBRP (obj) || + COMPILED_FUNCTIONP (obj) || + EQ (Fcar_safe (obj), Qlambda)); +} + +DEFUN ("glade-xml-signal-connect", Fglade_xml_signal_connect, 3, 3, 0, /* +Connect a glade handler. +*/ + (xml, handler_name, func)) +{ + CHECK_GTK_OBJECT (xml); + CHECK_STRING (handler_name); + + if (!__almost_functionp (func)) + { + func = wrong_type_argument (intern ("functionp"), func); + } + + glade_xml_signal_connect_full (GLADE_XML (XGTK_OBJECT (xml)->object), + XSTRING_DATA (handler_name), + connector, LISP_TO_VOID (func)); + return (Qt); +} + +DEFUN ("glade-xml-signal-autoconnect", Fglade_xml_signal_autoconnect, 1, 1, 0, /* +Connect all glade handlers. +*/ + (xml)) +{ + CHECK_GTK_OBJECT (xml); + + glade_xml_signal_autoconnect_full (GLADE_XML (XGTK_OBJECT (xml)->object), + connector, LISP_TO_VOID (Qnil)); + return (Qt); +} + +DEFUN ("glade-xml-textdomain", Fglade_xml_textdomain, 1, 1, 0, /* +Return the textdomain of a GladeXML object. +*/ + (xml)) +{ + gchar *the_domain = NULL; + + CHECK_GTK_OBJECT (xml); + + if (!GLADE_IS_XML (XGTK_OBJECT (xml)->object)) + { + signal_simple_error ("Object is not a GladeXML type.", xml); + } + +#ifdef LIBGLADE_XML_TXTDOMAIN + the_domain = GLADE_XML (XGTK_OBJECT (xml)->object)->txtdomain; +#else + the_domain = GLADE_XML (XGTK_OBJECT (xml)->object)->textdomain; +#endif + return (build_string (the_domain)); +} + +void syms_of_glade (void) +{ + DEFSUBR (Fglade_xml_signal_connect); + DEFSUBR (Fglade_xml_signal_autoconnect); + DEFSUBR (Fglade_xml_textdomain); +} + +void vars_of_glade (void) +{ + Fprovide (intern ("glade")); +} + +#else /* !(HAVE_GLADE_H || HAVE_GLADE_GLADE_H) */ +#define syms_of_glade() +#define vars_of_glade() +#endif diff --git a/src/glyphs-gtk.c b/src/glyphs-gtk.c new file mode 100644 index 0000000..ce6e345 --- /dev/null +++ b/src/glyphs-gtk.c @@ -0,0 +1,3033 @@ +/* X-specific Lisp objects. + Copyright (C) 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995 Tinker Systems + Copyright (C) 1995, 1996 Ben Wing + Copyright (C) 1995 Sun Microsystems + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* Original author: Jamie Zawinski for 19.8 + font-truename stuff added by Jamie Zawinski for 19.10 + subwindow support added by Chuck Thompson + additional XPM support added by Chuck Thompson + initial X-Face support added by Stig + rewritten/restructured by Ben Wing for 19.12/19.13 + GIF/JPEG support added by Ben Wing for 19.14 + PNG support added by Bill Perry for 19.14 + Improved GIF/JPEG support added by Bill Perry for 19.14 + Cleanup/simplification of error handling by Ben Wing for 19.14 + Pointer/icon overhaul, more restructuring by Ben Wing for 19.14 + GIF support changed to external GIFlib 3.1 by Jareth Hein for 21.0 + Many changes for color work and optimizations by Jareth Hein for 21.0 + Switch of GIF/JPEG/PNG to new EImage intermediate code by Jareth Hein for 21.0 + TIFF code by Jareth Hein for 21.0 + GIF/JPEG/PNG/TIFF code moved to new glyph-eimage.c for 21.0 + Gtk version by William Perry for 21.1 + + TODO: + Support the GrayScale, StaticColor and StaticGray visual classes. + Convert images.el to C and stick it in here? + */ + +#include +#include "lisp.h" +#include "lstream.h" +#include "console-gtk.h" +#include "glyphs.h" +#include "glyphs-gtk.h" +#include "objects-gtk.h" +#include "gui-gtk.h" +#include "ui-gtk.h" + +#include "buffer.h" +#include "window.h" +#include "frame.h" +#include "insdel.h" +#include "opaque.h" +#include "faces.h" + +#include "imgproc.h" + +#include "sysfile.h" + +#include + +#ifdef FILE_CODING +#include "file-coding.h" +#endif + +#if INTBITS == 32 +# define FOUR_BYTE_TYPE unsigned int +#elif LONGBITS == 32 +# define FOUR_BYTE_TYPE unsigned long +#elif SHORTBITS == 32 +# define FOUR_BYTE_TYPE unsigned short +#else +#error What kind of strange-ass system are we running on? +#endif + +DECLARE_IMAGE_INSTANTIATOR_FORMAT (nothing); +DECLARE_IMAGE_INSTANTIATOR_FORMAT (string); +DECLARE_IMAGE_INSTANTIATOR_FORMAT (formatted_string); +DECLARE_IMAGE_INSTANTIATOR_FORMAT (inherit); +#ifdef HAVE_JPEG +DECLARE_IMAGE_INSTANTIATOR_FORMAT (jpeg); +#endif +#ifdef HAVE_TIFF +DECLARE_IMAGE_INSTANTIATOR_FORMAT (tiff); +#endif +#ifdef HAVE_PNG +DECLARE_IMAGE_INSTANTIATOR_FORMAT (png); +#endif +#ifdef HAVE_GIF +DECLARE_IMAGE_INSTANTIATOR_FORMAT (gif); +#endif + +#ifdef HAVE_XFACE +DEFINE_DEVICE_IIFORMAT (gtk, xface); +Lisp_Object Qxface; +#endif + +#ifdef HAVE_XPM +DEFINE_DEVICE_IIFORMAT (gtk, xpm); +#endif + +DEFINE_DEVICE_IIFORMAT (gtk, xbm); +DEFINE_DEVICE_IIFORMAT (gtk, subwindow); + +DEFINE_IMAGE_INSTANTIATOR_FORMAT (cursor_font); +Lisp_Object Qcursor_font; + +DEFINE_IMAGE_INSTANTIATOR_FORMAT (font); + +DEFINE_IMAGE_INSTANTIATOR_FORMAT (autodetect); + +#ifdef HAVE_WIDGETS +DECLARE_IMAGE_INSTANTIATOR_FORMAT (layout); +DEFINE_DEVICE_IIFORMAT (gtk, widget); +DEFINE_DEVICE_IIFORMAT (gtk, native_layout); +DEFINE_DEVICE_IIFORMAT (gtk, button); +DEFINE_DEVICE_IIFORMAT (gtk, progress_gauge); +DEFINE_DEVICE_IIFORMAT (gtk, edit_field); +DEFINE_DEVICE_IIFORMAT (gtk, combo_box); +DEFINE_DEVICE_IIFORMAT (gtk, tab_control); +DEFINE_DEVICE_IIFORMAT (gtk, label); +#endif + +static void update_widget_face (GtkWidget *w, Lisp_Image_Instance *ii, + Lisp_Object domain); +static void cursor_font_instantiate (Lisp_Object image_instance, + Lisp_Object instantiator, + Lisp_Object pointer_fg, + Lisp_Object pointer_bg, + int dest_mask, + Lisp_Object domain); + +static gint cursor_name_to_index (const char *name); + +#ifndef BitmapSuccess +#define BitmapSuccess 0 +#define BitmapOpenFailed 1 +#define BitmapFileInvalid 2 +#define BitmapNoMemory 3 +#endif + +#include "bitmaps.h" + +DEFINE_IMAGE_INSTANTIATOR_FORMAT (gtk_resource); +Lisp_Object Q_resource_type, Q_resource_id; +Lisp_Object Qgtk_resource; +#ifdef HAVE_WIDGETS +Lisp_Object Qgtk_widget_instantiate_internal, Qgtk_widget_property_internal; +Lisp_Object Qgtk_widget_redisplay_internal, Qgtk_widget_set_style; +#endif + +#define CONST const + + +/************************************************************************/ +/* image instance methods */ +/************************************************************************/ + +/************************************************************************/ +/* convert from a series of RGB triples to an XImage formated for the */ +/* proper display */ +/************************************************************************/ +static GdkImage * +convert_EImage_to_GDKImage (Lisp_Object device, int width, int height, + unsigned char *pic, unsigned long **pixtbl, + int *npixels) +{ + GdkColormap *cmap; + GdkVisual *vis; + GdkImage *outimg; + int depth, byte_cnt, i, j; + int rd,gr,bl,q; + unsigned char *data, *ip, *dp = NULL; + quant_table *qtable = NULL; + union { + FOUR_BYTE_TYPE val; + char cp[4]; + } conv; + + cmap = DEVICE_GTK_COLORMAP (XDEVICE(device)); + vis = DEVICE_GTK_VISUAL (XDEVICE(device)); + depth = DEVICE_GTK_DEPTH(XDEVICE(device)); + + if (vis->type == GDK_VISUAL_GRAYSCALE || vis->type == GDK_VISUAL_STATIC_COLOR || + vis->type == GDK_VISUAL_STATIC_GRAY) + { + /* #### Implement me!!! */ + return NULL; + } + + if (vis->type == GDK_VISUAL_PSEUDO_COLOR) + { + /* Quantize the image and get a histogram while we're at it. + Do this first to save memory */ + qtable = build_EImage_quantable(pic, width, height, 256); + if (qtable == NULL) return NULL; + } + + /* The first parameter (GdkWindow *) is allowed to be NULL if we + ** specify the depth */ + outimg = gdk_image_new (GDK_IMAGE_FASTEST, vis, width, height); + + if (!outimg) return NULL; + + byte_cnt = outimg->bpp; + + data = (unsigned char *) outimg->mem; + + if (!data) + { + gdk_image_destroy (outimg); + return NULL; + } + + if (vis->type == GDK_VISUAL_PSEUDO_COLOR) + { + unsigned long pixarray[256]; + int pixcount, n; + /* use our quantize table to allocate the colors */ + pixcount = 32; + *pixtbl = xnew_array (unsigned long, pixcount); + *npixels = 0; + + /* ### should implement a sort by popularity to assure proper allocation */ + n = *npixels; + for (i = 0; i < qtable->num_active_colors; i++) + { + GdkColor color; + int res; + + color.red = qtable->rm[i] ? qtable->rm[i] << 8 : 0; + color.green = qtable->gm[i] ? qtable->gm[i] << 8 : 0; + color.blue = qtable->bm[i] ? qtable->bm[i] << 8 : 0; + res = allocate_nearest_color (cmap, vis, &color); + if (res > 0 && res < 3) + { + DO_REALLOC(*pixtbl, pixcount, n+1, unsigned long); + (*pixtbl)[n] = color.pixel; + n++; + } + pixarray[i] = color.pixel; + } + *npixels = n; + ip = pic; + for (i = 0; i < height; i++) + { + dp = data + (i * outimg->bpl); + for (j = 0; j < width; j++) + { + rd = *ip++; + gr = *ip++; + bl = *ip++; + conv.val = pixarray[QUANT_GET_COLOR(qtable,rd,gr,bl)]; +#if WORDS_BIGENDIAN + if (outimg->byte_order == GDK_MSB_FIRST) + for (q = 4-byte_cnt; q < 4; q++) *dp++ = conv.cp[q]; + else + for (q = 3; q >= 4-byte_cnt; q--) *dp++ = conv.cp[q]; +#else + if (outimg->byte_order == GDK_MSB_FIRST) + for (q = byte_cnt-1; q >= 0; q--) *dp++ = conv.cp[q]; + else + for (q = 0; q < byte_cnt; q++) *dp++ = conv.cp[q]; +#endif + } + } + xfree(qtable); + } else { + unsigned long rshift,gshift,bshift,rbits,gbits,bbits,junk; + junk = vis->red_mask; + rshift = 0; + while ((junk & 0x1) == 0) + { + junk = junk >> 1; + rshift ++; + } + rbits = 0; + while (junk != 0) + { + junk = junk >> 1; + rbits++; + } + junk = vis->green_mask; + gshift = 0; + while ((junk & 0x1) == 0) + { + junk = junk >> 1; + gshift ++; + } + gbits = 0; + while (junk != 0) + { + junk = junk >> 1; + gbits++; + } + junk = vis->blue_mask; + bshift = 0; + while ((junk & 0x1) == 0) + { + junk = junk >> 1; + bshift ++; + } + bbits = 0; + while (junk != 0) + { + junk = junk >> 1; + bbits++; + } + ip = pic; + for (i = 0; i < height; i++) + { + dp = data + (i * outimg->bpl); + for (j = 0; j < width; j++) + { + if (rbits > 8) + rd = *ip++ << (rbits - 8); + else + rd = *ip++ >> (8 - rbits); + if (gbits > 8) + gr = *ip++ << (gbits - 8); + else + gr = *ip++ >> (8 - gbits); + if (bbits > 8) + bl = *ip++ << (bbits - 8); + else + bl = *ip++ >> (8 - bbits); + + conv.val = (rd << rshift) | (gr << gshift) | (bl << bshift); +#if WORDS_BIGENDIAN + if (outimg->byte_order == GDK_MSB_FIRST) + for (q = 4-byte_cnt; q < 4; q++) *dp++ = conv.cp[q]; + else + for (q = 3; q >= 4-byte_cnt; q--) *dp++ = conv.cp[q]; +#else + if (outimg->byte_order == GDK_MSB_FIRST) + for (q = byte_cnt-1; q >= 0; q--) *dp++ = conv.cp[q]; + else + for (q = 0; q < byte_cnt; q++) *dp++ = conv.cp[q]; +#endif + } + } + } + return outimg; +} + +static void +gtk_print_image_instance (struct Lisp_Image_Instance *p, + Lisp_Object printcharfun, + int escapeflag) +{ + char buf[100]; + + switch (IMAGE_INSTANCE_TYPE (p)) + { + case IMAGE_MONO_PIXMAP: + case IMAGE_COLOR_PIXMAP: + case IMAGE_POINTER: + sprintf (buf, " (0x%lx", (unsigned long) IMAGE_INSTANCE_GTK_PIXMAP (p)); + write_c_string (buf, printcharfun); + if (IMAGE_INSTANCE_GTK_MASK (p)) + { + sprintf (buf, "/0x%lx", (unsigned long) IMAGE_INSTANCE_GTK_MASK (p)); + write_c_string (buf, printcharfun); + } + write_c_string (")", printcharfun); + break; +#if HAVE_SUBWINDOWS + case IMAGE_SUBWINDOW: + /* #### implement me */ +#endif + default: + break; + } +} + +static void +gtk_finalize_image_instance (struct Lisp_Image_Instance *p) +{ + if (!p->data) + return; + + if (DEVICE_LIVE_P (XDEVICE (p->device))) + { + if (0) + ; +#ifdef HAVE_WIDGETS + if (IMAGE_INSTANCE_TYPE (p) == IMAGE_WIDGET) + { + if (IMAGE_INSTANCE_SUBWINDOW_ID (p)) + { + gtk_widget_destroy (IMAGE_INSTANCE_SUBWINDOW_ID (p)); + + /* We can release the callbacks again. */ + /* #### FIXME! */ + /* ungcpro_popup_callbacks (...); */ + + /* IMAGE_INSTANCE_GTK_WIDGET_ID (p) = 0; */ + IMAGE_INSTANCE_GTK_CLIPWIDGET (p) = 0; + } + } +#endif + else if (IMAGE_INSTANCE_TYPE (p) == IMAGE_SUBWINDOW) + { + abort(); + } + else + { + int i; + if (IMAGE_INSTANCE_PIXMAP_TIMEOUT (p)) + disable_glyph_animated_timeout (IMAGE_INSTANCE_PIXMAP_TIMEOUT (p)); + + if (IMAGE_INSTANCE_GTK_MASK (p) && + IMAGE_INSTANCE_GTK_MASK (p) != IMAGE_INSTANCE_GTK_PIXMAP (p)) + gdk_pixmap_unref (IMAGE_INSTANCE_GTK_MASK (p)); + IMAGE_INSTANCE_PIXMAP_MASK (p) = 0; + + if (IMAGE_INSTANCE_GTK_PIXMAP_SLICES (p)) + { + for (i = 0; i < IMAGE_INSTANCE_PIXMAP_MAXSLICE (p); i++) + if (IMAGE_INSTANCE_GTK_PIXMAP_SLICE (p,i)) + { + gdk_pixmap_unref (IMAGE_INSTANCE_GTK_PIXMAP_SLICE (p,i)); + IMAGE_INSTANCE_GTK_PIXMAP_SLICE (p, i) = 0; + } + xfree (IMAGE_INSTANCE_GTK_PIXMAP_SLICES (p)); + IMAGE_INSTANCE_GTK_PIXMAP_SLICES (p) = 0; + } + + if (IMAGE_INSTANCE_GTK_CURSOR (p)) + { + gdk_cursor_destroy (IMAGE_INSTANCE_GTK_CURSOR (p)); + IMAGE_INSTANCE_GTK_CURSOR (p) = 0; + } + } + +#if 0 + /* #### BILL!!! */ + if (IMAGE_INSTANCE_GTK_NPIXELS (p) != 0) + { + XFreeColors (dpy, + IMAGE_INSTANCE_GTK_COLORMAP (p), + IMAGE_INSTANCE_GTK_PIXELS (p), + IMAGE_INSTANCE_GTK_NPIXELS (p), 0); + IMAGE_INSTANCE_GTK_NPIXELS (p) = 0; + } +#endif + } + + if (IMAGE_INSTANCE_TYPE (p) != IMAGE_WIDGET + && IMAGE_INSTANCE_TYPE (p) != IMAGE_SUBWINDOW + && IMAGE_INSTANCE_GTK_PIXELS (p)) + { + xfree (IMAGE_INSTANCE_GTK_PIXELS (p)); + IMAGE_INSTANCE_GTK_PIXELS (p) = 0; + } + + xfree (p->data); + p->data = 0; +} + +static int +gtk_image_instance_equal (struct Lisp_Image_Instance *p1, + struct Lisp_Image_Instance *p2, int depth) +{ + switch (IMAGE_INSTANCE_TYPE (p1)) + { + case IMAGE_MONO_PIXMAP: + case IMAGE_COLOR_PIXMAP: + case IMAGE_POINTER: + if (IMAGE_INSTANCE_GTK_COLORMAP (p1) != IMAGE_INSTANCE_GTK_COLORMAP (p2) || + IMAGE_INSTANCE_GTK_NPIXELS (p1) != IMAGE_INSTANCE_GTK_NPIXELS (p2)) + return 0; +#if HAVE_SUBWINDOWS + case IMAGE_SUBWINDOW: + /* #### implement me */ +#endif + break; + default: + break; + } + + return 1; +} + +static unsigned long +gtk_image_instance_hash (struct Lisp_Image_Instance *p, int depth) +{ + switch (IMAGE_INSTANCE_TYPE (p)) + { + case IMAGE_MONO_PIXMAP: + case IMAGE_COLOR_PIXMAP: + case IMAGE_POINTER: + return IMAGE_INSTANCE_GTK_NPIXELS (p); +#if HAVE_SUBWINDOWS + case IMAGE_SUBWINDOW: + /* #### implement me */ + return 0; +#endif + default: + return 0; + } +} + +/* Set all the slots in an image instance structure to reasonable + default values. This is used somewhere within an instantiate + method. It is assumed that the device slot within the image + instance is already set -- this is the case when instantiate + methods are called. */ + +static void +gtk_initialize_pixmap_image_instance (struct Lisp_Image_Instance *ii, + int slices, + enum image_instance_type type) +{ + ii->data = xnew_and_zero (struct gtk_image_instance_data); + IMAGE_INSTANCE_PIXMAP_MAXSLICE (ii) = slices; + IMAGE_INSTANCE_GTK_PIXMAP_SLICES (ii) = + xnew_array_and_zero (GdkPixmap *, slices); + IMAGE_INSTANCE_TYPE (ii) = type; + IMAGE_INSTANCE_PIXMAP_FILENAME (ii) = Qnil; + IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (ii) = Qnil; + IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii) = Qnil; + IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii) = Qnil; + IMAGE_INSTANCE_PIXMAP_FG (ii) = Qnil; + IMAGE_INSTANCE_PIXMAP_BG (ii) = Qnil; +} + + +/************************************************************************/ +/* pixmap file functions */ +/************************************************************************/ + +/* Where bitmaps are; initialized from resource database */ +Lisp_Object Vgtk_bitmap_file_path; + +#ifndef BITMAPDIR +#define BITMAPDIR "/usr/include/X11/bitmaps" +#endif + +/* Given a pixmap filename, look through all of the "standard" places + where the file might be located. Return a full pathname if found; + otherwise, return Qnil. */ + +static Lisp_Object +gtk_locate_pixmap_file (Lisp_Object name) +{ + /* This function can GC if IN_REDISPLAY is false */ + + /* Check non-absolute pathnames with a directory component relative to + the search path; that's the way Xt does it. */ + /* #### Unix-specific */ + if (XSTRING_BYTE (name, 0) == '/' || + (XSTRING_BYTE (name, 0) == '.' && + (XSTRING_BYTE (name, 1) == '/' || + (XSTRING_BYTE (name, 1) == '.' && + (XSTRING_BYTE (name, 2) == '/'))))) + { + if (!NILP (Ffile_readable_p (name))) + return name; + else + return Qnil; + } + + if (NILP (Vdefault_gtk_device)) + /* This may occur during intialization. */ + return Qnil; + + if (NILP (Vgtk_bitmap_file_path)) + { + Vgtk_bitmap_file_path = nconc2 (Vgtk_bitmap_file_path, + (decode_path (BITMAPDIR))); + } + + { + Lisp_Object found; + if (locate_file (Vgtk_bitmap_file_path, name, Qnil, &found, R_OK) < 0) + { + Lisp_Object temp = list1 (Vdata_directory); + struct gcpro gcpro1; + + GCPRO1 (temp); + locate_file (temp, name, Qnil, &found, R_OK); + UNGCPRO; + } + + return found; + } +} + +static Lisp_Object +locate_pixmap_file (Lisp_Object name) +{ + return gtk_locate_pixmap_file (name); +} + + +/************************************************************************/ +/* cursor functions */ +/************************************************************************/ + +/* Check that this server supports cursors of size WIDTH * HEIGHT. If + not, signal an error. INSTANTIATOR is only used in the error + message. */ + +static void +check_pointer_sizes (unsigned int width, unsigned int height, + Lisp_Object instantiator) +{ + /* #### BILL!!! There is no way to call XQueryBestCursor from Gdk! */ +#if 0 + unsigned int best_width, best_height; + if (! XQueryBestCursor (DisplayOfScreen (xs), RootWindowOfScreen (xs), + width, height, &best_width, &best_height)) + /* this means that an X error of some sort occurred (we trap + these so they're not fatal). */ + signal_simple_error ("XQueryBestCursor() failed?", instantiator); + + if (width > best_width || height > best_height) + error_with_frob (instantiator, + "pointer too large (%dx%d): " + "server requires %dx%d or smaller", + width, height, best_width, best_height); +#endif +} + +static void +generate_cursor_fg_bg (Lisp_Object device, Lisp_Object *foreground, + Lisp_Object *background, GdkColor *xfg, GdkColor *xbg) +{ + if (!NILP (*foreground) && !COLOR_INSTANCEP (*foreground)) + *foreground = + Fmake_color_instance (*foreground, device, + encode_error_behavior_flag (ERROR_ME)); + if (COLOR_INSTANCEP (*foreground)) + *xfg = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (*foreground)); + else + { + xfg->pixel = 0; + xfg->red = xfg->green = xfg->blue = 0; + } + + if (!NILP (*background) && !COLOR_INSTANCEP (*background)) + *background = + Fmake_color_instance (*background, device, + encode_error_behavior_flag (ERROR_ME)); + if (COLOR_INSTANCEP (*background)) + *xbg = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (*background)); + else + { + xbg->pixel = 0; + xbg->red = xbg->green = xbg->blue = ~0; + } +} + +static void +maybe_recolor_cursor (Lisp_Object image_instance, Lisp_Object foreground, + Lisp_Object background) +{ +#if 0 + /* #### BILL!!! */ + Lisp_Object device = XIMAGE_INSTANCE_DEVICE (image_instance); + GdkColor xfg, xbg; + + generate_cursor_fg_bg (device, &foreground, &background, &xfg, &xbg); + if (!NILP (foreground) || !NILP (background)) + { + XRecolorCursor (DEVICE_X_DISPLAY (XDEVICE (device)), + XIMAGE_INSTANCE_GTK_CURSOR (image_instance), + &xfg, &xbg); + XIMAGE_INSTANCE_PIXMAP_FG (image_instance) = foreground; + XIMAGE_INSTANCE_PIXMAP_BG (image_instance) = background; + } +#else + /* stderr_out ("Don't know how to recolor cursors in Gtk!\n"); */ +#endif +} + + +/************************************************************************/ +/* color pixmap functions */ +/************************************************************************/ + +/* Initialize an image instance from an XImage. + + DEST_MASK specifies the mask of allowed image types. + + PIXELS and NPIXELS specify an array of pixels that are used in + the image. These need to be kept around for the duration of the + image. When the image instance is freed, XFreeColors() will + automatically be called on all the pixels specified here; thus, + you should have allocated the pixels yourself using XAllocColor() + or the like. The array passed in is used directly without + being copied, so it should be heap data created with xmalloc(). + It will be freed using xfree() when the image instance is + destroyed. + + If this fails, signal an error. INSTANTIATOR is only used + in the error message. + + #### This should be able to handle conversion into `pointer'. + Use the same code as for `xpm'. */ + +static void +init_image_instance_from_gdk_image (struct Lisp_Image_Instance *ii, + GdkImage *gdk_image, + int dest_mask, + GdkColormap *cmap, + unsigned long *pixels, + int npixels, + int slices, + Lisp_Object instantiator) +{ + Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); + GdkGC *gc; + GdkWindow *d; + GdkPixmap *pixmap; + + if (!DEVICE_GTK_P (XDEVICE (device))) + signal_simple_error ("Not a Gtk device", device); + + d = GET_GTK_WIDGET_WINDOW (DEVICE_GTK_APP_SHELL (XDEVICE (device))); + + if (!(dest_mask & IMAGE_COLOR_PIXMAP_MASK)) + incompatible_image_types (instantiator, dest_mask, + IMAGE_COLOR_PIXMAP_MASK); + + pixmap = gdk_pixmap_new (d, gdk_image->width, gdk_image->height, gdk_image->depth); + if (!pixmap) + signal_simple_error ("Unable to create pixmap", instantiator); + + gc = gdk_gc_new (pixmap); + if (!gc) + { + gdk_pixmap_unref (pixmap); + signal_simple_error ("Unable to create GC", instantiator); + } + + gdk_draw_image (GDK_DRAWABLE (pixmap), gc, gdk_image, + 0, 0, 0, 0, gdk_image->width, gdk_image->height); + + gdk_gc_destroy (gc); + + gtk_initialize_pixmap_image_instance (ii, slices, IMAGE_COLOR_PIXMAP); + + IMAGE_INSTANCE_PIXMAP_FILENAME (ii) = + find_keyword_in_vector (instantiator, Q_file); + + IMAGE_INSTANCE_GTK_PIXMAP (ii) = pixmap; + IMAGE_INSTANCE_GTK_MASK (ii) = 0; + IMAGE_INSTANCE_PIXMAP_WIDTH (ii) = gdk_image->width; + IMAGE_INSTANCE_PIXMAP_HEIGHT (ii) = gdk_image->height; + IMAGE_INSTANCE_PIXMAP_DEPTH (ii) = gdk_image->depth; + IMAGE_INSTANCE_GTK_COLORMAP (ii) = cmap; + IMAGE_INSTANCE_GTK_PIXELS (ii) = pixels; + IMAGE_INSTANCE_GTK_NPIXELS (ii) = npixels; +} + +#if 0 +void init_image_instance_from_gdk_pixmap (struct Lisp_Image_Instance *ii, + struct device *device, + GdkPixmap *gdk_pixmap, + int dest_mask, + Lisp_Object instantiator) +{ + GdkWindow *d; + gint width, height, depth; + + if (!DEVICE_GTK_P (device)) + abort (); + + IMAGE_INSTANCE_DEVICE (ii) = device; + IMAGE_INSTANCE_TYPE (ii) = IMAGE_COLOR_PIXMAP; + + d = GET_GTK_WIDGET_WINDOW (DEVICE_GTK_APP_SHELL (device)); + + if (!(dest_mask & IMAGE_COLOR_PIXMAP_MASK)) + incompatible_image_types (instantiator, dest_mask, + IMAGE_COLOR_PIXMAP_MASK); + + gtk_initialize_pixmap_image_instance (ii, IMAGE_COLOR_PIXMAP); + + gdk_window_get_geometry (gdk_pixmap, NULL, NULL, &width, &height, &depth); + + IMAGE_INSTANCE_PIXMAP_FILENAME (ii) = Qnil; + IMAGE_INSTANCE_GTK_PIXMAP (ii) = gdk_pixmap; + IMAGE_INSTANCE_GTK_MASK (ii) = 0; + IMAGE_INSTANCE_PIXMAP_WIDTH (ii) = width; + IMAGE_INSTANCE_PIXMAP_HEIGHT (ii) = height; + IMAGE_INSTANCE_PIXMAP_DEPTH (ii) = depth; + IMAGE_INSTANCE_GTK_COLORMAP (ii) = gdk_window_get_colormap (gdk_pixmap); + IMAGE_INSTANCE_GTK_PIXELS (ii) = 0; + IMAGE_INSTANCE_GTK_NPIXELS (ii) = 0; +} +#endif + +static void +image_instance_add_gdk_image (Lisp_Image_Instance *ii, + GdkImage *gdk_image, + int slice, + Lisp_Object instantiator) +{ + Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); + GdkWindow *d; + GdkPixmap *pixmap; + GdkGC *gc; + + d = GET_GTK_WIDGET_WINDOW (DEVICE_GTK_APP_SHELL (XDEVICE (device))); + + pixmap = gdk_pixmap_new (d, gdk_image->width, gdk_image->height, gdk_image->depth); + + if (!pixmap) + signal_simple_error ("Unable to create pixmap", instantiator); + + gc = gdk_gc_new (pixmap); + + if (!gc) + { + gdk_pixmap_unref (pixmap); + signal_simple_error ("Unable to create GC", instantiator); + } + + gdk_draw_image (GDK_DRAWABLE (pixmap), gc, gdk_image, 0, 0, 0, 0, + gdk_image->width, gdk_image->height); + + gdk_gc_destroy (gc); + + IMAGE_INSTANCE_GTK_PIXMAP_SLICE (ii, slice) = pixmap; +} + +static void +gtk_init_image_instance_from_eimage (struct Lisp_Image_Instance *ii, + int width, int height, + int slices, + unsigned char *eimage, + int dest_mask, + Lisp_Object instantiator, + Lisp_Object domain) +{ + Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); + GdkColormap *cmap = DEVICE_GTK_COLORMAP (XDEVICE(device)); + unsigned long *pixtbl = NULL; + int npixels = 0; + int slice; + GdkImage* gdk_image; + + + for (slice = 0; slice < slices; slice++) + { + gdk_image = convert_EImage_to_GDKImage (device, width, height, eimage, + &pixtbl, &npixels); + if (!gdk_image) + { + if (pixtbl) xfree (pixtbl); + signal_image_error("EImage to GdkImage conversion failed", instantiator); + } + + if (slice == 0) + /* Now create the pixmap and set up the image instance */ + init_image_instance_from_gdk_image (ii, gdk_image, dest_mask, + cmap, pixtbl, npixels, slices, + instantiator); + else + image_instance_add_gdk_image (ii, gdk_image, slice, instantiator); + + if (gdk_image) + { + gdk_image_destroy (gdk_image); + } + gdk_image = 0; + } +} + +/* Given inline data for a mono pixmap, create and return the + corresponding X object. */ + +static GdkPixmap * +pixmap_from_xbm_inline (Lisp_Object device, int width, int height, + /* Note that data is in ext-format! */ + CONST Extbyte *bits) +{ + return (gdk_bitmap_create_from_data (GET_GTK_WIDGET_WINDOW (DEVICE_GTK_APP_SHELL (XDEVICE (device))), + (char *) bits, width, height)); +} + +/* Given inline data for a mono pixmap, initialize the given + image instance accordingly. */ + +static void +init_image_instance_from_xbm_inline (struct Lisp_Image_Instance *ii, + int width, int height, + /* Note that data is in ext-format! */ + CONST char *bits, + Lisp_Object instantiator, + Lisp_Object pointer_fg, + Lisp_Object pointer_bg, + int dest_mask, + GdkPixmap *mask, + Lisp_Object mask_filename) +{ + Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); + Lisp_Object foreground = find_keyword_in_vector (instantiator, Q_foreground); + Lisp_Object background = find_keyword_in_vector (instantiator, Q_background); + GdkColor fg; + GdkColor bg; + enum image_instance_type type; + GdkWindow *draw = GET_GTK_WIDGET_WINDOW (DEVICE_GTK_APP_SHELL (XDEVICE (device))); + GdkColormap *cmap = DEVICE_GTK_COLORMAP (XDEVICE(device)); + GdkColor black; + GdkColor white; + + gdk_color_black(cmap, &black); + gdk_color_white(cmap, &white); + + if (!DEVICE_GTK_P (XDEVICE (device))) + signal_simple_error ("Not a Gtk device", device); + + if ((dest_mask & IMAGE_MONO_PIXMAP_MASK) && + (dest_mask & IMAGE_COLOR_PIXMAP_MASK)) + { + if (!NILP (foreground) || !NILP (background)) + type = IMAGE_COLOR_PIXMAP; + else + type = IMAGE_MONO_PIXMAP; + } + else if (dest_mask & IMAGE_MONO_PIXMAP_MASK) + type = IMAGE_MONO_PIXMAP; + else if (dest_mask & IMAGE_COLOR_PIXMAP_MASK) + type = IMAGE_COLOR_PIXMAP; + else if (dest_mask & IMAGE_POINTER_MASK) + type = IMAGE_POINTER; + else + incompatible_image_types (instantiator, dest_mask, + IMAGE_MONO_PIXMAP_MASK | IMAGE_COLOR_PIXMAP_MASK + | IMAGE_POINTER_MASK); + + gtk_initialize_pixmap_image_instance (ii, 1, type); + IMAGE_INSTANCE_PIXMAP_WIDTH (ii) = width; + IMAGE_INSTANCE_PIXMAP_HEIGHT (ii) = height; + IMAGE_INSTANCE_PIXMAP_FILENAME (ii) = + find_keyword_in_vector (instantiator, Q_file); + + switch (type) + { + case IMAGE_MONO_PIXMAP: + { + IMAGE_INSTANCE_GTK_PIXMAP (ii) = + pixmap_from_xbm_inline (device, width, height, (Extbyte *) bits); + } + break; + + case IMAGE_COLOR_PIXMAP: + { + gint d = DEVICE_GTK_DEPTH (XDEVICE(device)); + + if (!NILP (foreground) && !COLOR_INSTANCEP (foreground)) + foreground = + Fmake_color_instance (foreground, device, + encode_error_behavior_flag (ERROR_ME)); + + if (COLOR_INSTANCEP (foreground)) + fg = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (foreground)); + + if (!NILP (background) && !COLOR_INSTANCEP (background)) + background = + Fmake_color_instance (background, device, + encode_error_behavior_flag (ERROR_ME)); + + if (COLOR_INSTANCEP (background)) + bg = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (background)); + + /* We used to duplicate the pixels using XAllocColor(), to protect + against their getting freed. Just as easy to just store the + color instances here and GC-protect them, so this doesn't + happen. */ + IMAGE_INSTANCE_PIXMAP_FG (ii) = foreground; + IMAGE_INSTANCE_PIXMAP_BG (ii) = background; + IMAGE_INSTANCE_GTK_PIXMAP (ii) = + gdk_pixmap_create_from_data (draw, (char *) bits, width, height, d, &fg, &bg); + IMAGE_INSTANCE_PIXMAP_DEPTH (ii) = d; + } + break; + + case IMAGE_POINTER: + { + GdkColor fg_color, bg_color; + GdkPixmap *source; + + check_pointer_sizes (width, height, instantiator); + + source = gdk_pixmap_create_from_data (draw, (char *) bits, width, height, 1, &black, &white); + + if (NILP (foreground)) + foreground = pointer_fg; + if (NILP (background)) + background = pointer_bg; + generate_cursor_fg_bg (device, &foreground, &background, + &fg_color, &bg_color); + + IMAGE_INSTANCE_PIXMAP_FG (ii) = foreground; + IMAGE_INSTANCE_PIXMAP_BG (ii) = background; + IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii) = + find_keyword_in_vector (instantiator, Q_hotspot_x); + IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii) = + find_keyword_in_vector (instantiator, Q_hotspot_y); + IMAGE_INSTANCE_GTK_CURSOR (ii) = + gdk_cursor_new_from_pixmap (source, mask, &fg_color, &bg_color, + !NILP (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii)) ? + XINT (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii)) : 0, + !NILP (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii)) ? + XINT (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii)) : 0); + } + break; + + default: + abort (); + } +} + +static void +xbm_instantiate_1 (Lisp_Object image_instance, Lisp_Object instantiator, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + int dest_mask, int width, int height, + /* Note that data is in ext-format! */ + CONST char *bits) +{ + Lisp_Object mask_data = find_keyword_in_vector (instantiator, Q_mask_data); + Lisp_Object mask_file = find_keyword_in_vector (instantiator, Q_mask_file); + struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + GdkPixmap *mask = 0; + CONST char *gcc_may_you_rot_in_hell; + + if (!NILP (mask_data)) + { + TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (XCDR (XCDR (mask_data))), + C_STRING_ALLOCA, gcc_may_you_rot_in_hell, + Qfile_name); + mask = + pixmap_from_xbm_inline (IMAGE_INSTANCE_DEVICE (ii), + XINT (XCAR (mask_data)), + XINT (XCAR (XCDR (mask_data))), + (CONST unsigned char *) + gcc_may_you_rot_in_hell); + } + + init_image_instance_from_xbm_inline (ii, width, height, bits, + instantiator, pointer_fg, pointer_bg, + dest_mask, mask, mask_file); +} + +/* Instantiate method for XBM's. */ + +static void +gtk_xbm_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + int dest_mask, Lisp_Object domain) +{ + Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); + CONST char *gcc_go_home; + + assert (!NILP (data)); + + TO_EXTERNAL_FORMAT (LISP_STRING, XCAR (XCDR (XCDR (data))), + C_STRING_ALLOCA, gcc_go_home, + Qbinary); + + xbm_instantiate_1 (image_instance, instantiator, pointer_fg, + pointer_bg, dest_mask, XINT (XCAR (data)), + XINT (XCAR (XCDR (data))), gcc_go_home); +} + + +#ifdef HAVE_XPM +/********************************************************************** + * XPM * + **********************************************************************/ +static void +write_lisp_string_to_temp_file (Lisp_Object string, char *filename_out) +{ + Lisp_Object instream, outstream; + Lstream *istr, *ostr; + char tempbuf[1024]; /* some random amount */ + int fubar = 0; + FILE *tmpfil; + static Extbyte_dynarr *conversion_out_dynarr; + Bytecount bstart, bend; + struct gcpro gcpro1, gcpro2; +#ifdef FILE_CODING + Lisp_Object conv_out_stream; + Lstream *costr; + struct gcpro gcpro3; +#endif + + /* This function can GC */ + if (!conversion_out_dynarr) + conversion_out_dynarr = Dynarr_new (Extbyte); + else + Dynarr_reset (conversion_out_dynarr); + + /* Create the temporary file ... */ + sprintf (filename_out, "/tmp/emacs%d.XXXXXX", (int) getpid ()); + mktemp (filename_out); + tmpfil = fopen (filename_out, "w"); + if (!tmpfil) + { + if (tmpfil) + { + int old_errno = errno; + fclose (tmpfil); + unlink (filename_out); + errno = old_errno; + } + report_file_error ("Creating temp file", + list1 (build_string (filename_out))); + } + + CHECK_STRING (string); + get_string_range_byte (string, Qnil, Qnil, &bstart, &bend, + GB_HISTORICAL_STRING_BEHAVIOR); + instream = make_lisp_string_input_stream (string, bstart, bend); + istr = XLSTREAM (instream); + /* setup the out stream */ + outstream = make_dynarr_output_stream((unsigned_char_dynarr *)conversion_out_dynarr); + ostr = XLSTREAM (outstream); +#ifdef FILE_CODING + /* setup the conversion stream */ + conv_out_stream = make_encoding_output_stream (ostr, Fget_coding_system(Qbinary)); + costr = XLSTREAM (conv_out_stream); + GCPRO3 (instream, outstream, conv_out_stream); +#else + GCPRO2 (instream, outstream); +#endif + + /* Get the data while doing the conversion */ + while (1) + { + int size_in_bytes = Lstream_read (istr, tempbuf, sizeof (tempbuf)); + if (!size_in_bytes) + break; + /* It does seem the flushes are necessary... */ +#ifdef FILE_CODING + Lstream_write (costr, tempbuf, size_in_bytes); + Lstream_flush (costr); +#else + Lstream_write (ostr, tempbuf, size_in_bytes); +#endif + Lstream_flush (ostr); + if (fwrite ((unsigned char *)Dynarr_atp(conversion_out_dynarr, 0), + Dynarr_length(conversion_out_dynarr), 1, tmpfil) != 1) + { + fubar = 1; + break; + } + /* reset the dynarr */ + Lstream_rewind(ostr); + } + + if (fclose (tmpfil) != 0) + fubar = 1; + Lstream_close (istr); +#ifdef FILE_CODING + Lstream_close (costr); +#endif + Lstream_close (ostr); + + UNGCPRO; + Lstream_delete (istr); + Lstream_delete (ostr); +#ifdef FILE_CODING + Lstream_delete (costr); +#endif + + if (fubar) + report_file_error ("Writing temp file", + list1 (build_string (filename_out))); +} + +struct color_symbol +{ + char* name; + GdkColor color; +}; + +static struct color_symbol* +extract_xpm_color_names (Lisp_Object device, + Lisp_Object domain, + Lisp_Object color_symbol_alist, + int* nsymbols) +{ + /* This function can GC */ + Lisp_Object rest; + Lisp_Object results = Qnil; + int i, j; + struct color_symbol *colortbl; + struct gcpro gcpro1, gcpro2; + + GCPRO2 (results, device); + + /* We built up results to be (("name" . #) ...) so that if an + error happens we don't lose any malloc()ed data, or more importantly, + leave any pixels allocated in the server. */ + i = 0; + LIST_LOOP (rest, color_symbol_alist) + { + Lisp_Object cons = XCAR (rest); + Lisp_Object name = XCAR (cons); + Lisp_Object value = XCDR (cons); + if (NILP (value)) + continue; + if (STRINGP (value)) + value = + Fmake_color_instance + (value, device, encode_error_behavior_flag (ERROR_ME_NOT)); + else + { + assert (COLOR_SPECIFIERP (value)); + value = Fspecifier_instance (value, domain, Qnil, Qnil); + } + if (NILP (value)) + continue; + results = noseeum_cons (noseeum_cons (name, value), results); + i++; + } + UNGCPRO; /* no more evaluation */ + + *nsymbols=i; + if (i == 0) return 0; + + colortbl = xnew_array_and_zero (struct color_symbol, i); + + for (j=0; j 1) + { + warn_when_safe (Qunimplemented, Qnotice, + "GTK does not support XPM cursors...\n"); + IMAGE_INSTANCE_GTK_CURSOR (ii) = gdk_cursor_new (GDK_COFFEE_MUG); + } + else + { + generate_cursor_fg_bg (device, &pointer_fg, &pointer_bg, + &fg, &bg); + IMAGE_INSTANCE_PIXMAP_FG (ii) = pointer_fg; + IMAGE_INSTANCE_PIXMAP_BG (ii) = pointer_bg; + IMAGE_INSTANCE_GTK_CURSOR (ii) = gdk_cursor_new_from_pixmap (pixmap, mask, &fg, &bg, xhot, yhot); + } + } + + break; + + default: + abort (); + } +} +#endif /* HAVE_XPM */ + + +#ifdef HAVE_XFACE + +/********************************************************************** + * X-Face * + **********************************************************************/ +#if defined(EXTERN) +/* This is about to get redefined! */ +#undef EXTERN +#endif +/* We have to define SYSV32 so that compface.h includes string.h + instead of strings.h. */ +#define SYSV32 +#ifdef __cplusplus +extern "C" { +#endif +#include +#ifdef __cplusplus +} +#endif +/* JMP_BUF cannot be used here because if it doesn't get defined + to jmp_buf we end up with a conflicting type error with the + definition in compface.h */ +extern jmp_buf comp_env; +#undef SYSV32 + +static void +gtk_xface_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + int dest_mask, Lisp_Object domain) +{ + Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); + int i, stattis; + char *p, *bits, *bp; + CONST char * volatile emsg = 0; + CONST char * volatile dstring; + + assert (!NILP (data)); + + LISP_STRING_TO_EXTERNAL (data, dstring, Qbinary); + + if ((p = strchr (dstring, ':'))) + { + dstring = p + 1; + } + + /* Must use setjmp not SETJMP because we used jmp_buf above not JMP_BUF */ + if (!(stattis = setjmp (comp_env))) + { + UnCompAll ((char *) dstring); + UnGenFace (); + } + + switch (stattis) + { + case -2: + emsg = "uncompface: internal error"; + break; + case -1: + emsg = "uncompface: insufficient or invalid data"; + break; + case 1: + emsg = "uncompface: excess data ignored"; + break; + } + + if (emsg) + signal_simple_error_2 (emsg, data, Qimage); + + bp = bits = (char *) alloca (PIXELS / 8); + + /* the compface library exports char F[], which uses a single byte per + pixel to represent a 48x48 bitmap. Yuck. */ + for (i = 0, p = F; i < (PIXELS / 8); ++i) + { + int n, b; + /* reverse the bit order of each byte... */ + for (b = n = 0; b < 8; ++b) + { + n |= ((*p++) << b); + } + *bp++ = (char) n; + } + + xbm_instantiate_1 (image_instance, instantiator, pointer_fg, + pointer_bg, dest_mask, 48, 48, bits); +} + +#endif /* HAVE_XFACE */ + +/********************************************************************** + * RESOURCES * + **********************************************************************/ + +static void +gtk_resource_validate (Lisp_Object instantiator) +{ + if ((NILP (find_keyword_in_vector (instantiator, Q_file)) + && + NILP (find_keyword_in_vector (instantiator, Q_resource_id))) + || + NILP (find_keyword_in_vector (instantiator, Q_resource_type))) + signal_simple_error ("Must supply :file, :resource-id and :resource-type", + instantiator); +} + +static Lisp_Object +gtk_resource_normalize (Lisp_Object inst, Lisp_Object console_type, Lisp_Object dest_mask) +{ + /* This function can call lisp */ + Lisp_Object file = Qnil; + struct gcpro gcpro1, gcpro2; + Lisp_Object alist = Qnil; + + GCPRO2 (file, alist); + + file = potential_pixmap_file_instantiator (inst, Q_file, Q_data, + console_type); + + if (CONSP (file)) /* failure locating filename */ + signal_double_file_error ("Opening pixmap file", + "no such file or directory", + Fcar (file)); + + if (NILP (file)) /* no conversion necessary */ + RETURN_UNGCPRO (inst); + + alist = tagged_vector_to_alist (inst); + + { + alist = remassq_no_quit (Q_file, alist); + alist = Fcons (Fcons (Q_file, file), alist); + } + + { + Lisp_Object result = alist_to_tagged_vector (Qgtk_resource, alist); + free_alist (alist); + RETURN_UNGCPRO (result); + } +} + +static int +gtk_resource_possible_dest_types (void) +{ + return IMAGE_POINTER_MASK | IMAGE_COLOR_PIXMAP_MASK; +} + +extern guint symbol_to_enum (Lisp_Object, GtkType); + +static guint resource_name_to_resource (Lisp_Object name, int type) +{ + if (type == IMAGE_POINTER) + return (symbol_to_enum (name, GTK_TYPE_GDK_CURSOR_TYPE)); + else + return (0); +} + +static int +resource_symbol_to_type (Lisp_Object data) +{ + if (EQ (data, Qcursor)) + return IMAGE_POINTER; +#if 0 + else if (EQ (data, Qicon)) + return IMAGE_ICON; + else if (EQ (data, Qbitmap)) + return IMAGE_BITMAP; +#endif + else + return 0; +} + +static void +gtk_resource_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + int dest_mask, Lisp_Object domain) +{ + struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + GdkCursor *c = NULL; + unsigned int type = 0; + Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); + Lisp_Object resource_type = find_keyword_in_vector (instantiator, Q_resource_type); + Lisp_Object resource_id = find_keyword_in_vector (instantiator, Q_resource_id); + + if (!DEVICE_GTK_P (XDEVICE (device))) + signal_simple_error ("Not a GTK device", device); + + type = resource_symbol_to_type (resource_type); + + // if (dest_mask & IMAGE_POINTER_MASK && type == IMAGE_POINTER_MASK) + // iitype = IMAGE_POINTER; + // else if (dest_mask & IMAGE_COLOR_PIXMAP_MASK) + // iitype = IMAGE_COLOR_PIXMAP; + // else + // incompatible_image_types (instantiator, dest_mask, + // IMAGE_COLOR_PIXMAP_MASK | IMAGE_POINTER_MASK); + + /* mess with the keyword info we were provided with */ + gtk_initialize_pixmap_image_instance (ii, 1, type); + c = gdk_cursor_new (resource_name_to_resource (resource_id, type)); + IMAGE_INSTANCE_GTK_CURSOR (ii) = c; + IMAGE_INSTANCE_PIXMAP_FILENAME (ii) = resource_id; + IMAGE_INSTANCE_PIXMAP_WIDTH (ii) = 10; + IMAGE_INSTANCE_PIXMAP_HEIGHT (ii) = 10; + IMAGE_INSTANCE_PIXMAP_DEPTH (ii) = 1; +} + +static void +check_valid_resource_symbol (Lisp_Object data) +{ + CHECK_SYMBOL (data); + if (!resource_symbol_to_type (data)) + signal_simple_error ("invalid resource type", data); +} + +static void +check_valid_resource_id (Lisp_Object data) +{ + if (!resource_name_to_resource (data, IMAGE_POINTER) + && + !resource_name_to_resource (data, IMAGE_COLOR_PIXMAP) +#if 0 + && + !resource_name_to_resource (data, IMAGE_BITMAP) +#endif + ) + signal_simple_error ("invalid resource identifier", data); +} + +#if 0 +void +check_valid_string_or_int (Lisp_Object data) +{ + if (!INTP (data)) + CHECK_STRING (data); + else + CHECK_INT (data); +} +#endif + + +/********************************************************************** + * Autodetect * + **********************************************************************/ + +static void +autodetect_validate (Lisp_Object instantiator) +{ + data_must_be_present (instantiator); +} + +static Lisp_Object +autodetect_normalize (Lisp_Object instantiator, + Lisp_Object console_type, + Lisp_Object dest_mask) +{ + Lisp_Object file = find_keyword_in_vector (instantiator, Q_data); + Lisp_Object filename = Qnil; + Lisp_Object data = Qnil; + struct gcpro gcpro1, gcpro2, gcpro3; + Lisp_Object alist = Qnil; + + GCPRO3 (filename, data, alist); + + if (NILP (file)) /* no conversion necessary */ + RETURN_UNGCPRO (instantiator); + + alist = tagged_vector_to_alist (instantiator); + + filename = locate_pixmap_file (file); + if (!NILP (filename)) + { + int xhot, yhot; + /* #### Apparently some versions of XpmReadFileToData, which is + called by pixmap_to_lisp_data, don't return an error value + if the given file is not a valid XPM file. Instead, they + just seg fault. It is definitely caused by passing a + bitmap. To try and avoid this we check for bitmaps first. */ + + data = bitmap_to_lisp_data (filename, &xhot, &yhot, 1); + + if (!EQ (data, Qt)) + { + alist = remassq_no_quit (Q_data, alist); + alist = Fcons (Fcons (Q_file, filename), + Fcons (Fcons (Q_data, data), alist)); + if (xhot != -1) + alist = Fcons (Fcons (Q_hotspot_x, make_int (xhot)), + alist); + if (yhot != -1) + alist = Fcons (Fcons (Q_hotspot_y, make_int (yhot)), + alist); + + alist = xbm_mask_file_munging (alist, filename, Qnil, console_type); + + { + Lisp_Object result = alist_to_tagged_vector (Qxbm, alist); + free_alist (alist); + RETURN_UNGCPRO (result); + } + } + +#ifdef HAVE_XPM + data = pixmap_to_lisp_data (filename, 1); + + if (!EQ (data, Qt)) + { + alist = remassq_no_quit (Q_data, alist); + alist = Fcons (Fcons (Q_file, filename), + Fcons (Fcons (Q_data, data), alist)); + alist = Fcons (Fcons (Q_color_symbols, + evaluate_xpm_color_symbols ()), + alist); + { + Lisp_Object result = alist_to_tagged_vector (Qxpm, alist); + free_alist (alist); + RETURN_UNGCPRO (result); + } + } +#endif + } + + /* If we couldn't convert it, just put it back as it is. + We might try to further frob it later as a cursor-font + specification. (We can't do that now because we don't know + what dest-types it's going to be instantiated into.) */ + { + Lisp_Object result = alist_to_tagged_vector (Qautodetect, alist); + free_alist (alist); + RETURN_UNGCPRO (result); + } +} + +static int +autodetect_possible_dest_types (void) +{ + return + IMAGE_MONO_PIXMAP_MASK | + IMAGE_COLOR_PIXMAP_MASK | + IMAGE_POINTER_MASK | + IMAGE_TEXT_MASK; +} + +static void +autodetect_instantiate (Lisp_Object image_instance, + Lisp_Object instantiator, + Lisp_Object pointer_fg, + Lisp_Object pointer_bg, + int dest_mask, Lisp_Object domain) +{ + Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); + struct gcpro gcpro1, gcpro2, gcpro3; + Lisp_Object alist = Qnil; + Lisp_Object result = Qnil; + int is_cursor_font = 0; + + GCPRO3 (data, alist, result); + + alist = tagged_vector_to_alist (instantiator); + if (dest_mask & IMAGE_POINTER_MASK) + { + CONST char *name_ext; + + TO_EXTERNAL_FORMAT (LISP_STRING, data, + C_STRING_ALLOCA, name_ext, + Qfile_name); + + if (cursor_name_to_index (name_ext) != -1) + { + result = alist_to_tagged_vector (Qcursor_font, alist); + is_cursor_font = 1; + } + } + + if (!is_cursor_font) + result = alist_to_tagged_vector (Qstring, alist); + free_alist (alist); + + if (is_cursor_font) + cursor_font_instantiate (image_instance, result, pointer_fg, + pointer_bg, dest_mask, domain); + else + string_instantiate (image_instance, result, pointer_fg, + pointer_bg, dest_mask, domain); + + UNGCPRO; +} + + +/********************************************************************** + * Font * + **********************************************************************/ + +static void +font_validate (Lisp_Object instantiator) +{ + data_must_be_present (instantiator); +} + +static int +font_possible_dest_types (void) +{ + return IMAGE_POINTER_MASK; +} + +static void +font_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + int dest_mask, Lisp_Object domain) +{ + /* This function can GC */ + Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); + struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); + GdkColor fg, bg; + GdkFont *source, *mask; + char source_name[MAXPATHLEN], mask_name[MAXPATHLEN], dummy; + int source_char, mask_char; + int count; + Lisp_Object foreground, background; + + if (!DEVICE_GTK_P (XDEVICE (device))) + signal_simple_error ("Not a Gtk device", device); + + if (!STRINGP (data) || + strncmp ("FONT ", (char *) XSTRING_DATA (data), 5)) + signal_simple_error ("Invalid font-glyph instantiator", + instantiator); + + if (!(dest_mask & IMAGE_POINTER_MASK)) + incompatible_image_types (instantiator, dest_mask, IMAGE_POINTER_MASK); + + foreground = find_keyword_in_vector (instantiator, Q_foreground); + if (NILP (foreground)) + foreground = pointer_fg; + background = find_keyword_in_vector (instantiator, Q_background); + if (NILP (background)) + background = pointer_bg; + + generate_cursor_fg_bg (device, &foreground, &background, &fg, &bg); + + count = sscanf ((char *) XSTRING_DATA (data), + "FONT %s %d %s %d %c", + source_name, &source_char, + mask_name, &mask_char, &dummy); + /* Allow "%s %d %d" as well... */ + if (count == 3 && (1 == sscanf (mask_name, "%d %c", &mask_char, &dummy))) + count = 4, mask_name[0] = 0; + + if (count != 2 && count != 4) + signal_simple_error ("invalid cursor specification", data); + source = gdk_font_load (source_name); + if (! source) + signal_simple_error_2 ("couldn't load font", + build_string (source_name), + data); + if (count == 2) + mask = 0; + else if (!mask_name[0]) + mask = source; + else + { + mask = gdk_font_load (mask_name); + if (!mask) + /* continuable */ + Fsignal (Qerror, list3 (build_string ("couldn't load font"), + build_string (mask_name), data)); + } + if (!mask) + mask_char = 0; + + /* #### call XQueryTextExtents() and check_pointer_sizes() here. */ + + gtk_initialize_pixmap_image_instance (ii, 1, IMAGE_POINTER); + + IMAGE_INSTANCE_GTK_CURSOR (ii) = NULL; + +#if 0 + /* #### BILL!!! There is no way to call this function from Gdk */ + XCreateGlyphCursor (dpy, source, mask, source_char, mask_char, + &fg, &bg); +#endif + XIMAGE_INSTANCE_PIXMAP_FG (image_instance) = foreground; + XIMAGE_INSTANCE_PIXMAP_BG (image_instance) = background; + + gdk_font_unref (source); + if (mask && mask != source) gdk_font_unref (mask); +} + + +/********************************************************************** + * Cursor-Font * + **********************************************************************/ + +static void +cursor_font_validate (Lisp_Object instantiator) +{ + data_must_be_present (instantiator); +} + +static int +cursor_font_possible_dest_types (void) +{ + return IMAGE_POINTER_MASK; +} + +static char *__downcase (const char *name) +{ + char *converted = strdup(name); + char *work = converted; + + while (*work) + { + *work = tolower(*work); + work++; + } + return(converted); +} + +/* This is basically the equivalent of XmuCursorNameToIndex */ +static gint +cursor_name_to_index (const char *name) +{ + int i; + static char *the_gdk_cursors[GDK_NUM_GLYPHS]; + + if (!the_gdk_cursors[GDK_BASED_ARROW_UP]) + { + /* Need to initialize the array */ + /* Supposedly since this array is static it should be + initialized to NULLs for us, but I'm very paranoid. */ + for (i = 0; i < GDK_NUM_GLYPHS; i++) + { + the_gdk_cursors[i] = NULL; + } + +#define FROB_CURSOR(x) the_gdk_cursors[GDK_##x] = __downcase(#x) + FROB_CURSOR(ARROW); FROB_CURSOR(BASED_ARROW_DOWN); + FROB_CURSOR(BASED_ARROW_UP); FROB_CURSOR(BOAT); + FROB_CURSOR(BOGOSITY); FROB_CURSOR(BOTTOM_LEFT_CORNER); + FROB_CURSOR(BOTTOM_RIGHT_CORNER); FROB_CURSOR(BOTTOM_SIDE); + FROB_CURSOR(BOTTOM_TEE); FROB_CURSOR(BOX_SPIRAL); + FROB_CURSOR(CENTER_PTR); FROB_CURSOR(CIRCLE); + FROB_CURSOR(CLOCK); FROB_CURSOR(COFFEE_MUG); + FROB_CURSOR(CROSS); FROB_CURSOR(CROSS_REVERSE); + FROB_CURSOR(CROSSHAIR); FROB_CURSOR(DIAMOND_CROSS); + FROB_CURSOR(DOT); FROB_CURSOR(DOTBOX); + FROB_CURSOR(DOUBLE_ARROW); FROB_CURSOR(DRAFT_LARGE); + FROB_CURSOR(DRAFT_SMALL); FROB_CURSOR(DRAPED_BOX); + FROB_CURSOR(EXCHANGE); FROB_CURSOR(FLEUR); + FROB_CURSOR(GOBBLER); FROB_CURSOR(GUMBY); + FROB_CURSOR(HAND1); FROB_CURSOR(HAND2); + FROB_CURSOR(HEART); FROB_CURSOR(ICON); + FROB_CURSOR(IRON_CROSS); FROB_CURSOR(LEFT_PTR); + FROB_CURSOR(LEFT_SIDE); FROB_CURSOR(LEFT_TEE); + FROB_CURSOR(LEFTBUTTON); FROB_CURSOR(LL_ANGLE); + FROB_CURSOR(LR_ANGLE); FROB_CURSOR(MAN); + FROB_CURSOR(MIDDLEBUTTON); FROB_CURSOR(MOUSE); + FROB_CURSOR(PENCIL); FROB_CURSOR(PIRATE); + FROB_CURSOR(PLUS); FROB_CURSOR(QUESTION_ARROW); + FROB_CURSOR(RIGHT_PTR); FROB_CURSOR(RIGHT_SIDE); + FROB_CURSOR(RIGHT_TEE); FROB_CURSOR(RIGHTBUTTON); + FROB_CURSOR(RTL_LOGO); FROB_CURSOR(SAILBOAT); + FROB_CURSOR(SB_DOWN_ARROW); FROB_CURSOR(SB_H_DOUBLE_ARROW); + FROB_CURSOR(SB_LEFT_ARROW); FROB_CURSOR(SB_RIGHT_ARROW); + FROB_CURSOR(SB_UP_ARROW); FROB_CURSOR(SB_V_DOUBLE_ARROW); + FROB_CURSOR(SHUTTLE); FROB_CURSOR(SIZING); + FROB_CURSOR(SPIDER); FROB_CURSOR(SPRAYCAN); + FROB_CURSOR(STAR); FROB_CURSOR(TARGET); + FROB_CURSOR(TCROSS); FROB_CURSOR(TOP_LEFT_ARROW); + FROB_CURSOR(TOP_LEFT_CORNER); FROB_CURSOR(TOP_RIGHT_CORNER); + FROB_CURSOR(TOP_SIDE); FROB_CURSOR(TOP_TEE); + FROB_CURSOR(TREK); FROB_CURSOR(UL_ANGLE); + FROB_CURSOR(UMBRELLA); FROB_CURSOR(UR_ANGLE); + FROB_CURSOR(WATCH); FROB_CURSOR(XTERM); + FROB_CURSOR(X_CURSOR); +#undef FROB_CURSOR + } + + for (i = 0; i < GDK_NUM_GLYPHS; i++) + { + if (!the_gdk_cursors[i]) continue; + if (!strcmp (the_gdk_cursors[i], name)) + { + return (i); + } + } + return(-1); +} + +static void +cursor_font_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + int dest_mask, Lisp_Object domain) +{ + /* This function can GC */ + Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); + struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); + int i; + CONST char *name_ext; + Lisp_Object foreground, background; + + if (!DEVICE_GTK_P (XDEVICE (device))) + signal_simple_error ("Not a Gtk device", device); + + if (!(dest_mask & IMAGE_POINTER_MASK)) + incompatible_image_types (instantiator, dest_mask, IMAGE_POINTER_MASK); + + TO_EXTERNAL_FORMAT (LISP_STRING, data, + C_STRING_ALLOCA, name_ext, + Qfile_name); + + if ((i = cursor_name_to_index (name_ext)) == -1) + signal_simple_error ("Unrecognized cursor-font name", data); + + gtk_initialize_pixmap_image_instance (ii, 1, IMAGE_POINTER); + IMAGE_INSTANCE_GTK_CURSOR (ii) = gdk_cursor_new (i); + foreground = find_keyword_in_vector (instantiator, Q_foreground); + if (NILP (foreground)) + foreground = pointer_fg; + background = find_keyword_in_vector (instantiator, Q_background); + if (NILP (background)) + background = pointer_bg; + maybe_recolor_cursor (image_instance, foreground, background); +} + +static int +gtk_colorize_image_instance (Lisp_Object image_instance, + Lisp_Object foreground, Lisp_Object background); + + +/************************************************************************/ +/* subwindow and widget support */ +/************************************************************************/ + +/* unmap the image if it is a widget. This is used by redisplay via + redisplay_unmap_subwindows */ +static void +gtk_unmap_subwindow (Lisp_Image_Instance *p) +{ + if (IMAGE_INSTANCE_TYPE (p) == IMAGE_SUBWINDOW) + { + /* We don't support subwindows, but we do support widgets... */ + abort (); + } + else /* must be a widget */ + { + /* Since we are being unmapped we want the enclosing frame to + get focus. The losing with simple scrolling but is the safest + thing to do. */ + if (IMAGE_INSTANCE_GTK_CLIPWIDGET (p)) + gtk_widget_unmap (IMAGE_INSTANCE_GTK_CLIPWIDGET (p)); + } +} + +/* map the subwindow. This is used by redisplay via + redisplay_output_subwindow */ +static void +gtk_map_subwindow (Lisp_Image_Instance *p, int x, int y, + struct display_glyph_area* dga) +{ + assert (dga->width > 0 && dga->height > 0); + + if (IMAGE_INSTANCE_TYPE (p) == IMAGE_SUBWINDOW) + { + /* No subwindow support... */ + abort (); + } + else /* must be a widget */ + { + struct frame *f = XFRAME (IMAGE_INSTANCE_FRAME (p)); + GtkWidget *wid = IMAGE_INSTANCE_GTK_CLIPWIDGET (p); + GtkAllocation a; + + if (!wid) return; + + a.x = x + IMAGE_INSTANCE_GTK_WIDGET_XOFFSET (p); + a.y = y + IMAGE_INSTANCE_GTK_WIDGET_YOFFSET (p); + a.width = dga->width; + a.height = dga->height; + + if ((a.width != wid->allocation.width) || + (a.height != wid->allocation.height)) + { + gtk_widget_size_allocate (IMAGE_INSTANCE_GTK_CLIPWIDGET (p), &a); + } + + /* #### FIXME DAMMIT */ + if ((wid->allocation.x != -dga->xoffset) || + (wid->allocation.y != -dga->yoffset)) + { + guint32 old_flags = GTK_WIDGET_FLAGS (FRAME_GTK_TEXT_WIDGET (f)); + + /* Fucking GtkFixed widget queues a resize when you add a widget. + ** But only if it is visible. + ** losers. + */ + GTK_WIDGET_FLAGS(FRAME_GTK_TEXT_WIDGET (f)) &= ~GTK_VISIBLE; + if (IMAGE_INSTANCE_GTK_ALREADY_PUT(p)) + { + gtk_fixed_move (GTK_FIXED (FRAME_GTK_TEXT_WIDGET (f)), + wid, + -dga->xoffset, -dga->yoffset); + } + else + { + IMAGE_INSTANCE_GTK_ALREADY_PUT(p) = TRUE; + gtk_fixed_put (GTK_FIXED (FRAME_GTK_TEXT_WIDGET (f)), + wid, + -dga->xoffset, -dga->yoffset); + } + GTK_WIDGET_FLAGS(FRAME_GTK_TEXT_WIDGET (f)) = old_flags; + } + + if (!IMAGE_INSTANCE_SUBWINDOW_DISPLAYEDP (p)) + { + gtk_widget_map (wid); + } + + gtk_widget_draw (wid, NULL); + } +} + +/* when you click on a widget you may activate another widget this + needs to be checked and all appropriate widgets updated */ +static void +gtk_redisplay_subwindow (Lisp_Image_Instance *p) +{ + /* Update the subwindow size if necessary. */ + if (IMAGE_INSTANCE_SIZE_CHANGED (p)) + { +#if 0 + XResizeWindow (IMAGE_INSTANCE_X_SUBWINDOW_DISPLAY (p), + IMAGE_INSTANCE_X_SUBWINDOW_ID (p), + IMAGE_INSTANCE_WIDTH (p), + IMAGE_INSTANCE_HEIGHT (p)); +#endif + } +} + +/* Update all attributes that have changed. */ +static void +gtk_redisplay_widget (Lisp_Image_Instance *p) +{ + /* This function can GC if IN_REDISPLAY is false. */ + + if (!IMAGE_INSTANCE_GTK_CLIPWIDGET (p)) + return; + +#ifdef HAVE_WIDGETS + /* First get the items if they have changed since this is a + structural change. As such it will nuke all added values so we + need to update most other things after the items have changed.*/ + gtk_widget_show_all (IMAGE_INSTANCE_GTK_CLIPWIDGET (p)); + if (IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (p)) + { + Lisp_Object image_instance; + + XSETIMAGE_INSTANCE (image_instance, p); + + /* Need to update GtkArgs that might have changed... */ + /* #### FIXME!!! */ + } + else + { + /* #### FIXME!!! */ + /* No items changed, so do nothing, right? */ + } + + /* Possibly update the colors and font */ + if (IMAGE_INSTANCE_WIDGET_FACE_CHANGED (p) + || + /* #### This is not sufficient because it will not cope with widgets + that are not currently visible. Once redisplay has done the + visible ones it will clear this flag so that when new ones + become visible they will not be updated. */ + XFRAME (IMAGE_INSTANCE_FRAME (p))->faces_changed + || + XFRAME (IMAGE_INSTANCE_FRAME (p))->frame_changed + || + IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (p)) + { + /* #### Write this function BILL! */ + update_widget_face (NULL, p, IMAGE_INSTANCE_FRAME (p)); + } + + /* Possibly update the text. */ + if (IMAGE_INSTANCE_TEXT_CHANGED (p)) + { + char* str; + Lisp_Object val = IMAGE_INSTANCE_WIDGET_TEXT (p); + LISP_STRING_TO_EXTERNAL (val, str, Qnative); + + /* #### Need to special case each type of GtkWidget here! */ + } + + /* Possibly update the size. */ + if (IMAGE_INSTANCE_SIZE_CHANGED (p) + || + IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (p) + || + IMAGE_INSTANCE_TEXT_CHANGED (p)) + { + assert (IMAGE_INSTANCE_GTK_WIDGET_ID (p) && + IMAGE_INSTANCE_GTK_CLIPWIDGET (p)) ; + + /* #### Resize the widget! */ + /* gtk_widget_size_allocate () */ + } + + /* Adjust offsets within the frame. */ + if (XFRAME (IMAGE_INSTANCE_FRAME (p))->size_changed) + { + /* I don't think we need to do anything for Gtk here... */ + } + + /* now modify the widget */ +#endif +} + +/* instantiate and gtk type subwindow */ +static void +gtk_subwindow_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + int dest_mask, Lisp_Object domain) +{ + /* This function can GC */ + Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); + Lisp_Object frame = DOMAIN_FRAME (domain); + + if (!DEVICE_GTK_P (XDEVICE (device))) + signal_simple_error ("Not a GTK device", device); + + IMAGE_INSTANCE_TYPE (ii) = IMAGE_SUBWINDOW; + + ii->data = xnew_and_zero (struct gtk_subwindow_data); + + /* Create a window for clipping */ + IMAGE_INSTANCE_GTK_CLIPWINDOW (ii) = NULL; + + /* Now put the subwindow inside the clip window. */ + IMAGE_INSTANCE_SUBWINDOW_ID (ii) = (void *) NULL; +} + +#ifdef HAVE_WIDGETS + +/************************************************************************/ +/* widgets */ +/************************************************************************/ +static void +update_widget_face (GtkWidget *w, Lisp_Image_Instance *ii, + Lisp_Object domain) +{ + if (0) + { + GtkStyle *style = gtk_widget_get_style (w); + Lisp_Object pixel = Qnil; + GdkColor *fcolor, *bcolor; + + style = gtk_style_copy (style); + + /* Update the foreground. */ + pixel = FACE_FOREGROUND (IMAGE_INSTANCE_WIDGET_FACE (ii), domain); + fcolor = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (pixel)); + + /* Update the background. */ + pixel = FACE_BACKGROUND (IMAGE_INSTANCE_WIDGET_FACE (ii), domain); + bcolor = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (pixel)); + + /* Update the font */ + /* #### FIXME!!! Need to copy the widgets style, dick with it, and + ** set the widgets style to the new style... + */ + gtk_widget_set_style (w, style); + + /* #### Megahack - but its just getting too complicated to do this + in the right place. */ +#if 0 + if (EQ (IMAGE_INSTANCE_WIDGET_TYPE (ii), Qtab_control)) + update_tab_widget_face (wv, ii, domain); +#endif + } +} + +#if 0 +static void +update_tab_widget_face (GtkWidget *w, Lisp_Image_Instance *ii, + Lisp_Object domain) +{ + if (wv->contents) + { + widget_value* val = wv->contents, *cur; + + /* Give each child label the correct foreground color. */ + Lisp_Object pixel = FACE_FOREGROUND + (IMAGE_INSTANCE_WIDGET_FACE (ii), + domain); + XColor fcolor = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (pixel)); + lw_add_widget_value_arg (val, XtNtabForeground, fcolor.pixel); + wv->change = VISIBLE_CHANGE; + val->change = VISIBLE_CHANGE; + + for (cur = val->next; cur; cur = cur->next) + { + cur->change = VISIBLE_CHANGE; + if (cur->value) + { + lw_copy_widget_value_args (val, cur); + } + } + } +} +#endif + +static Lisp_Object +gtk_widget_instantiate_1 (Lisp_Object image_instance, Lisp_Object instantiator, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + Lisp_Object domain) +{ + Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + Lisp_Object widget = Qnil; + char *nm = NULL; + GtkWidget *w = NULL; + struct gcpro gcpro1; + + IMAGE_INSTANCE_TYPE (ii) = IMAGE_WIDGET; + + if (!NILP (IMAGE_INSTANCE_WIDGET_TEXT (ii))) + { + LISP_STRING_TO_EXTERNAL (IMAGE_INSTANCE_WIDGET_TEXT (ii), nm, Qnative); + } + + ii->data = xnew_and_zero (struct gtk_subwindow_data); + + /* Create a clipping widget */ + IMAGE_INSTANCE_GTK_CLIPWIDGET (ii) = NULL; + IMAGE_INSTANCE_GTK_ALREADY_PUT(ii) = FALSE; + + /* Create the actual widget */ + GCPRO1 (widget); + widget = call5 (Qgtk_widget_instantiate_internal, + image_instance, instantiator, + pointer_fg, pointer_bg, + domain); + + if (!NILP (widget)) + { + CHECK_GTK_OBJECT (widget); + w = GTK_WIDGET (XGTK_OBJECT (widget)->object); + } + else + { + stderr_out ("Lisp-level creation of widget failed... falling back\n"); + w = gtk_label_new ("Widget Creation Failed..."); + } + + UNGCPRO; + + IMAGE_INSTANCE_SUBWINDOW_ID (ii) = (void *) w; + + /* #### HACK!!!! We should make this do the right thing if we + ** really need a clip widget! + */ + IMAGE_INSTANCE_GTK_CLIPWIDGET (ii) = w; + + return (Qt); +} + +static void +gtk_widget_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + int dest_mask, Lisp_Object domain) +{ + call_with_suspended_errors ((lisp_fn_t) gtk_widget_instantiate_1, + Qnil, Qimage, + ERROR_ME_WARN, 5, + image_instance, instantiator, + pointer_fg, + pointer_bg, + domain); +} + +/* get properties of a control */ +static Lisp_Object +gtk_widget_property (Lisp_Object image_instance, Lisp_Object prop) +{ + /* Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); */ + + /* get the text from a control */ + if (EQ (prop, Q_text)) + { + return Qnil; + } + return Qunbound; +} + +#define FAKE_GTK_WIDGET_INSTANTIATOR(x) \ +static void \ +gtk_##x##_instantiate (Lisp_Object image_instance, \ + Lisp_Object instantiator, \ + Lisp_Object pointer_fg, \ + Lisp_Object pointer_bg, \ + int dest_mask, Lisp_Object domain) \ +{ \ + gtk_widget_instantiate (image_instance, instantiator, pointer_fg, \ + pointer_bg, dest_mask, domain); \ +} + +FAKE_GTK_WIDGET_INSTANTIATOR(native_layout); +FAKE_GTK_WIDGET_INSTANTIATOR(button); +FAKE_GTK_WIDGET_INSTANTIATOR(progress_gauge); +FAKE_GTK_WIDGET_INSTANTIATOR(edit_field); +FAKE_GTK_WIDGET_INSTANTIATOR(combo_box); +FAKE_GTK_WIDGET_INSTANTIATOR(tab_control); +FAKE_GTK_WIDGET_INSTANTIATOR(label); + +/* Update a button's clicked state. */ +static void +gtk_button_redisplay (Lisp_Object image_instance) +{ + /* This function can GC if IN_REDISPLAY is false. */ + Lisp_Image_Instance *p = XIMAGE_INSTANCE (image_instance); + GtkWidget *w = IMAGE_INSTANCE_GTK_CLIPWIDGET (p); + + if (GTK_WIDGET_TYPE (w) == gtk_button_get_type ()) + { + } + else if (GTK_WIDGET_TYPE (w) == gtk_check_button_get_type ()) + { + } + else if (GTK_WIDGET_TYPE (w) == gtk_radio_button_get_type ()) + { + } + else + { + /* Unknown button type... */ + abort(); + } +} + +/* get properties of a button */ +static Lisp_Object +gtk_button_property (Lisp_Object image_instance, Lisp_Object prop) +{ + Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + + /* check the state of a button */ + if (EQ (prop, Q_selected)) + { + if (GTK_WIDGET_HAS_FOCUS (IMAGE_INSTANCE_SUBWINDOW_ID (ii))) + return Qt; + else + return Qnil; + } + return Qunbound; +} + +/* set the properties of a progress gauge */ +static void +gtk_progress_gauge_redisplay (Lisp_Object image_instance) +{ + Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + + if (IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii)) + { + gfloat f; + Lisp_Object val; + + val = XGUI_ITEM (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii))->value; + f = XFLOATINT (val); + + gtk_progress_set_value (GTK_PROGRESS (IMAGE_INSTANCE_SUBWINDOW_ID (ii)), + f); + } +} + +/* Set the properties of a tab control */ +static void +gtk_tab_control_redisplay (Lisp_Object image_instance) +{ + /* #### Convert this to GTK baby! */ + Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + + if (IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii) || + IMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (ii)) + { + /* If only the order has changed then simply select the first + one of the pending set. This stops horrendous rebuilding - + and hence flicker - of the tabs each time you click on + one. */ + if (tab_control_order_only_changed (image_instance)) + { + Lisp_Object rest, selected = + gui_item_list_find_selected + (NILP (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii)) ? + XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii)) : + XCDR (IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii))); + + LIST_LOOP (rest, XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii))) + { + if (gui_item_equal_sans_selected (XCAR (rest), selected, 0)) + { + Lisp_Object old_selected =gui_item_list_find_selected + (XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii))); + + /* Need to focus on the widget... */ + stderr_out ("Hey, change the tab-focus you boob...\n"); + + /* Pick up the new selected item. */ + XGUI_ITEM (old_selected)->selected = + XGUI_ITEM (XCAR (rest))->selected; + XGUI_ITEM (XCAR (rest))->selected = + XGUI_ITEM (selected)->selected; + /* We're not actually changing the items anymore. */ + IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii) = 0; + IMAGE_INSTANCE_WIDGET_PENDING_ITEMS (ii) = Qnil; + break; + } + } + } + else + { + /* More than just the order has changed... let's get busy! */ + GtkNotebook *nb = GTK_NOTEBOOK (IMAGE_INSTANCE_GTK_CLIPWIDGET (ii)); + guint num_pages = g_list_length (nb->children); + Lisp_Object rest; + + if (num_pages >= 0) + { + int i; + for (i = num_pages; i >= 0; --i) + { + gtk_notebook_remove_page (nb, i); + } + } + + LIST_LOOP (rest, XCDR (IMAGE_INSTANCE_WIDGET_ITEMS (ii))) + { + Lisp_Gui_Item *pgui = XGUI_ITEM (XCAR (rest)); + char *c_name = NULL; + + if (!STRINGP (pgui->name)) + pgui->name = Feval (pgui->name); + + CHECK_STRING (pgui->name); + + TO_EXTERNAL_FORMAT (LISP_STRING, pgui->name, + C_STRING_ALLOCA, c_name, + Qctext); + + gtk_notebook_append_page (nb, + gtk_vbox_new (FALSE, 3), + gtk_label_new (c_name)); + } + + /* Show all the new widgets we just added... */ + gtk_widget_show_all (GTK_WIDGET (nb)); + } + } + + /* Possibly update the face. */ +#if 0 + if (IMAGE_INSTANCE_WIDGET_FACE_CHANGED (ii) + || + XFRAME (IMAGE_INSTANCE_FRAME (ii))->faces_changed + || + IMAGE_INSTANCE_WIDGET_ITEMS_CHANGED (ii)) + { + update_tab_widget_face (wv, ii, + IMAGE_INSTANCE_FRAME (ii)); + } +#endif +} +#endif /* HAVE_WIDGETS */ + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ +void +syms_of_glyphs_gtk (void) +{ + defkeyword (&Q_resource_id, ":resource-id"); + defkeyword (&Q_resource_type, ":resource-type"); +#ifdef HAVE_WIDGETS + defsymbol (&Qgtk_widget_instantiate_internal, "gtk-widget-instantiate-internal"); + defsymbol (&Qgtk_widget_property_internal, "gtk-widget-property-internal"); + defsymbol (&Qgtk_widget_redisplay_internal, "gtk-widget-redisplay-internal"); + defsymbol (&Qgtk_widget_set_style, "gtk-widget-set-style"); +#endif +} + +void +console_type_create_glyphs_gtk (void) +{ + /* image methods */ + CONSOLE_HAS_METHOD (gtk, print_image_instance); + CONSOLE_HAS_METHOD (gtk, finalize_image_instance); + CONSOLE_HAS_METHOD (gtk, image_instance_equal); + CONSOLE_HAS_METHOD (gtk, image_instance_hash); + CONSOLE_HAS_METHOD (gtk, colorize_image_instance); + CONSOLE_HAS_METHOD (gtk, init_image_instance_from_eimage); + CONSOLE_HAS_METHOD (gtk, locate_pixmap_file); + CONSOLE_HAS_METHOD (gtk, unmap_subwindow); + CONSOLE_HAS_METHOD (gtk, map_subwindow); + CONSOLE_HAS_METHOD (gtk, redisplay_widget); + CONSOLE_HAS_METHOD (gtk, redisplay_subwindow); +} + +void +image_instantiator_format_create_glyphs_gtk (void) +{ + IIFORMAT_VALID_CONSOLE (gtk, nothing); + IIFORMAT_VALID_CONSOLE (gtk, string); +#ifdef HAVE_WIDGETS + IIFORMAT_VALID_CONSOLE (gtk, layout); +#endif + IIFORMAT_VALID_CONSOLE (gtk, formatted_string); + IIFORMAT_VALID_CONSOLE (gtk, inherit); +#ifdef HAVE_XPM + INITIALIZE_DEVICE_IIFORMAT (gtk, xpm); + IIFORMAT_HAS_DEVMETHOD (gtk, xpm, instantiate); +#endif +#ifdef HAVE_JPEG + IIFORMAT_VALID_CONSOLE (gtk, jpeg); +#endif +#ifdef HAVE_TIFF + IIFORMAT_VALID_CONSOLE (gtk, tiff); +#endif +#ifdef HAVE_PNG + IIFORMAT_VALID_CONSOLE (gtk, png); +#endif +#ifdef HAVE_GIF + IIFORMAT_VALID_CONSOLE (gtk, gif); +#endif + + INITIALIZE_DEVICE_IIFORMAT (gtk, subwindow); + IIFORMAT_HAS_DEVMETHOD (gtk, subwindow, instantiate); + +#ifdef HAVE_WIDGETS + /* layout widget */ + INITIALIZE_DEVICE_IIFORMAT (gtk, native_layout); + IIFORMAT_HAS_DEVMETHOD (gtk, native_layout, instantiate); + + /* button widget */ + INITIALIZE_DEVICE_IIFORMAT (gtk, button); + IIFORMAT_HAS_DEVMETHOD (gtk, button, property); + IIFORMAT_HAS_DEVMETHOD (gtk, button, instantiate); + IIFORMAT_HAS_DEVMETHOD (gtk, button, redisplay); + /* general widget methods. */ + INITIALIZE_DEVICE_IIFORMAT (gtk, widget); + IIFORMAT_HAS_DEVMETHOD (gtk, widget, property); + + /* progress gauge */ + INITIALIZE_DEVICE_IIFORMAT (gtk, progress_gauge); + IIFORMAT_HAS_DEVMETHOD (gtk, progress_gauge, redisplay); + IIFORMAT_HAS_DEVMETHOD (gtk, progress_gauge, instantiate); + /* text field */ + INITIALIZE_DEVICE_IIFORMAT (gtk, edit_field); + IIFORMAT_HAS_DEVMETHOD (gtk, edit_field, instantiate); + INITIALIZE_DEVICE_IIFORMAT (gtk, combo_box); + IIFORMAT_HAS_DEVMETHOD (gtk, combo_box, instantiate); + IIFORMAT_HAS_SHARED_DEVMETHOD (gtk, combo_box, redisplay, tab_control); + /* tab control widget */ + INITIALIZE_DEVICE_IIFORMAT (gtk, tab_control); + IIFORMAT_HAS_DEVMETHOD (gtk, tab_control, instantiate); + IIFORMAT_HAS_DEVMETHOD (gtk, tab_control, redisplay); + /* label */ + INITIALIZE_DEVICE_IIFORMAT (gtk, label); + IIFORMAT_HAS_DEVMETHOD (gtk, label, instantiate); +#endif + + INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (cursor_font, "cursor-font"); + IIFORMAT_VALID_CONSOLE (gtk, cursor_font); + + IIFORMAT_HAS_METHOD (cursor_font, validate); + IIFORMAT_HAS_METHOD (cursor_font, possible_dest_types); + IIFORMAT_HAS_METHOD (cursor_font, instantiate); + + IIFORMAT_VALID_KEYWORD (cursor_font, Q_data, check_valid_string); + IIFORMAT_VALID_KEYWORD (cursor_font, Q_foreground, check_valid_string); + IIFORMAT_VALID_KEYWORD (cursor_font, Q_background, check_valid_string); + + INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (font, "font"); + IIFORMAT_VALID_CONSOLE (gtk, font); + + IIFORMAT_HAS_METHOD (font, validate); + IIFORMAT_HAS_METHOD (font, possible_dest_types); + IIFORMAT_HAS_METHOD (font, instantiate); + + IIFORMAT_VALID_KEYWORD (font, Q_data, check_valid_string); + IIFORMAT_VALID_KEYWORD (font, Q_foreground, check_valid_string); + IIFORMAT_VALID_KEYWORD (font, Q_background, check_valid_string); + +#ifdef HAVE_XPM + INITIALIZE_DEVICE_IIFORMAT (gtk, xpm); + IIFORMAT_HAS_DEVMETHOD (gtk, xpm, instantiate); +#endif + +#ifdef HAVE_XFACE + INITIALIZE_DEVICE_IIFORMAT (gtk, xface); + IIFORMAT_HAS_DEVMETHOD (gtk, xface, instantiate); +#endif + + INITIALIZE_DEVICE_IIFORMAT (gtk, xbm); + IIFORMAT_HAS_DEVMETHOD (gtk, xbm, instantiate); + IIFORMAT_VALID_CONSOLE (gtk, xbm); + + INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (gtk_resource, "gtk-resource"); + IIFORMAT_VALID_CONSOLE (gtk, gtk_resource); + + IIFORMAT_HAS_METHOD (gtk_resource, validate); + IIFORMAT_HAS_METHOD (gtk_resource, normalize); + IIFORMAT_HAS_METHOD (gtk_resource, possible_dest_types); + IIFORMAT_HAS_METHOD (gtk_resource, instantiate); + + IIFORMAT_VALID_KEYWORD (gtk_resource, Q_resource_type, check_valid_resource_symbol); + IIFORMAT_VALID_KEYWORD (gtk_resource, Q_resource_id, check_valid_resource_id); + IIFORMAT_VALID_KEYWORD (gtk_resource, Q_file, check_valid_string); + + INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (autodetect, "autodetect"); + IIFORMAT_VALID_CONSOLE (gtk, autodetect); + + IIFORMAT_HAS_METHOD (autodetect, validate); + IIFORMAT_HAS_METHOD (autodetect, normalize); + IIFORMAT_HAS_METHOD (autodetect, possible_dest_types); + IIFORMAT_HAS_METHOD (autodetect, instantiate); + + IIFORMAT_VALID_KEYWORD (autodetect, Q_data, check_valid_string); +} + +void +vars_of_glyphs_gtk (void) +{ +#ifdef HAVE_XFACE + Fprovide (Qxface); +#endif + + DEFVAR_LISP ("gtk-bitmap-file-path", &Vgtk_bitmap_file_path /* +A list of the directories in which X bitmap files may be found. +If nil, this is initialized from the "*bitmapFilePath" resource. +This is used by the `make-image-instance' function (however, note that if +the environment variable XBMLANGPATH is set, it is consulted first). +*/ ); + Vgtk_bitmap_file_path = Qnil; +} + +void +complex_vars_of_glyphs_gtk (void) +{ +#define BUILD_GLYPH_INST(variable, name) \ + Fadd_spec_to_specifier \ + (GLYPH_IMAGE (XGLYPH (variable)), \ + vector3 (Qxbm, Q_data, \ + list3 (make_int (name##_width), \ + make_int (name##_height), \ + make_ext_string (name##_bits, \ + sizeof (name##_bits), \ + Qbinary))), \ + Qglobal, Qgtk, Qnil) + + BUILD_GLYPH_INST (Vtruncation_glyph, truncator); + BUILD_GLYPH_INST (Vcontinuation_glyph, continuer); + BUILD_GLYPH_INST (Vxemacs_logo, xemacs); + BUILD_GLYPH_INST (Vhscroll_glyph, hscroll); + +#undef BUILD_GLYPH_INST +} + + +/* Ripped off from glyphs-msw.c */ +/* + * The data returned by the following routine is always in left-most byte + * first and left-most bit first. If it doesn't return BitmapSuccess then + * its arguments won't have been touched. This routine should look as much + * like the Xlib routine XReadBitmapfile as possible. + */ +#define MAX_SIZE 1024 + +/* shared data for the image read/parse logic */ +static short hexTable[256]; /* conversion value */ +static int initialized = FALSE; /* easier to fill in at run time */ + +/* + * Table index for the hex values. Initialized once, first time. + * Used for translation value or delimiter significance lookup. + */ +static void initHexTable() +{ + /* + * We build the table at run time for several reasons: + * + * 1. portable to non-ASCII machines. + * 2. still reentrant since we set the init flag after setting table. + * 3. easier to extend. + * 4. less prone to bugs. + */ + hexTable['0'] = 0; hexTable['1'] = 1; + hexTable['2'] = 2; hexTable['3'] = 3; + hexTable['4'] = 4; hexTable['5'] = 5; + hexTable['6'] = 6; hexTable['7'] = 7; + hexTable['8'] = 8; hexTable['9'] = 9; + hexTable['A'] = 10; hexTable['B'] = 11; + hexTable['C'] = 12; hexTable['D'] = 13; + hexTable['E'] = 14; hexTable['F'] = 15; + hexTable['a'] = 10; hexTable['b'] = 11; + hexTable['c'] = 12; hexTable['d'] = 13; + hexTable['e'] = 14; hexTable['f'] = 15; + + /* delimiters of significance are flagged w/ negative value */ + hexTable[' '] = -1; hexTable[','] = -1; + hexTable['}'] = -1; hexTable['\n'] = -1; + hexTable['\t'] = -1; + + initialized = TRUE; +} + +/* + * read next hex value in the input stream, return -1 if EOF + */ +static int NextInt ( FILE *fstream ) +{ + int ch; + int value = 0; + int gotone = 0; + int done = 0; + + /* loop, accumulate hex value until find delimiter */ + /* skip any initial delimiters found in read stream */ + + while (!done) { + ch = getc(fstream); + if (ch == EOF) { + value = -1; + done++; + } else { + /* trim high bits, check type and accumulate */ + ch &= 0xff; + if (isascii(ch) && isxdigit(ch)) { + value = (value << 4) + hexTable[ch]; + gotone++; + } else if ((hexTable[ch]) < 0 && gotone) + done++; + } + } + return value; +} + +int read_bitmap_data (fstream, width, height, datap, x_hot, y_hot) + FILE *fstream; /* handle on file */ + unsigned int *width, *height; /* RETURNED */ + unsigned char **datap; /* RETURNED */ + int *x_hot, *y_hot; /* RETURNED */ +{ + unsigned char *data = NULL; /* working variable */ + char line[MAX_SIZE]; /* input line from file */ + int size; /* number of bytes of data */ + char name_and_type[MAX_SIZE]; /* an input line */ + char *type; /* for parsing */ + int value; /* from an input line */ + int version10p; /* boolean, old format */ + int padding; /* to handle alignment */ + int bytes_per_line; /* per scanline of data */ + unsigned int ww = 0; /* width */ + unsigned int hh = 0; /* height */ + int hx = -1; /* x hotspot */ + int hy = -1; /* y hotspot */ + +#define Xmalloc(size) malloc(size) + + /* first time initialization */ + if (initialized == FALSE) initHexTable(); + + /* error cleanup and return macro */ +#define RETURN(code) { if (data) free (data); return code; } + + while (fgets(line, MAX_SIZE, fstream)) { + if (strlen(line) == MAX_SIZE-1) { + RETURN (BitmapFileInvalid); + } + if (sscanf(line,"#define %s %d",name_and_type,&value) == 2) { + if (!(type = strrchr(name_and_type, '_'))) + type = name_and_type; + else + type++; + + if (!strcmp("width", type)) + ww = (unsigned int) value; + if (!strcmp("height", type)) + hh = (unsigned int) value; + if (!strcmp("hot", type)) { + if (type-- == name_and_type || type-- == name_and_type) + continue; + if (!strcmp("x_hot", type)) + hx = value; + if (!strcmp("y_hot", type)) + hy = value; + } + continue; + } + + if (sscanf(line, "static short %s = {", name_and_type) == 1) + version10p = 1; + else if (sscanf(line,"static unsigned char %s = {",name_and_type) == 1) + version10p = 0; + else if (sscanf(line, "static char %s = {", name_and_type) == 1) + version10p = 0; + else + continue; + + if (!(type = strrchr(name_and_type, '_'))) + type = name_and_type; + else + type++; + + if (strcmp("bits[]", type)) + continue; + + if (!ww || !hh) + RETURN (BitmapFileInvalid); + + if ((ww % 16) && ((ww % 16) < 9) && version10p) + padding = 1; + else + padding = 0; + + bytes_per_line = (ww+7)/8 + padding; + + size = bytes_per_line * hh; + data = (unsigned char *) Xmalloc ((unsigned int) size); + if (!data) + RETURN (BitmapNoMemory); + + if (version10p) { + unsigned char *ptr; + int bytes; + + for (bytes=0, ptr=data; bytes> 8; + } + } else { + unsigned char *ptr; + int bytes; + + for (bytes=0, ptr=data; bytes +/* #### Should remove all this X specific stuff when GTK/GDK matures a + bit more and provides an abstraction for it. */ +static int +gtk_colorize_image_instance (Lisp_Object image_instance, + Lisp_Object foreground, Lisp_Object background) +{ + struct Lisp_Image_Instance *p; + + p = XIMAGE_INSTANCE (image_instance); + + switch (IMAGE_INSTANCE_TYPE (p)) + { + case IMAGE_MONO_PIXMAP: + IMAGE_INSTANCE_TYPE (p) = IMAGE_COLOR_PIXMAP; + /* Make sure there aren't two pointers to the same mask, causing + it to get freed twice. */ + IMAGE_INSTANCE_GTK_MASK (p) = 0; + break; + + default: + return 0; + } + + { + GdkWindow *draw = GET_GTK_WIDGET_WINDOW (DEVICE_GTK_APP_SHELL (XDEVICE (IMAGE_INSTANCE_DEVICE (p)))); + GdkPixmap *new_pxmp = gdk_pixmap_new (draw, + IMAGE_INSTANCE_PIXMAP_WIDTH (p), + IMAGE_INSTANCE_PIXMAP_HEIGHT (p), + DEVICE_GTK_DEPTH (XDEVICE (IMAGE_INSTANCE_DEVICE (p)))); + GdkGCValues gcv; + GdkGC *gc; + + gcv.foreground = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (foreground)); + gcv.background = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (background)); + gc = gdk_gc_new_with_values (new_pxmp, &gcv, GDK_GC_BACKGROUND | GDK_GC_FOREGROUND); + + XCopyPlane (GDK_WINDOW_XDISPLAY (draw), + GDK_WINDOW_XWINDOW (IMAGE_INSTANCE_GTK_PIXMAP (p)), + GDK_WINDOW_XWINDOW (new_pxmp), + GDK_GC_XGC (gc), 0, 0, + IMAGE_INSTANCE_PIXMAP_WIDTH (p), + IMAGE_INSTANCE_PIXMAP_HEIGHT (p), + 0, 0, 1); + + gdk_gc_destroy (gc); + IMAGE_INSTANCE_GTK_PIXMAP (p) = new_pxmp; + IMAGE_INSTANCE_PIXMAP_DEPTH (p) = DEVICE_GTK_DEPTH (XDEVICE (IMAGE_INSTANCE_DEVICE (p))); + IMAGE_INSTANCE_PIXMAP_FG (p) = foreground; + IMAGE_INSTANCE_PIXMAP_BG (p) = background; + return 1; + } +} + diff --git a/src/glyphs-gtk.h b/src/glyphs-gtk.h new file mode 100644 index 0000000..0a99770 --- /dev/null +++ b/src/glyphs-gtk.h @@ -0,0 +1,157 @@ +/* Gtk-specific glyphs and related. + Copyright (C) 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995, 1996 Ben Wing + Copyright (C) 1995 Sun Microsystems, Inc. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ +/* Gtk version by William Perry */ + +#ifndef _XEMACS_GLYPHS_GTK_H_ +#define _XEMACS_GLYPHS_GTK_H_ + +#include "glyphs.h" + +#ifdef HAVE_GTK + +#include + +/**************************************************************************** + * Image-Instance Object * + ****************************************************************************/ + +struct gtk_image_instance_data +{ + GdkPixmap **pixmaps; + GdkPixmap *mask; + GdkCursor *cursor; + + /* If depth>0, then that means that other colors were allocated when + this pixmap was loaded. These are they; we need to free them when + finalizing the image instance. */ + GdkColormap *colormap; + unsigned long *pixels; + int npixels; + + /* Should we hang on to the extra info from the XpmAttributes, like + the textual color table and the comments? Is that useful? */ +}; + +struct gtk_subwindow_data +{ + union + { + struct + { + GtkWidget *parent_window; + GtkWidget *clip_window; + } sub; + struct + { + GtkWidget *clip_window; + Lisp_Object widget; + guint x_offset; + guint y_offset; + gboolean added_to_fixed; + } wid; + } data; +}; + +void init_image_instance_from_gdk_pixmap (struct Lisp_Image_Instance *ii, + struct device *device, + GdkPixmap *gdk_pixmap, + int dest_mask, + Lisp_Object instantiator); + +#define GTK_IMAGE_INSTANCE_DATA(i) ((struct gtk_image_instance_data *) (i)->data) + +#define IMAGE_INSTANCE_GTK_PIXMAP(i) (GTK_IMAGE_INSTANCE_DATA (i)->pixmaps[0]) +#define IMAGE_INSTANCE_GTK_PIXMAP_SLICE(i,slice) \ + (GTK_IMAGE_INSTANCE_DATA (i)->pixmaps[slice]) +#define IMAGE_INSTANCE_GTK_PIXMAP_SLICES(i) \ + (GTK_IMAGE_INSTANCE_DATA (i)->pixmaps) +#define IMAGE_INSTANCE_GTK_MASK(i) (GTK_IMAGE_INSTANCE_DATA (i)->mask) +#define IMAGE_INSTANCE_GTK_CURSOR(i) (GTK_IMAGE_INSTANCE_DATA (i)->cursor) +#define IMAGE_INSTANCE_GTK_COLORMAP(i) (GTK_IMAGE_INSTANCE_DATA (i)->colormap) +#define IMAGE_INSTANCE_GTK_PIXELS(i) (GTK_IMAGE_INSTANCE_DATA (i)->pixels) +#define IMAGE_INSTANCE_GTK_NPIXELS(i) (GTK_IMAGE_INSTANCE_DATA (i)->npixels) + +#define XIMAGE_INSTANCE_GTK_PIXMAP(i) \ + IMAGE_INSTANCE_GTK_PIXMAP (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_PIXMAP_SLICE(i) \ + IMAGE_INSTANCE_GTK_PIXMAP_SLICE (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_PIXMAP_SLICES(i) \ + IMAGE_INSTANCE_GTK_PIXMAP_SLICES (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_MASK(i) \ + IMAGE_INSTANCE_GTK_MASK (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_CURSOR(i) \ + IMAGE_INSTANCE_GTK_CURSOR (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_PIXELS(i) \ + IMAGE_INSTANCE_GTK_PIXELS (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_NPIXELS(i) \ + IMAGE_INSTANCE_GTK_NPIXELS (XIMAGE_INSTANCE (i)) + +/* Subwindow / widget stuff */ +#define GTK_SUBWINDOW_INSTANCE_DATA(i) ((struct gtk_subwindow_data *) (i)->data) + +#define IMAGE_INSTANCE_GTK_SUBWINDOW_PARENT(i) \ + (GTK_SUBWINDOW_INSTANCE_DATA (i)->data.sub.parent_window) +#define IMAGE_INSTANCE_GTK_CLIPWINDOW(i) \ + (GTK_SUBWINDOW_INSTANCE_DATA (i)->data.sub.clip_window) +#define IMAGE_INSTANCE_GTK_WIDGET_XOFFSET(i) \ + (GTK_SUBWINDOW_INSTANCE_DATA (i)->data.wid.x_offset) +#define IMAGE_INSTANCE_GTK_WIDGET_YOFFSET(i) \ + (GTK_SUBWINDOW_INSTANCE_DATA (i)->data.wid.y_offset) +#define IMAGE_INSTANCE_GTK_WIDGET_LWID(i) \ + (GTK_SUBWINDOW_INSTANCE_DATA (i)->data.wid.id) +#define IMAGE_INSTANCE_GTK_CLIPWIDGET(i) \ + (GTK_SUBWINDOW_INSTANCE_DATA (i)->data.wid.clip_window) +#define IMAGE_INSTANCE_GTK_ALREADY_PUT(i) \ + (GTK_SUBWINDOW_INSTANCE_DATA (i)->data.wid.added_to_fixed) +#define IMAGE_INSTANCE_GTK_SUBWINDOW_ID(i) \ + ((GdkWindow *) & IMAGE_INSTANCE_SUBWINDOW_ID (i)) +#define IMAGE_INSTANCE_GTK_WIDGET_ID(i) \ + ((GtkWidget *) & IMAGE_INSTANCE_SUBWINDOW_ID (i)) + +#define XIMAGE_INSTANCE_GTK_SUBWINDOW_PARENT(i) \ + IMAGE_INSTANCE_GTK_SUBWINDOW_PARENT (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_SUBWINDOW_DISPLAY(i) \ + IMAGE_INSTANCE_GTK_SUBWINDOW_DISPLAY (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_WIDGET_XOFFSET(i) \ + IMAGE_INSTANCE_GTK_WIDGET_XOFFSET (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_WIDGET_YOFFSET(i) \ + IMAGE_INSTANCE_GTK_WIDGET_YOFFSET (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_WIDGET_LWID(i) \ + IMAGE_INSTANCE_GTK_WIDGET_LWID (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_CLIPWIDGET(i) \ + IMAGE_INSTANCE_GTK_CLIPWIDGET (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_CLIPWINDOW(i) \ + IMAGE_INSTANCE_GTK_CLIPWINDOW (XIMAGE_INSTANCE (i)) +#define XIMAGE_INSTANCE_GTK_WIDGET_ID(i) \ + IMAGE_INSTANCE_GTK_WIDGET_ID (XIMAGE_INSTANCE (i)) + +#define DOMAIN_GTK_WIDGET(domain) \ + ((IMAGE_INSTANCEP (domain) && \ + GTK_SUBWINDOW_INSTANCE_DATA (XIMAGE_INSTANCE (domain))) ? \ + XIMAGE_INSTANCE_GTK_WIDGET_ID (domain) : \ + FRAME_GTK_CONTAINER_WIDGET (f) (DOMAIN_XFRAME (domain))) + +#endif /* HAVE_GTK */ +#endif /* _XEMACS_GLYPHS_GTK_H_ */ diff --git a/src/gtk-glue.c b/src/gtk-glue.c new file mode 100644 index 0000000..66cc549 --- /dev/null +++ b/src/gtk-glue.c @@ -0,0 +1,265 @@ +GtkType GTK_TYPE_ARRAY = 0; +GtkType GTK_TYPE_STRING_ARRAY = 0; +GtkType GTK_TYPE_FLOAT_ARRAY = 0; +GtkType GTK_TYPE_INT_ARRAY = 0; +GtkType GTK_TYPE_LISTOF = 0; +GtkType GTK_TYPE_STRING_LIST = 0; +GtkType GTK_TYPE_OBJECT_LIST = 0; +GtkType GTK_TYPE_GDK_GC = 0; + +static GtkType +xemacs_type_register (gchar *name, GtkType parent) +{ + GtkType type_id; + GtkTypeInfo info; + + info.type_name = name; + info.object_size = 0; + info.class_size = 0; + info.class_init_func = NULL; + info.object_init_func = NULL; + info.reserved_1 = NULL; + info.reserved_2 = NULL; + + type_id = gtk_type_unique (parent, &info); + + return (type_id); +} + +static void +xemacs_init_gtk_classes (void) +{ + if (!GTK_TYPE_ARRAY) + { + GTK_TYPE_ARRAY = xemacs_type_register ("GtkArrayOf", 0); + GTK_TYPE_STRING_ARRAY = xemacs_type_register ("GtkArrayOfString", GTK_TYPE_ARRAY); + GTK_TYPE_FLOAT_ARRAY = xemacs_type_register ("GtkArrayOfFloat", GTK_TYPE_ARRAY); + GTK_TYPE_INT_ARRAY = xemacs_type_register ("GtkArrayOfInteger", GTK_TYPE_ARRAY); + GTK_TYPE_LISTOF = xemacs_type_register ("GtkListOf", 0); + GTK_TYPE_STRING_LIST = xemacs_type_register ("GtkListOfString", GTK_TYPE_LISTOF); + GTK_TYPE_OBJECT_LIST = xemacs_type_register ("GtkListOfObject", GTK_TYPE_LISTOF); + GTK_TYPE_GDK_GC = xemacs_type_register ("GdkGC", GTK_TYPE_BOXED); + } +} + +static void +xemacs_list_to_gtklist (Lisp_Object obj, GtkArg *arg) +{ + CHECK_LIST (obj); + + if (arg->type == GTK_TYPE_STRING_LIST) + { + Lisp_Object temp = obj; + GList *strings = NULL; + + while (!NILP (temp)) + { + CHECK_STRING (XCAR (temp)); + temp = XCDR (temp); + } + + temp = obj; + + while (!NILP (temp)) + { + strings = g_list_append (strings, XSTRING_DATA (XCAR (temp))); + temp = XCDR (temp); + } + + GTK_VALUE_POINTER(*arg) = strings; + } + else if (arg->type == GTK_TYPE_OBJECT_LIST) + { + Lisp_Object temp = obj; + GList *objects = NULL; + + while (!NILP (temp)) + { + CHECK_GTK_OBJECT (XCAR (temp)); + temp = XCDR (temp); + } + + temp = obj; + + while (!NILP (temp)) + { + objects = g_list_append (objects, XGTK_OBJECT (XCAR (temp))->object); + temp = XCDR (temp); + } + + GTK_VALUE_POINTER(*arg) = objects; + } + else + { + abort(); + } +} + +static void +__make_gtk_object_mapper (gpointer data, gpointer user_data) +{ + Lisp_Object *rv = (Lisp_Object *) user_data; + + *rv = Fcons (build_gtk_object (GTK_OBJECT (data)), *rv); +} + +static void +__make_string_mapper (gpointer data, gpointer user_data) +{ + Lisp_Object *rv = (Lisp_Object *) user_data; + + *rv = Fcons (build_string ((char *)data), *rv); +} + +static Lisp_Object +xemacs_gtklist_to_list (GtkArg *arg) +{ + Lisp_Object rval = Qnil; + + if (GTK_VALUE_POINTER (*arg)) + { + if (arg->type == GTK_TYPE_STRING_LIST) + { + g_list_foreach (GTK_VALUE_POINTER (*arg), __make_string_mapper, &rval); + } + else if (arg->type == GTK_TYPE_OBJECT_LIST) + { + g_list_foreach (GTK_VALUE_POINTER (*arg), __make_gtk_object_mapper, &rval); + } + else + { + abort(); + } + } + return (rval); +} + +static void +xemacs_list_to_array (Lisp_Object obj, GtkArg *arg) +{ + CHECK_LIST (obj); + +#define FROB(ret_type,check_fn,extract_fn) \ + do { \ + Lisp_Object temp = obj; \ + int length = 0; \ + ret_type *array = NULL; \ + \ + while (!NILP (temp)) \ + { \ + check_fn (XCAR (temp)); \ + length++; \ + temp = XCDR (temp); \ + } \ + \ + array = xnew_array_and_zero (ret_type, length + 2); \ + temp = obj; \ + length = 0; \ + \ + while (!NILP (temp)) \ + { \ + array[length++] = extract_fn (XCAR (temp)); \ + temp = XCDR (temp); \ + } \ + \ + GTK_VALUE_POINTER(*arg) = array; \ + } while (0); + + if (arg->type == GTK_TYPE_STRING_ARRAY) + { + FROB(gchar *, CHECK_STRING, XSTRING_DATA); + } + else if (arg->type == GTK_TYPE_FLOAT_ARRAY) + { + FROB(gfloat, CHECK_FLOAT, extract_float); + } + else if (arg->type == GTK_TYPE_INT_ARRAY) + { + FROB(gint, CHECK_INT, XINT); + } + else + { + abort(); + } +#undef FROB +} + +extern GdkGC *gtk_get_gc (struct device *d, Lisp_Object font, Lisp_Object fg, Lisp_Object bg, + Lisp_Object bg_pmap, Lisp_Object lwidth); + +static GdkGC * +face_to_gc (Lisp_Object face) +{ + Lisp_Object device = Fselected_device (Qnil); + + return (gtk_get_gc (XDEVICE (device), + Fspecifier_instance (Fget (face, Qfont, Qnil), device, Qnil, Qnil), + Fspecifier_instance (Fget (face, Qforeground, Qnil), device, Qnil, Qnil), + Fspecifier_instance (Fget (face, Qbackground, Qnil), device, Qnil, Qnil), + Fspecifier_instance (Fget (face, Qbackground_pixmap, Qnil), device, Qnil, Qnil), + Qnil)); +} + +static GtkStyle * +face_to_style (Lisp_Object face) +{ + Lisp_Object device = Fselected_device (Qnil); + GtkStyle *style = gtk_style_new (); + int i; + + Lisp_Object font = Fspecifier_instance (Fget (face, Qfont, Qnil), device, Qnil, Qnil); + Lisp_Object fg = Fspecifier_instance (Fget (face, Qforeground, Qnil), device, Qnil, Qnil); + Lisp_Object bg = Fspecifier_instance (Fget (face, Qbackground, Qnil), device, Qnil, Qnil); + Lisp_Object pm = Fspecifier_instance (Fget (face, Qbackground_pixmap, Qnil), device, Qnil, Qnil); + + for (i = 0; i < 5; i++) style->fg[i] = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (fg)); + for (i = 0; i < 5; i++) style->bg[i] = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (bg)); + + if (IMAGE_INSTANCEP (pm)) + { + for (i = 0; i < 5; i++) style->bg_pixmap[i] = XIMAGE_INSTANCE_GTK_PIXMAP (pm); + } + + style->font = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (font)); + + return (style); +} + +extern int gtk_event_to_emacs_event (struct frame *, GdkEvent *, struct Lisp_Event *); + +static Lisp_Object +gdk_event_to_emacs_event(GdkEvent *ev) +{ + Lisp_Object emacs_event = Qnil; + + if (ev) + { + emacs_event = Fmake_event (Qnil, Qnil); + if (!gtk_event_to_emacs_event (NULL, ev, XEVENT (emacs_event))) + { + /* We need to handle a few more cases than the normal event + ** loop does. Mainly the double/triple click events. + */ + if ((ev->type == GDK_2BUTTON_PRESS) || (ev->type == GDK_3BUTTON_PRESS)) + { + struct Lisp_Event *le = XEVENT (emacs_event); + + le->event_type = misc_user_event; + le->event.misc.button = ev->button.button; + le->event.misc.modifiers = 0; + le->event.misc.x = ev->button.x; + le->event.misc.y = ev->button.y; + if (ev->type == GDK_2BUTTON_PRESS) + le->event.misc.function = intern ("double-click"); + else + le->event.misc.function = intern ("triple-click"); + } + else + { + Fdeallocate_event (emacs_event); + emacs_event = Qnil; + } + } + } + return (emacs_event); +} diff --git a/src/gtk-xemacs.c b/src/gtk-xemacs.c new file mode 100644 index 0000000..15d15c0 --- /dev/null +++ b/src/gtk-xemacs.c @@ -0,0 +1,347 @@ +/* gtk-xemacs.c +** +** Description: A widget to encapsulate a XEmacs 'text widget' +** +** Created by: William M. Perry +** Copyright (c) 2000 William M. Perry +** +*/ + +#include + +#include "lisp.h" +#include "console-gtk.h" +#include "objects-gtk.h" +#include "gtk-xemacs.h" +#include "window.h" +#include "faces.h" + +extern Lisp_Object Vmodeline_face; +extern Lisp_Object Vscrollbar_on_left_p; + +EXFUN (Fmake_image_instance, 4); + +static void gtk_xemacs_class_init (GtkXEmacsClass *klass); +static void gtk_xemacs_init (GtkXEmacs *xemacs); +static void gtk_xemacs_size_allocate (GtkWidget *widget, GtkAllocation *allocaction); +static void gtk_xemacs_draw (GtkWidget *widget, GdkRectangle *area); +static void gtk_xemacs_paint (GtkWidget *widget, GdkRectangle *area); +static void gtk_xemacs_size_request (GtkWidget *widget, GtkRequisition *requisition); +static void gtk_xemacs_realize (GtkWidget *widget); +static void gtk_xemacs_style_set (GtkWidget *widget, GtkStyle *previous_style); +static gint gtk_xemacs_expose (GtkWidget *widget, GdkEventExpose *event); + +guint +gtk_xemacs_get_type (void) +{ + static guint xemacs_type = 0; + + if (!xemacs_type) + { + static const GtkTypeInfo xemacs_info = + { + "GtkXEmacs", + sizeof (GtkXEmacs), + sizeof (GtkXEmacsClass), + (GtkClassInitFunc) gtk_xemacs_class_init, + (GtkObjectInitFunc) gtk_xemacs_init, + /* reserved_1 */ NULL, + /* reserved_2 */ NULL, + (GtkClassInitFunc) NULL, + }; + + xemacs_type = gtk_type_unique (gtk_fixed_get_type (), &xemacs_info); + } + + return xemacs_type; +} + +static GtkWidgetClass *parent_class; + +extern gint emacs_gtk_button_event_handler(GtkWidget *widget, GdkEventButton *event); +extern gint emacs_gtk_key_event_handler(GtkWidget *widget, GdkEventKey *event); +extern gint emacs_gtk_motion_event_handler(GtkWidget *widget, GdkEventMotion *event); + +static void +gtk_xemacs_class_init (GtkXEmacsClass *class) +{ + GtkWidgetClass *widget_class; + + widget_class = (GtkWidgetClass*) class; + parent_class = (GtkWidgetClass *) gtk_type_class (gtk_fixed_get_type ()); + + widget_class->size_allocate = gtk_xemacs_size_allocate; + widget_class->size_request = gtk_xemacs_size_request; + widget_class->draw = gtk_xemacs_draw; + widget_class->expose_event = gtk_xemacs_expose; + widget_class->realize = gtk_xemacs_realize; + widget_class->button_press_event = emacs_gtk_button_event_handler; + widget_class->button_release_event = emacs_gtk_button_event_handler; + widget_class->key_press_event = emacs_gtk_key_event_handler; + widget_class->key_release_event = emacs_gtk_key_event_handler; + widget_class->motion_notify_event = emacs_gtk_motion_event_handler; + widget_class->style_set = gtk_xemacs_style_set; +} + +static void +gtk_xemacs_init (GtkXEmacs *xemacs) +{ + GTK_WIDGET_SET_FLAGS (xemacs, GTK_CAN_FOCUS); +} + +GtkWidget* +gtk_xemacs_new (struct frame *f) +{ + GtkXEmacs *xemacs; + + xemacs = gtk_type_new (gtk_xemacs_get_type ()); + xemacs->f = f; + + return GTK_WIDGET (xemacs); +} + +static void +__nuke_background_items (GtkWidget *widget) +{ + /* This bit of voodoo is here to get around the annoying flicker + when GDK tries to futz with our background pixmap as well as + XEmacs doing it + + We do NOT set the background of this widget window, that way + there is NO flickering, etc. The downside is the XEmacs frame + appears as 'seethru' when XEmacs is too busy to redraw the + frame. + + Well, wait, we do... otherwise there sre weird 'seethru' areas + even when XEmacs does a full redisplay. Most noticable in some + areas of the modeline, or in the right-hand-side of the window + between the scrollbar ad n the edge of the window. + */ + if (widget->window) + { + gdk_window_set_back_pixmap (widget->window, NULL, 0); + gdk_window_set_back_pixmap (widget->parent->window, NULL, 0); + gdk_window_set_background (widget->parent->window, + &widget->style->bg[GTK_STATE_NORMAL]); + gdk_window_set_background (widget->window, + &widget->style->bg[GTK_STATE_NORMAL]); + } +} + +extern Lisp_Object xemacs_gtk_convert_color(GdkColor *c, GtkWidget *w); + +/* From objects-gtk.c */ +extern Lisp_Object __get_gtk_font_truename (GdkFont *gdk_font, int expandp); + +#define convert_font(f) __get_gtk_font_truename (f, 0) + +static void +smash_face_fallbacks (struct frame *f, GtkStyle *style) +{ +#define FROB(face,prop,slot) do { \ + Lisp_Object fallback = Qnil; \ + Lisp_Object specifier = Fget (face, prop, Qnil); \ + struct Lisp_Specifier *sp = NULL; \ + if (NILP (specifier)) continue; \ + sp = XSPECIFIER (specifier); \ + fallback = sp->fallback; \ + if (EQ (Fcar (Fcar (Fcar (fallback))), Qgtk)) \ + fallback = XCDR (fallback); \ + if (! NILP (slot)) \ + fallback = acons (list1 (Qgtk), \ + slot, \ + fallback); \ + set_specifier_fallback (specifier, fallback); \ + } while (0); +#define FROB_FACE(face,fg_slot,bg_slot) \ +do { \ + FROB (face, Qforeground, xemacs_gtk_convert_color (&style->fg_slot[GTK_STATE_NORMAL], FRAME_GTK_SHELL_WIDGET (f))); \ + FROB (face, Qbackground, xemacs_gtk_convert_color (&style->bg_slot[GTK_STATE_NORMAL], FRAME_GTK_SHELL_WIDGET (f))); \ + if (style->rc_style && style->rc_style->bg_pixmap_name[GTK_STATE_NORMAL]) \ + { \ + FROB (Vdefault_face, Qbackground_pixmap, \ + Fmake_image_instance (build_string (style->rc_style->bg_pixmap_name[GTK_STATE_NORMAL]), \ + f->device, Qnil, make_int (5))); \ + } \ + else \ + { \ + FROB (Vdefault_face, Qbackground_pixmap, Qnil); \ + } \ +} while (0) + + FROB (Vdefault_face, Qfont, convert_font (style->font)); + FROB_FACE (Vdefault_face, fg, bg); + FROB_FACE (Vgui_element_face, text, mid); + +#undef FROB +#undef FROB_FACE +} + +#ifdef HAVE_SCROLLBARS +static void +smash_scrollbar_specifiers (struct frame *f, GtkStyle *style) +{ + Lisp_Object frame; + int slider_size = 0; + int hsize, vsize; + GtkRangeClass *klass; + + XSETFRAME (frame, f); + + klass = (GtkRangeClass *) gtk_type_class (GTK_TYPE_SCROLLBAR); + slider_size = klass->slider_width; + hsize = slider_size + (style->klass->ythickness * 2); + vsize = slider_size + (style->klass->xthickness * 2); + + style = gtk_style_attach (style, + GTK_WIDGET (DEVICE_GTK_APP_SHELL (XDEVICE (FRAME_DEVICE (f))))->window); + + Fadd_spec_to_specifier (Vscrollbar_width, make_int (vsize), frame, Qnil, Qnil); + Fadd_spec_to_specifier (Vscrollbar_height, make_int (hsize), frame, Qnil, Qnil); +} +#else +#define smash_scrollbar_specifiers(x,y) +#endif /* HAVE_SCROLLBARS */ + +static void +gtk_xemacs_realize (GtkWidget *widget) +{ + parent_class->realize (widget); + gtk_xemacs_style_set (widget, gtk_widget_get_style (widget)); +} + +static void +gtk_xemacs_style_set (GtkWidget *widget, GtkStyle *previous_style) +{ + GtkStyle *new_style = gtk_widget_get_style (widget); + GtkXEmacs *x = GTK_XEMACS (widget); + + parent_class->style_set (widget, previous_style); + + if (x->f) + { + __nuke_background_items (widget); +#if 0 + smash_face_fallbacks (x->f, new_style); +#endif + smash_scrollbar_specifiers (x->f, new_style); + } +} + +static void +gtk_xemacs_size_request (GtkWidget *widget, GtkRequisition *requisition) +{ + GtkXEmacs *x = GTK_XEMACS (widget); + struct frame *f = GTK_XEMACS_FRAME (x); + int width, height; + + if (f) + { + char_to_pixel_size (f, FRAME_WIDTH (f), FRAME_HEIGHT (f), + &width, &height); + requisition->width = width; + requisition->height = height; + } + else + { + parent_class->size_request (widget, requisition); + } +} + +static void +gtk_xemacs_size_allocate (GtkWidget *widget, GtkAllocation *allocation) +{ + GtkXEmacs *x = GTK_XEMACS (widget); + struct frame *f = GTK_XEMACS_FRAME (x); + int columns, rows; + + parent_class->size_allocate(widget, allocation); + + if (f) + { + f->pixwidth = allocation->width; + f->pixheight = allocation->height; + + pixel_to_char_size (f, + allocation->width, + allocation->height, &columns, &rows); + + change_frame_size (f, rows, columns, 1); + } +} + +static void +gtk_xemacs_paint (GtkWidget *widget, GdkRectangle *area) +{ + GtkXEmacs *x = GTK_XEMACS (widget); + struct frame *f = GTK_XEMACS_FRAME (x); + gtk_redraw_exposed_area (f, area->x, area->y, area->width, area->height); +} + +static void +gtk_xemacs_draw (GtkWidget *widget, GdkRectangle *area) +{ + GtkFixed *fixed = GTK_FIXED (widget); + GtkFixedChild *child; + GdkRectangle child_area; + GList *children; + + /* I need to manually iterate over the children instead of just + chaining to parent_class->draw() because it calls + gtk_fixed_paint() directly, which clears the background window, + which causes A LOT of flashing. */ + + gtk_xemacs_paint (widget, area); + + children = fixed->children; + + while (children) + { + child = children->data; + children = children->next; + /* #### This is what causes the scrollbar flickering! + Evidently the scrollbars pretty much take care of drawing + themselves in most cases. Then we come along and tell them + to redraw again! + + But if we just leave it out, then they do not get drawn + correctly the first time! + + Scrollbar flickering has been greatly helped by the + optimizations in scrollbar-gtk.c / + gtk_update_scrollbar_instance_status (), so this is not that + big a deal anymore. + */ + if (gtk_widget_intersect (child->widget, area, &child_area)) + { + gtk_widget_draw (child->widget, &child_area); + } + } +} + +static gint +gtk_xemacs_expose (GtkWidget *widget, GdkEventExpose *event) +{ + GtkXEmacs *x = GTK_XEMACS (widget); + struct frame *f = GTK_XEMACS_FRAME (x); + GdkRectangle *a = &event->area; + + /* This takes care of drawing the scrollbars, etc */ + parent_class->expose_event (widget, event); + + /* Now draw the actual frame data */ + if (!check_for_ignored_expose (f, a->x, a->y, a->width, a->height) && + !find_matching_subwindow (f, a->x, a->y, a->width, a->height)) + gtk_redraw_exposed_area (f, a->x, a->y, a->width, a->height); + return (TRUE); +} + +Lisp_Object +xemacs_gtk_convert_color(GdkColor *c, GtkWidget *w) +{ + char color_buf[255]; + + sprintf (color_buf, "#%04x%04x%04x", c->red, c->green, c->blue); + + return (build_string (color_buf)); +} diff --git a/src/gtk-xemacs.h b/src/gtk-xemacs.h new file mode 100644 index 0000000..5357f0c --- /dev/null +++ b/src/gtk-xemacs.h @@ -0,0 +1,48 @@ +/* gtk-xemacs.h +** +** Description: A widget to encapsulate a XEmacs 'text widget' +** +** Created by: William M. Perry +** Copyright (c) 2000 William M. Perry +** +*/ + +#ifndef __GTK_XEMACS_H__ +#define __GTK_XEMACS_H__ + +#include +#include "frame.h" +#include +#include + +#ifdef __cplusplus +extern "C" { +#endif /* __cplusplus */ + +#define GTK_XEMACS(obj) GTK_CHECK_CAST (obj, gtk_xemacs_get_type (), GtkXEmacs) +#define GTK_XEMACS_CLASS(klass) GTK_CHECK_CLASS_CAST (klass, gtk_xemacs_get_type (), GtkXEmacsClass) +#define GTK_IS_XEMACS(obj) GTK_CHECK_TYPE (obj, gtk_xemacs_get_type ()) +#define GTK_XEMACS_FRAME(obj) GTK_XEMACS (obj)->f + + typedef struct _GtkXEmacs GtkXEmacs; + typedef struct _GtkXEmacsClass GtkXEmacsClass; + + struct _GtkXEmacs + { + GtkFixed fixed; + struct frame *f; + }; + + struct _GtkXEmacsClass + { + GtkFixedClass parent_class; + }; + + guint gtk_xemacs_get_type (void); + GtkWidget *gtk_xemacs_new (struct frame *f); + +#ifdef __cplusplus +} +#endif /* __cplusplus */ + +#endif /* __GTK_XEMACS_H__ */ diff --git a/src/gui-gtk.c b/src/gui-gtk.c new file mode 100644 index 0000000..d772eae --- /dev/null +++ b/src/gui-gtk.c @@ -0,0 +1,108 @@ +/* General GUI code -- X-specific. (menubars, scrollbars, toolbars, dialogs) + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995, 1996 Ben Wing. + Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 1998 Free Software Foundation, Inc. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "gui-gtk.h" +#include "buffer.h" +#include "device.h" +#include "frame.h" +#include "gui.h" +#include "opaque.h" + +#ifdef HAVE_POPUPS +Lisp_Object Qmenu_no_selection_hook; +#endif + +static GUI_ID gui_id_ctr = 0; + +GUI_ID +new_gui_id (void) +{ + return (++gui_id_ctr); +} + +/* This is like FRAME_MENUBAR_DATA (f), but contains an alist of + (id . popup-data) for GCPRO'ing the callbacks of the popup menus + and dialog boxes. */ +static Lisp_Object Vpopup_callbacks; + +void +gcpro_popup_callbacks (GUI_ID id, Lisp_Object data) +{ + Vpopup_callbacks = Fcons (Fcons (make_int (id), data), Vpopup_callbacks); +} + +void +ungcpro_popup_callbacks (GUI_ID id) +{ + Lisp_Object lid = make_int (id); + Lisp_Object this = assq_no_quit (lid, Vpopup_callbacks); + Vpopup_callbacks = delq_no_quit (this, Vpopup_callbacks); +} + +Lisp_Object +get_gcpro_popup_callbacks (GUI_ID id) +{ + Lisp_Object lid = make_int (id); + Lisp_Object this = assq_no_quit (lid, Vpopup_callbacks); + + if (!NILP (this)) + { + return (XCDR (this)); + } + return (Qnil); +} + +void +syms_of_gui_gtk (void) +{ +#ifdef HAVE_POPUPS + defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook"); +#endif +} + +void +vars_of_gui_gtk (void) +{ + staticpro (&Vpopup_callbacks); + Vpopup_callbacks = Qnil; +#ifdef HAVE_POPUPS + popup_up_p = 0; + +#if 0 + /* This DEFVAR_LISP is just for the benefit of make-docfile. */ + /* #### misnamed */ + DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /* +Function or functions to call when a menu or dialog box is dismissed +without a selection having been made. +*/ ); +#endif + + Fset (Qmenu_no_selection_hook, Qnil); +#endif /* HAVE_POPUPS */ +} diff --git a/src/gui-gtk.h b/src/gui-gtk.h new file mode 100644 index 0000000..9fb38eb --- /dev/null +++ b/src/gui-gtk.h @@ -0,0 +1,36 @@ +/* General GUI code -- X-specific header file. + Copyright (C) 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1996 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +#ifndef _XEMACS_GUI_GTK_H_ +#define _XEMACS_GUI_GTK_H_ + +#include + +typedef unsigned int GUI_ID; +extern GUI_ID new_gui_id (void); + +extern void gcpro_popup_callbacks (GUI_ID id, Lisp_Object data); +extern void ungcpro_popup_callbacks (GUI_ID id); +extern Lisp_Object get_gcpro_popup_callbacks (GUI_ID id); + +#endif /* _XEMACS_GUI_GTK_H_ */ diff --git a/src/menubar-gtk.c b/src/menubar-gtk.c new file mode 100644 index 0000000..8d2dac9 --- /dev/null +++ b/src/menubar-gtk.c @@ -0,0 +1,1305 @@ +/* Implements an elisp-programmable menubar -- X interface. + Copyright (C) 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1995 Tinker Systems and INS Engineering Corp. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* created 16-dec-91 by jwz */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "gui-gtk.h" + +#include "buffer.h" +#include "commands.h" /* zmacs_regions */ +#include "ui-gtk.h" +#include "gui.h" +#include "events.h" +#include "frame.h" +#include "opaque.h" +#include "window.h" + +#ifdef HAVE_GNOME +#include +#endif + +#define MENUBAR_TYPE 0 +#define SUBMENU_TYPE 1 +#define POPUP_TYPE 2 + +static GtkWidget *menu_descriptor_to_widget_1 (Lisp_Object descr); + +#define FRAME_MENUBAR_DATA(frame) ((frame)->menubar_data) +#define XFRAME_MENUBAR_DATA_LASTBUFF(frame) (XCAR ((frame)->menubar_data)) +#define XFRAME_MENUBAR_DATA_UPTODATE(frame) (XCDR ((frame)->menubar_data)) + + +/* This is a bogus subclass of GtkMenuBar so that the menu never tries +** to be bigger than the text widget. This prevents weird resizing +** when jumping around between buffers with radically different menu +** sizes. +*/ + +#define GTK_XEMACS_MENUBAR(obj) GTK_CHECK_CAST (obj, gtk_xemacs_menubar_get_type (), GtkXEmacsMenubar) +#define GTK_XEMACS_MENUBAR_CLASS(klass) GTK_CHECK_CLASS_CAST (klass, gtk_xemacs_menubar_get_type (), GtkXEmacsMenubarClass) +#define GTK_IS_XEMACS_MENUBAR(obj) GTK_CHECK_TYPE (obj, gtk_xemacs_menubar_get_type ()) +#define GTK_XEMACS_MENUBAR_FRAME(obj) GTK_XEMACS_MENUBAR (obj)->f + +typedef struct _GtkXEmacsMenubar GtkXEmacsMenubar; +typedef struct _GtkXEmacsMenubarClass GtkXEmacsMenubarClass; + +struct _GtkXEmacsMenubar +{ + GtkMenuBar menu; + struct frame *frame; +}; + +struct _GtkXEmacsMenubarClass +{ + GtkMenuBarClass parent_class; +}; + +guint gtk_xemacs_menubar_get_type (void); +GtkWidget *gtk_xemacs_menubar_new (struct frame *f); + +static void gtk_xemacs_menubar_class_init (GtkXEmacsMenubarClass *klass); +static void gtk_xemacs_menubar_init (GtkXEmacsMenubar *xemacs); +static void gtk_xemacs_menubar_size_request (GtkWidget *widget, GtkRequisition *requisition); + +guint +gtk_xemacs_menubar_get_type (void) +{ + static guint xemacs_menubar_type; + + if (!xemacs_menubar_type) + { + static const GtkTypeInfo xemacs_menubar_info = + { + "GtkXEmacsMenubar", + sizeof (GtkXEmacsMenubar), + sizeof (GtkXEmacsMenubarClass), + (GtkClassInitFunc) gtk_xemacs_menubar_class_init, + (GtkObjectInitFunc) gtk_xemacs_menubar_init, + /* reserved_1 */ NULL, + /* reserved_2 */ NULL, + (GtkClassInitFunc) NULL, + }; + + xemacs_menubar_type = gtk_type_unique (gtk_menu_bar_get_type (), &xemacs_menubar_info); + } + + return xemacs_menubar_type; +} + +static GtkWidgetClass *parent_class; + +static void gtk_xemacs_menubar_class_init (GtkXEmacsMenubarClass *klass) +{ + GtkWidgetClass *widget_class; + + widget_class = (GtkWidgetClass*) klass; + parent_class = (GtkWidgetClass *) gtk_type_class (gtk_menu_bar_get_type ()); + + widget_class->size_request = gtk_xemacs_menubar_size_request; +} + +static void gtk_xemacs_menubar_init (GtkXEmacsMenubar *xemacs) +{ +} + +static void gtk_xemacs_menubar_size_request (GtkWidget *widget, GtkRequisition *requisition) +{ + GtkXEmacsMenubar *x = GTK_XEMACS_MENUBAR (widget); + GtkRequisition frame_size; + + parent_class->size_request (widget, requisition); + + /* #### BILL! + ** We should really only do this if the menu has not been detached! + ** + ** WMP 9/9/2000 + */ + + gtk_widget_size_request (FRAME_GTK_TEXT_WIDGET (x->frame), &frame_size); + + requisition->width = frame_size.width; +} + +GtkWidget * +gtk_xemacs_menubar_new (struct frame *f) +{ + GtkXEmacsMenubar *menubar = gtk_type_new (gtk_xemacs_menubar_get_type ()); + + menubar->frame = f; + + return (GTK_WIDGET (menubar)); +} + +/* We now return you to your regularly scheduled menus... */ + +int dockable_menubar; + +/* #define TEAR_OFF_MENUS */ + +#ifdef TEAR_OFF_MENUS +int tear_off_menus; +#endif + + +/* Converting from XEmacs to GTK representation */ +static Lisp_Object +menu_name_to_accelerator (char *name) +{ + while (*name) { + if (*name=='%') { + ++name; + if (!(*name)) + return Qnil; + if (*name=='_' && *(name+1)) + { + int accelerator = (int) (unsigned char) (*(name+1)); + return make_char (tolower (accelerator)); + } + } + ++name; + } + return Qnil; +} + +#define XEMACS_MENU_DESCR_TAG "xemacs::menu::description" +#define XEMACS_MENU_FILTER_TAG "xemacs::menu::filter" +#define XEMACS_MENU_GUIID_TAG "xemacs::menu::gui_id" +#define XEMACS_MENU_FIRSTTIME_TAG "xemacs::menu::first_time" + +static void __activate_menu(GtkMenuItem *, gpointer); + +#ifdef TEAR_OFF_MENUS +static void +__torn_off_sir(GtkMenuItem *item, gpointer user_data) +{ + GtkWidget *menu_item = GTK_WIDGET (user_data); + + if (GTK_TEAROFF_MENU_ITEM (item)->torn_off) + { + /* Menu was just torn off */ + GUI_ID id = new_gui_id (); + Lisp_Object menu_desc = Qnil; + GtkWidget *old_submenu = GTK_MENU_ITEM (menu_item)->submenu; + + VOID_TO_LISP (menu_desc, gtk_object_get_data (GTK_OBJECT (menu_item), XEMACS_MENU_DESCR_TAG)); + + /* GCPRO all of our very own */ + gcpro_popup_callbacks (id, menu_desc); + + /* Hide the now detached menu from the attentions of + __activate_menu destroying the old submenu */ +#if 0 + gtk_widget_ref (old_submenu); + gtk_menu_item_set_submenu (GTK_MENU_ITEM (menu_item), gtk_menu_new ()); + gtk_widget_show_all (old_submenu); +#endif + } +} +#endif + +/* This is called when a menu is about to be shown... this is what + does the delayed creation of the menu items. We populate the + submenu and away we go. */ +static void +__maybe_destroy (GtkWidget *child, GtkWidget *precious) +{ + if (GTK_IS_MENU_ITEM (child) && !GTK_IS_TEAROFF_MENU_ITEM (child)) + { + if (GTK_WIDGET_VISIBLE (child)) + { + /* If we delete the menu item that was 'active' when the + menu was cancelled, GTK gets upset because it tries to + remove the focus rectangle from a (now) dead widget. + + This widget will eventually get killed because it will + not be visible the next time the window is shown. + */ + gtk_widget_set_sensitive (child, FALSE); + gtk_widget_hide_all (child); + } + else + { + gtk_widget_destroy (child); + } + } +} + +/* If user_data != 0x00 then we are using a hook to build the menu. */ +static void +__activate_menu(GtkMenuItem *item, gpointer user_data) +{ + Lisp_Object desc; + gpointer force_clear = gtk_object_get_data (GTK_OBJECT (item), XEMACS_MENU_FIRSTTIME_TAG); + + gtk_object_set_data (GTK_OBJECT (item), XEMACS_MENU_FIRSTTIME_TAG, 0x00); + + /* Delete the old contents of the menu if we are the top level menubar */ + if (GTK_IS_MENU_BAR (GTK_WIDGET (item)->parent) || force_clear) + { + GtkWidget *selected = gtk_menu_get_active (GTK_MENU (item->submenu)); + + gtk_container_foreach (GTK_CONTAINER (item->submenu),(GtkCallback) __maybe_destroy, + selected); + } + else if (gtk_container_children (GTK_CONTAINER (item->submenu))) + { + return; + } + + VOID_TO_LISP (desc, gtk_object_get_data (GTK_OBJECT (item), XEMACS_MENU_DESCR_TAG)); + +#ifdef TEAR_OFF_MENUS + /* Lets stick in a detacher just for giggles */ + if (tear_off_menus && !gtk_container_children (GTK_CONTAINER (item->submenu))) + { + GtkWidget *w = gtk_tearoff_menu_item_new (); + gtk_widget_show (w); + gtk_menu_append (GTK_MENU (item->submenu), w); + gtk_signal_connect (GTK_OBJECT (w), "activate", GTK_SIGNAL_FUNC (__torn_off_sir), item); + } +#endif + + if (user_data) + { + GUI_ID id = (GUI_ID) gtk_object_get_data (GTK_OBJECT (item), XEMACS_MENU_GUIID_TAG); + Lisp_Object hook_fn; + struct gcpro gcpro1, gcpro2; + + VOID_TO_LISP (hook_fn, gtk_object_get_data (GTK_OBJECT (item), XEMACS_MENU_FILTER_TAG)); + + GCPRO2 (desc, hook_fn); + + desc = call1 (hook_fn, desc); + + UNGCPRO; + + ungcpro_popup_callbacks (id); + gcpro_popup_callbacks (id, desc); + } + + /* Build the child widgets */ + for (; !NILP (desc); desc = Fcdr (desc)) + { + GtkWidget *next = NULL; + Lisp_Object child = Fcar (desc); + + if (NILP (child)) /* the partition */ + { + /* Signal an error here? The NILP handling is handled a + layer higher where appropriate */ + } + else + { + next = menu_descriptor_to_widget_1 (child); + } + + if (!next) + { + continue; + } + + gtk_widget_show_all (next); + gtk_menu_append (GTK_MENU (item->submenu), next); + } +} + +/* This is called whenever an item with a GUI_ID associated with it is + destroyed. This allows us to remove the references in gui-gtk.c + that made sure callbacks and such were GCPRO-ed +*/ +static void +__remove_gcpro_by_id (gpointer user_data) +{ + ungcpro_popup_callbacks ((GUI_ID) user_data); +} + +static void +__kill_stupid_gtk_timer (GtkObject *obj, gpointer user_data) +{ + GtkMenuItem *mi = GTK_MENU_ITEM (obj); + + if (mi->timer) + { + gtk_timeout_remove (mi->timer); + mi->timer = 0; + } +} + +static char * +remove_underscores(const char *name) +{ + char *rval = xmalloc_and_zero (strlen(name) + 1); + int i,j; + + for (i = 0, j = 0; name[i]; i++) + { + if (name[i]=='%') { + i++; + if (!(name[i])) + continue; + + if ((name[i] == '_')) + continue; + } + rval[j++] = name[i]; + } + return rval; +} + +/* This converts an entire menu into a GtkMenuItem (with an attached + submenu). A menu is a list of (STRING [:keyword value]+ [DESCR]+) + DESCR is either a list (meaning a submenu), a vector, or nil (if + you include a :filter keyword) */ +static GtkWidget * +menu_convert (Lisp_Object desc, GtkWidget *reuse) +{ + GtkWidget *menu_item = NULL; + GtkWidget *submenu = NULL; + Lisp_Object key, val; + Lisp_Object include_p = Qnil, hook_fn = Qnil, config_tag = Qnil; + Lisp_Object active_p = Qt; + Lisp_Object accel; + int included_spec = 0; + int active_spec = 0; + + if (STRINGP (XCAR (desc))) + { + accel = menu_name_to_accelerator (XSTRING_DATA (XCAR (desc))); + + if (!reuse) + { + char *temp_menu_name = remove_underscores (XSTRING_DATA (XCAR (desc))); + menu_item = gtk_menu_item_new_with_label (temp_menu_name); + free (temp_menu_name); + } + else + { + menu_item = reuse; + } + + submenu = gtk_menu_new (); + gtk_widget_show (menu_item); + gtk_widget_show (submenu); + + if (!reuse) + gtk_signal_connect (GTK_OBJECT (menu_item), "destroy", + GTK_SIGNAL_FUNC (__kill_stupid_gtk_timer), NULL); + + /* Without this sometimes a submenu gets left on the screen - + ** urk + */ + if (GTK_MENU_ITEM (menu_item)->submenu) + { + gtk_widget_destroy (GTK_MENU_ITEM (menu_item)->submenu); + } + + gtk_menu_item_set_submenu (GTK_MENU_ITEM (menu_item), submenu); + + /* We put this bogus menu item in so that GTK does the right + ** thing when the menu is near the screen border. + ** + ** Aug 29, 2000 + */ + { + GtkWidget *bogus_item = gtk_menu_item_new_with_label ("A suitably long label here..."); + + gtk_object_set_data (GTK_OBJECT (menu_item), XEMACS_MENU_FIRSTTIME_TAG, (gpointer)0x01); + gtk_widget_show_all (bogus_item); + gtk_menu_append (GTK_MENU (submenu), bogus_item); + } + + desc = Fcdr (desc); + + while (key = Fcar (desc), KEYWORDP (key)) + { + Lisp_Object cascade = desc; + desc = Fcdr (desc); + if (NILP (desc)) + signal_simple_error ("keyword in menu lacks a value", + cascade); + val = Fcar (desc); + desc = Fcdr (desc); + if (EQ (key, Q_included)) + include_p = val, included_spec = 1; + else if (EQ (key, Q_config)) + config_tag = val; + else if (EQ (key, Q_filter)) + hook_fn = val; + else if (EQ (key, Q_active)) + active_p = val, active_spec = 1; + else if (EQ (key, Q_accelerator)) + { +#if 0 + if ( SYMBOLP (val) + || CHARP (val)) + wv->accel = LISP_TO_VOID (val); + else + signal_simple_error ("bad keyboard accelerator", val); +#endif + } + else if (EQ (key, Q_label)) + { + /* implement in 21.2 */ + } + else + signal_simple_error ("unknown menu cascade keyword", cascade); + } + + gtk_object_set_data (GTK_OBJECT (menu_item), XEMACS_MENU_DESCR_TAG, LISP_TO_VOID (desc)); + gtk_object_set_data (GTK_OBJECT (menu_item), XEMACS_MENU_FILTER_TAG, LISP_TO_VOID (hook_fn)); + + if ((!NILP (config_tag) + && NILP (Fmemq (config_tag, Vmenubar_configuration))) + || (included_spec && NILP (Feval (include_p)))) + { + return (NULL); + } + + if (active_spec) + active_p = Feval (active_p); + + gtk_widget_set_sensitive (GTK_WIDGET (menu_item), ! NILP (active_p)); + } + else + { + signal_simple_error ("menu name (first element) must be a string", + desc); + } + + /* If we are reusing a widget, we need to make sure we clean + ** everything up. + */ + if (reuse) + { + gpointer id = gtk_object_get_data (GTK_OBJECT (reuse), XEMACS_MENU_GUIID_TAG); + + if (id) + { + /* If the menu item had a GUI_ID that means it was a filter menu */ + __remove_gcpro_by_id (id); + gtk_signal_disconnect_by_func (GTK_OBJECT (reuse), + GTK_SIGNAL_FUNC (__activate_menu), + (gpointer) 0x01 ); + } + else + { + gtk_signal_disconnect_by_func (GTK_OBJECT (reuse), + GTK_SIGNAL_FUNC (__activate_menu), + NULL); + } + + GTK_MENU_ITEM (reuse)->right_justify = 0; + } + + if (NILP (hook_fn)) + { + /* Generic menu builder */ + gtk_signal_connect (GTK_OBJECT (menu_item), "activate", + GTK_SIGNAL_FUNC (__activate_menu), + NULL); + } + else + { + GUI_ID id = new_gui_id (); + + gtk_object_set_data (GTK_OBJECT (menu_item), XEMACS_MENU_GUIID_TAG, + (gpointer) id); + + /* Make sure we gcpro the menu descriptions */ + gcpro_popup_callbacks (id, desc); + gtk_object_weakref (GTK_OBJECT (menu_item), __remove_gcpro_by_id, + (gpointer) id); + + gtk_signal_connect (GTK_OBJECT (menu_item), "activate", + GTK_SIGNAL_FUNC (__activate_menu), + (gpointer) 0x01); + } + + return (menu_item); +} + +static struct frame * +__get_channel (GtkWidget *w) +{ + struct frame *f = NULL; + + for (; w; w = w->parent) + { + if ((f = (struct frame *) gtk_object_get_data (GTK_OBJECT (w), "xemacs::frame"))) + return (f); + } + + return (selected_frame()); +} + + +/* Called whenever a button, radio, or toggle is selected in the menu */ +static void +__generic_button_callback (GtkMenuItem *item, gpointer user_data) +{ + Lisp_Object callback, function, data, channel; + + XSETFRAME (channel, __get_channel (GTK_WIDGET (item))); + + VOID_TO_LISP (callback, user_data); + + get_gui_callback (callback, &function, &data); + + signal_special_gtk_user_event (channel, function, data); +} + +/* Convert a single menu item descriptor to a suitable GtkMenuItem */ +/* This function cannot GC. + It is only called from menu_item_descriptor_to_widget_value, which + prohibits GC. */ +static GtkWidget *menu_descriptor_to_widget_1 (Lisp_Object descr) +{ + if (STRINGP (descr)) + { + /* It is a separator. Unfortunately GTK does not allow us to + specify what our separators look like, so we can't do all the + fancy stuff that the X code does. + */ + return (gtk_menu_item_new ()); + } + else if (LISTP (descr)) + { + /* It is a submenu */ + return (menu_convert (descr, NULL)); + } + else if (VECTORP (descr)) + { + /* An actual menu item description! This gets yucky. */ + Lisp_Object name = Qnil; + Lisp_Object callback = Qnil; + Lisp_Object suffix = Qnil; + Lisp_Object active_p = Qt; + Lisp_Object include_p = Qt; + Lisp_Object selected_p = Qnil; + Lisp_Object keys = Qnil; + Lisp_Object style = Qnil; + Lisp_Object config_tag = Qnil; + Lisp_Object accel = Qnil; + GtkWidget *main_label = NULL; + int length = XVECTOR_LENGTH (descr); + Lisp_Object *contents = XVECTOR_DATA (descr); + int plist_p; + int selected_spec = 0, included_spec = 0; + GtkWidget *widget = NULL; + + if (length < 2) + signal_simple_error ("button descriptors must be at least 2 long", descr); + + /* length 2: [ "name" callback ] + length 3: [ "name" callback active-p ] + length 4: [ "name" callback active-p suffix ] + or [ "name" callback keyword value ] + length 5+: [ "name" callback [ keyword value ]+ ] + */ + plist_p = (length >= 5 || (length > 2 && KEYWORDP (contents [2]))); + + if (!plist_p && length > 2) + /* the old way */ + { + name = contents [0]; + callback = contents [1]; + active_p = contents [2]; + if (length == 4) + suffix = contents [3]; + } + else + { + /* the new way */ + int i; + if (length & 1) + signal_simple_error ( + "button descriptor has an odd number of keywords and values", + descr); + + name = contents [0]; + callback = contents [1]; + for (i = 2; i < length;) + { + Lisp_Object key = contents [i++]; + Lisp_Object val = contents [i++]; + if (!KEYWORDP (key)) + signal_simple_error_2 ("not a keyword", key, descr); + + if (EQ (key, Q_active)) active_p = val; + else if (EQ (key, Q_suffix)) suffix = val; + else if (EQ (key, Q_keys)) keys = val; + else if (EQ (key, Q_key_sequence)) ; /* ignored for FSF compat */ + else if (EQ (key, Q_label)) ; /* implement for 21.0 */ + else if (EQ (key, Q_style)) style = val; + else if (EQ (key, Q_selected)) selected_p = val, selected_spec = 1; + else if (EQ (key, Q_included)) include_p = val, included_spec = 1; + else if (EQ (key, Q_config)) config_tag = val; + else if (EQ (key, Q_accelerator)) + { + if ( SYMBOLP (val) || CHARP (val)) + accel = val; + else + signal_simple_error ("bad keyboard accelerator", val); + } + else if (EQ (key, Q_filter)) + signal_simple_error(":filter keyword not permitted on leaf nodes", descr); + else + signal_simple_error_2 ("unknown menu item keyword", key, descr); + } + } + +#ifdef HAVE_MENUBARS + if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration))) + || (included_spec && NILP (Feval (include_p)))) + { + /* the include specification says to ignore this item. */ + return 0; + } +#endif /* HAVE_MENUBARS */ + + CHECK_STRING (name); + + if (NILP (accel)) + accel = menu_name_to_accelerator (XSTRING_DATA (name)); + + if (!NILP (suffix)) + suffix = Feval (suffix); + + if (!separator_string_p (XSTRING_DATA (name))) + { + char *label_buffer = NULL; + char *temp_label = NULL; + + if (STRINGP (suffix) && XSTRING_LENGTH (suffix)) + { + label_buffer = alloca (XSTRING_LENGTH (name) + 15 + XSTRING_LENGTH (suffix)); + sprintf (label_buffer, "%s %s ", XSTRING_DATA (name), XSTRING_DATA (suffix)); + } + else + { + label_buffer = alloca (XSTRING_LENGTH (name) + 15); + sprintf (label_buffer, "%s ", XSTRING_DATA (name)); + } + + temp_label = remove_underscores (label_buffer); + main_label = gtk_accel_label_new (temp_label); + free (temp_label); + } + + /* Evaluate the selected and active items now */ + if (selected_spec) + { + if (NILP (selected_p) || EQ (selected_p, Qt)) + { + /* Do nothing */ + } + else + { + selected_p = Feval (selected_p); + } + } + + if (NILP (active_p) || EQ (active_p, Qt)) + { + /* Do Nothing */ + } + else + { + active_p = Feval (active_p); + } + + if (0 || +#ifdef HAVE_MENUBARS + menubar_show_keybindings +#endif + ) + { + /* Need to get keybindings */ + if (!NILP (keys)) + { + /* User-specified string to generate key bindings with */ + CHECK_STRING (keys); + + keys = Fsubstitute_command_keys (keys); + } + else if (SYMBOLP (callback)) + { + char buf[1024]; + + /* #### Warning, dependency here on current_buffer and point */ + where_is_to_char (callback, buf); + + keys = build_string (buf); + } + } + + /* Now we get down to the dirty business of creating the widgets */ + if (NILP (style) || EQ (style, Qtext) || EQ (style, Qbutton)) + { + /* A normal menu item */ + widget = gtk_menu_item_new (); + } + else if (EQ (style, Qtoggle) || EQ (style, Qradio)) + { + /* They are radio or toggle buttons. + + XEmacs' menu descriptions are fairly lame in that they do + not have the idea of a 'group' of radio buttons. They + are exactly like toggle buttons except that they get + drawn differently. + + GTK rips us a new one again. If you have a radio button + in a group by itself, it always draws it as highlighted. + So we dummy up and create a second radio button that does + not get added to the menu, but gets invisibly set/unset + when the other gets unset/set. *sigh* + + */ + if (EQ (style, Qradio)) + { + GtkWidget *dummy_sibling = NULL; + GSList *group = NULL; + + dummy_sibling = gtk_radio_menu_item_new (group); + group = gtk_radio_menu_item_group (GTK_RADIO_MENU_ITEM (dummy_sibling)); + widget = gtk_radio_menu_item_new (group); + + /* We need to notice when the 'real' one gets destroyed + so we can clean up the dummy as well. */ + gtk_object_weakref (GTK_OBJECT (widget), + (GtkDestroyNotify) gtk_widget_destroy, + dummy_sibling); + } + else + { + widget = gtk_check_menu_item_new (); + } + + /* What horrible defaults you have GTK dear! The default + for a toggle menu item is to not show the toggle unless it + is turned on or actively highlighted. How absolutely + hideous. */ + gtk_check_menu_item_set_show_toggle (GTK_CHECK_MENU_ITEM (widget), TRUE); + gtk_check_menu_item_set_active (GTK_CHECK_MENU_ITEM (widget), + NILP (selected_p) ? FALSE : TRUE); + } + else + { + signal_simple_error_2 ("unknown style", style, descr); + } + + gtk_widget_set_sensitive (widget, ! NILP (active_p)); + + gtk_signal_connect (GTK_OBJECT (widget), "activate-item", + GTK_SIGNAL_FUNC (__generic_button_callback), + LISP_TO_VOID (callback)); + + gtk_signal_connect (GTK_OBJECT (widget), "activate", + GTK_SIGNAL_FUNC (__generic_button_callback), + LISP_TO_VOID (callback)); + + /* We cheat here... GtkAccelLabel usually builds its + `accel_string' from the widget it is attached to, but we do + not want to go thru the overhead of converting our nice + string back into the modifier + key format that requires, + just so that they can convert it back into a (possibly + different/wrong) string + + We set the label string manually, and things should 'just + work' + + In an ideal world we would just subclass GtkLabel ourselves, + but I have known for a very long time that this is not an + ideal world. + + #### Should do menu shortcuts `correctly' one of these days. + */ + + if (main_label) + { + GtkAccelLabel *l = GTK_ACCEL_LABEL (main_label); + + gtk_container_add (GTK_CONTAINER (widget), main_label); + + gtk_accel_label_set_accel_widget (l, NULL); + gtk_misc_set_alignment (GTK_MISC (l), 0.0, 0.5); + + if (STRINGP (keys) && XSTRING_LENGTH (keys)) + { + l->accel_string = g_strdup (XSTRING_DATA (keys)); + } + } + + return (widget); + } + else + { + return (NULL); + /* abort (); ???? */ + } +} + +static GtkWidget *menu_descriptor_to_widget (Lisp_Object descr) +{ + int count = specpdl_depth (); + GtkWidget *rval = NULL; + + record_unwind_protect (restore_gc_inhibit, make_int (gc_currently_forbidden)); + + gc_currently_forbidden = 1; + + /* Cannot GC from here on out... */ + rval = menu_descriptor_to_widget_1 (descr); + unbind_to (count, Qnil); + return (rval); + +} + +static gboolean +menu_can_reuse_widget (GtkWidget *child, const char *label) +{ + /* Everything up at the top level was done using + ** gtk_menu_item_new_with_label(), but we still double check to make + ** sure we don't seriously foobar ourselves. + */ + char *temp_label = NULL; + gpointer possible_child = g_list_nth_data (gtk_container_children (GTK_CONTAINER (child)), 0); + + if (possible_child && GTK_IS_LABEL (possible_child)) + { + if (!temp_label) temp_label = remove_underscores (label); + if (!strcmp (GTK_LABEL (possible_child)->label, temp_label)) + { + free (temp_label); + return (TRUE); + } + } + if (temp_label) free (temp_label); + return (FALSE); +} + +/* Converts a menubar description into a GtkMenuBar... a menubar is a + list of menus or buttons +*/ +static void +menu_create_menubar (struct frame *f, Lisp_Object descr) +{ + gboolean right_justify = FALSE; + Lisp_Object tail = Qnil; + Lisp_Object value = descr; + Lisp_Object item_descr = Qnil; + GtkWidget *menubar = FRAME_GTK_MENUBAR_WIDGET (f); + GUI_ID id = (GUI_ID) gtk_object_get_data (GTK_OBJECT (menubar), XEMACS_MENU_GUIID_TAG); + guint menu_position = 0; + + /* Remove any existing protection for old menu items */ + ungcpro_popup_callbacks (id); + + /* GCPRO the whole damn thing */ + gcpro_popup_callbacks (id, descr); + + EXTERNAL_LIST_LOOP (tail, value) + { + gpointer current_child = g_list_nth_data (GTK_MENU_SHELL (menubar)->children, menu_position); + + item_descr = XCAR (tail); + + if (NILP (item_descr)) + { + /* Need to start right-justifying menus */ + right_justify = TRUE; + menu_position--; + } + else if (VECTORP (item_descr)) + { + /* It is a button description */ + GtkWidget *item; + + item = menu_descriptor_to_widget (item_descr); + gtk_widget_set_name (item, "XEmacsMenuButton"); + + if (!item) + { + item = gtk_menu_item_new_with_label ("ITEM CREATION ERROR"); + } + + gtk_widget_show_all (item); + if (current_child) gtk_widget_destroy (GTK_WIDGET (current_child)); + gtk_menu_bar_insert (GTK_MENU_BAR (menubar), item, menu_position); + } + else if (LISTP (item_descr)) + { + /* Need to actually convert it into a menu and slap it in */ + GtkWidget *widget; + gboolean reused_p = FALSE; + + /* We may be able to reuse the widget, let's at least check. */ + if (current_child && menu_can_reuse_widget (GTK_WIDGET (current_child), + XSTRING_DATA (XCAR (item_descr)))) + { + widget = menu_convert (item_descr, GTK_WIDGET (current_child)); + reused_p = TRUE; + } + else + { + widget = menu_convert (item_descr, NULL); + if (current_child) gtk_widget_destroy (GTK_WIDGET (current_child)); + gtk_menu_bar_insert (GTK_MENU_BAR (menubar), widget, menu_position); + } + + if (widget) + { + if (right_justify) gtk_menu_item_right_justify (GTK_MENU_ITEM (widget)); + } + else + { + widget = gtk_menu_item_new_with_label ("ERROR"); + /* abort() */ + } + gtk_widget_show_all (widget); + } + else if (STRINGP (item_descr)) + { + /* Do I really want to be this careful? Anything else in a + menubar description is illegal */ + } + menu_position++; + } + + /* Need to delete any menu items that were past the bounds of the new one */ + { + GList *l = NULL; + + while ((l = g_list_nth (GTK_MENU_SHELL (menubar)->children, menu_position))) + { + gpointer data = l->data; + g_list_remove_link (GTK_MENU_SHELL (menubar)->children, l); + + if (data) + { + gtk_widget_destroy (GTK_WIDGET (data)); + } + } + } +} + + +/* Deal with getting/setting the menubar */ +#ifndef GNOME_IS_APP +#define GNOME_IS_APP(x) 0 +#define gnome_app_set_menus(x,y) +#endif + +static gboolean +run_menubar_hook (GtkWidget *widget, GdkEventButton *event, gpointer user_data) +{ + if (!GTK_MENU_SHELL(widget)->active) + { + run_hook (Qactivate_menubar_hook); + } + return(FALSE); +} + +static void +create_menubar_widget (struct frame *f) +{ + GUI_ID id = new_gui_id (); + GtkWidget *handlebox = NULL; + GtkWidget *menubar = gtk_xemacs_menubar_new (f); + + if (GNOME_IS_APP (FRAME_GTK_SHELL_WIDGET (f))) + { + gnome_app_set_menus (GNOME_APP (FRAME_GTK_SHELL_WIDGET (f)), GTK_MENU_BAR (menubar)); + } + else if (dockable_menubar) + { + handlebox = gtk_handle_box_new (); + gtk_handle_box_set_handle_position (GTK_HANDLE_BOX (handlebox), GTK_POS_LEFT); + gtk_container_add (GTK_CONTAINER (handlebox), menubar); + gtk_box_pack_start (GTK_BOX (FRAME_GTK_CONTAINER_WIDGET (f)), handlebox, FALSE, FALSE, 0); + } + else + { + gtk_box_pack_start (GTK_BOX (FRAME_GTK_CONTAINER_WIDGET (f)), menubar, FALSE, FALSE, 0); + } + + gtk_signal_connect (GTK_OBJECT (menubar), "button-press-event", + GTK_SIGNAL_FUNC (run_menubar_hook), NULL); + + FRAME_GTK_MENUBAR_WIDGET (f) = menubar; + gtk_object_set_data (GTK_OBJECT (menubar), XEMACS_MENU_GUIID_TAG, (gpointer) id); + gtk_object_weakref (GTK_OBJECT (menubar), __remove_gcpro_by_id, (gpointer) id); +} + +static int +set_frame_menubar (struct frame *f, int first_time_p) +{ + Lisp_Object menubar; + int menubar_visible; + /* As for the toolbar, the minibuffer does not have its own menubar. */ + struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)); + + if (! FRAME_GTK_P (f)) + return 0; + + /***** first compute the contents of the menubar *****/ + + if (! first_time_p) + { + /* evaluate `current-menubar' in the buffer of the selected window + of the frame in question. */ + menubar = symbol_value_in_buffer (Qcurrent_menubar, w->buffer); + } + else + { + /* That's a little tricky the first time since the frame isn't + fully initialized yet. */ + menubar = Fsymbol_value (Qcurrent_menubar); + } + + if (NILP (menubar)) + { + menubar = Vblank_menubar; + menubar_visible = 0; + } + else + { + menubar_visible = !NILP (w->menubar_visible_p); + } + + if (!FRAME_GTK_MENUBAR_WIDGET (f)) + { + create_menubar_widget (f); + } + + /* Populate the menubar, but nothing is shown yet */ + { + Lisp_Object old_buffer; + int count = specpdl_depth (); + + old_buffer = Fcurrent_buffer (); + record_unwind_protect (Fset_buffer, old_buffer); + Fset_buffer (XWINDOW (FRAME_SELECTED_WINDOW (f))->buffer); + + menu_create_menubar (f, menubar); + + Fset_buffer (old_buffer); + unbind_to (count, Qnil); + } + + FRAME_MENUBAR_DATA (f) = Fcons (XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer, Qt); + + return (menubar_visible); +} + +/* Called from gtk_create_widgets() to create the inital menubar of a frame + before it is mapped, so that the window is mapped with the menubar already + there instead of us tacking it on later and thrashing the window after it + is visible. */ +int +gtk_initialize_frame_menubar (struct frame *f) +{ + create_menubar_widget (f); + return set_frame_menubar (f, 1); +} + + +static void +gtk_update_frame_menubar_internal (struct frame *f) +{ + /* We assume the menubar contents has changed if the global flag is set, + or if the current buffer has changed, or if the menubar has never + been updated before. + */ + int menubar_contents_changed = + (f->menubar_changed + || NILP (FRAME_MENUBAR_DATA (f)) + || (!EQ (XFRAME_MENUBAR_DATA_LASTBUFF (f), + XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer))); + + gboolean menubar_was_visible = GTK_WIDGET_VISIBLE (FRAME_GTK_MENUBAR_WIDGET (f)); + gboolean menubar_will_be_visible = menubar_was_visible; + gboolean menubar_visibility_changed; + + if (menubar_contents_changed) + { + menubar_will_be_visible = set_frame_menubar (f, 0); + } + + menubar_visibility_changed = menubar_was_visible != menubar_will_be_visible; + + if (!menubar_visibility_changed) + { + return; + } + + /* We hide and show the menubar's parent (which is actually the + GtkHandleBox)... this is to simplify the code that destroys old + menu items, etc. There is no easy way to get the child out of a + handle box, and I didn't want to add yet another stupid widget + slot to struct gtk_frame. */ + if (menubar_will_be_visible) + { + gtk_widget_show_all (FRAME_GTK_MENUBAR_WIDGET (f)->parent); + } + else + { + gtk_widget_hide_all (FRAME_GTK_MENUBAR_WIDGET (f)->parent); + } + + MARK_FRAME_SIZE_SLIPPED (f); +} + +static void +gtk_update_frame_menubars (struct frame *f) +{ + GtkWidget *menubar = NULL; + + assert (FRAME_GTK_P (f)); + + menubar = FRAME_GTK_MENUBAR_WIDGET (f); + + if ((GTK_MENU_SHELL (menubar)->active) || + (GTK_MENU_SHELL (menubar)->have_grab) || + (GTK_MENU_SHELL (menubar)->have_xgrab)) + { + return; + } + + gtk_update_frame_menubar_internal (f); +} + +static void +gtk_free_frame_menubars (struct frame *f) +{ + GtkWidget *menubar_widget; + + assert (FRAME_GTK_P (f)); + + menubar_widget = FRAME_GTK_MENUBAR_WIDGET (f); + if (menubar_widget) + { + gtk_widget_destroy (menubar_widget); + } +} + +static void popdown_menu_cb (GtkMenuShell *menu, gpointer user_data) +{ + popup_up_p--; +} + +static void +gtk_popup_menu (Lisp_Object menu_desc, Lisp_Object event) +{ + struct Lisp_Event *eev = NULL; + GtkWidget *widget = menu_descriptor_to_widget (menu_desc); + GtkWidget *menu = GTK_MENU_ITEM (widget)->submenu; + gpointer id = gtk_object_get_data (GTK_OBJECT (widget), XEMACS_MENU_GUIID_TAG); + + gtk_widget_set_name (widget, "XEmacsPopupMenu"); + + __activate_menu (GTK_MENU_ITEM (widget), id); + + if (!NILP (event)) + { + CHECK_LIVE_EVENT (event); + eev = XEVENT (event); + + if ((eev->event_type != button_press_event) && + (eev->event_type != button_release_event)) + wrong_type_argument (Qmouse_event_p, event); + } + else if (!NILP (Vthis_command_keys)) + { + /* If an event wasn't passed, use the last event of the event + sequence currently being executed, if that event is a mouse + event. */ + eev = XEVENT (Vthis_command_keys); + if ((eev->event_type != button_press_event) && + (eev->event_type != button_release_event)) + eev = NULL; + } + + gtk_widget_show (menu); + + popup_up_p++; + gtk_signal_connect (GTK_OBJECT (menu), "deactivate", + GTK_SIGNAL_FUNC (popdown_menu_cb), NULL); + + gtk_menu_popup (GTK_MENU (menu), NULL, NULL, NULL, NULL, + eev ? eev->event.button.button : 0, + eev ? eev->timestamp : GDK_CURRENT_TIME); +} + +DEFUN ("gtk-build-xemacs-menu", Fgtk_build_xemacs_menu, 1, 1, 0, /* +Returns a GTK menu item from MENU, a standard XEmacs menu description. +See the definition of `popup-menu' for more information on the format of MENU. +*/ + (menu)) +{ + GtkWidget *w = menu_descriptor_to_widget (menu); + + return (w ? build_gtk_object (GTK_OBJECT (w)) : Qnil); +} + + +void +syms_of_menubar_gtk (void) +{ + DEFSUBR (Fgtk_build_xemacs_menu); +} + +void +console_type_create_menubar_gtk (void) +{ + CONSOLE_HAS_METHOD (gtk, update_frame_menubars); + CONSOLE_HAS_METHOD (gtk, free_frame_menubars); + CONSOLE_HAS_METHOD (gtk, popup_menu); +} + +void reinit_vars_of_menubar_gtk (void) +{ + dockable_menubar = 1; +#ifdef TEAR_OFF_MENUS + tear_off_menus = 1; +#endif +} + +void +vars_of_menubar_gtk (void) +{ + Fprovide (intern ("gtk-menubars")); + DEFVAR_BOOL ("menubar-dockable-p", &dockable_menubar /* +If non-nil, the frame menubar can be detached into its own top-level window. +*/ ); +#ifdef TEAR_OFF_MENUS + DEFVAR_BOOL ("menubar-tearable-p", &tear_off_menus /* +If non-nil, menus can be torn off into their own top-level windows. +*/ ); +#endif + reinit_vars_of_menubar_gtk (); +} diff --git a/src/native-gtk-toolbar.c b/src/native-gtk-toolbar.c new file mode 100644 index 0000000..8757108 --- /dev/null +++ b/src/native-gtk-toolbar.c @@ -0,0 +1,243 @@ +/* toolbar implementation -- GTK interface. + Copyright (C) 2000 Aaron Lehmann + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "glyphs-gtk.h" +#include "objects-gtk.h" + +#include "faces.h" +#include "frame.h" +#include "toolbar.h" +#include "window.h" + +#define SET_TOOLBAR_WAS_VISIBLE_FLAG(frame, pos, flag) \ + do { \ + switch (pos) \ + { \ + case TOP_TOOLBAR: \ + (frame)->top_toolbar_was_visible = flag; \ + break; \ + case BOTTOM_TOOLBAR: \ + (frame)->bottom_toolbar_was_visible = flag; \ + break; \ + case LEFT_TOOLBAR: \ + (frame)->left_toolbar_was_visible = flag; \ + break; \ + case RIGHT_TOOLBAR: \ + (frame)->right_toolbar_was_visible = flag; \ + break; \ + default: \ + abort (); \ + } \ + } while (0) + +static void +gtk_clear_toolbar (struct frame *f, enum toolbar_pos pos); + +static void +gtk_toolbar_callback (GtkWidget *w, gpointer user_data) +{ + struct toolbar_button *tb = (struct toolbar_button *) user_data; + + call0 (tb->callback); +} + + +static void +gtk_output_toolbar (struct frame *f, enum toolbar_pos pos) +{ + GtkWidget *toolbar; + Lisp_Object button, window, glyph, instance; + unsigned int checksum = 0; + struct window *w; + int x, y, bar_width, bar_height, vert; + int cur_x, cur_y; + + window = FRAME_LAST_NONMINIBUF_WINDOW (f); + w = XWINDOW (window); + + get_toolbar_coords (f, pos, &x, &y, &bar_width, &bar_height, &vert, 0); + + /* Get the toolbar and delete the old widgets in it */ + button = FRAME_TOOLBAR_BUTTONS (f, pos); + + /* First loop over all of the buttons to determine how many there + are. This loop will also make sure that all instances are + instantiated so when we actually output them they will come up + immediately. */ + while (!NILP (button)) + { + struct toolbar_button *tb = XTOOLBAR_BUTTON (button); + checksum = HASH4 (checksum, + internal_hash (get_toolbar_button_glyph(w, tb), 0), + internal_hash (tb->callback, 0), + 0 /* width */); + button = tb->next; + } + + /* Only do updates if the toolbar has changed, or this is the first + time we have drawn it in this position + */ + if (FRAME_GTK_TOOLBAR_WIDGET (f)[pos] && + FRAME_GTK_TOOLBAR_CHECKSUM (f, pos) == checksum) + { + return; + } + + /* Loop through buttons and add them to our toolbar. + This code ignores the button dimensions as we let GTK handle that :) + Attach the toolbar_button struct to the toolbar button so we know what + function to use as a callback. */ + + { + gtk_clear_toolbar (f, pos); + FRAME_GTK_TOOLBAR_WIDGET (f)[pos] = toolbar = + gtk_toolbar_new (((pos == TOP_TOOLBAR) || (pos == BOTTOM_TOOLBAR)) ? + GTK_ORIENTATION_HORIZONTAL : GTK_ORIENTATION_VERTICAL, + GTK_TOOLBAR_BOTH); + } + + if (NILP (w->toolbar_buttons_captioned_p)) + gtk_toolbar_set_style (toolbar, GTK_TOOLBAR_ICONS); + else + gtk_toolbar_set_style (toolbar, GTK_TOOLBAR_BOTH); + + FRAME_GTK_TOOLBAR_CHECKSUM(f, pos) = checksum; + button = FRAME_TOOLBAR_BUTTONS (f, pos); + + cur_x = 0; + cur_y = 0; + + while (!NILP (button)) + { + struct toolbar_button *tb = XTOOLBAR_BUTTON (button); + + if (tb->blank) + { + /* It is a blank space... we do not pay attention to the + size, because the GTK toolbar does not allow us to + specify different spacings. *sigh* + */ + gtk_toolbar_append_space (GTK_TOOLBAR (toolbar)); + } + else + { + /* It actually has a glyph associated with it! What WILL + they think of next? + */ + glyph = tb->up_glyph; + + /* #### It is currently possible for users to trash us by directly + changing the toolbar glyphs. Avoid crashing in that case. */ + if (GLYPHP (glyph)) + instance = glyph_image_instance (glyph, window, ERROR_ME_NOT, 1); + else + instance = Qnil; + + if (IMAGE_INSTANCEP(instance)) + { + GtkWidget *pixmapwid; + GdkPixmap *pixmap; + GdkBitmap *mask; + char *tooltip = NULL; + + if (STRINGP (tb->help_string)) + tooltip = XSTRING_DATA (tb->help_string); + + pixmap = XIMAGE_INSTANCE_GTK_PIXMAP(instance); + mask = XIMAGE_INSTANCE_GTK_MASK(instance); + pixmapwid = gtk_pixmap_new (pixmap, mask); + + gtk_widget_set_usize (pixmapwid, tb->width, tb->height); + + gtk_toolbar_append_item (GTK_TOOLBAR(toolbar), NULL, tooltip, NULL, + pixmapwid, gtk_toolbar_callback, (gpointer) tb); + } + } + cur_x += vert ? 0 : tb->width; + cur_y += vert ? tb->height : 0; + /* Who's idea was it to use a linked list for toolbar buttons? */ + button = tb->next; + } + + SET_TOOLBAR_WAS_VISIBLE_FLAG (f, pos, 1); + + x -= vert ? 3 : 2; + y -= vert ? 2 : 3; + + gtk_fixed_put (GTK_FIXED (FRAME_GTK_TEXT_WIDGET (f)), FRAME_GTK_TOOLBAR_WIDGET (f)[pos],x, y); + gtk_widget_show_all (FRAME_GTK_TOOLBAR_WIDGET (f)[pos]); +} + +static void +gtk_clear_toolbar (struct frame *f, enum toolbar_pos pos) +{ + FRAME_GTK_TOOLBAR_CHECKSUM (f, pos) = 0; + SET_TOOLBAR_WAS_VISIBLE_FLAG (f, pos, 0); + if (FRAME_GTK_TOOLBAR_WIDGET(f)[pos]) + gtk_widget_destroy (FRAME_GTK_TOOLBAR_WIDGET(f)[pos]); +} + +static void +gtk_output_frame_toolbars (struct frame *f) +{ + if (FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) + gtk_output_toolbar (f, TOP_TOOLBAR); + else if (f->top_toolbar_was_visible) + gtk_clear_toolbar (f, TOP_TOOLBAR); + + if (FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) + gtk_output_toolbar (f, BOTTOM_TOOLBAR); + else if (f->bottom_toolbar_was_visible) + gtk_clear_toolbar (f, LEFT_TOOLBAR); + + if (FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) + gtk_output_toolbar (f, LEFT_TOOLBAR); + else if (f->left_toolbar_was_visible) + gtk_clear_toolbar (f, LEFT_TOOLBAR); + + if (FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) + gtk_output_toolbar (f, RIGHT_TOOLBAR); + else if (f->right_toolbar_was_visible) + gtk_clear_toolbar (f, RIGHT_TOOLBAR); +} + +static void +gtk_initialize_frame_toolbars (struct frame *f) +{ + stderr_out ("We should draw toolbars\n"); +} + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +console_type_create_toolbar_gtk (void) +{ + CONSOLE_HAS_METHOD (gtk, output_frame_toolbars); + CONSOLE_HAS_METHOD (gtk, initialize_frame_toolbars); +} diff --git a/src/objects-gtk.c b/src/objects-gtk.c new file mode 100644 index 0000000..72fde7c --- /dev/null +++ b/src/objects-gtk.c @@ -0,0 +1,603 @@ +/* X-specific Lisp objects. + Copyright (C) 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995 Tinker Systems. + Copyright (C) 1995, 1996 Ben Wing. + Copyright (C) 1995 Sun Microsystems, Inc. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* Authors: Jamie Zawinski, Chuck Thompson, Ben Wing */ +/* Gtk version by William Perry */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "objects-gtk.h" + +#include "buffer.h" +#include "device.h" +#include "insdel.h" + +/* sigh */ +#include + + +/************************************************************************/ +/* color instances */ +/************************************************************************/ + +/* Replacement for XAllocColor() that tries to return the nearest + available color if the colormap is full. Original was from FSFmacs, + but rewritten by Jareth Hein 97/11/25 + Modified by Lee Kindness 31/08/99 to handle previous + total failure which was due to a read/write colorcell being the nearest + match - tries the next nearest... + + Gdk takes care of all this behind the scenes, so we don't need to + worry about it. + + Return value is 1 for normal success, 2 for nearest color success, + 3 for Non-deallocable sucess. */ +int +allocate_nearest_color (GdkColormap *colormap, GdkVisual *visual, + GdkColor *color_def) +{ + int rc; + + rc = gdk_colormap_alloc_color (colormap, color_def, FALSE, TRUE); + + if (rc == TRUE) + return (1); + + return (0); +} + +int +gtk_parse_nearest_color (struct device *d, GdkColor *color, Bufbyte *name, + Bytecount len, Error_behavior errb) +{ + GdkColormap *cmap; + GdkVisual *visual; + int result; + + cmap = DEVICE_GTK_COLORMAP(d); + visual = DEVICE_GTK_VISUAL (d); + + xzero (*color); + { + const Extbyte *extname; + Extcount extnamelen; + + TO_EXTERNAL_FORMAT (DATA, (name, len), ALLOCA, (extname, extnamelen), Qbinary); + + result = gdk_color_parse (extname, color); + } + + if (result == FALSE) + { + maybe_signal_simple_error ("unrecognized color", make_string (name, len), + Qcolor, errb); + return 0; + } + result = allocate_nearest_color (cmap, visual, color); + if (!result) + { + maybe_signal_simple_error ("couldn't allocate color", + make_string (name, len), Qcolor, errb); + return 0; + } + + return result; +} + +static int +gtk_initialize_color_instance (struct Lisp_Color_Instance *c, Lisp_Object name, + Lisp_Object device, Error_behavior errb) +{ + GdkColor color; + int result; + + result = gtk_parse_nearest_color (XDEVICE (device), &color, + XSTRING_DATA (name), + XSTRING_LENGTH (name), + errb); + + if (!result) + return 0; + + /* Don't allocate the data until we're sure that we will succeed, + or the finalize method may get fucked. */ + c->data = xnew (struct gtk_color_instance_data); + if (result == 3) + COLOR_INSTANCE_GTK_DEALLOC (c) = 0; + else + COLOR_INSTANCE_GTK_DEALLOC (c) = 1; + COLOR_INSTANCE_GTK_COLOR (c) = gdk_color_copy (&color); + return 1; +} + +static void +gtk_print_color_instance (struct Lisp_Color_Instance *c, + Lisp_Object printcharfun, + int escapeflag) +{ + char buf[100]; + GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c); + sprintf (buf, " %ld=(%X,%X,%X)", + color->pixel, color->red, color->green, color->blue); + write_c_string (buf, printcharfun); +} + +static void +gtk_finalize_color_instance (struct Lisp_Color_Instance *c) +{ + if (c->data) + { + if (DEVICE_LIVE_P (XDEVICE (c->device))) + { + if (COLOR_INSTANCE_GTK_DEALLOC (c)) + { + gdk_colormap_free_colors (DEVICE_GTK_COLORMAP (XDEVICE (c->device)), + COLOR_INSTANCE_GTK_COLOR (c), 1); + } + gdk_color_free (COLOR_INSTANCE_GTK_COLOR (c)); + } + xfree (c->data); + c->data = 0; + } +} + +/* Color instances are equal if they resolve to the same color on the + screen (have the same RGB values). I imagine that + "same RGB values" == "same cell in the colormap." Arguably we should + be comparing their names or pixel values instead. */ + +static int +gtk_color_instance_equal (struct Lisp_Color_Instance *c1, + struct Lisp_Color_Instance *c2, + int depth) +{ + return (gdk_color_equal (COLOR_INSTANCE_GTK_COLOR (c1), + COLOR_INSTANCE_GTK_COLOR (c2))); +} + +static unsigned long +gtk_color_instance_hash (struct Lisp_Color_Instance *c, int depth) +{ + return (gdk_color_hash (COLOR_INSTANCE_GTK_COLOR (c), NULL)); +} + +static Lisp_Object +gtk_color_instance_rgb_components (struct Lisp_Color_Instance *c) +{ + GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c); + return (list3 (make_int (color->red), + make_int (color->green), + make_int (color->blue))); +} + +static int +gtk_valid_color_name_p (struct device *d, Lisp_Object color) +{ + GdkColor c; + const char *extname; + + TO_EXTERNAL_FORMAT (LISP_STRING, color, C_STRING_ALLOCA, extname, Qctext); + + if (gdk_color_parse (extname, &c) != TRUE) + return(0); + return (1); +} + + +/************************************************************************/ +/* font instances */ +/************************************************************************/ + +static int +gtk_initialize_font_instance (struct Lisp_Font_Instance *f, Lisp_Object name, + Lisp_Object device, Error_behavior errb) +{ + GdkFont *gf; + XFontStruct *xf; + const char *extname; + + TO_EXTERNAL_FORMAT (LISP_STRING, f->name, C_STRING_ALLOCA, extname, Qctext); + + gf = gdk_font_load (extname); + + if (!gf) + { + maybe_signal_simple_error ("couldn't load font", f->name, + Qfont, errb); + return 0; + } + + xf = GDK_FONT_XFONT (gf); + + /* Don't allocate the data until we're sure that we will succeed, + or the finalize method may get fucked. */ + f->data = xnew (struct gtk_font_instance_data); + FONT_INSTANCE_GTK_TRUENAME (f) = Qnil; + FONT_INSTANCE_GTK_FONT (f) = gf; + f->ascent = gf->ascent; + f->descent = gf->descent; + f->height = gf->ascent + gf->descent; + + /* Now lets figure out the width of the font */ + { + /* following change suggested by Ted Phelps */ + unsigned int def_char = 'n'; /*xf->default_char;*/ + unsigned int byte1, byte2; + + once_more: + byte1 = def_char >> 8; + byte2 = def_char & 0xFF; + + if (xf->per_char) + { + /* Old versions of the R5 font server have garbage (>63k) as + def_char. 'n' might not be a valid character. */ + if (byte1 < xf->min_byte1 || + byte1 > xf->max_byte1 || + byte2 < xf->min_char_or_byte2 || + byte2 > xf->max_char_or_byte2) + f->width = 0; + else + f->width = xf->per_char[(byte1 - xf->min_byte1) * + (xf->max_char_or_byte2 - + xf->min_char_or_byte2 + 1) + + (byte2 - xf->min_char_or_byte2)].width; + } + else + f->width = xf->max_bounds.width; + + /* Some fonts have a default char whose width is 0. This is no good. + If that's the case, first try 'n' as the default char, and if n has + 0 width too (unlikely) then just use the max width. */ + if (f->width == 0) + { + if (def_char == xf->default_char) + f->width = xf->max_bounds.width; + else + { + def_char = xf->default_char; + goto once_more; + } + } + } + + /* If all characters don't exist then there could potentially be + 0-width characters lurking out there. Not setting this flag + trips an optimization that would make them appear to have width + to redisplay. This is bad. So we set it if not all characters + have the same width or if not all characters are defined. + */ + /* #### This sucks. There is a measurable performance increase + when using proportional width fonts if this flag is not set. + Unfortunately so many of the fucking X fonts are not fully + defined that we could almost just get rid of this damn flag and + make it an assertion. */ + f->proportional_p = (xf->min_bounds.width != xf->max_bounds.width || + (/* x_handle_non_fully_specified_fonts */ 0 && + !xf->all_chars_exist)); +#if 0 + f->width = gdk_char_width (gf, 'n'); + f->proportional_p = (gdk_char_width (gf, '|') != gdk_char_width (gf, 'W')) ? 1 : 0; +#endif + return 1; +} + +static void +gtk_mark_font_instance (struct Lisp_Font_Instance *f) +{ + mark_object (FONT_INSTANCE_GTK_TRUENAME (f)); +} + +static void +gtk_print_font_instance (struct Lisp_Font_Instance *f, + Lisp_Object printcharfun, + int escapeflag) +{ + char buf[200]; + sprintf (buf, " 0x%lx", (unsigned long) gdk_font_id (FONT_INSTANCE_GTK_FONT (f))); + write_c_string (buf, printcharfun); +} + +static void +gtk_finalize_font_instance (struct Lisp_Font_Instance *f) +{ + if (f->data) + { + if (DEVICE_LIVE_P (XDEVICE (f->device))) + { + gdk_font_unref (FONT_INSTANCE_GTK_FONT (f)); + } + xfree (f->data); + f->data = 0; + } +} + +/* Forward declarations for X specific functions at the end of the file */ +Lisp_Object __get_gtk_font_truename (GdkFont *gdk_font, int expandp); +static Lisp_Object __gtk_list_fonts_internal (const char *pattern); + +static Lisp_Object +gtk_font_instance_truename (struct Lisp_Font_Instance *f, Error_behavior errb) +{ + if (NILP (FONT_INSTANCE_GTK_TRUENAME (f))) + { + FONT_INSTANCE_GTK_TRUENAME (f) = __get_gtk_font_truename (FONT_INSTANCE_GTK_FONT (f), 1); + + if (NILP (FONT_INSTANCE_GTK_TRUENAME (f))) + { + /* Ok, just this once, return the font name as the truename. + (This is only used by Fequal() right now.) */ + return f->name; + } + } + return (FONT_INSTANCE_GTK_TRUENAME (f)); +} + +static Lisp_Object +gtk_font_instance_properties (struct Lisp_Font_Instance *f) +{ + Lisp_Object result = Qnil; + + /* #### BILL!!! */ + /* There seems to be no way to get this information under Gtk */ + return result; +} + +static Lisp_Object +gtk_list_fonts (Lisp_Object pattern, Lisp_Object device) +{ + const char *patternext; + + TO_EXTERNAL_FORMAT (LISP_STRING, pattern, C_STRING_ALLOCA, patternext, Qbinary); + + return (__gtk_list_fonts_internal (patternext)); +} + +#ifdef MULE + +static int +gtk_font_spec_matches_charset (struct device *d, Lisp_Object charset, + const Bufbyte *nonreloc, Lisp_Object reloc, + Bytecount offset, Bytecount length) +{ + if (UNBOUNDP (charset)) + return 1; + /* Hack! Short font names don't have the registry in them, + so we just assume the user knows what they're doing in the + case of ASCII. For other charsets, you gotta give the + long form; sorry buster. + */ + if (EQ (charset, Vcharset_ascii)) + { + const Bufbyte *the_nonreloc = nonreloc; + int i; + Bytecount the_length = length; + + if (!the_nonreloc) + the_nonreloc = XSTRING_DATA (reloc); + fixup_internal_substring (nonreloc, reloc, offset, &the_length); + the_nonreloc += offset; + if (!memchr (the_nonreloc, '*', the_length)) + { + for (i = 0;; i++) + { + const Bufbyte *new_nonreloc = (const Bufbyte *) + memchr (the_nonreloc, '-', the_length); + if (!new_nonreloc) + break; + new_nonreloc++; + the_length -= new_nonreloc - the_nonreloc; + the_nonreloc = new_nonreloc; + } + + /* If it has less than 5 dashes, it's a short font. + Of course, long fonts always have 14 dashes or so, but short + fonts never have more than 1 or 2 dashes, so this is some + sort of reasonable heuristic. */ + if (i < 5) + return 1; + } + } + + return (fast_string_match (XCHARSET_REGISTRY (charset), + nonreloc, reloc, offset, length, 1, + ERROR_ME, 0) >= 0); +} + +/* find a font spec that matches font spec FONT and also matches + (the registry of) CHARSET. */ +static Lisp_Object gtk_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset); + +#endif /* MULE */ + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +syms_of_objects_gtk (void) +{ +} + +void +console_type_create_objects_gtk (void) +{ + /* object methods */ + + CONSOLE_HAS_METHOD (gtk, initialize_color_instance); + CONSOLE_HAS_METHOD (gtk, print_color_instance); + CONSOLE_HAS_METHOD (gtk, finalize_color_instance); + CONSOLE_HAS_METHOD (gtk, color_instance_equal); + CONSOLE_HAS_METHOD (gtk, color_instance_hash); + CONSOLE_HAS_METHOD (gtk, color_instance_rgb_components); + CONSOLE_HAS_METHOD (gtk, valid_color_name_p); + + CONSOLE_HAS_METHOD (gtk, initialize_font_instance); + CONSOLE_HAS_METHOD (gtk, mark_font_instance); + CONSOLE_HAS_METHOD (gtk, print_font_instance); + CONSOLE_HAS_METHOD (gtk, finalize_font_instance); + CONSOLE_HAS_METHOD (gtk, font_instance_truename); + CONSOLE_HAS_METHOD (gtk, font_instance_properties); + CONSOLE_HAS_METHOD (gtk, list_fonts); +#ifdef MULE + CONSOLE_HAS_METHOD (gtk, find_charset_font); + CONSOLE_HAS_METHOD (gtk, font_spec_matches_charset); +#endif +} + +void +vars_of_objects_gtk (void) +{ +} + +/* #### BILL!!! Try to make this go away eventually */ +/* X Specific stuff */ +#include + +/* Unbounded, for sufficiently small values of infinity... */ +#define MAX_FONT_COUNT 5000 + +#ifdef MULE +/* find a font spec that matches font spec FONT and also matches + (the registry of) CHARSET. */ +static Lisp_Object +gtk_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset) +{ + char **names; + int count = 0; + Lisp_Object result = Qnil; + const char *patternext; + int i; + + TO_EXTERNAL_FORMAT (LISP_STRING, font, C_STRING_ALLOCA, patternext, Qbinary); + + names = XListFonts (GDK_DISPLAY (), + patternext, MAX_FONT_COUNT, &count); + /* ### This code seems awfully bogus -- mrb */ + for (i = 0; i < count; i ++) + { + const Bufbyte *intname; + Bytecount intlen; + + TO_INTERNAL_FORMAT (C_STRING, names[i], ALLOCA, (intname, intlen), + Qctext); + if (gtk_font_spec_matches_charset (XDEVICE (device), charset, + intname, Qnil, 0, -1)) + { + result = make_string ((char *) intname, intlen); + break; + } + } + + if (names) + XFreeFontNames (names); + + /* Check for a short font name. */ + if (NILP (result) + && gtk_font_spec_matches_charset (XDEVICE (device), charset, 0, + font, 0, -1)) + return font; + + return result; +} +#endif /* MULE */ + +/* Unbounded, for sufficiently small values of infinity... */ +#define MAX_FONT_COUNT 5000 + +static int +valid_font_name_p (Display *dpy, char *name) +{ + /* Maybe this should be implemented by callign XLoadFont and trapping + the error. That would be a lot of work, and wasteful as hell, but + might be more correct. + */ + int nnames = 0; + char **names = 0; + if (! name) + return 0; + names = XListFonts (dpy, name, 1, &nnames); + if (names) + XFreeFontNames (names); + return (nnames != 0); +} + +Lisp_Object +__get_gtk_font_truename (GdkFont *gdk_font, int expandp) +{ + Display *dpy = GDK_FONT_XDISPLAY (gdk_font); + GSList *names = ((GdkFontPrivate *) gdk_font)->names; + Lisp_Object font_name = Qnil; + + while (names) + { + if (names->data) + { + if (valid_font_name_p (dpy, names->data)) + { + if (!expandp) + { + /* They want the wildcarded version */ + font_name = build_string (names->data); + } + else + { + /* Need to expand out */ + int nnames = 0; + char **x_font_names = 0; + + x_font_names = XListFonts (dpy, names->data, 1, &nnames); + if (x_font_names) + { + font_name = build_string (x_font_names[0]); + XFreeFontNames (x_font_names); + } + } + break; + } + } + names = names->next; + } + return (font_name); +} + +static Lisp_Object __gtk_list_fonts_internal (const char *pattern) +{ + char **names; + int count = 0; + Lisp_Object result = Qnil; + + names = XListFonts (GDK_DISPLAY (), pattern, MAX_FONT_COUNT, &count); + while (count--) + result = Fcons (build_ext_string (names [count], Qbinary), result); + if (names) + XFreeFontNames (names); + + return result; +} diff --git a/src/objects-gtk.h b/src/objects-gtk.h new file mode 100644 index 0000000..7b74f5d --- /dev/null +++ b/src/objects-gtk.h @@ -0,0 +1,68 @@ +/* Gtk-specific Lisp objects. + Copyright (C) 1993, 1994 Free Software Foundation, Inc. + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995, 1996 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ +/* Gtk version by William Perry */ + +#ifndef _XEMACS_OBJECTS_GTK_H_ +#define _XEMACS_OBJECTS_GTK_H_ + +#include "objects.h" + +#ifdef HAVE_GTK + +/***************************************************************************** + Color-Instance + ****************************************************************************/ + +struct gtk_color_instance_data +{ + GdkColor *color; + char dealloc_on_gc; +}; + +#define GTK_COLOR_INSTANCE_DATA(c) ((struct gtk_color_instance_data *) (c)->data) +#define COLOR_INSTANCE_GTK_COLOR(c) (GTK_COLOR_INSTANCE_DATA (c)->color) +#define COLOR_INSTANCE_GTK_DEALLOC(c) (GTK_COLOR_INSTANCE_DATA (c)->dealloc_on_gc) + +int allocate_nearest_color (GdkColormap *screen_colormap, GdkVisual *visual, + GdkColor *color_def); +int gtk_parse_nearest_color (struct device *d, GdkColor *color, Bufbyte *name, + Bytecount len, Error_behavior errb); + +/***************************************************************************** + Font-Instance + ****************************************************************************/ + +struct gtk_font_instance_data +{ + /* Gtk-specific information */ + Lisp_Object truename; + GdkFont *font; +}; + +#define GTK_FONT_INSTANCE_DATA(f) ((struct gtk_font_instance_data *) (f)->data) +#define FONT_INSTANCE_GTK_FONT(f) (GTK_FONT_INSTANCE_DATA (f)->font) +#define FONT_INSTANCE_GTK_TRUENAME(f) (GTK_FONT_INSTANCE_DATA (f)->truename) + +#endif /* HAVE_GTK */ +#endif /* _XEMACS_OBJECTS_GTK_H_ */ diff --git a/src/redisplay-gtk.c b/src/redisplay-gtk.c new file mode 100644 index 0000000..f1ee926 --- /dev/null +++ b/src/redisplay-gtk.c @@ -0,0 +1,2051 @@ +/* X output and frame manipulation routines. + Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + Copyright (C) 1994 Lucid, Inc. + Copyright (C) 1995 Sun Microsystems, Inc. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* Author: Chuck Thompson */ +/* Gtk flavor by William Perry */ + +/* Lots of work done by Ben Wing for Mule */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "gccache-gtk.h" +#include "glyphs-gtk.h" +#include "objects-gtk.h" + +#include "buffer.h" +#include "debug.h" +#include "faces.h" +#include "frame.h" +#include "gutter.h" +#include "redisplay.h" +#include "sysdep.h" +#include "window.h" + +#include "sysproc.h" /* for select() */ + +#ifdef MULE +#include "mule-ccl.h" +#include "file-coding.h" /* for CCL conversion */ +#endif + +#define CONST const + +#define EOL_CURSOR_WIDTH 5 + +static void gtk_output_pixmap (struct window *w, struct display_line *dl, + Lisp_Object image_instance, int xpos, + int xoffset, + int start_pixpos, int width, face_index findex, + int cursor_start, int cursor_width, + int cursor_height); +static void gtk_output_vertical_divider (struct window *w, int clear); +static void gtk_output_blank (struct window *w, struct display_line *dl, + struct rune *rb, int start_pixpos, + int cursor_start, int cursor_width); +static void gtk_output_hline (struct window *w, struct display_line *dl, + struct rune *rb); +static void gtk_redraw_exposed_window (struct window *w, int x, int y, + int width, int height); +static void gtk_redraw_exposed_windows (Lisp_Object window, int x, int y, + int width, int height); +static void gtk_clear_region (Lisp_Object locale, struct device* d, struct frame* f, + face_index findex, int x, int y, + int width, int height, Lisp_Object fcolor, Lisp_Object bcolor, + Lisp_Object background_pixmap); +static void gtk_output_eol_cursor (struct window *w, struct display_line *dl, + int xpos, face_index findex); +static void gtk_clear_frame (struct frame *f); +static void gtk_clear_frame_windows (Lisp_Object window); +static void gtk_bevel_modeline (struct window *w, struct display_line *dl); + +#if 0 +static void __describe_gc (GdkGC *); +#endif + +struct textual_run +{ + Lisp_Object charset; + unsigned char *ptr; + int len; + int dimension; +}; + +/* Separate out the text in DYN into a series of textual runs of a + particular charset. Also convert the characters as necessary into + the format needed by XDrawImageString(), XDrawImageString16(), et + al. (This means converting to one or two byte format, possibly + tweaking the high bits, and possibly running a CCL program.) You + must pre-allocate the space used and pass it in. (This is done so + you can alloca() the space.) You need to allocate (2 * len) bytes + of TEXT_STORAGE and (len * sizeof (struct textual_run)) bytes of + RUN_STORAGE, where LEN is the length of the dynarr. + + Returns the number of runs actually used. */ + +static int +separate_textual_runs (unsigned char *text_storage, + struct textual_run *run_storage, + CONST Emchar *str, Charcount len) +{ + Lisp_Object prev_charset = Qunbound; /* not Qnil because that is a + possible valid charset when + MULE is not defined */ + int runs_so_far = 0; + int i; +#ifdef MULE + struct ccl_program char_converter; + int need_ccl_conversion = 0; +#endif + + for (i = 0; i < len; i++) + { + Emchar ch = str[i]; + Lisp_Object charset; + int byte1, byte2; + int dimension; + int graphic; + + BREAKUP_CHAR (ch, charset, byte1, byte2); + dimension = XCHARSET_DIMENSION (charset); + graphic = XCHARSET_GRAPHIC (charset); + + if (!EQ (charset, prev_charset)) + { + run_storage[runs_so_far].ptr = text_storage; + run_storage[runs_so_far].charset = charset; + run_storage[runs_so_far].dimension = dimension; + + if (runs_so_far) + { + run_storage[runs_so_far - 1].len = + text_storage - run_storage[runs_so_far - 1].ptr; + if (run_storage[runs_so_far - 1].dimension == 2) + run_storage[runs_so_far - 1].len >>= 1; + } + runs_so_far++; + prev_charset = charset; +#ifdef MULE + { + Lisp_Object ccl_prog = XCHARSET_CCL_PROGRAM (charset); + need_ccl_conversion = !NILP (ccl_prog); + if (need_ccl_conversion) + setup_ccl_program (&char_converter, ccl_prog); + } +#endif + } + + if (graphic == 0) + { + byte1 &= 0x7F; + byte2 &= 0x7F; + } + else if (graphic == 1) + { + byte1 |= 0x80; + byte2 |= 0x80; + } +#ifdef MULE + if (need_ccl_conversion) + { + char_converter.reg[0] = XCHARSET_ID (charset); + char_converter.reg[1] = byte1; + char_converter.reg[2] = byte2; + ccl_driver (&char_converter, 0, 0, 0, 0, CCL_MODE_ENCODING); + byte1 = char_converter.reg[1]; + byte2 = char_converter.reg[2]; + } +#endif + *text_storage++ = (unsigned char) byte1; + if (dimension == 2) + *text_storage++ = (unsigned char) byte2; + } + + if (runs_so_far) + { + run_storage[runs_so_far - 1].len = + text_storage - run_storage[runs_so_far - 1].ptr; + if (run_storage[runs_so_far - 1].dimension == 2) + run_storage[runs_so_far - 1].len >>= 1; + } + + return runs_so_far; +} + +/****************************************************************************/ +/* */ +/* Gtk output routines */ +/* */ +/****************************************************************************/ + +static int +gtk_text_width_single_run (struct face_cachel *cachel, struct textual_run *run) +{ + Lisp_Object font_inst = FACE_CACHEL_FONT (cachel, run->charset); + struct Lisp_Font_Instance *fi = XFONT_INSTANCE (font_inst); + + if (!fi->proportional_p) + { + return fi->width * run->len; + } + else + { + if (run->dimension == 2) + { + stderr_out ("Measuring wide characters\n"); + return gdk_text_width_wc (FONT_INSTANCE_GTK_FONT (fi), + (GdkWChar *) run->ptr, run->len); + } + else + { + return gdk_text_width (FONT_INSTANCE_GTK_FONT (fi), + (char *) run->ptr, run->len); + } + } +} + +/* + gtk_text_width + + Given a string and a face, return the string's length in pixels when + displayed in the font associated with the face. + */ + +static int +gtk_text_width (struct frame *f, struct face_cachel *cachel, CONST Emchar *str, + Charcount len) +{ + int width_so_far = 0; + unsigned char *text_storage = (unsigned char *) alloca (2 * len); + struct textual_run *runs = alloca_array (struct textual_run, len); + int nruns; + int i; + + nruns = separate_textual_runs (text_storage, runs, str, len); + + for (i = 0; i < nruns; i++) + width_so_far += gtk_text_width_single_run (cachel, runs + i); + + return width_so_far; +} + +/***************************************************************************** + gtk_divider_height + + Return the height of the horizontal divider. This is a function because + divider_height is a device method. + + #### If we add etched horizontal divider lines this will have to get + smarter. + ****************************************************************************/ +static int +gtk_divider_height (void) +{ + return 2; +} + +/***************************************************************************** + gtk_eol_cursor_width + + Return the width of the end-of-line cursor. This is a function + because eol_cursor_width is a device method. + ****************************************************************************/ +static int +gtk_eol_cursor_width (void) +{ + return EOL_CURSOR_WIDTH; +} + +/***************************************************************************** + gtk_output_display_block + + Given a display line, a block number for that start line, output all + runes between start and end in the specified display block. + ****************************************************************************/ +static void +gtk_output_display_block (struct window *w, struct display_line *dl, int block, + int start, int end, int start_pixpos, int cursor_start, + int cursor_width, int cursor_height) +{ + struct frame *f = XFRAME (w->frame); + Emchar_dynarr *buf = Dynarr_new (Emchar); + Lisp_Object window; + + struct display_block *db = Dynarr_atp (dl->display_blocks, block); + rune_dynarr *rba = db->runes; + struct rune *rb; + + int elt = start; + face_index findex; + int xpos, width; + Lisp_Object charset = Qunbound; /* Qnil is a valid charset when + MULE is not defined */ + + XSETWINDOW (window, w); + rb = Dynarr_atp (rba, start); + + if (!rb) + { + /* Nothing to do so don't do anything. */ + return; + } + else + { + findex = rb->findex; + xpos = rb->xpos; + width = 0; + if (rb->type == RUNE_CHAR) + charset = CHAR_CHARSET (rb->object.chr.ch); + } + + if (end < 0) + end = Dynarr_length (rba); + Dynarr_reset (buf); + + while (elt < end) + { + rb = Dynarr_atp (rba, elt); + + if (rb->findex == findex && rb->type == RUNE_CHAR + && rb->object.chr.ch != '\n' && rb->cursor_type != CURSOR_ON + && EQ (charset, CHAR_CHARSET (rb->object.chr.ch))) + { + Dynarr_add (buf, rb->object.chr.ch); + width += rb->width; + elt++; + } + else + { + if (Dynarr_length (buf)) + { + gtk_output_string (w, dl, buf, xpos, 0, start_pixpos, width, + findex, 0, cursor_start, cursor_width, + cursor_height); + xpos = rb->xpos; + width = 0; + } + Dynarr_reset (buf); + width = 0; + + if (rb->type == RUNE_CHAR) + { + findex = rb->findex; + xpos = rb->xpos; + charset = CHAR_CHARSET (rb->object.chr.ch); + + if (rb->cursor_type == CURSOR_ON) + { + if (rb->object.chr.ch == '\n') + { + gtk_output_eol_cursor (w, dl, xpos, findex); + } + else + { + Dynarr_add (buf, rb->object.chr.ch); + gtk_output_string (w, dl, buf, xpos, 0, start_pixpos, + rb->width, findex, 1, + cursor_start, cursor_width, + cursor_height); + Dynarr_reset (buf); + } + + xpos += rb->width; + elt++; + } + else if (rb->object.chr.ch == '\n') + { + /* Clear in case a cursor was formerly here. */ + int height = dl->ascent + dl->descent - dl->clip; + + redisplay_clear_region (window, findex, xpos, dl->ypos - dl->ascent, + rb->width, height); + elt++; + } + } + else if (rb->type == RUNE_BLANK || rb->type == RUNE_HLINE) + { + if (rb->type == RUNE_BLANK) + gtk_output_blank (w, dl, rb, start_pixpos, cursor_start, + cursor_width); + else + { + /* #### Our flagging of when we need to redraw the + modeline shadows sucks. Since RUNE_HLINE is only used + by the modeline at the moment it is a good bet + that if it gets redrawn then we should also + redraw the shadows. This won't be true forever. + We borrow the shadow_thickness_changed flag for + now. */ + w->shadow_thickness_changed = 1; + gtk_output_hline (w, dl, rb); + } + + elt++; + if (elt < end) + { + rb = Dynarr_atp (rba, elt); + + findex = rb->findex; + xpos = rb->xpos; + } + } + else if (rb->type == RUNE_DGLYPH) + { + Lisp_Object instance; + struct display_box dbox; + struct display_glyph_area dga; + redisplay_calculate_display_boxes (dl, rb->xpos, rb->object.dglyph.xoffset, + start_pixpos, rb->width, + &dbox, &dga); + + XSETWINDOW (window, w); + instance = glyph_image_instance (rb->object.dglyph.glyph, + window, ERROR_ME_NOT, 1); + findex = rb->findex; + + if (IMAGE_INSTANCEP (instance)) + switch (XIMAGE_INSTANCE_TYPE (instance)) + { + case IMAGE_TEXT: + { + /* #### This is way losing. See the comment in + add_glyph_rune(). */ + Lisp_Object string = + XIMAGE_INSTANCE_TEXT_STRING (instance); + convert_bufbyte_string_into_emchar_dynarr + (XSTRING_DATA (string), XSTRING_LENGTH (string), buf); + + gtk_output_string (w, dl, buf, xpos, + rb->object.dglyph.xoffset, + start_pixpos, -1, findex, + (rb->cursor_type == CURSOR_ON), + cursor_start, cursor_width, + cursor_height); + Dynarr_reset (buf); + } + break; + + case IMAGE_MONO_PIXMAP: + case IMAGE_COLOR_PIXMAP: + gtk_output_pixmap (w, dl, instance, xpos, + rb->object.dglyph.xoffset, start_pixpos, + rb->width, findex, cursor_start, + cursor_width, cursor_height); + break; + + case IMAGE_POINTER: + abort (); + + case IMAGE_WIDGET: + if (EQ (XIMAGE_INSTANCE_WIDGET_TYPE (instance), + Qlayout)) + { + redisplay_output_layout (window, instance, &dbox, + &dga, findex, + cursor_start, cursor_width, + cursor_height); + break; + } + + case IMAGE_SUBWINDOW: + redisplay_output_subwindow (w, instance, &dbox, &dga, + findex, cursor_start, + cursor_width, cursor_height); + break; + + case IMAGE_NOTHING: + /* nothing is as nothing does */ + break; + + default: + abort (); + } + + xpos += rb->width; + elt++; + } + else + abort (); + } + } + + if (Dynarr_length (buf)) + gtk_output_string (w, dl, buf, xpos, 0, start_pixpos, width, findex, + 0, cursor_start, cursor_width, cursor_height); + + /* #### This is really conditionalized well for optimized + performance. */ + if (dl->modeline + && !EQ (Qzero, w->modeline_shadow_thickness) + && (f->clear + || f->windows_structure_changed + || w->shadow_thickness_changed)) + gtk_bevel_modeline (w, dl); + + Dynarr_free (buf); +} + +/***************************************************************************** + gtk_bevel_modeline + + Draw a 3d border around the modeline on window W. + ****************************************************************************/ +static void +gtk_bevel_modeline (struct window *w, struct display_line *dl) +{ + struct frame *f = XFRAME (w->frame); + int shadow_thickness = MODELINE_SHADOW_THICKNESS (w); + int x,y, width, height; + + x = WINDOW_MODELINE_LEFT (w); + width = WINDOW_MODELINE_RIGHT (w) - x; + y = dl->ypos - dl->ascent - shadow_thickness; + height = dl->ascent + dl->descent + 2 * shadow_thickness; + + gtk_output_shadows (f, x, y, width, height, shadow_thickness); +} + +/***************************************************************************** + gtk_get_gc + + Given a number of parameters return a GC with those properties. + ****************************************************************************/ +GdkGC * +gtk_get_gc (struct device *d, Lisp_Object font, Lisp_Object fg, Lisp_Object bg, + Lisp_Object bg_pmap, Lisp_Object lwidth) +{ + GdkGCValues gcv; + unsigned long mask; + + memset (&gcv, ~0, sizeof (gcv)); + gcv.graphics_exposures = FALSE; + /* Make absolutely sure that we don't pick up a clipping region in + the GC returned by this function. */ + gcv.clip_mask = 0; + gcv.clip_x_origin = 0; + gcv.clip_y_origin = 0; + gcv.fill = GDK_SOLID; + mask = GDK_GC_EXPOSURES | GDK_GC_CLIP_MASK | GDK_GC_CLIP_X_ORIGIN | GDK_GC_CLIP_Y_ORIGIN; + mask |= GDK_GC_FILL; + + if (!NILP (font)) + { + gcv.font = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (font)); + mask |= GDK_GC_FONT; + } + + /* evil kludge! */ + if (!NILP (fg) && !COLOR_INSTANCEP (fg) && !INTP (fg)) + { + /* #### I fixed once case where this was getting it. It was a + bad macro expansion (compiler bug). */ + fprintf (stderr, "Help! gtk_get_gc got a bogus fg value! fg = "); + debug_print (fg); + fg = Qnil; + } + + if (!NILP (fg)) + { + if (COLOR_INSTANCEP (fg)) + gcv.foreground = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (fg)); + else + gcv.foreground.pixel = XINT (fg); + mask |= GDK_GC_FOREGROUND; + } + + if (!NILP (bg)) + { + if (COLOR_INSTANCEP (bg)) + gcv.background = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (bg)); + else + gcv.background.pixel = XINT (fg); + mask |= GDK_GC_BACKGROUND; + } + + if (IMAGE_INSTANCEP (bg_pmap) + && IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (bg_pmap))) + { + if (XIMAGE_INSTANCE_PIXMAP_DEPTH (bg_pmap) == 0) + { + gcv.fill = GDK_OPAQUE_STIPPLED; + gcv.stipple = XIMAGE_INSTANCE_GTK_PIXMAP (bg_pmap); + mask |= (GDK_GC_STIPPLE | GDK_GC_FILL); + } + else + { + gcv.fill = GDK_TILED; + gcv.tile = XIMAGE_INSTANCE_GTK_PIXMAP (bg_pmap); + mask |= (GDK_GC_TILE | GDK_GC_FILL); + } + } + + if (!NILP (lwidth)) + { + gcv.line_width = XINT (lwidth); + mask |= GDK_GC_LINE_WIDTH; + } + + return gc_cache_lookup (DEVICE_GTK_GC_CACHE (d), &gcv, mask); +} + +/***************************************************************************** + gtk_output_string + + Given a string and a starting position, output that string in the + given face. If cursor is true, draw a cursor around the string. + Correctly handles multiple charsets in the string. + + The meaning of the parameters is something like this: + + W Window that the text is to be displayed in. + DL Display line that this text is on. The values in the + structure are used to determine the vertical position and + clipping range of the text. + BUF Dynamic array of Emchars specifying what is actually to be + drawn. + XPOS X position in pixels where the text should start being drawn. + XOFFSET Number of pixels to be chopped off the left side of the + text. The effect is as if the text were shifted to the + left this many pixels and clipped at XPOS. + CLIP_START Clip everything left of this X position. + WIDTH Clip everything right of XPOS + WIDTH. + FINDEX Index for the face cache element describing how to display + the text. + CURSOR #### I don't understand this. There's something + strange and overcomplexified with this variable. + Chuck, explain please? + CURSOR_START Starting X position of cursor. + CURSOR_WIDTH Width of cursor in pixels. + CURSOR_HEIGHT Height of cursor in pixels. + + Starting Y position of cursor is the top of the text line. + The cursor is drawn sometimes whether or not CURSOR is set. ??? + ****************************************************************************/ +void +gdk_draw_text_image (GdkDrawable *drawable, + GdkFont *font, + GdkGC *gc, + gint x, + gint y, + const gchar *text, + gint text_length); + +void +gtk_output_string (struct window *w, struct display_line *dl, + Emchar_dynarr *buf, int xpos, int xoffset, int clip_start, + int width, face_index findex, int cursor, + int cursor_start, int cursor_width, int cursor_height) +{ + /* General variables */ + struct frame *f = XFRAME (w->frame); + struct device *d = XDEVICE (f->device); + Lisp_Object device; + Lisp_Object window; + GdkWindow *x_win = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)); + + int clip_end; + + /* Cursor-related variables */ + int focus = EQ (w->frame, DEVICE_FRAME_WITH_FOCUS_REAL (d)); + int cursor_clip; + Lisp_Object bar_cursor_value = symbol_value_in_buffer (Qbar_cursor, + WINDOW_BUFFER (w)); + struct face_cachel *cursor_cachel = 0; + + /* Text-related variables */ + Lisp_Object bg_pmap; + GdkGC *bgc, *gc; + int height; + int len = Dynarr_length (buf); + unsigned char *text_storage = (unsigned char *) alloca (2 * len); + struct textual_run *runs = alloca_array (struct textual_run, len); + int nruns; + int i; + struct face_cachel *cachel = WINDOW_FACE_CACHEL (w, findex); + + XSETDEVICE (device, d); + XSETWINDOW (window, w); + + if (width < 0) + width = gtk_text_width (f, cachel, Dynarr_atp (buf, 0), Dynarr_length (buf)); + height = dl->ascent + dl->descent - dl->clip; + + /* Regularize the variables passed in. */ + + if (clip_start < xpos) + clip_start = xpos; + clip_end = xpos + width; + if (clip_start >= clip_end) + /* It's all clipped out. */ + return; + + xpos -= xoffset; + + nruns = separate_textual_runs (text_storage, runs, Dynarr_atp (buf, 0), + Dynarr_length (buf)); + + cursor_clip = (cursor_start >= clip_start && + cursor_start < clip_end); + + /* This cursor code is really a mess. */ + if (!NILP (w->text_cursor_visible_p) + && (cursor + || cursor_clip + || (cursor_width + && (cursor_start + cursor_width >= clip_start) + && !NILP (bar_cursor_value)))) + { + /* These have to be in separate statements in order to avoid a + compiler bug. */ + face_index sucks = get_builtin_face_cache_index (w, Vtext_cursor_face); + cursor_cachel = WINDOW_FACE_CACHEL (w, sucks); + + /* We have to reset this since any call to WINDOW_FACE_CACHEL + may cause the cache to resize and any pointers to it to + become invalid. */ + cachel = WINDOW_FACE_CACHEL (w, findex); + } + + bg_pmap = cachel->background_pixmap; + if (!IMAGE_INSTANCEP (bg_pmap) + || !IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (bg_pmap))) + bg_pmap = Qnil; + + if ((cursor && focus && NILP (bar_cursor_value) + && !NILP (w->text_cursor_visible_p)) || NILP (bg_pmap)) + bgc = 0; + else + bgc = gtk_get_gc (d, Qnil, cachel->foreground, cachel->background, + bg_pmap, Qnil); + + if (bgc) + gdk_draw_rectangle (GDK_DRAWABLE (x_win), bgc, TRUE, clip_start, + dl->ypos - dl->ascent, clip_end - clip_start, + height); + + for (i = 0; i < nruns; i++) + { + Lisp_Object font = FACE_CACHEL_FONT (cachel, runs[i].charset); + struct Lisp_Font_Instance *fi = XFONT_INSTANCE (font); + GdkFont *gdk_font = FONT_INSTANCE_GTK_FONT (fi); + int this_width; + int need_clipping; + + if (EQ (font, Vthe_null_font_instance)) + continue; + + this_width = gtk_text_width_single_run (cachel, runs + i); + need_clipping = (dl->clip || clip_start > xpos || + clip_end < xpos + this_width); + + /* XDrawImageString only clears the area equal to the height of + the given font. It is possible that a font is being displayed + on a line taller than it is, so this would cause us to fail to + clear some areas. */ + if ((int) fi->height < (int) (height + dl->clip)) + { + int clear_start = max (xpos, clip_start); + int clear_end = min (xpos + this_width, clip_end); + + if (cursor) + { + int ypos1_line, ypos1_string, ypos2_line, ypos2_string; + + ypos1_string = dl->ypos - fi->ascent; + ypos2_string = dl->ypos + fi->descent; + ypos1_line = dl->ypos - dl->ascent; + ypos2_line = dl->ypos + dl->descent - dl->clip; + + /* Make sure we don't clear below the real bottom of the + line. */ + if (ypos1_string > ypos2_line) + ypos1_string = ypos2_line; + if (ypos2_string > ypos2_line) + ypos2_string = ypos2_line; + + if (ypos1_line < ypos1_string) + { + redisplay_clear_region (window, findex, clear_start, ypos1_line, + clear_end - clear_start, + ypos1_string - ypos1_line); + } + + if (ypos2_line > ypos2_string) + { + redisplay_clear_region (window, findex, clear_start, ypos2_string, + clear_end - clear_start, + ypos2_line - ypos2_string); + } + } + else + { + redisplay_clear_region (window, findex, clear_start, + dl->ypos - dl->ascent, clear_end - clear_start, + height); + } + } + + if (cursor && cursor_cachel && focus && NILP (bar_cursor_value)) + { + gc = gtk_get_gc (d, font, cursor_cachel->foreground, + cursor_cachel->background, Qnil, Qnil); + } + else + { + gc = gtk_get_gc (d, font, cachel->foreground, cachel->background, + Qnil, Qnil); + } + + if (need_clipping) + { + GdkRectangle clip_box; + + clip_box.x = 0; + clip_box.y = 0; + clip_box.width = clip_end - clip_start; + clip_box.height = height; + + gdk_gc_set_clip_rectangle (gc, &clip_box); + gdk_gc_set_clip_origin (gc, clip_start, dl->ypos - dl->ascent); + } + + /* The X specific called different functions (XDraw*String + vs. XDraw*String16), but apparently gdk_draw_text takes care + of that for us. + + BUT, gdk_draw_text also does too much, by dividing the length + by 2. So we fake them out my multiplying the length by the + dimension of the text. This will do the right thing for + single-dimension runs as well of course. + */ + (bgc ? gdk_draw_text : gdk_draw_text_image) (GDK_DRAWABLE (x_win), gdk_font, gc, xpos, + dl->ypos, (char *) runs[i].ptr, + runs[i].len * runs[i].dimension); + + /* We draw underlines in the same color as the text. */ + if (cachel->underline) + { + unsigned long upos, uthick; + + /* Cannot get at font properties in Gtk, so we resort to + guessing */ + upos = dl->descent / 2; + uthick = 1; + + if (dl->ypos + upos < dl->ypos + dl->descent - dl->clip) + { + if (dl->ypos + upos + uthick > dl->ypos + dl->descent - dl->clip) + uthick = dl->descent - dl->clip - upos; + + if (uthick == 1) + { + gdk_draw_line (GDK_DRAWABLE (x_win), gc, xpos, dl->ypos + upos, + xpos + this_width, dl->ypos + upos); + } + else if (uthick > 1) + { + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, TRUE, xpos, + dl->ypos + upos, this_width, uthick); + } + } + } + + if (cachel->strikethru) { + unsigned long ascent,descent,upos, uthick; + GdkFont *gfont = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (font)); + + /* Cannot get at font properties in Gtk, so we resort to + guessing */ + + ascent = gfont->ascent; + descent = gfont->descent; + uthick = 1; + + upos = ascent - ((ascent + descent) / 2) + 1; + + /* Generally, upos will be positive (above the baseline),so subtract */ + if (dl->ypos - upos < dl->ypos + dl->descent - dl->clip) + { + if (dl->ypos - upos + uthick > dl->ypos + dl->descent - dl->clip) + uthick = dl->descent - dl->clip + upos; + + if (uthick == 1) + { + gdk_draw_line (GDK_DRAWABLE (x_win), gc, xpos, dl->ypos - upos, + xpos + this_width, dl->ypos - upos); + } + else if (uthick > 1) + { + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, TRUE, xpos, dl->ypos + upos, + this_width, uthick); + } + } + } + + /* Restore the GC */ + if (need_clipping) + { + gdk_gc_set_clip_rectangle (gc, NULL); + gdk_gc_set_clip_origin (gc, 0, 0); + } + + /* If we are actually superimposing the cursor then redraw with just + the appropriate section highlighted. */ + if (cursor_clip && !cursor && focus && cursor_cachel) + { + GdkGC *cgc; + GdkRectangle clip_box; + + cgc = gtk_get_gc (d, font, cursor_cachel->foreground, + cursor_cachel->background, Qnil, Qnil); + + clip_box.x = 0; + clip_box.y = 0; + clip_box.width = cursor_width; + clip_box.height = height; + + gdk_gc_set_clip_rectangle (cgc, &clip_box); + gdk_gc_set_clip_origin (cgc, cursor_start, dl->ypos - dl->ascent); + + /* The X specific called different functions (XDraw*String + vs. XDraw*String16), but apparently gdk_draw_text takes care + of that for us. + + BUT, gdk_draw_text also does too much, by dividing the + length by 2. So we fake them out my multiplying the + length by the dimension of the text. This will do the + right thing for single-dimension runs as well of course. + */ + gdk_draw_text_image (GDK_DRAWABLE (x_win), gdk_font, cgc, xpos, + dl->ypos, (char *) runs[i].ptr, + runs[i].len * runs[i].dimension); + + gdk_gc_set_clip_rectangle (cgc, NULL); + gdk_gc_set_clip_origin (cgc, 0, 0); + } + + xpos += this_width; + } + + /* Draw the non-focus box or bar-cursor as needed. */ + /* Can't this logic be simplified? */ + if (cursor_cachel + && ((cursor && !focus && NILP (bar_cursor_value)) + || (cursor_width + && (cursor_start + cursor_width >= clip_start) + && !NILP (bar_cursor_value)))) + { + int tmp_height, tmp_y; + int bar_width = EQ (bar_cursor_value, Qt) ? 1 : 2; + int need_clipping = (cursor_start < clip_start + || clip_end < cursor_start + cursor_width); + + /* #### This value is correct (as far as I know) because + all of the times we need to draw this cursor, we will + be called with exactly one character, so we know we + can always use runs[0]. + + This is bogus as all hell, however. The cursor handling in + this function is way bogus and desperately needs to be + cleaned up. (In particular, the drawing of the cursor should + really really be separated out of this function. This may be + a bit tricky now because this function itself does way too + much stuff, a lot of which needs to be moved into + redisplay.c) This is the only way to be able to easily add + new cursor types or (e.g.) make the bar cursor be able to + span two characters instead of overlaying just one. */ + int bogusly_obtained_ascent_value = + XFONT_INSTANCE (FACE_CACHEL_FONT (cachel, runs[0].charset))->ascent; + + if (!NILP (bar_cursor_value)) + { + gc = gtk_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, + make_int (bar_width)); + } + else + { + gc = gtk_get_gc (d, Qnil, cursor_cachel->background, + Qnil, Qnil, Qnil); + } + + tmp_y = dl->ypos - bogusly_obtained_ascent_value; + tmp_height = cursor_height; + if (tmp_y + tmp_height > (int) (dl->ypos - dl->ascent + height)) + { + tmp_y = dl->ypos - dl->ascent + height - tmp_height; + if (tmp_y < (int) (dl->ypos - dl->ascent)) + tmp_y = dl->ypos - dl->ascent; + tmp_height = dl->ypos - dl->ascent + height - tmp_y; + } + + if (need_clipping) + { + GdkRectangle clip_box; + clip_box.x = 0; + clip_box.y = 0; + clip_box.width = clip_end - clip_start; + clip_box.height = tmp_height; + + gdk_gc_set_clip_rectangle (gc, &clip_box); + gdk_gc_set_clip_origin (gc, clip_start, tmp_y); + } + + if (!focus && NILP (bar_cursor_value)) + { + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, FALSE, + cursor_start, tmp_y, + cursor_width - 1, tmp_height - 1); + } + else if (focus && !NILP (bar_cursor_value)) + { + gdk_draw_line (GDK_DRAWABLE (x_win), gc, + cursor_start + bar_width - 1, tmp_y, + cursor_start + bar_width - 1, tmp_y + tmp_height - 1); + } + + /* Restore the GC */ + if (need_clipping) + { + gdk_gc_set_clip_rectangle (gc, NULL); + gdk_gc_set_clip_origin (gc, 0, 0); + } + } +} + +static void +our_draw_bitmap (GdkDrawable *drawable, + GdkGC *gc, + GdkPixmap *src, + gint xsrc, + gint ysrc, + gint xdest, + gint ydest, + gint width, + gint height); + +void +gtk_output_gdk_pixmap (struct frame *f, struct Lisp_Image_Instance *p, int x, + int y, int clip_x, int clip_y, int clip_width, + int clip_height, int width, int height, int pixmap_offset, + GdkColor *fg, GdkColor *bg, GdkGC *override_gc) +{ + struct device *d = XDEVICE (f->device); + GdkWindow *x_win = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)); + + GdkGC *gc; + GdkGCValues gcv; + unsigned long pixmap_mask; + int need_clipping = (clip_x || clip_y); + + if (!override_gc) + { + memset (&gcv, ~0, sizeof (gcv)); + gcv.graphics_exposures = FALSE; + gcv.foreground = *fg; + gcv.background = *bg; + pixmap_mask = GDK_GC_FOREGROUND | GDK_GC_BACKGROUND | GDK_GC_EXPOSURES; + + if (IMAGE_INSTANCE_GTK_MASK (p)) + { + gcv.function = GDK_COPY; + gcv.clip_mask = IMAGE_INSTANCE_GTK_MASK (p); + gcv.clip_x_origin = x; + gcv.clip_y_origin = y - pixmap_offset; + pixmap_mask |= (GDK_GC_FUNCTION | GDK_GC_CLIP_MASK | GDK_GC_CLIP_X_ORIGIN | + GDK_GC_CLIP_Y_ORIGIN); + /* Can't set a clip rectangle below because we already have a mask. + We could conceivably create a new clipmask by zeroing out + everything outside the clip region. Is it worth it? + Is it possible to get an equivalent effect by changing the + args to XCopyArea below rather than messing with a clip box? + - dkindred@cs.cmu.edu */ + need_clipping = 0; + } + + gc = gc_cache_lookup (DEVICE_GTK_GC_CACHE (d), &gcv, pixmap_mask); + } + else + { + gc = override_gc; + /* override_gc might have a mask already--we don't want to nuke it. + Maybe we can insist that override_gc have no mask, or use + one of the suggestions above. */ + need_clipping = 0; + } + + if (need_clipping) + { + GdkRectangle clip_box; + + clip_box.x = clip_x; + clip_box.y = clip_y; + clip_box.width = clip_width; + clip_box.height = clip_height; + + gdk_gc_set_clip_rectangle (gc, &clip_box); + gdk_gc_set_clip_origin (gc, x, y); + } + + if (IMAGE_INSTANCE_PIXMAP_DEPTH (p) > 0) + { + gdk_draw_pixmap (GDK_DRAWABLE (x_win), gc, + IMAGE_INSTANCE_GTK_PIXMAP (p), + 0, pixmap_offset, x, y, width, height); + } + else + { + our_draw_bitmap (GDK_DRAWABLE (x_win), gc, + IMAGE_INSTANCE_GTK_PIXMAP (p), + 0, pixmap_offset, x, y, width, height); + } + + if (need_clipping) + { + gdk_gc_set_clip_rectangle (gc, NULL); + gdk_gc_set_clip_origin (gc, 0, 0); + } +} + +static void +gtk_output_pixmap (struct window *w, struct display_line *dl, + Lisp_Object image_instance, int xpos, int xoffset, + int start_pixpos, int width, face_index findex, + int cursor_start, int cursor_width, int cursor_height) +{ + struct frame *f = XFRAME (w->frame); + struct device *d = XDEVICE (f->device); + struct Lisp_Image_Instance *p = XIMAGE_INSTANCE (image_instance); + Lisp_Object window; + + GdkWindow *x_win = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)); + int lheight = dl->ascent + dl->descent - dl->clip; + int pheight = ((int) IMAGE_INSTANCE_PIXMAP_HEIGHT (p) > lheight ? lheight : + IMAGE_INSTANCE_PIXMAP_HEIGHT (p)); + int pwidth = min (width + xoffset, (int) IMAGE_INSTANCE_PIXMAP_WIDTH (p)); + int clip_x, clip_y, clip_width, clip_height; + + /* The pixmap_offset is used to center the pixmap on lines which are + shorter than it is. This results in odd effects when scrolling + pixmaps off of the bottom. Let's try not using it. */ +#if 0 + int pixmap_offset = (int) (IMAGE_INSTANCE_PIXMAP_HEIGHT (p) - lheight) / 2; +#else + int pixmap_offset = 0; +#endif + + XSETWINDOW (window, w); + + if ((start_pixpos >= 0 && start_pixpos > xpos) || xoffset) + { + if (start_pixpos > xpos && start_pixpos > xpos + width) + return; + + clip_x = xoffset; + clip_width = width; + if (start_pixpos > xpos) + { + clip_x += (start_pixpos - xpos); + clip_width -= (start_pixpos - xpos); + } + } + else + { + clip_x = 0; + clip_width = 0; + } + + /* Place markers for possible future functionality (clipping the top + half instead of the bottom half; think pixel scrolling). */ + clip_y = 0; + clip_height = pheight; + + /* Clear the area the pixmap is going into. The pixmap itself will + always take care of the full width. We don't want to clear where + it is going to go in order to avoid flicker. So, all we have to + take care of is any area above or below the pixmap. */ + /* #### We take a shortcut for now. We know that since we have + pixmap_offset hardwired to 0 that the pixmap is against the top + edge so all we have to worry about is below it. */ + /* #### Unless the pixmap has a mask in which case we have to clear + the whole damn thing since we can't yet clear just the area not + included in the mask. */ + if (((int) (dl->ypos - dl->ascent + pheight) < + (int) (dl->ypos + dl->descent - dl->clip)) + || IMAGE_INSTANCE_GTK_MASK (p)) + { + int clear_x, clear_y, clear_width, clear_height; + + if (IMAGE_INSTANCE_GTK_MASK (p)) + { + clear_y = dl->ypos - dl->ascent; + clear_height = lheight; + } + else + { + clear_y = dl->ypos - dl->ascent + pheight; + clear_height = lheight - pheight; + } + + if (start_pixpos >= 0 && start_pixpos > xpos) + { + clear_x = start_pixpos; + clear_width = xpos + width - start_pixpos; + } + else + { + clear_x = xpos; + clear_width = width; + } + + redisplay_clear_region (window, findex, clear_x, clear_y, + clear_width, clear_height); + } + + /* Output the pixmap. */ + { + Lisp_Object tmp_pixel; + GdkColor *tmp_bcolor, *tmp_fcolor; + + tmp_pixel = WINDOW_FACE_CACHEL_FOREGROUND (w, findex); + tmp_fcolor = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (tmp_pixel)); + tmp_pixel = WINDOW_FACE_CACHEL_BACKGROUND (w, findex); + tmp_bcolor = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (tmp_pixel)); + + gtk_output_gdk_pixmap (f, p, xpos - xoffset, dl->ypos - dl->ascent, clip_x, + clip_y, clip_width, clip_height, + pwidth, pheight, pixmap_offset, + tmp_fcolor, tmp_bcolor, 0); + } + + /* Draw a cursor over top of the pixmap. */ + if (cursor_width && cursor_height && (cursor_start >= xpos) + && !NILP (w->text_cursor_visible_p) + && (cursor_start < xpos + pwidth)) + { + GdkGC *gc; + int focus = EQ (w->frame, DEVICE_FRAME_WITH_FOCUS_REAL (d)); + int y = dl->ypos - dl->ascent; + struct face_cachel *cursor_cachel = + WINDOW_FACE_CACHEL (w, + get_builtin_face_cache_index + (w, Vtext_cursor_face)); + + gc = gtk_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, Qnil); + + if (cursor_width > xpos + pwidth - cursor_start) + cursor_width = xpos + pwidth - cursor_start; + + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, focus ? TRUE : FALSE, + cursor_start, y, cursor_width, + cursor_height); + } +} + +/***************************************************************************** + gtk_output_vertical_divider + + Draw a vertical divider down the right side of the given window. + ****************************************************************************/ +static void +gtk_output_vertical_divider (struct window *w, int clear) +{ + struct frame *f = XFRAME (w->frame); + struct device *d = XDEVICE (f->device); + GdkWindow *x_win = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)); + GdkGC *background_gc; + Lisp_Object tmp_pixel; + GdkGCValues gcv; + unsigned long mask; + int x, y1, y2, width, shadow_thickness, spacing, line_width; + face_index div_face = get_builtin_face_cache_index (w, Vvertical_divider_face); + + width = window_divider_width (w); + shadow_thickness = XINT (w->vertical_divider_shadow_thickness); + spacing = XINT (w->vertical_divider_spacing); + line_width = XINT (w->vertical_divider_line_width); + x = WINDOW_RIGHT (w) - width; + y1 = WINDOW_TOP (w); + y2 = WINDOW_BOTTOM (w); + + memset (&gcv, ~0, sizeof (gcv)); + + tmp_pixel = WINDOW_FACE_CACHEL_BACKGROUND (w, div_face); + + gcv.background = * COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (tmp_pixel)); + gcv.foreground = gcv.background; + gcv.graphics_exposures = FALSE; + mask = GDK_GC_FOREGROUND | GDK_GC_BACKGROUND | GDK_GC_EXPOSURES; + + background_gc = gc_cache_lookup (DEVICE_GTK_GC_CACHE (d), &gcv, mask); + + /* Clear the divider area first. This needs to be done when a + window split occurs. */ + /* if (clear) */ + gdk_draw_rectangle (GDK_DRAWABLE (x_win), background_gc, TRUE, + x, y1, width, y2 - y1); + +#if 0 + /* Draw the divider line. */ + gdk_draw_rectangle (GDK_DRAWABLE (x_win), background_gc, TRUE, + x + spacing + shadow_thickness, y1, + line_width, y2 - y1); +#endif + + /* Draw the shadows around the divider line */ + gtk_output_shadows (f, x + spacing, y1, + width - 2 * spacing, y2 - y1, + shadow_thickness); +} + +/***************************************************************************** + gtk_output_blank + + Output a blank by clearing the area it covers in the foreground color + of its face. + ****************************************************************************/ +static void +gtk_output_blank (struct window *w, struct display_line *dl, struct rune *rb, + int start_pixpos, int cursor_start, int cursor_width) +{ + struct frame *f = XFRAME (w->frame); + struct device *d = XDEVICE (f->device); + + GdkWindow *x_win = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)); + GdkGC *gc; + struct face_cachel *cursor_cachel = + WINDOW_FACE_CACHEL (w, + get_builtin_face_cache_index + (w, Vtext_cursor_face)); + Lisp_Object bg_pmap; + Lisp_Object buffer = WINDOW_BUFFER (w); + Lisp_Object bar_cursor_value = symbol_value_in_buffer (Qbar_cursor, + buffer); + + int x = rb->xpos; + int y = dl->ypos - dl->ascent; + int width = rb->width; + int height = dl->ascent + dl->descent - dl->clip; + + if (start_pixpos > x) + { + if (start_pixpos >= (x + width)) + return; + else + { + width -= (start_pixpos - x); + x = start_pixpos; + } + } + + bg_pmap = WINDOW_FACE_CACHEL_BACKGROUND_PIXMAP (w, rb->findex); + if (!IMAGE_INSTANCEP (bg_pmap) + || !IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (bg_pmap))) + bg_pmap = Qnil; + + if (NILP (bg_pmap)) + gc = gtk_get_gc (d, Qnil, WINDOW_FACE_CACHEL_BACKGROUND (w, rb->findex), + Qnil, Qnil, Qnil); + else + gc = gtk_get_gc (d, Qnil, WINDOW_FACE_CACHEL_FOREGROUND (w, rb->findex), + WINDOW_FACE_CACHEL_BACKGROUND (w, rb->findex), bg_pmap, + Qnil); + + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, TRUE, x, y, width, height); + + /* If this rune is marked as having the cursor, then it is actually + representing a tab. */ + if (!NILP (w->text_cursor_visible_p) + && (rb->cursor_type == CURSOR_ON + || (cursor_width + && (cursor_start + cursor_width > x) + && cursor_start < (x + width)))) + { + int cursor_height, cursor_y; + int focus = EQ (w->frame, DEVICE_FRAME_WITH_FOCUS_REAL (d)); + struct Lisp_Font_Instance *fi; + + fi = XFONT_INSTANCE (FACE_CACHEL_FONT + (WINDOW_FACE_CACHEL (w, rb->findex), + Vcharset_ascii)); + + gc = gtk_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, Qnil); + + cursor_y = dl->ypos - fi->ascent; + cursor_height = fi->height; + if (cursor_y + cursor_height > y + height) + cursor_height = y + height - cursor_y; + + if (focus) + { + if (NILP (bar_cursor_value)) + { + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, TRUE, + cursor_start, cursor_y, + fi->width, cursor_height); + } + else + { + int bar_width = EQ (bar_cursor_value, Qt) ? 1 : 2; + + gc = gtk_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, + make_int (bar_width)); + gdk_draw_line (GDK_DRAWABLE (x_win), gc, cursor_start + bar_width - 1, + cursor_y, cursor_start + bar_width - 1, + cursor_y + cursor_height - 1); + } + } + else if (NILP (bar_cursor_value)) + { + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, FALSE, + cursor_start, cursor_y, + fi->width - 1, cursor_height - 1); + } + } +} + +/***************************************************************************** + gtk_output_hline + + Output a horizontal line in the foreground of its face. + ****************************************************************************/ +static void +gtk_output_hline (struct window *w, struct display_line *dl, struct rune *rb) +{ + struct frame *f = XFRAME (w->frame); + struct device *d = XDEVICE (f->device); + GtkStyle *style = FRAME_GTK_TEXT_WIDGET (f)->style; + + GdkWindow *x_win = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)); + GdkGC *gc; + + int x = rb->xpos; + int width = rb->width; + int height = dl->ascent + dl->descent - dl->clip; + + int ypos1, ypos2, ypos3, ypos4; + + ypos1 = dl->ypos - dl->ascent; + ypos2 = ypos1 + rb->object.hline.yoffset; + ypos3 = ypos2 + rb->object.hline.thickness; + ypos4 = dl->ypos + dl->descent - dl->clip; + + /* First clear the area not covered by the line. */ + if (height - rb->object.hline.thickness > 0) + { + gc = gtk_get_gc (d, Qnil, WINDOW_FACE_CACHEL_FOREGROUND (w, rb->findex), + Qnil, Qnil, Qnil); + + if (ypos2 - ypos1 > 0) + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, TRUE, x, ypos1, width, ypos2 - ypos1); + if (ypos4 - ypos3 > 0) + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, TRUE, x, ypos1, width, ypos2 - ypos1); + } + + gtk_paint_hline (style, x_win, GTK_STATE_NORMAL, NULL, FRAME_GTK_TEXT_WIDGET (f), + "hline", x, x + width, ypos2); +#if 0 + /* Now draw the line. */ + gc = gtk_get_gc (d, Qnil, WINDOW_FACE_CACHEL_BACKGROUND (w, rb->findex), + Qnil, Qnil, Qnil); + + if (ypos2 < ypos1) + ypos2 = ypos1; + if (ypos3 > ypos4) + ypos3 = ypos4; + + if (ypos3 - ypos2 > 0) + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, TRUE, x, ypos2, width, ypos3 - ypos2); +#endif +} + +/***************************************************************************** + gtk_output_shadows + + Draw a shadow around the given area using the standard theme engine routines. + ****************************************************************************/ +void +gtk_output_shadows (struct frame *f, int x, int y, int width, int height, + int shadow_thickness) +{ + GdkWindow *x_win = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)); + GtkStyle *style = FRAME_GTK_TEXT_WIDGET (f)->style; + GtkShadowType stype = GTK_SHADOW_OUT; + + if (shadow_thickness < 0) + { + stype = GTK_SHADOW_IN; + } + else if (shadow_thickness == 0) + { + stype = GTK_SHADOW_NONE; + } + + /* Do we want to have some magic constants to set + GTK_SHADOW_ETCHED_IN or GTK_SHADOW_ETCHED_OUT? */ + + gtk_paint_shadow (style, x_win, GTK_STATE_NORMAL, stype, NULL, + FRAME_GTK_TEXT_WIDGET (f), "modeline", + x, y, width, height); +} + +/***************************************************************************** + gtk_clear_to_window_end + + Clear the area between ypos1 and ypos2. Each margin area and the + text area is handled separately since they may each have their own + background color. + ****************************************************************************/ +static void +gtk_clear_to_window_end (struct window *w, int ypos1, int ypos2) +{ + int height = ypos2 - ypos1; + + if (height) + { + struct frame *f = XFRAME (w->frame); + Lisp_Object window; + int bflag = (window_needs_vertical_divider (w) ? 0 : 1); + layout_bounds bounds; + + bounds = calculate_display_line_boundaries (w, bflag); + XSETWINDOW (window, w); + + if (window_is_leftmost (w)) + redisplay_clear_region (window, DEFAULT_INDEX, FRAME_LEFT_BORDER_START (f), + ypos1, FRAME_BORDER_WIDTH (f), height); + + if (bounds.left_in - bounds.left_out > 0) + redisplay_clear_region (window, + get_builtin_face_cache_index (w, Vleft_margin_face), + bounds.left_out, ypos1, + bounds.left_in - bounds.left_out, height); + + if (bounds.right_in - bounds.left_in > 0) + redisplay_clear_region (window, DEFAULT_INDEX, bounds.left_in, ypos1, + bounds.right_in - bounds.left_in, height); + + if (bounds.right_out - bounds.right_in > 0) + redisplay_clear_region (window, + get_builtin_face_cache_index (w, Vright_margin_face), + bounds.right_in, ypos1, + bounds.right_out - bounds.right_in, height); + + if (window_is_rightmost (w)) + redisplay_clear_region (window, DEFAULT_INDEX, FRAME_RIGHT_BORDER_START (f), + ypos1, FRAME_BORDER_WIDTH (f), height); + } +} + +/***************************************************************************** + gtk_redraw_exposed_window + + Given a bounding box for an area that needs to be redrawn, determine + what parts of what lines are contained within and re-output their + contents. + ****************************************************************************/ +static void +gtk_redraw_exposed_window (struct window *w, int x, int y, int width, int height) +{ + struct frame *f = XFRAME (w->frame); + int line; + int start_x, start_y, end_x, end_y; + int orig_windows_structure_changed; + + display_line_dynarr *cdla = window_display_lines (w, CURRENT_DISP); + + if (!NILP (w->vchild)) + { + gtk_redraw_exposed_windows (w->vchild, x, y, width, height); + return; + } + else if (!NILP (w->hchild)) + { + gtk_redraw_exposed_windows (w->hchild, x, y, width, height); + return; + } + + /* If the window doesn't intersect the exposed region, we're done here. */ + if (x >= WINDOW_RIGHT (w) || (x + width) <= WINDOW_LEFT (w) + || y >= WINDOW_BOTTOM (w) || (y + height) <= WINDOW_TOP (w)) + { + return; + } + else + { + start_x = max (WINDOW_LEFT (w), x); + end_x = min (WINDOW_RIGHT (w), (x + width)); + start_y = max (WINDOW_TOP (w), y); + end_y = min (WINDOW_BOTTOM (w), y + height); + + /* We do this to make sure that the 3D modelines get redrawn if + they are in the exposed region. */ + orig_windows_structure_changed = f->windows_structure_changed; + f->windows_structure_changed = 1; + } + + if (window_needs_vertical_divider (w)) + { + gtk_output_vertical_divider (w, 0); + } + + for (line = 0; line < Dynarr_length (cdla); line++) + { + struct display_line *cdl = Dynarr_atp (cdla, line); + int top_y = cdl->ypos - cdl->ascent; + int bottom_y = cdl->ypos + cdl->descent; + + if (bottom_y >= start_y) + { + if (top_y > end_y) + { + if (line == 0) + continue; + else + break; + } + else + { + output_display_line (w, 0, cdla, line, start_x, end_x); + } + } + } + + f->windows_structure_changed = orig_windows_structure_changed; + + /* If there have never been any face cache_elements created, then this + expose event doesn't actually have anything to do. */ + if (Dynarr_largest (w->face_cachels)) + redisplay_clear_bottom_of_window (w, cdla, start_y, end_y); +} + +/***************************************************************************** + gtk_redraw_exposed_windows + + For each window beneath the given window in the window hierarchy, + ensure that it is redrawn if necessary after an Expose event. + ****************************************************************************/ +static void +gtk_redraw_exposed_windows (Lisp_Object window, int x, int y, int width, + int height) +{ + for (; !NILP (window); window = XWINDOW (window)->next) + gtk_redraw_exposed_window (XWINDOW (window), x, y, width, height); +} + +/***************************************************************************** + gtk_redraw_exposed_area + + For each window on the given frame, ensure that any area in the + Exposed area is redrawn. + ****************************************************************************/ +void +gtk_redraw_exposed_area (struct frame *f, int x, int y, int width, int height) +{ + /* If any window on the frame has had its face cache reset then the + redisplay structures are effectively invalid. If we attempt to + use them we'll blow up. We mark the frame as changed to ensure + that redisplay will do a full update. This probably isn't + necessary but it can't hurt. */ + +#ifdef HAVE_TOOLBARS + /* #### We would rather put these off as well but there is currently + no combination of flags which will force an unchanged toolbar to + redraw anyhow. */ + MAYBE_FRAMEMETH (f, redraw_exposed_toolbars, (f, x, y, width, height)); +#endif + redraw_exposed_gutters (f, x, y, width, height); + + if (!f->window_face_cache_reset) + { + gtk_redraw_exposed_windows (f->root_window, x, y, width, height); + } + else + MARK_FRAME_CHANGED (f); +} + +/**************************************************************************** + gtk_clear_region + + Clear the area in the box defined by the given parameters using the + given face. + ****************************************************************************/ +static void +gtk_clear_region (Lisp_Object locale, struct device* d, struct frame* f, face_index findex, + int x, int y, + int width, int height, Lisp_Object fcolor, Lisp_Object bcolor, + Lisp_Object background_pixmap) +{ + GdkWindow *x_win; + GdkGC *gc = NULL; + + x_win = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)); + + if (!UNBOUNDP (background_pixmap)) + { + gc = gtk_get_gc (d, Qnil, fcolor, bcolor, background_pixmap, Qnil); + } + + if (gc) + { + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc,TRUE, + x, y, width, height); + } + else + { + gdk_window_clear_area (x_win, x, y, width, height); + } +} + +/***************************************************************************** + gtk_output_eol_cursor + + Draw a cursor at the end of a line. The end-of-line cursor is + narrower than the normal cursor. + ****************************************************************************/ +static void +gtk_output_eol_cursor (struct window *w, struct display_line *dl, int xpos, + face_index findex) +{ + struct frame *f = XFRAME (w->frame); + struct device *d = XDEVICE (f->device); + Lisp_Object window; + + GdkWindow *x_win = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)); + GdkGC *gc; + face_index elt = get_builtin_face_cache_index (w, Vtext_cursor_face); + struct face_cachel *cursor_cachel = WINDOW_FACE_CACHEL (w, elt); + + int focus = EQ (w->frame, DEVICE_FRAME_WITH_FOCUS_REAL (d)); + Lisp_Object bar_cursor_value = symbol_value_in_buffer (Qbar_cursor, + WINDOW_BUFFER (w)); + + int x = xpos; + int y = dl->ypos - dl->ascent; + int width = EOL_CURSOR_WIDTH; + int height = dl->ascent + dl->descent - dl->clip; + int cursor_height, cursor_y; + int defheight, defascent; + + XSETWINDOW (window, w); + redisplay_clear_region (window, findex, x, y, width, height); + + if (NILP (w->text_cursor_visible_p)) + return; + + gc = gtk_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, Qnil); + + default_face_font_info (window, &defascent, 0, &defheight, 0, 0); + + /* make sure the cursor is entirely contained between y and y+height */ + cursor_height = min (defheight, height); + cursor_y = max (y, min (y + height - cursor_height, + dl->ypos - defascent)); + + if (focus) + { + if (NILP (bar_cursor_value)) + { + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, TRUE, x, cursor_y, width, cursor_height); + } + else + { + int bar_width = EQ (bar_cursor_value, Qt) ? 1 : 2; + + gc = gtk_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, + make_int (bar_width)); + gdk_draw_line (GDK_DRAWABLE (x_win), gc, x + bar_width - 1, cursor_y, + x + bar_width - 1, cursor_y + cursor_height - 1); + } + } + else if (NILP (bar_cursor_value)) + { + gdk_draw_rectangle (GDK_DRAWABLE (x_win), gc, FALSE, x, cursor_y, width - 1, + cursor_height - 1); + } +} + +static void +gtk_clear_frame_window (Lisp_Object window) +{ + struct window *w = XWINDOW (window); + + if (!NILP (w->vchild)) + { + gtk_clear_frame_windows (w->vchild); + return; + } + + if (!NILP (w->hchild)) + { + gtk_clear_frame_windows (w->hchild); + return; + } + + gtk_clear_to_window_end (w, WINDOW_TEXT_TOP (w), WINDOW_TEXT_BOTTOM (w)); +} + +static void +gtk_clear_frame_windows (Lisp_Object window) +{ + for (; !NILP (window); window = XWINDOW (window)->next) + gtk_clear_frame_window (window); +} + +static void +gtk_clear_frame (struct frame *f) +{ + GdkWindow *x_win = GET_GTK_WIDGET_WINDOW (FRAME_GTK_TEXT_WIDGET (f)); + int x, y, width, height; + Lisp_Object frame; + + x = FRAME_LEFT_BORDER_START (f); + width = (FRAME_PIXWIDTH (f) - FRAME_REAL_LEFT_TOOLBAR_WIDTH (f) - + FRAME_REAL_RIGHT_TOOLBAR_WIDTH (f) - + 2 * FRAME_REAL_LEFT_TOOLBAR_BORDER_WIDTH (f) - + 2 * FRAME_REAL_RIGHT_TOOLBAR_BORDER_WIDTH (f)); + /* #### This adjustment by 1 should be being done in the macros. + There is some small differences between when the menubar is on + and off that we still need to deal with. */ + y = FRAME_TOP_BORDER_START (f) - 1; + height = (FRAME_PIXHEIGHT (f) - FRAME_REAL_TOP_TOOLBAR_HEIGHT (f) - + FRAME_REAL_BOTTOM_TOOLBAR_HEIGHT (f) - + 2 * FRAME_REAL_TOP_TOOLBAR_BORDER_WIDTH (f) - + 2 * FRAME_REAL_BOTTOM_TOOLBAR_BORDER_WIDTH (f)) + 1; + + gdk_window_clear_area (x_win, x, y, width, height); + + XSETFRAME (frame, f); + + if (!UNBOUNDP (FACE_BACKGROUND_PIXMAP (Vdefault_face, frame)) + || !UNBOUNDP (FACE_BACKGROUND_PIXMAP (Vleft_margin_face, frame)) + || !UNBOUNDP (FACE_BACKGROUND_PIXMAP (Vright_margin_face, frame))) + { + gtk_clear_frame_windows (f->root_window); + } +} + +static int +gtk_flash (struct device *d) +{ + GdkGCValues gcv; + GdkGC *gc; + GdkColor tmp_fcolor, tmp_bcolor; + Lisp_Object tmp_pixel, frame; + struct frame *f = device_selected_frame (d); + struct window *w = XWINDOW (FRAME_ROOT_WINDOW (f)); + + XSETFRAME (frame, f); + + tmp_pixel = FACE_FOREGROUND (Vdefault_face, frame); + tmp_fcolor = * (COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (tmp_pixel))); + tmp_pixel = FACE_BACKGROUND (Vdefault_face, frame); + tmp_bcolor = * (COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (tmp_pixel))); + + memset (&gcv, ~0, sizeof (gcv)); /* initialize all slots to ~0 */ + gcv.foreground.pixel = (tmp_fcolor.pixel ^ tmp_bcolor.pixel); + gcv.function = GDK_XOR; + gcv.graphics_exposures = FALSE; + gc = gc_cache_lookup (DEVICE_GTK_GC_CACHE (XDEVICE (f->device)), &gcv, + GDK_GC_FOREGROUND | GDK_GC_FUNCTION | GDK_GC_EXPOSURES); + + gdk_draw_rectangle (GDK_DRAWABLE (GET_GTK_WIDGET_WINDOW (FRAME_GTK_SHELL_WIDGET (f))), + gc, TRUE, w->pixel_left, w->pixel_top, + w->pixel_width, w->pixel_height); + + gdk_flush (); + +#ifdef HAVE_POLL + poll (0, 0, 100); +#else /* !HAVE_POLL */ +#ifdef HAVE_SELECT + { + int usecs = 100000; + struct timeval tv; + tv.tv_sec = usecs / 1000000L; + tv.tv_usec = usecs % 1000000L; + /* I'm sure someone is going to complain about this... */ + select (0, 0, 0, 0, &tv); + } +#else + bite me +#endif /* HAVE_POLL */ +#endif /* HAVE_SELECT */ + + gdk_draw_rectangle (GDK_DRAWABLE (GET_GTK_WIDGET_WINDOW (FRAME_GTK_SHELL_WIDGET (f))), + gc, TRUE, w->pixel_left, w->pixel_top, + w->pixel_width, w->pixel_height); + + gdk_flush (); + + return 1; +} + +static void +gtk_bevel_area (struct window *w, face_index findex, + int x, int y, int width, int height, + int shadow_thickness, int edges, enum edge_style style) +{ + struct frame *f = XFRAME (w->frame); + struct device *d = XDEVICE (f->device); + + gtk_output_shadows (f, x, y, width, height, shadow_thickness); +} + + + +/* Make audible bell. */ +static void +gtk_ring_bell (struct device *d, int volume, int pitch, int duration) +{ + /* Gdk does not allow us to control the duration / pitch / volume */ + gdk_beep (); +} + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +console_type_create_redisplay_gtk (void) +{ + /* redisplay methods */ + CONSOLE_HAS_METHOD (gtk, text_width); + CONSOLE_HAS_METHOD (gtk, output_display_block); + CONSOLE_HAS_METHOD (gtk, divider_height); + CONSOLE_HAS_METHOD (gtk, eol_cursor_width); + CONSOLE_HAS_METHOD (gtk, output_vertical_divider); + CONSOLE_HAS_METHOD (gtk, clear_to_window_end); + CONSOLE_HAS_METHOD (gtk, clear_region); + CONSOLE_HAS_METHOD (gtk, clear_frame); + CONSOLE_HAS_METHOD (gtk, flash); + CONSOLE_HAS_METHOD (gtk, ring_bell); + CONSOLE_HAS_METHOD (gtk, bevel_area); + CONSOLE_HAS_METHOD (gtk, output_string); + /* CONSOLE_HAS_METHOD (gtk, output_pixmap); */ +} + +/* This makes me feel incredibly dirty... but there is no other way to + get this done right other than calling clear_area before every + single $#!%@ing piece of text, which I do NOT want to do. */ +#define USE_X_SPECIFIC_DRAW_ROUTINES 1 + +#include + +void +gdk_draw_text_image (GdkDrawable *drawable, + GdkFont *font, + GdkGC *gc, + gint x, + gint y, + const gchar *text, + gint text_length) +{ +#if !USE_X_SPECIFIC_DRAW_ROUTINES + int width = gdk_text_measure (font, text, text_length); + int height = gdk_text_height (font, text, text_length); + + gdk_draw_rectangle (drawable, gc, TRUE, x, y, width, height); + gdk_draw_text (drawable, font, gc, x, y, text, text_length); +#else + GdkWindowPrivate *drawable_private; + GdkFontPrivate *font_private; + GdkGCPrivate *gc_private; + + g_return_if_fail (drawable != NULL); + g_return_if_fail (font != NULL); + g_return_if_fail (gc != NULL); + g_return_if_fail (text != NULL); + + drawable_private = (GdkWindowPrivate*) drawable; + if (drawable_private->destroyed) + return; + gc_private = (GdkGCPrivate*) gc; + font_private = (GdkFontPrivate*) font; + + if (font->type == GDK_FONT_FONT) + { + XFontStruct *xfont = (XFontStruct *) font_private->xfont; + XSetFont(drawable_private->xdisplay, gc_private->xgc, xfont->fid); + if ((xfont->min_byte1 == 0) && (xfont->max_byte1 == 0)) + { + XDrawImageString (drawable_private->xdisplay, drawable_private->xwindow, + gc_private->xgc, x, y, text, text_length); + } + else + { + XDrawImageString16 (drawable_private->xdisplay, drawable_private->xwindow, + gc_private->xgc, x, y, (XChar2b *) text, text_length / 2); + } + } + else if (font->type == GDK_FONT_FONTSET) + { + XFontSet fontset = (XFontSet) font_private->xfont; + XmbDrawImageString (drawable_private->xdisplay, drawable_private->xwindow, + fontset, gc_private->xgc, x, y, text, text_length); + } + else + g_error("undefined font type\n"); +#endif +} + +static void +our_draw_bitmap (GdkDrawable *drawable, + GdkGC *gc, + GdkPixmap *src, + gint xsrc, + gint ysrc, + gint xdest, + gint ydest, + gint width, + gint height) +{ + GdkWindowPrivate *drawable_private; + GdkWindowPrivate *src_private; + GdkGCPrivate *gc_private; + + g_return_if_fail (drawable != NULL); + g_return_if_fail (src != NULL); + g_return_if_fail (gc != NULL); + + drawable_private = (GdkWindowPrivate*) drawable; + src_private = (GdkWindowPrivate*) src; + if (drawable_private->destroyed || src_private->destroyed) + return; + gc_private = (GdkGCPrivate*) gc; + + if (width == -1) + width = src_private->width; + if (height == -1) + height = src_private->height; + + XCopyPlane (drawable_private->xdisplay, + src_private->xwindow, + drawable_private->xwindow, + gc_private->xgc, + xsrc, ysrc, + width, height, + xdest, ydest, 1L); +} diff --git a/src/scrollbar-gtk.c b/src/scrollbar-gtk.c new file mode 100644 index 0000000..c7247ff --- /dev/null +++ b/src/scrollbar-gtk.c @@ -0,0 +1,481 @@ +/* scrollbar implementation -- X interface. + Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + Copyright (C) 1994 Amdhal Corporation. + Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 1995 Darrell Kindred . + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ +/* Gtk version by William M. Perry */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "glyphs-gtk.h" +#include "gui-gtk.h" +#include "scrollbar-gtk.h" + +#include "frame.h" +#include "window.h" + +static gboolean scrollbar_cb (GtkAdjustment *adj, gpointer user_data); + +/* Used to prevent changing the size of the slider while drag + scrolling, under Motif. This is necessary because the Motif + scrollbar is incredibly stupid about updating the slider and causes + lots of flicker if it is done too often. */ +static int inhibit_slider_size_change; + +static int vertical_drag_in_progress; + + +/* A device method. */ +static int +gtk_inhibit_scrollbar_slider_size_change (void) +{ + return inhibit_slider_size_change; +} + +/* A device method. */ +static void +gtk_free_scrollbar_instance (struct scrollbar_instance *instance) +{ + if (SCROLLBAR_GTK_WIDGET (instance)) + { + gtk_widget_hide_all (SCROLLBAR_GTK_WIDGET (instance)); + gtk_widget_destroy (SCROLLBAR_GTK_WIDGET (instance)); + } + + if (instance->scrollbar_data) + xfree (instance->scrollbar_data); +} + +/* A device method. */ +static void +gtk_release_scrollbar_instance (struct scrollbar_instance *instance) +{ + /* It won't hurt to hide it all the time, will it? */ + gtk_widget_hide_all (SCROLLBAR_GTK_WIDGET (instance)); +} + +static gboolean +scrollbar_drag_hack_cb (GtkWidget *w, GdkEventButton *ev, gpointer v) +{ + vertical_drag_in_progress = (int) v; + inhibit_slider_size_change = (int) v; + return (FALSE); +} + +/* A device method. */ +static void +gtk_create_scrollbar_instance (struct frame *f, int vertical, + struct scrollbar_instance *instance) +{ + GtkAdjustment *adj = GTK_ADJUSTMENT (gtk_adjustment_new (0,0,0,0,0,0)); + GtkScrollbar *sb = NULL; + + /* initialize the X specific data section. */ + instance->scrollbar_data = xnew_and_zero (struct gtk_scrollbar_data); + + SCROLLBAR_GTK_ID (instance) = new_gui_id (); + SCROLLBAR_GTK_VDRAG_ORIG_VALUE (instance) = -1; + SCROLLBAR_GTK_LAST_VALUE (instance) = adj->value; + + gtk_object_set_data (GTK_OBJECT (adj), "xemacs::gui_id", (void *) SCROLLBAR_GTK_ID (instance)); + gtk_object_set_data (GTK_OBJECT (adj), "xemacs::frame", f); + gtk_object_set_data (GTK_OBJECT (adj), "xemacs::sb_instance", instance); + + sb = GTK_SCROLLBAR (vertical ? gtk_vscrollbar_new (adj) : gtk_hscrollbar_new (adj)); + SCROLLBAR_GTK_WIDGET (instance) = GTK_WIDGET (sb); + + gtk_signal_connect (GTK_OBJECT (adj),"value-changed", + GTK_SIGNAL_FUNC (scrollbar_cb), (gpointer) vertical); + + gtk_signal_connect (GTK_OBJECT (sb), "button-press-event", + GTK_SIGNAL_FUNC (scrollbar_drag_hack_cb), (gpointer) 1); + gtk_signal_connect (GTK_OBJECT (sb), "button-release-event", + GTK_SIGNAL_FUNC (scrollbar_drag_hack_cb), (gpointer) 0); + + gtk_fixed_put (GTK_FIXED (FRAME_GTK_TEXT_WIDGET (f)), SCROLLBAR_GTK_WIDGET (instance), 0, 0); + gtk_widget_hide (SCROLLBAR_GTK_WIDGET (instance)); +} + +#define UPDATE_DATA_FIELD(field) \ + if (new_##field >= 0 && \ + SCROLLBAR_GTK_POS_DATA (inst).field != new_##field) { \ + SCROLLBAR_GTK_POS_DATA (inst).field = new_##field; \ + inst->scrollbar_instance_changed = 1; \ + } + +/* A device method. */ +/* #### The -1 check is such a hack. */ +static void +gtk_update_scrollbar_instance_values (struct window *w, + struct scrollbar_instance *inst, + int new_line_increment, + int new_page_increment, + int new_minimum, int new_maximum, + int new_slider_size, + int new_slider_position, + int new_scrollbar_width, + int new_scrollbar_height, + int new_scrollbar_x, int new_scrollbar_y) +{ + UPDATE_DATA_FIELD (line_increment); + UPDATE_DATA_FIELD (page_increment); + UPDATE_DATA_FIELD (minimum); + UPDATE_DATA_FIELD (maximum); + UPDATE_DATA_FIELD (slider_size); + UPDATE_DATA_FIELD (slider_position); + UPDATE_DATA_FIELD (scrollbar_width); + UPDATE_DATA_FIELD (scrollbar_height); + UPDATE_DATA_FIELD (scrollbar_x); + UPDATE_DATA_FIELD (scrollbar_y); + + if (w && !vertical_drag_in_progress) + { + int new_vov = SCROLLBAR_GTK_POS_DATA (inst).slider_position; + int new_vows = marker_position (w->start[CURRENT_DISP]); + + if (SCROLLBAR_GTK_VDRAG_ORIG_VALUE (inst) != new_vov) + { + SCROLLBAR_GTK_VDRAG_ORIG_VALUE (inst) = new_vov; + inst->scrollbar_instance_changed = 1; + } + if (SCROLLBAR_GTK_VDRAG_ORIG_WINDOW_START (inst) != new_vows) + { + SCROLLBAR_GTK_VDRAG_ORIG_WINDOW_START (inst) = new_vows; + inst->scrollbar_instance_changed = 1; + } + } +} + +/* Used by gtk_update_scrollbar_instance_status. */ +static void +update_one_widget_scrollbar_pointer (struct window *w, GtkWidget *wid) +{ + if (!wid->window) + gtk_widget_realize (wid); + + if (POINTER_IMAGE_INSTANCEP (w->scrollbar_pointer)) + { + gdk_window_set_cursor (GET_GTK_WIDGET_WINDOW (wid), + XIMAGE_INSTANCE_GTK_CURSOR (w->scrollbar_pointer)); + gdk_flush (); + } +} + +/* A device method. */ +static void +gtk_update_scrollbar_instance_status (struct window *w, int active, int size, + struct scrollbar_instance *instance) +{ + struct frame *f = XFRAME (w->frame); + GtkWidget *wid = SCROLLBAR_GTK_WIDGET (instance); + gboolean managed = GTK_WIDGET_MAPPED (wid); + + if (active && size) + { + if (instance->scrollbar_instance_changed) + { + /* Need to set the height, width, and position of the widget */ + GtkAdjustment *adj = gtk_range_get_adjustment (GTK_RANGE (wid)); + scrollbar_values *pos_data = & SCROLLBAR_GTK_POS_DATA (instance); + int modified_p = 0; + + /* We do not want to update the size all the time if we can + help it. This cuts down on annoying flicker. + */ + if ((wid->allocation.width != pos_data->scrollbar_width) || + (wid->allocation.height != pos_data->scrollbar_height)) + { + gtk_widget_set_usize (wid, + pos_data->scrollbar_width, + pos_data->scrollbar_height); + modified_p = 1; + } + + /* Ditto for the x/y position. */ + if ((wid->allocation.x != pos_data->scrollbar_x) || + (wid->allocation.y != pos_data->scrollbar_y)) + { + gtk_fixed_move (GTK_FIXED (FRAME_GTK_TEXT_WIDGET (f)), + wid, + pos_data->scrollbar_x, + pos_data->scrollbar_y); + modified_p = 1; + } + + adj->lower = pos_data->minimum; + adj->upper = pos_data->maximum; + adj->page_increment = pos_data->slider_size + 1; + adj->step_increment = w->max_line_len - 1; + adj->page_size = pos_data->slider_size + 1; + adj->value = pos_data->slider_position; + + /* But, if we didn't resize or move the scrollbar, the + widget will not get redrawn correctly when the user + scrolls around in the XEmacs frame manually. So we + update the slider manually here. + */ + if (!modified_p) + gtk_range_slider_update (GTK_RANGE (wid)); + + instance->scrollbar_instance_changed = 0; + } + + if (!managed) + { + gtk_widget_show (wid); + update_one_widget_scrollbar_pointer (w, wid); + } + } + else if (managed) + { + gtk_widget_hide (wid); + } +} + +enum gtk_scrollbar_loop +{ + GTK_FIND_SCROLLBAR_WINDOW_MIRROR, + GTK_SET_SCROLLBAR_POINTER, + GTK_WINDOW_IS_SCROLLBAR, + GTK_UPDATE_FRAME_SCROLLBARS +}; + +static struct window_mirror * +gtk_scrollbar_loop (enum gtk_scrollbar_loop type, Lisp_Object window, + struct window_mirror *mir, + GUI_ID id, GdkWindow *x_win) +{ + struct window_mirror *retval = NULL; + + while (mir) + { + struct scrollbar_instance *vinstance = mir->scrollbar_vertical_instance; + struct scrollbar_instance *hinstance = mir->scrollbar_horizontal_instance; + struct window *w = XWINDOW (window); + + if (mir->vchild) + retval = gtk_scrollbar_loop (type, w->vchild, mir->vchild, id, x_win); + else if (mir->hchild) + retval = gtk_scrollbar_loop (type, w->hchild, mir->hchild, id, x_win); + if (retval) + return retval; + + if (hinstance || vinstance) + { + switch (type) + { + case GTK_FIND_SCROLLBAR_WINDOW_MIRROR: + if ((vinstance && SCROLLBAR_GTK_ID (vinstance) == id) || + (hinstance && SCROLLBAR_GTK_ID (hinstance) == id)) + return mir; + break; + case GTK_UPDATE_FRAME_SCROLLBARS: + if (!mir->vchild && !mir->hchild) + update_window_scrollbars (w, mir, 1, 0); + break; + case GTK_SET_SCROLLBAR_POINTER: + if (!mir->vchild && !mir->hchild) + { + GtkWidget *widget; + + widget = SCROLLBAR_GTK_WIDGET (hinstance); + if (widget && GTK_WIDGET_MAPPED (widget)) + update_one_widget_scrollbar_pointer (w, widget); + + widget = SCROLLBAR_GTK_WIDGET (vinstance); + if (widget && GTK_WIDGET_MAPPED (widget)) + update_one_widget_scrollbar_pointer (w, widget); + } + break; + case GTK_WINDOW_IS_SCROLLBAR: + if (!mir->vchild && !mir->hchild) + { + GtkWidget *widget; + + widget = SCROLLBAR_GTK_WIDGET (hinstance); + if (widget && GTK_WIDGET_MAPPED (widget) && + GET_GTK_WIDGET_WINDOW (widget) == x_win) + return (struct window_mirror *) 1; + + widget = SCROLLBAR_GTK_WIDGET (vinstance); + if (widget && GTK_WIDGET_MAPPED (widget) && + GET_GTK_WIDGET_WINDOW (widget) == x_win) + return (struct window_mirror *) 1; + } + break; + default: + abort (); + } + } + + mir = mir->next; + window = w->next; + } + + return NULL; +} + +/* Used by callbacks. */ +static struct window_mirror * +find_scrollbar_window_mirror (struct frame *f, GUI_ID id) +{ + if (f->mirror_dirty) + update_frame_window_mirror (f); + return gtk_scrollbar_loop (GTK_FIND_SCROLLBAR_WINDOW_MIRROR, f->root_window, + f->root_mirror, id, (GdkWindow *) NULL); +} + +static gboolean +scrollbar_cb (GtkAdjustment *adj, gpointer user_data) +{ + /* This function can GC */ + int vertical = (int) user_data; + struct frame *f = gtk_object_get_data (GTK_OBJECT (adj), "xemacs::frame"); + struct scrollbar_instance *instance = gtk_object_get_data (GTK_OBJECT (adj), "xemacs::sb_instance"); + GUI_ID id = (GUI_ID) gtk_object_get_data (GTK_OBJECT (adj), "xemacs::gui_id"); + Lisp_Object win, frame; + struct window_mirror *mirror; + Lisp_Object event_type = Qnil; + Lisp_Object event_data = Qnil; + + if (!f) + return(FALSE); + + mirror = find_scrollbar_window_mirror (f, id); + if (!mirror) + return(FALSE); + + win = real_window (mirror, 1); + + if (NILP (win)) + return(FALSE); + instance = vertical ? mirror->scrollbar_vertical_instance : mirror->scrollbar_horizontal_instance; + frame = WINDOW_FRAME (XWINDOW (win)); + + inhibit_slider_size_change = 0; + switch (GTK_RANGE (SCROLLBAR_GTK_WIDGET (instance))->scroll_type) + { + case GTK_SCROLL_PAGE_BACKWARD: + event_type = vertical ? Qscrollbar_page_up : Qscrollbar_page_left; + event_data = Fcons (win, Qnil); + break; + case GTK_SCROLL_PAGE_FORWARD: + event_type = vertical ? Qscrollbar_page_down : Qscrollbar_page_right; + event_data = Fcons (win, Qnil); + break; + case GTK_SCROLL_STEP_FORWARD: + event_type = vertical ? Qscrollbar_line_down : Qscrollbar_char_right; + event_data = win; + break; + case GTK_SCROLL_STEP_BACKWARD: + event_type = vertical ? Qscrollbar_line_up : Qscrollbar_char_left; + event_data = win; + break; + case GTK_SCROLL_NONE: + case GTK_SCROLL_JUMP: + inhibit_slider_size_change = 1; + event_type = vertical ? Qscrollbar_vertical_drag : Qscrollbar_horizontal_drag; + event_data = Fcons (win, make_int ((int)adj->value)); + break; + default: + abort(); + } + + signal_special_gtk_user_event (frame, event_type, event_data); + + return (TRUE); +} + +static void +gtk_scrollbar_pointer_changed_in_window (struct window *w) +{ + Lisp_Object window; + + XSETWINDOW (window, w); + gtk_scrollbar_loop (GTK_SET_SCROLLBAR_POINTER, window, find_window_mirror (w), + 0, (GdkWindow *) NULL); +} + +/* #### BILL!!! This comment is not true for Gtk - should it be? */ +/* Make sure that all scrollbars on frame are up-to-date. Called + directly from gtk_set_frame_properties in frame-gtk.c*/ +void +gtk_update_frame_scrollbars (struct frame *f) +{ + /* Consider this code to be "in_display" so that we abort() if Fsignal() + gets called. */ + in_display++; + gtk_scrollbar_loop (GTK_UPDATE_FRAME_SCROLLBARS, f->root_window, f->root_mirror, + 0, (GdkWindow *) NULL); + in_display--; + if (in_display < 0) abort (); +} + +#ifdef MEMORY_USAGE_STATS +static int +gtk_compute_scrollbar_instance_usage (struct device *d, + struct scrollbar_instance *inst, + struct overhead_stats *ovstats) +{ + int total = 0; + + while (inst) + { + struct gtk_scrollbar_data *data = + (struct gtk_scrollbar_data *) inst->scrollbar_data; + + total += malloced_storage_size (data, sizeof (*data), ovstats); + inst = inst->next; + } + + return total; +} + +#endif /* MEMORY_USAGE_STATS */ + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +console_type_create_scrollbar_gtk (void) +{ + CONSOLE_HAS_METHOD (gtk, inhibit_scrollbar_slider_size_change); + CONSOLE_HAS_METHOD (gtk, free_scrollbar_instance); + CONSOLE_HAS_METHOD (gtk, release_scrollbar_instance); + CONSOLE_HAS_METHOD (gtk, create_scrollbar_instance); + CONSOLE_HAS_METHOD (gtk, update_scrollbar_instance_values); + CONSOLE_HAS_METHOD (gtk, update_scrollbar_instance_status); + CONSOLE_HAS_METHOD (gtk, scrollbar_pointer_changed_in_window); +#ifdef MEMORY_USAGE_STATS + CONSOLE_HAS_METHOD (gtk, compute_scrollbar_instance_usage); +#endif /* MEMORY_USAGE_STATS */ +} + +void +vars_of_scrollbar_gtk (void) +{ + Fprovide (intern ("gtk-scrollbars")); +} diff --git a/src/scrollbar-gtk.h b/src/scrollbar-gtk.h new file mode 100644 index 0000000..98be12c --- /dev/null +++ b/src/scrollbar-gtk.h @@ -0,0 +1,84 @@ +/* Define Gtk-specific scrollbar instance. + Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +#ifndef _XEMACS_SCROLLBAR_GTK_H_ +#define _XEMACS_SCROLLBAR_GTK_H_ + +#if defined (HAVE_GTK) && defined (HAVE_SCROLLBARS) + +#include "scrollbar.h" + +typedef struct _scrollbar_values +{ + int line_increment; + int page_increment; + + int minimum; + int maximum; + + int slider_size; + int slider_position; + + int scrollbar_width, scrollbar_height; + int scrollbar_x, scrollbar_y; +} scrollbar_values; + +struct gtk_scrollbar_data +{ + /* Unique scrollbar identifier and name. */ + unsigned int id; + + /* Is set if we have already set the backing_store attribute correctly */ + char backing_store_initialized; + + /* Positioning and sizing information for scrollbar and slider. */ + scrollbar_values pos_data; + + /* Pointer to the scrollbar widget this structure describes. */ + GtkWidget *widget; + + gfloat last_value; + + /* Recorded starting position for Motif-like scrollbar drags. */ + int vdrag_orig_value; + Bufpos vdrag_orig_window_start; +}; + +#define SCROLLBAR_GTK_DATA(i) ((struct gtk_scrollbar_data *) ((i)->scrollbar_data)) + +#define SCROLLBAR_GTK_ID(i) (SCROLLBAR_GTK_DATA (i)->id) +#define SCROLLBAR_GTK_BACKING_STORE_INITIALIZED(i) \ + (SCROLLBAR_GTK_DATA (i)->backing_store_initialized) +#define SCROLLBAR_GTK_POS_DATA(i) (SCROLLBAR_GTK_DATA (i)->pos_data) +#define SCROLLBAR_GTK_WIDGET(i) (SCROLLBAR_GTK_DATA (i)->widget) +#define SCROLLBAR_GTK_LAST_VALUE(i) SCROLLBAR_GTK_DATA (i)->last_value + +#define SCROLLBAR_GTK_VDRAG_ORIG_VALUE(i) \ + (SCROLLBAR_GTK_DATA (i)->vdrag_orig_value) +#define SCROLLBAR_GTK_VDRAG_ORIG_WINDOW_START(i) \ + (SCROLLBAR_GTK_DATA (i)->vdrag_orig_window_start) + +void gtk_update_frame_scrollbars (struct frame *f); +void gtk_set_scrollbar_pointer (struct frame *f, Lisp_Object cursor); + +#endif /* HAVE_GDK and HAVE_SCROLLBARS */ +#endif /* _XEMACS_SCROLLBAR_GTK_H_ */ diff --git a/src/select-gtk.c b/src/select-gtk.c new file mode 100644 index 0000000..a11cb63 --- /dev/null +++ b/src/select-gtk.c @@ -0,0 +1,946 @@ +/* GTK selection processing for XEmacs + Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not synched with FSF. */ + +/* Authorship: + + Written by Kevin Gallo for FSF Emacs. + Rewritten for mswindows by Jonathan Harris, December 1997 for 21.0. + Rewritten for GTK by William Perry, April 2000 for 21.1 + */ + + +#include +#include "lisp.h" +#include "events.h" +#include "buffer.h" +#include "device.h" +#include "console-gtk.h" +#include "select.h" +#include "opaque.h" +#include "frame.h" + +static Lisp_Object Vretrieved_selection; +static gboolean waiting_for_selection; +Lisp_Object Vgtk_sent_selection_hooks; + +static Lisp_Object atom_to_symbol (struct device *d, GdkAtom atom); +static GdkAtom symbol_to_gtk_atom (struct device *d, Lisp_Object sym, int only_if_exists); + +static void lisp_data_to_selection_data (struct device *, + Lisp_Object obj, + unsigned char **data_ret, + GdkAtom *type_ret, + unsigned int *size_ret, + int *format_ret); +static Lisp_Object selection_data_to_lisp_data (struct device *, + Extbyte *data, + size_t size, + GdkAtom type, + int format); + +/* Set the selection data to GDK_NONE and NULL data, meaning we were +** unable to do what they wanted. +*/ +static void +gtk_decline_selection_request (GtkSelectionData *data) +{ + gtk_selection_data_set (data, GDK_NONE, 0, NULL, 0); +} + +/* Used as an unwind-protect clause so that, if a selection-converter signals + an error, we tell the requestor that we were unable to do what they wanted + before we throw to top-level or go into the debugger or whatever. + */ +struct _selection_closure +{ + GtkSelectionData *data; + gboolean successful; +}; + +static Lisp_Object +gtk_selection_request_lisp_error (Lisp_Object closure) +{ + struct _selection_closure *cl = (struct _selection_closure *) + get_opaque_ptr (closure); + + free_opaque_ptr (closure); + if (cl->successful == TRUE) + return Qnil; + gtk_decline_selection_request (cl->data); + return Qnil; +} + +/* This provides the current selection to a requester. +** +** This is connected to the selection_get() signal of the application +** shell in device-gtk.c:gtk_init_device(). +** +** This is radically different than the old selection code (21.1.x), +** but has been modeled after the X code, and appears to work. +** +** WMP Feb 12 2001 +*/ +void +emacs_gtk_selection_handle (GtkWidget *widget, + GtkSelectionData *selection_data, + guint info, + guint time_stamp, + gpointer data) +{ + /* This function can GC */ + struct gcpro gcpro1, gcpro2; + Lisp_Object temp_obj; + Lisp_Object selection_symbol; + Lisp_Object target_symbol = Qnil; + Lisp_Object converted_selection = Qnil; + guint32 local_selection_time; + Lisp_Object successful_p = Qnil; + int count; + struct device *d = decode_gtk_device (Qnil); + struct _selection_closure *cl = NULL; + + GCPRO2 (converted_selection, target_symbol); + + selection_symbol = atom_to_symbol (d, selection_data->selection); + target_symbol = atom_to_symbol (d, selection_data->target); + +#if 0 /* #### MULTIPLE doesn't work yet */ + if (EQ (target_symbol, QMULTIPLE)) + target_symbol = fetch_multiple_target (selection_data); +#endif + + temp_obj = Fget_selection_timestamp (selection_symbol); + + if (NILP (temp_obj)) + { + /* We don't appear to have the selection. */ + gtk_decline_selection_request (selection_data); + + goto DONE_LABEL; + } + + local_selection_time = * (guint32 *) XOPAQUE_DATA (temp_obj); + + if (time_stamp != GDK_CURRENT_TIME && + local_selection_time > time_stamp) + { + /* Someone asked for the selection, and we have one, but not the one + they're looking for. */ + gtk_decline_selection_request (selection_data); + goto DONE_LABEL; + } + + converted_selection = select_convert_out (selection_symbol, + target_symbol, Qnil); + + /* #### Is this the right thing to do? I'm no X expert. -- ajh */ + if (NILP (converted_selection)) + { + /* We don't appear to have a selection in that data type. */ + gtk_decline_selection_request (selection_data); + goto DONE_LABEL; + } + + count = specpdl_depth (); + + cl = (struct _selection_closure *) xmalloc (sizeof (*cl)); + cl->data = selection_data; + cl->successful = FALSE; + + record_unwind_protect (gtk_selection_request_lisp_error, + make_opaque_ptr (cl)); + + { + unsigned char *data; + unsigned int size; + int format; + GdkAtom type; + lisp_data_to_selection_data (d, converted_selection, + &data, &type, &size, &format); + + gtk_selection_data_set (selection_data, type, format, data, size); + successful_p = Qt; + /* Tell x_selection_request_lisp_error() it's cool. */ + cl->successful = TRUE; + xfree (data); + } + + unbind_to (count, Qnil); + + DONE_LABEL: + + if (cl) xfree (cl); + + UNGCPRO; + + /* Let random lisp code notice that the selection has been asked for. */ + { + Lisp_Object val = Vgtk_sent_selection_hooks; + if (!UNBOUNDP (val) && !NILP (val)) + { + Lisp_Object rest; + if (CONSP (val) && !EQ (XCAR (val), Qlambda)) + for (rest = val; !NILP (rest); rest = Fcdr (rest)) + call3 (Fcar (rest), selection_symbol, target_symbol, successful_p); + else + call3 (val, selection_symbol, target_symbol, successful_p); + } + } +} + + + +static GtkWidget *reading_selection_reply; +static GdkAtom reading_which_selection; +static int selection_reply_timed_out; + +/* Gets the current selection owned by another application */ +void +emacs_gtk_selection_received (GtkWidget *widget, + GtkSelectionData *selection_data, + gpointer user_data) +{ + waiting_for_selection = FALSE; + Vretrieved_selection = Qnil; + + reading_selection_reply = NULL; + + signal_fake_event (); + + if (selection_data->length < 0) + { + return; + } + + Vretrieved_selection = + selection_data_to_lisp_data (NULL, + selection_data->data, + selection_data->length, + selection_data->type, + selection_data->format); +} + +static int +selection_reply_done (void *ignore) +{ + return !reading_selection_reply; +} + +/* Do protocol to read selection-data from the server. + Converts this to lisp data and returns it. + */ +static Lisp_Object +gtk_get_foreign_selection (Lisp_Object selection_symbol, + Lisp_Object target_type) +{ + /* This function can GC */ + struct device *d = decode_gtk_device (Qnil); + GtkWidget *requestor = DEVICE_GTK_APP_SHELL (d); + guint32 requestor_time = DEVICE_GTK_MOUSE_TIMESTAMP (d); + GdkAtom selection_atom = symbol_to_gtk_atom (d, selection_symbol, 0); + int speccount; + GdkAtom type_atom = symbol_to_gtk_atom (d, (CONSP (target_type) ? + XCAR (target_type) : target_type), 0); + + gtk_selection_convert (requestor, selection_atom, type_atom, + requestor_time); + + signal_fake_event (); + + /* Block until the reply has been read. */ + reading_selection_reply = requestor; + reading_which_selection = selection_atom; + selection_reply_timed_out = 0; + + speccount = specpdl_depth (); + +#if 0 + /* add a timeout handler */ + if (gtk_selection_timeout > 0) + { + Lisp_Object id = Fadd_timeout (make_int (x_selection_timeout), + Qx_selection_reply_timeout_internal, + Qnil, Qnil); + record_unwind_protect (Fdisable_timeout, id); + } +#endif + + /* This is ^Gable */ + wait_delaying_user_input (selection_reply_done, 0); + + if (selection_reply_timed_out) + error ("timed out waiting for reply from selection owner"); + + unbind_to (speccount, Qnil); + + /* otherwise, the selection is waiting for us on the requested property. */ + return select_convert_in (selection_symbol, + target_type, + Vretrieved_selection); +} + + +#if 0 +static void +gtk_get_window_property (struct device *d, GtkWidget *window, GdkAtom property, + Extbyte **data_ret, int *bytes_ret, + GdkAtom *actual_type_ret, int *actual_format_ret, + unsigned long *actual_size_ret, int delete_p) +{ + size_t total_size; + unsigned long bytes_remaining; + int offset = 0; + unsigned char *tmp_data = 0; + int result; + int buffer_size = SELECTION_QUANTUM (display); + if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM; + + /* First probe the thing to find out how big it is. */ + result = XGetWindowProperty (display, window, property, + 0, 0, False, AnyPropertyType, + actual_type_ret, actual_format_ret, + actual_size_ret, + &bytes_remaining, &tmp_data); + if (result != Success) + { + *data_ret = 0; + *bytes_ret = 0; + return; + } + XFree ((char *) tmp_data); + + if (*actual_type_ret == None || *actual_format_ret == 0) + { + if (delete_p) XDeleteProperty (display, window, property); + *data_ret = 0; + *bytes_ret = 0; + return; + } + + total_size = bytes_remaining + 1; + *data_ret = (Extbyte *) xmalloc (total_size); + + /* Now read, until we've gotten it all. */ + while (bytes_remaining) + { +#if 0 + int last = bytes_remaining; +#endif + result = + XGetWindowProperty (display, window, property, + offset/4, buffer_size/4, + (delete_p ? True : False), + AnyPropertyType, + actual_type_ret, actual_format_ret, + actual_size_ret, &bytes_remaining, &tmp_data); +#if 0 + stderr_out ("<< read %d\n", last-bytes_remaining); +#endif + /* If this doesn't return Success at this point, it means that + some clod deleted the selection while we were in the midst of + reading it. Deal with that, I guess.... + */ + if (result != Success) break; + *actual_size_ret *= *actual_format_ret / 8; + memcpy ((*data_ret) + offset, tmp_data, *actual_size_ret); + offset += *actual_size_ret; + XFree ((char *) tmp_data); + } + *bytes_ret = offset; +} + + +static void +receive_incremental_selection (Display *display, Window window, Atom property, + /* this one is for error messages only */ + Lisp_Object target_type, + unsigned int min_size_bytes, + Extbyte **data_ret, int *size_bytes_ret, + Atom *type_ret, int *format_ret, + unsigned long *size_ret) +{ + /* This function can GC */ + int offset = 0; + int prop_id; + *size_bytes_ret = min_size_bytes; + *data_ret = (Extbyte *) xmalloc (*size_bytes_ret); +#if 0 + stderr_out ("\nread INCR %d\n", min_size_bytes); +#endif + /* At this point, we have read an INCR property, and deleted it (which + is how we ack its receipt: the sending window will be selecting + PropertyNotify events on our window to notice this). + + Now, we must loop, waiting for the sending window to put a value on + that property, then reading the property, then deleting it to ack. + We are done when the sender places a property of length 0. + */ + prop_id = expect_property_change (display, window, property, + PropertyNewValue); + while (1) + { + Extbyte *tmp_data; + int tmp_size_bytes; + wait_for_property_change (prop_id); + /* expect it again immediately, because x_get_window_property may + .. no it won't, I don't get it. + .. Ok, I get it now, the Xt code that implements INCR is broken. + */ + prop_id = expect_property_change (display, window, property, + PropertyNewValue); + x_get_window_property (display, window, property, + &tmp_data, &tmp_size_bytes, + type_ret, format_ret, size_ret, 1); + + if (tmp_size_bytes == 0) /* we're done */ + { +#if 0 + stderr_out (" read INCR done\n"); +#endif + unexpect_property_change (prop_id); + if (tmp_data) xfree (tmp_data); + break; + } +#if 0 + stderr_out (" read INCR %d\n", tmp_size_bytes); +#endif + if (*size_bytes_ret < offset + tmp_size_bytes) + { +#if 0 + stderr_out (" read INCR realloc %d -> %d\n", + *size_bytes_ret, offset + tmp_size_bytes); +#endif + *size_bytes_ret = offset + tmp_size_bytes; + *data_ret = (Extbyte *) xrealloc (*data_ret, *size_bytes_ret); + } + memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes); + offset += tmp_size_bytes; + xfree (tmp_data); + } +} + + +static Lisp_Object +gtk_get_window_property_as_lisp_data (struct device *d, + GtkWidget *window, + GdkAtom property, + /* next two for error messages only */ + Lisp_Object target_type, + GdkAtom selection_atom) +{ + /* This function can GC */ + Atom actual_type; + int actual_format; + unsigned long actual_size; + Extbyte *data = NULL; + int bytes = 0; + Lisp_Object val; + struct device *d = get_device_from_display (display); + + x_get_window_property (display, window, property, &data, &bytes, + &actual_type, &actual_format, &actual_size, 1); + if (! data) + { + if (XGetSelectionOwner (display, selection_atom)) + /* there is a selection owner */ + signal_error + (Qselection_conversion_error, + Fcons (build_string ("selection owner couldn't convert"), + Fcons (x_atom_to_symbol (d, selection_atom), + actual_type ? + list2 (target_type, x_atom_to_symbol (d, actual_type)) : + list1 (target_type)))); + else + signal_error (Qerror, + list2 (build_string ("no selection"), + x_atom_to_symbol (d, selection_atom))); + } + + if (actual_type == DEVICE_XATOM_INCR (d)) + { + /* Ok, that data wasn't *the* data, it was just the beginning. */ + + unsigned int min_size_bytes = * ((unsigned int *) data); + xfree (data); + receive_incremental_selection (display, window, property, target_type, + min_size_bytes, &data, &bytes, + &actual_type, &actual_format, + &actual_size); + } + + /* It's been read. Now convert it to a lisp object in some semi-rational + manner. */ + val = selection_data_to_lisp_data (d, data, bytes, + actual_type, actual_format); + + xfree (data); + return val; +} +#endif + + +static GdkAtom +symbol_to_gtk_atom (struct device *d, Lisp_Object sym, int only_if_exists) +{ + if (NILP (sym)) return GDK_SELECTION_PRIMARY; + if (EQ (sym, Qt)) return GDK_SELECTION_SECONDARY; + if (EQ (sym, QPRIMARY)) return GDK_SELECTION_PRIMARY; + if (EQ (sym, QSECONDARY)) return GDK_SELECTION_SECONDARY; + + { + const char *nameext; + LISP_STRING_TO_EXTERNAL (Fsymbol_name (sym), nameext, Qctext); + return gdk_atom_intern (nameext, only_if_exists ? TRUE : FALSE); + } +} + +static Lisp_Object +atom_to_symbol (struct device *d, GdkAtom atom) +{ + if (atom == GDK_SELECTION_PRIMARY) return (QPRIMARY); + if (atom == GDK_SELECTION_SECONDARY) return (QSECONDARY); + + { + char *intstr; + char *str = gdk_atom_name (atom); + + if (! str) return Qnil; + + TO_INTERNAL_FORMAT (C_STRING, str, + C_STRING_ALLOCA, intstr, + Qctext); + g_free (str); + return intern (intstr); + } +} + +/* #### These are going to move into Lisp code(!) with the aid of + some new functions I'm working on - ajh */ + +/* These functions convert from the selection data read from the server into + something that we can use from elisp, and vice versa. + + Type: Format: Size: Elisp Type: + ----- ------- ----- ----------- + * 8 * String + ATOM 32 1 Symbol + ATOM 32 > 1 Vector of Symbols + * 16 1 Integer + * 16 > 1 Vector of Integers + * 32 1 if <=16 bits: Integer + if > 16 bits: Cons of top16, bot16 + * 32 > 1 Vector of the above + + When converting a Lisp number to C, it is assumed to be of format 16 if + it is an integer, and of format 32 if it is a cons of two integers. + + When converting a vector of numbers from Elisp to C, it is assumed to be + of format 16 if every element in the vector is an integer, and is assumed + to be of format 32 if any element is a cons of two integers. + + When converting an object to C, it may be of the form (SYMBOL . ) + where SYMBOL is what we should claim that the type is. Format and + representation are as above. + + NOTE: Under Mule, when someone shoves us a string without a type, we + set the type to 'COMPOUND_TEXT and automatically convert to Compound + Text. If the string has a type, we assume that the user wants the + data sent as-is so we just do "binary" conversion. + */ + + +static Lisp_Object +selection_data_to_lisp_data (struct device *d, + Extbyte *data, + size_t size, + GdkAtom type, + int format) +{ + if (type == gdk_atom_intern ("NULL", 0)) + return QNULL; + + /* Convert any 8-bit data to a string, for compactness. */ + else if (format == 8) + return make_ext_string (data, size, + ((type == gdk_atom_intern ("TEXT", FALSE)) || + (type == gdk_atom_intern ("COMPOUND_TEXT", FALSE))) + ? Qctext : Qbinary); + + /* Convert a single atom to a Lisp Symbol. + Convert a set of atoms to a vector of symbols. */ + else if (type == gdk_atom_intern ("ATOM", FALSE)) + { + if (size == sizeof (GdkAtom)) + return atom_to_symbol (d, *((GdkAtom *) data)); + else + { + int i; + int len = size / sizeof (GdkAtom); + Lisp_Object v = Fmake_vector (make_int (len), Qzero); + for (i = 0; i < len; i++) + Faset (v, make_int (i), atom_to_symbol (d, ((GdkAtom *) data) [i])); + return v; + } + } + + /* Convert a single 16 or small 32 bit number to a Lisp Int. + If the number is > 16 bits, convert it to a cons of integers, + 16 bits in each half. + */ + else if (format == 32 && size == sizeof (long)) + return word_to_lisp (((unsigned long *) data) [0]); + else if (format == 16 && size == sizeof (short)) + return make_int ((int) (((unsigned short *) data) [0])); + + /* Convert any other kind of data to a vector of numbers, represented + as above (as an integer, or a cons of two 16 bit integers). + + #### Perhaps we should return the actual type to lisp as well. + + (x-get-selection-internal 'PRIMARY 'LINE_NUMBER) + ==> [4 4] + + and perhaps it should be + + (x-get-selection-internal 'PRIMARY 'LINE_NUMBER) + ==> (SPAN . [4 4]) + + Right now the fact that the return type was SPAN is discarded before + lisp code gets to see it. + */ + else if (format == 16) + { + int i; + Lisp_Object v = make_vector (size / 4, Qzero); + for (i = 0; i < (int) size / 4; i++) + { + int j = (int) ((unsigned short *) data) [i]; + Faset (v, make_int (i), make_int (j)); + } + return v; + } + else + { + int i; + Lisp_Object v = make_vector (size / 4, Qzero); + for (i = 0; i < (int) size / 4; i++) + { + unsigned long j = ((unsigned long *) data) [i]; + Faset (v, make_int (i), word_to_lisp (j)); + } + return v; + } +} + + +static void +lisp_data_to_selection_data (struct device *d, + Lisp_Object obj, + unsigned char **data_ret, + GdkAtom *type_ret, + unsigned int *size_ret, + int *format_ret) +{ + Lisp_Object type = Qnil; + + if (CONSP (obj) && SYMBOLP (XCAR (obj))) + { + type = XCAR (obj); + obj = XCDR (obj); + if (CONSP (obj) && NILP (XCDR (obj))) + obj = XCAR (obj); + } + + if (EQ (obj, QNULL) || (EQ (type, QNULL))) + { /* This is not the same as declining */ + *format_ret = 32; + *size_ret = 0; + *data_ret = 0; + type = QNULL; + } + else if (STRINGP (obj)) + { + const Extbyte *extval; + Extcount extvallen; + + TO_EXTERNAL_FORMAT (LISP_STRING, obj, + ALLOCA, (extval, extvallen), + (NILP (type) ? Qctext : Qbinary)); + *format_ret = 8; + *size_ret = extvallen; + *data_ret = (unsigned char *) xmalloc (*size_ret); + memcpy (*data_ret, extval, *size_ret); +#ifdef MULE + if (NILP (type)) type = QCOMPOUND_TEXT; +#else + if (NILP (type)) type = QSTRING; +#endif + } + else if (CHARP (obj)) + { + Bufbyte buf[MAX_EMCHAR_LEN]; + Bytecount len; + const Extbyte *extval; + Extcount extvallen; + + *format_ret = 8; + len = set_charptr_emchar (buf, XCHAR (obj)); + TO_EXTERNAL_FORMAT (DATA, (buf, len), + ALLOCA, (extval, extvallen), + Qctext); + *size_ret = extvallen; + *data_ret = (unsigned char *) xmalloc (*size_ret); + memcpy (*data_ret, extval, *size_ret); +#ifdef MULE + if (NILP (type)) type = QCOMPOUND_TEXT; +#else + if (NILP (type)) type = QSTRING; +#endif + } + else if (SYMBOLP (obj)) + { + *format_ret = 32; + *size_ret = 1; + *data_ret = (unsigned char *) xmalloc (sizeof (GdkAtom) + 1); + (*data_ret) [sizeof (GdkAtom)] = 0; + (*(GdkAtom **) data_ret) [0] = symbol_to_gtk_atom (d, obj, 0); + if (NILP (type)) type = QATOM; + } + else if (INTP (obj) && + XINT (obj) <= 0x7FFF && + XINT (obj) >= -0x8000) + { + *format_ret = 16; + *size_ret = 1; + *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1); + (*data_ret) [sizeof (short)] = 0; + (*(short **) data_ret) [0] = (short) XINT (obj); + if (NILP (type)) type = QINTEGER; + } + else if (INTP (obj) || CONSP (obj)) + { + *format_ret = 32; + *size_ret = 1; + *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1); + (*data_ret) [sizeof (long)] = 0; + (*(unsigned long **) data_ret) [0] = lisp_to_word (obj); + if (NILP (type)) type = QINTEGER; + } + else if (VECTORP (obj)) + { + /* Lisp Vectors may represent a set of ATOMs; + a set of 16 or 32 bit INTEGERs; + or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...] + */ + int i; + + if (SYMBOLP (XVECTOR_DATA (obj) [0])) + /* This vector is an ATOM set */ + { + if (NILP (type)) type = QATOM; + *size_ret = XVECTOR_LENGTH (obj); + *format_ret = 32; + *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (GdkAtom)); + for (i = 0; i < (int) (*size_ret); i++) + if (SYMBOLP (XVECTOR_DATA (obj) [i])) + (*(GdkAtom **) data_ret) [i] = + symbol_to_gtk_atom (d, XVECTOR_DATA (obj) [i], 0); + else + signal_error (Qerror, /* Qselection_error */ + list2 (build_string + ("all elements of the vector must be of the same type"), + obj)); + } +#if 0 /* #### MULTIPLE doesn't work yet */ + else if (VECTORP (XVECTOR_DATA (obj) [0])) + /* This vector is an ATOM_PAIR set */ + { + if (NILP (type)) type = QATOM_PAIR; + *size_ret = XVECTOR_LENGTH (obj); + *format_ret = 32; + *data_ret = (unsigned char *) + xmalloc ((*size_ret) * sizeof (Atom) * 2); + for (i = 0; i < *size_ret; i++) + if (VECTORP (XVECTOR_DATA (obj) [i])) + { + Lisp_Object pair = XVECTOR_DATA (obj) [i]; + if (XVECTOR_LENGTH (pair) != 2) + signal_error (Qerror, + list2 (build_string + ("elements of the vector must be vectors of exactly two elements"), + pair)); + + (*(GdkAtom **) data_ret) [i * 2] = + symbol_to_gtk_atom (d, XVECTOR_DATA (pair) [0], 0); + (*(GdkAtom **) data_ret) [(i * 2) + 1] = + symbol_to_gtk_atom (d, XVECTOR_DATA (pair) [1], 0); + } + else + signal_error (Qerror, + list2 (build_string + ("all elements of the vector must be of the same type"), + obj)); + } +#endif + else + /* This vector is an INTEGER set, or something like it */ + { + *size_ret = XVECTOR_LENGTH (obj); + if (NILP (type)) type = QINTEGER; + *format_ret = 16; + for (i = 0; i < (int) (*size_ret); i++) + if (CONSP (XVECTOR_DATA (obj) [i])) + *format_ret = 32; + else if (!INTP (XVECTOR_DATA (obj) [i])) + signal_error (Qerror, /* Qselection_error */ + list2 (build_string + ("all elements of the vector must be integers or conses of integers"), + obj)); + + *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8)); + for (i = 0; i < (int) (*size_ret); i++) + if (*format_ret == 32) + (*((unsigned long **) data_ret)) [i] = + lisp_to_word (XVECTOR_DATA (obj) [i]); + else + (*((unsigned short **) data_ret)) [i] = + (unsigned short) lisp_to_word (XVECTOR_DATA (obj) [i]); + } + } + else + signal_error (Qerror, /* Qselection_error */ + list2 (build_string ("unrecognized selection data"), + obj)); + + *type_ret = symbol_to_gtk_atom (d, type, 0); +} + + + +static Lisp_Object +gtk_own_selection (Lisp_Object selection_name, Lisp_Object selection_value, + Lisp_Object how_to_add, Lisp_Object selection_type) +{ + struct device *d = decode_gtk_device (Qnil); + GtkWidget *selecting_window = GTK_WIDGET (DEVICE_GTK_APP_SHELL (d)); + Lisp_Object selection_time; + /* Use the time of the last-read mouse or keyboard event. + For selection purposes, we use this as a sleazy way of knowing what the + current time is in server-time. This assumes that the most recently read + mouse or keyboard event has something to do with the assertion of the + selection, which is probably true. + */ + guint32 thyme = DEVICE_GTK_MOUSE_TIMESTAMP (d); + GdkAtom selection_atom; + + CHECK_SYMBOL (selection_name); + selection_atom = symbol_to_gtk_atom (d, selection_name, 0); + + gtk_selection_owner_set (selecting_window, + selection_atom, + thyme); + + /* We do NOT use time_to_lisp() here any more, like we used to. + That assumed equivalence of time_t and Time, which is not + necessarily the case (e.g. under OSF on the Alphas, where + Time is a 64-bit quantity and time_t is a 32-bit quantity). + + Opaque pointers are the clean way to go here. + */ + selection_time = make_opaque (&thyme, sizeof (thyme)); + + return selection_time; +} + +static void +gtk_disown_selection (Lisp_Object selection, Lisp_Object timeval) +{ + struct device *d = decode_gtk_device (Qnil); + GdkAtom selection_atom; + guint32 timestamp; + + CHECK_SYMBOL (selection); + selection_atom = symbol_to_gtk_atom (d, selection, 0); + + if (NILP (timeval)) + timestamp = DEVICE_GTK_MOUSE_TIMESTAMP (d); + else + { + time_t the_time; + lisp_to_time (timeval, &the_time); + timestamp = (guint32) the_time; + } + + gtk_selection_owner_set (NULL, selection_atom, timestamp); +} + +static Lisp_Object +gtk_selection_exists_p (Lisp_Object selection, + Lisp_Object selection_type) +{ + struct device *d = decode_gtk_device (Qnil); + + return (gdk_selection_owner_get (symbol_to_gtk_atom (d, selection, 0)) ? Qt : Qnil); +} + + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +syms_of_select_gtk (void) +{ +} + +void +console_type_create_select_gtk (void) +{ + CONSOLE_HAS_METHOD (gtk, own_selection); + CONSOLE_HAS_METHOD (gtk, disown_selection); + CONSOLE_HAS_METHOD (gtk, selection_exists_p); + CONSOLE_HAS_METHOD (gtk, get_foreign_selection); +} + +void +vars_of_select_gtk (void) +{ + staticpro (&Vretrieved_selection); + Vretrieved_selection = Qnil; + + DEFVAR_LISP ("gtk-sent-selection-hooks", &Vgtk_sent_selection_hooks /* +A function or functions to be called after we have responded to some +other client's request for the value of a selection that we own. The +function(s) will be called with four arguments: + - the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD); + - the name of the selection-type which we were requested to convert the + selection into before sending (for example, STRING or LENGTH); + - and whether we successfully transmitted the selection. +We might have failed (and declined the request) for any number of reasons, +including being asked for a selection that we no longer own, or being asked +to convert into a type that we don't know about or that is inappropriate. +This hook doesn't let you change the behavior of emacs's selection replies, +it merely informs you that they have happened. +*/ ); + Vgtk_sent_selection_hooks = Qunbound; +} diff --git a/src/toolbar-gtk.c b/src/toolbar-gtk.c new file mode 100644 index 0000000..f2ec8c5 --- /dev/null +++ b/src/toolbar-gtk.c @@ -0,0 +1,671 @@ +/* toolbar implementation -- X interface. + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 1995, 1996 Ben Wing. + Copyright (C) 1996 Chuck Thompson. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +#include +#include "lisp.h" + +#include "console-gtk.h" +#include "glyphs-gtk.h" +#include "objects-gtk.h" +#include "gtk-xemacs.h" +#include "gccache-gtk.h" + +#include "faces.h" +#include "frame.h" +#include "toolbar.h" +#include "window.h" + +extern GdkGC *gtk_get_gc (struct device *d, Lisp_Object font, Lisp_Object fg, Lisp_Object bg, + Lisp_Object bg_pmap, Lisp_Object lwidth); + +static GdkGC *get_toolbar_gc (struct frame *f) +{ + Lisp_Object fg, bg; + Lisp_Object frame; + + XSETFRAME (frame, f); + + fg = Fspecifier_instance (Fget (Vtoolbar_face, Qforeground, Qnil), frame, Qnil, Qnil); + bg = Fspecifier_instance (Fget (Vtoolbar_face, Qbackground, Qnil), frame, Qnil, Qnil); + + /* Need to swap the foreground/background here or most themes look bug ugly */ + return (gtk_get_gc (XDEVICE (FRAME_DEVICE (f)), Qnil, bg, fg, Qnil, Qnil)); +} + +static void +gtk_draw_blank_toolbar_button (struct frame *f, int x, int y, int width, + int height, int threed, int border_width, + int vertical) +{ + GtkXEmacs *ef = GTK_XEMACS (FRAME_GTK_TEXT_WIDGET (f)); + int sx = x, sy = y, swidth = width, sheight = height; + GdkWindow *x_win = GTK_WIDGET (ef)->window; + GdkGC *background_gc = get_toolbar_gc (f); + + if (vertical) + { + sx += border_width; + swidth -= 2 * border_width; + } + else + { + sy += border_width; + sheight -= 2 * border_width; + } + + /* Blank the entire area. */ + gdk_draw_rectangle (x_win, background_gc, TRUE, sx, sy, swidth, sheight); + + /* Draw the outline. */ + if (threed) + gtk_output_shadows (f, sx, sy, swidth, sheight, 2); + + /* Do the border */ + gdk_draw_rectangle (x_win, background_gc, TRUE, x, y, + (vertical ? border_width : width), + (vertical ? height : border_width)); + gdk_draw_rectangle (x_win, background_gc, TRUE, + (vertical ? sx + swidth : x), + (vertical ? y : sy + sheight), + (vertical ? border_width : width), + (vertical ? height : border_width)); +} + +static void +gtk_output_toolbar_button (struct frame *f, Lisp_Object button) +{ + int shadow_thickness = 2; + int x_adj, y_adj, width_adj, height_adj; + GdkWindow *x_win = FRAME_GTK_TEXT_WIDGET (f)->window; + GdkGC *background_gc = get_toolbar_gc (f); + Lisp_Object instance, frame, window, glyph; + struct toolbar_button *tb = XTOOLBAR_BUTTON (button); + struct Lisp_Image_Instance *p; + struct window *w; + int vertical = tb->vertical; + int border_width = tb->border_width; + + if (vertical) + { + x_adj = border_width; + width_adj = - 2 * border_width; + y_adj = 0; + height_adj = 0; + } + else + { + x_adj = 0; + width_adj = 0; + y_adj = border_width; + height_adj = - 2 * border_width; + } + + XSETFRAME (frame, f); + window = FRAME_LAST_NONMINIBUF_WINDOW (f); + w = XWINDOW (window); + + glyph = get_toolbar_button_glyph (w, tb); + + if (tb->enabled) + { + if (tb->down) + { + shadow_thickness = -2; + } + else + { + shadow_thickness = 2; + } + } + else + { + shadow_thickness = 0; + } + + background_gc = get_toolbar_gc (f); + + /* Clear the entire area. */ + gdk_draw_rectangle (x_win, background_gc, TRUE, + tb->x + x_adj, + tb->y + y_adj, + tb->width + width_adj, + tb->height + height_adj); + + /* Draw the outline. */ + if (shadow_thickness) + gtk_output_shadows (f, tb->x + x_adj, tb->y + y_adj, + tb->width + width_adj, tb->height + height_adj, + shadow_thickness); + + /* Do the border. */ + gdk_draw_rectangle (x_win, background_gc, TRUE, tb->x, tb->y, + (vertical ? border_width : tb->width), + (vertical ? tb->height : border_width)); + + gdk_draw_rectangle (x_win, background_gc, TRUE, + (vertical ? tb->x + tb->width - border_width : tb->x), + (vertical ? tb->y : tb->y + tb->height - border_width), + (vertical ? border_width : tb->width), + (vertical ? tb->height : border_width)); + + background_gc = get_toolbar_gc (f); + + /* #### It is currently possible for users to trash us by directly + changing the toolbar glyphs. Avoid crashing in that case. */ + if (GLYPHP (glyph)) + instance = glyph_image_instance (glyph, window, ERROR_ME_NOT, 1); + else + instance = Qnil; + + if (IMAGE_INSTANCEP (instance)) + { + int width = tb->width + width_adj - shadow_thickness * 2; + int height = tb->height + height_adj - shadow_thickness * 2; + int x_offset = x_adj + shadow_thickness; + int y_offset = y_adj + shadow_thickness; + + p = XIMAGE_INSTANCE (instance); + + if (IMAGE_INSTANCE_PIXMAP_TYPE_P (p)) + { + if (width > (int) IMAGE_INSTANCE_PIXMAP_WIDTH (p)) + { + x_offset += ((int) (width - IMAGE_INSTANCE_PIXMAP_WIDTH (p)) + / 2); + width = IMAGE_INSTANCE_PIXMAP_WIDTH (p); + } + if (height > (int) IMAGE_INSTANCE_PIXMAP_HEIGHT (p)) + { + y_offset += ((int) (height - IMAGE_INSTANCE_PIXMAP_HEIGHT (p)) + / 2); + height = IMAGE_INSTANCE_PIXMAP_HEIGHT (p); + } + + gtk_output_gdk_pixmap (f, XIMAGE_INSTANCE (instance), tb->x + x_offset, + tb->y + y_offset, 0, 0, 0, 0, width, height, + 0, 0, 0, background_gc); + } + else if (IMAGE_INSTANCE_TYPE (p) == IMAGE_TEXT) + { + /* #### We need to make the face used configurable. */ + struct face_cachel *cachel = + WINDOW_FACE_CACHEL (w, DEFAULT_INDEX); + struct display_line dl; + Lisp_Object string = IMAGE_INSTANCE_TEXT_STRING (p); + unsigned char charsets[NUM_LEADING_BYTES]; + Emchar_dynarr *buf; + struct font_metric_info fm; + + /* This could be true if we were called via the Expose event + handler. Mark the button as dirty and return + immediately. */ + if (f->window_face_cache_reset) + { + tb->dirty = 1; + MARK_TOOLBAR_CHANGED; + return; + } + buf = Dynarr_new (Emchar); + convert_bufbyte_string_into_emchar_dynarr + (XSTRING_DATA (string), XSTRING_LENGTH (string), buf); + find_charsets_in_emchar_string (charsets, Dynarr_atp (buf, 0), + Dynarr_length (buf)); + ensure_face_cachel_complete (cachel, window, charsets); + face_cachel_charset_font_metric_info (cachel, charsets, &fm); + + dl.ascent = fm.ascent; + dl.descent = fm.descent; + dl.ypos = tb->y + y_offset + fm.ascent; + + if (fm.ascent + fm.descent <= height) + { + dl.ypos += (height - fm.ascent - fm.descent) / 2; + dl.clip = 0; + } + else + { + dl.clip = fm.ascent + fm.descent - height; + } + + gtk_output_string (w, &dl, buf, tb->x + x_offset, 0, 0, width, + DEFAULT_INDEX, 0, 0, 0, 0); + Dynarr_free (buf); + } + + /* We silently ignore the image if it isn't a pixmap or text. */ + } + + tb->dirty = 0; +} + +static int +gtk_get_button_size (struct frame *f, Lisp_Object window, + struct toolbar_button *tb, int vert, int pos) +{ + int shadow_thickness = 2; + int size; + + if (tb->blank) + { + if (!NILP (tb->down_glyph)) + size = XINT (tb->down_glyph); + else + size = DEFAULT_TOOLBAR_BLANK_SIZE; + } + else + { + struct window *w = XWINDOW (window); + Lisp_Object glyph = get_toolbar_button_glyph (w, tb); + + /* Unless, of course, the user has done something stupid like + change the glyph out from under us. Use a blank placeholder + in that case. */ + if (NILP (glyph)) + return XINT (f->toolbar_size[pos]); + + if (vert) + size = glyph_height (glyph, window); + else + size = glyph_width (glyph, window); + } + + if (!size) + { + /* If the glyph doesn't have a size we'll insert a blank + placeholder instead. */ + return XINT (f->toolbar_size[pos]); + } + + size += shadow_thickness * 2; + + return (size); +} + +#define GTK_OUTPUT_BUTTONS_LOOP(left) \ + do { \ + while (!NILP (button)) \ + { \ + struct toolbar_button *tb = XTOOLBAR_BUTTON (button); \ + int size, height, width; \ + \ + if (left && tb->pushright) \ + break; \ + \ + size = gtk_get_button_size (f, window, tb, vert, pos); \ + \ + if (vert) \ + { \ + width = bar_width; \ + if (y + size > max_pixpos) \ + height = max_pixpos - y; \ + else \ + height = size; \ + } \ + else \ + { \ + if (x + size > max_pixpos) \ + width = max_pixpos - x; \ + else \ + width = size; \ + height = bar_height; \ + } \ + \ + if (tb->x != x \ + || tb->y != y \ + || tb->width != width \ + || tb->height != height \ + || tb->dirty) \ + { \ + if (width && height) \ + { \ + tb->x = x; \ + tb->y = y; \ + tb->width = width; \ + tb->height = height; \ + tb->border_width = border_width; \ + tb->vertical = vert; \ + \ + if (tb->blank || NILP (tb->up_glyph)) \ + { \ + int threed = (EQ (Qt, tb->up_glyph) ? 1 : 0); \ + gtk_draw_blank_toolbar_button (f, x, y, width, \ + height, threed, \ + border_width, vert); \ + } \ + else \ + gtk_output_toolbar_button (f, button); \ + } \ + } \ + \ + if (vert) \ + y += height; \ + else \ + x += width; \ + \ + if ((vert && y == max_pixpos) || (!vert && x == max_pixpos)) \ + button = Qnil; \ + else \ + button = tb->next; \ + } \ + } while (0) + +#define SET_TOOLBAR_WAS_VISIBLE_FLAG(frame, pos, flag) \ + do { \ + switch (pos) \ + { \ + case TOP_TOOLBAR: \ + (frame)->top_toolbar_was_visible = flag; \ + break; \ + case BOTTOM_TOOLBAR: \ + (frame)->bottom_toolbar_was_visible = flag; \ + break; \ + case LEFT_TOOLBAR: \ + (frame)->left_toolbar_was_visible = flag; \ + break; \ + case RIGHT_TOOLBAR: \ + (frame)->right_toolbar_was_visible = flag; \ + break; \ + default: \ + abort (); \ + } \ + } while (0) + +static void +gtk_output_toolbar (struct frame *f, enum toolbar_pos pos) +{ + int x, y, bar_width, bar_height, vert; + int max_pixpos, right_size, right_start, blank_size; + int border_width = FRAME_REAL_TOOLBAR_BORDER_WIDTH (f, pos); + Lisp_Object button, window; + GdkWindow *x_win = FRAME_GTK_TEXT_WIDGET (f)->window; + GdkGC *background_gc = get_toolbar_gc (f); + + get_toolbar_coords (f, pos, &x, &y, &bar_width, &bar_height, &vert, 1); + window = FRAME_LAST_NONMINIBUF_WINDOW (f); + + /* Do the border */ + gdk_draw_rectangle (x_win, background_gc, TRUE, x, y, + (vert ? bar_width : border_width), + (vert ? border_width : bar_height)); + gdk_draw_rectangle (x_win, background_gc, TRUE, + (vert ? x : x + bar_width - border_width), + (vert ? y + bar_height - border_width : y), + (vert ? bar_width : border_width), + (vert ? border_width : bar_height)); + + if (vert) + { + max_pixpos = y + bar_height - border_width; + y += border_width; + } + else + { + max_pixpos = x + bar_width - border_width; + x += border_width; + } + + button = FRAME_TOOLBAR_BUTTONS (f, pos); + right_size = 0; + + /* First loop over all of the buttons to determine how much room we + need for left hand and right hand buttons. This loop will also + make sure that all instances are instantiated so when we actually + output them they will come up immediately. */ + while (!NILP (button)) + { + struct toolbar_button *tb = XTOOLBAR_BUTTON (button); + int size = gtk_get_button_size (f, window, tb, vert, pos); + + if (tb->pushright) + right_size += size; + + button = tb->next; + } + + button = FRAME_TOOLBAR_BUTTONS (f, pos); + + /* Loop over the left buttons, updating and outputting them. */ + GTK_OUTPUT_BUTTONS_LOOP (1); + + /* Now determine where the right buttons start. */ + right_start = max_pixpos - right_size; + if (right_start < (vert ? y : x)) + right_start = (vert ? y : x); + + /* Output the blank which goes from the end of the left buttons to + the start of the right. */ + blank_size = right_start - (vert ? y : x); + if (blank_size) + { + int height, width; + + if (vert) + { + width = bar_width; + height = blank_size; + } + else + { + width = blank_size; + height = bar_height; + } + + /* + * Use a 3D pushright separator only if there isn't a toolbar + * border. A flat separator meshes with the border and looks + * better. + */ + gtk_draw_blank_toolbar_button (f, x, y, width, height, !border_width, + border_width, vert); + + if (vert) + y += height; + else + x += width; + } + + /* Loop over the right buttons, updating and outputting them. */ + GTK_OUTPUT_BUTTONS_LOOP (0); + + if (!vert) + { + Lisp_Object frame; + + XSETFRAME (frame, f); + redisplay_clear_region (frame, + DEFAULT_INDEX, FRAME_PIXWIDTH (f) - 1, y, 1, + bar_height); + } + + SET_TOOLBAR_WAS_VISIBLE_FLAG (f, pos, 1); + + gdk_flush (); +} + +static void +gtk_clear_toolbar (struct frame *f, enum toolbar_pos pos, int thickness_change) +{ + Lisp_Object frame; + int x, y, width, height, vert; + + get_toolbar_coords (f, pos, &x, &y, &width, &height, &vert, 1); + XSETFRAME (frame, f); + + /* The thickness_change parameter is used by the toolbar resize routines + to clear any excess toolbar if the size shrinks. */ + if (thickness_change < 0) + { + if (pos == LEFT_TOOLBAR || pos == RIGHT_TOOLBAR) + { + x = x + width + thickness_change; + width = -thickness_change; + } + else + { + y = y + height + thickness_change; + height = -thickness_change; + } + } + + SET_TOOLBAR_WAS_VISIBLE_FLAG (f, pos, 0); + + redisplay_clear_region (frame, DEFAULT_INDEX, x, y, width, height); + gdk_flush (); +} + +static void +gtk_output_frame_toolbars (struct frame *f) +{ + assert (FRAME_GTK_P (f)); + + if (FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) + gtk_output_toolbar (f, TOP_TOOLBAR); + else if (f->top_toolbar_was_visible) + gtk_clear_toolbar (f, TOP_TOOLBAR, 0); + + if (FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) + gtk_output_toolbar (f, BOTTOM_TOOLBAR); + else if (f->bottom_toolbar_was_visible) + gtk_clear_toolbar (f, BOTTOM_TOOLBAR, 0); + + if (FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) + gtk_output_toolbar (f, LEFT_TOOLBAR); + else if (f->left_toolbar_was_visible) + gtk_clear_toolbar (f, LEFT_TOOLBAR, 0); + + if (FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) + gtk_output_toolbar (f, RIGHT_TOOLBAR); + else if (f->right_toolbar_was_visible) + gtk_clear_toolbar (f, RIGHT_TOOLBAR, 0); +} + +static void +gtk_redraw_exposed_toolbar (struct frame *f, enum toolbar_pos pos, int x, int y, + int width, int height) +{ + int bar_x, bar_y, bar_width, bar_height, vert; + Lisp_Object button = FRAME_TOOLBAR_BUTTONS (f, pos); + + get_toolbar_coords (f, pos, &bar_x, &bar_y, &bar_width, &bar_height, + &vert, 1); + + if (((y + height) < bar_y) || (y > (bar_y + bar_height))) + return; + if (((x + width) < bar_x) || (x > (bar_x + bar_width))) + return; + + while (!NILP (button)) + { + struct toolbar_button *tb = XTOOLBAR_BUTTON (button); + + if (vert) + { + if (((tb->y + tb->height) > y) && (tb->y < (y + height))) + tb->dirty = 1; + + /* If this is true we have gone past the exposed region. */ + if (tb->y > (y + height)) + break; + } + else + { + if (((tb->x + tb->width) > x) && (tb->x < (x + width))) + tb->dirty = 1; + + /* If this is true we have gone past the exposed region. */ + if (tb->x > (x + width)) + break; + } + + button = tb->next; + } + + /* Even if none of the buttons is in the area, the blank region at + the very least must be because the first thing we did is verify + that some portion of the toolbar is in the exposed region. */ + gtk_output_toolbar (f, pos); +} + +static void +gtk_redraw_exposed_toolbars (struct frame *f, int x, int y, int width, + int height) +{ + assert (FRAME_GTK_P (f)); + + if (FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) + gtk_redraw_exposed_toolbar (f, TOP_TOOLBAR, x, y, width, height); + + if (FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) + gtk_redraw_exposed_toolbar (f, BOTTOM_TOOLBAR, x, y, width, height); + + if (FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) + gtk_redraw_exposed_toolbar (f, LEFT_TOOLBAR, x, y, width, height); + + if (FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) + gtk_redraw_exposed_toolbar (f, RIGHT_TOOLBAR, x, y, width, height); +} + +static void +gtk_redraw_frame_toolbars (struct frame *f) +{ + /* There are certain startup paths that lead to update_EmacsFrame in + faces.c being called before a new frame is fully initialized. In + particular before we have actually mapped it. That routine can + call this one. So, we need to make sure that the frame is + actually ready before we try and draw all over it. */ + + if (GTK_WIDGET_REALIZED (FRAME_GTK_TEXT_WIDGET (f))) + gtk_redraw_exposed_toolbars (f, 0, 0, FRAME_PIXWIDTH (f), + FRAME_PIXHEIGHT (f)); +} + + +static void +gtk_initialize_frame_toolbars (struct frame *f) +{ +} + +/* This only calls one function but we go ahead and create this in + case we ever do decide that we need to do more work. */ +static void +gtk_free_frame_toolbars (struct frame *f) +{ +} + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +console_type_create_toolbar_gtk (void) +{ + CONSOLE_HAS_METHOD (gtk, output_frame_toolbars); + CONSOLE_HAS_METHOD (gtk, initialize_frame_toolbars); + CONSOLE_HAS_METHOD (gtk, free_frame_toolbars); + CONSOLE_HAS_METHOD (gtk, output_toolbar_button); + CONSOLE_HAS_METHOD (gtk, redraw_exposed_toolbars); + CONSOLE_HAS_METHOD (gtk, redraw_frame_toolbars); +} diff --git a/src/ui-byhand.c b/src/ui-byhand.c new file mode 100644 index 0000000..ac1960c --- /dev/null +++ b/src/ui-byhand.c @@ -0,0 +1,692 @@ +/* I really wish this entire file could go away, but there is + currently no way to do the following in the Foreign Function + Interface: + + 1) Deal with return values in the parameter list (ie: int *foo) + + So we have to code a few functions by hand. Ick. + + William M. Perry 5/8/00 +*/ + +#include "gui.h" + +DEFUN ("gtk-box-query-child-packing", Fgtk_box_query_child_packing, 2, 2,0, /* +Returns information about how CHILD is packed into BOX. +Return value is a list of (EXPAND FILL PADDING PACK_TYPE). +*/ + (box, child)) +{ + gboolean expand, fill; + guint padding; + GtkPackType pack_type; + Lisp_Object result = Qnil; + + CHECK_GTK_OBJECT (box); + CHECK_GTK_OBJECT (child); + + if (!GTK_IS_BOX (XGTK_OBJECT (box)->object)) + { + signal_simple_error ("Object is not a GtkBox", box); + } + + if (!GTK_IS_WIDGET (XGTK_OBJECT (child)->object)) + { + signal_simple_error ("Child is not a GtkWidget", child); + } + + gtk_box_query_child_packing (GTK_BOX (XGTK_OBJECT (box)->object), + GTK_WIDGET (XGTK_OBJECT (child)->object), + &expand, &fill, &padding, &pack_type); + + result = Fcons (make_int (pack_type), result); + result = Fcons (make_int (padding), result); + result = Fcons (fill ? Qt : Qnil, result); + result = Fcons (expand ? Qt : Qnil, result); + + return (result); +} + +/* void gtk_button_box_get_child_size_default (gint *min_width, gint *min_height); */ +DEFUN ("gtk-button-box-get-child-size-default", + Fgtk_button_box_get_child_size_default, 0, 0, 0, /* +Return a cons cell (WIDTH . HEIGHT) of the default button box child size. +*/ + ()) +{ + gint width, height; + + gtk_button_box_get_child_size_default (&width, &height); + + return (Fcons (make_int (width), make_int (height))); +} + +/* void gtk_button_box_get_child_ipadding_default (gint *ipad_x, gint *ipad_y); */ +DEFUN ("gtk-button-box-get-child-ipadding-default", + Fgtk_button_box_get_child_ipadding_default, 0, 0, 0, /* +Return a cons cell (X . Y) of the default button box ipadding. +*/ + ()) +{ + gint x, y; + + gtk_button_box_get_child_ipadding_default (&x, &y); + + return (Fcons (make_int (x), make_int (y))); +} + +/* void gtk_button_box_get_child_size (GtkButtonBox *widget, + gint *min_width, gint *min_height); */ +DEFUN ("gtk-button-box-get-child-size", Fgtk_button_box_get_child_size, 1, 1, 0, /* +Get the current size of a child in the buttonbox BOX. +*/ + (box)) +{ + gint width, height; + + CHECK_GTK_OBJECT (box); + + if (!GTK_IS_BUTTON_BOX (XGTK_OBJECT (box)->object)) + { + signal_simple_error ("Not a GtkBox object", box); + } + + gtk_button_box_get_child_size (GTK_BUTTON_BOX (XGTK_OBJECT (box)->object), + &width, &height); + + return (Fcons (make_int (width), make_int (height))); +} + +/* void gtk_button_box_get_child_ipadding (GtkButtonBox *widget, gint *ipad_x, gint *ipad_y); */ +DEFUN ("gtk-button-box-get-child-ipadding", + Fgtk_button_box_get_child_ipadding, 1, 1, 0, /* +Return a cons cell (X . Y) of the current buttonbox BOX ipadding. +*/ + (box)) +{ + gint x, y; + + CHECK_GTK_OBJECT (box); + + if (!GTK_IS_BUTTON_BOX (XGTK_OBJECT (box)->object)) + { + signal_simple_error ("Not a GtkBox object", box); + } + + gtk_button_box_get_child_ipadding (GTK_BUTTON_BOX (XGTK_OBJECT (box)->object), + &x, &y); + + return (Fcons (make_int (x), make_int (y))); +} + +/*void gtk_calendar_get_date (GtkCalendar *calendar, + guint *year, + guint *month, + guint *day); +*/ +DEFUN ("gtk-calendar-get-date", Fgtk_calendar_get_date, 1, 1, 0, /* +Return a list of (YEAR MONTH DAY) from the CALENDAR object. +*/ + (calendar)) +{ + guint year, month, day; + + CHECK_GTK_OBJECT (calendar); + + if (!GTK_IS_CALENDAR (XGTK_OBJECT (calendar)->object)) + { + signal_simple_error ("Not a GtkCalendar object", calendar); + } + + gtk_calendar_get_date (GTK_CALENDAR (XGTK_OBJECT (calendar)->object), + &year, &month, &day); + + return (list3 (make_int (year), make_int (month), make_int (day))); +} + +/* gint gtk_clist_get_text (GtkCList *clist, + gint row, + gint column, + gchar **text); +*/ +DEFUN ("gtk-clist-get-text", Fgtk_clist_get_text, 3, 3, 0, /* +Returns the text from GtkCList OBJ cell at coordinates ROW, COLUMN. +*/ + (obj, row, column)) +{ + gchar *text = NULL; + Lisp_Object rval = Qnil; + + CHECK_GTK_OBJECT (obj); + CHECK_INT (row); + CHECK_INT (column); + + if (!GTK_IS_CLIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCList", obj); + } + + gtk_clist_get_text (GTK_CLIST (XGTK_OBJECT (obj)->object), XINT (row), XINT (column), &text); + + if (text) + { + rval = build_string (text); + /* NOTE: This is NOT a memory leak. GtkCList returns a pointer + to internally used memory, not a copy of it. + g_free (text); + */ + } + + return (rval); +} + +/* gint gtk_clist_get_selection_info (GtkCList *clist, + gint x, + gint y, + gint *row, + gint *column); */ +DEFUN ("gtk-clist-get-selection-info", Fgtk_clist_get_selection, 3, 3, 0, /* +Returns a cons cell of (ROW . COLUMN) of the GtkCList OBJ at coordinates X, Y. +*/ + (obj, x, y)) +{ + gint row, column; + + CHECK_GTK_OBJECT (obj); + CHECK_INT (x); + CHECK_INT (y); + + if (!GTK_IS_CLIST (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkCList", obj); + } + + gtk_clist_get_selection_info (GTK_CLIST (XGTK_OBJECT (obj)->object), + XINT (x), XINT (y), &row, &column); + + return (Fcons (make_int (row), make_int (column))); +} + +DEFUN ("gtk-clist-get-pixmap", Fgtk_clist_get_pixmap, 3, 3, 0, /* +Return a cons of (pixmap . mask) at ROW,COLUMN in CLIST. +*/ + (clist, row, column)) +{ + GdkPixmap *pixmap = NULL; + GdkBitmap *mask = NULL; + + CHECK_GTK_OBJECT (clist); + CHECK_INT (row); + CHECK_INT (column); + + if (!GTK_IS_CLIST (XGTK_OBJECT (clist)->object)) + { + signal_simple_error ("Object is not a GtkCList", clist); + } + + gtk_clist_get_pixmap (GTK_CLIST (XGTK_OBJECT (clist)->object), + XINT (row), XINT (column), + &pixmap, &mask); + + return (Fcons (pixmap ? build_gtk_boxed (pixmap, GTK_TYPE_GDK_WINDOW) : Qnil, + mask ? build_gtk_boxed (mask, GTK_TYPE_GDK_WINDOW) : Qnil)); +} + +DEFUN ("gtk-clist-get-pixtext", Fgtk_clist_get_pixtext, 3, 3, 0, /* +Return a list of (pixmap mask text) at ROW,COLUMN in CLIST. +*/ + (clist, row, column)) +{ + GdkPixmap *pixmap = NULL; + GdkBitmap *mask = NULL; + char *text = NULL; + guint8 spacing; + + CHECK_GTK_OBJECT (clist); + CHECK_INT (row); + CHECK_INT (column); + + if (!GTK_IS_CLIST (XGTK_OBJECT (clist)->object)) + { + signal_simple_error ("Object is not a GtkCList", clist); + } + + gtk_clist_get_pixtext (GTK_CLIST (XGTK_OBJECT (clist)->object), + XINT (row), XINT (column), &text, &spacing, + &pixmap, &mask); + + return (list3 (pixmap ? build_gtk_boxed (pixmap, GTK_TYPE_GDK_WINDOW) : Qnil, + mask ? build_gtk_boxed (mask, GTK_TYPE_GDK_WINDOW) : Qnil, + (text && text[0]) ? build_string (text) : Qnil)); +} + +/* void gtk_color_selection_get_color(GtkColorSelection *colorsel, gdouble *color); */ +DEFUN ("gtk-color-selection-get-color", Fgtk_color_selection_get_color, 1, 1, 0, /* +Return a list of (RED GREEN BLUE ALPHA) from the GtkColorSelection OBJECT. +*/ + (object)) +{ + gdouble rgba[4]; + + CHECK_GTK_OBJECT (object); + + if (!GTK_IS_COLOR_SELECTION (XGTK_OBJECT (object)->object)) + { + signal_simple_error ("Object is not a GtkColorSelection", object); + } + + gtk_color_selection_get_color (GTK_COLOR_SELECTION (XGTK_OBJECT (object)), rgba); + + return (list4 (make_float (rgba[0]), + make_float (rgba[1]), + make_float (rgba[2]), + make_float (rgba[3]))); +} + +/* (gtk-import-function nil "gtk_editable_insert_text" 'GtkEditable 'GtkString 'gint 'pointer-to-gint) */ +DEFUN ("gtk-editable-insert-text", Fgtk_editable_insert_text, 3, 3, 0, /* +Insert text STRINT at POS in GtkEditable widget OBJ. +Returns the new position of the cursor in the widget. +*/ + (obj, string, pos)) +{ + gint the_pos; + + CHECK_GTK_OBJECT (obj); + CHECK_STRING (string); + CHECK_INT (pos); + + the_pos = XINT (pos); + + if (!GTK_IS_EDITABLE (XGTK_OBJECT (obj)->object)) + { + signal_simple_error ("Object is not a GtkEditable", obj); + } + + gtk_editable_insert_text (GTK_EDITABLE (XGTK_OBJECT (obj)->object), + (char *) XSTRING_DATA (string), + XSTRING_LENGTH (string), + &the_pos); + + return (make_int (the_pos)); +} + +DEFUN ("gtk-pixmap-get", Fgtk_pixmap_get, 1, 1, 0, /* +Return a cons cell of (PIXMAP . MASK) from GtkPixmap OBJECT. +*/ + (object)) +{ + GdkPixmap *pixmap, *mask; + + CHECK_GTK_OBJECT (object); + + if (!GTK_IS_PIXMAP (XGTK_OBJECT (object)->object)) + { + signal_simple_error ("Object is not a GtkPixmap", object); + } + + gtk_pixmap_get (GTK_PIXMAP (XGTK_OBJECT (object)->object), &pixmap, &mask); + + return (Fcons (pixmap ? build_gtk_object (GTK_OBJECT (pixmap)) : Qnil, + mask ? build_gtk_object (GTK_OBJECT (mask)) : Qnil)); +} + +DEFUN ("gtk-curve-get-vector", Fgtk_curve_get_vector, 2, 2, 0, /* +Returns a vector of LENGTH points representing the curve of CURVE. +*/ + (curve, length)) +{ + gfloat *vector = NULL; + Lisp_Object lisp_vector = Qnil; + int i; + + CHECK_GTK_OBJECT (curve); + CHECK_INT (length); + + if (!GTK_IS_CURVE (XGTK_OBJECT (curve)->object)) + { + signal_simple_error ("Object is not a GtkCurve", curve); + } + + vector = (gfloat *) alloca (sizeof (gfloat) * XINT (length)); + + gtk_curve_get_vector (GTK_CURVE (XGTK_OBJECT (curve)->object), XINT (length), vector); + lisp_vector = make_vector (XINT (length), Qnil); + + for (i = 0; i < XINT (length); i++) + { + XVECTOR_DATA (lisp_vector)[i] = make_float (vector[i]); + } + + return (lisp_vector); +} + +DEFUN ("gtk-curve-set-vector", Fgtk_curve_set_vector, 2, 2, 0, /* +Set the vector of points on CURVE to VECTOR. +*/ + (curve, vector)) +{ + gfloat *c_vector = NULL; + int vec_length = 0; + int i; + + CHECK_GTK_OBJECT (curve); + CHECK_VECTOR (vector); + + vec_length = XVECTOR_LENGTH (vector); + + if (!GTK_IS_CURVE (XGTK_OBJECT (curve)->object)) + { + signal_simple_error ("Object is not a GtkCurve", curve); + } + + c_vector = (gfloat *) alloca (sizeof (gfloat) * vec_length); + + for (i = 0; i < vec_length; i++) + { + CHECK_FLOAT (XVECTOR_DATA (vector)[i]); + c_vector[i] = extract_float (XVECTOR_DATA (vector)[i]); + } + + gtk_curve_set_vector (GTK_CURVE (XGTK_OBJECT (curve)->object), vec_length, c_vector); + return (Qt); +} + +DEFUN ("gtk-label-get", Fgtk_label_get, 1, 1, 0, /* +Return the text of LABEL. +*/ + (label)) +{ + gchar *string; + + CHECK_GTK_OBJECT (label); + + if (!GTK_IS_LABEL (XGTK_OBJECT (label)->object)) + { + signal_simple_error ("Object is not a GtkLabel", label); + } + + gtk_label_get (GTK_LABEL (XGTK_OBJECT (label)->object), &string); + + return (build_string (string)); +} + +DEFUN ("gtk-notebook-query-tab-label-packing", Fgtk_notebook_query_tab_label_packing, 2, 2, 0, /* +Return a list of packing information (EXPAND FILL PACK_TYPE) for CHILD in NOTEBOOK. +*/ + (notebook, child)) +{ + gboolean expand, fill; + GtkPackType pack_type; + + CHECK_GTK_OBJECT (notebook); + CHECK_GTK_OBJECT (child); + + if (!GTK_IS_NOTEBOOK (XGTK_OBJECT (notebook)->object)) + { + signal_simple_error ("Object is not a GtkLabel", notebook); + } + + if (!GTK_IS_WIDGET (XGTK_OBJECT (child)->object)) + { + signal_simple_error ("Object is not a GtkWidget", child); + } + + gtk_notebook_query_tab_label_packing (GTK_NOTEBOOK (XGTK_OBJECT (notebook)->object), + GTK_WIDGET (XGTK_OBJECT (child)->object), + &expand, &fill, &pack_type); + + return (list3 (expand ? Qt : Qnil, fill ? Qt : Qnil, make_int (pack_type))); +} + +DEFUN ("gtk-widget-get-pointer", Fgtk_widget_get_pointer, 1, 1, 0, /* +Return the pointer position relative to WIDGET as a cons of (X . Y). +*/ + (widget)) +{ + gint x,y; + CHECK_GTK_OBJECT (widget); + + if (!GTK_IS_WIDGET (XGTK_OBJECT (widget)->object)) + { + signal_simple_error ("Object is not a GtkWidget", widget); + } + + gtk_widget_get_pointer (GTK_WIDGET (XGTK_OBJECT (widget)->object), &x, &y); + + return (Fcons (make_int (x), make_int (y))); +} + +/* This is called whenever an item with a GUI_ID associated with it is + destroyed. This allows us to remove the references in gui-gtk.c + that made sure callbacks and such were GCPRO-ed +*/ +static void +__remove_gcpro_by_id (gpointer user_data) +{ + ungcpro_popup_callbacks ((GUI_ID) user_data); +} + +static void +__generic_toolbar_callback (GtkWidget *item, gpointer user_data) +{ + Lisp_Object callback; + Lisp_Object lisp_user_data; + + VOID_TO_LISP (callback, user_data); + + lisp_user_data = XCAR (callback); + callback = XCDR (callback); + + signal_special_gtk_user_event (Qnil, callback, lisp_user_data); +} + +static Lisp_Object +generic_toolbar_insert_item (Lisp_Object toolbar, + Lisp_Object text, + Lisp_Object tooltip_text, + Lisp_Object tooltip_private_text, + Lisp_Object icon, + Lisp_Object callback, + Lisp_Object data, + Lisp_Object prepend_p, + Lisp_Object position) +{ + GUI_ID id; + GtkWidget *w = NULL; + + CHECK_GTK_OBJECT (toolbar); + CHECK_GTK_OBJECT (icon); + CHECK_STRING (text); + CHECK_STRING (tooltip_text); + CHECK_STRING (tooltip_private_text); + + if (!SYMBOLP (callback) && !LISTP (callback)) + { + signal_simple_error ("Callback must be symbol or eval-able form", callback); + } + + if (!GTK_IS_TOOLBAR (XGTK_OBJECT (toolbar)->object)) + { + signal_simple_error ("Object is not a GtkToolbar", toolbar); + } + + if (!GTK_IS_WIDGET (XGTK_OBJECT (icon)->object)) + { + signal_simple_error ("Object is not a GtkWidget", icon); + } + + callback = Fcons (data, callback); + + id = new_gui_id (); + gcpro_popup_callbacks (id, callback); + gtk_object_weakref (XGTK_OBJECT (toolbar)->object, __remove_gcpro_by_id, + (gpointer) id); + + if (NILP (position)) + { + w = (NILP (prepend_p) ? gtk_toolbar_append_item : gtk_toolbar_prepend_item) + (GTK_TOOLBAR (XGTK_OBJECT (toolbar)->object), + XSTRING_DATA (text), + XSTRING_DATA (tooltip_text), + XSTRING_DATA (tooltip_private_text), + GTK_WIDGET (XGTK_OBJECT (icon)->object), + GTK_SIGNAL_FUNC (__generic_toolbar_callback), + LISP_TO_VOID (callback)); + } + else + { + w = gtk_toolbar_insert_item (GTK_TOOLBAR (XGTK_OBJECT (toolbar)->object), + XSTRING_DATA (text), + XSTRING_DATA (tooltip_text), + XSTRING_DATA (tooltip_private_text), + GTK_WIDGET (XGTK_OBJECT (icon)->object), + GTK_SIGNAL_FUNC (__generic_toolbar_callback), + LISP_TO_VOID (callback), + XINT (position)); + } + + + return (w ? build_gtk_object (GTK_OBJECT (w)) : Qnil); +} + +DEFUN ("gtk-toolbar-append-item", Fgtk_toolbar_append_item, 6, 7, 0, /* +Appends a new button to the given toolbar. +*/ + (toolbar, text, tooltip_text, tooltip_private_text, icon, callback, data)) +{ + return (generic_toolbar_insert_item (toolbar,text,tooltip_text,tooltip_private_text,icon,callback,data,Qnil,Qnil)); +} + +DEFUN ("gtk-toolbar-prepend-item", Fgtk_toolbar_prepend_item, 6, 7, 0, /* +Adds a new button to the beginning (left or top edges) of the given toolbar. +*/ + (toolbar, text, tooltip_text, tooltip_private_text, icon, callback, data)) +{ + return (generic_toolbar_insert_item (toolbar,text,tooltip_text,tooltip_private_text,icon,callback,data,Qt,Qnil)); +} + +DEFUN ("gtk-toolbar-insert-item", Fgtk_toolbar_insert_item, 7, 8, 0, /* +Adds a new button to the beginning (left or top edges) of the given toolbar. +*/ + (toolbar, text, tooltip_text, tooltip_private_text, icon, callback, position, data)) +{ + CHECK_INT (position); + + return (generic_toolbar_insert_item (toolbar,text,tooltip_text,tooltip_private_text,icon,callback,data,Qnil,position)); +} + +/* GtkCTree is an abomination in the eyes of the object system. */ +static void +__emacs_gtk_ctree_recurse_internal (GtkCTree *ctree, GtkCTreeNode *node, gpointer user_data) +{ + Lisp_Object closure; + + VOID_TO_LISP (closure, user_data); + + call3 (XCAR (closure), + build_gtk_object (GTK_OBJECT (ctree)), + build_gtk_boxed (node, GTK_TYPE_CTREE_NODE), + XCDR (closure)); +} + +DEFUN ("gtk-ctree-recurse", Fgtk_ctree_recurse, 3, 6, 0, /* +Recursively apply FUNC to all nodes of CTREE at or below NODE. +FUNC is called with three arguments: CTREE, a GtkCTreeNode, and DATA. +The return value of FUNC is ignored. + +If optional 5th argument CHILDFIRSTP is non-nil, then +the function is called for each node after it has been +called for that node's children. + +Optional 6th argument DEPTH limits how deeply to recurse. + +This function encompasses all the following Gtk functions: + +void gtk_ctree_post_recursive (GtkCTree *ctree, + GtkCTreeNode *node, + GtkCTreeFunc func, + gpointer data); +void gtk_ctree_post_recursive_to_depth (GtkCTree *ctree, + GtkCTreeNode *node, + gint depth, + GtkCTreeFunc func, + gpointer data); +void gtk_ctree_pre_recursive (GtkCTree *ctree, + GtkCTreeNode *node, + GtkCTreeFunc func, + gpointer data); +void gtk_ctree_pre_recursive_to_depth (GtkCTree *ctree, + GtkCTreeNode *node, + gint depth, + GtkCTreeFunc func, + gpointer data); +*/ + (ctree, node, func, data, childfirstp, depth)) +{ + struct gcpro gcpro1, gcpro2, gcpro3; + Lisp_Object closure = Qnil; + + CHECK_GTK_OBJECT (ctree); + + if (!NILP (node)) + { + CHECK_GTK_BOXED (node); + } + + if (!NILP (depth)) + { + CHECK_INT (depth); + } + + closure = Fcons (func, data); + + GCPRO3 (ctree, node, closure); + + if (NILP (depth)) + { + (NILP (childfirstp) ? gtk_ctree_post_recursive : gtk_ctree_pre_recursive) + (GTK_CTREE (XGTK_OBJECT (ctree)->object), + NILP (node) ? NULL : (GtkCTreeNode *) XGTK_BOXED (node)->object, + __emacs_gtk_ctree_recurse_internal, + LISP_TO_VOID (closure)); + } + else + { + (NILP (childfirstp) ? gtk_ctree_post_recursive_to_depth : gtk_ctree_pre_recursive_to_depth) + (GTK_CTREE (XGTK_OBJECT (ctree)->object), + NILP (node) ? NULL : (GtkCTreeNode *) XGTK_BOXED (node)->object, + XINT (depth), + __emacs_gtk_ctree_recurse_internal, + LISP_TO_VOID (closure)); + } + + UNGCPRO; + return (Qnil); +} + +void syms_of_ui_byhand (void) +{ + DEFSUBR (Fgtk_toolbar_append_item); + DEFSUBR (Fgtk_toolbar_insert_item); + DEFSUBR (Fgtk_toolbar_prepend_item); + DEFSUBR (Fgtk_box_query_child_packing); + DEFSUBR (Fgtk_button_box_get_child_size_default); + DEFSUBR (Fgtk_button_box_get_child_ipadding_default); + DEFSUBR (Fgtk_button_box_get_child_size); + DEFSUBR (Fgtk_button_box_get_child_ipadding); + DEFSUBR (Fgtk_calendar_get_date); + DEFSUBR (Fgtk_clist_get_text); + DEFSUBR (Fgtk_clist_get_selection); + DEFSUBR (Fgtk_clist_get_pixmap); + DEFSUBR (Fgtk_clist_get_pixtext); + DEFSUBR (Fgtk_color_selection_get_color); + DEFSUBR (Fgtk_editable_insert_text); + DEFSUBR (Fgtk_pixmap_get); + DEFSUBR (Fgtk_curve_get_vector); + DEFSUBR (Fgtk_curve_set_vector); + DEFSUBR (Fgtk_label_get); + DEFSUBR (Fgtk_notebook_query_tab_label_packing); + DEFSUBR (Fgtk_widget_get_pointer); + DEFSUBR (Fgtk_ctree_recurse); +} diff --git a/src/ui-gtk.c b/src/ui-gtk.c new file mode 100644 index 0000000..c7ddd3e --- /dev/null +++ b/src/ui-gtk.c @@ -0,0 +1,1903 @@ +/* ui-gtk.c +** +** Description: Creating 'real' UIs from lisp. +** +** Created by: William M. Perry +** Copyright (c) 2000 William M. Perry +** +*/ + +#include +#include "lisp.h" +#include "buffer.h" +#include "console-gtk.h" +#include "device.h" +#include "window.h" +#include "glyphs-gtk.h" +#include "objects-gtk.h" +#include "ui-gtk.h" +#include "faces.h" +#include "gui-gtk.h" +#include "sysdll.h" +#include "hash.h" +#include "events.h" +#include "elhash.h" + +/* XEmacs specific GTK types */ +#include "gtk-glue.c" + +Lisp_Object Qemacs_ffip; +Lisp_Object Qemacs_gtk_objectp; +Lisp_Object Qemacs_gtk_boxedp; +Lisp_Object Qvoid; +Lisp_Object Venumeration_info; + +static GHashTable *dll_cache; + +Lisp_Object gtk_type_to_lisp (GtkArg *arg); +int lisp_to_gtk_type (Lisp_Object obj, GtkArg *arg); +void describe_gtk_arg (GtkArg *arg); +guint symbol_to_enum (Lisp_Object obj, GtkType t); +static guint lisp_to_flag (Lisp_Object obj, GtkType t); +static Lisp_Object flags_to_list (guint value, GtkType t); +static Lisp_Object enum_to_symbol (guint value, GtkType t); + +#define NIL_OR_VOID_P(x) (NILP (x) || EQ (x, Qvoid)) + +static void +initialize_dll_cache (void) +{ + if (!dll_cache) + { + dll_cache = g_hash_table_new (g_str_hash, g_str_equal); + + g_hash_table_insert (dll_cache, "---XEmacs Internal Handle---", dll_open (NULL)); + } +} + +DEFUN ("dll-load", Fdll_load, 1, 1, 0, /* +Load a shared library DLL into XEmacs. No initialization routines are required. +This is for loading dependency DLLs into XEmacs. +*/ + (dll)) +{ + dll_handle h; + + CHECK_STRING (dll); + + initialize_dll_cache (); + + /* If the dll name has a directory component in it, then we should + expand it. */ + if (!NILP (Fstring_match (build_string ("/"), dll, Qnil, Qnil))) + dll = Fexpand_file_name (dll, Qnil); + + /* Check if we have already opened it first */ + h = g_hash_table_lookup (dll_cache, XSTRING_DATA (dll)); + + if (!h) + { + h = dll_open ((char *) XSTRING_DATA (dll)); + + if (h) + { + g_hash_table_insert (dll_cache, g_strdup (XSTRING_DATA (dll)), h); + } + else + { + signal_simple_error ("dll_open error", build_string (dll_error (NULL))); + } + } + return (h ? Qt : Qnil); +} + + +/* Gtk object importing */ +EXFUN (Fgtk_import_type, 1); + +static struct hash_table *internal_type_hash; + +static int +type_hash_equal(const void *arg1, const void *arg2) +{ + return ((GtkType) arg1 == (GtkType) arg2); +} + +static unsigned long +type_hash_hash(const void *arg) +{ + return ((unsigned long) arg); +} + +static int +type_already_imported_p (GtkType t) +{ + void *retval = NULL; + + /* These are cases that we don't need to import */ + switch (GTK_FUNDAMENTAL_TYPE (t)) + { + case GTK_TYPE_CHAR: + case GTK_TYPE_UCHAR: + case GTK_TYPE_BOOL: + case GTK_TYPE_INT: + case GTK_TYPE_UINT: + case GTK_TYPE_LONG: + case GTK_TYPE_ULONG: + case GTK_TYPE_FLOAT: + case GTK_TYPE_DOUBLE: + case GTK_TYPE_STRING: + case GTK_TYPE_BOXED: + case GTK_TYPE_POINTER: + case GTK_TYPE_SIGNAL: + case GTK_TYPE_ARGS: + case GTK_TYPE_CALLBACK: + case GTK_TYPE_C_CALLBACK: + case GTK_TYPE_FOREIGN: + return (1); + } + + if (!internal_type_hash) + { + internal_type_hash = make_general_hash_table (163, type_hash_hash, type_hash_equal); + return (0); + } + + if (gethash ((void *)t, internal_type_hash, (const void **)&retval)) + { + return (1); + } + return (0); +} + +static void +mark_type_as_imported (GtkType t) +{ + if (type_already_imported_p (t)) + return; + + puthash ((void *) t, (void *) 1, internal_type_hash); +} + +static void import_gtk_type (GtkType t); + +static void +import_gtk_object_internal (GtkType the_type) +{ + GtkType original_type = the_type; + int first_time = 1; + + do + { + GtkArg *args; + guint32 *flags; + guint n_args; + guint i; +#if 0 + GtkObjectClass *klass; + GtkSignalQuery *query; + guint32 *signals; + guint n_signals; +#endif + + /* Register the type before we do anything else with it... */ + if (!first_time) + { + if (!type_already_imported_p (the_type)) + { + import_gtk_type (the_type); + } + } + else + { + /* We need to mark the object type as imported here or we + run the risk of SERIOUS recursion when we do automatic + argument type importing. mark_type_as_imported() is + smart enough to be a noop if we attempt to register + things twice. */ + first_time = 0; + mark_type_as_imported (the_type); + } + + args = gtk_object_query_args(the_type,&flags,&n_args); + + /* First get the arguments the object can accept */ + for (i = 0; i < n_args; i++) + { + if ((args[i].type != original_type) && !type_already_imported_p (args[i].type)) + { + import_gtk_type (args[i].type); + } + } + + g_free(args); + g_free(flags); + +#if 0 + /* Now lets publish the signals */ + klass = (GtkObjectClass *) gtk_type_class (the_type); + signals = klass->signals; + n_signals = klass->nsignals; + + for (i = 0; i < n_signals; i++) + { + query = gtk_signal_query (signals[i]); + /* What do we want to do here? */ + g_free (query); + } +#endif + + the_type = gtk_type_parent(the_type); + } while (the_type != GTK_TYPE_INVALID); +} + +static void +import_gtk_enumeration_internal (GtkType the_type) +{ + GtkEnumValue *vals = gtk_type_enum_get_values (the_type); + Lisp_Object assoc = Qnil; + + if (NILP (Venumeration_info)) + { + Venumeration_info = call2 (intern ("make-hashtable"), make_int (100), Qequal); + } + + while (vals && vals->value_name) + { + assoc = Fcons (Fcons (intern (vals->value_nick), make_int (vals->value)), assoc); + assoc = Fcons (Fcons (intern (vals->value_name), make_int (vals->value)), assoc); + vals++; + } + + assoc = Fnreverse (assoc); + + Fputhash (make_int (the_type), assoc, Venumeration_info); +} + +static void +import_gtk_type (GtkType t) +{ + if (type_already_imported_p (t)) + { + return; + } + + switch (GTK_FUNDAMENTAL_TYPE (t)) + { + case GTK_TYPE_ENUM: + case GTK_TYPE_FLAGS: + import_gtk_enumeration_internal (t); + break; + case GTK_TYPE_OBJECT: + import_gtk_object_internal (t); + break; + default: + break; + } + + mark_type_as_imported (t); +} + + +/* Foreign function calls */ +static emacs_ffi_data * +allocate_ffi_data (void) +{ + emacs_ffi_data *data = alloc_lcrecord_type (emacs_ffi_data, &lrecord_emacs_ffi); + + data->return_type = GTK_TYPE_NONE; + data->n_args = 0; + data->function_name = Qnil; + data->function_ptr = 0; + data->marshal = 0; + + return (data); +} + +static Lisp_Object +mark_ffi_data (Lisp_Object obj) +{ + emacs_ffi_data *data = (emacs_ffi_data *) XFFI (obj); + + mark_object (data->function_name); + return (Qnil); +} + +static void +ffi_object_printer (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + char buf[200]; + + if (print_readably) + error ("printing unreadable object #function_ptr); + + write_c_string ("#function_name, printcharfun, 1); + if (XFFI (obj)->n_args) + { + sprintf (buf, " %d arguments", XFFI (obj)->n_args); + write_c_string (buf, printcharfun); + } + sprintf (buf, " %p>", (void *)XFFI (obj)->function_ptr); + write_c_string (buf, printcharfun); +} + +DEFINE_LRECORD_IMPLEMENTATION ("ffi", emacs_ffi, + mark_ffi_data, ffi_object_printer, + 0, 0, 0, NULL, emacs_ffi_data); + +typedef GtkObject * (*__OBJECT_fn) (); +typedef gint (*__INT_fn) (); +typedef void (*__NONE_fn) (); +typedef gchar * (*__STRING_fn) (); +typedef gboolean (*__BOOL_fn) (); +typedef gfloat (*__FLOAT_fn) (); +typedef void * (*__POINTER_fn) (); +typedef GList * (*__LIST_fn) (); + +/* An auto-generated file of marshalling functions. */ +#include "emacs-marshals.c" + +#define CONVERT_SINGLE_TYPE(var,nam,tp) case GTK_TYPE_##nam: GTK_VALUE_##nam (var) = * (tp *) v; break; +#define CONVERT_RETVAL(a,freep) \ + do { \ + void *v = GTK_VALUE_POINTER(a); \ + switch (GTK_FUNDAMENTAL_TYPE (a.type)) \ + { \ + CONVERT_SINGLE_TYPE(a,CHAR,gchar); \ + CONVERT_SINGLE_TYPE(a,UCHAR,guchar); \ + CONVERT_SINGLE_TYPE(a,BOOL,gboolean); \ + CONVERT_SINGLE_TYPE(a,INT,gint); \ + CONVERT_SINGLE_TYPE(a,UINT,guint); \ + CONVERT_SINGLE_TYPE(a,LONG,glong); \ + CONVERT_SINGLE_TYPE(a,ULONG,gulong); \ + CONVERT_SINGLE_TYPE(a,FLOAT,gfloat); \ + CONVERT_SINGLE_TYPE(a,DOUBLE,gdouble); \ + CONVERT_SINGLE_TYPE(a,STRING,gchar *); \ + CONVERT_SINGLE_TYPE(a,ENUM,gint); \ + CONVERT_SINGLE_TYPE(a,FLAGS,guint); \ + CONVERT_SINGLE_TYPE(a,BOXED,void *); \ + CONVERT_SINGLE_TYPE(a,POINTER,void *); \ + CONVERT_SINGLE_TYPE(a,OBJECT,GtkObject *); \ + default: \ + GTK_VALUE_POINTER (a) = * (void **) v; \ + break; \ + } \ + if (freep) xfree(v); \ + } while (0) + +gpointer __allocate_object_storage (GtkType t) +{ + size_t s = 0; + void *rval = NULL; + + switch (GTK_FUNDAMENTAL_TYPE (t)) + { + /* flag types */ + case GTK_TYPE_CHAR: + s = (sizeof (gchar)); + break; + case GTK_TYPE_UCHAR: + s = (sizeof (guchar)); + break; + case GTK_TYPE_BOOL: + s = (sizeof (gboolean)); + break; + case GTK_TYPE_INT: + s = (sizeof (gint)); + break; + case GTK_TYPE_UINT: + s = (sizeof (guint)); + break; + case GTK_TYPE_LONG: + s = (sizeof (glong)); + break; + case GTK_TYPE_ULONG: + s = (sizeof (gulong)); + break; + case GTK_TYPE_FLOAT: + s = (sizeof (gfloat)); + break; + case GTK_TYPE_DOUBLE: + s = (sizeof (gdouble)); + break; + case GTK_TYPE_STRING: + s = (sizeof (gchar *)); + break; + case GTK_TYPE_ENUM: + case GTK_TYPE_FLAGS: + s = (sizeof (guint)); + break; + case GTK_TYPE_BOXED: + case GTK_TYPE_POINTER: + s = (sizeof (void *)); + break; + + /* base type of the object system */ + case GTK_TYPE_OBJECT: + s = (sizeof (GtkObject *)); + break; + + default: + if (GTK_FUNDAMENTAL_TYPE (t) == GTK_TYPE_LISTOF) + { + s = (sizeof (void *)); + } + rval = NULL; + break; + } + + if (s) + { + rval = xmalloc (s); + memset (rval, '\0', s); + } + + return (rval); +} + +Lisp_Object type_to_marshaller_type (GtkType t) +{ + switch (GTK_FUNDAMENTAL_TYPE (t)) + { + case GTK_TYPE_NONE: + return (build_string ("NONE")); + /* flag types */ + case GTK_TYPE_CHAR: + case GTK_TYPE_UCHAR: + return (build_string ("CHAR")); + case GTK_TYPE_BOOL: + return (build_string ("BOOL")); + case GTK_TYPE_ENUM: + case GTK_TYPE_FLAGS: + case GTK_TYPE_INT: + case GTK_TYPE_UINT: + return (build_string ("INT")); + case GTK_TYPE_LONG: + case GTK_TYPE_ULONG: + return (build_string ("LONG")); + case GTK_TYPE_FLOAT: + case GTK_TYPE_DOUBLE: + return (build_string ("FLOAT")); + case GTK_TYPE_STRING: + return (build_string ("STRING")); + case GTK_TYPE_BOXED: + case GTK_TYPE_POINTER: + return (build_string ("POINTER")); + case GTK_TYPE_OBJECT: + return (build_string ("OBJECT")); + case GTK_TYPE_CALLBACK: + return (build_string ("CALLBACK")); + default: + /* I can't put this in the main switch statement because it is a + new fundamental type that is not fixed at compile time. + *sigh* + */ + if (GTK_FUNDAMENTAL_TYPE (t) == GTK_TYPE_ARRAY) + return (build_string ("ARRAY")); + + if (GTK_FUNDAMENTAL_TYPE (t) == GTK_TYPE_LISTOF) + return (build_string ("LIST")); + return (Qnil); + } +} + +struct __dll_mapper_closure { + void * (*func) (dll_handle, const char *); + const char *obj_name; + void **storage; +}; + +static void __dll_mapper (gpointer key, gpointer value, gpointer user_data) +{ + struct __dll_mapper_closure *closure = (struct __dll_mapper_closure *) user_data; + + if (*(closure->storage) == NULL) + { + /* Need to see if it is in this one */ + *(closure->storage) = closure->func ((dll_handle) value, closure->obj_name); + } +} + +DEFUN ("gtk-import-variable-internal", Fgtk_import_variable_internal, 2, 2, 0, /* +Import a variable into the XEmacs namespace. +*/ + (type, name)) +{ + void *var = NULL; + GtkArg arg; + + if (SYMBOLP (type)) type = Fsymbol_name (type); + + CHECK_STRING (type); + CHECK_STRING (name); + + initialize_dll_cache (); + xemacs_init_gtk_classes (); + + arg.type = gtk_type_from_name ((char *) XSTRING_DATA (type)); + + if (arg.type == GTK_TYPE_INVALID) + { + signal_simple_error ("Unknown type", type); + } + + /* Need to look thru the already-loaded dlls */ + { + struct __dll_mapper_closure closure; + + closure.func = dll_variable; + closure.obj_name = XSTRING_DATA (name); + closure.storage = &var; + + g_hash_table_foreach (dll_cache, __dll_mapper, &closure); + } + + if (!var) + { + signal_simple_error ("Could not locate variable", name); + } + + GTK_VALUE_POINTER(arg) = var; + CONVERT_RETVAL (arg, 0); + return (gtk_type_to_lisp (&arg)); +} + +DEFUN ("gtk-import-function-internal", Fgtk_import_function_internal, 2, 3, 0, /* +Import a function into the XEmacs namespace. +*/ + (rettype, name, args)) +{ + Lisp_Object rval = Qnil; + Lisp_Object marshaller = Qnil; + emacs_ffi_data *data = NULL; + gint n_args = 0; +#if 0 + dll_handle h = NULL; +#endif + ffi_marshalling_function marshaller_func = NULL; + ffi_actual_function name_func = NULL; + + CHECK_SYMBOL (rettype); + CHECK_STRING (name); + CHECK_LIST (args); + + initialize_dll_cache (); + xemacs_init_gtk_classes (); + + /* Need to look thru the already-loaded dlls */ + { + struct __dll_mapper_closure closure; + + closure.func = dll_function; + closure.obj_name = XSTRING_DATA (name); + closure.storage = (void **) &name_func; + + g_hash_table_foreach (dll_cache, __dll_mapper, &closure); + } + + if (!name_func) + { + signal_simple_error ("Could not locate function", name); + } + + data = allocate_ffi_data (); + + if (NILP (rettype)) + { + rettype = Qvoid; + } + + if (!NILP (args)) + { + Lisp_Object tail = Qnil; + Lisp_Object value = args; + Lisp_Object type = Qnil; + + EXTERNAL_LIST_LOOP (tail, value) + { + GtkType the_type; + Lisp_Object marshaller_type = Qnil; + + CHECK_SYMBOL (XCAR (tail)); + + type = Fsymbol_name (XCAR (tail)); + + the_type = gtk_type_from_name ((char *) XSTRING_DATA (type)); + + if (the_type == GTK_TYPE_INVALID) + { + signal_simple_error ("Unknown argument type", type); + } + + /* All things must be reduced to their basest form... */ + import_gtk_type (the_type); + data->args[n_args] = the_type; /* GTK_FUNDAMENTAL_TYPE (the_type); */ + + /* Now lets build up another chunk of our marshaller function name */ + marshaller_type = type_to_marshaller_type (data->args[n_args]); + + if (NILP (marshaller_type)) + { + signal_simple_error ("Do not know how to marshal", type); + } + marshaller = concat3 (marshaller, build_string ("_"), marshaller_type); + n_args++; + } + } + else + { + marshaller = concat3 (marshaller, build_string ("_"), type_to_marshaller_type (GTK_TYPE_NONE)); + } + + rettype = Fsymbol_name (rettype); + data->return_type = gtk_type_from_name ((char *) XSTRING_DATA (rettype)); + + if (data->return_type == GTK_TYPE_INVALID) + { + signal_simple_error ("Unknown return type", rettype); + } + + import_gtk_type (data->return_type); + + marshaller = concat3 (type_to_marshaller_type (data->return_type), build_string ("_"), marshaller); + marshaller = concat2 (build_string ("emacs_gtk_marshal_"), marshaller); + + marshaller_func = (ffi_marshalling_function) find_marshaller ((char *) XSTRING_DATA (marshaller)); + + if (!marshaller_func) + { + signal_simple_error ("Could not locate marshaller function", marshaller); + } + + data->n_args = n_args; + data->function_name = name; + data->function_ptr = name_func; + data->marshal = marshaller_func; + + XSETFFI (rval, data); + return (rval); +} + +DEFUN ("gtk-call-function", Fgtk_call_function, 1, 2, 0, /* +Call an external function. +*/ + (func, args)) +{ + GtkArg the_args[MAX_GTK_ARGS]; + gint n_args = 0; + Lisp_Object retval = Qnil; + + CHECK_FFI (func); + CHECK_LIST (args); + + n_args = XINT (Flength (args)); + +#ifdef XEMACS_IS_SMARTER_THAN_THE_PROGRAMMER + /* #### I think this is too dangerous to enable by default. + ** #### Genuine program bugs would probably be allowed to + ** #### slip by, and not be very easy to find. + ** #### Bill Perry July 9, 2000 + */ + if (n_args != XFFI(func)->n_args) + { + Lisp_Object for_append[3]; + + /* Signal an error if they pass in too many arguments */ + if (n_args > XFFI(func)->n_args) + { + return Fsignal (Qwrong_number_of_arguments, + list2 (func, make_int (n_args))); + } + + /* If they did not provide enough arguments, be nice and assume + ** they wanted `nil' in there. + */ + for_append[0] = args; + for_append[1] = Fmake_list (make_int (XFFI(func)->n_args - n_args), Qnil); + + args = Fappend (2, for_append); + } +#else + if (n_args != XFFI(func)->n_args) + { + /* Signal an error if they do not pass in the correct # of arguments */ + return Fsignal (Qwrong_number_of_arguments, + list2 (func, make_int (n_args))); + } +#endif + + if (!NILP (args)) + { + Lisp_Object tail = Qnil; + Lisp_Object value = args; + + CHECK_LIST (args); + n_args = 0; + + /* First we convert all of the arguments from Lisp to GtkArgs */ + EXTERNAL_LIST_LOOP (tail, value) + { + the_args[n_args].type = XFFI (func)->args[n_args]; + + if (lisp_to_gtk_type (XCAR (tail), &the_args[n_args])) + { + /* There was some sort of an error */ + signal_simple_error ("Error converting arguments", args); + } + n_args++; + } + } + + /* Now we need to tack on space for a return value, if they have + asked for one */ + if (XFFI (func)->return_type != GTK_TYPE_NONE) + { + the_args[n_args].type = XFFI (func)->return_type; + GTK_VALUE_POINTER (the_args[n_args]) = __allocate_object_storage (the_args[n_args].type); + n_args++; + } + + XFFI (func)->marshal ((ffi_actual_function) (XFFI (func)->function_ptr), the_args); + + if (XFFI (func)->return_type != GTK_TYPE_NONE) + { + CONVERT_RETVAL (the_args[n_args - 1], 1); + retval = gtk_type_to_lisp (&the_args[n_args - 1]); + } + + /* Need to free any array or list pointers */ + { + int i; + for (i = 0; i < n_args; i++) + { + if (GTK_FUNDAMENTAL_TYPE (the_args[i].type) == GTK_TYPE_ARRAY) + { + g_free (GTK_VALUE_POINTER (the_args[i])); + } + else if (GTK_FUNDAMENTAL_TYPE (the_args[i].type) == GTK_TYPE_LISTOF) + { + /* g_list_free (GTK_VALUE_POINTER (the_args[i])); */ + } + } + } + + return (retval); +} + + + +/* GtkObject wrapping for Lisp */ +static void +emacs_gtk_object_printer (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + char buf[200]; + + if (print_readably) + error ("printing unreadable object #", XGTK_OBJECT (obj)->object); + + write_c_string ("#alive_p) + write_c_string (gtk_type_name (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object)), printcharfun); + else + write_c_string ("dead", printcharfun); + sprintf (buf, ") %p>", (void *) XGTK_OBJECT (obj)->object); + write_c_string (buf, printcharfun); +} + +static Lisp_Object +object_getprop (Lisp_Object obj, Lisp_Object prop) +{ + Lisp_Object rval = Qnil; + Lisp_Object prop_name = Qnil; + GtkArgInfo *info = NULL; + char *err; + GtkArg args[2]; + + CHECK_SYMBOL (prop); /* Shouldn't need to ever do this, but I'm paranoid */ + + prop_name = Fsymbol_name (prop); + + args[0].name = (char *) XSTRING_DATA (prop_name); + + err = gtk_object_arg_get_info (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object), + args[0].name, + &info); + + if (err) + { + /* Not a magic symbol, fall back to just looking in our real plist */ + g_free (err); + + return (Fplist_get (XGTK_OBJECT (obj)->plist, prop, Qunbound)); + } + + if (!(info->arg_flags & GTK_ARG_READABLE)) + { + signal_simple_error ("Attempt to get write-only property", prop); + } + + gtk_object_getv (XGTK_OBJECT (obj)->object, 1, args); + + if (args[0].type == GTK_TYPE_INVALID) + { + /* If we can't get the attribute, then let the code in Fget know + so it can use the default value supplied by the caller */ + return (Qunbound); + } + + rval = gtk_type_to_lisp (&args[0]); + + /* Free up any memory. According to the documentation and Havoc's + book, if the fundamental type of the returned value is + GTK_TYPE_STRING, GTK_TYPE_BOXED, or GTK_TYPE_ARGS, you are + responsible for freeing it. */ + switch (GTK_FUNDAMENTAL_TYPE (args[0].type)) + { + case GTK_TYPE_STRING: + g_free (GTK_VALUE_STRING (args[0])); + break; + case GTK_TYPE_BOXED: + g_free (GTK_VALUE_BOXED (args[0])); + break; + case GTK_TYPE_ARGS: + g_free (GTK_VALUE_ARGS (args[0]).args); + default: + break; + } + + return (rval); +} + +static int +object_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value) +{ + GtkArgInfo *info = NULL; + Lisp_Object prop_name = Qnil; + GtkArg args[2]; + char *err = NULL; + + prop_name = Fsymbol_name (prop); + + args[0].name = (char *) XSTRING_DATA (prop_name); + + err = gtk_object_arg_get_info (GTK_OBJECT_TYPE (XGTK_OBJECT (obj)->object), + args[0].name, + &info); + + if (err) + { + /* Not a magic symbol, fall back to just storing in our real plist */ + g_free (err); + + XGTK_OBJECT (obj)->plist = Fplist_put (XGTK_OBJECT (obj)->plist, prop, value); + return (1); + } + + args[0].type = info->type; + + if (lisp_to_gtk_type (value, &args[0])) + { + signal_simple_error ("Error converting to GtkType", value); + } + + if (!(info->arg_flags & GTK_ARG_WRITABLE)) + { + signal_simple_error ("Attemp to set read-only argument", prop); + } + + gtk_object_setv (XGTK_OBJECT (obj)->object, 1, args); + + return (1); +} + +static Lisp_Object +mark_gtk_object_data (Lisp_Object obj) +{ + return (XGTK_OBJECT (obj)->plist); +} + +static void +emacs_gtk_object_finalizer (void *header, int for_disksave) +{ + emacs_gtk_object_data *data = (emacs_gtk_object_data *) header; + + if (for_disksave) + { + Lisp_Object obj; + XSETGTK_OBJECT (obj, data); + + signal_simple_error + ("Can't dump an emacs containing GtkObject objects", obj); + } + + if (data->alive_p) + { + gtk_object_unref (data->object); + } +} + +DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("GtkObject", emacs_gtk_object, + mark_gtk_object_data, /* marker function */ + emacs_gtk_object_printer, /* print function */ + emacs_gtk_object_finalizer, /* finalizer */ + 0, /* equality */ + 0, /* hash */ + NULL, /* desc */ + object_getprop, /* get prop */ + object_putprop, /* put prop */ + 0, /* rem prop */ + 0, /* plist */ + emacs_gtk_object_data); + +static emacs_gtk_object_data * +allocate_emacs_gtk_object_data (void) +{ + emacs_gtk_object_data *data = alloc_lcrecord_type (emacs_gtk_object_data, + &lrecord_emacs_gtk_object); + + data->object = NULL; + data->alive_p = FALSE; + data->plist = Qnil; + + return (data); +} + +/* We need to keep track of when the object is destroyed so that we + can mark it as dead, otherwise even our print routine (which calls + GTK_OBJECT_TYPE) will crap out and die. This is also used in the + lisp_to_gtk_type() routine to defend against passing dead objects + to GTK routines. */ +static void +__notice_object_destruction (GtkObject *obj, gpointer user_data) +{ + ungcpro_popup_callbacks ((GUI_ID) user_data); +} + +Lisp_Object build_gtk_object (GtkObject *obj) +{ + Lisp_Object retval = Qnil; + emacs_gtk_object_data *data = NULL; + GUI_ID id = 0; + + id = (GUI_ID) gtk_object_get_data (obj, "xemacs::gui_id"); + + if (id) + { + retval = get_gcpro_popup_callbacks (id); + } + + if (NILP (retval)) + { + data = allocate_emacs_gtk_object_data (); + + data->object = obj; + data->alive_p = TRUE; + XSETGTK_OBJECT (retval, data); + + id = new_gui_id (); + gtk_object_set_data (obj, "xemacs::gui_id", (gpointer) id); + gcpro_popup_callbacks (id, retval); + gtk_object_ref (obj); + gtk_signal_connect (obj, "destroy", GTK_SIGNAL_FUNC (__notice_object_destruction), (gpointer)id); + } + + return (retval); +} + +static void +__internal_callback_destroy (gpointer data) +{ + Lisp_Object lisp_data; + + VOID_TO_LISP (lisp_data, data); + + ungcpro_popup_callbacks (XINT (XCAR (lisp_data))); +} + +static void +__internal_callback_marshal (GtkObject *obj, gpointer data, guint n_args, GtkArg *args) +{ + Lisp_Object arg_list = Qnil; + Lisp_Object callback_fn = Qnil; + Lisp_Object callback_data = Qnil; + Lisp_Object newargs[3]; + Lisp_Object rval = Qnil; + struct gcpro gcpro1; + int i; + + VOID_TO_LISP (callback_fn, data); + + /* Nuke the GUI_ID off the front */ + callback_fn = XCDR (callback_fn); + + callback_data = XCAR (callback_fn); + callback_fn = XCDR (callback_fn); + + /* The callback data goes at the very end of the argument list */ + arg_list = Fcons (callback_data, Qnil); + + /* Build up the argument list, lisp style */ + for (i = n_args - 1; i >= 0; i--) + { + arg_list = Fcons (gtk_type_to_lisp (&args[i]), arg_list); + } + + /* We always pass the widget as the first parameter at the very least */ + arg_list = Fcons (build_gtk_object (obj), arg_list); + + GCPRO1 ((arg_list)); + + newargs[0] = callback_fn; + newargs[1] = arg_list; + + rval = Fapply (2, newargs); + signal_fake_event (); + + if (args[n_args].type != GTK_TYPE_NONE) + lisp_to_gtk_type (rval, &args[n_args]); + + UNGCPRO; +} + +DEFUN ("gtk-signal-connect", Fgtk_signal_connect, 3, 6, 0, /* +*/ + (obj, name, func, cb_data, object_signal, after_p)) +{ + int c_after; + int c_object_signal; + GUI_ID id = 0; + + CHECK_GTK_OBJECT (obj); + + if (SYMBOLP (name)) + name = Fsymbol_name (name); + + CHECK_STRING (name); + + if (NILP (object_signal)) + c_object_signal = 0; + else + c_object_signal = 1; + + if (NILP (after_p)) + c_after = 0; + else + c_after = 1; + + id = new_gui_id (); + func = Fcons (cb_data, func); + func = Fcons (make_int (id), func); + + gcpro_popup_callbacks (id, func); + + gtk_signal_connect_full (XGTK_OBJECT (obj)->object, (char *) XSTRING_DATA (name), + NULL, __internal_callback_marshal, LISP_TO_VOID (func), + __internal_callback_destroy, c_object_signal, c_after); + return (Qt); +} + + +/* GTK_TYPE_BOXED wrapper for Emacs lisp */ +static void +emacs_gtk_boxed_printer (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + char buf[200]; + + if (print_readably) + error ("printing unreadable object #", XGTK_BOXED (obj)->object); + + write_c_string ("#object_type), printcharfun); + sprintf (buf, ") %p>", (void *) XGTK_BOXED (obj)->object); + write_c_string (buf, printcharfun); +} + +static int +emacs_gtk_boxed_equality (Lisp_Object o1, Lisp_Object o2, int depth) +{ + emacs_gtk_boxed_data *data1 = XGTK_BOXED(o1); + emacs_gtk_boxed_data *data2 = XGTK_BOXED(o2); + + return ((data1->object == data2->object) && + (data1->object_type == data2->object_type)); +} + +static unsigned long +emacs_gtk_boxed_hash (Lisp_Object obj, int depth) +{ + emacs_gtk_boxed_data *data = XGTK_BOXED(obj); + return (HASH2 ((unsigned long)data->object, data->object_type)); +} + +DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("GtkBoxed", emacs_gtk_boxed, + 0, /* marker function */ + emacs_gtk_boxed_printer, /* print function */ + 0, /* nuker */ + emacs_gtk_boxed_equality, /* equality */ + emacs_gtk_boxed_hash, /* hash */ + NULL, /* desc */ + 0, /* get prop */ + 0, /* put prop */ + 0, /* rem prop */ + 0, /* plist */ + emacs_gtk_boxed_data); + +/* Currently defined GTK_TYPE_BOXED structures are: + + GtkAccelGroup - + GtkSelectionData - + GtkStyle - + GtkCTreeNode - + GdkColormap - + GdkVisual - + GdkFont - + GdkWindow - + GdkDragContext - + GdkEvent - + GdkColor - +*/ +static emacs_gtk_boxed_data * +allocate_emacs_gtk_boxed_data (void) +{ + emacs_gtk_boxed_data *data = alloc_lcrecord_type (emacs_gtk_boxed_data, + &lrecord_emacs_gtk_boxed); + + data->object = NULL; + data->object_type = GTK_TYPE_INVALID; + + return (data); +} + +Lisp_Object build_gtk_boxed (void *obj, GtkType t) +{ + Lisp_Object retval = Qnil; + emacs_gtk_boxed_data *data = NULL; + + if (GTK_FUNDAMENTAL_TYPE (t) != GTK_TYPE_BOXED) + abort(); + + data = allocate_emacs_gtk_boxed_data (); + data->object = obj; + data->object_type = t; + + XSETGTK_BOXED (retval, data); + + return (retval); +} + + +/* The automatically generated structure access routines */ +#include "emacs-widget-accessors.c" + +/* The hand generated funky functions that we can't just import using the FFI */ +#include "ui-byhand.c" + +/* The glade support */ +#include "glade.c" + + +/* Type manipulation */ +DEFUN ("gtk-fundamental-type", Fgtk_fundamental_type, 1, 1, 0, /* +Load a shared library DLL into XEmacs. No initialization routines are required. +This is for loading dependency DLLs into XEmacs. +*/ + (type)) +{ + GtkType t; + + if (SYMBOLP (type)) + type = Fsymbol_name (type); + + CHECK_STRING (type); + + t = gtk_type_from_name ((char *) XSTRING_DATA (type)); + + if (t == GTK_TYPE_INVALID) + { + signal_simple_error ("Not a GTK type", type); + } + return (make_int (GTK_FUNDAMENTAL_TYPE (t))); +} + +DEFUN ("gtk-object-type", Fgtk_object_type, 1, 1, 0, /* +Return the GtkType of OBJECT. +*/ + (object)) +{ + CHECK_GTK_OBJECT (object); + return (make_int (GTK_OBJECT_TYPE (XGTK_OBJECT (object)->object))); +} + +DEFUN ("gtk-describe-type", Fgtk_describe_type, 1, 1, 0, /* +Returns a cons of two lists describing the Gtk object TYPE. +The car is a list of all the signals that it will emit. +The cdr is a list of all the magic properties it has. +*/ + (type)) +{ + Lisp_Object rval, signals, props; + GtkType t; + + props = signals = rval = Qnil; + + if (SYMBOLP (type)) + { + type = Fsymbol_name (type); + } + + if (STRINGP (type)) + { + t = gtk_type_from_name (XSTRING_DATA (type)); + if (t == GTK_TYPE_INVALID) + { + signal_simple_error ("Not a GTK type", type); + } + } + else + { + CHECK_INT (type); + t = XINT (type); + } + + if (GTK_FUNDAMENTAL_TYPE (t) != GTK_TYPE_OBJECT) + { + signal_simple_error ("Not a GtkObject", type); + } + + /* Need to do stupid shit like this to get the args + ** registered... damn GTK and its lazy loading + */ + { + GtkArg args[3]; + GtkObject *obj = gtk_object_newv (t, 0, args); + + gtk_object_destroy(obj); + } + + do + { + guint i; + + /* Do the magic arguments first */ + { + GtkArg *args; + guint32 *flags; + guint n_args; + + args = gtk_object_query_args(t,&flags,&n_args); + + for (i = 0; i < n_args; i++) + { + props = Fcons (Fcons (intern (gtk_type_name(args[i].type)), + intern (args[i].name)), props); + } + + g_free (args); + g_free (flags); + } + + /* Now the signals */ + { + GtkObjectClass *klass; + GtkSignalQuery *query; + guint32 *gtk_signals; + guint n_signals; + + klass = (GtkObjectClass *) gtk_type_class (t); + gtk_signals = klass->signals; + n_signals = klass->nsignals; + + for (i = 0; i < n_signals; i++) + { + Lisp_Object params = Qnil; + + query = gtk_signal_query (gtk_signals[i]); + + if (query) + { + if (query->nparams) + { + int j; + + for (j = query->nparams - 1; j >= 0; j--) + { + params = Fcons (intern (gtk_type_name (query->params[j])), params); + } + } + + signals = Fcons (Fcons (intern (gtk_type_name (query->return_val)), + Fcons (intern (query->signal_name), + params)), + signals); + + g_free (query); + } + } + } + t = gtk_type_parent(t); + } while (t != GTK_TYPE_INVALID); + + rval = Fcons (signals, props); + + return (rval); +} + + +void +syms_of_ui_gtk (void) +{ + INIT_LRECORD_IMPLEMENTATION (emacs_ffi); + INIT_LRECORD_IMPLEMENTATION (emacs_gtk_object); + INIT_LRECORD_IMPLEMENTATION (emacs_gtk_boxed); + defsymbol (&Qemacs_ffip, "emacs-ffi-p"); + defsymbol (&Qemacs_gtk_objectp, "emacs-gtk-object-p"); + defsymbol (&Qemacs_gtk_boxedp, "emacs-gtk-boxed-p"); + defsymbol (&Qvoid, "void"); + DEFSUBR (Fdll_load); + DEFSUBR (Fgtk_import_function_internal); + DEFSUBR (Fgtk_import_variable_internal); + DEFSUBR (Fgtk_signal_connect); + DEFSUBR (Fgtk_call_function); + DEFSUBR (Fgtk_fundamental_type); + DEFSUBR (Fgtk_object_type); + DEFSUBR (Fgtk_describe_type); + syms_of_widget_accessors (); + syms_of_ui_byhand (); + syms_of_glade (); +} + +void +vars_of_ui_gtk (void) +{ + Fprovide (intern ("gtk-ui")); + DEFVAR_LISP ("gtk-enumeration-info", &Venumeration_info /* +A hashtable holding type information about GTK enumerations and flags. +Do NOT modify unless you really understand ui-gtk.c. +*/); + + Venumeration_info = Qnil; + vars_of_glade (); +} + + +/* Various utility functions */ +void describe_gtk_arg (GtkArg *arg) +{ + GtkArg a = *arg; + + switch (GTK_FUNDAMENTAL_TYPE (a.type)) + { + /* flag types */ + case GTK_TYPE_CHAR: + stderr_out ("char: %c\n", GTK_VALUE_CHAR (a)); + break; + case GTK_TYPE_UCHAR: + stderr_out ("uchar: %c\n", GTK_VALUE_CHAR (a)); + break; + case GTK_TYPE_BOOL: + stderr_out ("uchar: %s\n", GTK_VALUE_BOOL (a) ? "true" : "false"); + break; + case GTK_TYPE_INT: + stderr_out ("int: %d\n", GTK_VALUE_INT (a)); + break; + case GTK_TYPE_UINT: + stderr_out ("uint: %du\n", GTK_VALUE_UINT (a)); + break; + case GTK_TYPE_LONG: + stderr_out ("long: %ld\n", GTK_VALUE_LONG (a)); + break; + case GTK_TYPE_ULONG: + stderr_out ("ulong: %lu\n", GTK_VALUE_ULONG (a)); + break; + case GTK_TYPE_FLOAT: + stderr_out ("float: %g\n", GTK_VALUE_FLOAT (a)); + break; + case GTK_TYPE_DOUBLE: + stderr_out ("double: %f\n", GTK_VALUE_DOUBLE (a)); + break; + case GTK_TYPE_STRING: + stderr_out ("string: %s\n", GTK_VALUE_STRING (a)); + break; + case GTK_TYPE_ENUM: + case GTK_TYPE_FLAGS: + stderr_out ("%s: ", (a.type == GTK_TYPE_ENUM) ? "enum" : "flag"); + { + GtkEnumValue *vals = gtk_type_enum_get_values (a.type); + + while (vals && vals->value_name && (vals->value != GTK_VALUE_ENUM(a))) vals++; + + stderr_out ("%s\n", vals ? vals->value_name : "!!! UNKNOWN ENUM VALUE !!!"); + } + break; + case GTK_TYPE_BOXED: + stderr_out ("boxed: %p\n", GTK_VALUE_BOXED (a)); + break; + case GTK_TYPE_POINTER: + stderr_out ("pointer: %p\n", GTK_VALUE_BOXED (a)); + break; + + /* structured types */ + case GTK_TYPE_SIGNAL: + case GTK_TYPE_ARGS: /* This we can do as a list of values */ + abort(); + case GTK_TYPE_CALLBACK: + stderr_out ("callback fn: ...\n"); + break; + case GTK_TYPE_C_CALLBACK: + case GTK_TYPE_FOREIGN: + abort(); + + /* base type of the object system */ + case GTK_TYPE_OBJECT: + if (GTK_VALUE_OBJECT (a)) + stderr_out ("object: %s\n", gtk_type_name (GTK_OBJECT_TYPE (GTK_VALUE_OBJECT (a)))); + else + stderr_out ("object: NULL\n"); + break; + + default: + abort(); + } +} + +Lisp_Object gtk_type_to_lisp (GtkArg *arg) +{ + switch (GTK_FUNDAMENTAL_TYPE (arg->type)) + { + case GTK_TYPE_NONE: + return (Qnil); + case GTK_TYPE_CHAR: + return (make_char (GTK_VALUE_CHAR (*arg))); + case GTK_TYPE_UCHAR: + return (make_char (GTK_VALUE_UCHAR (*arg))); + case GTK_TYPE_BOOL: + return (GTK_VALUE_BOOL (*arg) ? Qt : Qnil); + case GTK_TYPE_INT: + return (make_int (GTK_VALUE_INT (*arg))); + case GTK_TYPE_UINT: + return (make_int (GTK_VALUE_INT (*arg))); + case GTK_TYPE_LONG: /* I think these are wrong! */ + return (make_int (GTK_VALUE_INT (*arg))); + case GTK_TYPE_ULONG: /* I think these are wrong! */ + return (make_int (GTK_VALUE_INT (*arg))); + case GTK_TYPE_FLOAT: + return (make_float (GTK_VALUE_FLOAT (*arg))); + case GTK_TYPE_DOUBLE: + return (make_float (GTK_VALUE_DOUBLE (*arg))); + case GTK_TYPE_STRING: + return (build_string (GTK_VALUE_STRING (*arg))); + case GTK_TYPE_FLAGS: + return (flags_to_list (GTK_VALUE_FLAGS (*arg), arg->type)); + case GTK_TYPE_ENUM: + return (enum_to_symbol (GTK_VALUE_ENUM (*arg), arg->type)); + case GTK_TYPE_BOXED: + if (arg->type == GTK_TYPE_GDK_EVENT) + { + return (gdk_event_to_emacs_event((GdkEvent *) GTK_VALUE_BOXED (*arg))); + } + + if (GTK_VALUE_BOXED (*arg)) + return (build_gtk_boxed (GTK_VALUE_BOXED (*arg), arg->type)); + else + return (Qnil); + case GTK_TYPE_POINTER: + if (GTK_VALUE_POINTER (*arg)) + { + Lisp_Object rval; + + VOID_TO_LISP (rval, GTK_VALUE_POINTER (*arg)); + return (rval); + } + else + return (Qnil); + case GTK_TYPE_OBJECT: + if (GTK_VALUE_OBJECT (*arg)) + return (build_gtk_object (GTK_VALUE_OBJECT (*arg))); + else + return (Qnil); + + case GTK_TYPE_CALLBACK: + { + Lisp_Object rval; + + VOID_TO_LISP (rval, GTK_VALUE_CALLBACK (*arg).data); + + return (rval); + } + + default: + if (GTK_FUNDAMENTAL_TYPE (arg->type) == GTK_TYPE_LISTOF) + { + if (!GTK_VALUE_POINTER (*arg)) + return (Qnil); + else + { + return (xemacs_gtklist_to_list (arg)); + } + } + stderr_out ("Do not know how to convert `%s' to lisp!\n", gtk_type_name (arg->type)); + abort (); + } + /* This is chuck reminding GCC to... SHUT UP! */ + return (Qnil); +} + +int lisp_to_gtk_type (Lisp_Object obj, GtkArg *arg) +{ + switch (GTK_FUNDAMENTAL_TYPE (arg->type)) + { + /* flag types */ + case GTK_TYPE_NONE: + return (0); + case GTK_TYPE_CHAR: + { + Emchar c; + + CHECK_CHAR_COERCE_INT (obj); + c = XCHAR (obj); + GTK_VALUE_CHAR (*arg) = c; + } + break; + case GTK_TYPE_UCHAR: + { + Emchar c; + + CHECK_CHAR_COERCE_INT (obj); + c = XCHAR (obj); + GTK_VALUE_CHAR (*arg) = c; + } + break; + case GTK_TYPE_BOOL: + GTK_VALUE_BOOL (*arg) = NILP (obj) ? FALSE : TRUE; + break; + case GTK_TYPE_INT: + case GTK_TYPE_UINT: + if (NILP (obj) || EQ (Qt, obj)) + { + /* For we are a kind mistress and allow sending t/nil for + 1/0 to stupid GTK functions that say they take guint or + gint in the header files, but actually treat it like a + bool. *sigh* + */ + GTK_VALUE_INT(*arg) = NILP (obj) ? 0 : 1; + } + else + { + CHECK_INT (obj); + GTK_VALUE_INT(*arg) = XINT (obj); + } + break; + case GTK_TYPE_LONG: + case GTK_TYPE_ULONG: + abort(); + case GTK_TYPE_FLOAT: + CHECK_INT_OR_FLOAT (obj); + GTK_VALUE_FLOAT(*arg) = extract_float (obj); + break; + case GTK_TYPE_DOUBLE: + CHECK_INT_OR_FLOAT (obj); + GTK_VALUE_DOUBLE(*arg) = extract_float (obj); + break; + case GTK_TYPE_STRING: + if (NILP (obj)) + GTK_VALUE_STRING (*arg) = NULL; + else + { + CHECK_STRING (obj); + GTK_VALUE_STRING (*arg) = (char *) XSTRING_DATA (obj); + } + break; + case GTK_TYPE_ENUM: + case GTK_TYPE_FLAGS: + /* Convert a lisp symbol to a GTK enum */ + GTK_VALUE_ENUM(*arg) = lisp_to_flag (obj, arg->type); + break; + case GTK_TYPE_BOXED: + if (NILP (obj)) + { + GTK_VALUE_BOXED(*arg) = NULL; + } + else if (GTK_BOXEDP (obj)) + { + GTK_VALUE_BOXED(*arg) = XGTK_BOXED (obj)->object; + } + else if (arg->type == GTK_TYPE_STYLE) + { + obj = Ffind_face (obj); + CHECK_FACE (obj); + GTK_VALUE_BOXED(*arg) = face_to_style (obj); + } + else if (arg->type == GTK_TYPE_GDK_GC) + { + obj = Ffind_face (obj); + CHECK_FACE (obj); + GTK_VALUE_BOXED(*arg) = face_to_gc (obj); + } + else if (arg->type == GTK_TYPE_GDK_WINDOW) + { + if (GLYPHP (obj)) + { + Lisp_Object window = Fselected_window (Qnil); + Lisp_Object instance = glyph_image_instance (obj, window, ERROR_ME_NOT, 1); + struct Lisp_Image_Instance *p = XIMAGE_INSTANCE (instance); + + switch (XIMAGE_INSTANCE_TYPE (instance)) + { + case IMAGE_TEXT: + case IMAGE_POINTER: + case IMAGE_SUBWINDOW: + case IMAGE_NOTHING: + GTK_VALUE_BOXED(*arg) = NULL; + break; + + case IMAGE_MONO_PIXMAP: + case IMAGE_COLOR_PIXMAP: + GTK_VALUE_BOXED(*arg) = IMAGE_INSTANCE_GTK_PIXMAP (p); + break; + } + } + else if (GTK_OBJECTP (obj) && GTK_IS_WIDGET (XGTK_OBJECT (obj)->object)) + { + GTK_VALUE_BOXED(*arg) = GTK_WIDGET (XGTK_OBJECT (obj))->window; + } + else + { + signal_simple_error ("Don't know how to convert object to GDK_WINDOW", obj); + } + break; + } + else if (arg->type == GTK_TYPE_GDK_COLOR) + { + if (COLOR_SPECIFIERP (obj)) + { + /* If it is a specifier, we just convert it to an + instance, and let the ifs below handle it. + */ + obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil); + } + + if (COLOR_INSTANCEP (obj)) + { + /* Easiest one */ + GTK_VALUE_BOXED(*arg) = COLOR_INSTANCE_GTK_COLOR (XCOLOR_INSTANCE (obj)); + } + else if (STRINGP (obj)) + { + signal_simple_error ("Please use a color specifier or instance, not a string", obj); + } + else + { + signal_simple_error ("Don't know hot to convert to GdkColor", obj); + } + } + else if (arg->type == GTK_TYPE_GDK_FONT) + { + if (SYMBOLP (obj)) + { + /* If it is a symbol, we treat that as a face name */ + obj = Ffind_face (obj); + } + + if (FACEP (obj)) + { + /* If it is a face, we just grab the font specifier, and + cascade down until we finally reach a FONT_INSTANCE + */ + obj = Fget (obj, Qfont, Qnil); + } + + if (FONT_SPECIFIERP (obj)) + { + /* If it is a specifier, we just convert it to an + instance, and let the ifs below handle it + */ + obj = Fspecifier_instance (obj, Qnil, Qnil, Qnil); + } + + if (FONT_INSTANCEP (obj)) + { + /* Easiest one */ + GTK_VALUE_BOXED(*arg) = FONT_INSTANCE_GTK_FONT (XFONT_INSTANCE (obj)); + } + else if (STRINGP (obj)) + { + signal_simple_error ("Please use a font specifier or instance, not a string", obj); + } + else + { + signal_simple_error ("Don't know hot to convert to GdkColor", obj); + } + } + else + { + /* Unknown type to convert to boxed */ + stderr_out ("Don't know how to convert to boxed!\n"); + GTK_VALUE_BOXED(*arg) = NULL; + } + break; + + case GTK_TYPE_POINTER: + if (NILP (obj)) + GTK_VALUE_POINTER(*arg) = NULL; + else + GTK_VALUE_POINTER(*arg) = LISP_TO_VOID (obj); + break; + + /* structured types */ + case GTK_TYPE_SIGNAL: + case GTK_TYPE_ARGS: /* This we can do as a list of values */ + case GTK_TYPE_C_CALLBACK: + case GTK_TYPE_FOREIGN: + stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type)); + return (-1); + +#if 0 + /* #### BILL! */ + /* This is not used, and does not work with union type */ + case GTK_TYPE_CALLBACK: + { + GUI_ID id; + + id = new_gui_id (); + obj = Fcons (Qnil, obj); /* Empty data */ + obj = Fcons (make_int (id), obj); + + gcpro_popup_callbacks (id, obj); + + GTK_VALUE_CALLBACK(*arg).marshal = __internal_callback_marshal; + GTK_VALUE_CALLBACK(*arg).data = (gpointer) obj; + GTK_VALUE_CALLBACK(*arg).notify = __internal_callback_destroy; + } + break; +#endif + + /* base type of the object system */ + case GTK_TYPE_OBJECT: + if (NILP (obj)) + GTK_VALUE_OBJECT (*arg) = NULL; + else + { + CHECK_GTK_OBJECT (obj); + if (XGTK_OBJECT (obj)->alive_p) + GTK_VALUE_OBJECT (*arg) = XGTK_OBJECT (obj)->object; + else + signal_simple_error ("Attempting to pass dead object to GTK function", obj); + } + break; + + default: + if (GTK_FUNDAMENTAL_TYPE (arg->type) == GTK_TYPE_ARRAY) + { + if (NILP (obj)) + GTK_VALUE_POINTER(*arg) = NULL; + else + { + xemacs_list_to_array (obj, arg); + } + } + else if (GTK_FUNDAMENTAL_TYPE (arg->type) == GTK_TYPE_LISTOF) + { + if (NILP (obj)) + GTK_VALUE_POINTER(*arg) = NULL; + else + { + xemacs_list_to_gtklist (obj, arg); + } + } + else + { + stderr_out ("Do not know how to convert `%s' from lisp!\n", gtk_type_name (arg->type)); + abort(); + } + break; + } + + return (0); +} + +/* This is used in glyphs-gtk.c as well */ +static Lisp_Object +get_enumeration (GtkType t) +{ + Lisp_Object alist; + + if (NILP (Venumeration_info)) + { + Venumeration_info = call2 (intern ("make-hashtable"), make_int (100), Qequal); + } + + alist = Fgethash (make_int (t), Venumeration_info, Qnil); + + if (NILP (alist)) + { + import_gtk_enumeration_internal (t); + alist = Fgethash (make_int (t), Venumeration_info, Qnil); + } + return (alist); +} + +guint +symbol_to_enum (Lisp_Object obj, GtkType t) +{ + Lisp_Object alist = get_enumeration (t); + Lisp_Object value = Qnil; + + if (NILP (alist)) + { + signal_simple_error ("Unkown enumeration", build_string (gtk_type_name (t))); + } + + value = Fassq (obj, alist); + + if (NILP (value)) + { + signal_simple_error ("Unknown value", obj); + } + + CHECK_INT (XCDR (value)); + + return (XINT (XCDR (value))); +} + +static guint +lisp_to_flag (Lisp_Object obj, GtkType t) +{ + guint val = 0; + + if (NILP (obj)) + { + /* Do nothing */ + } + else if (SYMBOLP (obj)) + { + val = symbol_to_enum (obj, t); + } + else if (LISTP (obj)) + { + while (!NILP (obj)) + { + val |= symbol_to_enum (XCAR (obj), t); + obj = XCDR (obj); + } + } + else + { + /* abort ()? */ + } + return (val); +} + +static Lisp_Object +flags_to_list (guint value, GtkType t) +{ + Lisp_Object rval = Qnil; + Lisp_Object alist = get_enumeration (t); + + while (!NILP (alist)) + { + if (value & XINT (XCDR (XCAR (alist)))) + { + rval = Fcons (XCAR (XCAR (alist)), rval); + value &= ~(XINT (XCDR (XCAR (alist)))); + } + alist = XCDR (alist); + } + return (rval); +} + +static Lisp_Object +enum_to_symbol (guint value, GtkType t) +{ + Lisp_Object alist = get_enumeration (t); + Lisp_Object cell = Qnil; + + if (NILP (alist)) + { + signal_simple_error ("Unkown enumeration", build_string (gtk_type_name (t))); + } + + cell = Frassq (make_int (value), alist); + + return (NILP (cell) ? Qnil : XCAR (cell)); +} diff --git a/src/ui-gtk.h b/src/ui-gtk.h new file mode 100644 index 0000000..8fb48d1 --- /dev/null +++ b/src/ui-gtk.h @@ -0,0 +1,71 @@ +/* ui-gtk.h +** +** Description: +** +** Created by: William M. Perry +** Copyright (c) 2000 Aventail Corporation +** +*/ + +#ifndef __UI_GTK_H__ +#define __UI_GTK_H__ + +/* Encapsulate a foreign function call */ +#include +#include "sysdll.h" +#include "lrecord.h" + +typedef void (*ffi_actual_function) (void); +typedef void (*ffi_marshalling_function) (ffi_actual_function, GtkArg *); + +#define MAX_GTK_ARGS 100 + +typedef struct { + struct lcrecord_header header; + GtkType return_type; + GtkType args[MAX_GTK_ARGS]; + gint n_args; + Lisp_Object function_name; + dll_func function_ptr; + ffi_marshalling_function marshal; +} emacs_ffi_data; + +DECLARE_LRECORD (emacs_ffi, emacs_ffi_data); + +#define XFFI(x) XRECORD (x, emacs_ffi, emacs_ffi_data) +#define XSETFFI(x,p) XSETRECORD (x, p, emacs_ffi) +#define FFIP(x) RECORDP (x, emacs_ffi) +#define CHECK_FFI(x) CHECK_RECORD (x, emacs_ffi) + +/* Encapsulate a GtkObject in Lisp */ +typedef struct { + struct lcrecord_header header; + gboolean alive_p; + GtkObject *object; + Lisp_Object plist; +} emacs_gtk_object_data; + +DECLARE_LRECORD (emacs_gtk_object, emacs_gtk_object_data); + +#define XGTK_OBJECT(x) XRECORD (x, emacs_gtk_object, emacs_gtk_object_data) +#define XSETGTK_OBJECT(x,p) XSETRECORD (x, p, emacs_gtk_object) +#define GTK_OBJECTP(x) RECORDP (x, emacs_gtk_object) +#define CHECK_GTK_OBJECT(x) CHECK_RECORD (x, emacs_gtk_object) + +extern Lisp_Object build_gtk_object (GtkObject *obj); + +/* Encapsulate a GTK_TYPE_BOXED in lisp */ +typedef struct { + struct lcrecord_header header; + GtkType object_type; + void *object; +} emacs_gtk_boxed_data; + +DECLARE_LRECORD (emacs_gtk_boxed, emacs_gtk_boxed_data); + +#define XGTK_BOXED(x) XRECORD (x, emacs_gtk_boxed, emacs_gtk_boxed_data) +#define XSETGTK_BOXED(x,p) XSETRECORD (x, p, emacs_gtk_boxed) +#define GTK_BOXEDP(x) RECORDP (x, emacs_gtk_boxed) +#define CHECK_GTK_BOXED(x) CHECK_RECORD (x, emacs_gtk_boxed) + +#endif /* __UI_GTK_H__ */ diff --git a/tests/gtk/UNIMPLEMENTED b/tests/gtk/UNIMPLEMENTED new file mode 100644 index 0000000..5b8dd29 --- /dev/null +++ b/tests/gtk/UNIMPLEMENTED @@ -0,0 +1,12 @@ +This is a list of all the tests from GTK+ 1.2.8 that are not implemented. + +item factory -- Widget is not supported (useless with XEmacs menubar construction code) +rc file -- Function not imported +test idle -- XEmacs already has this functionality, no need to export GTK equivalent +cursors -- No converter from glyph to GdkCursor defined +saved position +shapes + +layout +modal window +tree diff --git a/tests/gtk/event-stream-tests.el b/tests/gtk/event-stream-tests.el new file mode 100644 index 0000000..3cdaf8e --- /dev/null +++ b/tests/gtk/event-stream-tests.el @@ -0,0 +1,74 @@ +;also do this: make two frames, one viewing "*scratch*", the other "foo". +;in *scratch*, type (sit-for 20)^J +;wait a couple of seconds, move cursor to foo, type "a" +;a should be inserted in foo. Cursor highlighting should not change in +;the meantime. + +;do it with sleep-for. move cursor into foo, then back into *scratch* +;before typing. +;repeat also with (accept-process-output nil 20) + +;make sure ^G aborts sit-for, sleep-for and accept-process-output: + + (defun tst () + (list (condition-case c + (sleep-for 20) + (quit c)) + (read-char))) + + (tst)^Ja^G ==> ((quit) 97) with no signal + (tst)^J^Ga ==> ((quit) 97) with no signal + (tst)^Jabc^G ==> ((quit) 97) with no signal, and "bc" inserted in buffer + +; with sit-for only do the 2nd test. +; Do all 3 tests with (accept-proccess-output nil 20) + +/* +Additional test cases for accept-process-output, sleep-for, sit-for. +Be sure you do all of the above checking for C-g and focus, too! + +; Make sure that timer handlers are run during, not after sit-for: +(defun timer-check () + (add-timeout 2 '(lambda (ignore) (message "timer ran")) nil) + (sit-for 5) + (message "after sit-for")) + +; The first message should appear after 2 seconds, and the final message +; 3 seconds after that. +; repeat above test with (sleep-for 5) and (accept-process-output nil 5) + +; Make sure that process filters are run during, not after sit-for. +(defun fubar () + (message "sit-for = %s" (sit-for 30))) +(add-hook 'post-command-hook 'fubar) + +; Now type M-x shell RET +; wait for the shell prompt then send: ls RET +; the output of ls should fill immediately, and not wait 30 seconds. + +; repeat above test with (sleep-for 30) and (accept-process-output nil 30) + + + +; Make sure that recursive invocations return immediately: +(defmacro test-diff-time (start end) + `(+ (* (- (car ,end) (car ,start)) 65536.0) + (- (cadr ,end) (cadr ,start)) + (/ (- (caddr ,end) (caddr ,start)) 1000000.0))) + +(defun testee (ignore) + (sit-for 10)) + +(defun test-them () + (let ((start (current-time)) + end) + (add-timeout 2 'testee nil) + (sit-for 5) + (add-timeout 2 'testee nil) + (sleep-for 5) + (add-timeout 2 'testee nil) + (accept-process-output nil 5) + (setq end (current-time)) + (test-diff-time start end))) + +(test-them) should sit for 15 seconds. diff --git a/tests/gtk/gnome-test.el b/tests/gtk/gnome-test.el new file mode 100644 index 0000000..8b0faf9 --- /dev/null +++ b/tests/gtk/gnome-test.el @@ -0,0 +1,247 @@ +(require 'gnome) + +(gtk-define-test + "GNOME Stock Pixmaps" gnome gnome-pixmaps nil + (let ((hbox nil) + (vbox nil) + (widget nil) + (label nil) + (i 0)) + (mapc (lambda (b) + (if (= (% i 5) 0) + (progn + (setq hbox (gtk-hbutton-box-new)) + (gtk-box-set-spacing hbox 5) + (gtk-container-add window hbox))) + + (setq widget (gnome-stock-pixmap-widget-new window (car b)) + vbox (gtk-vbox-new t 0) + label (gtk-label-new (cdr b))) + (gtk-container-add hbox vbox) + (gtk-container-add vbox widget) + (gtk-container-add vbox label) + (gtk-widget-show-all vbox) + (setq i (1+ i))) + gnome-stock-pixmaps))) + +(gtk-define-test + "GNOME Stock Buttons" gnome gnome-buttons nil + (let ((hbbox nil) + (button nil) + (i 0)) + (mapc (lambda (b) + (setq button (gnome-stock-button (car b))) + (gtk-signal-connect button 'clicked (lambda (obj data) + (message "Stock GNOME Button: %s" data)) + (cdr b)) + (if (= (% i 3) 0) + (progn + (setq hbbox (gtk-hbutton-box-new)) + (gtk-button-box-set-spacing hbbox 5) + (gtk-container-add window hbbox))) + + (gtk-container-add hbbox button) + (gtk-widget-show button) + (setq i (1+ i))) + gnome-stock-buttons))) + +(gtk-define-test + "GNOME About" gnome gnome-about t + (setq window (gnome-about-new "XEmacs/GTK Test Application" + "1.0a" + "Copyright (C) 2000 Free Software Foundation" + '("William M. Perry " + "Ichabod Crane") + "This is a comment string... what wonderful commentary you have my dear!" + ""))) + +(gtk-define-test + "GNOME File Entry" gnome gnome-file-entry nil + (let ((button (gnome-file-entry-new nil "Test browse dialog..."))) + (gtk-container-add window button))) + +(gtk-define-test + "GNOME Color Picker" gnome gnome-color-picker nil + (let ((picker (gnome-color-picker-new)) + (hbox (gtk-hbox-new nil 0)) + (label (gtk-label-new "Please choose a color: "))) + + (gtk-box-pack-start hbox label nil nil 2) + (gtk-box-pack-start hbox picker t t 2) + (gtk-container-add window hbox) + (gtk-widget-show-all hbox))) + +(gtk-define-test + "GNOME Desktop Entry Editor" gnome gnome-dentry-edit nil + (let* ((notebook (gtk-notebook-new))) + (gnome-dentry-edit-new-notebook notebook) + (gtk-container-add window notebook))) + +(gtk-define-test + "GNOME Date Edit" gnome gnome-date-entry nil + (let ((date (gnome-date-edit-new 0 t t)) + button) + (gtk-box-pack-start window date t t 0) + + (setq button (gtk-check-button-new-with-label "Show time")) + (gtk-signal-connect button 'clicked + (lambda (button date) + (let ((flags (gnome-date-edit-get-flags date))) + (if (gtk-toggle-button-get-active button) + (push 'show-time flags) + (setq flags (delq 'show-time flags))) + (gnome-date-edit-set-flags date flags))) date) + (gtk-toggle-button-set-active button t) + (gtk-box-pack-start window button nil nil 0) + + (setq button (gtk-check-button-new-with-label "24 Hour format")) + (gtk-signal-connect button 'clicked + (lambda (button date) + (let ((flags (gnome-date-edit-get-flags date))) + (if (gtk-toggle-button-get-active button) + (push '24-hr flags) + (setq flags (delq '24-hr flags))) + (gnome-date-edit-set-flags date flags))) date) + (gtk-toggle-button-set-active button t) + (gtk-box-pack-start window button nil nil 0) + + (setq button (gtk-check-button-new-with-label "Week starts on monday")) + (gtk-signal-connect button 'clicked + (lambda (button date) + (let ((flags (gnome-date-edit-get-flags date))) + (if (gtk-toggle-button-get-active button) + (push 'week-starts-on-monday flags) + (setq flags (delq 'week-starts-on-monday flags))) + (gnome-date-edit-set-flags date flags))) date) + (gtk-toggle-button-set-active button t) + (gtk-box-pack-start window button nil nil 0))) + +(gtk-define-test + "GNOME Font Picker" gnome gnome-font-picker nil + (let ((hbox (gtk-hbox-new nil 5)) + (fp (gnome-font-picker-new)) + (label (gtk-label-new "Choose a font: ")) + (button nil)) + (gtk-box-pack-start hbox label t t 0) + (gtk-box-pack-start hbox fp nil nil 2) + (gnome-font-picker-set-title fp "Select a font...") + (gnome-font-picker-set-mode fp 'font-info) + (gtk-box-pack-start window hbox t t 0) + + (setq button (gtk-check-button-new-with-label "Use font in label")) + (gtk-signal-connect button 'clicked + (lambda (button fp) + (gnome-font-picker-fi-set-use-font-in-label + fp (gtk-toggle-button-get-active button) 14)) + fp) + (gtk-box-pack-start window button nil nil 0) + + (setq button (gtk-check-button-new-with-label "Show size")) + (gtk-signal-connect button 'clicked + (lambda (button fp) + (gnome-font-picker-fi-set-show-size + fp (gtk-toggle-button-get-active button))) + fp) + (gtk-box-pack-start window button nil nil 0))) + +(gtk-define-test + "GNOME Application" gnome gnome-app t + (setq window (gnome-app-new "XEmacs" "XEmacs/GNOME")) + (let ((menubar (gtk-menu-bar-new)) + (contents nil) + ;(toolbar-instance (specifier-instance top-toolbar)) + (toolbar nil) + (item nil) + (flushright nil)) + (mapc (lambda (node) + (if (not node) + (setq flushright t) + (setq item (gtk-build-xemacs-menu node)) + (gtk-widget-show item) + (if flushright (gtk-menu-item-right-justify item)) + (gtk-menu-append menubar item))) + current-menubar) + + (setq toolbar (gtk-toolbar-new 'horizontal 'both)) + (mapc (lambda (x) + (let ((button (gtk-button-new)) + (pixmap (gnome-stock-pixmap-widget-new toolbar x))) + (gtk-container-add button pixmap) + (gtk-toolbar-append-widget toolbar button (symbol-name x) nil))) + '(open save print cut copy paste undo spellcheck srchrpl mail help)) + + (setq contents (gtk-hbox-new nil 5)) + (let ((hbox contents) + (vbox (gtk-vbox-new nil 5)) + (frame nil) + (label nil)) + (gtk-box-pack-start hbox vbox nil nil 0) + + (setq frame (gtk-frame-new "Normal Label") + label (gtk-label-new "This is a Normal label")) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + (setq frame (gtk-frame-new "Multi-line Label") + label (gtk-label-new "This is a multi-line label.\nSecond line\nThird line")) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + (setq frame (gtk-frame-new "Left Justified Label") + label (gtk-label-new "This is a Left-Justified\nMulti-line label.\nThird line")) + (gtk-label-set-justify label 'left) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + (setq frame (gtk-frame-new "Right Justified Label") + label (gtk-label-new "This is a Right-Justified\nMulti-line label.\nFourth line, (j/k)")) + (gtk-label-set-justify label 'right) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + ;; Start a second row so that we don't make a ridiculously tall window + (setq vbox (gtk-vbox-new nil 5)) + (gtk-box-pack-start hbox vbox nil nil 0) + + (setq frame (gtk-frame-new "Line wrapped label") + label (gtk-label-new + (concat "This is an example of a line-wrapped label. It should not be taking " + "up the entire " ;;; big space to test spacing + "width allocated to it, but automatically wraps the words to fit. " + "The time has come, for all good men, to come to the aid of their party. " + "The sixth sheik's six sheep's sick.\n" + " It supports multiple paragraphs correctly, and correctly adds " + "many extra spaces. "))) + (gtk-label-set-line-wrap label t) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + (setq frame (gtk-frame-new "Filled, wrapped label") + label (gtk-label-new + (concat + "This is an example of a line-wrapped, filled label. It should be taking " + "up the entire width allocated to it. Here is a seneance to prove " + "my point. Here is another sentence. " + "Here comes the sun, do de do de do.\n" + " This is a new paragraph.\n" + " This is another newer, longer, better paragraph. It is coming to an end, " + "unfortunately."))) + (gtk-label-set-justify label 'fill) + (gtk-label-set-line-wrap label t) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + (setq frame (gtk-frame-new "Underlined label") + label (gtk-label-new (concat "This label is underlined!\n" + "This one is underlined in ÆüËܸì¤ÎÆþÍÑquite a funky fashion"))) + (gtk-label-set-justify label 'left) + (gtk-label-set-pattern label "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____") + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0)) + + (gtk-widget-show-all toolbar) + (gtk-widget-show-all menubar) + (gtk-widget-show-all contents) + (gnome-app-set-menus window menubar) + (gnome-app-set-toolbar window toolbar) + (gnome-app-set-contents window contents))) diff --git a/tests/gtk/gtk-embedded-test.el b/tests/gtk/gtk-embedded-test.el new file mode 100644 index 0000000..3752dd6 --- /dev/null +++ b/tests/gtk/gtk-embedded-test.el @@ -0,0 +1,32 @@ +(gtk-define-test + "Embedded XEmacs frame" xemacs-frame t + (setq window (gtk-window-new 'toplevel)) + (let ((table (gtk-table-new 5 3 nil)) + (label nil) + (entry nil) + (frame (gtk-frame-new "Type mail message here..."))) + (gtk-container-add window table) + + (setq label (gtk-label-new "To: ") + entry (gtk-entry-new)) + (gtk-table-attach table label 0 1 0 1 nil nil 0 0) + (gtk-table-attach table entry 1 2 0 1 '(fill) '(fill) 0 0) + + (setq label (gtk-label-new "CC: ") + entry (gtk-entry-new)) + (gtk-table-attach table label 0 1 1 2 nil nil 0 0) + (gtk-table-attach table entry 1 2 1 2 '(fill) '(fill) 0 0) + + (setq label (gtk-label-new "Subject: ") + entry (gtk-entry-new)) + (gtk-table-attach table label 0 1 2 3 nil nil 0 0) + (gtk-table-attach table entry 1 2 2 3 '(fill) '(fill) 0 0) + + (gtk-table-attach table frame 0 2 3 4 '(expand fill) '(expand fill) 5 5) + + (gtk-widget-show-all window) + (gdk-flush) + (make-frame (list 'window-id frame + 'unsplittable t + 'menubar-visible-p nil + 'default-toolbar-visible-p nil)))) diff --git a/tests/gtk/gtk-extra-test.el b/tests/gtk/gtk-extra-test.el new file mode 100644 index 0000000..5e7b00e --- /dev/null +++ b/tests/gtk/gtk-extra-test.el @@ -0,0 +1,26 @@ +(require 'gtk-extra) + +(gtk-define-test + "Color Combo" extra color-combo nil + (let ((combo (gtk-color-combo-new))) + (gtk-box-pack-start window combo nil nil 0))) + +(gtk-define-test + "Directory Tree" extra dirtree nil + (let ((dir (gtk-dir-tree-new))) + (gtk-box-pack-start window dir nil nil 0) + (gtk-dir-tree-open-dir dir "/"))) + +(gtk-define-test + "File List" extra filelist nil + (let ((scrolled (gtk-scrolled-window-new nil nil)) + (list (gtk-file-list-new 32 2 "/"))) + (gtk-scrolled-window-add-with-viewport scrolled list) + (put scrolled 'height 200) + (gtk-box-pack-start window scrolled t t 0))) + +(gtk-define-test + "Font Combo" extra fontcombo nil + (let ((fc (gtk-font-combo-new))) + (gtk-box-pack-start window fc t t 0))) + diff --git a/tests/gtk/gtk-test.el b/tests/gtk/gtk-test.el new file mode 100644 index 0000000..8f2b021 --- /dev/null +++ b/tests/gtk/gtk-test.el @@ -0,0 +1,2044 @@ +;;; gtk-test.el --- Test harness for GTK widgets + +;; Copyright (C) 2000 Free Software Foundation + +;; Maintainer: William Perry +;; Keywords: tests + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +(require 'font) + +(setq GTK_TOPLEVEL (lsh 1 4) + GTK_NO_WINDOW (lsh 1 5) + GTK_REALIZED (lsh 1 6) + GTK_MAPPED (lsh 1 7) + GTK_VISIBLE (lsh 1 8) + GTK_SENSITIVE (lsh 1 9) + GTK_PARENT_SENSITIVE (lsh 1 10) + GTK_CAN_FOCUS (lsh 1 11) + GTK_HAS_FOCUS (lsh 1 12) + GTK_CAN_DEFAULT (lsh 1 13) + GTK_HAS_DEFAULT (lsh 1 14) + GTK_HAS_GRAB (lsh 1 15) + GTK_RC_STYLE (lsh 1 16) + GTK_COMPOSITE_CHILD (lsh 1 17) + GTK_NO_REPARENT (lsh 1 18) + GTK_APP_PAINTABLE (lsh 1 19) + GTK_RECEIVES_DEFAULT (lsh 1 20)) + +(defun gtk-widget-visible (widget) + (= (logand (gtk-object-flags widget) GTK_VISIBLE) GTK_VISIBLE)) + +(defvar gtk-defined-tests nil + "A list describing the defined tests. +Each element is of the form (DESCRIPTION TYPE FUNCTION)") + +(defvar gtk-test-directory nil) +(defun gtk-test-directory () + (if (not gtk-test-directory) + (mapc (lambda (c) + (if (and (not gtk-test-directory) + (string= (file-name-nondirectory (car c)) "gtk-test.el")) + (setq gtk-test-directory (file-name-directory (car c))))) + load-history)) + gtk-test-directory) + +(defvar gtk-test-categories '((container . "Containers") + (basic . "Basic Widgets") + (composite . "Composite Widgets") + (gimp . "Gimp Widgets") + (misc . "Miscellaneous") + (extra . "GTK+ Extra") + (gdk . "GDK Primitives") + (gnome . "GNOME tests")) + "An assoc list mapping test categories to friendly names.") + +(defvar gtk-test-open-glyph + (make-glyph [xpm :data "/* XPM */\nstatic char * book_open_xpm[] = {\n\"16 16 4 1\",\n\" c None s None\",\n\". c black\",\n\"X c #808080\",\n\"o c white\",\n\" \",\n\" .. \",\n\" .Xo. ... \",\n\" .Xoo. ..oo. \",\n\" .Xooo.Xooo... \",\n\" .Xooo.oooo.X. \",\n\" .Xooo.Xooo.X. \",\n\" .Xooo.oooo.X. \",\n\" .Xooo.Xooo.X. \",\n\" .Xooo.oooo.X. \",\n\" .Xoo.Xoo..X. \",\n\" .Xo.o..ooX. \",\n\" .X..XXXXX. \",\n\" ..X....... \",\n\" .. \",\n\" \"};"])) + +(defvar gtk-test-closed-glyph + (make-glyph [xpm :data "/* XPM */\nstatic char * book_closed_xpm[] = {\n\"16 16 6 1\",\n\" c None s None\",\n\". c black\",\n\"X c red\",\n\"o c yellow\",\n\"O c #808080\",\n\"# c white\",\n\" \",\n\" .. \",\n\" ..XX. \",\n\" ..XXXXX. \",\n\" ..XXXXXXXX. \",\n\".ooXXXXXXXXX. \",\n\"..ooXXXXXXXXX. \",\n\".X.ooXXXXXXXXX. \",\n\".XX.ooXXXXXX.. \",\n\" .XX.ooXXX..#O \",\n\" .XX.oo..##OO. \",\n\" .XX..##OO.. \",\n\" .X.#OO.. \",\n\" ..O.. \",\n\" .. \",\n\" \"};\n"])) + +(defvar gtk-test-mini-page-glyph + (make-glyph [xpm :data "/* XPM */\nstatic char * mini_page_xpm[] = {\n\"16 16 4 1\",\n\" c None s None\",\n\". c black\",\n\"X c white\",\n\"o c #808080\",\n\" \",\n\" ....... \",\n\" .XXXXX.. \",\n\" .XoooX.X. \",\n\" .XXXXX.... \",\n\" .XooooXoo.o \",\n\" .XXXXXXXX.o \",\n\" .XooooooX.o \",\n\" .XXXXXXXX.o \",\n\" .XooooooX.o \",\n\" .XXXXXXXX.o \",\n\" .XooooooX.o \",\n\" .XXXXXXXX.o \",\n\" ..........o \",\n\" oooooooooo \",\n\" \"};\n"])) + +(defvar gtk-test-mini-gtk-glyph + (make-glyph [xpm :data "/* XPM */\nstatic char * gtk_mini_xpm[] = {\n\"15 20 17 1\",\n\" c None\",\n\". c #14121F\",\n\"+ c #278828\",\n\"@ c #9B3334\",\n\"# c #284C72\",\n\"$ c #24692A\",\n\"% c #69282E\",\n\"& c #37C539\",\n\"* c #1D2F4D\",\n\"= c #6D7076\",\n\"- c #7D8482\",\n\"; c #E24A49\",\n\"> c #515357\",\n\", c #9B9C9B\",\n\"' c #2FA232\",\n\") c #3CE23D\",\n\"! c #3B6CCB\",\n\" \",\n\" ***> \",\n\" >.*!!!* \",\n\" ***....#*= \",\n\" *!*.!!!**!!# \",\n\" .!!#*!#*!!!!# \",\n\" @%#!.##.*!!$& \",\n\" @;%*!*.#!#')) \",\n\" @;;@%!!*$&)'' \",\n\" @%.%@%$'&)$+' \",\n\" @;...@$'*'*)+ \",\n\" @;%..@$+*.')$ \",\n\" @;%%;;$+..$)# \",\n\" @;%%;@$$$'.$# \",\n\" %;@@;;$$+))&* \",\n\" %;;;@+$&)&* \",\n\" %;;@'))+> \",\n\" %;@'&# \",\n\" >%$$ \",\n\" >= \"};"])) + + +(defun build-option-menu (items history obj) + (let (omenu menu menu-item group i) + (setq omenu (gtk-option-menu-new) + menu (gtk-menu-new) + i 0) + + (while items + (setq menu-item (gtk-radio-menu-item-new-with-label group (car (car items)))) + (gtk-signal-connect menu-item 'activate (cdr (car items)) obj) + (setq group (gtk-radio-menu-item-group menu-item)) + (gtk-menu-append menu menu-item) + (if (= i history) + (gtk-check-menu-item-set-active menu-item t)) + (gtk-widget-show menu-item) + (setq items (cdr items)) + (incf i)) + + (gtk-option-menu-set-menu omenu menu) + (gtk-option-menu-set-history omenu history) + omenu)) + +(defun gtk-test-notice-destroy (object symbol) + ;; Set variable to NIL to aid in object destruction. + (set symbol nil)) + +(defun gtk-test-make-sample-buttons (box maker) + ;; Create buttons and pack them in a premade BOX. + (mapcar (lambda (name) + (let ((button (funcall maker name))) + (gtk-box-pack-start box button t t 0) + (gtk-widget-show button) + button)) '("button1" "button2" "button3"))) + +(make-face 'gtk-test-face-large "A face with a large font, for use in GTK test cases") +(font-set-face-font 'gtk-test-face-large + (make-font :family '("LucidaBright" "Utopia" "Helvetica" "fixed") + :weight :normal + :size "36pt")) + +(defvar gtk-test-shell nil + "Where non-dialog tests should realize their widgets.") + +(defmacro gtk-define-test (title type name-stub dialog-p &rest body) + "Define a GTK demo/test. +TITLE is the friendly name of the test to show to the user. +TYPE is used to sort the items. +NAME-STUB is used to create the function definition. +DIALOG-P must be non-nil for demos that create their own top-level window. +BODY are the forms that actually create the demo. + +They must pack their widgets into the dynamically bound WINDOW variable, +which is a GtkVBox. +" + `(progn + (if (not (assoc ,title gtk-defined-tests)) + (push (list ,title (quote ,type) + (quote ,(intern (format "gtk-test-%s" name-stub)))) gtk-defined-tests)) + (defun ,(intern (format "gtk-test-%s" name-stub)) () + (let ((main-widget (if (not gtk-test-shell) + (gtk-window-new 'toplevel) + (gtk-frame-new ,title))) + (window nil)) + (if gtk-test-shell + (progn + (mapc 'gtk-widget-destroy (gtk-container-children gtk-test-shell)) + (gtk-box-pack-start gtk-test-shell main-widget nil nil 0)) + (gtk-window-set-title main-widget ,title)) + (if ,dialog-p + (let ((button (gtk-button-new-with-label ,title)) + (blank (gtk-event-box-new))) + (setq window (gtk-hbox-new nil 0)) + (gtk-signal-connect button 'clicked + (lambda (&rest ignored) + (let ((window nil)) + ,@body + (gtk-widget-show-all window)))) + (gtk-box-pack-start window + (gtk-label-new + (concat "This demo creates an external dialog.\n" + "Activate the button to see the demo.")) + nil nil 0) + (gtk-box-pack-start window button nil nil 0) + (gtk-box-pack-start window blank t t 0) + (gtk-widget-show-all main-widget)) + (setq window (gtk-vbox-new nil 0)) + ,@body) + (gtk-container-add main-widget window) + (gtk-widget-show-all (or main-widget window)))))) + + +;;;; Pixmaps +(gtk-define-test + "Pixmaps" misc pixmap nil + (let* ((button (gtk-button-new)) + (pixmap (gtk-pixmap-new xemacs-logo nil)) + (label (gtk-label-new "Pixmap test")) + (hbox (gtk-hbox-new nil 0))) + (gtk-box-pack-start window button nil nil 0) + (gtk-widget-show button) + (gtk-container-set-border-width hbox 2) + (gtk-container-add hbox pixmap) + (gtk-container-add hbox label) + (gtk-container-add button hbox) + (gtk-widget-show pixmap) + (gtk-widget-show label) + (gtk-widget-show hbox))) + + +;;;; Scrolled windows +(gtk-define-test + "Scrolled windows" container create-scrolled-windows nil + (let* ((scrolled-win (gtk-scrolled-window-new nil nil)) + (viewport (gtk-viewport-new + (gtk-scrolled-window-get-hadjustment scrolled-win) + (gtk-scrolled-window-get-vadjustment scrolled-win))) + (table (gtk-table-new 20 20 nil)) + (button nil)) + (gtk-container-set-border-width window 0) + (gtk-container-set-border-width scrolled-win 10) + (gtk-scrolled-window-set-policy scrolled-win 'automatic 'automatic) + (gtk-box-pack-start window scrolled-win t t 0) + (gtk-table-set-row-spacings table 10) + (gtk-table-set-col-spacings table 10) + (gtk-scrolled-window-add-with-viewport scrolled-win table) + (gtk-container-set-focus-hadjustment + table (gtk-scrolled-window-get-hadjustment scrolled-win)) + (gtk-container-set-focus-vadjustment + table (gtk-scrolled-window-get-vadjustment scrolled-win)) + (loop for i from 0 to 19 do + (loop for j from 0 to 19 do + (setq button (gtk-button-new-with-label (format "button (%d, %d)\n" i j))) + (gtk-table-attach-defaults table button i (1+ i) j (1+ j)))) + (gtk-widget-show-all scrolled-win))) + + +;;;; Lists +(gtk-define-test + "List" basic create-list nil + (let ((list-items '("hello" + "world" + "blah" + "foo" + "bar" + "argh" + "wmperry" + "is a" + "wussy" + "programmer")) + (scrolled-win (gtk-scrolled-window-new nil nil)) + (lyst (gtk-list-new)) + (add (gtk-button-new-with-label "add")) + (remove (gtk-button-new-with-label "remove"))) + + (gtk-scrolled-window-set-policy scrolled-win 'automatic 'automatic) + (gtk-box-pack-start window scrolled-win t t 0) + (gtk-widget-show scrolled-win) + + (gtk-list-set-selection-mode lyst 'multiple) + (gtk-list-set-selection-mode lyst 'browse) + (gtk-scrolled-window-add-with-viewport scrolled-win lyst) + (gtk-widget-show lyst) + + (mapc (lambda (i) + (let ((list-item (gtk-list-item-new-with-label i))) + (gtk-container-add lyst list-item) + (gtk-widget-show list-item))) + list-items) + + (gtk-signal-connect add 'clicked + (lambda (obj data) (message "Should add to the list"))) + (gtk-box-pack-start window add nil t 0) + (gtk-widget-show add) + + (gtk-signal-connect remove 'clicked + (lambda (obj list) + (if (gtk-list-selection list) + (gtk-list-remove-items list (gtk-list-selection list)))) lyst) + (gtk-box-pack-start window remove nil t 0) + (gtk-widget-show remove) + + (gtk-signal-connect lyst 'select_child + (lambda (lyst child ignored) + (message "selected %S %d" child (gtk-list-child-position lyst child)))) + + (gtk-widget-set-usize scrolled-win 200 75) + + (gtk-signal-connect lyst 'unselect_child (lambda (lyst child ignored) + (message "unselected %S" child))))) + + +;;;; Tooltips +(defvar gtk-test-tooltips nil) + +(gtk-define-test + "Tooltips" composite create-tooltips nil + (if (not gtk-test-tooltips) + (setq gtk-test-tooltips (gtk-tooltips-new))) + (let ((buttons (gtk-test-make-sample-buttons window 'gtk-toggle-button-new-with-label)) + (tips '("This is button 1" + "This is button 2" + "This is button 3. This is also a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly."))) + (while buttons + (gtk-tooltips-set-tip gtk-test-tooltips (pop buttons) (pop tips) "")))) + + +;;;; Panes +(defun toggle-resize (widget child) + (let* ((paned (gtk-widget-parent child)) + (is-child1 (eq child (gtk-paned-child1 paned))) + resize shrink) + (setq resize (if is-child1 + (gtk-paned-child1-resize paned) + (gtk-paned-child2-resize paned)) + shrink (if is-child1 + (gtk-paned-child1-shrink paned) + (gtk-paned-child2-shrink paned))) + + (gtk-widget-ref child) + (gtk-container-remove paned child) + (if is-child1 + (gtk-paned-pack1 paned child (not resize) shrink) + (gtk-paned-pack2 paned child (not resize) shrink)) + (gtk-widget-unref child))) + +(defun toggle-shrink (widget child) + (let* ((paned (gtk-widget-parent child)) + (is-child1 (eq child (gtk-paned-child1 paned))) + resize shrink) + (setq resize (if is-child1 + (gtk-paned-child1-resize paned) + (gtk-paned-child2-resize paned)) + shrink (if is-child1 + (gtk-paned-child1-shrink paned) + (gtk-paned-child2-shrink paned))) + + (gtk-widget-ref child) + (gtk-container-remove paned child) + (if is-child1 + (gtk-paned-pack1 paned child resize (not shrink)) + (gtk-paned-pack2 paned child resize (not shrink))) + (gtk-widget-unref child))) + +(defun create-pane-options (widget frame-label label1 label2) + (let (frame table label check-button) + (setq frame (gtk-frame-new frame-label)) + (gtk-container-set-border-width frame 4) + + (setq table (gtk-table-new 3 2 4)) + (gtk-container-add frame table) + + (setq label (gtk-label-new label1)) + (gtk-table-attach-defaults table label 0 1 0 1) + + (setq check-button (gtk-check-button-new-with-label "Resize")) + (gtk-table-attach-defaults table check-button 0 1 1 2) + (gtk-signal-connect check-button 'toggled 'toggle-resize (gtk-paned-child1 widget)) + + (setq check-button (gtk-check-button-new-with-label "Shrink")) + (gtk-table-attach-defaults table check-button 0 1 2 3) + (gtk-toggle-button-set-active check-button t) + (gtk-signal-connect check-button 'toggled 'toggle-shrink (gtk-paned-child1 widget)) + + (setq label (gtk-label-new label2)) + (gtk-table-attach-defaults table label 1 2 0 1) + + (setq check-button (gtk-check-button-new-with-label "Resize")) + (gtk-table-attach-defaults table check-button 1 2 1 2) + (gtk-toggle-button-set-active check-button t) + (gtk-signal-connect check-button 'toggled 'toggle-resize (gtk-paned-child2 widget)) + + (setq check-button (gtk-check-button-new-with-label "Shrink")) + (gtk-table-attach-defaults table check-button 1 2 2 3) + (gtk-toggle-button-set-active check-button t) + (gtk-signal-connect check-button 'toggled 'toggle-shrink (gtk-paned-child2 widget)) + frame)) + +(gtk-define-test + "Panes" container panes nil + (let (frame hpaned vpaned button vbox) + (gtk-container-set-border-width window 0) + + (setq vpaned (gtk-vpaned-new)) + (gtk-box-pack-start window vpaned t t 0) + (gtk-container-set-border-width vpaned 5) + + (setq hpaned (gtk-hpaned-new)) + (gtk-paned-add1 vpaned hpaned) + + (setq frame (gtk-frame-new nil)) + (gtk-frame-set-shadow-type frame 'in) + (gtk-widget-set-usize frame 60 60) + (gtk-paned-add1 hpaned frame) + + (setq button (gtk-button-new-with-label "Hi there")) + (gtk-container-add frame button) + + (setq frame (gtk-frame-new nil)) + (gtk-frame-set-shadow-type frame 'in) + (gtk-widget-set-usize frame 80 60) + (gtk-paned-add2 hpaned frame) + + (setq frame (gtk-frame-new nil)) + (gtk-frame-set-shadow-type frame 'in) + (gtk-widget-set-usize frame 60 80) + (gtk-paned-add2 vpaned frame) + + ;; Now create toggle buttons to control sizing + (gtk-box-pack-start window (create-pane-options hpaned "Horizontal" "Left" "Right") nil nil 0) + (gtk-box-pack-start window (create-pane-options vpaned "Vertical" "Top" "Bottom") nil nil 0) + (gtk-widget-show-all window))) + + +;;;; Entry +(gtk-define-test + "Entry" basic entry nil + (let ((box1 nil) + (box2 nil) + (editable-check nil) + (sensitive-check nil) + (entry nil) + (cb nil) + (button nil) + (separator nil) + (cbitems '("item0" + "item1 item1" + "item2 item2 item2" + "item3 item3 item3 item3" + "item4 item4 item4 item4 item4" + "item5 item5 item5 item5 item5 item5" + "item6 item6 item6 item6 item6" + "item7 item7 item7 item7" + "item8 item8 item8" + "item9 item9"))) + (gtk-container-set-border-width window 0) + + (setq box1 (gtk-vbox-new nil 0)) + (gtk-container-add window box1) + (gtk-widget-show box1) + + (setq box2 (gtk-vbox-new nil 10)) + (gtk-container-set-border-width box2 10) + (gtk-box-pack-start box1 box2 t t 0) + (gtk-widget-show box2) + + (setq entry (gtk-entry-new)) + (gtk-entry-set-text entry "hello world") + (gtk-editable-select-region entry 0 5) + (gtk-box-pack-start box2 entry t t 0) + (gtk-widget-show entry) + + (setq cb (gtk-combo-new)) + (gtk-combo-set-popdown-strings cb cbitems) + (gtk-entry-set-text (gtk-combo-entry cb) "hellow world") + (gtk-editable-select-region (gtk-combo-entry cb) 0 -1) + (gtk-box-pack-start box2 cb t t 0) + (gtk-widget-show cb) + + (setq editable-check (gtk-check-button-new-with-label "Editable")) + (gtk-box-pack-start box2 editable-check nil t 0) + (gtk-signal-connect editable-check 'toggled + (lambda (obj data) + (gtk-entry-set-editable + data + (gtk-toggle-button-get-active obj))) entry) + (gtk-toggle-button-set-active editable-check t) + (gtk-widget-show editable-check) + + (setq editable-check (gtk-check-button-new-with-label "Visible")) + (gtk-box-pack-start box2 editable-check nil t 0) + (gtk-signal-connect editable-check 'toggled + (lambda (obj data) + (gtk-entry-set-visibility data + (gtk-toggle-button-get-active obj))) entry) + (gtk-toggle-button-set-active editable-check t) + (gtk-widget-show editable-check) + + (setq sensitive-check (gtk-check-button-new-with-label "Sensitive")) + (gtk-box-pack-start box2 sensitive-check nil t 0) + (gtk-signal-connect sensitive-check 'toggled + (lambda (obj data) + (gtk-widget-set-sensitive data + (gtk-toggle-button-get-active obj))) entry) + (gtk-toggle-button-set-active sensitive-check t) + (gtk-widget-show sensitive-check))) + + +;;;; Various built-in dialog types +(gtk-define-test + "Font Dialog" composite font-selection t + (setq window (gtk-font-selection-dialog-new "font selection dialog")) + (gtk-font-selection-dialog-set-preview-text window "Set from Emacs Lisp!") + (gtk-signal-connect + (gtk-font-selection-dialog-cancel-button window) + 'clicked (lambda (button dlg) + (gtk-widget-destroy dlg)) + window) + (gtk-signal-connect + (gtk-font-selection-dialog-ok-button window) + 'clicked + (lambda (button dlg) + (message "Font selected: %s" (gtk-font-selection-dialog-get-font-name dlg))) + window)) + +(gtk-define-test + "File Selection Dialog" composite file-selection t + (let (button) + (setq window (gtk-file-selection-new "file selection")) + (gtk-signal-connect + (gtk-file-selection-ok-button window) + 'clicked (lambda (obj dlg) (message "You clicked ok: %s" + (gtk-file-selection-get-filename dlg))) + window) + + (gtk-signal-connect + (gtk-file-selection-cancel-button window) + 'clicked (lambda (obj dlg) (gtk-widget-destroy dlg)) window) + + (gtk-file-selection-hide-fileop-buttons window) + + (setq button (gtk-button-new-with-label "Hide Fileops")) + (gtk-signal-connect + button 'clicked + (lambda (obj dlg) + (gtk-file-selection-hide-fileop-buttons dlg)) window) + + (gtk-box-pack-start (gtk-file-selection-action-area window) + button nil nil 0) + (gtk-widget-show button) + + (setq button (gtk-button-new-with-label "Show Fileops")) + (gtk-signal-connect + button 'clicked + (lambda (obj dlg) + (gtk-file-selection-show-fileop-buttons dlg)) window) + (gtk-box-pack-start (gtk-file-selection-action-area window) + button nil nil 0) + (gtk-widget-show button))) + +(gtk-define-test + "Color selection" composite color t + (setq window (gtk-color-selection-dialog-new "GTK color selection")) + (gtk-signal-connect (gtk-color-selection-dialog-cancel-button window) + 'clicked + (lambda (button data) + (gtk-widget-destroy data)) window) + (gtk-signal-connect (gtk-color-selection-dialog-ok-button window) + 'clicked + (lambda (button data) + (let ((rgba (gtk-color-selection-get-color + (gtk-color-selection-dialog-colorsel data))) + r g b a) + (setq r (pop rgba) + g (pop rgba) + b (pop rgba) + a (pop rgba)) + (gtk-widget-destroy data) + (message-box + "You selected color: red (%04x) blue (%04x) green (%04x) alpha (%g)" + (* 65535 r) (* 65535 g) (* 65535 b) a))) + window)) + + +;;;; Dialog +(defun gtk-container-specific-children (parent predicate &optional data) + (let ((children nil)) + (mapc (lambda (w) + (if (funcall predicate w data) + (push w children))) + (gtk-container-children parent)) + children)) + +(gtk-define-test + "Dialog" basic dialog t + (let ((button nil) + (label nil)) + (setq window (gtk-dialog-new)) + (gtk-container-set-border-width window 0) + (gtk-widget-set-usize window 200 110) + + (setq button (gtk-button-new-with-label "OK")) + (gtk-box-pack-start (gtk-dialog-action-area window) button t t 0) + (gtk-widget-show button) + (gtk-signal-connect button 'clicked + (lambda (obj data) + (gtk-widget-destroy data)) + window) + + (setq button (gtk-button-new-with-label "Toggle")) + (gtk-signal-connect + button 'clicked + (lambda (button dlg) + (if (not (gtk-container-specific-children (gtk-dialog-vbox dlg) + (lambda (w ignored) + (= (gtk-object-type w) (gtk-label-get-type))))) + (let ((label (gtk-label-new "Dialog Test"))) + (gtk-box-pack-start (gtk-dialog-vbox dlg) label t t 0) + (gtk-widget-show label)) + (mapc 'gtk-widget-destroy + (gtk-container-specific-children (gtk-dialog-vbox dlg) + (lambda (w ignored) + (= (gtk-object-type w) (gtk-label-get-type))))))) + window) + (gtk-box-pack-start (gtk-dialog-action-area window) button t t 0) + (gtk-widget-show button))) + + +;;;; Range controls +(gtk-define-test + "Range Controls" basic range-controls nil + (let* ((adjustment (gtk-adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)) + (scale (gtk-hscale-new adjustment)) + (scrollbar (gtk-hscrollbar-new adjustment))) + (gtk-widget-set-usize scale 150 30) + (gtk-range-set-update-policy scale 'delayed) + (gtk-scale-set-digits scale 2) + (gtk-scale-set-draw-value scale t) + (gtk-box-pack-start window scale t t 0) + (gtk-widget-show scale) + + (gtk-range-set-update-policy scrollbar 'continuous) + (gtk-box-pack-start window scrollbar t t 0) + (gtk-widget-show scrollbar))) + + +;;;; Ruler +'(gtk-define-test + "Rulers" gimp rulers nil + (let* ((table (gtk-table-new 2 2 nil)) + (hruler nil) + (vruler nil) + (ebox (gtk-event-box-new))) + + (gtk-widget-set-usize ebox 300 300) + (gtk-widget-set-events ebox '(pointer-motion-mask pointer-motion-hint-mask)) + (gtk-container-set-border-width ebox 0) + + (gtk-container-add window ebox) + (gtk-container-add ebox table) + (gtk-widget-show table) + + (setq hruler (gtk-hruler-new)) + (gtk-ruler-set-metric hruler 'centimeters) + (gtk-ruler-set-range hruler 100 0 0 20) + (gtk-table-attach table hruler 1 2 0 1 '(expand fill) 'fill 0 0) + (gtk-widget-show hruler) + + (setq vruler (gtk-vruler-new)) + (gtk-ruler-set-range vruler 5 15 0 20) + (gtk-table-attach table vruler 0 1 1 2 'fill '(expand fill) 0 0) + (gtk-widget-show vruler) + + (gtk-signal-connect + ebox 'motion_notify_event + (lambda (object ev data) + (gtk-widget-event (car data) ev) + (gtk-widget-event (cdr data) ev)) + (cons hruler vruler)))) + + +;;;; Toggle button types +(gtk-define-test + "Toggle Buttons" basic toggle-buttons nil + (gtk-container-set-border-width window 0) + (gtk-test-make-sample-buttons window 'gtk-toggle-button-new-with-label)) + +(gtk-define-test + "Check Buttons" basic check-buttons nil + (gtk-container-set-border-width window 0) + (gtk-test-make-sample-buttons window 'gtk-check-button-new-with-label)) + +(gtk-define-test + "Radio Buttons" basic radio-buttons nil + (gtk-container-set-border-width window 0) + (let ((group nil)) + (gtk-test-make-sample-buttons window + (lambda (label) + (let ((button (gtk-radio-button-new-with-label group label))) + (setq group (gtk-radio-button-group button)) + button))))) + + +;;;; Button weirdness +(gtk-define-test + "Buttons" basic buttons nil + (let ((box1 nil) + (box2 nil) + (table nil) + (buttons nil) + (separator nil) + (connect-buttons (lambda (button1 button2) + (gtk-signal-connect button1 'clicked + (lambda (obj data) + (if (gtk-widget-visible data) + (gtk-widget-hide data) + (gtk-widget-show data))) button2)))) + + (gtk-container-set-border-width window 0) + + (setq box1 (gtk-vbox-new nil 0)) + (gtk-container-add window box1) + + (setq table (gtk-table-new 3 3 nil)) + (gtk-table-set-row-spacings table 5) + (gtk-table-set-col-spacings table 5) + (gtk-container-set-border-width table 10) + (gtk-box-pack-start box1 table t t 0) + + (push (gtk-button-new-with-label "button9") buttons) + (push (gtk-button-new-with-label "button8") buttons) + (push (gtk-button-new-with-label "button7") buttons) + (push (gtk-button-new-with-label "button6") buttons) + (push (gtk-button-new-with-label "button5") buttons) + (push (gtk-button-new-with-label "button4") buttons) + (push (gtk-button-new-with-label "button3") buttons) + (push (gtk-button-new-with-label "button2") buttons) + (push (gtk-button-new-with-label "button1") buttons) + + (funcall connect-buttons (nth 0 buttons) (nth 1 buttons)) + (funcall connect-buttons (nth 1 buttons) (nth 2 buttons)) + (funcall connect-buttons (nth 2 buttons) (nth 3 buttons)) + (funcall connect-buttons (nth 3 buttons) (nth 4 buttons)) + (funcall connect-buttons (nth 4 buttons) (nth 5 buttons)) + (funcall connect-buttons (nth 5 buttons) (nth 6 buttons)) + (funcall connect-buttons (nth 6 buttons) (nth 7 buttons)) + (funcall connect-buttons (nth 7 buttons) (nth 8 buttons)) + (funcall connect-buttons (nth 8 buttons) (nth 0 buttons)) + + (gtk-table-attach table (nth 0 buttons) 0 1 0 1 '(expand fill) '(expand fill) 0 0) + (gtk-table-attach table (nth 1 buttons) 1 2 1 2 '(expand fill) '(expand fill) 0 0) + (gtk-table-attach table (nth 2 buttons) 2 3 2 3 '(expand fill) '(expand fill) 0 0) + (gtk-table-attach table (nth 3 buttons) 0 1 2 3 '(expand fill) '(expand fill) 0 0) + (gtk-table-attach table (nth 4 buttons) 2 3 0 1 '(expand fill) '(expand fill) 0 0) + (gtk-table-attach table (nth 5 buttons) 1 2 2 3 '(expand fill) '(expand fill) 0 0) + (gtk-table-attach table (nth 6 buttons) 1 2 0 1 '(expand fill) '(expand fill) 0 0) + (gtk-table-attach table (nth 7 buttons) 2 3 1 2 '(expand fill) '(expand fill) 0 0) + (gtk-table-attach table (nth 8 buttons) 0 1 1 2 '(expand fill) '(expand fill) 0 0) + )) + + +;;;; Testing labels and underlining +(gtk-define-test + "Labels" basic labels nil + (let ((hbox (gtk-hbox-new nil 5)) + (vbox (gtk-vbox-new nil 5)) + (frame nil) + (label nil)) + (gtk-container-add window hbox) + (gtk-box-pack-start hbox vbox nil nil 0) + (gtk-container-set-border-width window 5) + + (setq frame (gtk-frame-new "Normal Label") + label (gtk-label-new "This is a Normal label")) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + (setq frame (gtk-frame-new "Multi-line Label") + label (gtk-label-new "This is a multi-line label.\nSecond line\nThird line")) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + (setq frame (gtk-frame-new "Left Justified Label") + label (gtk-label-new "This is a Left-Justified\nMulti-line label.\nThird line")) + (gtk-label-set-justify label 'left) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + (setq frame (gtk-frame-new "Right Justified Label") + label (gtk-label-new "This is a Right-Justified\nMulti-line label.\nFourth line, (j/k)")) + (gtk-label-set-justify label 'right) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + ;; Start a second row so that we don't make a ridiculously tall window + (setq vbox (gtk-vbox-new nil 5)) + (gtk-box-pack-start hbox vbox nil nil 0) + + (setq frame (gtk-frame-new "Line wrapped label") + label (gtk-label-new + (concat "This is an example of a line-wrapped label. It should not be taking " + "up the entire " ;;; big space to test spacing + "width allocated to it, but automatically wraps the words to fit. " + "The time has come, for all good men, to come to the aid of their party. " + "The sixth sheik's six sheep's sick.\n" + " It supports multiple paragraphs correctly, and correctly adds " + "many extra spaces. "))) + (gtk-label-set-line-wrap label t) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + (setq frame (gtk-frame-new "Filled, wrapped label") + label (gtk-label-new + (concat + "This is an example of a line-wrapped, filled label. It should be taking " + "up the entire width allocated to it. Here is a seneance to prove " + "my point. Here is another sentence. " + "Here comes the sun, do de do de do.\n" + " This is a new paragraph.\n" + " This is another newer, longer, better paragraph. It is coming to an end, " + "unfortunately."))) + (gtk-label-set-justify label 'fill) + (gtk-label-set-line-wrap label t) + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0) + + (setq frame (gtk-frame-new "Underlined label") + label (gtk-label-new (concat "This label is underlined!\n" + "This one is underlined in ÆüËܸì¤ÎÆþÍÑquite a funky fashion"))) + (gtk-label-set-justify label 'left) + (gtk-label-set-pattern label "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____") + (gtk-container-add frame label) + (gtk-box-pack-start vbox frame nil nil 0))) + + +;;;; Progress gauges +(gtk-define-test + "Progress bars" basic progress nil + (let* ((timer nil) + (adj (gtk-adjustment-new 1 0 100 1 1 1)) + (label (gtk-label-new "progress...")) + (pbar (gtk-progress-bar-new-with-adjustment adj)) + (button nil) + (timer (make-itimer))) + + ;; The original test used GTK timers, but XEmacs already has + ;; perfectly good timer support, that ends up mapping onto GTK + ;; timers anyway, so we'll use those instead. + (set-itimer-function + timer + (lambda (bar adj) + (let ((val (gtk-adjustment-value adj))) + (setq val (+ 1 (if (>= val 100) 0 val))) + (gtk-adjustment-set-value adj val) + (gtk-widget-queue-draw bar)))) + + (set-itimer-function-arguments timer (list pbar adj)) + (set-itimer-uses-arguments timer t) + (set-itimer-restart timer 0.1) + (set-itimer-value timer 0.1) + (set-itimer-is-idle timer nil) + + (gtk-progress-set-format-string pbar "%v%%") + (gtk-signal-connect pbar 'destroy (lambda (obj timer) + (delete-itimer timer)) timer) + + (gtk-misc-set-alignment label 0 0.5) + (gtk-box-pack-start window label nil t 0) + (gtk-widget-show label) + (gtk-widget-set-usize pbar 200 20) + (gtk-box-pack-start window pbar t t 0) + + (setq button (gtk-check-button-new-with-label "Show text")) + (gtk-box-pack-start window button nil nil 0) + (gtk-signal-connect button 'clicked + (lambda (button bar) + (gtk-progress-set-show-text + bar + (gtk-toggle-button-get-active button))) pbar) + (gtk-widget-show button) + + (setq button (gtk-check-button-new-with-label "Discrete blocks")) + (gtk-box-pack-start window button nil nil 0) + (gtk-signal-connect button 'clicked + (lambda (button bar) + (gtk-progress-bar-set-bar-style + bar + (if (gtk-toggle-button-get-active button) + 'discrete + 'continuous))) pbar) + (gtk-widget-show button) + + (gtk-widget-show pbar) + + (activate-itimer timer))) + +(gtk-define-test + "Gamma Curve" gimp gamma-curve nil + (let ((curve (gtk-gamma-curve-new))) + (gtk-container-add window curve) + (gtk-widget-show-all curve) + (gtk-curve-set-range (gtk-gamma-curve-curve curve) 0 255 0 255) + (gtk-curve-set-gamma (gtk-gamma-curve-curve curve) 2))) + + +;;;; Testing various button boxes and layout strategies. +(gtk-define-test + "Button Box" container button-box nil + (let ((main-vbox (gtk-vbox-new nil 0)) + (vbox (gtk-vbox-new nil 0)) + (hbox (gtk-hbox-new nil 0)) + (frame-horz (gtk-frame-new "Horizontal Button Boxes")) + (frame-vert (gtk-frame-new "Vertical Button Boxes")) + (create-bbox (lambda (horizontal title spacing child-w child-h layout) + (let ((frame (gtk-frame-new title)) + (bbox (if horizontal + (gtk-hbutton-box-new) + (gtk-vbutton-box-new)))) + (gtk-container-set-border-width bbox 5) + (gtk-container-add frame bbox) + (gtk-button-box-set-layout bbox layout) + (gtk-button-box-set-spacing bbox spacing) + (gtk-button-box-set-child-size bbox child-w child-h) + (gtk-container-add bbox (gtk-button-new-with-label "OK")) + (gtk-container-add bbox (gtk-button-new-with-label "Cancel")) + (gtk-container-add bbox (gtk-button-new-with-label "Help")) + frame)))) + + (gtk-container-set-border-width window 10) + (gtk-container-add window main-vbox) + + (gtk-box-pack-start main-vbox frame-horz t t 10) + (gtk-container-set-border-width vbox 10) + (gtk-container-add frame-horz vbox) + + (gtk-box-pack-start main-vbox frame-vert t t 10) + (gtk-container-set-border-width hbox 10) + (gtk-container-add frame-vert hbox) + + (gtk-box-pack-start vbox (funcall create-bbox t "Spread" 40 85 20 'spread) t t 0) + (gtk-box-pack-start vbox (funcall create-bbox t "Edge" 40 85 20 'edge) t t 0) + (gtk-box-pack-start vbox (funcall create-bbox t "Start" 40 85 20 'start) t t 0) + (gtk-box-pack-start vbox (funcall create-bbox t "End" 40 85 20 'end) t t 0) + + (gtk-box-pack-start hbox (funcall create-bbox nil "Spread" 40 85 20 'spread) t t 0) + (gtk-box-pack-start hbox (funcall create-bbox nil "Edge" 40 85 20 'edge) t t 0) + (gtk-box-pack-start hbox (funcall create-bbox nil "Start" 40 85 20 'start) t t 0) + (gtk-box-pack-start hbox (funcall create-bbox nil "End" 40 85 20 'end) t t 0))) + + +;;;; Cursors +'(gtk-define-test + "Cursors" cursors nil + (let ((cursors '(x-cursor arrow based-arrow-down based-arrow-up boat bogosity + bottom-left-corner bottom-right-corner bottom-side bottom-tee + box-spiral center-ptr circle clock coffee-mug cross cross-reverse + crosshair diamond-cross dot dotbox double-arrow draft-large + draft-small draped-box exchange fleur gobbler gumby hand1 hand2 heart + icon iron-cross left-ptr left-side left-tee leftbutton ll-angle + lr-angle man middlebutton mouse pencil pirate plus question-arrow + right-ptr right-side right-tee rightbutton rtl-logo sailboat + sb-down-arrow sb-h-double-arrow sb-left-arrow sb-right-arrow + sb-up-arrow sb-v-double-arrow shuttle sizing spider spraycan star + target tcross top-left-arrow top-left-corner top-right-corner top-side + top-tee trek ul-angle umbrella ur-angle watch xterm last-cursor)) + (cursor-area nil) + (adjustment nil) + (spinner nil)) + (setq cursor-area (gtk-event-box-new) + adjustment (gtk-adjustment-new 0 0 (length cursors) 1 1 1) + spinner (gtk-spin-button-new adjustment 1 3)) + (gtk-widget-set-usize cursor-area 200 100) + (gtk-box-pack-start window cursor-area t t 0) + (gtk-box-pack-start window spinner nil nil 0))) + + +;;;; Toolbar +(defun gtk-test-toolbar-create () + (let ((toolbar (gtk-toolbar-new 'horizontal 'both))) + (gtk-toolbar-set-button-relief toolbar 'none) + + (gtk-toolbar-append-item toolbar + "Horizonal" "Horizontal toolbar layout" "Toolbar/Horizontal" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-orientation tbar 'horizontal)) toolbar) + (gtk-toolbar-append-item toolbar + "Vertical" "Vertical toolbar layout" "Toolbar/Vertical" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-orientation tbar 'vertical)) toolbar) + + (gtk-toolbar-append-space toolbar) + (gtk-toolbar-append-item toolbar + "Icons" "Only show toolbar icons" "Toolbar/IconsOnly" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-style tbar 'icons)) toolbar) + (gtk-toolbar-append-item toolbar + "Text" "Only show toolbar text" "Toolbar/TextOnly" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-style tbar 'text)) toolbar) + (gtk-toolbar-append-item toolbar + "Both" "Show toolbar icons and text" "Toolbar/Both" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-style tbar 'both)) toolbar) + + (gtk-toolbar-append-space toolbar) + (gtk-toolbar-append-item toolbar + "Small" "Use small spaces" "" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-space-size tbar 5)) toolbar) + (gtk-toolbar-append-item toolbar + "Big" "Use big spaces" "" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-space-size tbar 10)) toolbar) + + (gtk-toolbar-append-space toolbar) + (gtk-toolbar-append-item toolbar + "Enable" "Enable tooltips" "" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-tooltips tbar t)) toolbar) + (gtk-toolbar-append-item toolbar + "Disable" "Disable tooltips" "" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-tooltips tbar nil)) toolbar) + + (gtk-toolbar-append-space toolbar) + (gtk-toolbar-append-item toolbar + "Borders" "Show borders" "" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-button-relief tbar 'normal)) toolbar) + (gtk-toolbar-append-item toolbar + "Borderless" "Hide borders" "" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-button-relief tbar 'none)) toolbar) + + (gtk-toolbar-append-space toolbar) + (gtk-toolbar-append-item toolbar + "Empty" "Empty spaces" "" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-space-style tbar 'empty)) toolbar) + (gtk-toolbar-append-item toolbar + "Lines" "Lines in spaces" "" + (gtk-pixmap-new gtk-test-open-glyph nil) + (lambda (tbar) + (gtk-toolbar-set-space-style tbar 'line)) toolbar) + (gtk-widget-show-all toolbar) + toolbar)) + +(gtk-define-test + "Toolbar" container toolbar nil + (gtk-box-pack-start window (gtk-test-toolbar-create) t t 0)) + + +;;;; Text +(gtk-define-test + "Text" composite text nil + (let ((text (gtk-text-new nil nil)) + (scrolled (gtk-scrolled-window-new nil nil)) + (bbox (gtk-hbutton-box-new)) + (button nil)) + (gtk-box-pack-start window scrolled t t 0) + (gtk-box-pack-start window bbox nil nil 0) + (gtk-widget-set-usize text 500 500) + (gtk-container-add scrolled text) + + (setq button (gtk-check-button-new-with-label "Editable")) + (gtk-signal-connect button 'toggled + (lambda (button text) + (gtk-text-set-editable text (gtk-toggle-button-get-active button))) text) + (gtk-container-add bbox button) + + (setq button (gtk-check-button-new-with-label "Wrap words")) + (gtk-signal-connect button 'toggled + (lambda (button text) + (gtk-text-set-word-wrap text (gtk-toggle-button-get-active button))) text) + (gtk-container-add bbox button) + + ;; put some default text in there. + (gtk-widget-set-style text 'default) + (let ((faces '(blue bold bold-italic gtk-test-face-large red text-cursor)) + (string nil)) + (mapc (lambda (face) + (setq string (format "Sample text in the `%s' face\n" face)) + (gtk-text-insert text + (face-font face) + (face-foreground face) + (face-background face) + string (length string))) faces)) + + + ;; Tell the user their rights... + (let ((file (locate-data-file "COPYING"))) + (gtk-text-freeze text) + (save-excursion + (set-buffer (get-buffer-create " *foo*")) + (insert-file-contents file) + (gtk-text-insert text nil nil nil (buffer-string) (point-max)) + (kill-buffer (current-buffer)))) + (gtk-text-thaw text))) + + +;;;; handle box +(gtk-define-test + "Handle box" container handles nil + (let ((handle nil) + (hbox (gtk-hbox-new nil 0))) + + (gtk-box-pack-start window (gtk-label-new "Above") nil nil 0) + (gtk-box-pack-start window (gtk-hseparator-new) nil nil 0) + (gtk-box-pack-start window hbox t t 0) + (gtk-box-pack-start window (gtk-hseparator-new) nil nil 0) + (gtk-box-pack-start window (gtk-label-new "Below") nil nil 0) + + (setq handle (gtk-handle-box-new)) + (gtk-container-add handle (gtk-test-toolbar-create)) + (gtk-widget-show-all handle) + (gtk-box-pack-start hbox handle nil nil 0) + (gtk-signal-connect handle 'child_attached + (lambda (box child data) + (message "Child widget (%s) attached" child))) + (gtk-signal-connect handle 'child_detached + (lambda (box child data) + (message "Child widget (%s) detached" child))) + + (setq handle (gtk-handle-box-new)) + (gtk-container-add handle (gtk-label-new "Fooo!!!")) + (gtk-box-pack-start hbox handle nil nil 0) + (gtk-signal-connect handle 'child_attached + (lambda (box child data) + (message "Child widget (%s) attached" child))) + (gtk-signal-connect handle 'child_detached + (lambda (box child data) + (message "Child widget (%s) detached" child))))) + + +;;;; Menus +(gtk-define-test + "Menus" basic menus nil + (let ((menubar (gtk-menu-bar-new)) + (item nil) + (right-justify nil)) + (gtk-box-pack-start window menubar nil nil 0) + (mapc (lambda (menudesc) + (if (not menudesc) + (setq right-justify t) + (setq item (gtk-build-xemacs-menu menudesc)) + (gtk-widget-show item) + (if right-justify + (gtk-menu-item-right-justify item)) + (gtk-menu-bar-append menubar item))) + default-menubar))) + + +;;;; Spinbutton +(gtk-define-test + "Spinbutton" composite spinbutton nil + (let (frame vbox vbox2 hbox label spin adj spin2 button) + + (gtk-container-set-border-width window 5) + + (setq frame (gtk-frame-new "Not accelerated") + hbox (gtk-hbox-new nil 0)) + + (gtk-box-pack-start window frame t t 0) + (gtk-container-add frame hbox) + + (setq vbox (gtk-vbox-new nil 0) + label (gtk-label-new "Day:") + adj (gtk-adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) + spin (gtk-spin-button-new adj 0 0)) + + (gtk-misc-set-alignment label 0 0.5) + (gtk-spin-button-set-wrap spin t) + (gtk-spin-button-set-shadow-type spin 'out) + (gtk-box-pack-start hbox vbox t t 5) + (gtk-box-pack-start vbox label nil t 0) + (gtk-box-pack-start vbox spin nil t 0) + + (setq vbox (gtk-vbox-new nil 0) + label (gtk-label-new "Month:") + adj (gtk-adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) + spin (gtk-spin-button-new adj 0 0)) + (gtk-misc-set-alignment label 0 0.5) + (gtk-spin-button-set-wrap spin t) + (gtk-spin-button-set-shadow-type spin 'out) + (gtk-box-pack-start hbox vbox t t 5) + (gtk-box-pack-start vbox label nil t 0) + (gtk-box-pack-start vbox spin nil t 0) + + (setq vbox (gtk-vbox-new nil 0) + label (gtk-label-new "Year:") + adj (gtk-adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) + spin (gtk-spin-button-new adj 0 0)) + (gtk-misc-set-alignment label 0 0.5) + (gtk-spin-button-set-wrap spin t) + (gtk-spin-button-set-shadow-type spin 'out) + (gtk-widget-set-usize spin 55 0) + (gtk-box-pack-start hbox vbox t t 5) + (gtk-box-pack-start vbox label nil t 0) + (gtk-box-pack-start vbox spin nil t 0) + + (setq frame (gtk-frame-new "Accelerated") + vbox (gtk-vbox-new nil 0)) + + (gtk-box-pack-start window frame t t 0) + (gtk-container-add frame vbox) + + (setq hbox (gtk-hbox-new nil 0)) + (gtk-box-pack-start vbox hbox nil t 5) + + (setq vbox2 (gtk-vbox-new nil 0) + label (gtk-label-new "Value:") + adj (gtk-adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0) + spin (gtk-spin-button-new adj 1.0 2)) + (gtk-misc-set-alignment label 0 0.5) + (gtk-spin-button-set-wrap spin t) + (gtk-widget-set-usize spin 100 0) + (gtk-box-pack-start vbox2 label nil t 0) + (gtk-box-pack-start vbox2 spin nil t 0) + (gtk-box-pack-start hbox vbox2 t t 0) + + (setq vbox2 (gtk-vbox-new nil 0) + label (gtk-label-new "Digits:") + adj (gtk-adjustment-new 2 1 5 1 1 0) + spin2 (gtk-spin-button-new adj 0 0)) + (gtk-misc-set-alignment label 0 0.5) + (gtk-spin-button-set-wrap spin2 t) + (gtk-widget-set-usize spin2 100 0) + (gtk-box-pack-start vbox2 label nil t 0) + (gtk-box-pack-start vbox2 spin2 nil t 0) + (gtk-box-pack-start hbox vbox2 t t 0) + (gtk-signal-connect adj 'value_changed + (lambda (adj spinners) + (gtk-spin-button-set-digits + (car spinners) + (gtk-spin-button-get-value-as-int (cdr spinners)))) + (cons spin spin2)) + + (setq button (gtk-check-button-new-with-label "Snap to 0.5-ticks")) + (gtk-signal-connect button 'clicked + (lambda (button spin) + (gtk-spin-button-set-snap-to-ticks + spin + (gtk-toggle-button-get-active button))) + spin) + (gtk-box-pack-start vbox button t t 0) + (gtk-toggle-button-set-active button t) + + (setq button (gtk-check-button-new-with-label "Numeric only input mode")) + (gtk-signal-connect button 'clicked + (lambda (button spin) + (gtk-spin-button-set-numeric + spin + (gtk-toggle-button-get-active button))) + spin) + (gtk-box-pack-start vbox button t t 0) + (gtk-toggle-button-set-active button t) + + (setq label (gtk-label-new "")) + + (setq hbox (gtk-hbutton-box-new)) + (gtk-box-pack-start vbox hbox nil t 5) + (gtk-box-pack-start vbox label nil nil 5) + + (setq button (gtk-button-new-with-label "Value as int")) + (gtk-container-add hbox button) + (gtk-signal-connect button 'clicked + (lambda (obj data) + (let ((spin (car data)) + (label (cdr data))) + (gtk-label-set-text label + (format "%d" + (gtk-spin-button-get-value-as-int spin))))) + (cons spin label)) + + (setq button (gtk-button-new-with-label "Value as float")) + (gtk-container-add hbox button) + (gtk-signal-connect button 'clicked + (lambda (obj data) + (let ((spin (car data)) + (label (cdr data))) + (gtk-label-set-text label + (format "%g" + (gtk-spin-button-get-value-as-float spin))))) + (cons spin label)))) + + +;;;; Reparenting +(gtk-define-test + "Reparenting" misc reparenting nil + (let ((label (gtk-label-new "Hello World")) + (frame-1 (gtk-frame-new "Frame 1")) + (frame-2 (gtk-frame-new "Frame 2")) + (button nil) + (hbox (gtk-hbox-new nil 5)) + (vbox-1 nil) + (vbox-2 nil) + (reparent-func (lambda (button data) + (let ((label (car data)) + (new-parent (cdr data))) + (gtk-widget-reparent label new-parent))))) + + (gtk-box-pack-start window hbox t t 0) + (gtk-box-pack-start hbox frame-1 t t 0) + (gtk-box-pack-start hbox frame-2 t t 0) + + (setq vbox-1 (gtk-vbox-new nil 0)) + (gtk-container-add frame-1 vbox-1) + (setq vbox-2 (gtk-vbox-new nil 0)) + (gtk-container-add frame-2 vbox-2) + + (setq button (gtk-button-new-with-label "switch")) + (gtk-box-pack-start vbox-1 button nil nil 0) + (gtk-signal-connect button 'clicked reparent-func (cons label vbox-2)) + + (setq button (gtk-button-new-with-label "switch")) + (gtk-box-pack-start vbox-2 button nil nil 0) + (gtk-signal-connect button 'clicked reparent-func (cons label vbox-1)) + + (gtk-box-pack-start vbox-2 label nil t 0))) + + +;;;; StatusBar +(defvar statusbar-counter 1) + +(gtk-define-test + "Statusbar" composite statusbar nil + (let ((bar (gtk-statusbar-new)) + (vbox nil) + (button nil)) + + (setq vbox (gtk-vbox-new nil 0)) + (gtk-box-pack-start window vbox t t 0) + (gtk-box-pack-end window bar t t 0) + + (setq button (gtk-button-new-with-label "push something")) + (gtk-box-pack-start-defaults vbox button) + (gtk-signal-connect button 'clicked + (lambda (button bar) + (gtk-statusbar-push bar 1 (format "something %d" (incf statusbar-counter)))) + bar) + + (setq button (gtk-button-new-with-label "pop")) + (gtk-box-pack-start-defaults vbox button) + (gtk-signal-connect button 'clicked + (lambda (button bar) + (gtk-statusbar-pop bar 1)) bar) + + (setq button (gtk-button-new-with-label "steal #4")) + (gtk-box-pack-start-defaults vbox button) + (gtk-signal-connect button 'clicked + (lambda (button bar) + (gtk-statusbar-remove bar 1 4)) bar) + + (setq button (gtk-button-new-with-label "dump stack")) + (gtk-box-pack-start-defaults vbox button) + (gtk-widget-set-sensitive button nil) + + (setq button (gtk-button-new-with-label "test contexts")) + (gtk-box-pack-start-defaults vbox button) + (gtk-signal-connect button 'clicked + (lambda (button bar) + (let ((contexts '("any context" "idle messages" "some text" + "hit the mouse" "hit the mouse2"))) + (message-box "%s" + (mapconcat + (lambda (ctx) + (format "context=\"%s\", context_id=%d" + ctx (gtk-statusbar-get-context-id bar ctx))) + contexts "\n")))) bar))) + + +;;;; Columned List +(gtk-define-test + "Columnar List" composite clist nil + (let ((titles '("auto resize" "not resizeable" "max width 100" "min width 50" + "hide column" "Title 5" "Title 6" "Title 7" "Title 8" "Title 9" + "Title 10" "Title 11")) + hbox clist button separator scrolled-win check undo-button label) + + (gtk-container-set-border-width window 0) + + (setq scrolled-win (gtk-scrolled-window-new nil nil)) + (gtk-container-set-border-width scrolled-win 5) + (gtk-scrolled-window-set-policy scrolled-win 'automatic 'automatic) + + ;; create GtkCList here so we have a pointer to throw at the + ;; button callbacks -- more is done with it later + (setq clist (gtk-clist-new-with-titles (length titles) titles)) + (gtk-container-add scrolled-win clist) + + ;; Make the columns live up to their titles. + (gtk-clist-set-column-auto-resize clist 0 t) + (gtk-clist-set-column-resizeable clist 1 nil) + (gtk-clist-set-column-max-width clist 2 100) + (gtk-clist-set-column-min-width clist 3 50) + + (gtk-signal-connect clist 'click-column + (lambda (clist column data) + (cond + ((= column 4) + (gtk-clist-set-column-visibility clist column nil)) + ((= column (gtk-clist-sort-column clist)) + (gtk-clist-set-sort-type + clist (if (eq (gtk-clist-sort-type clist) 'ascending) + 'descending + 'ascending))) + (t + (gtk-clist-set-sort-column clist column))) + (gtk-clist-sort clist))) + + ;; control buttons + (setq hbox (gtk-hbox-new nil 5)) + (gtk-container-set-border-width hbox 5) + (gtk-box-pack-start window hbox nil nil 0) + + (setq button (gtk-button-new-with-label "Insert Row")) + (gtk-box-pack-start hbox button t t 0) + (gtk-signal-connect button 'clicked + (lambda (button clist) + (gtk-clist-append clist + (list (format "CListRow %05d" (random 10000)) + "Column 1" + "Column 2" + "Column 3" + "Column 4" + "Column 5" + "Column 6" + "Column 7" + "Column 8" + "Column 0" + "Column 10" + "Column 11"))) clist) + + (setq button (gtk-button-new-with-label "Add 1,000 Rows with Pixmaps")) + (gtk-box-pack-start hbox button t t 0) + (gtk-signal-connect button 'clicked + (lambda (button clist) + (let ((row 0) i) + (gtk-clist-freeze clist) + (loop for i from 0 to 1000 do + (setq row + (gtk-clist-append clist + (list + (format "CListRow %05d" (random 10000)) + "Column 1" + "Column 2" + "Column 3" + "Column 4" + "Column 5" + "Column 6" + "Column 7" + "Column 8" + "Column 0" + "Column 10" + "Column 11"))) + (gtk-clist-set-pixtext clist row 3 "gtk+" 5 + gtk-test-mini-gtk-glyph + nil)) + (gtk-clist-thaw clist))) clist) + + (setq button (gtk-button-new-with-label "Add 10,000 Rows")) + (gtk-box-pack-start hbox button t t 0) + (gtk-signal-connect button 'clicked + (lambda (button clist) + (gtk-clist-freeze clist) + (loop for i from 0 to 10000 do + (gtk-clist-append clist + (list + (format "CListRow %05d" (random 10000)) + "Column 1" + "Column 2" + "Column 3" + "Column 4" + "Column 5" + "Column 6" + "Column 7" + "Column 8" + "Column 0" + "Column 10" + "Column 11"))) + (gtk-clist-thaw clist)) clist) + + ;; Second layer of buttons + (setq hbox (gtk-hbox-new nil 5)) + (gtk-container-set-border-width hbox 5) + (gtk-box-pack-start window hbox nil nil 0) + + (setq button (gtk-button-new-with-label "Clear List")) + (gtk-box-pack-start hbox button t t 0) + (gtk-signal-connect button 'clicked (lambda (button clist) + (gtk-clist-clear clist)) clist) + + (setq button (gtk-button-new-with-label "Remove Selection")) + (gtk-box-pack-start hbox button t t 0) + (gtk-signal-connect button 'clicked (lambda (button clist) + (error "Do not know how to do this yet."))) + (gtk-widget-set-sensitive button nil) + + (setq button (gtk-button-new-with-label "Undo Selection")) + (gtk-box-pack-start hbox button t t 0) + (gtk-signal-connect button 'clicked + (lambda (button clist) (gtk-clist-undo-selection clist))) + + (setq button (gtk-button-new-with-label "Warning Test")) + (gtk-box-pack-start hbox button t t 0) + (gtk-signal-connect button 'clicked 'ignore) + (gtk-widget-set-sensitive button nil) + + ;; Third layer of buttons + (setq hbox (gtk-hbox-new nil 5)) + (gtk-container-set-border-width hbox 5) + (gtk-box-pack-start window hbox nil nil 0) + + (setq button (gtk-check-button-new-with-label "Show Title Buttons")) + (gtk-box-pack-start hbox button nil t 0) + (gtk-signal-connect button 'clicked (lambda (button clist) + (if (gtk-toggle-button-get-active button) + (gtk-clist-column-titles-show clist) + (gtk-clist-column-titles-hide clist))) clist) + (gtk-toggle-button-set-active button t) + + (setq button (gtk-check-button-new-with-label "Reorderable")) + (gtk-box-pack-start hbox check nil t 0) + (gtk-signal-connect button 'clicked (lambda (button clist) + (gtk-clist-set-reorderable + clist + (gtk-toggle-button-get-active button))) clist) + (gtk-toggle-button-set-active button t) + + (setq label (gtk-label-new "Selection Mode :")) + (gtk-box-pack-start hbox label nil t 0) + + (gtk-box-pack-start hbox (build-option-menu + '(("Single" . + (lambda (item clist) + (gtk-clist-set-selection-mode clist 'single))) + ("Browse" . + (lambda (item clist) + (gtk-clist-set-selection-mode clist 'browse))) + ("Multiple" . + (lambda (item clist) + (gtk-clist-set-selection-mode clist 'multiple))) + ("Extended" . + (lambda (item clist) + (gtk-clist-set-selection-mode clist 'extended)))) + 3 clist) nil t 0) + + ;; The rest of the clist configuration + (gtk-box-pack-start window scrolled-win t t 0) + (gtk-clist-set-row-height clist 18) + (gtk-widget-set-usize clist -1 300) + + (loop for i from 0 to 11 do + (gtk-clist-set-column-width clist i 80)))) + + +;;;; Notebook +(defun set-tab-label (notebook page selected-p) + (if page + (let (label label-box pixwid) + (setq label-box (gtk-hbox-new nil 0)) + (setq pixwid (gtk-pixmap-new + (if selected-p gtk-test-open-glyph gtk-test-closed-glyph) nil)) + (gtk-box-pack-start label-box pixwid nil t 0) + (gtk-misc-set-padding pixwid 3 1) ; + (setq label (gtk-label-new + (format "Page %d" (1+ (gtk-notebook-page-num notebook page))))) + (gtk-box-pack-start label-box label nil t 0) + (gtk-widget-show-all label-box) + (gtk-notebook-set-tab-label notebook page label-box)))) + +(defun page-switch (widget page page-num data) + (let ((oldpage (gtk-notebook-get-current-page widget)) + (label nil) + (label-box nil) + (pixwid nil)) + (if (eq page-num oldpage) + nil + (set-tab-label widget (gtk-notebook-get-nth-page widget oldpage) nil) + (set-tab-label widget (gtk-notebook-get-nth-page widget page-num) t)))) + +(defun create-pages (notebook start end) + (let (child button label hbox vbox label-box menu-box pixwid i) + (setq i start) + (while (<= i end) + (setq child (gtk-frame-new (format "Page %d" i))) + (gtk-container-set-border-width child 10) + + (setq vbox (gtk-vbox-new t 0)) + (gtk-container-set-border-width vbox 10) + (gtk-container-add child vbox) + + (setq hbox (gtk-hbox-new t 0)) + (gtk-box-pack-start vbox hbox nil t 5) + + (setq button (gtk-check-button-new-with-label "Fill Tab")) + (gtk-box-pack-start hbox button t t 5) + (gtk-toggle-button-set-active button t) + (gtk-signal-connect + button 'toggled + (lambda (button data) + (let ((packing (gtk-notebook-query-tab-label-packing (car data) (cdr data)))) + (gtk-notebook-set-tab-label-packing (car data) (cdr data) + (nth 0 packing) + (gtk-toggle-button-get-active button) + (nth 2 packing)))) + (cons notebook child)) + + (setq button (gtk-check-button-new-with-label "Expand Tab")) + (gtk-box-pack-start hbox button t t 5) + (gtk-signal-connect + button 'toggled + (lambda (button data) + (let ((packing (gtk-notebook-query-tab-label-packing (car data) (cdr data)))) + (gtk-notebook-set-tab-label-packing (car data) (cdr data) + (gtk-toggle-button-get-active button) + (nth 1 packing) (nth 2 packing)))) + (cons notebook child)) + + (setq button (gtk-check-button-new-with-label "Pack End")) + (gtk-box-pack-start hbox button t t 5) + (gtk-signal-connect + button 'toggled + (lambda (button data) + (let ((packing (gtk-notebook-query-tab-label-packing (car data) (cdr data)))) + (gtk-notebook-set-tab-label-packing (car data) (cdr data) + (nth 0 packing) (nth 1 packing) + (if (gtk-toggle-button-get-active button) 'end 'start)))) + (cons notebook child)) + + (setq button (gtk-button-new-with-label "Hide Page")) + (gtk-box-pack-end vbox button nil nil 5) + (gtk-signal-connect button 'clicked + (lambda (ignored child) (gtk-widget-hide child)) child) + + (gtk-widget-show-all child) + + (setq label-box (gtk-hbox-new nil 0)) + (setq pixwid (gtk-pixmap-new gtk-test-closed-glyph nil)) + (gtk-box-pack-start label-box pixwid nil t 0) + (gtk-misc-set-padding pixwid 3 1); + (setq label (gtk-label-new (format "Page %d" i))) + (gtk-box-pack-start label-box label nil t 0) + (gtk-widget-show-all label-box) + + (setq menu-box (gtk-hbox-new nil 0)) + (setq pixwid (gtk-pixmap-new gtk-test-closed-glyph nil)) + (gtk-box-pack-start menu-box pixwid nil t 0) + (gtk-misc-set-padding pixwid 3 1) + (setq label (gtk-label-new (format "Page %d" i))) + (gtk-box-pack-start menu-box label nil t 0) + (gtk-widget-show-all menu-box) + (gtk-notebook-append-page-menu notebook child label-box menu-box) + (incf i)))) + +(gtk-define-test + "Notebook" container notebook nil + (let (box1 box2 button separator omenu transparent label sample-notebook) + (gtk-container-set-border-width window 0) + + (setq sample-notebook (gtk-notebook-new)) + (gtk-signal-connect sample-notebook 'switch_page 'page-switch) + (gtk-notebook-set-tab-pos sample-notebook 'top) + (gtk-box-pack-start window sample-notebook t t 0) + (gtk-container-set-border-width sample-notebook 10) + + (create-pages sample-notebook 1 5) + + (setq separator (gtk-hseparator-new)) + (gtk-box-pack-start window separator nil t 10) + + (setq box2 (gtk-hbox-new nil 5)) + (gtk-container-set-border-width box2 10) + (gtk-box-pack-start window box2 nil t 0) + + (setq button (gtk-check-button-new-with-label "popup menu")) + (gtk-box-pack-start box2 button t nil 0) + (gtk-signal-connect button 'clicked + (lambda (button notebook) + (if (gtk-toggle-button-get-active button) + (gtk-notebook-popup-enable notebook) + (gtk-notebook-popup-disable notebook))) sample-notebook) + + (setq button (gtk-check-button-new-with-label "homogeneous tabs")) + (gtk-box-pack-start box2 button t nil 0) + (gtk-signal-connect button 'clicked + (lambda (button notebook) + (gtk-notebook-set-homogeneous-tabs + notebook + (gtk-toggle-button-get-active button))) sample-notebook) + + (setq box2 (gtk-hbox-new nil 5)) + (gtk-container-set-border-width box2 10) + (gtk-box-pack-start window box2 nil t 0) + + (setq label (gtk-label-new "Notebook Style :")) + (gtk-box-pack-start box2 label nil t 0) + + (setq omenu (build-option-menu '(("Standard" . + (lambda (b n) + (gtk-notebook-set-show-tabs n t) + (gtk-notebook-set-scrollable n nil))) + ("No tabs" . + (lambda (b n) + (gtk-notebook-set-show-tabs n nil))) + ("Scrollable" . + (lambda (b n) + (gtk-notebook-set-show-tabs n t) + (gtk-notebook-set-scrollable n t)))) + 0 + sample-notebook)) + (gtk-box-pack-start box2 omenu nil t 0) + + (setq button (gtk-button-new-with-label "Show all pages")) + (gtk-box-pack-start box2 button nil t 0) + (gtk-signal-connect + button 'clicked (lambda (button notebook) + (mapc 'gtk-widget-show (gtk-container-children notebook))) + sample-notebook) + + (setq box2 (gtk-hbox-new t 10)) + (gtk-container-set-border-width box2 10) + (gtk-box-pack-start window box2 nil t 0) + + (setq button (gtk-button-new-with-label "prev")) + (gtk-signal-connect button 'clicked + (lambda (button notebook) + (gtk-notebook-prev-page notebook)) sample-notebook) + (gtk-box-pack-start box2 button t t 0) + + (setq button (gtk-button-new-with-label "next")) + (gtk-signal-connect button 'clicked + (lambda (button notebook) + (gtk-notebook-next-page notebook)) sample-notebook) + (gtk-box-pack-start box2 button t t 0) + + (setq button (gtk-button-new-with-label "rotate")) + (gtk-signal-connect button 'clicked + (lambda (button notebook) + (gtk-notebook-set-tab-pos + notebook + (case (gtk-notebook-tab-pos notebook) + (top 'right) + (right 'bottom) + (bottom 'left) + (left 'top)))) + sample-notebook) + + (gtk-box-pack-start box2 button t t 0))) + + +;;;; Glade interfaces +(if (and (featurep 'glade) + (file-exists-p (expand-file-name "gtk-test.glade" (gtk-test-directory)))) + (gtk-define-test + "Glade Interface" misc libglade t + (glade-init) + (glade-xml-get-type) + (let ((xml (glade-xml-new (expand-file-name "gtk-test.glade" (gtk-test-directory)) + nil))) + (setq window (glade-xml-get-widget xml "main_window")) + (glade-xml-signal-autoconnect xml))) + (fmakunbound 'gtk-test-libglade)) + + +;;;; CTree +(defvar gtk-test-ctree-hash nil) + +(defun gtk-test-ctree-expand-directory (ctree dir parent) + (ignore-errors + (let ((dirs (directory-files dir t nil nil 5)) + (files (directory-files dir t nil nil t)) + (node nil)) + (mapc (lambda (d) + (if (or (string-match "/\\.$" d) + (string-match "/\\.\\.$" d)) + nil + (setq node + (gtk-ctree-insert-node ctree parent nil + (list (file-name-nondirectory d) "") + 0 nil nil nil nil nil t)) + (puthash node d gtk-test-ctree-hash) + (gtk-ctree-insert-node ctree node nil + (list "" "") + 0 nil nil nil nil nil nil) + (gtk-ctree-collapse ctree node))) + dirs) + (mapc (lambda (f) + (gtk-ctree-insert-node ctree parent nil + (list (file-name-nondirectory f) + (user-login-name (nth 2 (file-attributes f)))) + 0 nil nil nil nil t nil)) + files) + (gtk-clist-columns-autosize ctree)))) + +(defun gtk-spin-button-new-with-label (label adjustment climb-rate digits) + (let ((box (gtk-hbox-new nil 2)) + (spin (gtk-spin-button-new adjustment climb-rate digits)) + (lbl (gtk-label-new label))) + (gtk-box-pack-start box lbl nil nil 0) + (gtk-box-pack-start box spin t t 0) + (cons box spin))) + +(gtk-define-test + "Columnar Tree" composite ctree nil + (let ((scrolled (gtk-scrolled-window-new nil nil)) + (ctree (gtk-ctree-new-with-titles 2 0 '("File" "Owner"))) + (box (gtk-hbutton-box-new)) + (button nil)) + (setq gtk-test-ctree-hash (make-hash-table :test 'equal)) + (put scrolled 'child ctree) + (put scrolled 'height 400) + (put ctree 'line_style 'solid) + (put ctree 'expander_style 'square) + + (gtk-box-pack-start window scrolled t t 0) + (gtk-box-pack-start window box nil nil 5) + + (gtk-clist-freeze ctree) + (gtk-test-ctree-expand-directory ctree "/" nil) + (gtk-clist-thaw ctree) + + (setq button (gtk-button-new-with-label "Expand all")) + (put box 'child button) + (gtk-signal-connect button 'clicked (lambda (button tree) + (gtk-ctree-expand-recursive tree nil)) ctree) + + (setq button (gtk-button-new-with-label "Collaps all")) + (put box 'child button) + (gtk-signal-connect button 'clicked (lambda (button tree) + (gtk-ctree-collapse-recursive tree nil)) ctree) + + (setq button (gtk-button-new-with-label "Change style")) + (put box 'child button) + (put button 'sensitive nil) + + (setq box (gtk-hbox-new t 5)) + (gtk-box-pack-start window box nil nil 0) + + (setq button (gtk-button-new-with-label "Select all")) + (put box 'child button) + (gtk-signal-connect button 'clicked (lambda (button tree) + (gtk-ctree-select-recursive tree nil)) ctree) + + (setq button (gtk-button-new-with-label "Unselect all")) + (put box 'child button) + (gtk-signal-connect button 'clicked (lambda (button tree) + (gtk-ctree-unselect-recursive tree nil)) ctree) + + (setq button (gtk-button-new-with-label "Remove all")) + (put box 'child button) + (gtk-signal-connect button 'clicked (lambda (button tree) + (gtk-clist-freeze tree) + (gtk-ctree-recurse + tree nil + (lambda (tree subnode data) + (gtk-ctree-remove-node tree subnode))) + (gtk-clist-thaw tree)) ctree) + + (setq button (gtk-check-button-new-with-label "Reorderable")) + (put box 'child button) + (gtk-signal-connect button 'clicked (lambda (button tree) + (put tree 'reorderable + (gtk-toggle-button-get-active button))) ctree) + + (setq box (gtk-hbox-new t 5)) + (gtk-box-pack-start window box nil nil 0) + + (gtk-box-pack-start box (build-option-menu + '(("Dotted" . (lambda (item ctree) (put ctree 'line_style 'dotted))) + ("Solid" . (lambda (item ctree) (put ctree 'line_style 'solid))) + ("Tabbed" . (lambda (item ctree) (put ctree 'line_style 'tabbed))) + ("None" . (lambda (item ctree) (put ctree 'line_style 'none)))) + 0 ctree) nil t 0) + (gtk-box-pack-start box (build-option-menu + '(("Square" . (lambda (item ctree) (put ctree 'expander_style 'square))) + ("Triangle" . (lambda (item ctree) (put ctree 'expander_style 'triangle))) + ("Circular" . (lambda (item ctree) (put ctree 'expander_style 'circular))) + ("None" . (lambda (item ctree) (put ctree 'expander_style 'none)))) + 0 ctree) nil t 0) + (gtk-box-pack-start box (build-option-menu + '(("Left" . (lambda (item ctree) + (gtk-clist-set-column-justification + ctree (get ctree 'tree_column) 'left))) + ("Right" . (lambda (item ctree) + (gtk-clist-set-column-justification + ctree (get ctree 'tree_column) 'right)))) + 0 ctree) nil t 0) + (gtk-box-pack-start box (build-option-menu + '(("Single" . + (lambda (item clist) + (gtk-clist-set-selection-mode clist 'single))) + ("Browse" . + (lambda (item clist) + (gtk-clist-set-selection-mode clist 'browse))) + ("Multiple" . + (lambda (item clist) + (gtk-clist-set-selection-mode clist 'multiple))) + ("Extended" . + (lambda (item clist) + (gtk-clist-set-selection-mode clist 'extended)))) + 3 ctree) nil t 0) + + (setq box (gtk-hbox-new t 5)) + (gtk-box-pack-start window box nil nil 0) + + (let (adj spinner) + (setq adj (gtk-adjustment-new (get ctree 'indent) 0 999 1 5 5) + spinner (gtk-spin-button-new-with-label "Indent: " adj 1 3)) + (put box 'child (car spinner)) + (gtk-signal-connect adj 'value-changed + (lambda (adj tree) + (put tree 'indent (truncate (gtk-adjustment-value adj)))) ctree) + + (setq adj (gtk-adjustment-new (get ctree 'spacing) 0 999 1 5 5) + spinner (gtk-spin-button-new-with-label "Spacing: " adj 1 3)) + (put box 'child (car spinner)) + (gtk-signal-connect adj 'value-changed + (lambda (adj tree) + (put tree 'spacing (truncate (gtk-adjustment-value adj)))) ctree) + + (setq adj (gtk-adjustment-new (get ctree 'row_height) 0 999 1 5 5) + spinner (gtk-spin-button-new-with-label "Row Height: " adj 1 3)) + (put box 'child (car spinner)) + (gtk-signal-connect adj 'value-changed + (lambda (adj tree) + (put tree 'row_height (truncate (gtk-adjustment-value adj)))) ctree) + + (setq button (gtk-check-button-new-with-label "Show logical root")) + (put box 'child button) + (gtk-signal-connect button 'clicked + (lambda (button tree) + (put tree 'show_stub (gtk-toggle-button-get-active button))) ctree)) + + (gtk-signal-connect ctree 'tree-expand + (lambda (ctree node user-data) + (gtk-clist-freeze ctree) + (gtk-ctree-recurse + ctree node + (lambda (tree subnode user-data) + (if (not (equal subnode node)) + (gtk-ctree-remove-node tree subnode)))) + (gtk-test-ctree-expand-directory ctree + (gethash node gtk-test-ctree-hash) + node) + (gtk-clist-thaw ctree))))) + + +;;;; The main interface + +(defun gtk-test-view-source (test) + ;; View the source for this test in a XEmacs window. + (if test + (let ((path (expand-file-name "gtk-test.el" (gtk-test-directory)))) + (if (not (file-exists-p path)) + (error "Could not find source for gtk-test.el")) + (find-file path) + (widen) + (goto-char (point-min)) + (if (not (re-search-forward (concat "(gtk-define-test[ \t\n]*\"" test "\"") nil t)) + (error "Could not find test: %s" test) + (narrow-to-page) + (goto-char (point-min)))))) + +(defvar gtk-test-selected-test nil) + +(defun gtk-test () + (interactive) + (let ((items nil) + (box nil) + (window nil) + (category-trees nil) + (tree nil) + (pane nil) + (scrolled nil) + (src-button nil) + (gc-button nil) + (standalone-p (not (default-gtk-device))) + (close-button nil)) + (gtk-init (list invocation-name)) + (if standalone-p + (progn + (gtk-object-destroy (gtk-adjustment-new 0 0 0 0 0 0)))) + (ignore-errors + (or (fboundp 'gtk-test-gnome-pixmaps) + (load-file (expand-file-name "gnome-test.el" (gtk-test-directory)))) + (or (fboundp 'gtk-test-color-combo) + (load-file (expand-file-name "gtk-extra-test.el" (gtk-test-directory))))) + (unwind-protect + (progn + (setq window (gtk-dialog-new) + box (gtk-vbox-new nil 5) + pane (gtk-hpaned-new) + scrolled (gtk-scrolled-window-new nil nil) + tree (gtk-tree-new) + src-button (gtk-button-new-with-label "View source") + gc-button (gtk-button-new-with-label "Garbage Collect") + close-button (gtk-button-new-with-label "Quit")) + (gtk-window-set-title window + (format "%s/GTK %d.%d.%d" + (if (featurep 'infodock) "InfoDock" "XEmacs") + emacs-major-version emacs-minor-version + (or emacs-patch-level emacs-beta-version))) + + (gtk-scrolled-window-set-policy scrolled 'automatic 'automatic) + (gtk-scrolled-window-add-with-viewport scrolled tree) + (gtk-widget-set-usize scrolled 200 600) + + (gtk-box-pack-start (gtk-dialog-vbox window) pane t t 5) + (gtk-paned-pack1 pane scrolled t nil) + (gtk-paned-pack2 pane box t nil) + (setq gtk-test-shell box) + (gtk-widget-show-all box) + + (gtk-container-add (gtk-dialog-action-area window) close-button) + (gtk-container-add (gtk-dialog-action-area window) src-button) + (gtk-container-add (gtk-dialog-action-area window) gc-button) + + (gtk-signal-connect gc-button 'clicked + (lambda (obj data) + (garbage-collect))) + (gtk-signal-connect close-button 'clicked + (lambda (obj data) + (gtk-widget-destroy data)) window) + (gtk-signal-connect src-button 'clicked + (lambda (obj data) + (gtk-test-view-source gtk-test-selected-test))) + + ;; Try to be a nice person and sort the tests + (setq gtk-defined-tests + (sort gtk-defined-tests + (lambda (a b) + (string-lessp (car a) (car b))))) + + ;; This adds all of the buttons to the window. + (mapcar (lambda (test) + (let* ((desc (nth 0 test)) + (type (nth 1 test)) + (func (nth 2 test)) + (parent (cdr-safe (assoc type category-trees))) + (item (gtk-tree-item-new-with-label desc))) + (put item 'test-function func) + (put item 'test-description desc) + (put item 'test-type type) + (gtk-widget-show item) + (if (not parent) + (let ((subtree (gtk-tree-new))) + (setq parent (gtk-tree-item-new-with-label + (or (cdr-safe (assoc type gtk-test-categories)) + (symbol-name type)))) + (gtk-signal-connect subtree 'select-child + (lambda (tree widget data) + (setq gtk-test-selected-test (get widget 'test-description)) + (funcall (get widget 'test-function)))) + (gtk-tree-append tree parent) + (gtk-tree-item-set-subtree parent subtree) + (setq parent subtree) + (push (cons type parent) category-trees))) + (gtk-tree-append parent item))) + gtk-defined-tests) + (gtk-widget-show-all window) + (if standalone-p + (progn + (gtk-signal-connect window 'destroy (lambda (w d) + (gtk-main-quit))) + (gtk-main))))))) diff --git a/tests/gtk/gtk-test.glade b/tests/gtk/gtk-test.glade new file mode 100644 index 0000000..0e2760c --- /dev/null +++ b/tests/gtk/gtk-test.glade @@ -0,0 +1,145 @@ + + + + + Project1 + project1 + + src + pixmaps + C + True + True + + + + GtkWindow + main_window + Glade Created Window + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + False + True + False + + + GtkVBox + Container + False + 0 + + + GtkToolbar + toolbar1 + GTK_ORIENTATION_HORIZONTAL + GTK_TOOLBAR_BOTH + 5 + GTK_TOOLBAR_SPACE_EMPTY + GTK_RELIEF_NORMAL + True + + 0 + False + False + + + + GtkButton + Toolbar:button + button1 + + + + + GtkButton + Toolbar:button + button2 + + + + + GtkButton + Toolbar:button + button3 + + + + + + GtkScrolledWindow + scrolledwindow1 + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_UPDATE_CONTINUOUS + GTK_UPDATE_CONTINUOUS + + 0 + True + True + + + + GtkCTree + ctree + True + 3 + 114,80,80 + GTK_SELECTION_SINGLE + True + GTK_SHADOW_IN + + + GtkLabel + CTree:title + label1 + + GTK_JUSTIFY_CENTER + False + 2.98023e-08 + 0.5 + 0 + 0 + + + + GtkLabel + CTree:title + label2 + + GTK_JUSTIFY_CENTER + False + 0.5 + 0.5 + 0 + 0 + + + + GtkLabel + CTree:title + label3 + + GTK_JUSTIFY_CENTER + False + 0.5 + 0.5 + 0 + 0 + + + + + + GtkStatusbar + statusbar + + 0 + False + False + + + + + + diff --git a/tests/gtk/statusbar-test.el b/tests/gtk/statusbar-test.el new file mode 100644 index 0000000..457e5d8 --- /dev/null +++ b/tests/gtk/statusbar-test.el @@ -0,0 +1,74 @@ +(defvar statusbar-hashtable (make-hashtable 29)) +(defvar statusbar-gnome-p nil) + +(defmacro get-frame-statusbar (frame) + `(gethash (or ,frame (selected-frame)) statusbar-hashtable)) + +(defun add-frame-statusbar (frame) + "Stick a GTK (or GNOME) statusbar at the bottom of the frame." + (if (windowp (frame-property frame 'minibuffer)) + (puthash frame (get-frame-statusbar (window-frame (frame-property frame 'minibuffer))) + statusbar-hashtable) + (let ((sbar nil) + (shell (frame-property frame 'shell-widget))) + (if (string-match "Gnome" (gtk-type-name (gtk-object-type shell))) + (progn + (require 'gnome-widgets) + (setq sbar (gnome-appbar-new t t 0) + statusbar-gnome-p t) + (gtk-progress-set-format-string sbar "%p%%") + (gnome-app-set-statusbar shell sbar)) + (setq sbar (gtk-statusbar-new)) + (gtk-box-pack-end (frame-property frame 'container-widget) + sbar nil nil 0)) + (puthash frame sbar statusbar-hashtable)))) + +(add-hook 'create-frame-hook 'add-frame-statusbar) +(add-hook 'delete-frame-hook (lambda (f) + (remhash f statusbar-hashtable))) + + +(defun clear-message (&optional label frame stdout-p no-restore) + (let ((sbar (get-frame-statusbar frame))) + (if sbar + (if statusbar-gnome-p + (gnome-appbar-pop sbar) + (gtk-statusbar-pop sbar 1))))) + +(defun append-message (label message &optional frame stdout-p) + (let ((sbar (get-frame-statusbar frame))) + (if sbar + (if statusbar-gnome-p + (gnome-appbar-push sbar message) + (gtk-statusbar-push sbar 1 message))))) + +(defun progress-display (fmt &optional value &rest args) + "Print a progress gauge and message in the bottom gutter area of the frame. +The arguments are the same as to `format'. + +If the only argument is nil, clear any existing progress gauge." + (let ((sbar (get-frame-statusbar nil))) + (apply 'message fmt args) + (if statusbar-gnome-p + (progn + (gtk-progress-set-show-text (gnome-appbar-get-progress sbar) t) + (gnome-appbar-set-progress sbar (/ value 100.0)) + (gdk-flush))))) + +(defun lprogress-display (label fmt &optional value &rest args) + "Print a progress gauge and message in the bottom gutter area of the frame. +First argument LABEL is an identifier for this progress gauge. The rest of the +arguments are the same as to `format'." + (if (and (null fmt) (null args)) + (prog1 nil + (clear-progress-display label nil)) + (let ((str (apply 'format fmt args))) + (progress-display str value) + str))) + +(defun clear-progress-display (&rest ignored) + (if statusbar-gnome-p + (let* ((sbar (get-frame-statusbar nil)) + (progress (gnome-appbar-get-progress sbar))) + (gnome-appbar-set-progress sbar 0) + (gtk-progress-set-show-text progress nil)))) diff --git a/tests/gtk/toolbar-test.el b/tests/gtk/toolbar-test.el new file mode 100644 index 0000000..f006bd4 --- /dev/null +++ b/tests/gtk/toolbar-test.el @@ -0,0 +1,34 @@ +(require 'gtk-widgets) +(require 'gnome-widgets) + +(defvar gnomeified-toolbar + ;; [CAPTION TOOLTIP ICON CALLBACK ENABLED] + '(["Open" "Open a file" new toolbar-open t] + ["Dired" "Edit a directory" open toolbar-dired t] + ["Save" "Save buffer" save toolbar-save t] + ["Print" "Print Buffer" print toolbar-print t] + ["Cut" "Kill region" cut toolbar-cut t] + ["Copy" "Copy region" copy toolbar-copy t] + ["Paste" "Paste from clipboard" paste toolbar-paste t] + ["Undo" "Undo edit" undo toolbar-undo t] + ["Spell" "Check spelling" spellcheck toolbar-ispell t] + ["Replace" "Search & Replace" srchrpl toolbar-replace t] + ["Mail" "Read mail" mail toolbar-mail t] + ; info + ; compile + ; debug + ; news + )) + +(setq x (gtk-toolbar-new 'horizontal 'both)) +(gnome-app-set-toolbar (frame-property nil 'shell-widget) x) + +(mapc (lambda (descr) + (gtk-toolbar-append-item x + (aref descr 0) + (aref descr 1) + "" + (gnome-stock-pixmap-widget-new x (aref descr 2)) + `(lambda (&rest ignored) + (,(aref descr 3))))) + gnomeified-toolbar) diff --git a/tests/gtk/xemacs-toolbar.el b/tests/gtk/xemacs-toolbar.el new file mode 100644 index 0000000..eef5265 --- /dev/null +++ b/tests/gtk/xemacs-toolbar.el @@ -0,0 +1,21 @@ +(defvar gtk-torture-test-toolbar-open-active-p t) + +(defvar gtk-torture-test-toolbar + '([toolbar-file-icon + (lambda () + (setq gtk-torture-test-toolbar-open-active-p (not gtk-torture-test-toolbar-open-active-p))) + gtk-torture-test-toolbar-open-active-p + "Dynamic enabled-p slot... broken in XEmacs 21.1.x"] + [:size 35 :style 3d] + [toolbar-folder-icon toolbar-dired t "Edit a directory"] + [:size 35 :style 2d] + [toolbar-news-icon toolbar-news t "Read news"] + nil + [toolbar-info-icon toolbar-info t "Info documentation"] + )) + +(defun gtk-torture-test-toolbar () + (interactive) + (switch-to-buffer (get-buffer-create "Toolbar testing")) + (set-specifier default-toolbar gtk-torture-test-toolbar (current-buffer)) + (set-specifier default-toolbar-visible-p t (current-buffer)))