Mercurial > emacs
changeset 83078:fac24544c283
Merged in changes from CVS HEAD
Patches applied:
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-146
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-147
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-148
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-149
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-150
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-151
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-152
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-153
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-154
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-155
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-156
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-157
Update from CVS
* miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-158
Update from CVS
git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-118
| author | Karoly Lorentey <lorentey@elte.hu> |
|---|---|
| date | Tue, 16 Mar 2004 20:27:22 +0000 |
| parents | 40fd42596e17 (current diff) b8704d6a3c6f (diff) |
| children | 5f17f5c40152 |
| files | ChangeLog lisp/ChangeLog lisp/emacs-lisp/bytecomp.el lisp/server.el lisp/smerge-mode.el lisp/vc-hooks.el lisp/vc.el src/Makefile.in src/dispextern.h src/emacs.c src/lisp.h src/macterm.c src/macterm.h src/xfns.c src/xterm.h |
| diffstat | 50 files changed, 10137 insertions(+), 19045 deletions(-) [+] |
line wrap: on
line diff
--- a/ChangeLog Thu Mar 11 02:31:12 2004 +0000 +++ b/ChangeLog Tue Mar 16 20:27:22 2004 +0000 @@ -1,3 +1,7 @@ +2004-03-15 Luc Teirlinck <teirllm@auburn.edu> + + * info/dir (File): Add SMTP and SES. + 2004-03-02 Stefan Monnier <monnier@iro.umontreal.ca> * Makefile.in (maintainer-clean): Clean in the lisp dir as well.
--- a/etc/NEWS Thu Mar 11 02:31:12 2004 +0000 +++ b/etc/NEWS Tue Mar 16 20:27:22 2004 +0000 @@ -88,6 +88,22 @@ * Changes in Emacs 21.4 +** M-x compile has been completely overhauled + +It now uses font-lock for turning compiler output into hypertext. Quite a few +more kinds of messages are recognized. Messages that are recognized as +warnings or informational come in orange or green, instead of red. +Informational messages are by default skipped with `next-error'. + +The new file etc/compilation.txt gives examples of each type of message. + +** M-x grep has been adapted to new compile + +Hits are fontified in green, and hits in binary files in orange. Grep buffers +can be saved and will again be loaded with the new `grep-mode'. + +** M-x diff uses diff-mode instead of compilation-mode. + --- ** The saveplace.el package now filters out unreadable files. When you exit Emacs, the saved positions in visited files no longer @@ -97,6 +113,13 @@ and `save-place-skip-check-regexp' allow further fine-tuning of this feature. +** You can have several Emacs servers on the same machine. + + % emacs --eval '(setq server-name "foo")' -f server-start & + % emacs --eval '(setq server-name "bar")' -f server-start & + % emacsclient -s foo file1 + % emacsclient -s bar file2 + ** On window systems, lines which are exactly as wide as the window (not counting the final newline character) are no longer broken into two lines on the display (with just the newline on the second line).
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/compilation.txt Tue Mar 16 20:27:22 2004 +0000 @@ -0,0 +1,342 @@ +* Introduction -*-compilation-*- + +This shows the different kinds of messages compile recognizes by default and +how they are rendered. It is intended both to help you decide which matchers +you need and as a test of the matchers. Move the mouse over a colored part or +use `compilation-message-face', to see how much text was actually matched. + +The important part is the symbol(s) line at the beginning of each entry. +These are the symbols you can customize `compilation-error-regexp-alist' for, +to match the messages shown in that entry. A few complex cases have more than +one symbol, which should be selected together. + + +* Absoft FORTRAN 77 Compiler 3.1.3 + +symbol: absoft + +Error on line 3 of t.f: Execution error unclassifiable statement +Line 45 of "foo.c": bloofle undefined +error on line 19 of fplot.f: spelling error? +warning on line 17 of fplot.f: data type is undefined for variable d + + +* Ada & Mpatrol (memory leak debugger) + +symbol: ada + +This matches only the end of line, the beginning is covered by GNU style. + +foo.adb:61:11: [...] in call to size declared at foo.ads:11 + 0x8008621 main+16 at error.c:17 + + +* IBM AIX PS/2 C version 1.1 + +symbol: aix + +****** Error number 140 in line 8 of file errors.c ****** + + +* Ant Java: works at least for jikes and javac + +symbol: ant + +The regexps found on http://ant.apache.org/faq.html, and since integrated in +both Emacsen, were hairy. Why so many numbers for jikes -- is one a column +number? + + [javac] /src/DataBaseTestCase.java:27: unreported exception ... + [javac] /src/DataBaseTestCase.java:49: warning: finally clause cannot complete normally + [jikes] foo.java:3:5:7:9: blah blah + + +* Bash v2 + +symbol: bash + +a.sh: line 1: ls-l: command not found + + +* Borland C++, C++Builder + +symbol: borland + +Error ping.c 15: Unable to open include file 'sys/types.h' +Warning ping.c 68: Call to function 'func' with no prototype +Error E2010 ping.c 15: Unable to open include file 'sys/types.h' +Warning W1022 ping.c 68: Call to function 'func' with no prototype + + +* Caml & Python + +symbol: caml + +File "foobar.ml", lines 5-8, characters 20-155: blah blah +File "F:\ocaml\sorting.ml", line 65, characters 2-145: +Warning: this expression should have type unit. + File "/usr/share/gdesklets/display/TargetGauge.py", line 41, in add_children + + +* Apollo cc, 4.3BSD fc & IBM RS6000/AIX xlc compiler & Microtec mcc68k & GNAT (July 94) + +symbol: comma + +"foo.f", line 3: Error: syntax error near end of statement +"vvouch.c", line 19.5: 1506-046 (S) Syntax error. +"foo.c", line 32 pos 1; (E) syntax error; unexpected symbol: "lossage" +"foo.adb", line 2(11): warning: file name does not match ... +"src/swapping.c", line 30.34: 1506-342 (W) "/*" detected in comment. + + +* EPC F90 compiler + +symbol: epc + +Error 24 at (2:progran.f90) : syntax error + + +* IAR Systems C Compiler + +symbol: iar + +"foo.c",3 Error[32]: Error message +"foo.c",3 Warning[32]: Error message + + +* IBM C/C++ Tools 2.01 + +symbol: ibm + +foo.c(2:0) : informational EDC0804: Function foo is not referenced. +foo.c(3:8) : warning EDC0833: Implicit return statement encountered. +foo.c(5:5) : error EDC0350: Syntax error. + + +* Ultrix MIPS RISC CC & DEC AXP OSF/1 cc & IRIX 5.2 + +symbol: irix + +ccom: Error: foo.c, line 2: syntax error +cfe: Warning 712: foo.c, line 2: illegal combination of pointer and ... +cfe: Warning 600: xfe.c: 170: Not in a conditional directive while ... +/usr/lib/cmplrs/cc/cfe: Error: foo.c: 1: blah blah +/usr/lib/cmplrs/cc/cfe: warning: foo.c: 1: blah blah + + +* Java Exception & Valgrind (memory debugger for x86 GNU/Linux) + +symbol: java + +Register 6 contains wrong type + at org.foo.ComponentGateway.doGet(ComponentGateway.java:172) + at javax.servlet.http.HttpServlet.service(HttpServlet.java:740) +==1332== Invalid write of size 1 +==1332== at 0x4040743C: System::getErrorString() (../src/Lib/System.cpp:217) +==1332== by 0x8008621: main (vtest.c:180) + + +* IBM jikes + +symbols: jikes-file jikes-line + +Jikes separates file names from the actual error messages. For visual +feedback the underline and the word "Error" on the 3rd line is fontified like +a file name would be. + +Found 2 semantic errors compiling "../javax/swing/BorderFactory.java": + + 150. case '{': + <-> +*** Error: The type of this expression, "char", is not ... + + 312. return new CompoundBorder(outside, inside); + <---------------------------------> +*** Error: No match was found for constructor ... + +Issued 1 semantic warning compiling "java/awt/Toolkit.java": + + 504. void imgProduceImage( ImageNativeProducer prod, Ptr imgData); + <-----------------> +*** Warning: The type "ImageNativeProducer" is defined ... + + +* GCC include message + +symbol: gcc-include + +The last file, i.e. the one you are compiling, is the interesting one. + +In file included from /usr/include/c++/3.3/backward/warn.h:4, + from /usr/include/c++/3.3/backward/iostream.h:31, + from test_clt.cc:1: + + +* GNU style + +symbol: gnu + +foo.c:8: message +../foo.c:8: W: message +/tmp/foo.c:8:warning message +foo/bar.py:8: FutureWarning message +foo.py:8: RuntimeWarning message +foo.c:8:I: message +foo.c:8.23: info: message +foo.c:8:23:information: message +foo.c:8.23-45: Informational: message +foo.c:8-23: message +foo.c:8-45.3: message +foo.c:8.23-9.1: message +jade:dbcommon.dsl:133:17:E: missing argument for function call +G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found. +file:G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found. + + +* Lucid Compiler, lcc 3.x + +symbol: lcc + +E, file.cc(35,52) Illegal operation on pointers +W, file.cc(36,52) blah blah + + +* makepp 1.20 + +symbol: makepp + +makepp: Scanning `/foo/bar.c' +makepp: warning: bla bla `/foo/bar.c' and `/foo/bar.h' +makepp: bla bla `/foo/Makeppfile:12' bla +makepp: bla bla `/foo/bar.c' and `/foo/bar.h' + + +* MIPS lint; looks good for SunPro lint also + +symbols: mips-1 mips-2 + +This can match multiple times on a line. + +TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomon.c due to truncation +name defined but never used: LinInt in cmap_calc.c(199) + + +* Microsoft C/C++ + +symbol: msft + +This used to be less selective and allowed characters other than parens around +the line number, but that caused confusion for GNU-style error messages. This +used to reject spaces and dashes in file names, but they are valid now; so I +made it more strict about the error message that follows. + +keyboard handler.c(537) : warning C4005: 'min' : macro redefinition +d:\tmp\test.c(23) : error C2143: syntax error : missing ';' before 'if' + + +* Oracle pro*c + +symbol: oracle + +Semantic error at line 528, column 5, file erosacqdb.pc: + + +* Perl + +symbol: perl + +syntax error at automake line 922, near "':'" +Died at test.pl line 27. +store::odrecall('File_A', 'x2') called at store.pm line 90 + + +* RXP + +symbol: rxp + +GPL XML validator at http://www.cogsci.ed.ac.uk/~richard/rxp.html + +Error: Mismatched end tag: expected </geroup>, got </group> +in unnamed entity at line 71 char 8 of file:///home/reto/test/group.xml +Warning: Start tag for undeclared element geroup +in unnamed entity at line 4 char 8 of file:///home/reto/test/group.xml + + +* Sparc Pascal + +symbols: sparc-pascal-file sparc-pascal-line sparc-pascal-example + +These messages don't contain a file name. Instead the compiler gives a +message whenever the file being compiled is changed. For visual feedback the +error code is fontified like a file name would be. + +Thu May 14 10:46:12 1992 mom3.p: + 20 linjer : array[1..4] of linje; +w 18480-----------^--- Inserted ';' + 20 linjer : array[1..4] of linje; +e 18480-----------^--- Inserted ';' +w 18520 line 61 - 0 is undefined +E 18520 line 61 - 0 is undefined + + +* SGI IRIX MipsPro 7.3 & Sun F90 & Cray C + +symbol: sun + +cc-1020 CC: REMARK File = CUI_App.h, Line = 735 +cc-1070 cc: WARNING File = linkl.c, Line = 38 +cf90-113 f90comp: ERROR NSE, File = Hoved.f90, Line = 16, Column = 3 + + +* Sun Ada (VADS, Solaris) + +symbol: sun-ada + +/home3/xdhar/rcds_rc/main.a, line 361, char 6:syntax error: "," inserted + + +* Ultrix 3.0 f77 & Some SGI cc version + +symbol: ultrix + +fort: Severe: addstf.f, line 82: Missing operator or delimiter symbol +cfe: Warning 835: foo.c, line 2: something + + +* 4.3BSD grep, cc, lint + +symbol: 4bsd + +/usr/src/foo/foo.c(8): warning: w may be used before set +/usr/src/foo/foo.c(9): error: w is used before set +strcmp: variable # of args. llib-lc(359) :: /usr/src/foo/foo.c(8) +bloofle defined( /users/wolfgang/foo.c(4) ), but never used + + +* Directory tracking + +Directories are matched via `compilation-directory-matcher'. Files which are +not shown as full paths are searched for relative to the directory where the +message was issued. + +Entering directory `/a/b/c' +Leaving directory `/a/b/c' +gmake[2]: Entering directory `/a/b/c' +makepp: Leaving directory `/a/b/c' + + +* Miscellaneous + +These are not messages that can be gone to. They are only highlighted via +`compilation-mode-font-lock-keywords' to recognize some useful information at +a glance. + +checking dynamic linker characteristics... GNU/Linux ld.so +checking if libtool supports shared libraries... yes +checking whether to build shared libraries... yes +checking whether -lc should be explicitly linked in... (cached) no +checking For GLIB - version >= 2.0.0... yes (version 2.1.0) +checking FONTCONFIG_CFLAGS... +g++ -o foo.o foo.cc +tool1 -output=foo foo.x +tool2 --outfile foo foo.y
--- a/lisp/ChangeLog Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/ChangeLog Tue Mar 16 20:27:22 2004 +0000 @@ -1,3 +1,176 @@ +2004-03-15 Masatake YAMATO <jet@gyve.org> + + Added context menu support in smerge mode. + Most of the part is written by Stefan Monnier. + + * smerge-mode.el (smerge-context-menu-map, smerge-context-menu): + New keymap and menu. + (smerge-text-properties): New function. + (smerge-remove-props): New function. + (smerge-popup-context-menu): New function. + (smerge-resolve): Call `smerge-remove-props'. + (smerge-keep-base, smerge-keep-other, smerge-keep-mine): Ditto. + (smerge-keep-current): Ditto. + (smerge-kill-current): New function. + (smerge-match-conflict): Put text properties. + Detect the file as `same-diff conflict' if the filename is "ANCESTOR". + +2004-03-15 David Ponce <david@dponce.com> + + * ruler-mode.el: (ruler-mode-left-fringe-cols) + (ruler-mode-right-fringe-cols, ruler-mode-left-scroll-bar-cols) + (ruler-mode-right-scroll-bar-cols): Remove. + (ruler-mode-window-col, ruler-mode-mouse-set-left-margin) + (ruler-mode-mouse-set-right-margin, ruler-mode-ruler): + Use fringe-columns and scroll-bar-columns. + +2004-03-15 Masatake YAMATO <jet@gyve.org> + + * hl-line.el (hl-line-range-function): New variable. + (hl-line-move): New function. + (global-hl-line-highlight): Use `hl-line-move'. + (hl-line-highlight): Ditto. + + * scroll-bar.el (scroll-bar-columns): + * fringe.el (fringe-columns): New function derived from ruler-mode.el. + + * ruler-mode.el (top-level): Require scroll-bar and fringe. + (ruler-mode-left-fringe-cols) + (ruler-mode-right-fringe-cols): Use `fringe-columns'. + (ruler-mode-right-scroll-bar-cols) + (ruler-mode-left-scroll-bar-cols): Use `scroll-bar-columns'. + (ruler-mode-ruler-function): New variable. + (ruler-mode-header-line-format): Call `ruler-mode-ruler-function' + if the value for `ruler-mode-ruler-function'is given. + + * hexl.el (hexl-mode-hook): Make the hook customizable. + (hexl-address-area, hexl-ascii-area): New customize variables. + (hexlify-buffer): Put font-lock-faces on the address area and + the ascii area. + (hexl-activate-ruler): New function. + (hexl-follow-line): New function. + (hexl-highlight-line-range): New function. + (hexl-mode-ruler): New function. + +2004-03-14 Stefan Monnier <monnier@iro.umontreal.ca> + + * vc-hooks.el (vc-handled-backends): Add Arch. Move MCVS down. + (vc-default-find-file-hook): New fun. + (vc-find-file-hook): Call new find-file-hook operation. + + * vc-arch.el: New file. + +2004-03-12 Jesper Harder <harder@ifa.au.dk> + + * info-look.el (info-lookup): Reuse an existing Info window. + +2004-03-12 Francis J. Wright <F.J.Wright@qmul.ac.uk> + + * woman.el (woman-preserve-ascii): Default value changed to t and + doc string revised. + +2004-03-12 Richard M. Stallman <rms@gnu.org> + + * pcvs.el (cvs-mode-add-change-log-entry-other-window): + Fix minor bug. + + * replace.el (occur-engine): Change message for count of matches. + + * emacs-lisp/bytecomp.el (byte-compile-get-constant): + For strings, do compare text properties. + +2004-03-11 Daniel Pfeiffer <occitan@esperanto.org> + + * progmodes/compile.el (compile-auto-highlight) + (compilation-error-list, compilation-old-error-list) + (compilation-parse-errors-function, compilation-parsing-end) + (compilation-error-message, compilation-directory-stack) + (compilation-enter-directory-regexp-alist) + (compilation-leave-directory-regexp-alist) + (compilation-file-regexp-alist, compilation-nomessage-regexp-alist) + (compilation-current-file, compilation-regexps): Remove vars. + + (compile-error-at-point, compilation-error-filedata) + (compilation-error-filedata-file-name, compile-reinitialize-errors) + (compilation-next-error-locus, compilation-forget-errors) + (count-regexp-groupings, compilation-parse-errors) + (compile-collect-regexps, compile-buffer-substring): Remove funs. + + (compile-internal): Make obsolete. + + (compilation-first-column, compilation-error) + (compilation-directory-matcher, compilation-page-delimiter) + (compilation-mode-font-lock-keywords, compilation-debug) + (compilation-error-face, compilation-warning-face) + (compilation-info-face, compilation-line-face) + (compilation-column-face, compilation-enter-directory-face) + (compilation-leave-directory-face, compilation-skip-threshold) + (compilation-skip-visited, compilation-context-lines): New vars. + + (compilation-warning-face, compilation-info-face) + (compilation-message-face): New faces. + + (compilation-error-regexp-alist-alist): New constant. + + (compilation-face, compilation-directory-properties) + (compilation-assq, compilation-error-properties, compilation-start) + (define-compilation-mode, compilation-loop) + (compilation-set-window): New functions. + + (compile): Additional argument for interactive compiles like TeX. + + * progmodes/grep.el (kill-grep): Move here from compile.el + (grep-error, grep-hit-face, grep-error-face) + (grep-mode-font-lock-keywords): New variables. + (grep-regexp-alist): Simplify regexp and add `binary' case. + (grep-mode): New mode. + (grep-process-setup): Simplify. + +2004-03-11 Jason Rumney <jasonr@gnu.org> + + * net/ldap.el (ldap-search-internal): Handle file URLs with drive + letters on DOS/Windows. + +2004-03-11 Stefan Monnier <monnier@iro.umontreal.ca> + + * server.el (server-name): New var. + (server-socket-dir): New var to replace server-socket-name. + (server-start): Use them. + +2004-03-11 Simon Josefsson <jas@extundo.com> + + * mail/smtpmail.el (smtpmail-read-response): Abort if process has + died to avoid infloop. Reported by Jonathan Glauner + <jglauner@sbum.org>. + +2004-03-10 Stefan Monnier <monnier@iro.umontreal.ca> + + * smerge-mode.el (smerge-check-cache, smerge-check): New var and fun. + (smerge-mode-menu): Use it to deactivate menu entries. + (smerge-keep-current): New fun. + (smerge-keep-current): Use it. + +2004-03-10 John Paul Wallington <jpw@gnu.org> + + * foldout.el (foldout-fold-list, foldout-modeline-string): + Declare them as variables, not constants. + +2004-03-10 Vinicius Jose Latorre <viniciusjl@ig.com.br> + + * ps-print.el: Modification to print *Messages* buffer. + (ps-print-version): New version 6.6.4. + (ps-message-log-max): New fun. + (ps-spool-without-faces, ps-spool-with-faces) + (ps-count-lines-preprint): Code fix. + + * printing.el: New tips in Tips section. + +2004-03-09 Vinicius Jose Latorre <viniciusjl@ig.com.br> + + * delim-col.el: Doc fix. + + * printing.el: Doc fix. New doc section (Tips). + 2004-03-09 Stefan Monnier <monnier@iro.umontreal.ca> * type-break.el (type-break-emacs-variant): Remove. @@ -17,6 +190,11 @@ 2004-03-07 Stefan Monnier <monnier@iro.umontreal.ca> + * newcomment.el (comment-use-global-state): New var. + (comment-search-forward): Use it. + + * emacs-lisp/lisp-mode.el (lisp-mode-variables): Set it. + * cus-edit.el (fill) <defgroup>: Move to fill.el. * textmodes/fill.el (fill) <defgroup>: Move from cus-edit.el.
--- a/lisp/delim-col.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/delim-col.el Tue Mar 16 20:27:22 2004 +0000 @@ -2,9 +2,9 @@ ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br> -;; Maintainer: Vinicius Jose Latorre <vinicius@cpqd.com.br> -;; Time-stamp: <2001-10-13 10:02:26 pavel> +;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Time-stamp: <2004/03/09 21:32:06 vinicius> ;; Version: 2.1 ;; Keywords: internal ;; X-URL: http://www.cpqd.com.br/~vinicius/emacs/
--- a/lisp/emacs-lisp/bytecomp.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/emacs-lisp/bytecomp.el Tue Mar 16 20:27:22 2004 +0000 @@ -10,7 +10,7 @@ ;;; This version incorporates changes up to version 2.10 of the ;;; Zawinski-Furuseth compiler. -(defconst byte-compile-version "$Revision: 2.142 $") +(defconst byte-compile-version "$Revision: 2.143 $") ;; This file is part of GNU Emacs. @@ -2776,7 +2776,8 @@ (defmacro byte-compile-get-constant (const) `(or (if (stringp ,const) - (assoc ,const byte-compile-constants) + (assoc-default ,const byte-compile-constants + 'equal-including-properties nil) (assq ,const byte-compile-constants)) (car (setq byte-compile-constants (cons (list ,const) byte-compile-constants)))))
--- a/lisp/foldout.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/foldout.el Tue Mar 16 20:27:22 2004 +0000 @@ -214,12 +214,12 @@ (if (not (boundp 'outline-minor-mode)) (error "Can't find outline-minor-mode")) -(defconst foldout-fold-list nil +(defvar foldout-fold-list nil "List of start and end markers for the folds currently entered. An end marker of nil means the fold ends after (point-max).") (make-variable-buffer-local 'foldout-fold-list) -(defconst foldout-modeline-string nil +(defvar foldout-modeline-string nil "Modeline string announcing that we are in an outline fold.") (make-variable-buffer-local 'foldout-modeline-string)
--- a/lisp/fringe.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/fringe.el Tue Mar 16 20:27:22 2004 +0000 @@ -218,6 +218,17 @@ (list (cons 'left-fringe (if (consp mode) (car mode) mode)) (cons 'right-fringe (if (consp mode) (cdr mode) mode))))) +(defsubst fringe-columns (side &optional real) + "Return the width, measured in columns, of the fringe area on SIDE. +If optional argument REAL is non-nil, return a real floating point +number instead of a rounded integer value. +SIDE must be the symbol `left' or `right'." + (funcall (if real '/ 'ceiling) + (or (funcall (if (eq side 'left) 'car 'cadr) + (window-fringes)) + 0) + (float (frame-char-width)))) + (provide 'fringe) ;;; arch-tag: 6611ef60-0869-47ed-8b93-587ee7d3ff5d
--- a/lisp/hexl.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/hexl.el Tue Mar 16 20:27:22 2004 +0000 @@ -78,6 +78,22 @@ :group 'hexl :version "20.3") +(defcustom hexl-mode-hook '(hexl-follow-line hexl-activate-ruler) + "Normal hook run when entering Hexl mode." + :type 'hook + :options '(hexl-follow-line hexl-activate-ruler turn-on-eldoc-mode) + :group 'hexl) + +(defface hexl-address-area + '((t (:inherit header-line))) + "Face used in address are of hexl-mode buffer." + :group 'hexl) + +(defface hexl-ascii-area + '((t (:inherit header-line))) + "Face used in ascii are of hexl-mode buffer." + :group 'hexl) + (defvar hexl-max-address 0 "Maximum offset into hexl buffer.") @@ -648,6 +664,15 @@ (apply 'call-process-region (point-min) (point-max) (expand-file-name hexl-program exec-directory) t t nil (split-string hexl-options)) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^[0-9a-f]+:" nil t) + (put-text-property (match-beginning 0) (match-end 0) + 'font-lock-face 'hexl-address-area)) + (goto-char (point-min)) + (while (re-search-forward " \\(.+$\\)" nil t) + (put-text-property (match-beginning 1) (match-end 1) + 'font-lock-face 'hexl-ascii-area))) (if (> (point) (hexl-address-to-marker hexl-max-address)) (hexl-goto-address hexl-max-address)))) @@ -865,6 +890,32 @@ (remove-hook 'post-command-hook 'hexl-follow-ascii-find t) ))))) +(defun hexl-activate-ruler () + "Activate `ruler-mode'" + (require 'ruler-mode) + (set (make-local-variable 'ruler-mode-ruler-function) + 'hexl-mode-ruler) + (ruler-mode 1)) + +(defun hexl-follow-line () + "Activate `hl-line-mode'" + (require 'frame) + (require 'fringe) + (require 'hl-line) + (set (make-local-variable 'hl-line-range-function) + 'hexl-highlight-line-range) + (set (make-local-variable 'hl-line-face) + 'highlight) + (hl-line-mode 1)) + +(defun hexl-highlight-line-range () + "Return the range of address area for the point. +This function is assumed to be used as call back function for `hl-line-mode'." + (cons + (line-beginning-position) + ;; 9 stands for (length "87654321:") + (+ (line-beginning-position) 9))) + (defun hexl-follow-ascii-find () "Find and highlight the ASCII element corresponding to current point." (let ((pos (+ 51 @@ -873,6 +924,37 @@ (move-overlay hexl-ascii-overlay pos (1+ pos)) )) +(defun hexl-mode-ruler () + "Return a string ruler for hexl mode." + (let* ((highlight (mod (hexl-current-address) 16)) + (s "87654321 0011 2233 4455 6677 8899 aabb ccdd eeff 0123456789abcdef") + (pos 0) + (spaces (+ (scroll-bar-columns 'left) + (fringe-columns 'left) + (or (car (window-margins)) 0)))) + (set-text-properties 0 (length s) nil s) + ;; Turn spaces in the header into stretch specs so they work + ;; regardless of the header-line face. + (while (string-match "[ \t]+" s pos) + (setq pos (match-end 0)) + (put-text-property (match-beginning 0) pos 'display + ;; Assume fixed-size chars + `(space :align-to (+ (scroll-bar . left) + left-fringe left-margin + ,pos)) + s)) + ;; Highlight the current column. + (put-text-property (+ 10 (/ (* 5 highlight) 2)) + (+ 12 (/ (* 5 highlight) 2)) + 'face 'highlight s) + ;; Highlight the current ascii column + (put-text-property (+ 12 39 highlight) (+ 12 40 highlight) + 'face 'highlight s) + ;; Add the leading space. + (concat (propertize (make-string (floor spaces) ? ) + 'display `(space :width ,spaces)) + s))) + ;; startup stuff. (if hexl-mode-map
--- a/lisp/hl-line.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/hl-line.el Tue Mar 16 20:27:22 2004 +0000 @@ -57,6 +57,10 @@ ;; it to nil to avoid highlighting specific buffers, when the global ;; mode is used. +;; In default whole the line is highlighted. The range of highlighting +;; can be changed by defining an appropriate function as the +;; buffer-local value of `hl-line-range-function'. + ;;; Code: (defgroup hl-line nil @@ -78,6 +82,15 @@ :version "21.4" :group 'hl-line) +(defvar hl-line-range-function nil + "If non-nil, function to call to return highlight range. +The function of no args should return a cons cell; its car value +is the beginning position of highlight and its cdr value is the +end position of highlight in the buffer. +It should return nil if there's no region to be highlighted. + +This variable is expected to be made buffer-local by modes.") + (defvar hl-line-overlay nil "Overlay used by Hl-Line mode to highlight the current line.") (make-variable-buffer-local 'hl-line-overlay) @@ -124,8 +137,7 @@ (overlay-put hl-line-overlay 'face hl-line-face)) (overlay-put hl-line-overlay 'window (unless hl-line-sticky-flag (selected-window))) - (move-overlay hl-line-overlay - (line-beginning-position) (line-beginning-position 2))) + (hl-line-move hl-line-overlay)) (hl-line-unhighlight))) (defun hl-line-unhighlight () @@ -158,14 +170,30 @@ (setq global-hl-line-overlay (make-overlay 1 1)) ; to be moved (overlay-put global-hl-line-overlay 'face hl-line-face)) (overlay-put global-hl-line-overlay 'window (selected-window)) - (move-overlay global-hl-line-overlay - (line-beginning-position) (line-beginning-position 2))))) + (hl-line-move global-hl-line-overlay)))) (defun global-hl-line-unhighlight () "Deactivate the Global-Hl-Line overlay on the current line." (if global-hl-line-overlay (delete-overlay global-hl-line-overlay))) +(defun hl-line-move (overlay) + "Move the hl-line-mode overlay. +If `hl-line-range-function' is non-nil, move the OVERLAY to the position +where the function returns. If `hl-line-range-function' is nil, fill +the line including the point by OVERLAY." + (let (tmp b e) + (if hl-line-range-function + (setq tmp (funcall hl-line-range-function) + b (car tmp) + e (cdr tmp)) + (setq tmp t + b (line-beginning-position) + e (line-beginning-position 2))) + (if tmp + (move-overlay overlay b e) + (move-overlay overlay 1 1)))) + (provide 'hl-line) ;;; arch-tag: ac806940-0876-4959-8c89-947563ee2833
--- a/lisp/info-look.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/info-look.el Tue Mar 16 20:27:22 2004 +0000 @@ -338,7 +338,8 @@ (info-frame (and window (window-frame window)))) (if (and info-frame (display-multi-frame-p) - (memq info-frame (frames-on-display-list))) + (memq info-frame (frames-on-display-list)) + (not (eq info-frame (selected-frame)))) (select-frame info-frame) (switch-to-buffer-other-window "*info*"))))) (while (and (not found) modes)
--- a/lisp/mail/smtpmail.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/mail/smtpmail.el Tue Mar 16 20:27:22 2004 +0000 @@ -1,6 +1,6 @@ ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -;; Copyright (C) 1995, 1996, 2001, 2002, 2003 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp> ;; Maintainer: Simon Josefsson <simon@josefsson.org> @@ -778,49 +778,49 @@ (response-continue t) (return-value '(nil ())) match-end) + (catch 'done + (while response-continue + (goto-char smtpmail-read-point) + (while (not (search-forward "\r\n" nil t)) + (unless (memq (process-status process) '(open run)) + (throw 'done nil)) + (accept-process-output process) + (goto-char smtpmail-read-point)) - (while response-continue - (goto-char smtpmail-read-point) - (while (not (search-forward "\r\n" nil t)) - (accept-process-output process) - (goto-char smtpmail-read-point)) - - (setq match-end (point)) - (setq response-strings - (cons (buffer-substring smtpmail-read-point (- match-end 2)) - response-strings)) + (setq match-end (point)) + (setq response-strings + (cons (buffer-substring smtpmail-read-point (- match-end 2)) + response-strings)) - (goto-char smtpmail-read-point) - (if (looking-at "[0-9]+ ") - (let ((begin (match-beginning 0)) - (end (match-end 0))) - (if smtpmail-debug-info - (message "%s" (car response-strings))) + (goto-char smtpmail-read-point) + (if (looking-at "[0-9]+ ") + (let ((begin (match-beginning 0)) + (end (match-end 0))) + (if smtpmail-debug-info + (message "%s" (car response-strings))) + + (setq smtpmail-read-point match-end) - (setq smtpmail-read-point match-end) + ;; ignore lines that start with "0" + (if (looking-at "0[0-9]+ ") + nil + (setq response-continue nil) + (setq return-value + (cons (string-to-int + (buffer-substring begin end)) + (nreverse response-strings))))) - ;; ignore lines that start with "0" - (if (looking-at "0[0-9]+ ") - nil + (if (looking-at "[0-9]+-") + (progn (if smtpmail-debug-info + (message "%s" (car response-strings))) + (setq smtpmail-read-point match-end) + (setq response-continue t)) + (progn + (setq smtpmail-read-point match-end) (setq response-continue nil) (setq return-value - (cons (string-to-int - (buffer-substring begin end)) - (nreverse response-strings))))) - - (if (looking-at "[0-9]+-") - (progn (if smtpmail-debug-info - (message "%s" (car response-strings))) - (setq smtpmail-read-point match-end) - (setq response-continue t)) - (progn - (setq smtpmail-read-point match-end) - (setq response-continue nil) - (setq return-value - (cons nil (nreverse response-strings))) - ) - ))) - (setq smtpmail-read-point match-end) + (cons nil (nreverse response-strings))))))) + (setq smtpmail-read-point match-end)) return-value))
--- a/lisp/net/ldap.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/net/ldap.el Tue Mar 16 20:27:22 2004 +0000 @@ -582,6 +582,11 @@ (while (looking-at "^\\(\\w*\\)[=:\t ]+\\(<[\t ]*file://\\)?\\(.*\\)$") (setq name (match-string 1) value (match-string 3)) + ;; Need to handle file:///D:/... as generated by OpenLDAP + ;; on DOS/Windows as local files. + (if (and (memq system-type '(windows-nt ms-dos)) + (eq (string-match "/\\(.:.*\\)$" value) 0)) + (setq value (match-string 1 value))) ;; Do not try to open non-existent files (if (equal value "") (setq value " ")
--- a/lisp/pcvs.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/pcvs.el Tue Mar 16 20:27:22 2004 +0000 @@ -2115,8 +2115,8 @@ "Add a ChangeLog entry in the ChangeLog of the current directory." (interactive) (dolist (fi (cvs-mode-marked nil nil)) - (let ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi))) - (buffer-file-name (expand-file-name (cvs-fileinfo->file fi)))) + (let* ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi))) + (buffer-file-name (expand-file-name (cvs-fileinfo->file fi)))) (kill-local-variable 'change-log-default-name) (save-excursion (add-change-log-entry-other-window)))))
--- a/lisp/printing.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/printing.el Tue Mar 16 20:27:22 2004 +0000 @@ -5,7 +5,7 @@ ;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br> ;; Maintainer: Vinicius Jose Latorre <vinicius@cpqd.com.br> -;; Time-stamp: <2004/02/29 23:18:15 vinicius> +;; Time-stamp: <2004/03/10 20:37:21 vinicius> ;; Keywords: wp, print, PostScript ;; Version: 6.7.2 ;; X-URL: http://www.cpqd.com.br/~vinicius/emacs/ @@ -166,6 +166,27 @@ ;; printer doesn't have duplex feature; otherwise, it's ok, your ;; printer does have duplex feature. ;; +;; NOTE 4: See Tips section. +;; +;; +;; Tips +;; ---- +;; +;; 1. If your have a local printer, that is, a printer which is connected +;; directly to your computer, don't forget to connect the printer to your +;; computer before printing. +;; +;; 2. If you try to print a file and it seems that the file was printed, but +;; there is no paper in the printer, then try to set `pr-delete-temp-file' +;; to nil. Probably `printing' is deleting the temporary file before your +;; local system can get it to send to the printer. +;; +;; 3. Don't try to print a dynamic buffer, that is, a buffer which is +;; modifying while `printing' tries to print. Eventually you got an error +;; message. Instead, save the dynamic buffer to a file or copy it in +;; another buffer and, then, print the file or the new static buffer. +;; An example of dynamic buffer is the *Messages* buffer. +;; ;; ;; Using `printing' ;; ---------------- @@ -840,8 +861,8 @@ ;; Acknowledgments ;; --------------- ;; -;; Thanks to Drew Adams <?@?> for directory processing and `pr-path-alist' -;; suggestions. +;; Thanks to Drew Adams <drew.adams@oracle.com> for directory processing and +;; `pr-path-alist' suggestions. ;; ;; Thanks to Fred Labrosse <f.labrosse@maths.bath.ac.uk> for XEmacs tests. ;;
--- a/lisp/progmodes/compile.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/progmodes/compile.el Tue Mar 16 20:27:22 2004 +0000 @@ -1,9 +1,10 @@ ;;; compile.el --- run compiler as inferior of Emacs, parse error messages -;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 1999, 2001, 2003 +;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 1999, 2001, 03, 2004 ;; Free Software Foundation, Inc. -;; Author: Roland McGrath <roland@gnu.org> +;; Authors: Roland McGrath <roland@gnu.org>, +;; Daniel Pfeiffer <occitan@esperanto.org> ;; Maintainer: FSF ;; Keywords: tools, processes @@ -26,11 +27,51 @@ ;;; Commentary: -;; This package provides the compile and grep facilities documented in -;; the Emacs user's manual. +;; This package provides the compile facilities documented in the Emacs user's +;; manual. ;;; Code: +;; This is the parsing engine for compile: +(require 'font-lock) ; needed to get font-lock-value-in-major-mode + +;;; This mode uses some complex data-structures: + +;;; LOC (or location) is a list of (COLUMN LINE FILE-STRUCTURE) + +;; COLUMN and LINE are numbers parsed from an error message. COLUMN and maybe +;; LINE will be nil for a message that doesn't contain them. Then the +;; location refers to a indented beginning of line or beginning of file. +;; Once any location in some file has been jumped to, the list is extended to +;; (COLUMN LINE FILE-STRUCTURE MARKER . VISITED) for all LOCs pertaining to +;; that file. +;; MARKER initially points to LINE and COLUMN in a buffer visiting that file. +;; Being a marker it sticks to some text, when the buffer grows or shrinks +;; before that point. VISITED is t if we have jumped there, else nil. + +;;; FILE-STRUCTURE is a list of ((FILENAME . DIRECTORY) FORMATS (LINE LOC ...) +;;; ...) + +;; FILENAME is a string parsed from an error message. DIRECTORY is a string +;; obtained by following directory change messages. DIRECTORY will be nil for +;; an absolute filename. FORMATS is a list of formats to apply to FILENAME if +;; a file of that name can't be found. +;; The rest of the list is an alist of elements with LINE as key. The keys +;; are either nil or line numbers. If present, nil comes first, followed by +;; the numbers in decreasing order. The LOCs for each line are again an alist +;; ordered the same way. Note that the whole file structure is referenced in +;; every LOC. + +;;; MESSAGE is a list of (LOC TYPE END-LOC) + +;; TYPE is 0 for info or 1 for warning if the message matcher identified it as +;; such, 2 otherwise (for a real error). END-LOC is a LOC pointing to the +;; other end, if the parsed message contained a range. If the end of the +;; range didn't specify a COLUMN, it defaults to -1, meaning end of line. +;; These are the value of the `message' text-properties in the compilation +;; buffer. + + (defgroup compilation nil "Run compiler as inferior of Emacs, parse error messages." :group 'tools @@ -50,50 +91,8 @@ integer) :group 'compilation) -(defcustom compile-auto-highlight nil - "*Specify how many compiler errors to highlight (and parse) initially. -\(Highlighting applies to an error message when the mouse is over it.) -If this is a number N, all compiler error messages in the first N lines -are highlighted and parsed as soon as they arrive in Emacs. -If t, highlight and parse the whole compilation output as soon as it arrives. -If nil, don't highlight or parse any of the buffer until you try to -move to the error messages. - -Those messages which are not parsed and highlighted initially -will be parsed and highlighted as soon as you try to move to them." - :type '(choice (const :tag "All" t) - (const :tag "None" nil) - (integer :tag "First N lines")) - :group 'compilation) - -(defvar compilation-error-list nil - "List of error message descriptors for visiting erring functions. -Each error descriptor is a cons (or nil). Its car is a marker pointing to -an error message. If its cdr is a marker, it points to the text of the -line the message is about. If its cdr is a cons, it is a list -\(\(DIRECTORY . FILE\) LINE [COLUMN]\). Or its cdr may be nil if that -error is not interesting. - -The value may be t instead of a list; this means that the buffer of -error messages should be reparsed the next time the list of errors is wanted. - -Some other commands (like `diff') use this list to control the error -message tracking facilities; if you change its structure, you should make -sure you also change those packages. Perhaps it is better not to change -it at all.") - -(defvar compilation-old-error-list nil - "Value of `compilation-error-list' after errors were parsed.") - -(defvar compilation-parse-errors-function 'compilation-parse-errors - "Function to call to parse error messages from a compilation. -It takes args LIMIT-SEARCH and FIND-AT-LEAST. -If LIMIT-SEARCH is non-nil, don't bother parsing past that location. -If FIND-AT-LEAST is non-nil, don't bother parsing after finding that -many new errors. -It should read in the source files which have errors and set -`compilation-error-list' to a list with an element for each error message -found. See that variable for more info.") +(defvar compilation-first-column 1 + "*This is how compilers number the first column, usually 1 or 0.") (defvar compilation-parse-errors-filename-function nil "Function to call to post-process filenames while parsing error messages. @@ -107,7 +106,7 @@ started. It can be used to set any variables or functions that are used while processing the output of the compilation process. The function is called with variables `compilation-buffer' and `compilation-window' -bound to the compilation buffer and window, respectively.") +bound to the compilation buffer and window, respectively.") ;;;###autoload (defvar compilation-buffer-name-function nil @@ -139,309 +138,234 @@ (setq minor-mode-alist (cons '(compilation-in-progress " Compiling") minor-mode-alist))) -(defvar compilation-parsing-end nil - "Marker position of end of buffer when last error messages were parsed.") - -(defvar compilation-error-message "No more errors" - "Message to print when no more matches are found.") +(defvar compilation-error "error" + "Stem of message to print when no matches are found.") (defvar compilation-arguments nil - "Arguments that were given to `compile-internal'.") + "Arguments that were given to `compilation-start'.") (defvar compilation-num-errors-found) -(defvar compilation-error-regexp-alist - '( - ;; NOTE! See also grep-regexp-alist, below. +(defconst compilation-error-regexp-alist-alist + '((absoft + "^\\(?:[Ee]rror on \\|[Ww]arning on\\( \\)\\)?[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\ +of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) + + (ada + "\\(warning: .*\\)? at \\([^ \n]+\\):\\([0-9]+\\)$" 2 3 nil (1)) + + (aix + " in line \\([0-9]+\\) of file \\([^ \n]+[^. \n]\\)\\.? " 2 1) - ;; 4.3BSD grep, cc, lint pass 1: - ;; /usr/src/foo/foo.c(8): warning: w may be used before set - ;; or GNU utilities: - ;; foo.c:8: error message - ;; or HP-UX 7.0 fc: - ;; foo.f :16 some horrible error message - ;; or GNU utilities with column (GNAT 1.82): - ;; foo.adb:2:1: Unit name does not match file name - ;; or with column and program name: - ;; jade:dbcommon.dsl:133:17:E: missing argument for function call - ;; - ;; We'll insist that the number be followed by a colon or closing - ;; paren, because otherwise this matches just about anything - ;; containing a number with spaces around it. + (ant + "^[ \t]*\\[[^] \n]+\\][ \t]*\\([^: \n]+\\):\\([0-9]+\\):\\(?:\\([0-9]+\\):[0-9]+:[0-9]+:\\)?\ +\\( warning\\)?" 1 2 3 (4)) - ;; We insist on a non-digit in the file name - ;; so that we don't mistake the file name for a command name - ;; and take the line number as the file name. - ("\\([a-zA-Z][-a-zA-Z._0-9]+: ?\\)?\ -\\([a-zA-Z]?:?[^:( \t\n]*[^:( \t\n0-9][^:( \t\n]*\\)[:(][ \t]*\\([0-9]+\\)\ -\\([) \t]\\|:\\(\\([0-9]+:\\)\\|[0-9]*[^:0-9]\\)\\)" 2 3 6) + (bash + "^\\([^: \n\t]+\\): line \\([0-9]+\\):" 1 2) + + (borland + "^\\(?:Error\\|Warnin\\(g\\)\\) \\(?:[FEW][0-9]+ \\)?\ +\\([a-zA-Z]?:?[^:( \t\n]+\\)\ + \\([0-9]+\\)\\(?:[) \t]\\|:[^0-9\n]\\)" 2 3 nil (1)) - ;; GNU utilities with precise locations (line and columns), - ;; possibly ranges: - ;; foo.c:8.23-9.1: error message - ("\\([a-zA-Z][-a-zA-Z._0-9]+\\): ?\ -\\([0-9]+\\)\\.\\([0-9]+\\)\ --\\([0-9]+\\)\\.\\([0-9]+\\)\ -:" 1 2 3) ;; When ending points are supported, add line = 4 and col = 5. - ;; foo.c:8.23-45: error message - ("\\([a-zA-Z][-a-zA-Z._0-9]+\\): ?\ -\\([0-9]+\\)\\.\\([0-9]+\\)\ --\\([0-9]+\\)\ -:" 1 2 3) ;; When ending points are supported, add line = 2 and col = 4. - ;; foo.c:8-45.3: error message - ("\\([a-zA-Z][-a-zA-Z._0-9]+\\): ?\ -\\([0-9]+\\)\ --\\([0-9]+\\)\\.\\([0-9]+\\)\ -:" 1 2 nil) ;; When ending points are supported, add line = 2 and col = 4. - ;; foo.c:8.23: error message - ("\\([a-zA-Z][-a-zA-Z._0-9]+\\): ?\ -\\([0-9]+\\)\\.\\([0-9]+\\)\ -:" 1 2 3) - ;; foo.c:8-23: error message - ("\\([a-zA-Z][-a-zA-Z._0-9]+\\): ?\ -\\([0-9]+\\)\ --\\([0-9]+\\)\ -:" 1 2 nil);; When ending points are supported, add line = 3. + (caml + "^ *File \"\\([^,\" \n\t]+\\)\", lines? \\([0-9]+\\)-?\\([0-9]+\\)?,\ +\\(?: characters? \\([0-9]+\\)-?\\([0-9]+\\)?:\\)?\\([ \n]Warning:\\)?" + 1 (2 . 3) (4 . 5) (6)) + + (comma + "^\"\\([^,\" \n\t]+\\)\", line \\([0-9]+\\)\ +\\(?:[(. pos]+\\([0-9]+\\))?\\)?[:.,; (-]\\( warning:\\|[-0-9 ]*(W)\\)?" 1 2 3 (4)) + + (epc + "^Error [0-9]+ at (\\([0-9]*\\):\\([^)\n]+\\))" 2 1) - ;; Microsoft C/C++: - ;; keyboard.c(537) : warning C4005: 'min' : macro redefinition - ;; d:\tmp\test.c(23) : error C2143: syntax error : missing ';' before 'if' - ;; This used to be less selective and allow characters other than - ;; parens around the line number, but that caused confusion for - ;; GNU-style error messages. - ;; This used to reject spaces and dashes in file names, - ;; but they are valid now; so I made it more strict about the error - ;; message that follows. - ("\\(\\([a-zA-Z]:\\)?[^:(\t\n]+\\)(\\([0-9]+\\)) \ -: \\(error\\|warning\\) C[0-9]+:" 1 3) + (iar + "^\"\\(.*\\)\",\\([0-9]+\\)\\s-+\\(?:Error\\|Warnin\\(g\\)\\)\\[[0-9]+\\]:" + 1 2 nil (3)) - ;; Borland C++, C++Builder: - ;; Error ping.c 15: Unable to open include file 'sys/types.h' - ;; Warning ping.c 68: Call to function 'func' with no prototype - ;; Error E2010 ping.c 15: Unable to open include file 'sys/types.h' - ;; Warning W1022 ping.c 68: Call to function 'func' with no prototype - ("\\(Error\\|Warning\\) \\(\\([FEW][0-9]+\\) \\)?\ -\\([a-zA-Z]?:?[^:( \t\n]+\\)\ - \\([0-9]+\\)\\([) \t]\\|:[^0-9\n]\\)" 4 5) + (ibm + "^\\([^( \n\t]+\\)(\\([0-9]+\\):\\([0-9]+\\)) :\ + \\(?:warnin\\(g\\)\\|informationa\\(l\\)\\)?" 1 2 3 (4 . 5)) - ;; Valgrind (memory debugger for x86 GNU/Linux): - ;; ==1332== at 0x8008621: main (vtest.c:180) - ;; Currently this regexp only matches the first error. - ;; Thanks to Hans Petter Jansson <hpj@ximian.com> for his regexp wisdom. - ("^==[0-9]+==[^(]+\(([^:]+):([0-9]+)" 1 2) - - ;; 4.3BSD lint pass 2 - ;; strcmp: variable # of args. llib-lc(359) :: /usr/src/foo/foo.c(8) - (".*[ \t:]\\([a-zA-Z]?:?[^:( \t\n]+\\)[:(](+[ \t]*\\([0-9]+\\))[:) \t]*$" - 1 2) - - ;; 4.3BSD lint pass 3 - ;; bloofle defined( /users/wolfgang/foo.c(4) ), but never used - ;; This used to be - ;; ("[ \t(]+\\([a-zA-Z]?:?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]+" 1 2) - ;; which is regexp Impressionism - it matches almost anything! - (".*([ \t]*\\([a-zA-Z]?:?[^:( \t\n]+\\)[:(][ \t]*\\([0-9]+\\))" 1 2) + (irix + "^[a-z0-9/]+: \\(?:[eE]rror\\|[wW]arnin\\(g\\)\\)[0-9 ]*:\ + \\([^,\" \n\t]+\\)\\(?:, line\\|:\\) \\([0-9]+\\):" 2 3 nil (1)) - ;; MIPS lint pass<n>; looks good for SunPro lint also - ;; TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomon.c due to truncation - ("[^\n ]+ (\\([0-9]+\\)) in \\([^ \n]+\\)" 2 1) - ;; name defined but never used: LinInt in cmap_calc.c(199) - (".*in \\([^(\n]+\\)(\\([0-9]+\\))$" 1 2) + (java + "^\\(?:[ \t]+at \\|==[0-9]+== +\\(?:at\\|b\\(y\\)\\)\\).+(\\([^()\n]+\\):\\([0-9]+\\))$" 2 3 nil (1)) - ;; Ultrix 3.0 f77: - ;; fort: Severe: addstf.f, line 82: Missing operator or delimiter symbol - ;; Some SGI cc version: - ;; cfe: Warning 835: foo.c, line 2: something - ("\\(cfe\\|fort\\): [^:\n]*: \\([^ \n]*\\), line \\([0-9]+\\):" 2 3) - ;; Error on line 3 of t.f: Execution error unclassifiable statement - ;; Unknown who does this: - ;; Line 45 of "foo.c": bloofle undefined - ;; Absoft FORTRAN 77 Compiler 3.1.3 - ;; error on line 19 of fplot.f: spelling error? - ;; warning on line 17 of fplot.f: data type is undefined for variable d - ("\\(.* on \\)?[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\ -of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2) + (jikes-file + "^\\(?:Found\\|Issued\\) .* compiling \"\\(.+\\)\":$" 1 nil nil 0) + (jikes-line + "^ *\\([0-9]+\\)\\.[ \t]+.*\n +\\(<-*>\n\\*\\*\\* \\(?:Error\\|Warnin\\(g\\)\\)\\)" + nil 1 nil 2 0 + (2 (compilation-face '(3)))) - ;; Apollo cc, 4.3BSD fc: - ;; "foo.f", line 3: Error: syntax error near end of statement - ;; IBM RS6000: - ;; "vvouch.c", line 19.5: 1506-046 (S) Syntax error. - ;; Microtec mcc68k: - ;; "foo.c", line 32 pos 1; (E) syntax error; unexpected symbol: "lossage" - ;; GNAT (as of July 94): - ;; "foo.adb", line 2(11): warning: file name does not match ... - ;; IBM AIX xlc compiler: - ;; "src/swapping.c", line 30.34: 1506-342 (W) "/*" detected in comment. - (".*\"\\([^,\" \n\t]+\\)\", lines? \ -\\([0-9]+\\)\\([\(.]\\([0-9]+\\)\)?\\)?[:., (-]" 1 2 4) + (gcc-include + "^\\(?:In file included\\| \\) from \ +\\(.+\\):\\([0-9]+\\)\\(?:\\(:\\)\\|\\(,\\)\\)?" 1 2 nil (3 . 4)) - ;; Python: - ;; File "foobar.py", line 5, blah blah - ("^File \"\\([^,\" \n\t]+\\)\", line \\([0-9]+\\)," 1 2) - - ;; Caml compiler: - ;; File "foobar.ml", lines 5-8, characters 20-155: blah blah - ("^File \"\\([^,\" \n\t]+\\)\", lines? \\([0-9]+\\)[-0-9]*, characters? \\([0-9]+\\)" 1 2 3) - - ;; MIPS RISC CC - the one distributed with Ultrix: - ;; ccom: Error: foo.c, line 2: syntax error - ;; DEC AXP OSF/1 cc - ;; /usr/lib/cmplrs/cc/cfe: Error: foo.c: 1: blah blah - ("[a-z0-9/]+: \\([eE]rror\\|[wW]arning\\): \\([^,\" \n\t]+\\)[,:] \\(line \\)?\\([0-9]+\\):" 2 4) + (gnu + "^\\(?:[a-zA-Z][-a-zA-Z0-9.]+: ?\\)?\ +\\([/.]*[a-zA-Z]:?[^ \t\n:]*\\): ?\ +\\([0-9]+\\)\\([.:]?\\)\\([0-9]+\\)?\ +\\(?:-\\(?:\\([0-9]+\\)\\3\\)?\\.?\\([0-9]+\\)?\\)?:\ +\\(?: *\\(\\(?:Future\\|Runtime\\)?[Ww]arning\\|W:\\)\\|\ + *\\([Ii]nfo\\(?:\\>\\|rmationa?l?\\)\\|I:\\)\\)?" + 1 (2 . 5) (4 . 6) (7 . 8)) - ;; IBM AIX PS/2 C version 1.1: - ;; ****** Error number 140 in line 8 of file errors.c ****** - (".*in line \\([0-9]+\\) of file \\([^ \n]+[^. \n]\\)\\.? " 2 1) - ;; IBM AIX lint is too painful to do right this way. File name - ;; prefixes entire sections rather than being on each line. - - ;; SPARCcompiler Pascal: - ;; 20 linjer : array[1..4] of linje; - ;; e 18480-----------^--- Inserted ';' - ;; and - ;; E 18520 line 61 - 0 is undefined - ;; These messages don't contain a file name. Instead the compiler gives - ;; a message whenever the file being compiled is changed. - (" +\\([0-9]+\\) +.*\n[ew] [0-9]+-+" nil 1) - ("[Ew] +[0-9]+ line \\([0-9]+\\) - " nil 1) - - ;; Lucid Compiler, lcc 3.x - ;; E, file.cc(35,52) Illegal operation on pointers - ("[EW], \\([^(\n]*\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)" 1 2 3) - - ;; This seems to be superfluous because the first pattern matches it. - ;; ;; GNU messages with program name and optional column number. - ;; ("[a-zA-Z]?:?[^0-9 \n\t:]+[^ \n\t:]*:[ \t]*\\([^ \n\t:]+\\):\ - ;;\\([0-9]+\\):\\(\\([0-9]+\\)[: \t]\\)?" 1 2 4) + (lcc + "^\\(?:E\\|\\(W\\)\\), \\([^(\n]+\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)" + 2 3 4 (1)) - ;; Cray C compiler error messages - ("\\(cc\\| cft\\)-[0-9]+ c\\(c\\|f77\\): ERROR \\([^,\n]+, \\)* File = \ -\\([^,\n]+\\), Line = \\([0-9]+\\)" 4 5) - - ;; IBM C/C++ Tools 2.01: - ;; foo.c(2:0) : informational EDC0804: Function foo is not referenced. - ;; foo.c(3:8) : warning EDC0833: Implicit return statement encountered. - ;; foo.c(5:5) : error EDC0350: Syntax error. - ("\\([^( \n\t]+\\)(\\([0-9]+\\):\\([0-9]+\\)) : " 1 2 3) + (makepp + "^makepp: \\(?:\\(?:warning\\(:\\).*?\\|\\(Scanning\\|[LR]e?l?oading makefile\\) \\|.*?\\)\ +`\\(\\(\\S +?\\)\\(?::\\([0-9]+\\)\\)?\\)'\\)" + 4 5 nil (1 . 2) 3 + ("`\\(\\(\\S +?\\)\\(?::\\([0-9]+\\)\\)?\\)'" nil nil + (2 compilation-info-face) + (3 compilation-line-face nil t) + (1 (compilation-error-properties 2 3 nil nil nil 2 nil) + append))) - ;; IAR Systems C Compiler: - ;; "foo.c",3 Error[32]: Error message - ;; "foo.c",3 Warning[32]: Error message - ("\"\\(.*\\)\",\\([0-9]+\\)\\s-+\\(Error\\|Warning\\)\\[[0-9]+\\]:" 1 2) - - ;; Sun ada (VADS, Solaris): - ;; /home3/xdhar/rcds_rc/main.a, line 361, char 6:syntax error: "," inserted - ("\\([^, \n\t]+\\), line \\([0-9]+\\), char \\([0-9]+\\)[:., \(-]" 1 2 3) + (mips-1 + " (\\([0-9]+\\)) in \\([^ \n]+\\)" 2 1) + (mips-2 + " in \\([^()\n ]+\\)(\\([0-9]+\\))$" 1 2) - ;; Perl -w: - ;; syntax error at automake line 922, near "':'" - ;; Perl debugging traces - ;; store::odrecall('File_A', 'x2') called at store.pm line 90 - (".* at \\([^ \n]+\\) line \\([0-9]+\\)[,.\n]" 1 2) + (msft + "^\\(\\(?:[a-zA-Z]:\\)?[^:(\t\n]+\\)(\\([0-9]+\\)) \ +: \\(?:error\\|warnin\\(g\\)\\) C[0-9]+:" 1 2 nil (3)) - ;; Oracle pro*c: - ;; Semantic error at line 528, column 5, file erosacqdb.pc: - ("Semantic error at line \\([0-9]+\\), column \\([0-9]+\\), file \\(.*\\):" + (oracle + "^Semantic error at line \\([0-9]+\\), column \\([0-9]+\\), file \\(.*\\):$" 3 1 2) - ;; EPC F90 compiler: - ;; Error 24 at (2:progran.f90) : syntax error - ("Error [0-9]+ at (\\([0-9]*\\):\\([^)\n]+\\))" 2 1) + (perl + " at \\([^ \n]+\\) line \\([0-9]+\\)\\(?:[,.]\\|$\\)" 1 2) + + (rxp + "^\\(?:Error\\|Warnin\\(g\\)\\):.*\n.* line \\([0-9]+\\) char\ + \\([0-9]+\\) of file://\\(.+\\)" + 4 2 3 (1)) + + (sparc-pascal-file + "^\\w\\w\\w \\w\\w\\w +[0-3]?[0-9] +[0-2][0-9]:[0-5][0-9]:[0-5][0-9]\ + [12][09][0-9][0-9] +\\(.*\\):$" + 1 nil nil 0) + (sparc-pascal-line + "^\\(\\(?:E\\|\\(w\\)\\) +[0-9]+\\) line \\([0-9]+\\) - " + nil 3 nil (2) nil (1 (compilation-face '(2)))) + (sparc-pascal-example + "^ +\\([0-9]+\\) +.*\n\\(\\(?:e\\|\\(w\\)\\) [0-9]+\\)-+" + nil 1 nil (3) nil (2 (compilation-face '(3)))) - ;; SGI IRIX MipsPro 7.3 compilers: - ;; cc-1070 cc: ERROR File = linkl.c, Line = 38 - (".*: ERROR File = \\(.+\\), Line = \\([0-9]+\\)" 1 2) - (".*: WARNING File = \\(.+\\), Line = \\([0-9]+\\)" 1 2) + (sun + ": \\(?:ERROR\\|WARNIN\\(G\\)\\|REMAR\\(K\\)\\) \\(?:[a-zA-Z0-9 ]+, \\)?\ +File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?" + 3 4 5 (1 . 2)) + + (sun-ada + "^\\([^, \n\t]+\\), line \\([0-9]+\\), char \\([0-9]+\\)[:., \(-]" 1 2 3) + + (ultrix + "^\\(?:cfe\\|fort\\): \\(Warning\\)?[^:\n]*: \\([^ \n]*\\), line \\([0-9]+\\):" 2 3 nil (1)) - ;; Sun F90 error messages: - ;; cf90-113 f90comp: ERROR NSE, File = Hoved.f90, Line = 16, Column = 3 - (".* ERROR [a-zA-Z0-9 ]+, File = \\(.+\\), Line = \\([0-9]+\\), Column = \\([0-9]+\\)" - 1 2 3) + (4bsd + "\\(?:^\\|:: \\|\\S ( \\)\\(/[^ \n\t()]+\\)(\\([0-9]+\\))\ +\\(?:: \\(warning:\\)?\\|$\\| ),\\)" 1 2 nil (3))) + "Alist of values for `compilation-error-regexp-alist'.") + +(defcustom compilation-error-regexp-alist + (mapcar 'car compilation-error-regexp-alist-alist) + "Alist that specifies how to match errors in compiler output. +Note that on Unix exerything is a valid filename, so these +matchers must make some common sense assumptions, which catch +normal cases. A shorter list will be lighter on resource usage. - ;; RXP - GPL XML validator at http://www.cogsci.ed.ac.uk/~richard/rxp.html: - ;; Error: Mismatched end tag: expected </geroup>, got </group> - ;; in unnamed entity at line 71 char 8 of file:///home/reto/test/group.xml - ("Error:.*\n.* line \\([0-9]+\\) char \\([0-9]+\\) of file://\\(.+\\)" - 3 1 2) - ;; Warning: Start tag for undeclared element geroup - ;; in unnamed entity at line 4 char 8 of file:///home/reto/test/group.xml - ("Warning:.*\n.* line \\([0-9]+\\) char \\([0-9]+\\) of file://\\(.+\\)" - 3 1 2) +Instead of an alist element, you can use a symbol, which is +looked up in `compilation-error-regexp-alist-alist'. You can see +the predefined symbols and their effects in the file +`etc/compilation.txt' (linked below if your are customizing this). + +Each elt has the form (REGEXP FILE [LINE COLUMN TYPE HYPERLINK +HIGHLIGHT...]). If REGEXP matches, the FILE'th subexpression +gives the file name, and the LINE'th subexpression gives the line +number. The COLUMN'th subexpression gives the column number on +that line. - ;; See http://ant.apache.org/faq.html - ;; Ant Java: works for jikes - ("^\\s-*\\[[^]]*\\]\\s-*\\(.+\\):\\([0-9]+\\):\\([0-9]+\\):[0-9]+:[0-9]+:" 1 2 3) +If FILE, LINE or COLUMN are nil or that index didn't match, that +information is not present on the matched line. In that case the +file name is assumed to be the same as the previous one in the +buffer, line number defaults to 1 and column defaults to +beginning of line's indentation. + +FILE can also have the form (FILE FORMAT...), where the FORMATs +\(e.g. \"%s.c\") will be applied in turn to the recognized file +name, until a file of that name is found. Or FILE can also be a +function to return the filename. - ;; Ant Java: works for javac - ("^\\s-*\\[[^]]*\\]\\s-*\\(.+\\):\\([0-9]+\\):" 1 2) +LINE can also be of the form (LINE . END-LINE) meaning a range +of lines. COLUMN can also be of the form (COLUMN . END-COLUMN) +meaning a range of columns starting on LINE and ending on +END-LINE, if that matched. - ) +TYPE is 2 or nil for a real error or 1 for warning or 0 for info. +TYPE can also be of the form (WARNING . INFO). In that case this +will be equivalent to 1 if the WARNING'th subexpression matched +or else equivalent to 0 if the INFO'th subexpression matched. +See `compilation-error-face', `compilation-warning-face', +`compilation-info-face' and `compilation-skip-threshold'. - "Alist that specifies how to match errors in compiler output. -Each elt has the form (REGEXP FILE-IDX LINE-IDX [COLUMN-IDX FILE-FORMAT...]) -If REGEXP matches, the FILE-IDX'th subexpression gives the file name, and -the LINE-IDX'th subexpression gives the line number. If COLUMN-IDX is -given, the COLUMN-IDX'th subexpression gives the column number on that line. -If any FILE-FORMAT is given, each is a format string to produce a file name to -try; %s in the string is replaced by the text matching the FILE-IDX'th -subexpression.") +What matched the HYPERLINK'th subexpression has `mouse-face' and +`compilation-message-face' applied. If this is nil, the text +matched by the whole REGEXP becomes the hyperlink. + +Additional HIGHLIGHTs as described under `font-lock-keywords' can +be added." + :type `(set :menu-tag "Pick" + ,@(mapcar (lambda (elt) + (list 'const (car elt))) + compilation-error-regexp-alist-alist)) + :link `(file-link :tag "example file" + ,(concat doc-directory "compilation.txt")) + :group 'compilation) (defvar compilation-directory nil "Directory to restore to when doing `recompile'.") -(defvar compilation-enter-directory-regexp-alist - '( - ;; Matches lines printed by the `-w' option of GNU Make. - (".*: Entering directory `\\(.*\\)'$" 1) - ;; Matches lines made by Emacs byte compiler. - ("^Entering directory `\\(.*\\)'$" 1) - ) - "Alist specifying how to match lines that indicate a new current directory. -Note that the match is done at the beginning of lines. -Each elt has the form (REGEXP IDX). -If REGEXP matches, the IDX'th subexpression gives the directory name. - -The default value matches lines printed by the `-w' option of GNU Make.") +(defvar compilation-directory-matcher + '("\\(?:Entering\\|Leavin\\(g\\)\\) directory `\\(.+\\)'$" (2 . 1)) + "A list for tracking when directories are entered or left. +Nil means not to track directories, e.g. if all file names are absolute. The +first element is the REGEXP matching these messages. It can match any number +of variants, e.g. different languages. The remaining elements are all of the +form (DIR . LEAVE). If for any one of these the DIR'th subexpression +matches, that is a directory name. If LEAVE is nil or the corresponding +LEAVE'th subexpression doesn't match, this message is about going into another +directory. If it does match anything, this message is about going back to the +directory we were in before the last entering message. If you change this, +you may also want to change `compilation-page-delimiter'.") -(defvar compilation-leave-directory-regexp-alist - '( - ;; Matches lines printed by the `-w' option of GNU Make. - (".*: Leaving directory `\\(.*\\)'$" 1) - ;; Matches lines made by Emacs byte compiler. - ("^Leaving directory `\\(.*\\)'$" 1) - ) -"Alist specifying how to match lines that indicate restoring current directory. -Note that the match is done at the beginning of lines. -Each elt has the form (REGEXP IDX). -If REGEXP matches, the IDX'th subexpression gives the name of the directory -being moved from. If IDX is nil, the last directory entered \(by a line -matching `compilation-enter-directory-regexp-alist'\) is assumed. - -The default value matches lines printed by the `-w' option of GNU Make.") +(defvar compilation-page-delimiter + "^\\(?:\f\\|.*\\(?:Entering\\|Leaving\\) directory `.+'\n\\)+" + "Value of `page-delimiter' in Compilation mode.") -(defvar compilation-file-regexp-alist - '( - ;; This matches entries with date time year file-name: like - ;; Thu May 14 10:46:12 1992 mom3.p: - ("\\w\\w\\w \\w\\w\\w +[0-9]+ [0-9][0-9]:[0-9][0-9]:[0-9][0-9] [0-9][0-9][0-9][0-9] \\(.*\\):$" 1) - ) - "Alist specifying how to match lines that indicate a new current file. -Note that the match is done at the beginning of lines. -Each elt has the form (REGEXP IDX). -If REGEXP matches, the IDX'th subexpression gives the file name. This is -used with compilers that don't indicate file name in every error message.") - -;; There is no generally useful regexp that will match non messages, but -;; in special cases there might be one. The lines that are not matched by -;; a regexp take much longer time than the ones that are recognized so if -;; you have same regexeps here, parsing is faster. -(defvar compilation-nomessage-regexp-alist - '( - ) - "Alist specifying how to match lines that have no message. -Note that the match is done at the beginning of lines. -Each elt has the form (REGEXP). This alist is by default empty, but if -you have some good regexps here, the parsing of messages will be faster.") +(defvar compilation-mode-font-lock-keywords + '(;; configure output lines. + ("^[Cc]hecking \\(?:[Ff]or \\|[Ii]f \\|[Ww]hether \\(?:to \\)?\\)?\\(.+\\)\\.\\.\\. *\\(?:(cached) *\\)?\\(\\(yes\\(?: .+\\)?\\)\\|no\\|\\(.*\\)\\)$" + (1 font-lock-variable-name-face) + (2 (compilation-face '(4 . 3)))) + ;; Command output lines. Recognize `make[n]:' lines too. + ("^\\([A-Za-z_0-9/.+-]+\\)\\(\\[\\([0-9]+\\)\\]\\)?[ \t]*:" + (1 font-lock-function-name-face) (3 compilation-line-face nil t)) + (" --?o\\(?:utfile\\|utput\\)?[= ]?\\(\\S +\\)" . 1) + ("^Compilation finished" . compilation-info-face) + ("^Compilation exited abnormally" . compilation-error-face)) + "Additional things to highlight in Compilation mode. +This gets tacked on the end of the generated expressions.") (defvar compilation-highlight-regexp t "Regexp matching part of visited source lines to highlight temporarily. @@ -495,13 +419,19 @@ (file-exists-p \"Makefile\")) (set (make-local-variable 'compile-command) (concat \"make -k \" - (file-name-sans-extension buffer-file-name))))))" + (file-name-sans-extension buffer-file-name))))))" :type 'string :group 'compilation) -(defvar compilation-directory-stack nil - "Stack of previous directories for `compilation-leave-directory-regexp'. -The last element is the directory the compilation was started in.") +;; A weak per-compilation-buffer hash indexed by (FILENAME . DIRECTORY). Each +;; value is a FILE-STRUCTURE as described above, with the car eq to the hash +;; key. This holds the tree seen from root, for storing new nodes. +(defvar compilation-locs ()) + +(defvar compilation-debug nil + "*Set this to `t' before creating a *compilation* buffer. +Then every error line will have a debug text property with the matcher that +fit this line and the match data. Use `describe-text-properties'.") (defvar compilation-exit-message-function nil "\ If non-nil, called when a compilation process dies to return a status message. @@ -518,45 +448,268 @@ ;; History of compile commands. (defvar compile-history nil) +(defface compilation-warning-face + '((((type tty) (class color)) (:foreground "cyan" :weight bold)) + (((class color)) (:foreground "Orange" :weight bold)) + (t (:weight bold))) + "Face used to highlight compiler warnings." + :group 'font-lock-highlighting-faces) + +(defface compilation-info-face + '((((type tty) (class color)) (:foreground "green" :weight bold)) + (((class color) (background light)) (:foreground "Green3" :weight bold)) + (((class color) (background dark)) (:foreground "Green" :weight bold)) + (t (:weight bold))) + "Face used to highlight compiler warnings." + :group 'font-lock-highlighting-faces) + +(defvar compilation-message-face nil + "Face name to use for whole messages. +Faces `compilation-error-face', `compilation-warning-face', +`compilation-info-face', `compilation-line-face' and +`compilation-column-face' get prepended to this, when applicable.") + +(defvar compilation-error-face 'font-lock-warning-face + "Face name to use for file name in error messages.") + +(defvar compilation-warning-face 'compilation-warning-face + "Face name to use for file name in warning messages.") + +(defvar compilation-info-face 'compilation-info-face + "Face name to use for file name in informational messages.") + +(defvar compilation-line-face 'font-lock-variable-name-face + "Face name to use for line number in message.") + +(defvar compilation-column-face 'font-lock-type-face + "Face name to use for column number in message.") + +;; same faces as dired uses +(defvar compilation-enter-directory-face 'font-lock-function-name-face + "Face name to use for column number in message.") + +(defvar compilation-leave-directory-face 'font-lock-type-face + "Face name to use for column number in message.") + + + +(defun compilation-face (type) + (or (and (car type) (match-end (car type)) compilation-warning-face) + (and (cdr type) (match-end (cdr type)) compilation-info-face) + compilation-error-face)) + +(defun compilation-directory-properties (idx leave) + (if leave (setq leave (match-end leave))) + ;; find previous stack, and push onto it, or if `leave' pop it + (let ((dir (previous-single-property-change (point) 'directory))) + (setq dir (if dir (or (get-text-property (1- dir) 'directory) + (get-text-property dir 'directory)))) + `(face ,(if leave + compilation-leave-directory-face + compilation-enter-directory-face) + directory ,(if leave + (or (cdr dir) + '(nil)) ; nil only isn't a property-change + (cons (match-string-no-properties idx) dir)) + mouse-face highlight + help-echo "mouse-2: visit current directory"))) + +;; Data type `reverse-ordered-alist' retriever. This function retrieves the +;; KEY element from the ALIST, creating it in the right position if not already +;; present. ALIST structure is +;; '(ANCHOR (KEY1 ...) (KEY2 ...)... (KEYn ALIST ...)) +;; ANCHOR is ignored, but necessary so that elements can be inserted. KEY1 +;; may be nil. The other KEYs are ordered backwards so that growing line +;; numbers can be inserted in front and searching can abort after half the +;; list on average. +(defmacro compilation-assq (key alist) + `(let* ((l1 ,alist) + (l2 (cdr l1))) + (car (if (if (null ,key) + (if l2 (null (caar l2))) + (while (if l2 (if (caar l2) (< ,key (caar l2)) t)) + (setq l1 l2 + l2 (cdr l1))) + (if l2 (eq ,key (caar l2)))) + l2 + (setcdr l1 (cons (list ,key) l2)))))) + + +;; This function is the central driver, called when font-locking to gather +;; all information needed to later jump to corresponding source code. +;; Return a property list with all meta information on this error location. +(defun compilation-error-properties (file line end-line col end-col type fmt) + (unless (< (next-single-property-change (match-beginning 0) 'directory nil (point)) + (point)) + (if file + (if (functionp file) + (setq file (funcall file)) + (let (dir) + (setq file (match-string-no-properties file)) + (unless (file-name-absolute-p file) + (setq dir (previous-single-property-change (point) 'directory) + dir (if dir (or (get-text-property (1- dir) 'directory) + (get-text-property dir 'directory))))) + (setq file (cons file (car dir)) ; top of dir stack is current + file (or (gethash file compilation-locs) + (puthash file (list file fmt) compilation-locs))))) + ;; This message didn't mention one, get it from previous + (setq file (previous-single-property-change (point) 'message) + file (or (if file + (nth 2 (car (or (get-text-property (1- file) 'message) + (get-text-property file 'message))))) + ;; no previous either -- let font-lock continue + (gethash (setq file '("*unknown*")) compilation-locs) + (puthash file (list file fmt) compilation-locs)))) + ;; All of these fields are optional, get them only if we have an index, and + ;; it matched some part of the message. + (and line + (setq line (match-string-no-properties line)) + (setq line (string-to-number line))) + (and end-line + (setq end-line (match-string-no-properties end-line)) + (setq end-line (string-to-number end-line))) + (and col + (setq col (match-string-no-properties col)) + (setq col (- (string-to-number col) compilation-first-column))) + (if (and end-col (setq end-col (match-string-no-properties end-col))) + (setq end-col (- (string-to-number end-col) compilation-first-column)) + (if end-line (setq end-col -1))) + (if (consp type) ; not a preset type, check what it is. + (setq type (or (and (car type) (match-end (car type)) 1) + (and (cdr type) (match-end (cdr type)) 0) + 2))) + ;; Get any (first) already existing marker (if any has one, all have one). + ;; Do this first, as the next assq`s may create new nodes. + (let ((marker (nth 3 (car (cdar (cddr file))))) + (loc (compilation-assq line (cdr file))) + end-loc) + (if end-line + (setq end-loc (compilation-assq end-line (cdr file)) + end-loc (compilation-assq end-col end-loc)) + (if end-col ; use same line element + (setq end-loc (compilation-assq end-col loc)))) + (setq loc (compilation-assq col loc)) + ;; If they are new, make the loc(s) reference the file they point to. + (or (cdr loc) (setcdr loc (list line file))) + (if end-loc + (or (cdr end-loc) (setcdr end-loc (list (or end-line line) file)))) + ;; If we'd found a marker, ensure that the new locs also get markers + (when (and marker + (not (or (cddr loc) (cddr end-loc))) ; maybe new node w/o marker + (marker-buffer marker)) ; other marker still valid + (or line (setq line 1)) ; normalize no linenumber to line 1 + (catch 'marker ; find nearest loc, at least one exists + (dolist (x (cddr file)) + (if (> (or (car x) 1) line) + (setq marker x) + (if (eq (or (car x) 1) line) + (if (cdr (cddr x)) ; at least one other column + (throw 'marker (setq marker x)) + (if marker (throw 'marker t))) + (throw 'marker (or marker (setq marker x))))))) + (setq marker (if (eq (car (cddr marker)) col) + (nthcdr 3 marker) + (cddr marker)) + file compilation-error-screen-columns) + (save-excursion + (set-buffer (marker-buffer (cddr marker))) + (save-restriction + (widen) + (goto-char (marker-position (cddr marker))) + (beginning-of-line (- line (car (cadr marker)) -1)) + (if file ; original c.-error-screen-columns + (move-to-column (car loc)) + (forward-char (car loc))) + (setcdr (cdr loc) (point-marker)) + (when end-loc + (beginning-of-line (- end-line line -1)) + (if (< end-col 0) + (end-of-line) + (if file ; original c.-error-screen-columns + (move-to-column (car end-loc)) + (forward-char (car end-loc)))) + (setcdr (cdr end-loc) (point-marker)))))) + ;; Must start with face + `(face ,compilation-message-face + message (,loc ,type ,end-loc) + ,@(if compilation-debug + `(debug (,(assoc (with-no-warnings matcher) font-lock-keywords) + ,@(match-data)))) + help-echo ,(if col + "mouse-2: visit this file, line and column" + (if line + "mouse-2: visit this file and line" + "mouse-2: visit this file")) + mouse-face highlight)))) + (defun compilation-mode-font-lock-keywords () "Return expressions to highlight in Compilation mode." (nconc - ;; + ;; make directory tracking + (if compilation-directory-matcher + `((,(car compilation-directory-matcher) + ,@(mapcar (lambda (elt) + `(,(car elt) + (compilation-directory-properties + ,(car elt) ,(cdr elt)) + t)) + (cdr compilation-directory-matcher))))) + ;; Compiler warning/error lines. - (mapcar (function - (lambda (item) - ;; Prepend "^", adjusting FILE-IDX and LINE-IDX accordingly. - (let ((file-idx (nth 1 item)) - (line-idx (nth 2 item)) - (col-idx (nth 3 item)) - keyword) - (when (numberp col-idx) - (setq keyword - (cons (list (1+ col-idx) 'font-lock-type-face nil t) - keyword))) - (when (numberp line-idx) - (setq keyword - (cons (list (1+ line-idx) 'font-lock-variable-name-face) - keyword))) - (when (numberp file-idx) - (setq keyword - (cons (list (1+ file-idx) 'font-lock-warning-face) - keyword))) - (cons (concat "^\\(" (nth 0 item) "\\)") keyword)))) + (mapcar (lambda (item) + (if (symbolp item) + (setq item (cdr (assq item + compilation-error-regexp-alist-alist)))) + (let ((file (nth 1 item)) + (line (nth 2 item)) + (col (nth 3 item)) + (type (nth 4 item)) + end-line end-col fmt) + (if (consp file) (setq fmt (cdr file) file (car file))) + (if (consp line) (setq end-line (cdr line) line (car line))) + (if (consp col) (setq end-col (cdr col) col (car col))) + + `(,(nth 0 item) + + ,@(when (integerp file) + `((,file ,(if (consp type) + `(compilation-face ',type) + (aref [compilation-info-face + compilation-warning-face + compilation-error-face] + (or type 2)))))) + + ,@(when line + `((,line compilation-line-face nil t))) + ,@(when end-line + `((,end-line compilation-line-face nil t))) + + ,@(when col + `((,col compilation-column-face nil t))) + ,@(when end-col + `((,end-col compilation-column-face nil t))) + + ,@(nthcdr 6 item) + (,(or (nth 5 item) 0) + (compilation-error-properties ',file ,line ,end-line + ,col ,end-col ',(or type 2) + ',fmt) + append)))) ; for compilation-message-face compilation-error-regexp-alist) - (list - ;; - ;; Compiler output lines. Recognize `make[n]:' lines too. - '("^\\([A-Za-z_0-9/\.+-]+\\)\\(\\[\\([0-9]+\\)\\]\\)?[ \t]*:" - (1 font-lock-function-name-face) (3 font-lock-comment-face nil t))) - )) + + compilation-mode-font-lock-keywords)) + ;;;###autoload -(defun compile (command) +(defun compile (command &optional comint) "Compile the program including the current buffer. Default: run `make'. Runs COMMAND, a shell command, in a separate process asynchronously with output going to the buffer `*compilation*'. +If optional second arg COMINT is t the buffer will be in comint mode with +`compilation-shell-minor-mode'. + You can then use the command \\[next-error] to find the next error message and move to the source code that caused it. @@ -575,14 +728,14 @@ (interactive (if (or compilation-read-command current-prefix-arg) (list (read-from-minibuffer "Compile command: " - (eval compile-command) nil nil - '(compile-history . 1))) + (eval compile-command) nil nil + '(compile-history . 1))) (list (eval compile-command)))) (unless (equal command (eval compile-command)) (setq compile-command command)) (save-some-buffers (not compilation-ask-about-save) nil) (setq compilation-directory default-directory) - (compile-internal command "No more errors")) + (compilation-start command comint)) ;; run compile with the default command line (defun recompile () @@ -592,9 +745,8 @@ (interactive) (save-some-buffers (not compilation-ask-about-save) nil) (let ((default-directory (or compilation-directory default-directory))) - (apply 'compile-internal (or compilation-arguments - `(,(eval compile-command) - "No more errors"))))) + (apply 'compilation-start (or compilation-arguments + `(,(eval compile-command)))))) (defcustom compilation-scroll-output nil "*Non-nil to scroll the *compilation* buffer window as output appears. @@ -625,51 +777,59 @@ (t (concat "*" (downcase mode-name) "*")))) - +;; This is a rough emulation of the old hack, until the transition to new +;; compile is complete. (defun compile-internal (command error-message &optional name-of-mode parser error-regexp-alist name-function enter-regexp-alist leave-regexp-alist file-regexp-alist nomessage-regexp-alist no-async highlight-regexp local-map) + (if parser + (error "Compile now works very differently, see `compilation-error-regexp-alist'")) + (let ((compilation-error-regexp-alist + (append file-regexp-alist (or error-regexp-alist + compilation-error-regexp-alist))) + (compilation-error (replace-regexp-in-string "^No more \\(.+\\)s\\.?" + "\\1" error-message))) + (compilation-start command nil name-function highlight-regexp))) +(make-obsolete 'compile-internal 'compilation-start) + +(defun compilation-start (command &optional mode name-function highlight-regexp) "Run compilation command COMMAND (low level interface). -ERROR-MESSAGE is a string to print if the user asks to see another error -and there are no more errors. - The rest of the arguments are optional; for them, nil means use the default. -NAME-OF-MODE is the name to display as the major mode in the compilation -buffer. - -PARSER is the error parser function. -ERROR-REGEXP-ALIST is the error message regexp alist to use. +MODE is the major mode to set in the compilation buffer. Mode +may also be `t' meaning `compilation-shell-minor-mode' under `comint-mode'. NAME-FUNCTION is a function called to name the buffer. -ENTER-REGEXP-ALIST is the enter directory message regexp alist to use. -LEAVE-REGEXP-ALIST is the leave directory message regexp alist to use. -FILE-REGEXP-ALIST is the change current file message regexp alist to use. -NOMESSAGE-REGEXP-ALIST is the nomessage regexp alist to use. - The defaults for these variables are the global values of -\`compilation-parse-errors-function', `compilation-error-regexp-alist', -\`compilation-buffer-name-function', `compilation-enter-directory-regexp-alist', -\`compilation-leave-directory-regexp-alist', `compilation-file-regexp-alist', -\ and `compilation-nomessage-regexp-alist', respectively. -For arg 7-10 a value t means an empty alist. - -If NO-ASYNC is non-nil, start the compilation process synchronously. If HIGHLIGHT-REGEXP is non-nil, `next-error' will temporarily highlight matching section of the visited source line; the default is to use the global value of `compilation-highlight-regexp'. -If LOCAL-MAP is non-nil, use the given keymap instead of `compilation-mode-map'. - Returns the compilation buffer created." - (unless no-async - (setq no-async (not (fboundp 'start-process)))) - (let (outbuf) + (or mode (setq mode 'compilation-mode)) + (let ((name-of-mode + (if (eq mode t) + (prog1 "compilation" (require 'comint)) + (replace-regexp-in-string "-mode$" "" (symbol-name mode)))) + (process-environment + (append + compilation-environment + (if (and (boundp 'system-uses-terminfo) + system-uses-terminfo) + (list "TERM=dumb" "TERMCAP=" + (format "COLUMNS=%d" (window-width))) + (list "TERM=emacs" + (format "TERMCAP=emacs:co#%d:tc=unknown:" + (window-width)))) + ;; Set the EMACS variable, but + ;; don't override users' setting of $EMACS. + (unless (getenv "EMACS") '("EMACS=t")) + process-environment)) + (thisdir default-directory) + outwin outbuf) (save-excursion - (or name-of-mode - (setq name-of-mode "Compilation")) (setq outbuf (get-buffer-create (compilation-buffer-name name-of-mode name-function))) @@ -687,137 +847,89 @@ (delete-process comp-proc)) (error nil)) (error "Cannot have two processes in `%s' at once" - (buffer-name)) - ))) - ;; In case the compilation buffer is current, make sure we get the global - ;; values of compilation-error-regexp-alist, etc. - (kill-all-local-variables)) - (or error-regexp-alist - (setq error-regexp-alist compilation-error-regexp-alist)) - (or enter-regexp-alist - (setq enter-regexp-alist compilation-enter-directory-regexp-alist)) - (or leave-regexp-alist - (setq leave-regexp-alist compilation-leave-directory-regexp-alist)) - (or file-regexp-alist - (setq file-regexp-alist compilation-file-regexp-alist)) - (or nomessage-regexp-alist - (setq nomessage-regexp-alist compilation-nomessage-regexp-alist)) - (or highlight-regexp - (setq highlight-regexp compilation-highlight-regexp)) - (or parser (setq parser compilation-parse-errors-function)) - (let ((thisdir default-directory) - outwin) - (save-excursion - ;; Clear out the compilation buffer and make it writable. - ;; Change its default-directory to the directory where the compilation - ;; will happen, and insert a `cd' command to indicate this. - (set-buffer outbuf) - (setq buffer-read-only nil) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (buffer-enable-undo (current-buffer)) - (setq default-directory thisdir) - (insert "cd " thisdir "\n" command "\n") - (set-buffer-modified-p nil)) - ;; If we're already in the compilation buffer, go to the end - ;; of the buffer, so point will track the compilation output. - (if (eq outbuf (current-buffer)) + (buffer-name))))) + ;; Clear out the compilation buffer and make it writable. + ;; Change its default-directory to the directory where the compilation + ;; will happen, and insert a `cd' command to indicate this. + (setq buffer-read-only nil) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (buffer-enable-undo (current-buffer)) + (setq default-directory thisdir) + ;; output a mode setter, for saving and later reloading this buffer + (insert "cd " thisdir " # -*-" name-of-mode + "-*-\nEntering directory `" thisdir "'\n" command "\n") + (set-buffer-modified-p nil)) + ;; If we're already in the compilation buffer, go to the end + ;; of the buffer, so point will track the compilation output. + (if (eq outbuf (current-buffer)) + (goto-char (point-max))) + ;; Pop up the compilation buffer. + (setq outwin (display-buffer outbuf nil t)) + (with-current-buffer outbuf + (if (not (eq mode t)) + (funcall mode) + (with-no-warnings (comint-mode)) + (compilation-shell-minor-mode)) + ;; In what way is it non-ergonomic ? -stef + ;; (toggle-read-only 1) ;;; Non-ergonomic. + (if highlight-regexp + (set (make-local-variable 'compilation-highlight-regexp) + highlight-regexp)) + (set (make-local-variable 'compilation-arguments) + (list command mode name-function highlight-regexp)) + (set (make-local-variable 'revert-buffer-function) + 'compilation-revert-buffer) + (set-window-start outwin (point-min)) + (or (eq outwin (selected-window)) + (set-window-point outwin (point))) + ;; The setup function is called before compilation-set-window-height + ;; so it can set the compilation-window-height buffer locally. + (if compilation-process-setup-function + (funcall compilation-process-setup-function)) + (compilation-set-window-height outwin) + ;; Start the compilation. + (if (fboundp 'start-process) + (let ((proc (if (eq mode t) + (get-buffer-process + (with-no-warnings + (comint-exec outbuf (downcase mode-name) + shell-file-name nil `("-c" ,command)))) + (start-process-shell-command (downcase mode-name) + outbuf command)))) + ;; Make the buffer's mode line show process state. + (setq mode-line-process '(":%s")) + (set-process-sentinel proc 'compilation-sentinel) + (set-process-filter proc 'compilation-filter) + (set-marker (process-mark proc) (point) outbuf) + (setq compilation-in-progress + (cons proc compilation-in-progress))) + ;; No asynchronous processes available. + (message "Executing `%s'..." command) + ;; Fake modeline display as if `start-process' were run. + (setq mode-line-process ":run") + (force-mode-line-update) + (let ((status (call-process shell-file-name nil outbuf nil "-c" + command))) + (cond ((numberp status) + (compilation-handle-exit 'exit status + (if (zerop status) + "finished\n" + (format "\ +exited abnormally with code %d\n" + status)))) + ((stringp status) + (compilation-handle-exit 'signal status + (concat status "\n"))) + (t + (compilation-handle-exit 'bizarre status status)))) + (message "Executing `%s'...done" command))) + (if (buffer-local-value 'compilation-scroll-output outbuf) + (save-selected-window + (select-window outwin) (goto-char (point-max))) - ;; Pop up the compilation buffer. - (setq outwin (display-buffer outbuf nil t)) - (with-current-buffer outbuf - (compilation-mode name-of-mode) - (if local-map - (use-local-map local-map)) - ;; In what way is it non-ergonomic ? -stef - ;; (toggle-read-only 1) ;;; Non-ergonomic. - (set (make-local-variable 'compilation-parse-errors-function) parser) - (set (make-local-variable 'compilation-error-message) error-message) - (set (make-local-variable 'compilation-error-regexp-alist) - error-regexp-alist) - (set (make-local-variable 'compilation-enter-directory-regexp-alist) - enter-regexp-alist) - (set (make-local-variable 'compilation-leave-directory-regexp-alist) - leave-regexp-alist) - (set (make-local-variable 'compilation-file-regexp-alist) - file-regexp-alist) - (set (make-local-variable 'compilation-nomessage-regexp-alist) - nomessage-regexp-alist) - (set (make-local-variable 'compilation-highlight-regexp) - highlight-regexp) - (set (make-local-variable 'compilation-arguments) - (list command error-message - name-of-mode parser - error-regexp-alist name-function - enter-regexp-alist leave-regexp-alist - file-regexp-alist nomessage-regexp-alist - nil ; or no-async ?? - highlight-regexp local-map)) - ;; This proves a good idea if the buffer's going to scroll - ;; with lazy-lock on. - (set (make-local-variable 'lazy-lock-defer-on-scrolling) t) - (setq default-directory thisdir - compilation-directory-stack (list default-directory)) - (set-window-start outwin (point-min)) - (or (eq outwin (selected-window)) - (set-window-point outwin (point))) - ;; The setup function is called before compilation-set-window-height - ;; so it can set the compilation-window-height buffer locally. - (if compilation-process-setup-function - (funcall compilation-process-setup-function)) - (compilation-set-window-height outwin) - ;; Start the compilation. - (if (not no-async) - (let* ((process-environment - (append - compilation-environment - (if (and (boundp 'system-uses-terminfo) - system-uses-terminfo) - (list "TERM=dumb" "TERMCAP=" - (format "COLUMNS=%d" (window-width))) - (list "TERM=emacs" - (format "TERMCAP=emacs:co#%d:tc=unknown:" - (window-width)))) - ;; Set the EMACS variable, but - ;; don't override users' setting of $EMACS. - (if (getenv "EMACS") - process-environment - (cons "EMACS=t" process-environment)))) - (proc (start-process-shell-command (downcase mode-name) - outbuf - command))) - (set-process-sentinel proc 'compilation-sentinel) - (set-process-filter proc 'compilation-filter) - (set-marker (process-mark proc) (point) outbuf) - (setq compilation-in-progress - (cons proc compilation-in-progress))) - ;; No asynchronous processes available. - (message "Executing `%s'..." command) - ;; Fake modeline display as if `start-process' were run. - (setq mode-line-process ":run") - (force-mode-line-update) - (sit-for 0) ; Force redisplay - (let ((status (call-process shell-file-name nil outbuf nil "-c" - command))) - (cond ((numberp status) - (compilation-handle-exit 'exit status - (if (zerop status) - "finished\n" - (format "\ -exited abnormally with code %d\n" - status)))) - ((stringp status) - (compilation-handle-exit 'signal status - (concat status "\n"))) - (t - (compilation-handle-exit 'bizarre status status)))) - (message "Executing `%s'...done" command))) - (if (buffer-local-value 'compilation-scroll-output outbuf) - (save-selected-window - (select-window outwin) - (goto-char (point-max))))) - ;; Make it so the next C-x ` will use this buffer. - (setq compilation-last-buffer outbuf))) + ;; Make it so the next C-x ` will use this buffer. + (setq compilation-last-buffer outbuf)))) (defun compilation-set-window-height (window) "Set the height of WINDOW according to `compilation-window-height'." @@ -902,7 +1014,7 @@ (put 'compilation-mode 'mode-class 'special) ;;;###autoload -(defun compilation-mode (&optional name-of-mode) +(defun compilation-mode () "Major mode for compilation log buffers. \\<compilation-mode-map>To visit the source for a line-numbered error, move point to the error message line and type \\[compile-goto-error]. @@ -913,32 +1025,86 @@ (kill-all-local-variables) (use-local-map compilation-mode-map) (setq major-mode 'compilation-mode - mode-name (or name-of-mode "Compilation")) + mode-name "Compilation") + (set (make-local-variable 'page-delimiter) + compilation-page-delimiter) (compilation-setup) - (set (make-local-variable 'font-lock-defaults) - '(compilation-mode-font-lock-keywords t)) - (set (make-local-variable 'revert-buffer-function) - 'compilation-revert-buffer) - (run-hooks 'compilation-mode-hook)) + (run-mode-hooks 'compilation-mode-hook)) + +(defmacro define-compilation-mode (mode name doc &rest body) + "This is like `define-derived-mode' without the PARENT argument. +The parent is always `compilation-mode' and the customizable `compilation-...' +variables are also set from the name of the mode you have chosen, by replacing +the fist word, e.g `compilation-scroll-output' from `grep-scroll-output' if that +variable exists." + (let ((mode-name (replace-regexp-in-string "-mode\\'" "" (symbol-name mode)))) + `(define-derived-mode ,mode compilation-mode ,name + ,doc + ,@(mapcar (lambda (v) + (setq v (cons v + (intern-soft (replace-regexp-in-string + "^compilation" mode-name + (symbol-name v))))) + (and (cdr v) + (or (boundp (cdr v)) + (if (boundp 'byte-compile-bound-variables) + (memq (cdr v) byte-compile-bound-variables))) + `(set (make-local-variable ',(car v)) ,(cdr v)))) + '(compilation-buffer-name-function + compilation-directory-matcher + compilation-error + compilation-error-regexp-alist + compilation-error-regexp-alist-alist + compilation-error-screen-columns + compilation-finish-function + compilation-finish-functions + compilation-first-column + compilation-mode-font-lock-keywords + compilation-page-delimiter + compilation-parse-errors-filename-function + compilation-process-setup-function + compilation-scroll-output + compilation-search-path + compilation-skip-threshold + compilation-window-height)) + ,@body))) (defun compilation-revert-buffer (ignore-auto noconfirm) (if buffer-file-name (let (revert-buffer-function) (revert-buffer ignore-auto noconfirm)) (if (or noconfirm (yes-or-no-p (format "Restart compilation? "))) - (apply 'compile-internal compilation-arguments)))) + (apply 'compilation-start compilation-arguments)))) -(defun compilation-setup () +;; A function name can't be a hook, must be something with a value. +(defconst compilation-turn-on-font-lock 'turn-on-font-lock) + +(defun compilation-setup (&optional minor) "Prepare the buffer for the compilation parsing commands to work." - ;; Make the buffer's mode line show process state. - (setq mode-line-process '(":%s")) - (set (make-local-variable 'compilation-error-list) nil) - (set (make-local-variable 'compilation-old-error-list) nil) - (set (make-local-variable 'compilation-parsing-end) (copy-marker 1)) - (set (make-local-variable 'compilation-directory-stack) - (list default-directory)) (make-local-variable 'compilation-error-screen-columns) - (setq compilation-last-buffer (current-buffer))) + (setq compilation-last-buffer (current-buffer)) + (if minor + (if font-lock-defaults + (font-lock-add-keywords nil (compilation-mode-font-lock-keywords)) + (set (make-local-variable 'font-lock-defaults) + '(compilation-mode-font-lock-keywords t))) + (set (make-local-variable 'font-lock-defaults) + '(compilation-mode-font-lock-keywords t))) + (set (make-local-variable 'font-lock-extra-managed-props) + '(directory message help-echo mouse-face debug)) + (set (make-local-variable 'compilation-locs) + (make-hash-table :test 'equal :weakness 'value)) + ;; lazy-lock would never find the message unless it's scrolled to + ;; jit-lock might fontify some things too late + (if (font-lock-value-in-major-mode font-lock-support-mode) + (set (make-local-variable 'font-lock-support-mode) nil)) + (set (make-local-variable 'font-lock-maximum-size) nil) + (if minor + (if font-lock-mode + (font-lock-fontify-buffer) + (turn-on-font-lock)) + ;; maybe defer font-lock till after derived mode is set up + (run-mode-hooks 'compilation-turn-on-font-lock))) ;;;###autoload (define-minor-mode compilation-shell-minor-mode @@ -948,10 +1114,12 @@ Compilation major mode are available but bound to keys that don't collide with Shell mode. See `compilation-mode'. Turning the mode on runs the normal hook `compilation-shell-minor-mode-hook'." - nil " Shell-Compile" nil + nil " Shell-Compile" :group 'compilation - (let (mode-line-process) - (compilation-setup))) + (if compilation-shell-minor-mode + (compilation-setup t) + (font-lock-remove-keywords nil (compilation-mode-font-lock-keywords)) + (font-lock-fontify-buffer))) ;;;###autoload (define-minor-mode compilation-minor-mode @@ -960,10 +1128,12 @@ In this minor mode, all the error-parsing commands of the Compilation major mode are available. See `compilation-mode'. Turning the mode on runs the normal hook `compilation-minor-mode-hook'." - nil " Compilation" nil + nil " Compilation" :group 'compilation - (let ((mode-line-process)) - (compilation-setup))) + (if compilation-minor-mode + (compilation-setup t) + (font-lock-remove-keywords nil (compilation-mode-font-lock-keywords)) + (font-lock-fontify-buffer))) (defun compilation-handle-exit (process-status exit-status msg) "Write msg in the current buffer and hack its mode-line-process." @@ -979,8 +1149,8 @@ (goto-char omax) (insert ?\n mode-name " " (car status)) (if (and (numberp compilation-window-height) - (zerop compilation-window-height)) - (message "%s" (cdr status))) + (zerop compilation-window-height)) + (message "%s" (cdr status))) (if (bolp) (forward-char -1)) (insert " at " (substring (current-time-string) 0 19)) @@ -993,14 +1163,6 @@ (force-mode-line-update) (if (and opoint (< opoint omax)) (goto-char opoint)) - ;; Automatically parse (and mouse-highlight) error messages: - (cond ((eq compile-auto-highlight t) - (compile-reinitialize-errors nil (point-max))) - ((numberp compile-auto-highlight) - (compile-reinitialize-errors nil - (save-excursion - (goto-line compile-auto-highlight) - (point))))) (if compilation-finish-function (funcall compilation-finish-function (current-buffer) msg)) (let ((functions compilation-finish-functions)) @@ -1042,33 +1204,36 @@ (if (buffer-name (process-buffer proc)) (save-excursion (set-buffer (process-buffer proc)) - (let ((buffer-read-only nil) - (end (marker-position compilation-parsing-end))) + (let ((buffer-read-only nil)) (save-excursion (goto-char (process-mark proc)) (insert-before-markers string) - (set-marker compilation-parsing-end end) ;don't move it - (run-hooks 'compilation-filter-hook) - ;; this seems redundant since we insert-before-marks -stefan - ;;(set-marker (process-mark proc) (point)) - ))))) - -(defun compile-error-at-point () - "Return the cdr of `compilation-old-error-list' for error containing point." - (compile-reinitialize-errors nil (point)) - (let ((errors compilation-old-error-list)) - (while (and errors - (> (point) (car (car errors)))) - (setq errors (cdr errors))) - errors)) + (run-hooks 'compilation-filter-hook)))))) (defsubst compilation-buffer-p (buffer) - (save-excursion - (set-buffer buffer) - (or compilation-shell-minor-mode compilation-minor-mode - (eq major-mode 'compilation-mode)))) + (local-variable-p 'compilation-locs buffer)) -(defun compilation-next-error (n) +(defmacro compilation-loop (< property-change 1+ error) + `(while (,< n 0) + (or (setq pt (,property-change pt 'message)) + (error ,error compilation-error)) + ;; prop 'message usually has 2 changes, on and off, so re-search if off + (or (setq msg (get-text-property pt 'message)) + (if (setq pt (,property-change pt 'message)) + (setq msg (get-text-property pt 'message))) + (error ,error compilation-error)) + (or (< (cadr msg) compilation-skip-threshold) + (if different-file + (eq (prog1 last (setq last (nth 2 (car msg)))) + last)) + (if compilation-skip-visited + (nthcdr 4 (car msg))) + (if compilation-skip-to-next-location + (eq (car msg) loc)) + ;; count this message only if none of the above are true + (setq n (,1+ n))))) + +(defun compilation-next-error (n &optional different-file) "Move point to the next error in the compilation buffer. Prefix arg N says how many error messages to move forwards (or backwards, if negative). @@ -1077,42 +1242,43 @@ (or (compilation-buffer-p (current-buffer)) (error "Not in a compilation buffer")) (setq compilation-last-buffer (current-buffer)) - - (let ((errors (compile-error-at-point))) - - ;; Move to the error after the one containing point. - (goto-char (car (if (< n 0) - (let ((i 0) - (e compilation-old-error-list)) - ;; See how many cdrs away ERRORS is from the start. - (while (not (eq e errors)) - (setq i (1+ i) - e (cdr e))) - (if (> (- n) i) - (error "Moved back past first error") - (nth (+ i n) compilation-old-error-list))) - (save-excursion - (while (and (> n 0) errors) - ;; Discard the current error and any previous. - (while (and errors (>= (point) (car (car errors)))) - (setq errors (cdr errors))) - ;; Now (car errors) is the next error. - ;; If we want to move down more errors, - ;; put point at this one and start again. - (setq n (1- n)) - (if (and errors (> n 0)) - (goto-char (car (car errors)))))) - (let ((compilation-error-list errors)) - (compile-reinitialize-errors nil nil n) - (if compilation-error-list - (nth (1- n) compilation-error-list) - (error "Moved past last error")))))))) + (let* ((pt (point)) + (msg (get-text-property pt 'message)) + (loc (car msg)) + last) + (if (zerop n) + (unless (or msg ; find message near here + (setq msg (get-text-property (max (1- pt) 1) 'message))) + (setq pt (previous-single-property-change pt 'message nil + (save-excursion + (beginning-of-line) + (point)))) + (if pt + (setq msg (get-text-property (max (1- pt) 1) 'message)) + (setq pt (next-single-property-change pt 'message nil + (save-excursion + (end-of-line) + (point)))) + (if pt + (setq msg (get-text-property pt 'message)) + (setq pt (point))))) + (setq last (nth 2 (car msg))) + ;; These loops search only either forwards or backwards + (compilation-loop > next-single-property-change 1- + (if (get-buffer-process (current-buffer)) + "No more %ss yet" + "Moved past last %s")) + (compilation-loop < previous-single-property-change 1+ + "Moved back before first %s")) + (goto-char pt) + (or msg + (error "No %s here" compilation-error)))) (defun compilation-previous-error (n) "Move point to the previous error in the compilation buffer. Prefix arg N says how many error messages to move backwards (or forwards, if negative). -Does NOT find the source line like \\[next-error]." +Does NOT find the source line like \\[previous-error]." (interactive "p") (compilation-next-error (- n))) @@ -1128,84 +1294,15 @@ (defun previous-error-no-select (n) "Move point to the previous error in the compilation buffer and highlight match. Prefix arg N says how many error messages to move forwards. -Finds and highlights the source line like \\[next-error], but does not +Finds and highlights the source line like \\[previous-error], but does not select the source buffer." (interactive "p") - (next-error (- n)) - (pop-to-buffer compilation-last-buffer)) - -;; Given an elt of `compilation-error-list', return an object representing -;; the referenced file which is equal to (but not necessarily eq to) what -;; this function would return for another error in the same file. -(defsubst compilation-error-filedata (data) - (setq data (cdr data)) - (if (markerp data) - (marker-buffer data) - (car data))) - -;; Return a string describing a value from compilation-error-filedata. -;; This value is not necessarily useful as a file name, but should be -;; indicative to the user of what file's errors are being referred to. -(defsubst compilation-error-filedata-file-name (filedata) - (if (bufferp filedata) - (buffer-file-name filedata) - (car filedata))) + (next-error-no-select (- n))) (defun compilation-next-file (n) "Move point to the next error for a different file than the current one." (interactive "p") - (or (compilation-buffer-p (current-buffer)) - (error "Not in a compilation buffer")) - (setq compilation-last-buffer (current-buffer)) - - (let ((reversed (< n 0)) - errors filedata) - - (if (not reversed) - (setq errors (or (compile-error-at-point) - (error "Moved past last error"))) - - ;; Get a reversed list of the errors up through the one containing point. - (compile-reinitialize-errors nil (point)) - (setq errors (reverse compilation-old-error-list) - n (- n)) - - ;; Ignore errors after point. (car ERRORS) will be the error - ;; containing point, (cadr ERRORS) the one before it. - (while (and errors - (< (point) (car (car errors)))) - (setq errors (cdr errors)))) - - (while (> n 0) - (setq filedata (compilation-error-filedata (car errors))) - - ;; Skip past the following errors for this file. - (while (equal filedata - (compilation-error-filedata - (car (or errors - (if reversed - (error "%s the first erring file" - (compilation-error-filedata-file-name - filedata)) - (let ((compilation-error-list nil)) - ;; Parse some more. - (compile-reinitialize-errors nil nil 2) - (setq errors compilation-error-list))) - (error "%s is the last erring file" - (compilation-error-filedata-file-name - filedata)))))) - (setq errors (cdr errors))) - - (setq n (1- n))) - - ;; Move to the following error. - (goto-char (car (car (or errors - (if reversed - (error "This is the first erring file") - (let ((compilation-error-list nil)) - ;; Parse the last one. - (compile-reinitialize-errors nil nil 1) - compilation-error-list)))))))) + (compilation-next-error n t)) (defun compilation-previous-file (n) "Move point to the previous error for a different file than the current one." @@ -1220,154 +1317,24 @@ (interrupt-process (get-buffer-process buffer)) (error "The compilation process is not running")))) -(defalias 'kill-grep 'kill-compilation) +(defun compile-mouse-goto-error (event) + "Visit the source for the error message the mouse is pointing at." + (interactive "e") + (mouse-set-point event) + (if (get-text-property (point) 'directory) + (dired-other-window (car (get-text-property (point) 'directory))) + (next-error 0))) -;; Parse any new errors in the compilation buffer, -;; or reparse from the beginning if the user has asked for that. -(defun compile-reinitialize-errors (reparse - &optional limit-search find-at-least) - (save-excursion - (set-buffer compilation-last-buffer) - ;; If we are out of errors, or if user says "reparse", - ;; discard the info we have, to force reparsing. - (if (or (eq compilation-error-list t) - reparse) - (compilation-forget-errors)) - (if (and compilation-error-list - (or (not limit-search) - (> compilation-parsing-end limit-search)) - (or (not find-at-least) - (>= (length compilation-error-list) find-at-least))) - ;; Since compilation-error-list is non-nil, it points to a specific - ;; error the user wanted. So don't move it around. - nil - ;; This was here for a long time (before my rewrite); why? --roland - ;;(switch-to-buffer compilation-last-buffer) - (set-buffer-modified-p nil) - (if (< compilation-parsing-end (point-max)) - ;; compilation-error-list might be non-nil if we have a non-nil - ;; LIMIT-SEARCH or FIND-AT-LEAST arg. In that case its value - ;; records the current position in the error list, and we must - ;; preserve that after reparsing. - (let ((error-list-pos compilation-error-list)) - (funcall compilation-parse-errors-function - limit-search - (and find-at-least - ;; We only need enough new parsed errors to reach - ;; FIND-AT-LEAST errors past the current - ;; position. - (- find-at-least (length compilation-error-list)))) - ;; Remember the entire list for compilation-forget-errors. If - ;; this is an incremental parse, append to previous list. If - ;; we are parsing anew, compilation-forget-errors cleared - ;; compilation-old-error-list above. - (setq compilation-old-error-list - (nconc compilation-old-error-list compilation-error-list)) - (if error-list-pos - ;; We started in the middle of an existing list of parsed - ;; errors before parsing more; restore that position. - (setq compilation-error-list error-list-pos)) - ;; Mouse-Highlight (the first line of) each error message when the - ;; mouse pointer moves over it: - (let ((inhibit-read-only t) - (buffer-undo-list t) - deactivate-mark - (buffer-was-modified (buffer-modified-p)) - (error-list compilation-error-list)) - (while error-list - (save-excursion - (add-text-properties (goto-char (car (car error-list))) - (progn (end-of-line) (point)) - '(mouse-face highlight help-echo "\ -mouse-2: visit this file and line"))) - (setq error-list (cdr error-list))) - (set-buffer-modified-p buffer-was-modified)) - ))))) - -(defun compile-mouse-goto-error (event) - "Visit the source for the error message the mouse is pointing at. -This is like `compile-goto-error' called without prefix arg -at the end of the line." - (interactive "e") - (save-excursion - (set-buffer (window-buffer (posn-window (event-end event)))) - (goto-char (posn-point (event-end event))) - - (or (compilation-buffer-p (current-buffer)) - (error "Not in a compilation buffer")) - (setq compilation-last-buffer (current-buffer)) - ;; `compile-reinitialize-errors' needs to see the complete filename - ;; on the line where they clicked the mouse. Since it only looks - ;; up to point, moving point to eol makes sure the filename is - ;; visible to `compile-reinitialize-errors'. - (end-of-line) - (compile-reinitialize-errors nil (point)) - - ;; Move to bol; the marker for the error on this line will point there. - (beginning-of-line) - - ;; Move compilation-error-list to the elt of compilation-old-error-list - ;; we want. - (setq compilation-error-list compilation-old-error-list) - (while (and compilation-error-list - ;; The marker can point nowhere if we previously - ;; failed to find the relevant file. See - ;; compilation-next-error-locus. - (or (null (marker-buffer (caar compilation-error-list))) - (and (> (point) (caar compilation-error-list)) - (>= (point) - ;; Don't skip too far: the text between - ;; two errors belongs to the first. This - ;; in-between text might be other errors - ;; on the same line (see - ;; compilation-skip-to-next-location). - (if (null (cdr compilation-error-list)) - compilation-parsing-end - (caar (cdr compilation-error-list))))))) - (setq compilation-error-list (cdr compilation-error-list))) - (or compilation-error-list - (error "No error to go to"))) - (select-window (posn-window (event-end event))) - - (push-mark) - (next-error 1)) - -(defun compile-goto-error (&optional argp) +(defun compile-goto-error () "Visit the source for the error message point is on. -Use this command in a compilation log buffer. Sets the mark at point there. -\\[universal-argument] as a prefix arg means to reparse the buffer's error messages first; -other kinds of prefix arguments are ignored." - (interactive "P") +Use this command in a compilation log buffer. Sets the mark at point there." + (interactive) (or (compilation-buffer-p (current-buffer)) (error "Not in a compilation buffer")) - (setq compilation-last-buffer (current-buffer)) - (compile-reinitialize-errors (consp argp) (point)) - - ;; Move to bol; the marker for the error on this line will point there. - (beginning-of-line) - - ;; Move compilation-error-list to the elt of compilation-old-error-list - ;; we want. - (setq compilation-error-list compilation-old-error-list) - (while (and compilation-error-list - ;; The marker can point nowhere if we previously - ;; failed to find the relevant file. See - ;; compilation-next-error-locus. - (or (null (marker-buffer (caar compilation-error-list))) - (and (> (point) (caar compilation-error-list)) - (>= (point) - ;; Don't skip too far: the text between - ;; two errors belongs to the first. This - ;; in-between text might be other errors - ;; on the same line (see - ;; compilation-skip-to-next-location). - (if (null (cdr compilation-error-list)) - compilation-parsing-end - (caar (cdr compilation-error-list))))))) - (setq compilation-error-list (cdr compilation-error-list))) - - (push-mark) - (next-error 1)) + (if (get-text-property (point) 'directory) + (dired-other-window (car (get-text-property (point) 'directory))) + (push-mark) + (next-error 0))) ;; Return a compilation buffer. ;; If the current buffer is a compilation buffer, return it. @@ -1401,16 +1368,11 @@ (error "No compilation started!"))))))) ;;;###autoload -(defun next-error (&optional argp) +(defun next-error (n) "Visit next compilation error message and corresponding source code. -If all the error messages parsed so far have been processed already, -the message buffer is checked for new ones. - A prefix ARGP specifies how many error messages to move; negative means move back to previous error messages. -Just \\[universal-argument] as a prefix means reparse the error message buffer -and start at the first error. \\[next-error] normally uses the most recently started compilation or grep buffer. However, it can operate on any buffer with output from @@ -1423,16 +1385,48 @@ it stays with that buffer until you use it in some other buffer which uses Compilation mode or Compilation Minor mode. -See variables `compilation-parse-errors-function' and -\`compilation-error-regexp-alist' for customization ideas." - (interactive "P") - (setq compilation-last-buffer (compilation-find-buffer)) - (compilation-goto-locus (compilation-next-error-locus - ;; We want to pass a number here only if - ;; we got a numeric prefix arg, not just C-u. - (and (not (consp argp)) - (prefix-numeric-value argp)) - (consp argp)))) +See variable `compilation-error-regexp-alist' for customization ideas." + (interactive "p") + (set-buffer (setq compilation-last-buffer (compilation-find-buffer))) + (let* ((columns compilation-error-screen-columns) ; buffer's local value + (last 1) + (loc (compilation-next-error n)) + (end-loc (nth 2 loc)) + (marker (point-marker))) + (setq loc (car loc)) + ;; If loc contains no marker, no error in that file has been visited. If + ;; the marker is invalid the buffer has been killed. So, recalculate all + ;; markers for that file. + (unless (and (nthcdr 3 loc) (marker-buffer (nth 3 loc))) + (save-excursion + (set-buffer (compilation-find-file marker (caar (nth 2 loc)) + (or (cdar (nth 2 loc)) + default-directory))) + (save-restriction + (widen) + (goto-char 1) + ;; Treat file's found lines in forward order, 1 by 1. + (dolist (line (reverse (cddr (nth 2 loc)))) + (when (car line) ; else this is a filename w/o a line# + (beginning-of-line (- (car line) last -1)) + (setq last (car line))) + ;; Treat line's found columns and store/update a marker for each. + (dolist (col (cdr line)) + (if (car col) + (if (eq (car col) -1) ; special case for range end + (end-of-line) + (if columns + (move-to-column (car col)) + (beginning-of-line) + (forward-char (car col)))) + (beginning-of-line) + (skip-chars-forward " \t")) + (if (nthcdr 3 col) + (set-marker (nth 3 col) (point)) + (setcdr (nthcdr 2 col) `(,(point-marker))))))))) + (compilation-goto-locus marker (nth 3 loc) (nth 3 end-loc)) + (setcdr (nthcdr 3 loc) t))) ; Set this one as visited. + ;;;###autoload (define-key ctl-x-map "`" 'next-error) (defun previous-error (argp) @@ -1445,224 +1439,102 @@ (interactive "P") (next-error (- (prefix-numeric-value argp)))) -(defun first-error () - "Reparse the error message buffer and start at the first error. +(defun first-error (arg) + "Restart at the first error. Visit corresponding source code. +With prefix ARG, visit the source code of the ARGth error. This operates on the output from the \\[compile] command." - (interactive) - (next-error '(4))) + (interactive "p") + (set-buffer (setq compilation-last-buffer (compilation-find-buffer))) + (goto-char (point-min)) + (next-error arg)) (defvar compilation-skip-to-next-location nil "*If non-nil, skip multiple error messages for the same source location.") -(defun compilation-next-error-locus (&optional move reparse silent) - "Visit next compilation error and return locus in corresponding source code. -This operates on the output from the \\[compile] command. -If all preparsed error messages have been processed, -the error message buffer is checked for new ones. +(defcustom compilation-skip-threshold 1 + "*Compilation motion commands skip less important messages. +The value can be either 2 -- skip anything less than error, 1 -- +skip anything less than warning or 0 -- don't skip any messages. +Note that all messages not positively identified as warning or +info, are considered errors." + :type '(choice (const :tag "Warnings and info" 2) + (const :tag "Info" 1) + (const :tag "None" 0)) + :group 'compilation) -Returns a cons (ERROR . SOURCE) of two markers: ERROR is a marker at the -location of the error message in the compilation buffer, and SOURCE is a -marker at the location in the source code indicated by the error message. - -Optional first arg MOVE says how many error messages to move forwards (or -backwards, if negative); default is 1. Optional second arg REPARSE, if -non-nil, says to reparse the error message buffer and reset to the first -error (plus MOVE - 1). If optional third argument SILENT is non-nil, return -nil instead of raising an error if there are no more errors. +(defcustom compilation-skip-visited nil + "*Compilation motion commands skip visited messages if this is t. +Visited messages are ones for which the file, line and column have been jumped +to from the current content in the current compilation buffer, even if it was +from a different message." + :type 'boolean + :group 'compilation) -The current buffer should be the desired compilation output buffer." - (or move (setq move 1)) - (compile-reinitialize-errors reparse nil (and (not reparse) (max 0 move))) - (let (next-errors next-error) - (catch 'no-next-error - (save-excursion - (set-buffer compilation-last-buffer) - ;; compilation-error-list points to the "current" error. - (setq next-errors - (if (> move 0) - (nthcdr (1- move) - compilation-error-list) - ;; Zero or negative arg; we need to move back in the list. - (let ((n (1- move)) - (i 0) - (e compilation-old-error-list)) - ;; See how many cdrs away the current error is from the start. - (while (not (eq e compilation-error-list)) - (setq i (1+ i) - e (cdr e))) - (if (> (- n) i) - (error "Moved back past first error") - (nthcdr (+ i n) compilation-old-error-list)))) - next-error (car next-errors)) - (while - (if (null next-error) - (progn - (and move (/= move 1) - (error (if (> move 0) - "Moved past last error") - "Moved back past first error")) - ;; Forget existing error messages if compilation has finished. - (if (not (and (get-buffer-process (current-buffer)) - (eq (process-status - (get-buffer-process - (current-buffer))) - 'run))) - (compilation-forget-errors)) - (if silent - (throw 'no-next-error nil) - (error (concat compilation-error-message - (and (get-buffer-process (current-buffer)) - (eq (process-status - (get-buffer-process - (current-buffer))) - 'run) - " yet"))))) - (setq compilation-error-list (cdr next-errors)) - (if (null (cdr next-error)) - ;; This error is boring. Go to the next. - t - (or (markerp (cdr next-error)) - ;; This error has a filename/lineno pair. - ;; Find the file and turn it into a marker. - (let* ((fileinfo (car (cdr next-error))) - (buffer (apply 'compilation-find-file - (car next-error) fileinfo))) - (if (null buffer) - ;; We can't find this error's file. - ;; Remove all errors in the same file. - (progn - (setq next-errors compilation-old-error-list) - (while next-errors - (and (consp (cdr (car next-errors))) - (equal (car (cdr (car next-errors))) - fileinfo) - (progn - (set-marker (car (car next-errors)) nil) - (setcdr (car next-errors) nil))) - (setq next-errors (cdr next-errors))) - ;; Look for the next error. - t) - ;; We found the file. Get a marker for this error. - ;; compilation-old-error-list and - ;; compilation-error-screen-columns are buffer-local - ;; so we must be careful to extract their value - ;; before switching to the source file buffer. - (let ((errors compilation-old-error-list) - (columns compilation-error-screen-columns) - (last-line (nth 1 (cdr next-error))) - (column (nth 2 (cdr next-error)))) - (set-buffer buffer) - (save-excursion - (save-restriction - (widen) - (goto-line last-line) - (if (and column (> column 0)) - ;; Columns in error msgs are 1-origin. - (if columns - (move-to-column (1- column)) - (forward-char (1- column))) - (beginning-of-line)) - (setcdr next-error (point-marker)) - ;; Make all the other error messages referring - ;; to the same file have markers into the buffer. - (while errors - (and (consp (cdr (car errors))) - (equal (car (cdr (car errors))) fileinfo) - (let* ((this (nth 1 (cdr (car errors)))) - (column (nth 2 (cdr (car errors)))) - (lines (- this last-line))) - (if (eq selective-display t) - ;; When selective-display is t, - ;; each C-m is a line boundary, - ;; as well as each newline. - (if (< lines 0) - (re-search-backward "[\n\C-m]" - nil 'end - (- lines)) - (re-search-forward "[\n\C-m]" - nil 'end - lines)) - (forward-line lines)) - (if (and column (> column 1)) - (if columns - (move-to-column (1- column)) - (forward-char (1- column))) - (beginning-of-line)) - (setq last-line this) - (setcdr (car errors) (point-marker)))) - (setq errors (cdr errors))))))))) - ;; If we didn't get a marker for this error, or this - ;; marker's buffer was killed, go on to the next one. - (or (not (markerp (cdr next-error))) - (not (marker-buffer (cdr next-error)))))) - (setq next-errors compilation-error-list - next-error (car next-errors))))) +(defcustom compilation-context-lines next-screen-context-lines + "*Display this many lines of leading context before message." + :type 'integer + :group 'compilation) - (if compilation-skip-to-next-location - ;; Skip over multiple error messages for the same source location, - ;; so the next C-x ` won't go to an error in the same place. - (while (and compilation-error-list - (equal (cdr (car compilation-error-list)) - (cdr next-error))) - (setq compilation-error-list (cdr compilation-error-list)))) +(defsubst compilation-set-window (w mk) + ;; Align the compilation output window W with marker MK near top. + (set-window-start w (save-excursion + (goto-char mk) + (beginning-of-line (- 1 compilation-context-lines)) + (point))) + (set-window-point w mk)) - ;; We now have a marker for the position of the error source code. - ;; NEXT-ERROR is a cons (ERROR . SOURCE) of two markers. - next-error)) - -(defun compilation-goto-locus (next-error) - "Jump to an error locus returned by `compilation-next-error-locus'. -Takes one argument, a cons (ERROR . SOURCE) of two markers. -Selects a window with point at SOURCE, with another window displaying ERROR." +(defun compilation-goto-locus (msg mk end-mk) + "Jump to an error MESSAGE and SOURCE. +All arguments are markers. If SOURCE-END is non nil, mark is set there." (if (eq (window-buffer (selected-window)) - (marker-buffer (car next-error))) + (marker-buffer msg)) ;; If the compilation buffer window is selected, ;; keep the compilation buffer in this window; ;; display the source in another window. (let ((pop-up-windows t)) - (pop-to-buffer (marker-buffer (cdr next-error)))) + (pop-to-buffer (marker-buffer mk))) (if (window-dedicated-p (selected-window)) - (pop-to-buffer (marker-buffer (cdr next-error))) - (switch-to-buffer (marker-buffer (cdr next-error))))) - (goto-char (cdr next-error)) - ;; If narrowing got in the way of - ;; going to the right place, widen. - (or (= (point) (marker-position (cdr next-error))) - (progn - (widen) - (goto-char (cdr next-error)))) + (pop-to-buffer (marker-buffer mk)) + (switch-to-buffer (marker-buffer mk)))) + ;; If narrowing gets in the way of going to the right place, widen. + (unless (eq (goto-char mk) (point)) + (widen) + (goto-char mk)) + (if end-mk + (push-mark end-mk nil t) + (if mark-active (setq mark-active))) ;; If hideshow got in the way of ;; seeing the right place, open permanently. - (mapcar (function (lambda (ov) - (when (eq 'hs (overlay-get ov 'invisible)) - (delete-overlay ov) - (goto-char (cdr next-error))))) - (overlays-at (point))) + (dolist (ov (overlays-at (point))) + (when (eq 'hs (overlay-get ov 'invisible)) + (delete-overlay ov) + (goto-char mk))) ;; Show compilation buffer in other window, scrolled to this error. (let* ((pop-up-windows t) ;; Use an existing window if it is in a visible frame. - (w (or (get-buffer-window (marker-buffer (car next-error)) 'visible) + (w (or (get-buffer-window (marker-buffer msg) 'visible) ;; Pop up a window. - (display-buffer (marker-buffer (car next-error))))) - (highlight-regexp (with-current-buffer (marker-buffer (car next-error)) + (display-buffer (marker-buffer msg)))) + (highlight-regexp (with-current-buffer (marker-buffer msg) + ;; also do this while we change buffer + (compilation-set-window w msg) compilation-highlight-regexp))) - (set-window-point w (car next-error)) - (set-window-start w (car next-error)) (compilation-set-window-height w) - (when highlight-regexp + (when (and highlight-regexp + (not (and end-mk transient-mark-mode))) (unless compilation-highlight-overlay (setq compilation-highlight-overlay (make-overlay 1 1)) (overlay-put compilation-highlight-overlay 'face 'region)) - (with-current-buffer (marker-buffer (cdr next-error)) + (with-current-buffer (marker-buffer mk) (save-excursion (end-of-line) (let ((end (point)) olay) (beginning-of-line) (if (and (stringp highlight-regexp) - (re-search-forward highlight-regexp end t)) + (re-search-forward highlight-regexp end t)) (progn (goto-char (match-beginning 0)) (move-overlay compilation-highlight-overlay (match-beginning 0) (match-end 0))) @@ -1700,14 +1572,10 @@ fmts (cdr fmts))) (setq dirs (cdr dirs))) (or buffer - ;; The file doesn't exist. - ;; Ask the user where to find it. - ;; If he hits C-g, then the next time he does - ;; next-error, he'll skip past it. - (let* ((pop-up-windows t) - (w (display-buffer (marker-buffer marker)))) - (set-window-point w marker) - (set-window-start w marker) + ;; The file doesn't exist. Ask the user where to find it. + (let ((pop-up-windows t)) + (compilation-set-window (display-buffer (marker-buffer marker)) + marker) (let ((name (expand-file-name (read-file-name (format "Find this error in: (default %s) " @@ -1736,7 +1604,7 @@ ;; by compile-abbreviate-directory). (file-name-absolute-p filename) (setq filename - (concat comint-file-name-prefix filename))) + (concat (with-no-warnings 'comint-file-name-prefix) filename))) ;; If compilation-parse-errors-filename-function is ;; defined, use it to process the filename. @@ -1753,305 +1621,6 @@ ;; up in the buffer. (setq filename (command-line-normalize-file-name filename))) -;; Set compilation-error-list to nil, and unchain the markers that point to the -;; error messages and their text, so that they no longer slow down gap motion. -;; This would happen anyway at the next garbage collection, but it is better to -;; do it right away. -(defun compilation-forget-errors () - (while compilation-old-error-list - (let ((next-error (car compilation-old-error-list))) - (set-marker (car next-error) nil) - (if (markerp (cdr next-error)) - (set-marker (cdr next-error) nil))) - (setq compilation-old-error-list (cdr compilation-old-error-list))) - (setq compilation-error-list nil - compilation-directory-stack (list default-directory)) - (if compilation-parsing-end - (set-marker compilation-parsing-end 1)) - ;; Remove the highlighting added by compile-reinitialize-errors: - (let ((inhibit-read-only t) - (buffer-undo-list t) - deactivate-mark) - (remove-text-properties (point-min) (point-max) - '(mouse-face highlight help-echo nil)))) - - -;; This function is not needed any more by compilation mode. -;; Does anyone else need it or can it be deleted? -(defun count-regexp-groupings (regexp) - "Return the number of \\( ... \\) groupings in REGEXP (a string)." - (let ((groupings 0) - (len (length regexp)) - (i 0) - c) - (while (< i len) - (setq c (aref regexp i) - i (1+ i)) - (cond ((= c ?\[) - ;; Find the end of this [...]. - (while (and (< i len) - (not (= (aref regexp i) ?\]))) - (setq i (1+ i)))) - ((= c ?\\) - (if (< i len) - (progn - (setq c (aref regexp i) - i (1+ i)) - (if (= c ?\)) - ;; We found the end of a grouping, - ;; so bump our counter. - (setq groupings (1+ groupings)))))))) - groupings)) - -(defvar compilation-current-file nil - "Used by `compilation-parse-errors' to store filename for file being compiled.") - -;; This variable is not used as a global variable. It's defined here just to -;; shut up the byte compiler. It's bound and used by compilation-parse-errors -;; and set by compile-collect-regexps. -(defvar compilation-regexps nil) - -(defun compilation-parse-errors (limit-search find-at-least) - "Parse the current buffer as grep, cc, lint or other error messages. -See variable `compilation-parse-errors-function' for the interface it uses." - (setq compilation-error-list nil) - (message "Parsing error messages...") - (if (null compilation-error-regexp-alist) - (error "compilation-error-regexp-alist is empty!")) - (let* ((compilation-regexps nil) ; Variable set by compile-collect-regexps. - (default-directory (car compilation-directory-stack)) - (found-desired nil) - (compilation-num-errors-found 0) - ;; Set up now the expanded, abbreviated directory variables - ;; that compile-abbreviate-directory will need, so we can - ;; compute them just once here. - (orig (abbreviate-file-name default-directory)) - (orig-expanded (abbreviate-file-name - (file-truename default-directory))) - (parent-expanded (abbreviate-file-name - (expand-file-name "../" orig-expanded)))) - - ;; Make a list of all the regexps. Each element has the form - ;; (REGEXP TYPE IDX1 IDX2 ...) - ;; where TYPE is one of leave, enter, file, error or nomessage. - (compile-collect-regexps 'leave compilation-leave-directory-regexp-alist) - (compile-collect-regexps 'enter compilation-enter-directory-regexp-alist) - (compile-collect-regexps 'file compilation-file-regexp-alist) - (compile-collect-regexps 'error compilation-error-regexp-alist) - (compile-collect-regexps 'nomessage compilation-nomessage-regexp-alist) - - ;; Don't reparse messages already seen at last parse. - (goto-char compilation-parsing-end) - (when (and (bobp) - (compilation-buffer-p (current-buffer))) - (setq compilation-current-file nil) ; No current file at start. - ;; Don't parse the first two lines as error messages. - ;; This matters for grep. - (forward-line 2)) - - ;; Parse messages. - (while (not (or found-desired (eobp) - ;; Don't parse the "compilation finished" message - ;; as a compilation error. - (get-text-property (point) 'compilation-handle-exit))) - (let ((this compilation-regexps) (prev nil) (alist nil) type) - ;; Go through the regular expressions. If a match is found, - ;; variable alist is set to the corresponding alist and the - ;; matching regexp is moved to the front of compilation-regexps - ;; to make it match faster next time. - (while (and this (null alist)) - (if (not (looking-at (car (car this)))) - (progn (setq prev this) ; No match, go to next. - (setq this (cdr this))) - (setq alist (cdr (car this))) ; Got a match. -;;; (if prev ; If not the first regexp, -;;; (progn ; move it to the front. -;;; (setcdr prev (cdr this)) -;;; (setcdr this compilation-regexps) -;;; (setq compilation-regexps this))) - )) - (if (and alist ; Seen a match and not to - (not (eq (setq type (car alist)) 'nomessage))) ; be ignored. - (let* ((end-of-match (match-end 0)) - (filename - (compile-buffer-substring (car (setq alist (cdr alist))))) - stack) - (if (eq type 'error) ; error message - (let* ((linenum (if (numberp (car (setq alist (cdr alist)))) - (string-to-int - (compile-buffer-substring (car alist))) - ;; (car alist) is not a number, must be a - ;; function that is called below to return - ;; an error position descriptor. - (car alist))) - ;; Convert to integer later if linenum not a function. - (column (compile-buffer-substring - (car (setq alist (cdr alist))))) - this-error) - - ;; Check that we have a file name. - (or filename - ;; No file name in message, we must have seen it before - (setq filename compilation-current-file) - (error "\ -An error message with no file name and no file name has been seen earlier")) - - ;; Clean up the file name string in several ways. - (setq filename (compilation-normalize-filename filename)) - - (setq filename - (cons filename (cons default-directory (cdr alist)))) - - ;; Locate the erring file and line. - ;; Make this-error a new elt for compilation-error-list, - ;; giving a marker for the current compilation buffer - ;; location, and the file and line number of the error. - ;; Save, as the start of the error, the beginning of the - ;; line containing the match. - (setq this-error - (if (numberp linenum) - (list (point-marker) filename linenum - (and column (string-to-int column))) - ;; If linenum is not a number then it must be - ;; a function returning an error position - ;; descriptor or nil (meaning no position). - (save-excursion - (funcall linenum filename column)))) - - ;; We have an error position descriptor. - ;; If we have found as many new errors as the user - ;; wants, or if we are past the buffer position he - ;; indicated, then we continue to parse until we have - ;; seen all consecutive errors in the same file. This - ;; means that all the errors of a source file will be - ;; seen in one parsing run, so that the error positions - ;; will be recorded as markers in the source file - ;; buffer that will move when the buffer is changed. - (if (and this-error - compilation-error-list ; At least one previous. - (or (and find-at-least - (>= compilation-num-errors-found - find-at-least)) - (and limit-search - (>= end-of-match limit-search))) - ;; `this-error' could contain a pair of - ;; markers already. - (let ((thispos (cdr this-error)) - (lastpos (cdar compilation-error-list))) - (not (equal - (if (markerp thispos) - (marker-buffer thispos) - (car thispos)) - (if (markerp lastpos) - (marker-buffer lastpos) - (car lastpos)))))) - ;; We are past the limits and the last error - ;; parsed, didn't belong to the same source file - ;; as the earlier ones i.e. we have seen all the - ;; errors belonging to the earlier file. We don't - ;; add the error just parsed so that the next - ;; parsing run can get it and the following errors - ;; in the same file all at once. - (setq found-desired t) - - (goto-char end-of-match) ; Prepare for next message. - ;; Don't add the same source line more than once. - (and this-error - (not (and - compilation-error-list - (equal (cdr (car compilation-error-list)) - (cdr this-error)))) - (setq compilation-error-list - (cons this-error compilation-error-list) - compilation-num-errors-found - (1+ compilation-num-errors-found))))) - - ;; Not an error message. - (if (eq type `file) ; Change current file. - (when filename - (setq compilation-current-file - ;; Clean up the file name string in several ways. - (compilation-normalize-filename filename))) - ;; Enter or leave directory. - (setq stack compilation-directory-stack) - ;; Don't check if it is really a directory. - ;; Let the code to search and clean up file names - ;; try to use it in any case. - (when filename - ;; Clean up the directory name string in several ways. - (setq filename (compilation-normalize-filename filename)) - (setq filename - ;; The directory name in the message - ;; is a truename. Try to convert it to a form - ;; like what the user typed in. - (compile-abbreviate-directory - (file-name-as-directory - (expand-file-name filename)) - orig orig-expanded parent-expanded)) - (if (eq type 'leave) - ;; If we are leaving a specific directory, - ;; as preparation, pop out of all other directories - ;; that we entered nested within it. - (while (and stack - (not (string-equal (car stack) - filename))) - (setq stack (cdr stack))) - (setq compilation-directory-stack - (cons filename compilation-directory-stack) - default-directory filename))) - (and (eq type 'leave) - stack - (setq compilation-directory-stack (cdr stack)) - (setq stack (car compilation-directory-stack)) - (setq default-directory stack))) - (goto-char end-of-match) ; Prepare to look at next message. - (and limit-search (>= end-of-match limit-search) - ;; The user wanted a specific error, and we're past it. - ;; We do this check here rather than at the end of the - ;; loop because if the last thing seen is an error - ;; message, we must carefully discard the last error - ;; when it is the first in a new file (see above in - ;; the error-message case) - (setq found-desired t))) - - ;; Go to before the last character in the message so that we will - ;; see the next line also when the message ended at end of line. - ;; When we ignore the last error message above, this will - ;; cancel the effect of forward-line below so that point - ;; doesn't move. - (forward-char -1) - - ;; Is this message necessary any more? Parsing is now so fast - ;; that you might not need to know how it proceeds. - (message - "Parsing error messages...%d found. %.0f%% of buffer seen." - compilation-num-errors-found - ;; Use floating-point because (* 100 (point)) frequently - ;; exceeds the range of Emacs Lisp integers. - (/ (* 100.0 (point)) (point-max))) - ))) - - (forward-line 1)) ; End of while loop. Look at next line. - - (set-marker compilation-parsing-end (point)) - (setq compilation-error-list (nreverse compilation-error-list)) - ;; (message "Parsing error messages...done. %d found. %.0f%% of buffer seen." - ;; compilation-num-errors-found - ;; (/ (* 100.0 (point)) (point-max))) - (message "Parsing error messages...done."))) - -(defun compile-collect-regexps (type this) - ;; Add elements to variable compilation-regexps that is bound in - ;; compilation-parse-errors. - (and (not (eq this t)) - (dolist (el this) - (push (cons (car el) (cons type (cdr el))) compilation-regexps)))) - -(defun compile-buffer-substring (index) - "Get substring matched by INDEXth subexpression." - (if index - (let ((beg (match-beginning index))) - (if beg (buffer-substring beg (match-end index)))))) ;; If directory DIR is a subdir of ORIG or of ORIG's parent, ;; return a relative name for it starting from ORIG or its parent. @@ -2085,7 +1654,7 @@ (substring dir (length parent-expanded))))) dir) -(add-to-list 'debug-ignored-errors "^No more errors\\( yet\\|\\)$") +(add-to-list 'debug-ignored-errors "^No more [-a-z ]+s yet$") (provide 'compile)
--- a/lisp/progmodes/grep.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/progmodes/grep.el Tue Mar 16 20:27:22 2004 +0000 @@ -194,6 +194,8 @@ "Keymap for grep buffers. `compilation-minor-mode-map' is a cdr of this.") +(defalias 'kill-grep 'kill-compilation) + ;;;; TODO --- refine this!! ;;; (defcustom grep-use-compilation-buffer t @@ -213,12 +215,39 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies `complation-last-buffer' rather than `grep-last-buffer'.") -;; Note: the character class after the optional drive letter does not -;; include a space to support file names with blanks. (defvar grep-regexp-alist - '(("\\([a-zA-Z]?:?.+?\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 2)) + '(("^\\(.+?\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 2) + ("^Binary file \\(.+\\) matches$" 1 nil nil 1)) "Regexp used to match grep hits. See `compilation-error-regexp-alist'.") +(defvar grep-error "grep hit" + "Message to print when no matches are found.") + +;; Reverse the colors because grep hits are not errors (though we jump there +;; with `next-error'), and unreadable files can't be gone to. +(defvar grep-hit-face compilation-info-face + "Face name to use for grep hits.") + +(defvar grep-error-face compilation-error-face + "Face name to use for grep error messages.") + +(defvar grep-mode-font-lock-keywords + '(;; Command output lines. + ("^\\([A-Za-z_0-9/\.+-]+\\)[ \t]*:" 1 font-lock-function-name-face) + (": \\(.+\\): \\(?:Permission denied\\|No such \\(?:file or directory\\|device or address\\)\\)$" + 1 grep-error-face) + ;; remove match from grep-regexp-alist before fontifying + ("^Grep finished \\(?:(\\(matches found\\))\\|with \\(no matches found\\)\\).*" + (0 '(face nil message nil help-echo nil mouse-face nil) t) + (1 grep-hit-face nil t) + (2 grep-error-face nil t)) + ("^Grep \\(exited abnormally\\) with code \\([0-9]+\\).*" + (0 '(face nil message nil help-echo nil mouse-face nil) t) + (1 compilation-warning-face) + (2 compilation-line-face))) + "Additional things to highlight in grep output. +This gets tacked on the end of the generated expressions.") + (defvar grep-program ;; Currently zgrep has trouble. It runs egrep instead of grep, ;; and it doesn't pass along long options right. @@ -251,9 +280,7 @@ (defun grep-process-setup () "Setup compilation variables and buffer for `grep'. -Set up `compilation-exit-message-function' and `compilation-window-height'. -Sets `grep-last-buffer' and runs `grep-setup-hook'." - (setq grep-last-buffer (current-buffer)) +Set up `compilation-exit-message-function' and run `grep-setup-hook'." (set (make-local-variable 'compilation-exit-message-function) (lambda (status code msg) (if (eq status 'exit) @@ -264,13 +291,6 @@ (t (cons msg code))) (cons msg code)))) - (if grep-window-height - (set (make-local-variable 'compilation-window-height) - grep-window-height)) - (set (make-local-variable 'compile-auto-highlight) - grep-auto-highlight) - (set (make-local-variable 'compilation-scroll-output) - grep-scroll-output) (run-hooks 'grep-setup-hook)) (defun grep-compute-defaults () @@ -402,15 +422,20 @@ ;; Setting process-setup-function makes exit-message-function work ;; even when async processes aren't supported. - (let* ((compilation-process-setup-function 'grep-process-setup) - (buf (compile-internal (if (and grep-use-null-device null-device) - (concat command-args " " null-device) - command-args) - "No more grep hits" "grep" - ;; Give it a simpler regexp to match. - nil grep-regexp-alist - nil nil nil nil nil nil - highlight-regexp grep-mode-map))))) + (let ((compilation-process-setup-function 'grep-process-setup)) + (compilation-start (if (and grep-use-null-device null-device) + (concat command-args " " null-device) + command-args) + 'grep-mode nil highlight-regexp))) + +;;;###autoload (autoload 'grep-mode "grep" nil t) +(define-compilation-mode grep-mode "Grep" + "Sets `grep-last-buffer' and `compilation-window-height'." + (setq grep-last-buffer (current-buffer)) + (set (make-local-variable 'compilation-error-face) + grep-hit-face) + (set (make-local-variable 'compilation-error-regexp-alist) + grep-regexp-alist)) ;; This is a copy of find-tag-default from etags.el. (defun grep-tag-default ()
--- a/lisp/ps-print.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/ps-print.el Tue Mar 16 20:27:22 2004 +0000 @@ -10,12 +10,12 @@ ;; Maintainer: Kenichi Handa <handa@etl.go.jp> (multi-byte characters) ;; Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Keywords: wp, print, PostScript -;; Time-stamp: <2004/02/29 00:07:55 vinicius> -;; Version: 6.6.3 +;; Time-stamp: <2004/03/10 18:57:00 vinicius> +;; Version: 6.6.4 ;; X-URL: http://www.cpqd.com.br/~vinicius/emacs/ -(defconst ps-print-version "6.6.3" - "ps-print.el, v 6.6.3 <2004/02/29 vinicius> +(defconst ps-print-version "6.6.4" + "ps-print.el, v 6.6.4 <2004/03/10 vinicius> Vinicius's last change version -- this file may have been edited as part of Emacs without changes to the version number. When reporting bugs, please also @@ -4141,6 +4141,11 @@ ;; Internal functions and variables +(defun ps-message-log-max () + (and (not (string= (buffer-name) "*Messages*")) + message-log-max)) + + (defvar ps-print-hook nil) (defvar ps-print-begin-sheet-hook nil) (defvar ps-print-begin-page-hook nil) @@ -4153,9 +4158,10 @@ (defun ps-spool-without-faces (from to &optional region-p) - (run-hooks 'ps-print-hook) - (ps-printing-region region-p from to) - (ps-generate (current-buffer) from to 'ps-generate-postscript)) + (let ((message-log-max (ps-message-log-max))) ; to print *Messages* buffer + (run-hooks 'ps-print-hook) + (ps-printing-region region-p from to) + (ps-generate (current-buffer) from to 'ps-generate-postscript))) (defun ps-print-with-faces (from to &optional filename region-p) @@ -4164,15 +4170,17 @@ (defun ps-spool-with-faces (from to &optional region-p) - (run-hooks 'ps-print-hook) - (ps-printing-region region-p from to) - (ps-generate (current-buffer) from to 'ps-generate-postscript-with-faces)) + (let ((message-log-max (ps-message-log-max))) ; to print *Messages* buffer + (run-hooks 'ps-print-hook) + (ps-printing-region region-p from to) + (ps-generate (current-buffer) from to 'ps-generate-postscript-with-faces))) (defun ps-count-lines-preprint (from to) - (or (and from to) - (error "The mark is not set now")) - (list (count-lines from to))) + (or (and from to) + (error "The mark is not set now")) + (let ((message-log-max (ps-message-log-max))) ; to count lines of *Messages* + (list (count-lines from to)))) (defun ps-count-lines (from to)
--- a/lisp/replace.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/replace.el Tue Mar 16 20:27:22 2004 +0000 @@ -916,7 +916,7 @@ (goto-char headerpt) (let ((beg (point)) end) - (insert (format "%d lines matching \"%s\" in buffer: %s\n" + (insert (format "%d matches for \"%s\" in buffer: %s\n" matches regexp (buffer-name buf))) (setq end (point)) (add-text-properties beg end
--- a/lisp/ruler-mode.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/ruler-mode.el Tue Mar 16 20:27:22 2004 +0000 @@ -94,6 +94,9 @@ ;; WARNING: To keep ruler graduations aligned on text columns it is ;; important to use the same font family and size for ruler and text ;; areas. +;; +;; You can override the ruler format by defining an appropriate +;; function as the buffer-local value of `ruler-mode-ruler-function'. ;; Installation ;; @@ -108,6 +111,8 @@ ;;; Code: (eval-when-compile (require 'wid-edit)) +(require 'scroll-bar) +(require 'fringe) (defgroup ruler-mode nil "Display a ruler in the header line." @@ -294,46 +299,6 @@ "Face used to highlight the `current-column' character." :group 'ruler-mode) -(defsubst ruler-mode-left-fringe-cols (&optional real) - "Return the width, measured in columns, of the left fringe area. -If optional argument REAL is non-nil, return a real floating point -number instead of a rounded integer value." - (funcall (if real '/ 'ceiling) - (or (car (window-fringes)) 0) - (float (frame-char-width)))) - -(defsubst ruler-mode-right-fringe-cols (&optional real) - "Return the width, measured in columns, of the right fringe area. -If optional argument REAL is non-nil, return a real floating point -number instead of a rounded integer value." - (funcall (if real '/ 'ceiling) - (or (nth 1 (window-fringes)) 0) - (float (frame-char-width)))) - -(defun ruler-mode-scroll-bar-cols (side) - "Return the width, measured in columns, of the vertical scrollbar on SIDE. -SIDE must be the symbol `left' or `right'." - (let* ((wsb (window-scroll-bars)) - (vtype (nth 2 wsb)) - (cols (nth 1 wsb))) - (cond - ((not (memq side '(left right))) - (error "`left' or `right' expected instead of %S" side)) - ((and (eq vtype side) cols)) - ((eq (frame-parameter nil 'vertical-scroll-bars) side) - ;; nil means it's a non-toolkit scroll bar, and its width in - ;; columns is 14 pixels rounded up. - (ceiling (or (frame-parameter nil 'scroll-bar-width) 14) - (frame-char-width))) - (0)))) - -(defmacro ruler-mode-right-scroll-bar-cols () - "Return the width, measured in columns, of the right vertical scrollbar." - '(ruler-mode-scroll-bar-cols 'right)) - -(defmacro ruler-mode-left-scroll-bar-cols () - "Return the width, measured in columns, of the left vertical scrollbar." - '(ruler-mode-scroll-bar-cols 'left)) (defsubst ruler-mode-full-window-width () "Return the full width of the selected window." @@ -346,8 +311,8 @@ (- n (car (window-edges)) (or (car (window-margins)) 0) - (ruler-mode-left-fringe-cols) - (ruler-mode-left-scroll-bar-cols))) + (fringe-columns 'left) + (scroll-bar-columns 'left))) (defun ruler-mode-mouse-set-left-margin (start-event) "Set left margin end to the graduation where the mouse pointer is on. @@ -360,10 +325,10 @@ (save-selected-window (select-window (posn-window start)) (setq col (- (car (posn-col-row start)) (car (window-edges)) - (ruler-mode-left-scroll-bar-cols)) + (scroll-bar-columns 'left)) w (- (ruler-mode-full-window-width) - (ruler-mode-left-scroll-bar-cols) - (ruler-mode-right-scroll-bar-cols))) + (scroll-bar-columns 'left) + (scroll-bar-columns 'right))) (when (and (>= col 0) (< col w)) (setq lm (window-margins) rm (or (cdr lm) 0) @@ -382,10 +347,10 @@ (save-selected-window (select-window (posn-window start)) (setq col (- (car (posn-col-row start)) (car (window-edges)) - (ruler-mode-left-scroll-bar-cols)) + (scroll-bar-columns 'left)) w (- (ruler-mode-full-window-width) - (ruler-mode-left-scroll-bar-cols) - (ruler-mode-right-scroll-bar-cols))) + (scroll-bar-columns 'left) + (scroll-bar-columns 'right))) (when (and (>= col 0) (< col w)) (setq lm (window-margins) rm (or (cdr lm) 0) @@ -568,9 +533,17 @@ "Hold previous value of `header-line-format'.") (make-variable-buffer-local 'ruler-mode-header-line-format-old) +(defvar ruler-mode-ruler-function nil + "If non-nil, function to call to return ruler string. +This variable is expected to be made buffer-local by modes.") + (defconst ruler-mode-header-line-format - '(:eval (ruler-mode-ruler)) - "`header-line-format' used in ruler mode.") + '(:eval (funcall (if ruler-mode-ruler-function + ruler-mode-ruler-function + 'ruler-mode-ruler))) + "`header-line-format' used in ruler mode. +If the non-nil value for ruler-mode-ruler-function is given, use it. +Else use `ruler-mode-ruler' is used as default value.") ;;;###autoload (define-minor-mode ruler-mode @@ -657,11 +630,11 @@ (when ruler-mode (let* ((w (window-width)) (m (window-margins)) - (lsb (ruler-mode-left-scroll-bar-cols)) - (lf (ruler-mode-left-fringe-cols t)) + (lsb (scroll-bar-columns 'left)) + (lf (fringe-columns 'left t)) (lm (or (car m) 0)) - (rsb (ruler-mode-right-scroll-bar-cols)) - (rf (ruler-mode-right-fringe-cols t)) + (rsb (scroll-bar-columns 'right)) + (rf (fringe-columns 'right t)) (rm (or (cdr m) 0)) (ruler (make-string w ruler-mode-basic-graduation-char)) (i 0)
--- a/lisp/scroll-bar.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/scroll-bar.el Tue Mar 16 20:27:22 2004 +0000 @@ -54,6 +54,23 @@ ;; with a large scroll bar portion can easily overflow a lisp int. (truncate (/ (* (float (car num-denom)) whole) (cdr num-denom)))) +(defun scroll-bar-columns (side) + "Return the width, measured in columns, of the vertical scrollbar on SIDE. +SIDE must be the symbol `left' or `right'." + (let* ((wsb (window-scroll-bars)) + (vtype (nth 2 wsb)) + (cols (nth 1 wsb))) + (cond + ((not (memq side '(left right))) + (error "`left' or `right' expected instead of %S" side)) + ((and (eq vtype side) cols)) + ((eq (frame-parameter nil 'vertical-scroll-bars) side) + ;; nil means it's a non-toolkit scroll bar, and its width in + ;; columns is 14 pixels rounded up. + (ceiling (or (frame-parameter nil 'scroll-bar-width) 14) + (frame-char-width))) + (0)))) + ;;;; Helpful functions for enabling and disabling scroll bars.
--- a/lisp/server.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/server.el Tue Mar 16 20:27:22 2004 +0000 @@ -177,8 +177,10 @@ are done with it in the server.") (make-variable-buffer-local 'server-existing-buffer) -(defvar server-socket-name - (format "/tmp/emacs%d/server" (user-uid))) +(defvar server-name "server") + +(defvar server-socket-dir + (format "/tmp/emacs%d" (user-uid))) (defun server-log (string &optional client) "If a *server* buffer exists, write STRING to it for logging purposes." @@ -330,12 +332,14 @@ Prefix arg means just kill any existing server communications subprocess." (interactive "P") ;; Make sure there is a safe directory in which to place the socket. - (server-ensure-safe-dir (file-name-directory server-socket-name)) + (server-ensure-safe-dir server-socket-dir) ;; kill it dead! (if server-process (condition-case () (delete-process server-process) (error nil))) ;; Delete the socket files made by previous server invocations. - (condition-case () (delete-file server-socket-name) (error nil)) + (condition-case () + (delete-file (expand-file-name server-name server-socket-dir)) + (error nil)) ;; If this Emacs already had a server, clear out associated status. (while server-clients (let ((buffer (nth 1 (car server-clients)))) @@ -355,7 +359,7 @@ (setq server-process (make-network-process :name "server" :family 'local :server t :noquery t - :service server-socket-name + :service (expand-file-name server-name server-socket-dir) :sentinel 'server-sentinel :filter 'server-process-filter ;; We must receive file names without being decoded. ;; Those are decoded by server-process-filter according
--- a/lisp/smerge-mode.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/smerge-mode.el Tue Mar 16 20:27:22 2004 +0000 @@ -1,10 +1,9 @@ ;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts -;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 01, 03, 2004 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@cs.yale.edu> -;; Keywords: merge diff3 cvs conflict -;; Revision: $Id: smerge-mode.el,v 1.24 2003/10/06 16:34:59 fx Exp $ +;; Keywords: revision-control merge diff3 cvs conflict ;; This file is part of GNU Emacs. @@ -137,26 +136,67 @@ `((,smerge-command-prefix . ,smerge-basic-map)) "Keymap for `smerge-mode'.") +(defvar smerge-check-cache nil) +(make-variable-buffer-local 'smerge-check-cache) +(defun smerge-check (n) + (condition-case nil + (let ((state (cons (point) (buffer-modified-tick)))) + (unless (equal (cdr smerge-check-cache) state) + (smerge-match-conflict) + (setq smerge-check-cache (cons (match-data) state))) + (nth (* 2 n) (car smerge-check-cache))) + (error nil))) + (easy-menu-define smerge-mode-menu smerge-mode-map "Menu for `smerge-mode'." '("SMerge" ["Next" smerge-next :help "Go to next conflict"] ["Previous" smerge-prev :help "Go to previous conflict"] - ["Keep All" smerge-keep-all :help "Keep all three versions"] - ["Revert to Base" smerge-keep-base :help "Revert to base version"] - ["Keep Other" smerge-keep-other :help "Keep `other' version"] - ["Keep Yours" smerge-keep-mine :help "Keep your version"] - ["Keep Current" smerge-keep-current :help "Use current (at point) version"] + "--" + ["Keep All" smerge-keep-all :help "Keep all three versions" + :active (smerge-check 1)] + ["Keep Current" smerge-keep-current :help "Use current (at point) version" + :active (and (smerge-check 1) (> (smerge-get-current) 0))] + "--" + ["Revert to Base" smerge-keep-base :help "Revert to base version" + :active (smerge-check 2)] + ["Keep Other" smerge-keep-other :help "Keep `other' version" + :active (smerge-check 3)] + ["Keep Yours" smerge-keep-mine :help "Keep your version" + :active (smerge-check 1)] "--" ["Diff Base/Mine" smerge-diff-base-mine - :help "Diff `base' and `mine' for current conflict"] + :help "Diff `base' and `mine' for current conflict" + :active (smerge-check 2)] ["Diff Base/Other" smerge-diff-base-other - :help "Diff `base' and `other' for current conflict"] + :help "Diff `base' and `other' for current conflict" + :active (smerge-check 2)] ["Diff Mine/Other" smerge-diff-mine-other - :help "Diff `mine' and `other' for current conflict"] + :help "Diff `mine' and `other' for current conflict" + :active (smerge-check 1)] "--" ["Invoke Ediff" smerge-ediff - :help "Use Ediff to resolve the conflicts"] + :help "Use Ediff to resolve the conflicts" + :active (smerge-check 1)] + ["Auto Resolve" smerge-resolve + :help "Use mode-provided resolution function" + :active (and (smerge-check 1) (local-variable-p 'smerge-resolve-function))] + ["Combine" smerge-combine-with-next + :help "Combine current conflict with next" + :active (smerge-check 1)] + )) + +(easy-mmode-defmap smerge-context-menu-map + `(([down-mouse-3] . smerge-activate-context-menu)) + "Keymap for context menu appeared on conflicts area.") +(easy-menu-define smerge-context-menu nil + "Context menu for mine area in `smerge-mode'." + '(nil + ["Keep Current" smerge-keep-current :help "Use current (at point) version"] + ["Kill Current" smerge-kill-current :help "Remove current (at point) version"] + ["Keep All" smerge-keep-all :help "Keep all three versions"] + "---" + ["More..." (popup-menu smerge-mode-menu) :help "Show full SMerge mode menu"] )) (defconst smerge-font-lock-keywords @@ -255,12 +295,53 @@ The function is called with no argument and with the match data set according to `smerge-match-conflict'.") +(defvar smerge-text-properties + `(help-echo "merge conflict: mouse-3 shows a menu" + ;; mouse-face highlight + keymap (keymap (down-mouse-3 . smerge-popup-context-menu)))) + +(defun smerge-remove-props (&optional beg end) + (remove-text-properties + (or beg (match-beginning 0)) + (or end (match-end 0)) + smerge-text-properties)) + +(defun smerge-popup-context-menu (event) + "Pop up the Smerge mode context menu under mouse." + (interactive "e") + (if (and smerge-mode + (save-excursion (mouse-set-point event) (smerge-check 1))) + (progn + (mouse-set-point event) + (smerge-match-conflict) + (let ((i (smerge-get-current)) + o) + (if (<= i 0) + ;; Out of range + (popup-menu smerge-mode-menu) + ;; Install overlay. + (setq o (make-overlay (match-beginning i) (match-end i))) + (overlay-put o 'face 'highlight) + (sit-for 0) + (popup-menu (if (smerge-check 2) + smerge-mode-menu + smerge-context-menu)) + ;; Delete overlay. + (delete-overlay o)))) + ;; There's no conflict at point, the text-props are just obsolete. + (save-excursion + (let ((beg (re-search-backward smerge-end-re nil t)) + (end (re-search-forward smerge-begin-re nil t))) + (smerge-remove-props (or beg (point-min)) (or end (point-max))) + (push event unread-command-events))))) + (defun smerge-resolve () "Resolve the conflict at point intelligently. This relies on mode-specific knowledge and thus only works in some major modes. Uses `smerge-resolve-function' to do the actual work." (interactive) (smerge-match-conflict) + (smerge-remove-props) (funcall smerge-resolve-function) (smerge-auto-leave)) @@ -269,6 +350,7 @@ (interactive) (smerge-match-conflict) (smerge-ensure-match 2) + (smerge-remove-props) (replace-match (match-string 2) t t) (smerge-auto-leave)) @@ -277,6 +359,7 @@ (interactive) (smerge-match-conflict) ;;(smerge-ensure-match 3) + (smerge-remove-props) (replace-match (match-string 3) t t) (smerge-auto-leave)) @@ -285,22 +368,41 @@ (interactive) (smerge-match-conflict) ;;(smerge-ensure-match 1) + (smerge-remove-props) (replace-match (match-string 1) t t) (smerge-auto-leave)) +(defun smerge-get-current () + (let ((i 3)) + (while (or (not (match-end i)) + (< (point) (match-beginning i)) + (>= (point) (match-end i))) + (decf i)) + i)) + (defun smerge-keep-current () "Use the current (under the cursor) version." (interactive) (smerge-match-conflict) - (let ((i 3)) - (while (or (not (match-end i)) - (< (point) (match-beginning i)) - (>= (point) (match-end i))) - (decf i)) + (let ((i (smerge-get-current))) (if (<= i 0) (error "Not inside a version") + (smerge-remove-props) (replace-match (match-string i) t t) (smerge-auto-leave)))) +(defun smerge-kill-current () + "Remove the current (under the cursor) version." + (interactive) + (smerge-match-conflict) + (let ((i (smerge-get-current))) + (if (<= i 0) (error "Not inside a version") + (smerge-remove-props) + (replace-match (mapconcat + (lambda (j) + (match-string j)) + (remove i '(1 2 3)) "") t t) + (smerge-auto-leave)))) + (defun smerge-diff-base-mine () "Diff 'base' and 'mine' version in current conflict region." (interactive) @@ -357,20 +459,28 @@ (setq mine-end (match-beginning 0)) (setq base-start (match-end 0))) - ((string= filename (file-name-nondirectory - (or buffer-file-name ""))) - ;; a 2-parts conflict - (set (make-local-variable 'smerge-conflict-style) 'diff3-E)) + ((string= filename (file-name-nondirectory + (or buffer-file-name ""))) + ;; a 2-parts conflict + (set (make-local-variable 'smerge-conflict-style) 'diff3-E)) - ((and (not base-start) - (or (eq smerge-conflict-style 'diff3-A) - (string-match "^[.0-9]+\\'" filename))) - ;; a same-diff conflict - (setq base-start mine-start) - (setq base-end mine-end) - (setq mine-start other-start) - (setq mine-end other-end))) + ((and (not base-start) + (or (eq smerge-conflict-style 'diff3-A) + (equal filename "ANCESTOR") + (string-match "\\`[.0-9]+\\'" filename))) + ;; a same-diff conflict + (setq base-start mine-start) + (setq base-end mine-end) + (setq mine-start other-start) + (setq mine-end other-end))) + (let ((inhibit-read-only t) + (inhibit-modification-hooks t) + (m (buffer-modified-p))) + (unwind-protect + (add-text-properties start end smerge-text-properties) + (restore-buffer-modified-p m))) + (store-match-data (list start end mine-start mine-end base-start base-end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc-arch.el Tue Mar 16 20:27:22 2004 +0000 @@ -0,0 +1,243 @@ +;;; vc-arch.el --- VC backend for the Arch version-control system + +;; Copyright (C) 1995,98,99,2000,01,02,03,2004 Free Software Foundation, Inc. + +;; Author: FSF (see vc.el for full credits) +;; Maintainer: Stefan Monnier <monnier@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The home page of the Arch version control system is at +;; +;; http://www.gnuarch.org/ +;; +;; This is derived from vc-mcvs.el as follows: +;; - cp vc-mcvs.el vc-arch.el and then M-% mcvs RET arch RET +;; +;; Then of course started the hacking. +;; +;; What has been partly tested: +;; - Open a file +;; - C-x v = without any prefix arg +;; - C-x v v to commit a change to a single file + +;; Bugs: + +;; - All files under the tree are considered as "under Arch's control" +;; without regards to =tagging-method and such. +;; - Files are always considered as `edited'. +;; - C-x v i does not work. +;; - VC-dired does not work. +;; - And more... + +;;; Code: + +(eval-when-compile (require 'vc)) + +;;; +;;; Customization options +;;; + +(defvar vc-arch-command + (let ((candidates '("tla"))) + (while (and candidates (not (executable-find (car candidates)))) + (setq candidates (cdr candidates))) + (or (car candidates) "tla"))) + +;; Clear up the cache to force vc-call to check again and discover +;; new functions when we reload this file. +(put 'Arch 'vc-functions nil) + +;;;###autoload (defun vc-arch-registered (file) +;;;###autoload (let ((dir file)) +;;;###autoload (while (and (stringp dir) +;;;###autoload (not (equal +;;;###autoload dir (setq dir (file-name-directory dir)))) +;;;###autoload dir) +;;;###autoload (setq dir (if (file-directory-p +;;;###autoload (expand-file-name "{arch}" dir)) +;;;###autoload t (directory-file-name dir)))) +;;;###autoload (if (eq dir t) +;;;###autoload (progn +;;;###autoload (load "vc-arch") +;;;###autoload (vc-arch-registered file))))) + +(defun vc-arch-add-tag () + "Add an `arch-tag' to the end of the current file." + (interactive) + (goto-char (point-max)) + (forward-comment -1) + (unless (bolp) (insert "\n")) + (let ((beg (point))) + (insert "arch-tag: ") + (call-process "uuidgen" nil t) ;Also inserts a terminal newline. + (comment-region beg (point)))) + +(defun vc-arch-root (file) + "Return the root directory of a Arch project, if any." + (or (vc-file-getprop file 'arch-root) + (vc-file-setprop + file 'arch-root + (let ((root nil)) + (while (not (or root + (equal file (setq file (file-name-directory file))) + (null file))) + (if (file-directory-p (expand-file-name "{arch}" file)) + (setq root file) + (setq file (directory-file-name file)))) + root)))) + +(defun vc-arch-registered (file) + ;; Don't check whether it's source or not. Checking would require + ;; running TLA, so it's better to not do it, so it also works if TLA is + ;; not installed. + (vc-arch-root file)) + +(defun vc-arch-default-version (file) + (or (vc-file-getprop (vc-arch-root file) 'arch-default-version) + (let* ((root (vc-arch-root file)) + (f (expand-file-name "{arch}/++default-version" root))) + (if (file-readable-p f) + (vc-file-setprop + root 'arch-default-version + (with-temp-buffer + (insert-file-contents f) + ;; Strip the terminating newline. + (buffer-substring (point-min) (1- (point-max))))))))) + +(defun vc-arch-state (file) + ;; There's no checkout operation and merging is not done from VC + ;; so the only operation that's state dependent that VC supports is commit + ;; which is only activated if the file is `edited'. + 'edited) + +(defun vc-arch-workfile-version (file) + (let* ((root (expand-file-name "{arch}" (vc-arch-root file))) + (defbranch (vc-arch-default-version file))) + (when (and defbranch (string-match "\\`\\(.+@[^/\n]+\\)/\\(\\(\\(.*\\)--.*\\)--.*\\)\\'" defbranch)) + (let* ((archive (match-string 1 defbranch)) + (category (match-string 4 defbranch)) + (branch (match-string 3 defbranch)) + (version (match-string 2 defbranch)) + (rev-nb 0) + (rev nil) + logdir tmp) + (setq logdir (expand-file-name category root)) + (setq logdir (expand-file-name branch logdir)) + (setq logdir (expand-file-name version logdir)) + (setq logdir (expand-file-name archive logdir)) + (setq logdir (expand-file-name "patch-log" logdir)) + (dolist (file (directory-files logdir)) + (if (and (string-match "-\\([0-9]+\\)\\'" file) + (setq tmp (string-to-number (match-string 1 file))) + (>= tmp rev-nb)) + (setq rev-nb tmp rev file))) + (concat defbranch "--" rev))))) + + +(defcustom vc-arch-mode-line-rewrite + '(("\\`.*--\\(.*--.*\\)--.*-\\([0-9]+\\)\\'" . "\\2[\\1]")) + "Rewrite rules to shorten Arch's revision names on the mode-line." + :type '(repeat (cons regexp string))) + +(defun vc-arch-mode-line-string (file) + "Return string for placement in modeline by `vc-mode-line' for FILE." + (let ((rev (vc-workfile-version file))) + (dolist (rule vc-arch-mode-line-rewrite) + (if (string-match (car rule) rev) + (setq rev (replace-match (cdr rule) t nil rev)))) + (format "Arch%c%s" + (if (memq (vc-state file) '(up-to-date needs-patch)) ?- ?:) + rev))) + +(defun vc-arch-diff3-rej-p (rej) + (and (eq (nth 7 (file-attributes rej)) 56) + (with-temp-buffer + (insert-file-contents rej) + (goto-char (point-min)) + (looking-at "Conflicts occured, diff3 conflict markers left in file\\.$")))) + +(defun vc-arch-delete-rej-if-obsolete () + "For use in `write-file-functions'." + (let ((rej (concat buffer-file-name ".rej"))) + (when (and buffer-file-name (vc-arch-diff3-rej-p rej)) + (if (not (re-search-forward "^>>>>>>> " nil t)) + ;; The .rej file is obsolete. + (condition-case nil (delete-file rej) (error nil))))) + ;; This did not save the buffer. + nil) + +(defun vc-arch-find-file-hook () + (let ((rej (concat buffer-file-name ".rej"))) + (when (and buffer-file-name (file-exists-p rej)) + (if (vc-arch-diff3-rej-p rej) + (save-excursion + (goto-char (point-min)) + (if (not (re-search-forward "^>>>>>>> " nil t)) + ;; The .rej file is obsolete. + (condition-case nil (delete-file rej) (error nil)) + (smerge-mode 1) + (add-hook 'write-file-functions + 'vc-arch-delete-rej-if-obsolete nil t) + (message "There are unresolved conflicts in this file"))) + (message "There are unresolved conflicts in %s" + (file-name-nondirectory rej)))))) + +(defun vc-arch-checkout-model (file) 'implicit) + +(defun vc-arch-checkin (file rev comment) + (if rev (error "Committing to a specific revision is unsupported.")) + (vc-arch-command nil 0 file "commit" "-L" comment "--" + (vc-switches 'Arch 'checkin))) + +(defun vc-arch-diff (file &optional oldvers newvers) + "Get a difference report using Arch between two versions of FILE." + (if newvers + (error "Diffing specific revisions not implemented.") + (let* ((async (fboundp 'start-process)) + ;; Run the command from the root dir. + (default-directory (vc-arch-root file)) + (status + (vc-arch-command + "*vc-diff*" + (if async 'async 1) + nil "file-diffs" + ;; Arch does not support the typical flags. + ;; (vc-switches 'Arch 'diff) + (file-relative-name file) + (if (equal oldvers (vc-workfile-version file)) + nil + oldvers)))) + (if async 1 status)))) ; async diff, pessimistic assumption. + +(defun vc-arch-delete-file (file) + (vc-arch-command nil 0 file "rm")) + +(defun vc-arch-rename-file (old new) + (vc-arch-command nil 0 new "mv" (file-relative-name old))) + +(defun vc-arch-command (buffer okstatus file &rest flags) + "A wrapper around `vc-do-command' for use in vc-arch.el." + (apply 'vc-do-command buffer okstatus vc-arch-command file flags)) + +(provide 'vc-arch) + +;;; arch-tag: a35c7c1c-5237-429d-88ef-3d718fd2e704 +;;; vc-arch.el ends here
--- a/lisp/vc-hooks.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/vc-hooks.el Tue Mar 16 20:27:22 2004 +0000 @@ -1,12 +1,12 @@ ;;; vc-hooks.el --- resident support for version-control -;; Copyright (C) 1992,93,94,95,96,98,99,2000,2003 +;; Copyright (C) 1992,93,94,95,96,98,99,2000,03,2004 ;; Free Software Foundation, Inc. ;; Author: FSF (see vc.el for full credits) ;; Maintainer: Andre Spiegel <spiegel@gnu.org> -;; $Id: vc-hooks.el,v 1.160 2003/09/01 15:45:17 miles Exp $ +;; $Id: vc-hooks.el,v 1.161 2004/03/15 03:53:05 monnier Exp $ ;; This file is part of GNU Emacs. @@ -52,7 +52,8 @@ (defvar vc-header-alist ()) (make-obsolete-variable 'vc-header-alist 'vc-BACKEND-header) -(defcustom vc-handled-backends '(RCS CVS SVN MCVS SCCS) +(defcustom vc-handled-backends '(RCS CVS SVN SCCS Arch MCVS) + ;; Arch and MCVS come last because they are per-tree rather than per-dir. "*List of version control backends for which VC will be used. Entries in this list will be tried in order to determine whether a file is under that sort of version control. @@ -698,6 +699,9 @@ (set-buffer true-buffer) (kill-buffer this-buffer)))) +(defun vc-default-find-file-hook (backend) + nil) + (defun vc-find-file-hook () "Function for `find-file-hook' activating VC mode if appropriate." ;; Recompute whether file is version controlled, @@ -713,7 +717,9 @@ (unless vc-make-backup-files ;; Use this variable, not make-backup-files, ;; because this is for things that depend on the file name. - (set (make-local-variable 'backup-inhibited) t))) + (set (make-local-variable 'backup-inhibited) t)) + ;; Let the backend setup any buffer-local things he needs. + (vc-call-backend (vc-backend buffer-file-name) 'find-file-hook)) ((let* ((link (file-symlink-p buffer-file-name)) (link-type (and link (vc-backend (file-chase-links link))))) (cond ((not link-type) nil) ;Nothing to do.
--- a/lisp/vc.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/vc.el Tue Mar 16 20:27:22 2004 +0000 @@ -7,7 +7,7 @@ ;; Maintainer: Andre Spiegel <spiegel@gnu.org> ;; Keywords: tools -;; $Id: vc.el,v 1.367 2004/02/08 22:42:42 uid65629 Exp $ +;; $Id: vc.el,v 1.368 2004/03/15 03:55:24 monnier Exp $ ;; This file is part of GNU Emacs. @@ -432,6 +432,10 @@ ;; repository. If this function is not provided, the renaming ;; will be done by (vc-delete-file old) and (vc-register new). ;; +;; - find-file-hook () +;; +;; Operation called in current buffer when opening a new file. This can +;; be used by the backend to setup some local variables it might need. ;;; Code:
--- a/lisp/woman.el Thu Mar 11 02:31:12 2004 +0000 +++ b/lisp/woman.el Tue Mar 16 20:27:22 2004 +0000 @@ -832,10 +832,15 @@ :type 'boolean :group 'woman-formatting) -(defcustom woman-preserve-ascii nil - "*If non-nil then preserve ASCII characters in the WoMan buffer. -Otherwise, non-ASCII characters (that display as ASCII) may remain. -This is irrelevant unless the buffer is to be saved to a file." +(defcustom woman-preserve-ascii t + "*If non-nil, preserve ASCII characters in the WoMan buffer. +Otherwise, to save time, some backslashes and spaces may be +represented differently (as the values of the variables +`woman-escaped-escape-char' and `woman-unpadded-space-char' +respectively) so that the buffer content is strictly wrong even though +it should display correctly. This should be irrelevant unless the +buffer text is searched, copied or saved to a file." + ;; This option should probably be removed! :type 'boolean :group 'woman-formatting)
--- a/lispref/ChangeLog Thu Mar 11 02:31:12 2004 +0000 +++ b/lispref/ChangeLog Tue Mar 16 20:27:22 2004 +0000 @@ -1,3 +1,18 @@ +2004-03-14 Luc Teirlinck <teirllm@auburn.edu> + + * intro.texi (Lisp History): Replace xref to `cl' manual with + inforef. + +2004-03-12 Richard M. Stallman <rms@gnu.org> + + * intro.texi (Version Info): Add arg to emacs-version. + (Lisp History): Change xref to CL manual. + +2004-03-09 Luc Teirlinck <teirllm@auburn.edu> + + * minibuf.texi (Completion Commands): Add xref to Emacs manual + for Partial Completion mode. + 2004-03-07 Thien-Thi Nguyen <ttn@gnu.org> * customize.texi: Fix typo. Remove eol whitespace.
--- a/lispref/intro.texi Thu Mar 11 02:31:12 2004 +0000 +++ b/lispref/intro.texi Tue Mar 16 20:27:22 2004 +0000 @@ -132,8 +132,7 @@ @pindex cl A certain amount of Common Lisp emulation is available via the -@file{cl} library. @xref{Top,, Common Lisp Extension, cl, Common Lisp -Extensions}. +@file{cl} library. @inforef{Top, Overview, cl}. Emacs Lisp is not at all influenced by Scheme; but the GNU project has an implementation of Scheme, called Guile. We use Guile in all new GNU @@ -476,7 +475,7 @@ These facilities provide information about which version of Emacs is in use. -@deffn Command emacs-version +@deffn Command emacs-version &optional here This function returns a string describing the version of Emacs that is running. It is useful to include this string in bug reports. @@ -488,8 +487,10 @@ @end group @end smallexample -Called interactively, the function prints the same information in the -echo area. +If @var{here} is non-@code{nil}, it inserts the text in the buffer +before point, and returns @code{nil}. Called interactively, the +function prints the same information in the echo area, but giving a +prefix argument makes @var{here} non-@code{nil}. @end deffn @defvar emacs-build-time
--- a/lispref/minibuf.texi Thu Mar 11 02:31:12 2004 +0000 +++ b/lispref/minibuf.texi Tue Mar 16 20:27:22 2004 +0000 @@ -863,7 +863,9 @@ in the minibuffer to do completion. The description refers to the situation when Partial Completion mode is disabled (as it is by default). When enabled, this minor mode uses its own alternatives to -some of the commands described below. +some of the commands described below. @xref{Completion Options,,, +emacs, The GNU Emacs Manual}, for a short description of Partial +Completion mode. @defvar minibuffer-local-completion-map @code{completing-read} uses this value as the local keymap when an
--- a/man/ChangeLog Thu Mar 11 02:31:12 2004 +0000 +++ b/man/ChangeLog Tue Mar 16 20:27:22 2004 +0000 @@ -1,3 +1,9 @@ +2004-03-12 Richard M. Stallman <rms@gnu.org> + + * cl.texi (Top): Rename top node's title. + + * buffers.texi (Misc Buffer): Add index entry for rename-uniquely. + 2004-03-08 Karl Berry <karl@gnu.org> * info.texi: \input texinfo.tex instead of just texinfo, to avoid
--- a/man/buffers.texi Thu Mar 11 02:31:12 2004 +0000 +++ b/man/buffers.texi Tue Mar 16 20:27:22 2004 +0000 @@ -217,6 +217,7 @@ specify a name that is in use for some other buffer, an error happens and no renaming is done. +@findex rename-uniquely @kbd{M-x rename-uniquely} renames the current buffer to a similar name with a numeric suffix added to make it both different and unique. This command does not need an argument. It is useful for creating
--- a/man/cl.texi Thu Mar 11 02:31:12 2004 +0000 +++ b/man/cl.texi Tue Mar 16 20:27:22 2004 +0000 @@ -50,7 +50,7 @@ @end titlepage @node Top, Overview, (dir), (dir) -@chapter Common Lisp Extensions +@chapter Overview @noindent This document describes a set of Emacs Lisp facilities borrowed from
--- a/nt/ChangeLog Thu Mar 11 02:31:12 2004 +0000 +++ b/nt/ChangeLog Tue Mar 16 20:27:22 2004 +0000 @@ -1,3 +1,12 @@ +2004-03-11 Jason Rumney <jasonr@gnu.org> + + * paths.h: Remove PATH_LOCK, add PATH_BITMAPS. + +2004-03-10 Juanma Barranquero <lektu@terra.es> + + * makefile.w32-in (install): Don't try to copy + ../lib-src/fns-*.el, as it isn't used anymore. + 2004-01-28 Peter Runestig <peter@runestig.com> * gmake.defs, nmake.defs: Add linking to ``winspool.lib''. @@ -601,7 +610,7 @@ 1999-01-22 Geoff Voelker <voelker@cs.washington.edu> * icons: New directory with Davenport's icons. - icons/sink.ico: Renamed from emacs.ico. + * icons/sink.ico: Renamed from emacs.ico. * makefile.nt (install, fast_install): Install Windows icons into etc/icons. @@ -925,8 +934,8 @@ 1995-06-09 Geoff Voelker <voelker@cs.washington.edu> - * emacs.bat.in: Renamed from emacs.bat - (emacs_dir): Renamed from emacs_path + * emacs.bat.in: Renamed from emacs.bat. + (emacs_dir): Renamed from emacs_path. Definition removed. * addpm.c: New file.
--- a/nt/makefile.w32-in Thu Mar 11 02:31:12 2004 +0000 +++ b/nt/makefile.w32-in Tue Mar 16 20:27:22 2004 +0000 @@ -179,7 +179,6 @@ - $(CP) $(BLD)/ddeclient.exe $(INSTALL_DIR)/bin - $(CP) $(BLD)/cmdproxy.exe $(INSTALL_DIR)/bin - $(CP) $(BLD)/runemacs.exe $(INSTALL_DIR)/bin - - $(CP) ../lib-src/fns-*.el $(INSTALL_DIR)/bin - "$(INSTALL_DIR)/bin/addpm" /q - $(DEL) ../same-dir.tst - $(DEL) $(INSTALL_DIR)/same-dir.tst
--- a/nt/paths.h Thu Mar 11 02:31:12 2004 +0000 +++ b/nt/paths.h Tue Mar 16 20:27:22 2004 +0000 @@ -44,17 +44,14 @@ /* #define PATH_DATA "/usr/local/lib/emacs/data" */ #define PATH_DATA "C:/emacs/data" +/* Where Emacs should look for X bitmap files. + The lisp variable x-bitmap-file-path is set based on this value. */ +#define PATH_BITMAPS "" + /* Where Emacs should look for its docstring file. The lisp variable doc-directory is set to this value. */ #define PATH_DOC "C:/emacs/etc" -/* The name of the directory that contains lock files with which we - record what files are being modified in Emacs. This directory - should be writable by everyone. THE STRING MUST END WITH A - SLASH!!! */ -/* #define PATH_LOCK "/usr/local/lib/emacs/lock/" */ -#define PATH_LOCK "C:/emacs/lock/" - /* Where the configuration process believes the info tree lives. The lisp variable configure-info-directory gets its value from this macro, and is then used to set the Info-default-directory-list. */
--- a/src/ChangeLog Thu Mar 11 02:31:12 2004 +0000 +++ b/src/ChangeLog Tue Mar 16 20:27:22 2004 +0000 @@ -1,3 +1,250 @@ +2004-03-14 Steven Tamm <steventamm@mac.com> + + * Makefile.in (XMENU_OBJ): Do not include xmenu.o if + HAVE_CARBON is defined. + +2004-03-14 Kim F. Storm <storm@cua.dk> + + * dispextern.h (x_find_image_file): Add prototype. + + * image.c (x_find_image_file): Make extern. + + * xfns.c (x_find_image_file): Remove prototype. + +2004-03-13 Eli Zaretskii <eliz@elta.co.il> + + * Makefile.in (XMENU_OBJ): Include xmenu.o if HAVE_MENUS is + defined. + + * emacs.c (main): Call syms_of_xmenu only if HAVE_MENUS is + defined. + +2004-03-12 Richard M. Stallman <rms@gnu.org> + + * fns.c (internal_equal): New arg PROPS controls comparing + text properties. All callers changed. + (Fequal_including_properties): New function. + (syms_of_fns): defsubr it. + +2004-03-12 Kim F. Storm <storm@cua.dk> + + Fix image support on MAC. From YAMAMOTO Mitsuharu. + + * dispextern.h (XImagePtr, XImagePtr_or_DC): Add typedefs. + (image_background, image_background_transparent): Fix prototypes. + + * image.c (XImagePtr, XImagePtr_or_DC): Move typedefs to + dispextern.h. + + * macfns.c (x_list_fonts, x_get_font_info, x_load_font) + (x_query_font, x_find_ccl_program, x_set_window_size) + (x_make_frame_visible, mac_initialize, XCreatePixmap) + (XCreatePixmapFromBitmapData, XFreePixmap, XSetForeground) + (mac_draw_line_to_pixmap): Move prototypes to macterm.h. + + * macterm.h (x_list_fonts, x_get_font_info, x_load_font) + (x_query_font, x_find_ccl_program, x_set_window_size) + (x_make_frame_visible, mac_initialize, XCreatePixmap) + (XCreatePixmapFromBitmapData, XFreePixmap, XSetForeground) + (mac_draw_line_to_pixmap): Add prototypes. + +2004-03-12 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp> + + * macterm.c (XTread_socket): Fix mouse click on tool bar. + +2004-03-11 Kim F. Storm <storm@cua.dk> + + * dispextern.h: Move image related prototypes from xfns.c section + to image.c. Condition them by HAVE_WINDOW_SYSTEM rather than + HAVE_X_WINDOWS. + + * Makefile.in (XOBJ): Consolidate into one list. Add image.o. + Move gtkutil.o to new GTK_OBJ list. + (XMENU_OBJ) [HAVE_MENUS]: Move declaration to proper place. + (GTK_OBJ) [USE_GTK]: New declaration. + (obj): Add $(GTK_OBJ) to list. + +2004-03-11 Steven Tamm <steventamm@mac.com> + + * image.c [MAC_OSX]: Include sys/stat.h + + * macfns.c (syms_of_macfns): Remove definitions of things now + defined in image.c + +2004-03-11 Kim F. Storm <storm@cua.dk> + + The following changes consolidates the identical/similar image + support code previously found in xfns.c, w32fns.c, and macfns.c + into a new file image.c. + + * makefile.w32-in (OBJ1): Add image.o. + ($(BLD)/image.$(O)): Add dependencies. + + * Makefile.in (XOBJ, MAC_OBJ): Add image.o. + (image.o): Add dependencies. + + * image.c: New file with consolidated image support code. + (COLOR_TABLE_SUPPORT): New define to control whether + color table support is available (X only). + (Bitmap_Record): Common name for x_bitmap_record, + w32_bitmap_record, and mac_bitmap_record. + (XImagePtr): Common name for pointer to XImage or equivalent. + (XImagePtr_or_DC): New type to simplify code sharing; equivalent + to XImagePtr on X+MAC, and to HDC on W32. + (GET_PIXEL): Wrapper for XGetPixel or equivalent. + (NO_PIXMAP): Common name for "None" or equivalent. + (PNG_BG_COLOR_SHIFT): Bits to shift PNG background colors. + (RGB_PIXEL_COLOR): Common type for an integer "pixel color" value. + (PIX_MASK_RETAIN, PIX_MASK_DRAW): Portability macros (from macfns.c). + (FRAME_X_VISUAL, x_defined_color, DefaultDepthOfScreen): Define + with suitable equivalents on W32 and MAC for code sharing. + (XDrawLine): Define on MAC for code sharing. + (Destroy_Image, Free_Pixmap): Wrappers for code sharing. + (IF_LIB_AVAILABLE): Macro to simplify code sharing. + (Vx_bitmap_file_path, Vimage_cache_eviction_delay) + (x_bitmap_height, x_bitmap_width, x_bitmap_pixmap) + (x_reference_bitmap, x_create_bitmap_from_data) + (x_create_bitmap_from_file, x_destroy_bitmap) + (x_destroy_all_bitmaps, x_create_bitmap_mask) + (XGetImage, XPutPixel, XGetPixel, XDestroyImage) + (QCascent, QCmargin, QCrelief, QCconversion, QCcolor_symbols) + (QCheuristic_mask, QCindex, QCmatrix, QCcolor_adjustment, QCmask) + (Qlaplace, Qemboss, Qedge_detection, Qheuristic, Qcenter) + (define_image_type, lookup_image_type, valid_image_p) + (image_error, enum image_value_type, struct image_keyword) + (parse_image_spec, image_spec_value, Fimage_size, Fimage_mask_p) + (make_image, free_image, prepare_image_for_display, image_ascent) + (four_corners_best, image_background, image_background_transparent) + (x_clear_image_1, x_clear_image, x_alloc_image_color) + (make_image_cache, free_image_cache, clear_image_cache) + (Fclear_image_cache, postprocess_image, lookup_image, cache_image) + (forall_images_in_image_cache, x_create_x_image_and_pixmap) + (x_destroy_x_image, x_put_x_image, x_find_image_file, slurp_file) + (find_image_fsspec, image_load_qt_1, image_load_quicktime) + (init_image_func_pointer, image_load_quartz2d) + (struct ct_color, init_color_table, free_color_table) + (lookup_rgb_color, lookup_pixel_color, colors_in_color_table) + (cross_disabled_images, x_to_xcolors, x_from_xcolors) + (x_detect_edges, x_emboss, x_laplace, x_edge_detection) + (x_disable_image, x_build_heuristic_mask) + (XBM support, XPM support, PBM support, PNG support, JPEG support) + (TIFF support, GIF support, Ghostscript support): Consolidate image + code from xfns.c, w32fns.c, and macfns.c. + (syms_of_image): Consolidate image related symbol setup here. + (init_image): Consolidate image related initializations here. + + * emacs.c (main) [HAVE_WINDOW_SYSTEM]: Add calls to syms_of_image + and init_image. Remove call to init_xfns. + + * macterm.h (struct mac_bitmap_record): Add file member. Not + currently used, but simplifies code sharing. + + * macfns.c (Vx_bitmap_file_path, Vimage_cache_eviction_delay) + (x_bitmap_height, x_bitmap_width, x_bitmap_pixmap) + (x_reference_bitmap, x_create_bitmap_from_data) + (x_create_bitmap_from_file, x_destroy_bitmap) + (x_destroy_all_bitmaps, x_create_bitmap_mask) + (XGetImage, XPutPixel, XGetPixel, XDestroyImage) + (QCascent, QCmargin, QCrelief, QCconversion, QCcolor_symbols) + (QCheuristic_mask, QCindex, QCmatrix, QCcolor_adjustment, QCmask) + (Qlaplace, Qemboss, Qedge_detection, Qheuristic, Qcenter) + (define_image_type, lookup_image_type, valid_image_p) + (image_error, enum image_value_type, struct image_keyword) + (parse_image_spec, image_spec_value, Fimage_size, Fimage_mask_p) + (make_image, free_image, prepare_image_for_display, image_ascent) + (four_corners_best, image_background, image_background_transparent) + (x_clear_image_1, x_clear_image, x_alloc_image_color) + (make_image_cache, free_image_cache, clear_image_cache) + (Fclear_image_cache, postprocess_image, lookup_image, cache_image) + (forall_images_in_image_cache, x_create_x_image_and_pixmap) + (x_destroy_x_image, x_put_x_image, x_find_image_file, slurp_file) + (find_image_fsspec, image_load_qt_1, image_load_quicktime) + (init_image_func_pointer, image_load_quartz2d) + (struct ct_color, init_color_table, free_color_table) + (lookup_rgb_color, lookup_pixel_color, colors_in_color_table) + (cross_disabled_images, x_to_xcolors, x_from_xcolors) + (x_detect_edges, x_emboss, x_laplace, x_edge_detection) + (x_disable_image, x_build_heuristic_mask) + (XBM support, XPM support, PBM support, PNG support, JPEG support) + (TIFF support, GIF support, Ghostscript support): Merge with image + code from xfns.c and macfns.c into image.c. + (syms_of_xfns): Move image related symbols to image.c. + (init_external_image_libraries, init_xfns): Remove; initialization + moved to init_image in image.c. + + * w32fns.c (Vx_bitmap_file_path, Vimage_cache_eviction_delay) + (x_bitmap_height, x_bitmap_width, x_bitmap_pixmap) + (x_reference_bitmap, x_create_bitmap_from_data) + (x_create_bitmap_from_file, x_destroy_bitmap) + (x_destroy_all_bitmaps, x_create_bitmap_mask) + (QCascent, QCmargin, QCrelief, QCconversion, QCcolor_symbols) + (QCheuristic_mask, QCindex, QCmatrix, QCcolor_adjustment, QCmask) + (Qlaplace, Qemboss, Qedge_detection, Qheuristic, Qcenter) + (define_image_type, lookup_image_type, valid_image_p) + (image_error, enum image_value_type, struct image_keyword) + (parse_image_spec, image_spec_value, Fimage_size, Fimage_mask_p) + (make_image, free_image, prepare_image_for_display, image_ascent) + (four_corners_best, image_background, image_background_transparent) + (x_clear_image_1, x_clear_image, x_alloc_image_color) + (make_image_cache, free_image_cache, clear_image_cache) + (Fclear_image_cache, postprocess_image, lookup_image, cache_image) + (forall_images_in_image_cache, x_create_x_image_and_pixmap) + (x_destroy_x_image, x_put_x_image, x_find_image_file, slurp_file) + (struct ct_color, init_color_table, free_color_table) + (lookup_rgb_color, lookup_pixel_color, colors_in_color_table) + (cross_disabled_images, x_to_xcolors, x_from_xcolors) + (x_detect_edges, x_emboss, x_laplace, x_edge_detection) + (x_disable_image, x_build_heuristic_mask) + (XBM support, XPM support, PBM support, PNG support, JPEG support) + (TIFF support, GIF support, Ghostscript support): Merge with image + code from xfns.c and macfns.c into image.c. + (syms_of_xfns): Move image related symbols to image.c. + (init_external_image_libraries, init_xfns): Remove; initialization + moved to init_image in image.c. + + * xfns.c (Vx_bitmap_file_path, Vimage_cache_eviction_delay) + (x_bitmap_height, x_bitmap_width, x_bitmap_pixmap) + (x_reference_bitmap, x_create_bitmap_from_data) + (x_create_bitmap_from_file, x_destroy_bitmap) + (x_destroy_all_bitmaps, x_create_bitmap_mask) + (QCascent, QCmargin, QCrelief, QCconversion, QCcolor_symbols) + (QCheuristic_mask, QCindex, QCmatrix, QCcolor_adjustment, QCmask) + (Qlaplace, Qemboss, Qedge_detection, Qheuristic, Qcenter) + (define_image_type, lookup_image_type, valid_image_p) + (image_error, enum image_value_type, struct image_keyword) + (parse_image_spec, image_spec_value, Fimage_size, Fimage_mask_p) + (make_image, free_image, prepare_image_for_display, image_ascent) + (four_corners_best, image_background, image_background_transparent) + (x_clear_image_1, x_clear_image, x_alloc_image_color) + (make_image_cache, free_image_cache, clear_image_cache) + (Fclear_image_cache, postprocess_image, lookup_image, cache_image) + (forall_images_in_image_cache, x_create_x_image_and_pixmap) + (x_destroy_x_image, x_put_x_image, x_find_image_file, slurp_file) + (struct ct_color, init_color_table, free_color_table) + (lookup_rgb_color, lookup_pixel_color, colors_in_color_table) + (cross_disabled_images, x_to_xcolors, x_from_xcolors) + (x_detect_edges, x_emboss, x_laplace, x_edge_detection) + (x_disable_image, x_build_heuristic_mask) + (XBM support, XPM support, PBM support, PNG support, JPEG support) + (TIFF support, GIF support, Ghostscript support): Merge with + w32fns.c and macfns.c image code into image.c. + (syms_of_xfns): Move image related symbols to image.c. + (init_xfns): Remove; initialization moved to init_image in image.c. + + * lisp.h (syms_of_image, init_image): Add protoypes. + (init_xfns): Remove prototype. + + * dispextern.h (x_bitmap_height, x_bitmap_width, x_bitmap_pixmap) + (x_reference_bitmap, x_create_bitmap_from_data) + (x_create_bitmap_from_file, x_destroy_bitmap) + (x_create_bitmap_mask): Move prototypes from dispextern.h. + (gamma_correct) [MAC_OS]: Add prototype. + + * xterm.h (x_bitmap_height, x_bitmap_width, x_bitmap_pixmap) + (x_reference_bitmap, x_create_bitmap_from_data) + (x_create_bitmap_from_file, x_destroy_bitmap) + (x_create_bitmap_mask): Move prototypes to dispextern.h. + 2004-03-09 Kenichi Handa <handa@etlken2> * coding.c (decode_coding_emacs_mule): Handle insufficent source
--- a/src/Makefile.in Thu Mar 11 02:31:12 2004 +0000 +++ b/src/Makefile.in Tue Mar 16 20:27:22 2004 +0000 @@ -305,14 +305,17 @@ #endif #ifdef HAVE_X_WINDOWS + +XOBJ= xterm.o xfns.o xselect.o xrdb.o fontset.o xsmfns.o fringe.o image.o + #ifdef HAVE_MENUS -/* Include xmenu.o in the list of X object files. */ +#ifndef HAVE_CARBON +XMENU_OBJ = xmenu.o +#endif #ifdef USE_GTK -XOBJ= xterm.o xfns.o xselect.o xrdb.o fontset.o xsmfns.o gtkutil.o fringe.o -#else -XOBJ= xterm.o xfns.o xselect.o xrdb.o fontset.o xsmfns.o fringe.o +GTK_OBJ= gtkutil.o #endif /* The X Menu stuff is present in the X10 distribution, but missing @@ -332,9 +335,7 @@ #else /* not HAVE_MENUS */ -/* Otherwise, omit xmenu.o from the list of X object files, and - don't worry about the menu library at all. */ -XOBJ= xterm.o xfns.o xselect.o xrdb.o fontset.o xsmfns.o fringe.o +/* Otherwise, don't worry about the menu library at all. */ LIBXMENU= #endif /* not HAVE_MENUS */ @@ -447,6 +448,10 @@ #else /* not HAVE_X11 */ LIBX= $(LIBXMENU) LD_SWITCH_X_SITE -lX10 LIBX10_MACHINE LIBX10_SYSTEM #endif /* not HAVE_X11 */ +#else /* not HAVE_X_WINDOWS */ +#if defined(HAVE_MENUS) && !defined(HAVE_CARBON) +XMENU_OBJ = xmenu.o +#endif #endif /* not HAVE_X_WINDOWS */ LIBSOUND= @LIBSOUND@ @@ -561,19 +566,16 @@ #ifdef HAVE_CARBON mac = $(dot)$(dot)/mac/ -XMENU_OBJ = -MAC_OBJ = mac.o macterm.o macfns.o macmenu.o fontset.o fringe.o +MAC_OBJ = mac.o macterm.o macfns.o macmenu.o fontset.o fringe.o image.o emacsapp = $(PWD)/$(mac)Emacs.app/ emacsappsrc = ${srcdir}/../mac/Emacs.app/ -#else -XMENU_OBJ = xmenu.o #endif /* lastfile must follow all files whose initialized data areas should be dumped as pure by dump-emacs. */ obj= dispnew.o frame.o scroll.o xdisp.o $(XMENU_OBJ) window.o \ charset.o coding.o category.o ccl.o \ - cm.o term.o xfaces.o $(XOBJ) \ + cm.o term.o xfaces.o $(XOBJ) $(GTK_OBJ)\ emacs.o keyboard.o macros.o keymap.o sysdep.o \ buffer.o filelock.o insdel.o marker.o \ minibuf.o fileio.o dired.o filemode.o \ @@ -1081,6 +1083,8 @@ fontset.o: dispextern.h fontset.h fontset.c ccl.h buffer.h charset.h frame.h \ keyboard.h termhooks.h $(config_h) getloadavg.o: getloadavg.c $(config_h) +image.o: image.c frame.h window.h dispextern.h blockinput.h atimer.h \ + systime.h xterm.h w32term.h w32gui.h macterm.h macgui.h $(config_h) indent.o: indent.c frame.h window.h indent.h buffer.h $(config_h) termchar.h \ termopts.h disptab.h region-cache.h charset.h composite.h dispextern.h \ keyboard.h
--- a/src/dispextern.h Thu Mar 11 02:31:12 2004 +0000 +++ b/src/dispextern.h Tue Mar 16 20:27:22 2004 +0000 @@ -50,17 +50,24 @@ #ifdef HAVE_X_WINDOWS typedef struct x_display_info Display_Info; +typedef XImage * XImagePtr; +typedef XImagePtr XImagePtr_or_DC; #define NativeRectangle XRectangle #endif #ifdef HAVE_NTGUI #include "w32gui.h" typedef struct w32_display_info Display_Info; +typedef XImage *XImagePtr; +typedef HDC XImagePtr_or_DC; #endif #ifdef HAVE_CARBON #include "macgui.h" typedef struct mac_display_info Display_Info; +/* Mac equivalent of XImage. */ +typedef Pixmap XImagePtr; +typedef XImagePtr XImagePtr_or_DC; #endif #ifndef NativeRectangle @@ -2591,6 +2598,41 @@ void w32_reset_fringes P_ ((void)); #endif +/* Defined in image.c */ + +#ifdef HAVE_WINDOW_SYSTEM + +extern int x_bitmap_height P_ ((struct frame *, int)); +extern int x_bitmap_width P_ ((struct frame *, int)); +extern int x_bitmap_pixmap P_ ((struct frame *, int)); +extern void x_reference_bitmap P_ ((struct frame *, int)); +extern int x_create_bitmap_from_data P_ ((struct frame *, char *, + unsigned int, unsigned int)); +extern int x_create_bitmap_from_file P_ ((struct frame *, Lisp_Object)); +#ifndef x_destroy_bitmap +extern void x_destroy_bitmap P_ ((struct frame *, int)); +#endif +extern void x_destroy_all_bitmaps P_ ((Display_Info *)); +extern int x_create_bitmap_mask P_ ((struct frame * , int)); +extern Lisp_Object x_find_image_file P_ ((Lisp_Object)); + +void x_kill_gs_process P_ ((Pixmap, struct frame *)); +struct image_cache *make_image_cache P_ ((void)); +void free_image_cache P_ ((struct frame *)); +void clear_image_cache P_ ((struct frame *, int)); +void forall_images_in_image_cache P_ ((struct frame *, + void (*) P_ ((struct image *)))); +int valid_image_p P_ ((Lisp_Object)); +void prepare_image_for_display P_ ((struct frame *, struct image *)); +int lookup_image P_ ((struct frame *, Lisp_Object)); + +unsigned long image_background P_ ((struct image *, struct frame *, + XImagePtr_or_DC ximg)); +int image_background_transparent P_ ((struct image *, struct frame *, + XImagePtr_or_DC mask)); + +#endif + /* Defined in sysdep.c */ void get_tty_size P_ ((int, int *, int *)); @@ -2643,27 +2685,14 @@ #ifdef WINDOWSNT void gamma_correct P_ ((struct frame *, COLORREF *)); #endif +#ifdef MAC_OS +void gamma_correct P_ ((struct frame *, unsigned long *)); +#endif #ifdef HAVE_WINDOW_SYSTEM -void x_kill_gs_process P_ ((Pixmap, struct frame *)); int x_screen_planes P_ ((struct frame *)); void x_implicitly_set_name P_ ((struct frame *, Lisp_Object, Lisp_Object)); -struct image_cache *make_image_cache P_ ((void)); -void free_image_cache P_ ((struct frame *)); -void clear_image_cache P_ ((struct frame *, int)); -void forall_images_in_image_cache P_ ((struct frame *, - void (*) P_ ((struct image *)))); -int valid_image_p P_ ((Lisp_Object)); -void prepare_image_for_display P_ ((struct frame *, struct image *)); -int lookup_image P_ ((struct frame *, Lisp_Object)); - -#ifdef HAVE_X_WINDOWS -unsigned long image_background P_ ((struct image *, struct frame *, - XImage *ximg)); -int image_background_transparent P_ ((struct image *, struct frame *, - XImage *mask)); -#endif /* HAVE_X_WINDOWS */ extern Lisp_Object tip_frame; extern Window tip_window;
--- a/src/emacs.c Thu Mar 11 02:31:12 2004 +0000 +++ b/src/emacs.c Tue Mar 16 20:27:22 2004 +0000 @@ -1512,6 +1512,7 @@ syms_of_xdisp (); #ifdef HAVE_WINDOW_SYSTEM syms_of_fringe (); + syms_of_image (); #endif /* HAVE_WINDOW_SYSTEM */ #ifdef HAVE_X_WINDOWS syms_of_xterm (); @@ -1525,12 +1526,14 @@ #endif #endif /* HAVE_X_WINDOWS */ +#ifdef HAVE_MENUS #ifndef HAVE_NTGUI #ifndef MAC_OS /* Called before init_window_once for Mac OS Classic. */ syms_of_xmenu (); #endif #endif +#endif #ifdef HAVE_NTGUI syms_of_w32term (); @@ -1589,13 +1592,11 @@ #endif /* VMS */ init_display (); /* Determine terminal type. Calls init_sys_modes. */ } -#if defined (HAVE_X_WINDOWS) || defined (WINDOWSNT) || defined (HAVE_CARBON) - init_xfns (); -#endif /* HAVE_X_WINDOWS */ init_fns (); init_xdisp (); #ifdef HAVE_WINDOW_SYSTEM init_fringe (); + init_image (); #endif /* HAVE_WINDOW_SYSTEM */ init_macros (); init_editfns ();
--- a/src/fns.c Thu Mar 11 02:31:12 2004 +0000 +++ b/src/fns.c Tue Mar 16 20:27:22 2004 +0000 @@ -2146,13 +2146,27 @@ (o1, o2) register Lisp_Object o1, o2; { - return internal_equal (o1, o2, 0) ? Qt : Qnil; + return internal_equal (o1, o2, 0, 0) ? Qt : Qnil; } +DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0, + doc: /* Return t if two Lisp objects have similar structure and contents. +This is like `equal' except that it compares the text properties +of strings. (`equal' ignores text properties.) */) + (o1, o2) + register Lisp_Object o1, o2; +{ + return internal_equal (o1, o2, 0, 1) ? Qt : Qnil; +} + +/* DEPTH is current depth of recursion. Signal an error if it + gets too deep. + PROPS, if non-nil, means compare string text properties too. */ + static int -internal_equal (o1, o2, depth) +internal_equal (o1, o2, depth, props) register Lisp_Object o1, o2; - int depth; + int depth, props; { if (depth > 200) error ("Stack overflow in equal"); @@ -2178,7 +2192,7 @@ } case Lisp_Cons: - if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1)) + if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props)) return 0; o1 = XCDR (o1); o2 = XCDR (o2); @@ -2190,7 +2204,7 @@ if (OVERLAYP (o1)) { if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2), - depth + 1) + depth + 1, props) || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2), depth + 1)) return 0; @@ -2244,7 +2258,7 @@ Lisp_Object v1, v2; v1 = XVECTOR (o1)->contents [i]; v2 = XVECTOR (o2)->contents [i]; - if (!internal_equal (v1, v2, depth + 1)) + if (!internal_equal (v1, v2, depth + 1, props)) return 0; } return 1; @@ -2259,6 +2273,8 @@ if (bcmp (SDATA (o1), SDATA (o2), SBYTES (o1))) return 0; + if (props && !compare_string_intervals (o1, o2)) + return 0; return 1; case Lisp_Int: @@ -5725,6 +5741,7 @@ defsubr (&Slax_plist_get); defsubr (&Slax_plist_put); defsubr (&Sequal); + defsubr (&Sequal_including_properties); defsubr (&Sfillarray); defsubr (&Sclear_string); defsubr (&Schar_table_subtype);
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/image.c Tue Mar 16 20:27:22 2004 +0000 @@ -0,0 +1,7534 @@ +/* Functions for image support on window system. + Copyright (C) 1989, 92, 93, 94, 95, 96, 97, 98, 99, 2000,01,02,03,04 + Free Software Foundation. + +This file is part of GNU Emacs. + +GNU Emacs 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. + +GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include <config.h> +#include <signal.h> +#include <stdio.h> +#include <math.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +/* This makes the fields of a Display accessible, in Xlib header files. */ + +#define XLIB_ILLEGAL_ACCESS + +#include "lisp.h" +#include "frame.h" +#include "window.h" +#include "dispextern.h" +#include "blockinput.h" +#include "systime.h" +#include <epaths.h> + + +#ifdef HAVE_X_WINDOWS +#include "xterm.h" +#include <sys/types.h> +#include <sys/stat.h> + +#define COLOR_TABLE_SUPPORT 1 + +typedef struct x_bitmap_record Bitmap_Record; +#define GET_PIXEL(ximg, x, y) XGetPixel(ximg, x, y) +#define NO_PIXMAP None +#define PNG_BG_COLOR_SHIFT 0 + +#define RGB_PIXEL_COLOR unsigned long + +#define PIX_MASK_RETAIN(f) 0 +#define PIX_MASK_DRAW(f) 1 +#endif /* HAVE_X_WINDOWS */ + + +#ifdef HAVE_NTGUI +#include "w32term.h" + +/* W32_TODO : Color tables on W32. */ +#undef COLOR_TABLE_SUPPORT + +typedef struct w32_bitmap_record Bitmap_Record; +#define GET_PIXEL(ximg, x, y) GetPixel(ximg, x, y) +#define NO_PIXMAP 0 +#define PNG_BG_COLOR_SHIFT 0 + +#define RGB_PIXEL_COLOR COLORREF + +#define PIX_MASK_RETAIN(f) 0 +#define PIX_MASK_DRAW(f) 1 + +#define FRAME_X_VISUAL(f) FRAME_X_DISPLAY_INFO (f)->visual +#define x_defined_color w32_defined_color +#define DefaultDepthOfScreen(screen) (one_w32_display_info.n_cbits) +#endif /* HAVE_NTGUI */ + + +#ifdef MAC_OS +#include "macterm.h" +#ifndef MAC_OSX +#include <alloca.h> +#endif +#ifdef MAC_OSX +#include <sys/stat.h> +#include <QuickTime/QuickTime.h> +#else /* not MAC_OSX */ +#include <Windows.h> +#include <Gestalt.h> +#include <TextUtils.h> +#endif /* not MAC_OSX */ + +/* MAC_TODO : Color tables on Mac. */ +#undef COLOR_TABLE_SUPPORT + +#define ZPixmap 0 /* arbitrary */ +typedef struct mac_bitmap_record Bitmap_Record; + +#define GET_PIXEL(ximg, x, y) XGetPixel(ximg, x, y) +#define NO_PIXMAP 0 +#define PNG_BG_COLOR_SHIFT 8 + +#define RGB_PIXEL_COLOR unsigned long + +#define FRAME_X_VISUAL(f) FRAME_X_DISPLAY_INFO (f)->visual +#define x_defined_color mac_defined_color +#define DefaultDepthOfScreen(screen) (one_mac_display_info.n_planes) +#define XDrawLine(display, w, gc, x1, y1, x2, y2) \ + mac_draw_line_to_pixmap(display, w, gc, x1, y1, x2, y2) + +#endif /* MAC_OS */ + + +/* Search path for bitmap files. */ + +Lisp_Object Vx_bitmap_file_path; + + +static void x_disable_image P_ ((struct frame *, struct image *)); +static void x_edge_detection P_ ((struct frame *, struct image *, Lisp_Object, + Lisp_Object)); + +static void init_color_table P_ ((void)); +static unsigned long lookup_rgb_color P_ ((struct frame *f, int r, int g, int b)); +#ifdef COLOR_TABLE_SUPPORT +static void free_color_table P_ ((void)); +static unsigned long *colors_in_color_table P_ ((int *n)); +static unsigned long lookup_pixel_color P_ ((struct frame *f, unsigned long p)); +#endif + +/* Code to deal with bitmaps. Bitmaps are referenced by their bitmap + id, which is just an int that this section returns. Bitmaps are + reference counted so they can be shared among frames. + + Bitmap indices are guaranteed to be > 0, so a negative number can + be used to indicate no bitmap. + + If you use x_create_bitmap_from_data, then you must keep track of + the bitmaps yourself. That is, creating a bitmap from the same + data more than once will not be caught. */ + +#ifdef MAC_OS + +static XImagePtr +XGetImage (display, pixmap, x, y, width, height, plane_mask, format) + Display *display; /* not used */ + Pixmap pixmap; + int x, y; /* not used */ + unsigned int width, height; /* not used */ + unsigned long plane_mask; /* not used */ + int format; /* not used */ +{ +#if GLYPH_DEBUG + xassert (x == 0 && y == 0); + { + Rect ri, rp; + SetRect (&ri, 0, 0, width, height); + xassert (EqualRect (&ri, GetPixBounds (GetGWorldPixMap (pixmap), &rp))); + } + xassert (! (pixelsLocked & GetPixelsState (GetGWorldPixMap (pixmap)))); +#endif + + LockPixels (GetGWorldPixMap (pixmap)); + + return pixmap; +} + +static void +XPutPixel (ximage, x, y, pixel) + XImagePtr ximage; + int x, y; + unsigned long pixel; +{ + RGBColor color; + + SetGWorld (ximage, NULL); + + color.red = RED16_FROM_ULONG (pixel); + color.green = GREEN16_FROM_ULONG (pixel); + color.blue = BLUE16_FROM_ULONG (pixel); + SetCPixel (x, y, &color); +} + +static unsigned long +XGetPixel (ximage, x, y) + XImagePtr ximage; + int x, y; +{ + RGBColor color; + + SetGWorld (ximage, NULL); + + GetCPixel (x, y, &color); + return RGB_TO_ULONG (color.red >> 8, color.green >> 8, color.blue >> 8); +} + +static void +XDestroyImage (ximg) + XImagePtr ximg; +{ + UnlockPixels (GetGWorldPixMap (ximg)); +} +#endif + + +/* Functions to access the contents of a bitmap, given an id. */ + +int +x_bitmap_height (f, id) + FRAME_PTR f; + int id; +{ + return FRAME_X_DISPLAY_INFO (f)->bitmaps[id - 1].height; +} + +int +x_bitmap_width (f, id) + FRAME_PTR f; + int id; +{ + return FRAME_X_DISPLAY_INFO (f)->bitmaps[id - 1].width; +} + +#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI) +int +x_bitmap_pixmap (f, id) + FRAME_PTR f; + int id; +{ + return (int) FRAME_X_DISPLAY_INFO (f)->bitmaps[id - 1].pixmap; +} +#endif + +#ifdef HAVE_X_WINDOWS +int +x_bitmap_mask (f, id) + FRAME_PTR f; + int id; +{ + return FRAME_X_DISPLAY_INFO (f)->bitmaps[id - 1].mask; +} +#endif + +/* Allocate a new bitmap record. Returns index of new record. */ + +static int +x_allocate_bitmap_record (f) + FRAME_PTR f; +{ + Display_Info *dpyinfo = FRAME_X_DISPLAY_INFO (f); + int i; + + if (dpyinfo->bitmaps == NULL) + { + dpyinfo->bitmaps_size = 10; + dpyinfo->bitmaps + = (Bitmap_Record *) xmalloc (dpyinfo->bitmaps_size * sizeof (Bitmap_Record)); + dpyinfo->bitmaps_last = 1; + return 1; + } + + if (dpyinfo->bitmaps_last < dpyinfo->bitmaps_size) + return ++dpyinfo->bitmaps_last; + + for (i = 0; i < dpyinfo->bitmaps_size; ++i) + if (dpyinfo->bitmaps[i].refcount == 0) + return i + 1; + + dpyinfo->bitmaps_size *= 2; + dpyinfo->bitmaps + = (Bitmap_Record *) xrealloc (dpyinfo->bitmaps, + dpyinfo->bitmaps_size * sizeof (Bitmap_Record)); + return ++dpyinfo->bitmaps_last; +} + +/* Add one reference to the reference count of the bitmap with id ID. */ + +void +x_reference_bitmap (f, id) + FRAME_PTR f; + int id; +{ + ++FRAME_X_DISPLAY_INFO (f)->bitmaps[id - 1].refcount; +} + +/* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at BITS. */ + +int +x_create_bitmap_from_data (f, bits, width, height) + struct frame *f; + char *bits; + unsigned int width, height; +{ + Display_Info *dpyinfo = FRAME_X_DISPLAY_INFO (f); + int id; + +#ifdef HAVE_X_WINDOWS + Pixmap bitmap; + bitmap = XCreateBitmapFromData (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + bits, width, height); + if (! bitmap) + return -1; +#endif /* HAVE_X_WINDOWS */ + +#ifdef HAVE_NTGUI + Pixmap bitmap; + bitmap = CreateBitmap (width, height, + FRAME_X_DISPLAY_INFO (XFRAME (frame))->n_planes, + FRAME_X_DISPLAY_INFO (XFRAME (frame))->n_cbits, + bits); + if (! bitmap) + return -1; +#endif /* HAVE_NTGUI */ + +#ifdef MAC_OS + /* MAC_TODO: for now fail if width is not mod 16 (toolbox requires it) */ + if (width % 16 != 0) + return -1; +#endif + + id = x_allocate_bitmap_record (f); +#ifdef MAC_OS + dpyinfo->bitmaps[id - 1].bitmap_data = (char *) xmalloc (height * width); + if (! dpyinfo->bitmaps[id - 1].bitmap_data) + return -1; + bcopy (bits, dpyinfo->bitmaps[id - 1].bitmap_data, height * width); +#endif /* MAC_OS */ + + dpyinfo->bitmaps[id - 1].file = NULL; + dpyinfo->bitmaps[id - 1].height = height; + dpyinfo->bitmaps[id - 1].width = width; + dpyinfo->bitmaps[id - 1].refcount = 1; + +#ifdef HAVE_X_WINDOWS + dpyinfo->bitmaps[id - 1].pixmap = bitmap; + dpyinfo->bitmaps[id - 1].have_mask = 0; + dpyinfo->bitmaps[id - 1].depth = 1; +#endif /* HAVE_X_WINDOWS */ + +#ifdef HAVE_NTGUI + dpyinfo->bitmaps[id - 1].pixmap = bitmap; + dpyinfo->bitmaps[id - 1].hinst = NULL; + dpyinfo->bitmaps[id - 1].depth = 1; +#endif /* HAVE_NTGUI */ + + return id; +} + +/* Create bitmap from file FILE for frame F. */ + +int +x_create_bitmap_from_file (f, file) + struct frame *f; + Lisp_Object file; +{ +#ifdef MAC_OS + return -1; /* MAC_TODO : bitmap support */ +#endif /* MAC_OS */ + +#ifdef HAVE_NTGUI + return -1; /* W32_TODO : bitmap support */ +#endif /* HAVE_NTGUI */ + +#ifdef HAVE_X_WINDOWS + Display_Info *dpyinfo = FRAME_X_DISPLAY_INFO (f); + unsigned int width, height; + Pixmap bitmap; + int xhot, yhot, result, id; + Lisp_Object found; + int fd; + char *filename; + + /* Look for an existing bitmap with the same name. */ + for (id = 0; id < dpyinfo->bitmaps_last; ++id) + { + if (dpyinfo->bitmaps[id].refcount + && dpyinfo->bitmaps[id].file + && !strcmp (dpyinfo->bitmaps[id].file, (char *) SDATA (file))) + { + ++dpyinfo->bitmaps[id].refcount; + return id + 1; + } + } + + /* Search bitmap-file-path for the file, if appropriate. */ + fd = openp (Vx_bitmap_file_path, file, Qnil, &found, Qnil); + if (fd < 0) + return -1; + emacs_close (fd); + + filename = (char *) SDATA (found); + + result = XReadBitmapFile (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + filename, &width, &height, &bitmap, &xhot, &yhot); + if (result != BitmapSuccess) + return -1; + + id = x_allocate_bitmap_record (f); + dpyinfo->bitmaps[id - 1].pixmap = bitmap; + dpyinfo->bitmaps[id - 1].have_mask = 0; + dpyinfo->bitmaps[id - 1].refcount = 1; + dpyinfo->bitmaps[id - 1].file = (char *) xmalloc (SBYTES (file) + 1); + dpyinfo->bitmaps[id - 1].depth = 1; + dpyinfo->bitmaps[id - 1].height = height; + dpyinfo->bitmaps[id - 1].width = width; + strcpy (dpyinfo->bitmaps[id - 1].file, SDATA (file)); + + return id; +#endif /* HAVE_X_WINDOWS */ +} + +/* Free bitmap B. */ + +static void +Free_Bitmap_Record (dpyinfo, bm) + Display_Info *dpyinfo; + Bitmap_Record *bm; +{ +#ifdef HAVE_X_WINDOWS + XFreePixmap (dpyinfo->display, bm->pixmap); + if (bm->have_mask) + XFreePixmap (dpyinfo->display, bm->mask); +#endif /* HAVE_X_WINDOWS */ + +#ifdef HAVE_NTGUI + DeleteObject (bm->pixmap); +#endif /* HAVE_NTGUI */ + +#ifdef MAC_OS + xfree (bm->bitmap_data); /* Added ++kfs */ + bm->bitmap_data = NULL; +#endif /* MAC_OS */ + + if (bm->file) + { + xfree (bm->file); + bm->file = NULL; + } +} + +/* Remove reference to bitmap with id number ID. */ + +void +x_destroy_bitmap (f, id) + FRAME_PTR f; + int id; +{ + Display_Info *dpyinfo = FRAME_X_DISPLAY_INFO (f); + + if (id > 0) + { + Bitmap_Record *bm = &dpyinfo->bitmaps[id - 1]; + + if (--bm->refcount == 0) + { + BLOCK_INPUT; + Free_Bitmap_Record (dpyinfo, bm); + UNBLOCK_INPUT; + } + } +} + +/* Free all the bitmaps for the display specified by DPYINFO. */ + +void +x_destroy_all_bitmaps (dpyinfo) + Display_Info *dpyinfo; +{ + int i; + Bitmap_Record *bm = dpyinfo->bitmaps; + + for (i = 0; i < dpyinfo->bitmaps_last; i++, bm++) + if (bm->refcount > 0) + Free_Bitmap_Record (dpyinfo, bm); + + dpyinfo->bitmaps_last = 0; +} + + +#ifdef HAVE_X_WINDOWS + +/* Useful functions defined in the section + `Image type independent image structures' below. */ + +static unsigned long four_corners_best P_ ((XImagePtr ximg, unsigned long width, + unsigned long height)); + +static int x_create_x_image_and_pixmap P_ ((struct frame *f, int width, int height, + int depth, XImagePtr *ximg, + Pixmap *pixmap)); + +static void x_destroy_x_image P_ ((XImagePtr ximg)); + + +/* Create a mask of a bitmap. Note is this not a perfect mask. + It's nicer with some borders in this context */ + +int +x_create_bitmap_mask (f, id) + struct frame *f; + int id; +{ + Pixmap pixmap, mask; + XImagePtr ximg, mask_img; + unsigned long width, height; + int result; + unsigned long bg; + unsigned long x, y, xp, xm, yp, ym; + GC gc; + + Display_Info *dpyinfo = FRAME_X_DISPLAY_INFO (f); + + if (!(id > 0)) + return -1; + + pixmap = x_bitmap_pixmap (f, id); + width = x_bitmap_width (f, id); + height = x_bitmap_height (f, id); + + BLOCK_INPUT; + ximg = XGetImage (FRAME_X_DISPLAY (f), pixmap, 0, 0, width, height, + ~0, ZPixmap); + + if (!ximg) + { + UNBLOCK_INPUT; + return -1; + } + + result = x_create_x_image_and_pixmap (f, width, height, 1, &mask_img, &mask); + + UNBLOCK_INPUT; + if (!result) + { + XDestroyImage (ximg); + return -1; + } + + bg = four_corners_best (ximg, width, height); + + for (y = 0; y < ximg->height; ++y) + { + for (x = 0; x < ximg->width; ++x) + { + xp = x != ximg->width - 1 ? x + 1 : 0; + xm = x != 0 ? x - 1 : ximg->width - 1; + yp = y != ximg->height - 1 ? y + 1 : 0; + ym = y != 0 ? y - 1 : ximg->height - 1; + if (XGetPixel (ximg, x, y) == bg + && XGetPixel (ximg, x, yp) == bg + && XGetPixel (ximg, x, ym) == bg + && XGetPixel (ximg, xp, y) == bg + && XGetPixel (ximg, xp, yp) == bg + && XGetPixel (ximg, xp, ym) == bg + && XGetPixel (ximg, xm, y) == bg + && XGetPixel (ximg, xm, yp) == bg + && XGetPixel (ximg, xm, ym) == bg) + XPutPixel (mask_img, x, y, 0); + else + XPutPixel (mask_img, x, y, 1); + } + } + + xassert (interrupt_input_blocked); + gc = XCreateGC (FRAME_X_DISPLAY (f), mask, 0, NULL); + XPutImage (FRAME_X_DISPLAY (f), mask, gc, mask_img, 0, 0, 0, 0, + width, height); + XFreeGC (FRAME_X_DISPLAY (f), gc); + + dpyinfo->bitmaps[id - 1].have_mask = 1; + dpyinfo->bitmaps[id - 1].mask = mask; + + XDestroyImage (ximg); + x_destroy_x_image (mask_img); + + return 0; +} + +#endif /* HAVE_X_WINDOWS */ + + +/*********************************************************************** + Image types + ***********************************************************************/ + +/* Value is the number of elements of vector VECTOR. */ + +#define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR)) + +/* List of supported image types. Use define_image_type to add new + types. Use lookup_image_type to find a type for a given symbol. */ + +static struct image_type *image_types; + +/* The symbol `xbm' which is used as the type symbol for XBM images. */ + +Lisp_Object Qxbm; + +/* Keywords. */ + +extern Lisp_Object QCwidth, QCheight, QCforeground, QCbackground, QCfile; +extern Lisp_Object QCdata, QCtype; +Lisp_Object QCascent, QCmargin, QCrelief; +Lisp_Object QCconversion, QCcolor_symbols, QCheuristic_mask; +Lisp_Object QCindex, QCmatrix, QCcolor_adjustment, QCmask; + +/* Other symbols. */ + +Lisp_Object Qlaplace, Qemboss, Qedge_detection, Qheuristic; +Lisp_Object Qcenter; + +/* Time in seconds after which images should be removed from the cache + if not displayed. */ + +Lisp_Object Vimage_cache_eviction_delay; + +/* Function prototypes. */ + +static void define_image_type P_ ((struct image_type *type)); +static struct image_type *lookup_image_type P_ ((Lisp_Object symbol)); +static void image_error P_ ((char *format, Lisp_Object, Lisp_Object)); +static void x_laplace P_ ((struct frame *, struct image *)); +static void x_emboss P_ ((struct frame *, struct image *)); +static int x_build_heuristic_mask P_ ((struct frame *, struct image *, + Lisp_Object)); + + +/* Define a new image type from TYPE. This adds a copy of TYPE to + image_types and adds the symbol *TYPE->type to Vimage_types. */ + +static void +define_image_type (type) + struct image_type *type; +{ + /* Make a copy of TYPE to avoid a bus error in a dumped Emacs. + The initialized data segment is read-only. */ + struct image_type *p = (struct image_type *) xmalloc (sizeof *p); + bcopy (type, p, sizeof *p); + p->next = image_types; + image_types = p; + Vimage_types = Fcons (*p->type, Vimage_types); +} + + +/* Look up image type SYMBOL, and return a pointer to its image_type + structure. Value is null if SYMBOL is not a known image type. */ + +static INLINE struct image_type * +lookup_image_type (symbol) + Lisp_Object symbol; +{ + struct image_type *type; + + for (type = image_types; type; type = type->next) + if (EQ (symbol, *type->type)) + break; + + return type; +} + + +/* Value is non-zero if OBJECT is a valid Lisp image specification. A + valid image specification is a list whose car is the symbol + `image', and whose rest is a property list. The property list must + contain a value for key `:type'. That value must be the name of a + supported image type. The rest of the property list depends on the + image type. */ + +int +valid_image_p (object) + Lisp_Object object; +{ + int valid_p = 0; + + if (IMAGEP (object)) + { + Lisp_Object tem; + + for (tem = XCDR (object); CONSP (tem); tem = XCDR (tem)) + if (EQ (XCAR (tem), QCtype)) + { + tem = XCDR (tem); + if (CONSP (tem) && SYMBOLP (XCAR (tem))) + { + struct image_type *type; + type = lookup_image_type (XCAR (tem)); + if (type) + valid_p = type->valid_p (object); + } + + break; + } + } + + return valid_p; +} + + +/* Log error message with format string FORMAT and argument ARG. + Signaling an error, e.g. when an image cannot be loaded, is not a + good idea because this would interrupt redisplay, and the error + message display would lead to another redisplay. This function + therefore simply displays a message. */ + +static void +image_error (format, arg1, arg2) + char *format; + Lisp_Object arg1, arg2; +{ + add_to_log (format, arg1, arg2); +} + + + +/*********************************************************************** + Image specifications + ***********************************************************************/ + +enum image_value_type +{ + IMAGE_DONT_CHECK_VALUE_TYPE, + IMAGE_STRING_VALUE, + IMAGE_STRING_OR_NIL_VALUE, + IMAGE_SYMBOL_VALUE, + IMAGE_POSITIVE_INTEGER_VALUE, + IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, + IMAGE_NON_NEGATIVE_INTEGER_VALUE, + IMAGE_ASCENT_VALUE, + IMAGE_INTEGER_VALUE, + IMAGE_FUNCTION_VALUE, + IMAGE_NUMBER_VALUE, + IMAGE_BOOL_VALUE +}; + +/* Structure used when parsing image specifications. */ + +struct image_keyword +{ + /* Name of keyword. */ + char *name; + + /* The type of value allowed. */ + enum image_value_type type; + + /* Non-zero means key must be present. */ + int mandatory_p; + + /* Used to recognize duplicate keywords in a property list. */ + int count; + + /* The value that was found. */ + Lisp_Object value; +}; + + +static int parse_image_spec P_ ((Lisp_Object, struct image_keyword *, + int, Lisp_Object)); +static Lisp_Object image_spec_value P_ ((Lisp_Object, Lisp_Object, int *)); + + +/* Parse image spec SPEC according to KEYWORDS. A valid image spec + has the format (image KEYWORD VALUE ...). One of the keyword/ + value pairs must be `:type TYPE'. KEYWORDS is a vector of + image_keywords structures of size NKEYWORDS describing other + allowed keyword/value pairs. Value is non-zero if SPEC is valid. */ + +static int +parse_image_spec (spec, keywords, nkeywords, type) + Lisp_Object spec; + struct image_keyword *keywords; + int nkeywords; + Lisp_Object type; +{ + int i; + Lisp_Object plist; + + if (!IMAGEP (spec)) + return 0; + + plist = XCDR (spec); + while (CONSP (plist)) + { + Lisp_Object key, value; + + /* First element of a pair must be a symbol. */ + key = XCAR (plist); + plist = XCDR (plist); + if (!SYMBOLP (key)) + return 0; + + /* There must follow a value. */ + if (!CONSP (plist)) + return 0; + value = XCAR (plist); + plist = XCDR (plist); + + /* Find key in KEYWORDS. Error if not found. */ + for (i = 0; i < nkeywords; ++i) + if (strcmp (keywords[i].name, SDATA (SYMBOL_NAME (key))) == 0) + break; + + if (i == nkeywords) + continue; + + /* Record that we recognized the keyword. If a keywords + was found more than once, it's an error. */ + keywords[i].value = value; + ++keywords[i].count; + + if (keywords[i].count > 1) + return 0; + + /* Check type of value against allowed type. */ + switch (keywords[i].type) + { + case IMAGE_STRING_VALUE: + if (!STRINGP (value)) + return 0; + break; + + case IMAGE_STRING_OR_NIL_VALUE: + if (!STRINGP (value) && !NILP (value)) + return 0; + break; + + case IMAGE_SYMBOL_VALUE: + if (!SYMBOLP (value)) + return 0; + break; + + case IMAGE_POSITIVE_INTEGER_VALUE: + if (!INTEGERP (value) || XINT (value) <= 0) + return 0; + break; + + case IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR: + if (INTEGERP (value) && XINT (value) >= 0) + break; + if (CONSP (value) + && INTEGERP (XCAR (value)) && INTEGERP (XCDR (value)) + && XINT (XCAR (value)) >= 0 && XINT (XCDR (value)) >= 0) + break; + return 0; + + case IMAGE_ASCENT_VALUE: + if (SYMBOLP (value) && EQ (value, Qcenter)) + break; + else if (INTEGERP (value) + && XINT (value) >= 0 + && XINT (value) <= 100) + break; + return 0; + + case IMAGE_NON_NEGATIVE_INTEGER_VALUE: + if (!INTEGERP (value) || XINT (value) < 0) + return 0; + break; + + case IMAGE_DONT_CHECK_VALUE_TYPE: + break; + + case IMAGE_FUNCTION_VALUE: + value = indirect_function (value); + if (SUBRP (value) + || COMPILEDP (value) + || (CONSP (value) && EQ (XCAR (value), Qlambda))) + break; + return 0; + + case IMAGE_NUMBER_VALUE: + if (!INTEGERP (value) && !FLOATP (value)) + return 0; + break; + + case IMAGE_INTEGER_VALUE: + if (!INTEGERP (value)) + return 0; + break; + + case IMAGE_BOOL_VALUE: + if (!NILP (value) && !EQ (value, Qt)) + return 0; + break; + + default: + abort (); + break; + } + + if (EQ (key, QCtype) && !EQ (type, value)) + return 0; + } + + /* Check that all mandatory fields are present. */ + for (i = 0; i < nkeywords; ++i) + if (keywords[i].mandatory_p && keywords[i].count == 0) + return 0; + + return NILP (plist); +} + + +/* Return the value of KEY in image specification SPEC. Value is nil + if KEY is not present in SPEC. if FOUND is not null, set *FOUND + to 1 if KEY was found in SPEC, set it to 0 otherwise. */ + +static Lisp_Object +image_spec_value (spec, key, found) + Lisp_Object spec, key; + int *found; +{ + Lisp_Object tail; + + xassert (valid_image_p (spec)); + + for (tail = XCDR (spec); + CONSP (tail) && CONSP (XCDR (tail)); + tail = XCDR (XCDR (tail))) + { + if (EQ (XCAR (tail), key)) + { + if (found) + *found = 1; + return XCAR (XCDR (tail)); + } + } + + if (found) + *found = 0; + return Qnil; +} + + +DEFUN ("image-size", Fimage_size, Simage_size, 1, 3, 0, + doc: /* Return the size of image SPEC as pair (WIDTH . HEIGHT). +PIXELS non-nil means return the size in pixels, otherwise return the +size in canonical character units. +FRAME is the frame on which the image will be displayed. FRAME nil +or omitted means use the selected frame. */) + (spec, pixels, frame) + Lisp_Object spec, pixels, frame; +{ + Lisp_Object size; + + size = Qnil; + if (valid_image_p (spec)) + { + struct frame *f = check_x_frame (frame); + int id = lookup_image (f, spec); + struct image *img = IMAGE_FROM_ID (f, id); + int width = img->width + 2 * img->hmargin; + int height = img->height + 2 * img->vmargin; + + if (NILP (pixels)) + size = Fcons (make_float ((double) width / FRAME_COLUMN_WIDTH (f)), + make_float ((double) height / FRAME_LINE_HEIGHT (f))); + else + size = Fcons (make_number (width), make_number (height)); + } + else + error ("Invalid image specification"); + + return size; +} + + +DEFUN ("image-mask-p", Fimage_mask_p, Simage_mask_p, 1, 2, 0, + doc: /* Return t if image SPEC has a mask bitmap. +FRAME is the frame on which the image will be displayed. FRAME nil +or omitted means use the selected frame. */) + (spec, frame) + Lisp_Object spec, frame; +{ + Lisp_Object mask; + + mask = Qnil; + if (valid_image_p (spec)) + { + struct frame *f = check_x_frame (frame); + int id = lookup_image (f, spec); + struct image *img = IMAGE_FROM_ID (f, id); + if (img->mask) + mask = Qt; + } + else + error ("Invalid image specification"); + + return mask; +} + + +/*********************************************************************** + Image type independent image structures + ***********************************************************************/ + +static struct image *make_image P_ ((Lisp_Object spec, unsigned hash)); +static void free_image P_ ((struct frame *f, struct image *img)); + + +/* Allocate and return a new image structure for image specification + SPEC. SPEC has a hash value of HASH. */ + +static struct image * +make_image (spec, hash) + Lisp_Object spec; + unsigned hash; +{ + struct image *img = (struct image *) xmalloc (sizeof *img); + + xassert (valid_image_p (spec)); + bzero (img, sizeof *img); + img->type = lookup_image_type (image_spec_value (spec, QCtype, NULL)); + xassert (img->type != NULL); + img->spec = spec; + img->data.lisp_val = Qnil; + img->ascent = DEFAULT_IMAGE_ASCENT; + img->hash = hash; + return img; +} + + +/* Free image IMG which was used on frame F, including its resources. */ + +static void +free_image (f, img) + struct frame *f; + struct image *img; +{ + if (img) + { + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + + /* Remove IMG from the hash table of its cache. */ + if (img->prev) + img->prev->next = img->next; + else + c->buckets[img->hash % IMAGE_CACHE_BUCKETS_SIZE] = img->next; + + if (img->next) + img->next->prev = img->prev; + + c->images[img->id] = NULL; + + /* Free resources, then free IMG. */ + img->type->free (f, img); + xfree (img); + } +} + + +/* Prepare image IMG for display on frame F. Must be called before + drawing an image. */ + +void +prepare_image_for_display (f, img) + struct frame *f; + struct image *img; +{ + EMACS_TIME t; + + /* We're about to display IMG, so set its timestamp to `now'. */ + EMACS_GET_TIME (t); + img->timestamp = EMACS_SECS (t); + + /* If IMG doesn't have a pixmap yet, load it now, using the image + type dependent loader function. */ + if (img->pixmap == NO_PIXMAP && !img->load_failed_p) + img->load_failed_p = img->type->load (f, img) == 0; +} + + +/* Value is the number of pixels for the ascent of image IMG when + drawn in face FACE. */ + +int +image_ascent (img, face) + struct image *img; + struct face *face; +{ + int height = img->height + img->vmargin; + int ascent; + + if (img->ascent == CENTERED_IMAGE_ASCENT) + { + if (face->font) + { +#ifdef HAVE_NTGUI + /* W32 specific version. Why?. ++kfs */ + ascent = height / 2 - (FONT_DESCENT(face->font) + - FONT_BASE(face->font)) / 2; +#else + /* This expression is arranged so that if the image can't be + exactly centered, it will be moved slightly up. This is + because a typical font is `top-heavy' (due to the presence + uppercase letters), so the image placement should err towards + being top-heavy too. It also just generally looks better. */ + ascent = (height + face->font->ascent - face->font->descent + 1) / 2; +#endif /* HAVE_NTGUI */ + } + else + ascent = height / 2; + } + else + ascent = (int) (height * img->ascent / 100.0); + + return ascent; +} + + +/* Image background colors. */ + +/* Find the "best" corner color of a bitmap. + On W32, XIMG is assumed to a device context with the bitmap selected. */ + +static RGB_PIXEL_COLOR +four_corners_best (ximg, width, height) + XImagePtr_or_DC ximg; + unsigned long width, height; +{ + RGB_PIXEL_COLOR corners[4], best; + int i, best_count; + + /* Get the colors at the corners of ximg. */ + corners[0] = GET_PIXEL (ximg, 0, 0); + corners[1] = GET_PIXEL (ximg, width - 1, 0); + corners[2] = GET_PIXEL (ximg, width - 1, height - 1); + corners[3] = GET_PIXEL (ximg, 0, height - 1); + + /* Choose the most frequently found color as background. */ + for (i = best_count = 0; i < 4; ++i) + { + int j, n; + + for (j = n = 0; j < 4; ++j) + if (corners[i] == corners[j]) + ++n; + + if (n > best_count) + best = corners[i], best_count = n; + } + + return best; +} + +/* Portability macros */ + +#ifdef HAVE_NTGUI + +#define Destroy_Image(img_dc, prev) \ + do { SelectObject (img_dc, prev); DeleteDC (img_dc); } while (0) + +#define Free_Pixmap(display, pixmap) \ + DeleteObject (pixmap) + +#else + +#define Destroy_Image(ximg, dummy) \ + XDestroyImage (ximg) + +#define Free_Pixmap(display, pixmap) \ + XFreePixmap (display, pixmap) + +#endif /* HAVE_NTGUI */ + + +/* Return the `background' field of IMG. If IMG doesn't have one yet, + it is guessed heuristically. If non-zero, XIMG is an existing + XImage object (or device context with the image selected on W32) to + use for the heuristic. */ + +RGB_PIXEL_COLOR +image_background (img, f, ximg) + struct image *img; + struct frame *f; + XImagePtr_or_DC ximg; +{ + if (! img->background_valid) + /* IMG doesn't have a background yet, try to guess a reasonable value. */ + { + int free_ximg = !ximg; +#ifdef HAVE_NTGUI + HGDIOBJ prev; +#endif /* HAVE_NTGUI */ + + if (free_ximg) + { +#ifndef HAVE_NTGUI + ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap, + 0, 0, img->width, img->height, ~0, ZPixmap); +#else + HDC frame_dc = get_frame_dc (f); + ximg = CreateCompatibleDC (frame_dc); + release_frame_dc (f, frame_dc); + prev = SelectObject (ximg, img->pixmap); +#endif /* !HAVE_NTGUI */ + } + + img->background = four_corners_best (ximg, img->width, img->height); + + if (free_ximg) + Destroy_Image (ximg, prev); + + img->background_valid = 1; + } + + return img->background; +} + +/* Return the `background_transparent' field of IMG. If IMG doesn't + have one yet, it is guessed heuristically. If non-zero, MASK is an + existing XImage object to use for the heuristic. */ + +int +image_background_transparent (img, f, mask) + struct image *img; + struct frame *f; + XImagePtr_or_DC mask; +{ + if (! img->background_transparent_valid) + /* IMG doesn't have a background yet, try to guess a reasonable value. */ + { + if (img->mask) + { + int free_mask = !mask; +#ifdef HAVE_NTGUI + HGDIOBJ prev; +#endif /* HAVE_NTGUI */ + + if (free_mask) + { +#ifndef HAVE_NTGUI + mask = XGetImage (FRAME_X_DISPLAY (f), img->mask, + 0, 0, img->width, img->height, ~0, ZPixmap); +#else + HDC frame_dc = get_frame_dc (f); + mask = CreateCompatibleDC (frame_dc); + release_frame_dc (f, frame_dc); + prev = SelectObject (mask, img->mask); +#endif /* HAVE_NTGUI */ + } + + img->background_transparent + = (four_corners_best (mask, img->width, img->height) == PIX_MASK_RETAIN (f)); + + if (free_mask) + Destroy_Image (mask, prev); + } + else + img->background_transparent = 0; + + img->background_transparent_valid = 1; + } + + return img->background_transparent; +} + + +/*********************************************************************** + Helper functions for X image types + ***********************************************************************/ + +static void x_clear_image_1 P_ ((struct frame *, struct image *, int, + int, int)); +static void x_clear_image P_ ((struct frame *f, struct image *img)); +static unsigned long x_alloc_image_color P_ ((struct frame *f, + struct image *img, + Lisp_Object color_name, + unsigned long dflt)); + + +/* Clear X resources of image IMG on frame F. PIXMAP_P non-zero means + free the pixmap if any. MASK_P non-zero means clear the mask + pixmap if any. COLORS_P non-zero means free colors allocated for + the image, if any. */ + +static void +x_clear_image_1 (f, img, pixmap_p, mask_p, colors_p) + struct frame *f; + struct image *img; + int pixmap_p, mask_p, colors_p; +{ + if (pixmap_p && img->pixmap) + { + Free_Pixmap (FRAME_X_DISPLAY (f), img->pixmap); + img->pixmap = NO_PIXMAP; + img->background_valid = 0; + } + + if (mask_p && img->mask) + { + Free_Pixmap (FRAME_X_DISPLAY (f), img->mask); + img->mask = NO_PIXMAP; + img->background_transparent_valid = 0; + } + + if (colors_p && img->ncolors) + { + /* MAC_TODO: color table support. */ + /* W32_TODO: color table support. */ +#ifdef HAVE_X_WINDOWS + x_free_colors (f, img->colors, img->ncolors); +#endif /* HAVE_X_WINDOWS */ + xfree (img->colors); + img->colors = NULL; + img->ncolors = 0; + } +} + +/* Free X resources of image IMG which is used on frame F. */ + +static void +x_clear_image (f, img) + struct frame *f; + struct image *img; +{ + BLOCK_INPUT; + x_clear_image_1 (f, img, 1, 1, 1); + UNBLOCK_INPUT; +} + + +/* Allocate color COLOR_NAME for image IMG on frame F. If color + cannot be allocated, use DFLT. Add a newly allocated color to + IMG->colors, so that it can be freed again. Value is the pixel + color. */ + +static unsigned long +x_alloc_image_color (f, img, color_name, dflt) + struct frame *f; + struct image *img; + Lisp_Object color_name; + unsigned long dflt; +{ + XColor color; + unsigned long result; + + xassert (STRINGP (color_name)); + + if (x_defined_color (f, SDATA (color_name), &color, 1)) + { + /* This isn't called frequently so we get away with simply + reallocating the color vector to the needed size, here. */ + ++img->ncolors; + img->colors = + (unsigned long *) xrealloc (img->colors, + img->ncolors * sizeof *img->colors); + img->colors[img->ncolors - 1] = color.pixel; + result = color.pixel; + } + else + result = dflt; + + return result; +} + + + +/*********************************************************************** + Image Cache + ***********************************************************************/ + +static void cache_image P_ ((struct frame *f, struct image *img)); +static void postprocess_image P_ ((struct frame *, struct image *)); + +/* Return a new, initialized image cache that is allocated from the + heap. Call free_image_cache to free an image cache. */ + +struct image_cache * +make_image_cache () +{ + struct image_cache *c = (struct image_cache *) xmalloc (sizeof *c); + int size; + + bzero (c, sizeof *c); + c->size = 50; + c->images = (struct image **) xmalloc (c->size * sizeof *c->images); + size = IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets; + c->buckets = (struct image **) xmalloc (size); + bzero (c->buckets, size); + return c; +} + + +/* Free image cache of frame F. Be aware that X frames share images + caches. */ + +void +free_image_cache (f) + struct frame *f; +{ + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + if (c) + { + int i; + + /* Cache should not be referenced by any frame when freed. */ + xassert (c->refcount == 0); + + for (i = 0; i < c->used; ++i) + free_image (f, c->images[i]); + xfree (c->images); + xfree (c->buckets); + xfree (c); + FRAME_X_IMAGE_CACHE (f) = NULL; + } +} + + +/* Clear image cache of frame F. FORCE_P non-zero means free all + images. FORCE_P zero means clear only images that haven't been + displayed for some time. Should be called from time to time to + reduce the number of loaded images. If image-eviction-seconds is + non-nil, this frees images in the cache which weren't displayed for + at least that many seconds. */ + +void +clear_image_cache (f, force_p) + struct frame *f; + int force_p; +{ + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + + if (c && INTEGERP (Vimage_cache_eviction_delay)) + { + EMACS_TIME t; + unsigned long old; + int i, nfreed; + + EMACS_GET_TIME (t); + old = EMACS_SECS (t) - XFASTINT (Vimage_cache_eviction_delay); + + /* Block input so that we won't be interrupted by a SIGIO + while being in an inconsistent state. */ + BLOCK_INPUT; + + for (i = nfreed = 0; i < c->used; ++i) + { + struct image *img = c->images[i]; + if (img != NULL + && (force_p || img->timestamp < old)) + { + free_image (f, img); + ++nfreed; + } + } + + /* We may be clearing the image cache because, for example, + Emacs was iconified for a longer period of time. In that + case, current matrices may still contain references to + images freed above. So, clear these matrices. */ + if (nfreed) + { + Lisp_Object tail, frame; + + FOR_EACH_FRAME (tail, frame) + { + struct frame *f = XFRAME (frame); + if (FRAME_WINDOW_P (f) + && FRAME_X_IMAGE_CACHE (f) == c) + clear_current_matrices (f); + } + + ++windows_or_buffers_changed; + } + + UNBLOCK_INPUT; + } +} + + +DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache, + 0, 1, 0, + doc: /* Clear the image cache of FRAME. +FRAME nil or omitted means use the selected frame. +FRAME t means clear the image caches of all frames. */) + (frame) + Lisp_Object frame; +{ + if (EQ (frame, Qt)) + { + Lisp_Object tail; + + FOR_EACH_FRAME (tail, frame) + if (FRAME_WINDOW_P (XFRAME (frame))) + clear_image_cache (XFRAME (frame), 1); + } + else + clear_image_cache (check_x_frame (frame), 1); + + return Qnil; +} + + +/* Compute masks and transform image IMG on frame F, as specified + by the image's specification, */ + +static void +postprocess_image (f, img) + struct frame *f; + struct image *img; +{ + /* Manipulation of the image's mask. */ + if (img->pixmap) + { + Lisp_Object conversion, spec; + Lisp_Object mask; + + spec = img->spec; + + /* `:heuristic-mask t' + `:mask heuristic' + means build a mask heuristically. + `:heuristic-mask (R G B)' + `:mask (heuristic (R G B))' + means build a mask from color (R G B) in the + image. + `:mask nil' + means remove a mask, if any. */ + + mask = image_spec_value (spec, QCheuristic_mask, NULL); + if (!NILP (mask)) + x_build_heuristic_mask (f, img, mask); + else + { + int found_p; + + mask = image_spec_value (spec, QCmask, &found_p); + + if (EQ (mask, Qheuristic)) + x_build_heuristic_mask (f, img, Qt); + else if (CONSP (mask) + && EQ (XCAR (mask), Qheuristic)) + { + if (CONSP (XCDR (mask))) + x_build_heuristic_mask (f, img, XCAR (XCDR (mask))); + else + x_build_heuristic_mask (f, img, XCDR (mask)); + } + else if (NILP (mask) && found_p && img->mask) + { + Free_Pixmap (FRAME_X_DISPLAY (f), img->mask); + img->mask = NO_PIXMAP; + } + } + + + /* Should we apply an image transformation algorithm? */ + conversion = image_spec_value (spec, QCconversion, NULL); + if (EQ (conversion, Qdisabled)) + x_disable_image (f, img); + else if (EQ (conversion, Qlaplace)) + x_laplace (f, img); + else if (EQ (conversion, Qemboss)) + x_emboss (f, img); + else if (CONSP (conversion) + && EQ (XCAR (conversion), Qedge_detection)) + { + Lisp_Object tem; + tem = XCDR (conversion); + if (CONSP (tem)) + x_edge_detection (f, img, + Fplist_get (tem, QCmatrix), + Fplist_get (tem, QCcolor_adjustment)); + } + } +} + + +/* Return the id of image with Lisp specification SPEC on frame F. + SPEC must be a valid Lisp image specification (see valid_image_p). */ + +int +lookup_image (f, spec) + struct frame *f; + Lisp_Object spec; +{ + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + struct image *img; + int i; + unsigned hash; + struct gcpro gcpro1; + EMACS_TIME now; + + /* F must be a window-system frame, and SPEC must be a valid image + specification. */ + xassert (FRAME_WINDOW_P (f)); + xassert (valid_image_p (spec)); + + GCPRO1 (spec); + + /* Look up SPEC in the hash table of the image cache. */ + hash = sxhash (spec, 0); + i = hash % IMAGE_CACHE_BUCKETS_SIZE; + + for (img = c->buckets[i]; img; img = img->next) + if (img->hash == hash && !NILP (Fequal (img->spec, spec))) + break; + + /* If not found, create a new image and cache it. */ + if (img == NULL) + { + extern Lisp_Object Qpostscript; + + BLOCK_INPUT; + img = make_image (spec, hash); + cache_image (f, img); + img->load_failed_p = img->type->load (f, img) == 0; + + /* If we can't load the image, and we don't have a width and + height, use some arbitrary width and height so that we can + draw a rectangle for it. */ + if (img->load_failed_p) + { + Lisp_Object value; + + value = image_spec_value (spec, QCwidth, NULL); + img->width = (INTEGERP (value) + ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH); + value = image_spec_value (spec, QCheight, NULL); + img->height = (INTEGERP (value) + ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT); + } + else + { + /* Handle image type independent image attributes + `:ascent ASCENT', `:margin MARGIN', `:relief RELIEF', + `:background COLOR'. */ + Lisp_Object ascent, margin, relief, bg; + + ascent = image_spec_value (spec, QCascent, NULL); + if (INTEGERP (ascent)) + img->ascent = XFASTINT (ascent); + else if (EQ (ascent, Qcenter)) + img->ascent = CENTERED_IMAGE_ASCENT; + + margin = image_spec_value (spec, QCmargin, NULL); + if (INTEGERP (margin) && XINT (margin) >= 0) + img->vmargin = img->hmargin = XFASTINT (margin); + else if (CONSP (margin) && INTEGERP (XCAR (margin)) + && INTEGERP (XCDR (margin))) + { + if (XINT (XCAR (margin)) > 0) + img->hmargin = XFASTINT (XCAR (margin)); + if (XINT (XCDR (margin)) > 0) + img->vmargin = XFASTINT (XCDR (margin)); + } + + relief = image_spec_value (spec, QCrelief, NULL); + if (INTEGERP (relief)) + { + img->relief = XINT (relief); + img->hmargin += abs (img->relief); + img->vmargin += abs (img->relief); + } + + if (! img->background_valid) + { + bg = image_spec_value (img->spec, QCbackground, NULL); + if (!NILP (bg)) + { + img->background + = x_alloc_image_color (f, img, bg, + FRAME_BACKGROUND_PIXEL (f)); + img->background_valid = 1; + } + } + + /* Do image transformations and compute masks, unless we + don't have the image yet. */ + if (!EQ (*img->type->type, Qpostscript)) + postprocess_image (f, img); + } + + UNBLOCK_INPUT; + } + + /* We're using IMG, so set its timestamp to `now'. */ + EMACS_GET_TIME (now); + img->timestamp = EMACS_SECS (now); + + UNGCPRO; + + /* Value is the image id. */ + return img->id; +} + + +/* Cache image IMG in the image cache of frame F. */ + +static void +cache_image (f, img) + struct frame *f; + struct image *img; +{ + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + int i; + + /* Find a free slot in c->images. */ + for (i = 0; i < c->used; ++i) + if (c->images[i] == NULL) + break; + + /* If no free slot found, maybe enlarge c->images. */ + if (i == c->used && c->used == c->size) + { + c->size *= 2; + c->images = (struct image **) xrealloc (c->images, + c->size * sizeof *c->images); + } + + /* Add IMG to c->images, and assign IMG an id. */ + c->images[i] = img; + img->id = i; + if (i == c->used) + ++c->used; + + /* Add IMG to the cache's hash table. */ + i = img->hash % IMAGE_CACHE_BUCKETS_SIZE; + img->next = c->buckets[i]; + if (img->next) + img->next->prev = img; + img->prev = NULL; + c->buckets[i] = img; +} + + +/* Call FN on every image in the image cache of frame F. Used to mark + Lisp Objects in the image cache. */ + +void +forall_images_in_image_cache (f, fn) + struct frame *f; + void (*fn) P_ ((struct image *img)); +{ + if (FRAME_LIVE_P (f) && FRAME_WINDOW_P (f)) + { + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + if (c) + { + int i; + for (i = 0; i < c->used; ++i) + if (c->images[i]) + fn (c->images[i]); + } + } +} + + + +/*********************************************************************** + X / MAC / W32 support code + ***********************************************************************/ + +#ifdef HAVE_NTGUI + +/* Macro for defining functions that will be loaded from image DLLs. */ +#define DEF_IMGLIB_FN(func) FARPROC fn_##func + +/* Macro for loading those image functions from the library. */ +#define LOAD_IMGLIB_FN(lib,func) { \ + fn_##func = (void *) GetProcAddress (lib, #func); \ + if (!fn_##func) return 0; \ + } + +#endif /* HAVE_NTGUI */ + +static int x_create_x_image_and_pixmap P_ ((struct frame *, int, int, int, + XImagePtr *, Pixmap *)); +static void x_destroy_x_image P_ ((XImagePtr)); +static void x_put_x_image P_ ((struct frame *, XImagePtr, Pixmap, int, int)); + + +/* Create an XImage and a pixmap of size WIDTH x HEIGHT for use on + frame F. Set *XIMG and *PIXMAP to the XImage and Pixmap created. + Set (*XIMG)->data to a raster of WIDTH x HEIGHT pixels allocated + via xmalloc. Print error messages via image_error if an error + occurs. Value is non-zero if successful. + + On W32, a DEPTH of zero signifies a 24 bit image, otherwise DEPTH + should indicate the bit depth of the image. */ + +static int +x_create_x_image_and_pixmap (f, width, height, depth, ximg, pixmap) + struct frame *f; + int width, height, depth; + XImagePtr *ximg; + Pixmap *pixmap; +{ +#ifdef HAVE_X_WINDOWS + Display *display = FRAME_X_DISPLAY (f); + Window window = FRAME_X_WINDOW (f); + Screen *screen = FRAME_X_SCREEN (f); + + xassert (interrupt_input_blocked); + + if (depth <= 0) + depth = DefaultDepthOfScreen (screen); + *ximg = XCreateImage (display, DefaultVisualOfScreen (screen), + depth, ZPixmap, 0, NULL, width, height, + depth > 16 ? 32 : depth > 8 ? 16 : 8, 0); + if (*ximg == NULL) + { + image_error ("Unable to allocate X image", Qnil, Qnil); + return 0; + } + + /* Allocate image raster. */ + (*ximg)->data = (char *) xmalloc ((*ximg)->bytes_per_line * height); + + /* Allocate a pixmap of the same size. */ + *pixmap = XCreatePixmap (display, window, width, height, depth); + if (*pixmap == NO_PIXMAP) + { + x_destroy_x_image (*ximg); + *ximg = NULL; + image_error ("Unable to create X pixmap", Qnil, Qnil); + return 0; + } + + return 1; +#endif /* HAVE_X_WINDOWS */ + +#ifdef HAVE_NTGUI + + BITMAPINFOHEADER *header; + HDC hdc; + int scanline_width_bits; + int remainder; + int palette_colors = 0; + + if (depth == 0) + depth = 24; + + if (depth != 1 && depth != 4 && depth != 8 + && depth != 16 && depth != 24 && depth != 32) + { + image_error ("Invalid image bit depth specified", Qnil, Qnil); + return 0; + } + + scanline_width_bits = width * depth; + remainder = scanline_width_bits % 32; + + if (remainder) + scanline_width_bits += 32 - remainder; + + /* Bitmaps with a depth less than 16 need a palette. */ + /* BITMAPINFO structure already contains the first RGBQUAD. */ + if (depth < 16) + palette_colors = 1 << depth - 1; + + *ximg = xmalloc (sizeof (XImage) + palette_colors * sizeof (RGBQUAD)); + if (*ximg == NULL) + { + image_error ("Unable to allocate memory for XImage", Qnil, Qnil); + return 0; + } + + header = &((*ximg)->info.bmiHeader); + bzero (&((*ximg)->info), sizeof (BITMAPINFO)); + header->biSize = sizeof (*header); + header->biWidth = width; + header->biHeight = -height; /* negative indicates a top-down bitmap. */ + header->biPlanes = 1; + header->biBitCount = depth; + header->biCompression = BI_RGB; + header->biClrUsed = palette_colors; + + /* TODO: fill in palette. */ + if (depth == 1) + { + (*ximg)->info.bmiColors[0].rgbBlue = 0; + (*ximg)->info.bmiColors[0].rgbGreen = 0; + (*ximg)->info.bmiColors[0].rgbRed = 0; + (*ximg)->info.bmiColors[0].rgbReserved = 0; + (*ximg)->info.bmiColors[1].rgbBlue = 255; + (*ximg)->info.bmiColors[1].rgbGreen = 255; + (*ximg)->info.bmiColors[1].rgbRed = 255; + (*ximg)->info.bmiColors[1].rgbReserved = 0; + } + + hdc = get_frame_dc (f); + + /* Create a DIBSection and raster array for the bitmap, + and store its handle in *pixmap. */ + *pixmap = CreateDIBSection (hdc, &((*ximg)->info), + (depth < 16) ? DIB_PAL_COLORS : DIB_RGB_COLORS, + &((*ximg)->data), NULL, 0); + + /* Realize display palette and garbage all frames. */ + release_frame_dc (f, hdc); + + if (*pixmap == NULL) + { + DWORD err = GetLastError(); + Lisp_Object errcode; + /* All system errors are < 10000, so the following is safe. */ + XSETINT (errcode, (int) err); + image_error ("Unable to create bitmap, error code %d", errcode, Qnil); + x_destroy_x_image (*ximg); + return 0; + } + + return 1; + +#endif /* HAVE_NTGUI */ + +#ifdef MAC_OS + Display *display = FRAME_X_DISPLAY (f); + Window window = FRAME_X_WINDOW (f); + + xassert (interrupt_input_blocked); + + /* Allocate a pixmap of the same size. */ + *pixmap = XCreatePixmap (display, window, width, height, depth); + if (*pixmap == NO_PIXMAP) + { + x_destroy_x_image (*ximg); + *ximg = NULL; + image_error ("Unable to create X pixmap", Qnil, Qnil); + return 0; + } + + LockPixels (GetGWorldPixMap (*pixmap)); + *ximg = *pixmap; + return 1; + +#endif /* MAC_OS */ +} + + +/* Destroy XImage XIMG. Free XIMG->data. */ + +static void +x_destroy_x_image (ximg) + XImagePtr ximg; +{ + xassert (interrupt_input_blocked); + if (ximg) + { +#ifdef HAVE_X_WINDOWS + xfree (ximg->data); + ximg->data = NULL; + XDestroyImage (ximg); +#endif /* HAVE_X_WINDOWS */ +#ifdef HAVE_NTGUI + /* Data will be freed by DestroyObject. */ + ximg->data = NULL; + xfree (ximg); +#endif /* HAVE_NTGUI */ +#ifdef MAC_OS + XDestroyImage (ximg); +#endif /* MAC_OS */ + } +} + + +/* Put XImage XIMG into pixmap PIXMAP on frame F. WIDTH and HEIGHT + are width and height of both the image and pixmap. */ + +static void +x_put_x_image (f, ximg, pixmap, width, height) + struct frame *f; + XImagePtr ximg; + Pixmap pixmap; + int width, height; +{ +#ifdef HAVE_X_WINDOWS + GC gc; + + xassert (interrupt_input_blocked); + gc = XCreateGC (FRAME_X_DISPLAY (f), pixmap, 0, NULL); + XPutImage (FRAME_X_DISPLAY (f), pixmap, gc, ximg, 0, 0, 0, 0, width, height); + XFreeGC (FRAME_X_DISPLAY (f), gc); +#endif /* HAVE_X_WINDOWS */ + +#ifdef HAVE_NTGUI +#if 0 /* I don't think this is necessary looking at where it is used. */ + HDC hdc = get_frame_dc (f); + SetDIBits (hdc, pixmap, 0, height, ximg->data, &(ximg->info), DIB_RGB_COLORS); + release_frame_dc (f, hdc); +#endif +#endif /* HAVE_NTGUI */ + +#ifdef MAC_OS + xassert (ximg == pixmap); +#endif /* MAC_OS */ +} + + +/*********************************************************************** + File Handling + ***********************************************************************/ + +static unsigned char *slurp_file P_ ((char *, int *)); + + +/* Find image file FILE. Look in data-directory, then + x-bitmap-file-path. Value is the full name of the file found, or + nil if not found. */ + +Lisp_Object +x_find_image_file (file) + Lisp_Object file; +{ + Lisp_Object file_found, search_path; + struct gcpro gcpro1, gcpro2; + int fd; + + file_found = Qnil; + search_path = Fcons (Vdata_directory, Vx_bitmap_file_path); + GCPRO2 (file_found, search_path); + + /* Try to find FILE in data-directory, then x-bitmap-file-path. */ + fd = openp (search_path, file, Qnil, &file_found, Qnil); + + if (fd == -1) + file_found = Qnil; + else + close (fd); + + UNGCPRO; + return file_found; +} + + +/* Read FILE into memory. Value is a pointer to a buffer allocated + with xmalloc holding FILE's contents. Value is null if an error + occurred. *SIZE is set to the size of the file. */ + +static unsigned char * +slurp_file (file, size) + char *file; + int *size; +{ + FILE *fp = NULL; + unsigned char *buf = NULL; + struct stat st; + + if (stat (file, &st) == 0 + && (fp = fopen (file, "rb")) != NULL + && (buf = (char *) xmalloc (st.st_size), + fread (buf, 1, st.st_size, fp) == st.st_size)) + { + *size = st.st_size; + fclose (fp); + } + else + { + if (fp) + fclose (fp); + if (buf) + { + xfree (buf); + buf = NULL; + } + } + + return buf; +} + + + +#ifdef MAC_OS + +/*********************************************************************** + MAC Image Load Functions + ***********************************************************************/ + +static int image_load_quicktime P_ ((struct frame *, struct image *img, + OSType)); +#ifdef MAC_OSX +static int image_load_quartz2d P_ ((struct frame *, struct image *img, int)); +#endif + +static OSErr +find_image_fsspec (specified_file, file, fss) + Lisp_Object specified_file, *file; + FSSpec *fss; +{ +#if TARGET_API_MAC_CARBON + FSRef fsr; +#else + Str255 mac_pathname; +#endif + OSErr err; + + *file = x_find_image_file (specified_file); + if (!STRINGP (*file)) + return fnfErr; /* file or directory not found; + incomplete pathname */ + /* Try to open the image file. */ +#if TARGET_API_MAC_CARBON + err = FSPathMakeRef (SDATA (*file), &fsr, NULL); + if (err == noErr) + err = FSGetCatalogInfo (&fsr, kFSCatInfoNone, NULL, NULL, fss, NULL); +#else + if (posix_to_mac_pathname (SDATA (*file), mac_pathname, MAXPATHLEN+1) == 0) + return fnfErr; + c2pstr (mac_pathname); + err = FSMakeFSSpec (0, 0, mac_pathname, fss); +#endif + return err; +} + +static int +image_load_qt_1 (f, img, type, fss, dh) + struct frame *f; + struct image *img; + OSType type; + FSSpec *fss; + Handle dh; +{ + OSErr err; + GraphicsImportComponent gi; + Rect rect; + int width, height; + short draw_all_pixels; + Lisp_Object specified_bg; + XColor color; + XImagePtr ximg; + RGBColor bg_color; + + err = OpenADefaultComponent (GraphicsImporterComponentType, + type, &gi); + if (err != noErr) + { + image_error ("Cannot get importer component for `%s'", img->spec, Qnil); + return 0; + } + if (dh == NULL) + { + /* read from file system spec */ + err = GraphicsImportSetDataFile (gi, fss); + if (err != noErr) + { + image_error ("Cannot set fsspec to graphics importer for '%s'", + img->spec, Qnil); + goto error; + } + } + else + { + /* read from data handle */ + err = GraphicsImportSetDataHandle (gi, dh); + if (err != noErr) + { + image_error ("Cannot set data handle to graphics importer for `%s'", + img->spec, Qnil); + goto error; + } + } + err = GraphicsImportGetNaturalBounds (gi, &rect); + if (err != noErr) + { + image_error ("Error reading `%s'", img->spec, Qnil); + goto error; + } + width = img->width = rect.right - rect.left; + height = img->height = rect.bottom - rect.top; + err = GraphicsImportDoesDrawAllPixels (gi, &draw_all_pixels); +#if 0 + /* Don't check the error code here. It may have an undocumented + value -32766. */ + if (err != noErr) + { + image_error ("Error reading `%s'", img->spec, Qnil); + goto error; + } +#endif + if (draw_all_pixels != graphicsImporterDrawsAllPixels) + { + specified_bg = image_spec_value (img->spec, QCbackground, NULL); + if (!STRINGP (specified_bg) || + !mac_defined_color (f, SDATA (specified_bg), &color, 0)) + { + color.pixel = FRAME_BACKGROUND_PIXEL (f); + color.red = RED16_FROM_ULONG (color.pixel); + color.green = GREEN16_FROM_ULONG (color.pixel); + color.blue = BLUE16_FROM_ULONG (color.pixel); + } + } + + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) + goto error; + if (draw_all_pixels != graphicsImporterDrawsAllPixels) + { + SetGWorld (ximg, NULL); + bg_color.red = color.red; + bg_color.green = color.green; + bg_color.blue = color.blue; + RGBBackColor (&bg_color); +#if TARGET_API_MAC_CARBON + GetPortBounds (ximg, &rect); + EraseRect (&rect); +#else + EraseRect (&(ximg->portRect)); +#endif + } + GraphicsImportSetGWorld (gi, ximg, NULL); + GraphicsImportDraw (gi); + CloseComponent (gi); + + /* Maybe fill in the background field while we have ximg handy. */ + if (NILP (image_spec_value (img->spec, QCbackground, NULL))) + IMAGE_BACKGROUND (img, f, ximg); + + /* Put the image into the pixmap. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + return 1; + + error: + CloseComponent (gi); + return 0; +} + + +/* Load an image using the QuickTime Graphics Importer. + Note: The alpha channel does not work for PNG images. */ +static int +image_load_quicktime (f, img, type) + struct frame *f; + struct image *img; + OSType type; +{ + Lisp_Object specified_file; + Lisp_Object specified_data; + OSErr err; + + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + + if (NILP (specified_data)) + { + /* Read from a file */ + Lisp_Object file; + FSSpec fss; + + err = find_image_fsspec (specified_file, &file, &fss); + if (err != noErr) + { + if (err == fnfErr) + image_error ("Cannot find image file `%s'", specified_file, Qnil); + else + image_error ("Cannot open `%s'", file, Qnil); + return 0; + } + return image_load_qt_1 (f, img, type, &fss, NULL); + } + else + { + /* Memory source! */ + int success_p; + Handle dh; + + err = PtrToHand (SDATA (specified_data), &dh, SBYTES (specified_data)); + if (err != noErr) + { + image_error ("Cannot allocate data handle for `%s'", + img->spec, Qnil); + return 0; + } + success_p = image_load_qt_1 (f, img, type, NULL, dh); + DisposeHandle (dh); + return success_p; + } +} + + +#ifdef MAC_OSX +/* Load a PNG/JPEG image using Quartz 2D decoding routines. + CGImageCreateWithPNGDataProvider is provided after Mac OS X 10.2. + So don't use this function directly but determine at runtime + whether it exists. */ +typedef CGImageRef (*CGImageCreateWithPNGDataProviderProcType) + (CGDataProviderRef, const float [], bool, CGColorRenderingIntent); +static CGImageCreateWithPNGDataProviderProcType MyCGImageCreateWithPNGDataProvider; + + +static void +init_image_func_pointer () +{ + if (NSIsSymbolNameDefined ("_CGImageCreateWithPNGDataProvider")) + { + MyCGImageCreateWithPNGDataProvider + = (CGImageCreateWithPNGDataProviderProcType) + NSAddressOfSymbol (NSLookupAndBindSymbol + ("_CGImageCreateWithPNGDataProvider")); + } + else + MyCGImageCreateWithPNGDataProvider = NULL; +} + + +static int +image_load_quartz2d (f, img, png_p) + struct frame *f; + struct image *img; + int png_p; +{ + Lisp_Object file, specified_file; + Lisp_Object specified_data, specified_bg; + struct gcpro gcpro1; + CGDataProviderRef source; + CGImageRef image; + int width, height; + XColor color; + XImagePtr ximg = NULL; + CGContextRef context; + CGRect rectangle; + + /* Open the file. */ + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + + file = Qnil; + GCPRO1 (file); + + if (NILP (specified_data)) + { + CFStringRef path; + CFURLRef url; + + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + path = CFStringCreateWithCString (NULL, SDATA (file), + kCFStringEncodingUTF8); + url = CFURLCreateWithFileSystemPath (NULL, path, + kCFURLPOSIXPathStyle, 0); + CFRelease (path); + source = CGDataProviderCreateWithURL (url); + CFRelease (url); + } + else + source = CGDataProviderCreateWithData (NULL, SDATA (specified_data), + SBYTES (specified_data), NULL); + + if (png_p) + image = (*MyCGImageCreateWithPNGDataProvider) (source, NULL, FALSE, + kCGRenderingIntentDefault); + else + image = CGImageCreateWithJPEGDataProvider (source, NULL, FALSE, + kCGRenderingIntentDefault); + + CGDataProviderRelease (source); + if (image == NULL) + { + UNGCPRO; + image_error ("Error reading image `%s'", img->spec, Qnil); + return 0; + } + + if (png_p) + { + specified_bg = image_spec_value (img->spec, QCbackground, NULL); + if (!STRINGP (specified_bg) || + !mac_defined_color (f, SDATA (specified_bg), &color, 0)) + { + color.pixel = FRAME_BACKGROUND_PIXEL (f); + color.red = RED16_FROM_ULONG (color.pixel); + color.green = GREEN16_FROM_ULONG (color.pixel); + color.blue = BLUE16_FROM_ULONG (color.pixel); + } + } + width = img->width = CGImageGetWidth (image); + height = img->height = CGImageGetHeight (image); + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) + { + CGImageRelease (image); + UNGCPRO; + return 0; + } + rectangle = CGRectMake (0, 0, width, height); + QDBeginCGContext (ximg, &context); + if (png_p) + { + CGContextSetRGBFillColor (context, color.red / 65535.0, + color.green / 65535.0, + color.blue / 65535.0, 1.0); + CGContextFillRect (context, rectangle); + } + CGContextDrawImage (context, rectangle, image); + QDEndCGContext (ximg, &context); + CGImageRelease (image); + + /* Maybe fill in the background field while we have ximg handy. */ + if (NILP (image_spec_value (img->spec, QCbackground, NULL))) + IMAGE_BACKGROUND (img, f, ximg); + + /* Put the image into the pixmap. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + UNGCPRO; + return 1; +} +#endif + +#endif /* MAC_OS */ + + +/*********************************************************************** + XBM images + ***********************************************************************/ + +static int xbm_scan P_ ((unsigned char **, unsigned char *, char *, int *)); +static int xbm_load P_ ((struct frame *f, struct image *img)); +static int xbm_load_image P_ ((struct frame *f, struct image *img, + unsigned char *, unsigned char *)); +static int xbm_image_p P_ ((Lisp_Object object)); +static int xbm_read_bitmap_data P_ ((unsigned char *, unsigned char *, + int *, int *, unsigned char **)); +static int xbm_file_p P_ ((Lisp_Object)); + + +/* Indices of image specification fields in xbm_format, below. */ + +enum xbm_keyword_index +{ + XBM_TYPE, + XBM_FILE, + XBM_WIDTH, + XBM_HEIGHT, + XBM_DATA, + XBM_FOREGROUND, + XBM_BACKGROUND, + XBM_ASCENT, + XBM_MARGIN, + XBM_RELIEF, + XBM_ALGORITHM, + XBM_HEURISTIC_MASK, + XBM_MASK, + XBM_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid XBM image specifications. */ + +static struct image_keyword xbm_format[XBM_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":file", IMAGE_STRING_VALUE, 0}, + {":width", IMAGE_POSITIVE_INTEGER_VALUE, 0}, + {":height", IMAGE_POSITIVE_INTEGER_VALUE, 0}, + {":data", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0} +}; + +/* Structure describing the image type XBM. */ + +static struct image_type xbm_type = +{ + &Qxbm, + xbm_image_p, + xbm_load, + x_clear_image, + NULL +}; + +/* Tokens returned from xbm_scan. */ + +enum xbm_token +{ + XBM_TK_IDENT = 256, + XBM_TK_NUMBER +}; + + +/* Return non-zero if OBJECT is a valid XBM-type image specification. + A valid specification is a list starting with the symbol `image' + The rest of the list is a property list which must contain an + entry `:type xbm.. + + If the specification specifies a file to load, it must contain + an entry `:file FILENAME' where FILENAME is a string. + + If the specification is for a bitmap loaded from memory it must + contain `:width WIDTH', `:height HEIGHT', and `:data DATA', where + WIDTH and HEIGHT are integers > 0. DATA may be: + + 1. a string large enough to hold the bitmap data, i.e. it must + have a size >= (WIDTH + 7) / 8 * HEIGHT + + 2. a bool-vector of size >= WIDTH * HEIGHT + + 3. a vector of strings or bool-vectors, one for each line of the + bitmap. + + 4. A string containing an in-memory XBM file. WIDTH and HEIGHT + may not be specified in this case because they are defined in the + XBM file. + + Both the file and data forms may contain the additional entries + `:background COLOR' and `:foreground COLOR'. If not present, + foreground and background of the frame on which the image is + displayed is used. */ + +static int +xbm_image_p (object) + Lisp_Object object; +{ + struct image_keyword kw[XBM_LAST]; + + bcopy (xbm_format, kw, sizeof kw); + if (!parse_image_spec (object, kw, XBM_LAST, Qxbm)) + return 0; + + xassert (EQ (kw[XBM_TYPE].value, Qxbm)); + + if (kw[XBM_FILE].count) + { + if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_DATA].count) + return 0; + } + else if (kw[XBM_DATA].count && xbm_file_p (kw[XBM_DATA].value)) + { + /* In-memory XBM file. */ + if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_FILE].count) + return 0; + } + else + { + Lisp_Object data; + int width, height; + + /* Entries for `:width', `:height' and `:data' must be present. */ + if (!kw[XBM_WIDTH].count + || !kw[XBM_HEIGHT].count + || !kw[XBM_DATA].count) + return 0; + + data = kw[XBM_DATA].value; + width = XFASTINT (kw[XBM_WIDTH].value); + height = XFASTINT (kw[XBM_HEIGHT].value); + + /* Check type of data, and width and height against contents of + data. */ + if (VECTORP (data)) + { + int i; + + /* Number of elements of the vector must be >= height. */ + if (XVECTOR (data)->size < height) + return 0; + + /* Each string or bool-vector in data must be large enough + for one line of the image. */ + for (i = 0; i < height; ++i) + { + Lisp_Object elt = XVECTOR (data)->contents[i]; + + if (STRINGP (elt)) + { + if (SCHARS (elt) + < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR) + return 0; + } + else if (BOOL_VECTOR_P (elt)) + { + if (XBOOL_VECTOR (elt)->size < width) + return 0; + } + else + return 0; + } + } + else if (STRINGP (data)) + { + if (SCHARS (data) + < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height) + return 0; + } + else if (BOOL_VECTOR_P (data)) + { + if (XBOOL_VECTOR (data)->size < width * height) + return 0; + } + else + return 0; + } + + return 1; +} + + +/* Scan a bitmap file. FP is the stream to read from. Value is + either an enumerator from enum xbm_token, or a character for a + single-character token, or 0 at end of file. If scanning an + identifier, store the lexeme of the identifier in SVAL. If + scanning a number, store its value in *IVAL. */ + +static int +xbm_scan (s, end, sval, ival) + unsigned char **s, *end; + char *sval; + int *ival; +{ + unsigned int c; + + loop: + + /* Skip white space. */ + while (*s < end && (c = *(*s)++, isspace (c))) + ; + + if (*s >= end) + c = 0; + else if (isdigit (c)) + { + int value = 0, digit; + + if (c == '0' && *s < end) + { + c = *(*s)++; + if (c == 'x' || c == 'X') + { + while (*s < end) + { + c = *(*s)++; + if (isdigit (c)) + digit = c - '0'; + else if (c >= 'a' && c <= 'f') + digit = c - 'a' + 10; + else if (c >= 'A' && c <= 'F') + digit = c - 'A' + 10; + else + break; + value = 16 * value + digit; + } + } + else if (isdigit (c)) + { + value = c - '0'; + while (*s < end + && (c = *(*s)++, isdigit (c))) + value = 8 * value + c - '0'; + } + } + else + { + value = c - '0'; + while (*s < end + && (c = *(*s)++, isdigit (c))) + value = 10 * value + c - '0'; + } + + if (*s < end) + *s = *s - 1; + *ival = value; + c = XBM_TK_NUMBER; + } + else if (isalpha (c) || c == '_') + { + *sval++ = c; + while (*s < end + && (c = *(*s)++, (isalnum (c) || c == '_'))) + *sval++ = c; + *sval = 0; + if (*s < end) + *s = *s - 1; + c = XBM_TK_IDENT; + } + else if (c == '/' && **s == '*') + { + /* C-style comment. */ + ++*s; + while (**s && (**s != '*' || *(*s + 1) != '/')) + ++*s; + if (**s) + { + *s += 2; + goto loop; + } + } + + return c; +} + +#ifdef HAVE_NTGUI + +/* Create a Windows bitmap from X bitmap data. */ +static HBITMAP +w32_create_pixmap_from_bitmap_data (int width, int height, char *data) +{ + static unsigned char swap_nibble[16] + = { 0x0, 0x8, 0x4, 0xc, /* 0000 1000 0100 1100 */ + 0x2, 0xa, 0x6, 0xe, /* 0010 1010 0110 1110 */ + 0x1, 0x9, 0x5, 0xd, /* 0001 1001 0101 1101 */ + 0x3, 0xb, 0x7, 0xf }; /* 0011 1011 0111 1111 */ + int i, j, w1, w2; + unsigned char *bits, *p; + HBITMAP bmp; + + w1 = (width + 7) / 8; /* nb of 8bits elt in X bitmap */ + w2 = ((width + 15) / 16) * 2; /* nb of 16bits elt in W32 bitmap */ + bits = (unsigned char *) alloca (height * w2); + bzero (bits, height * w2); + for (i = 0; i < height; i++) + { + p = bits + i*w2; + for (j = 0; j < w1; j++) + { + /* Bitswap XBM bytes to match how Windows does things. */ + unsigned char c = *data++; + *p++ = (unsigned char)((swap_nibble[c & 0xf] << 4) + | (swap_nibble[(c>>4) & 0xf])); + } + } + bmp = CreateBitmap (width, height, 1, 1, (char *) bits); + + return bmp; +} + +static void convert_mono_to_color_image (f, img, foreground, background) + struct frame *f; + struct image *img; + COLORREF foreground, background; +{ + HDC hdc, old_img_dc, new_img_dc; + HGDIOBJ old_prev, new_prev; + HBITMAP new_pixmap; + + hdc = get_frame_dc (f); + old_img_dc = CreateCompatibleDC (hdc); + new_img_dc = CreateCompatibleDC (hdc); + new_pixmap = CreateCompatibleBitmap (hdc, img->width, img->height); + release_frame_dc (f, hdc); + old_prev = SelectObject (old_img_dc, img->pixmap); + new_prev = SelectObject (new_img_dc, new_pixmap); + SetTextColor (new_img_dc, foreground); + SetBkColor (new_img_dc, background); + + BitBlt (new_img_dc, 0, 0, img->width, img->height, old_img_dc, + 0, 0, SRCCOPY); + + SelectObject (old_img_dc, old_prev); + SelectObject (new_img_dc, new_prev); + DeleteDC (old_img_dc); + DeleteDC (new_img_dc); + DeleteObject (img->pixmap); + if (new_pixmap == 0) + fprintf (stderr, "Failed to convert image to color.\n"); + else + img->pixmap = new_pixmap; +} + +#define XBM_BIT_SHUFFLE(b) (~(b)) + +#else + +#define XBM_BIT_SHUFFLE(b) (b) + +#endif /* HAVE_NTGUI */ + + +static void +Create_Pixmap_From_Bitmap_Data(f, img, data, fg, bg, non_default_colors) + struct frame *f; + struct image *img; + char *data; + RGB_PIXEL_COLOR fg, bg; + int non_default_colors; +{ +#ifdef HAVE_NTGUI + img->pixmap + = w32_create_pixmap_from_bitmap_data (img->width, img->height, data); + + /* If colors were specified, transfer the bitmap to a color one. */ + if (non_default_colors) + convert_mono_to_color_image (f, img, fg, bg); +#else + img->pixmap + = XCreatePixmapFromBitmapData (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + data, + img->width, img->height, + fg, bg, + DefaultDepthOfScreen (FRAME_X_SCREEN (f))); +#endif /* HAVE_NTGUI */ +} + + + +/* Replacement for XReadBitmapFileData which isn't available under old + X versions. CONTENTS is a pointer to a buffer to parse; END is the + buffer's end. Set *WIDTH and *HEIGHT to the width and height of + the image. Return in *DATA the bitmap data allocated with xmalloc. + Value is non-zero if successful. DATA null means just test if + CONTENTS looks like an in-memory XBM file. */ + +static int +xbm_read_bitmap_data (contents, end, width, height, data) + unsigned char *contents, *end; + int *width, *height; + unsigned char **data; +{ + unsigned char *s = contents; + char buffer[BUFSIZ]; + int padding_p = 0; + int v10 = 0; + int bytes_per_line, i, nbytes; + unsigned char *p; + int value; + int LA1; + +#define match() \ + LA1 = xbm_scan (&s, end, buffer, &value) + +#define expect(TOKEN) \ + if (LA1 != (TOKEN)) \ + goto failure; \ + else \ + match () + +#define expect_ident(IDENT) \ + if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \ + match (); \ + else \ + goto failure + + *width = *height = -1; + if (data) + *data = NULL; + LA1 = xbm_scan (&s, end, buffer, &value); + + /* Parse defines for width, height and hot-spots. */ + while (LA1 == '#') + { + match (); + expect_ident ("define"); + expect (XBM_TK_IDENT); + + if (LA1 == XBM_TK_NUMBER); + { + char *p = strrchr (buffer, '_'); + p = p ? p + 1 : buffer; + if (strcmp (p, "width") == 0) + *width = value; + else if (strcmp (p, "height") == 0) + *height = value; + } + expect (XBM_TK_NUMBER); + } + + if (*width < 0 || *height < 0) + goto failure; + else if (data == NULL) + goto success; + + /* Parse bits. Must start with `static'. */ + expect_ident ("static"); + if (LA1 == XBM_TK_IDENT) + { + if (strcmp (buffer, "unsigned") == 0) + { + match (); + expect_ident ("char"); + } + else if (strcmp (buffer, "short") == 0) + { + match (); + v10 = 1; + if (*width % 16 && *width % 16 < 9) + padding_p = 1; + } + else if (strcmp (buffer, "char") == 0) + match (); + else + goto failure; + } + else + goto failure; + + expect (XBM_TK_IDENT); + expect ('['); + expect (']'); + expect ('='); + expect ('{'); + + bytes_per_line = (*width + 7) / 8 + padding_p; + nbytes = bytes_per_line * *height; + p = *data = (char *) xmalloc (nbytes); + + if (v10) + { + for (i = 0; i < nbytes; i += 2) + { + int val = value; + expect (XBM_TK_NUMBER); + + *p++ = XBM_BIT_SHUFFLE (val); + if (!padding_p || ((i + 2) % bytes_per_line)) + *p++ = XBM_BIT_SHUFFLE (value >> 8); + + if (LA1 == ',' || LA1 == '}') + match (); + else + goto failure; + } + } + else + { + for (i = 0; i < nbytes; ++i) + { + int val = value; + expect (XBM_TK_NUMBER); + + *p++ = XBM_BIT_SHUFFLE (val); + + if (LA1 == ',' || LA1 == '}') + match (); + else + goto failure; + } + } + + success: + return 1; + + failure: + + if (data && *data) + { + xfree (*data); + *data = NULL; + } + return 0; + +#undef match +#undef expect +#undef expect_ident +} + + +/* Load XBM image IMG which will be displayed on frame F from buffer + CONTENTS. END is the end of the buffer. Value is non-zero if + successful. */ + +static int +xbm_load_image (f, img, contents, end) + struct frame *f; + struct image *img; + unsigned char *contents, *end; +{ + int rc; + unsigned char *data; + int success_p = 0; + + rc = xbm_read_bitmap_data (contents, end, &img->width, &img->height, &data); + if (rc) + { + unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); + unsigned long background = FRAME_BACKGROUND_PIXEL (f); + int non_default_colors = 0; + Lisp_Object value; + + xassert (img->width > 0 && img->height > 0); + + /* Get foreground and background colors, maybe allocate colors. */ + value = image_spec_value (img->spec, QCforeground, NULL); + if (!NILP (value)) + { + foreground = x_alloc_image_color (f, img, value, foreground); + non_default_colors = 1; + } + value = image_spec_value (img->spec, QCbackground, NULL); + if (!NILP (value)) + { + background = x_alloc_image_color (f, img, value, background); + img->background = background; + img->background_valid = 1; + non_default_colors = 1; + } + + Create_Pixmap_From_Bitmap_Data (f, img, data, + foreground, background, + non_default_colors); + xfree (data); + + if (img->pixmap == NO_PIXMAP) + { + x_clear_image (f, img); + image_error ("Unable to create X pixmap for `%s'", img->spec, Qnil); + } + else + success_p = 1; + } + else + image_error ("Error loading XBM image `%s'", img->spec, Qnil); + + return success_p; +} + + +/* Value is non-zero if DATA looks like an in-memory XBM file. */ + +static int +xbm_file_p (data) + Lisp_Object data; +{ + int w, h; + return (STRINGP (data) + && xbm_read_bitmap_data (SDATA (data), + (SDATA (data) + + SBYTES (data)), + &w, &h, NULL)); +} + + +/* Fill image IMG which is used on frame F with pixmap data. Value is + non-zero if successful. */ + +static int +xbm_load (f, img) + struct frame *f; + struct image *img; +{ + int success_p = 0; + Lisp_Object file_name; + + xassert (xbm_image_p (img->spec)); + + /* If IMG->spec specifies a file name, create a non-file spec from it. */ + file_name = image_spec_value (img->spec, QCfile, NULL); + if (STRINGP (file_name)) + { + Lisp_Object file; + unsigned char *contents; + int size; + struct gcpro gcpro1; + + file = x_find_image_file (file_name); + GCPRO1 (file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", file_name, Qnil); + UNGCPRO; + return 0; + } + + contents = slurp_file (SDATA (file), &size); + if (contents == NULL) + { + image_error ("Error loading XBM image `%s'", img->spec, Qnil); + UNGCPRO; + return 0; + } + + success_p = xbm_load_image (f, img, contents, contents + size); + UNGCPRO; + } + else + { + struct image_keyword fmt[XBM_LAST]; + Lisp_Object data; + unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); + unsigned long background = FRAME_BACKGROUND_PIXEL (f); + int non_default_colors = 0; + char *bits; + int parsed_p; + int in_memory_file_p = 0; + + /* See if data looks like an in-memory XBM file. */ + data = image_spec_value (img->spec, QCdata, NULL); + in_memory_file_p = xbm_file_p (data); + + /* Parse the image specification. */ + bcopy (xbm_format, fmt, sizeof fmt); + parsed_p = parse_image_spec (img->spec, fmt, XBM_LAST, Qxbm); + xassert (parsed_p); + + /* Get specified width, and height. */ + if (!in_memory_file_p) + { + img->width = XFASTINT (fmt[XBM_WIDTH].value); + img->height = XFASTINT (fmt[XBM_HEIGHT].value); + xassert (img->width > 0 && img->height > 0); + } + + /* Get foreground and background colors, maybe allocate colors. */ + if (fmt[XBM_FOREGROUND].count + && STRINGP (fmt[XBM_FOREGROUND].value)) + { + foreground = x_alloc_image_color (f, img, fmt[XBM_FOREGROUND].value, + foreground); + non_default_colors = 1; + } + + if (fmt[XBM_BACKGROUND].count + && STRINGP (fmt[XBM_BACKGROUND].value)) + { + background = x_alloc_image_color (f, img, fmt[XBM_BACKGROUND].value, + background); + non_default_colors = 1; + } + + if (in_memory_file_p) + success_p = xbm_load_image (f, img, SDATA (data), + (SDATA (data) + + SBYTES (data))); + else + { + if (VECTORP (data)) + { + int i; + char *p; + int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR; + + p = bits = (char *) alloca (nbytes * img->height); + for (i = 0; i < img->height; ++i, p += nbytes) + { + Lisp_Object line = XVECTOR (data)->contents[i]; + if (STRINGP (line)) + bcopy (SDATA (line), p, nbytes); + else + bcopy (XBOOL_VECTOR (line)->data, p, nbytes); + } + } + else if (STRINGP (data)) + bits = SDATA (data); + else + bits = XBOOL_VECTOR (data)->data; + + /* Create the pixmap. */ + + Create_Pixmap_From_Bitmap_Data (f, img, bits, + foreground, background, + non_default_colors); + if (img->pixmap) + success_p = 1; + else + { + image_error ("Unable to create pixmap for XBM image `%s'", + img->spec, Qnil); + x_clear_image (f, img); + } + } + } + + return success_p; +} + + + +/*********************************************************************** + XPM images + ***********************************************************************/ + +#ifdef HAVE_XPM + +static int xpm_image_p P_ ((Lisp_Object object)); +static int xpm_load P_ ((struct frame *f, struct image *img)); +static int xpm_valid_color_symbols_p P_ ((Lisp_Object)); + +#ifdef HAVE_NTGUI +/* Indicate to xpm.h that we don't have Xlib. */ +#define FOR_MSW +/* simx.h in xpm defines XColor and XImage differently than Emacs. */ +#define XColor xpm_XColor +#define XImage xpm_XImage +#define PIXEL_ALREADY_TYPEDEFED +#include "X11/xpm.h" +#undef FOR_MSW +#undef XColor +#undef XImage +#undef PIXEL_ALREADY_TYPEDEFED +#else +#include "X11/xpm.h" +#endif /* HAVE_NTGUI */ + +/* The symbol `xpm' identifying XPM-format images. */ + +Lisp_Object Qxpm; + +/* Indices of image specification fields in xpm_format, below. */ + +enum xpm_keyword_index +{ + XPM_TYPE, + XPM_FILE, + XPM_DATA, + XPM_ASCENT, + XPM_MARGIN, + XPM_RELIEF, + XPM_ALGORITHM, + XPM_HEURISTIC_MASK, + XPM_MASK, + XPM_COLOR_SYMBOLS, + XPM_BACKGROUND, + XPM_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid XPM image specifications. */ + +static struct image_keyword xpm_format[XPM_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":file", IMAGE_STRING_VALUE, 0}, + {":data", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0} +}; + +/* Structure describing the image type XPM. */ + +static struct image_type xpm_type = +{ + &Qxpm, + xpm_image_p, + xpm_load, + x_clear_image, + NULL +}; + +#ifdef HAVE_X_WINDOWS + +/* Define ALLOC_XPM_COLORS if we can use Emacs' own color allocation + functions for allocating image colors. Our own functions handle + color allocation failures more gracefully than the ones on the XPM + lib. */ + +#if defined XpmAllocColor && defined XpmFreeColors && defined XpmColorClosure +#define ALLOC_XPM_COLORS +#endif +#endif /* HAVE_X_WINDOWS */ + +#ifdef ALLOC_XPM_COLORS + +static void xpm_init_color_cache P_ ((struct frame *, XpmAttributes *)); +static void xpm_free_color_cache P_ ((void)); +static int xpm_lookup_color P_ ((struct frame *, char *, XColor *)); +static int xpm_color_bucket P_ ((char *)); +static struct xpm_cached_color *xpm_cache_color P_ ((struct frame *, char *, + XColor *, int)); + +/* An entry in a hash table used to cache color definitions of named + colors. This cache is necessary to speed up XPM image loading in + case we do color allocations ourselves. Without it, we would need + a call to XParseColor per pixel in the image. */ + +struct xpm_cached_color +{ + /* Next in collision chain. */ + struct xpm_cached_color *next; + + /* Color definition (RGB and pixel color). */ + XColor color; + + /* Color name. */ + char name[1]; +}; + +/* The hash table used for the color cache, and its bucket vector + size. */ + +#define XPM_COLOR_CACHE_BUCKETS 1001 +struct xpm_cached_color **xpm_color_cache; + +/* Initialize the color cache. */ + +static void +xpm_init_color_cache (f, attrs) + struct frame *f; + XpmAttributes *attrs; +{ + size_t nbytes = XPM_COLOR_CACHE_BUCKETS * sizeof *xpm_color_cache; + xpm_color_cache = (struct xpm_cached_color **) xmalloc (nbytes); + memset (xpm_color_cache, 0, nbytes); + init_color_table (); + + if (attrs->valuemask & XpmColorSymbols) + { + int i; + XColor color; + + for (i = 0; i < attrs->numsymbols; ++i) + if (XParseColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), + attrs->colorsymbols[i].value, &color)) + { + color.pixel = lookup_rgb_color (f, color.red, color.green, + color.blue); + xpm_cache_color (f, attrs->colorsymbols[i].name, &color, -1); + } + } +} + +/* Free the color cache. */ + +static void +xpm_free_color_cache () +{ + struct xpm_cached_color *p, *next; + int i; + + for (i = 0; i < XPM_COLOR_CACHE_BUCKETS; ++i) + for (p = xpm_color_cache[i]; p; p = next) + { + next = p->next; + xfree (p); + } + + xfree (xpm_color_cache); + xpm_color_cache = NULL; + free_color_table (); +} + +/* Return the bucket index for color named COLOR_NAME in the color + cache. */ + +static int +xpm_color_bucket (color_name) + char *color_name; +{ + unsigned h = 0; + char *s; + + for (s = color_name; *s; ++s) + h = (h << 2) ^ *s; + return h %= XPM_COLOR_CACHE_BUCKETS; +} + + +/* On frame F, cache values COLOR for color with name COLOR_NAME. + BUCKET, if >= 0, is a precomputed bucket index. Value is the cache + entry added. */ + +static struct xpm_cached_color * +xpm_cache_color (f, color_name, color, bucket) + struct frame *f; + char *color_name; + XColor *color; + int bucket; +{ + size_t nbytes; + struct xpm_cached_color *p; + + if (bucket < 0) + bucket = xpm_color_bucket (color_name); + + nbytes = sizeof *p + strlen (color_name); + p = (struct xpm_cached_color *) xmalloc (nbytes); + strcpy (p->name, color_name); + p->color = *color; + p->next = xpm_color_cache[bucket]; + xpm_color_cache[bucket] = p; + return p; +} + +/* Look up color COLOR_NAME for frame F in the color cache. If found, + return the cached definition in *COLOR. Otherwise, make a new + entry in the cache and allocate the color. Value is zero if color + allocation failed. */ + +static int +xpm_lookup_color (f, color_name, color) + struct frame *f; + char *color_name; + XColor *color; +{ + struct xpm_cached_color *p; + int h = xpm_color_bucket (color_name); + + for (p = xpm_color_cache[h]; p; p = p->next) + if (strcmp (p->name, color_name) == 0) + break; + + if (p != NULL) + *color = p->color; + else if (XParseColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), + color_name, color)) + { + color->pixel = lookup_rgb_color (f, color->red, color->green, + color->blue); + p = xpm_cache_color (f, color_name, color, h); + } + /* You get `opaque' at least from ImageMagick converting pbm to xpm + with transparency, and it's useful. */ + else if (strcmp ("opaque", color_name) == 0) + { + bzero (color, sizeof (XColor)); /* Is this necessary/correct? */ + color->pixel = FRAME_FOREGROUND_PIXEL (f); + p = xpm_cache_color (f, color_name, color, h); + } + + return p != NULL; +} + + +/* Callback for allocating color COLOR_NAME. Called from the XPM lib. + CLOSURE is a pointer to the frame on which we allocate the + color. Return in *COLOR the allocated color. Value is non-zero + if successful. */ + +static int +xpm_alloc_color (dpy, cmap, color_name, color, closure) + Display *dpy; + Colormap cmap; + char *color_name; + XColor *color; + void *closure; +{ + return xpm_lookup_color ((struct frame *) closure, color_name, color); +} + + +/* Callback for freeing NPIXELS colors contained in PIXELS. CLOSURE + is a pointer to the frame on which we allocate the color. Value is + non-zero if successful. */ + +static int +xpm_free_colors (dpy, cmap, pixels, npixels, closure) + Display *dpy; + Colormap cmap; + Pixel *pixels; + int npixels; + void *closure; +{ + return 1; +} + +#endif /* ALLOC_XPM_COLORS */ + + +#ifdef HAVE_NTGUI + +/* XPM library details. */ + +DEF_IMGLIB_FN (XpmFreeAttributes); +DEF_IMGLIB_FN (XpmCreateImageFromBuffer); +DEF_IMGLIB_FN (XpmReadFileToImage); +DEF_IMGLIB_FN (XImageFree); + + +static int +init_xpm_functions (void) +{ + HMODULE library; + + if (!(library = LoadLibrary ("libXpm.dll"))) + return 0; + + LOAD_IMGLIB_FN (library, XpmFreeAttributes); + LOAD_IMGLIB_FN (library, XpmCreateImageFromBuffer); + LOAD_IMGLIB_FN (library, XpmReadFileToImage); + LOAD_IMGLIB_FN (library, XImageFree); + return 1; +} + +#endif /* HAVE_NTGUI */ + + +/* Value is non-zero if COLOR_SYMBOLS is a valid color symbols list + for XPM images. Such a list must consist of conses whose car and + cdr are strings. */ + +static int +xpm_valid_color_symbols_p (color_symbols) + Lisp_Object color_symbols; +{ + while (CONSP (color_symbols)) + { + Lisp_Object sym = XCAR (color_symbols); + if (!CONSP (sym) + || !STRINGP (XCAR (sym)) + || !STRINGP (XCDR (sym))) + break; + color_symbols = XCDR (color_symbols); + } + + return NILP (color_symbols); +} + + +/* Value is non-zero if OBJECT is a valid XPM image specification. */ + +static int +xpm_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[XPM_LAST]; + bcopy (xpm_format, fmt, sizeof fmt); + return (parse_image_spec (object, fmt, XPM_LAST, Qxpm) + /* Either `:file' or `:data' must be present. */ + && fmt[XPM_FILE].count + fmt[XPM_DATA].count == 1 + /* Either no `:color-symbols' or it's a list of conses + whose car and cdr are strings. */ + && (fmt[XPM_COLOR_SYMBOLS].count == 0 + || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value))); +} + + +/* Load image IMG which will be displayed on frame F. Value is + non-zero if successful. */ + +static int +xpm_load (f, img) + struct frame *f; + struct image *img; +{ + int rc; + XpmAttributes attrs; + Lisp_Object specified_file, color_symbols; +#ifdef HAVE_NTGUI + HDC hdc; + xpm_XImage * xpm_image = NULL, * xpm_mask = NULL; +#endif /* HAVE_NTGUI */ + + /* Configure the XPM lib. Use the visual of frame F. Allocate + close colors. Return colors allocated. */ + bzero (&attrs, sizeof attrs); + +#ifndef HAVE_NTGUI + attrs.visual = FRAME_X_VISUAL (f); + attrs.colormap = FRAME_X_COLORMAP (f); + attrs.valuemask |= XpmVisual; + attrs.valuemask |= XpmColormap; +#endif /* HAVE_NTGUI */ + +#ifdef ALLOC_XPM_COLORS + /* Allocate colors with our own functions which handle + failing color allocation more gracefully. */ + attrs.color_closure = f; + attrs.alloc_color = xpm_alloc_color; + attrs.free_colors = xpm_free_colors; + attrs.valuemask |= XpmAllocColor | XpmFreeColors | XpmColorClosure; +#else /* not ALLOC_XPM_COLORS */ + /* Let the XPM lib allocate colors. */ + attrs.valuemask |= XpmReturnAllocPixels; +#ifdef XpmAllocCloseColors + attrs.alloc_close_colors = 1; + attrs.valuemask |= XpmAllocCloseColors; +#else /* not XpmAllocCloseColors */ + attrs.closeness = 600; + attrs.valuemask |= XpmCloseness; +#endif /* not XpmAllocCloseColors */ +#endif /* ALLOC_XPM_COLORS */ + + /* If image specification contains symbolic color definitions, add + these to `attrs'. */ + color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL); + if (CONSP (color_symbols)) + { + Lisp_Object tail; + XpmColorSymbol *xpm_syms; + int i, size; + + attrs.valuemask |= XpmColorSymbols; + + /* Count number of symbols. */ + attrs.numsymbols = 0; + for (tail = color_symbols; CONSP (tail); tail = XCDR (tail)) + ++attrs.numsymbols; + + /* Allocate an XpmColorSymbol array. */ + size = attrs.numsymbols * sizeof *xpm_syms; + xpm_syms = (XpmColorSymbol *) alloca (size); + bzero (xpm_syms, size); + attrs.colorsymbols = xpm_syms; + + /* Fill the color symbol array. */ + for (tail = color_symbols, i = 0; + CONSP (tail); + ++i, tail = XCDR (tail)) + { + Lisp_Object name = XCAR (XCAR (tail)); + Lisp_Object color = XCDR (XCAR (tail)); + xpm_syms[i].name = (char *) alloca (SCHARS (name) + 1); + strcpy (xpm_syms[i].name, SDATA (name)); + xpm_syms[i].value = (char *) alloca (SCHARS (color) + 1); + strcpy (xpm_syms[i].value, SDATA (color)); + } + } + + /* Create a pixmap for the image, either from a file, or from a + string buffer containing data in the same format as an XPM file. */ +#ifdef ALLOC_XPM_COLORS + xpm_init_color_cache (f, &attrs); +#endif + + specified_file = image_spec_value (img->spec, QCfile, NULL); + +#ifdef HAVE_NTGUI + { + HDC frame_dc = get_frame_dc (f); + hdc = CreateCompatibleDC (frame_dc); + release_frame_dc (f, frame_dc); + } +#endif /* HAVE_NTGUI */ + + if (STRINGP (specified_file)) + { + Lisp_Object file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + return 0; + } + +#ifdef HAVE_NTGUI + /* XpmReadFileToPixmap is not available in the Windows port of + libxpm. But XpmReadFileToImage almost does what we want. */ + rc = fn_XpmReadFileToImage (&hdc, SDATA (file), + &xpm_image, &xpm_mask, + &attrs); +#else + rc = XpmReadFileToPixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + SDATA (file), &img->pixmap, &img->mask, + &attrs); +#endif /* HAVE_NTGUI */ + } + else + { + Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL); +#ifdef HAVE_NTGUI + /* XpmCreatePixmapFromBuffer is not available in the Windows port + of libxpm. But XpmCreateImageFromBuffer almost does what we want. */ + rc = fn_XpmCreateImageFromBuffer (&hdc, SDATA (buffer), + &xpm_image, &xpm_mask, + &attrs); +#else + rc = XpmCreatePixmapFromBuffer (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + SDATA (buffer), + &img->pixmap, &img->mask, + &attrs); +#endif /* HAVE_NTGUI */ + } + + if (rc == XpmSuccess) + { +#if defined (COLOR_TABLE_SUPPORT) && defined (ALLOC_XPM_COLORS) + img->colors = colors_in_color_table (&img->ncolors); +#else /* not ALLOC_XPM_COLORS */ + int i; + +#ifdef HAVE_NTGUI + /* W32 XPM uses XImage to wrap what W32 Emacs calls a Pixmap, + plus some duplicate attributes. */ + if (xpm_image && xpm_image->bitmap) + { + img->pixmap = xpm_image->bitmap; + /* XImageFree in libXpm frees XImage struct without destroying + the bitmap, which is what we want. */ + fn_XImageFree (xpm_image); + } + if (xpm_mask && xpm_mask->bitmap) + { + /* The mask appears to be inverted compared with what we expect. + TODO: invert our expectations. See other places where we + have to invert bits because our idea of masks is backwards. */ + HGDIOBJ old_obj; + old_obj = SelectObject (hdc, xpm_mask->bitmap); + + PatBlt (hdc, 0, 0, xpm_mask->width, xpm_mask->height, DSTINVERT); + SelectObject (hdc, old_obj); + + img->mask = xpm_mask->bitmap; + fn_XImageFree (xpm_mask); + DeleteDC (hdc); + } + + DeleteDC (hdc); +#endif /* HAVE_NTGUI */ + + /* Remember allocated colors. */ + img->ncolors = attrs.nalloc_pixels; + img->colors = (unsigned long *) xmalloc (img->ncolors + * sizeof *img->colors); + for (i = 0; i < attrs.nalloc_pixels; ++i) + { + img->colors[i] = attrs.alloc_pixels[i]; +#ifdef DEBUG_X_COLORS + register_color (img->colors[i]); +#endif + } +#endif /* not ALLOC_XPM_COLORS */ + + img->width = attrs.width; + img->height = attrs.height; + xassert (img->width > 0 && img->height > 0); + + /* The call to XpmFreeAttributes below frees attrs.alloc_pixels. */ +#ifdef HAVE_NTGUI + fn_XpmFreeAttributes (&attrs); +#else + XpmFreeAttributes (&attrs); +#endif /* HAVE_NTGUI */ + } + else + { +#ifdef HAVE_NTGUI + DeleteDC (hdc); +#endif /* HAVE_NTGUI */ + + switch (rc) + { + case XpmOpenFailed: + image_error ("Error opening XPM file (%s)", img->spec, Qnil); + break; + + case XpmFileInvalid: + image_error ("Invalid XPM file (%s)", img->spec, Qnil); + break; + + case XpmNoMemory: + image_error ("Out of memory (%s)", img->spec, Qnil); + break; + + case XpmColorFailed: + image_error ("Color allocation error (%s)", img->spec, Qnil); + break; + + default: + image_error ("Unknown error (%s)", img->spec, Qnil); + break; + } + } + +#ifdef ALLOC_XPM_COLORS + xpm_free_color_cache (); +#endif + return rc == XpmSuccess; +} + +#endif /* HAVE_XPM */ + + +/*********************************************************************** + Color table + ***********************************************************************/ + +#ifdef COLOR_TABLE_SUPPORT + +/* An entry in the color table mapping an RGB color to a pixel color. */ + +struct ct_color +{ + int r, g, b; + unsigned long pixel; + + /* Next in color table collision list. */ + struct ct_color *next; +}; + +/* The bucket vector size to use. Must be prime. */ + +#define CT_SIZE 101 + +/* Value is a hash of the RGB color given by R, G, and B. */ + +#define CT_HASH_RGB(R, G, B) (((R) << 16) ^ ((G) << 8) ^ (B)) + +/* The color hash table. */ + +struct ct_color **ct_table; + +/* Number of entries in the color table. */ + +int ct_colors_allocated; + +/* Initialize the color table. */ + +static void +init_color_table () +{ + int size = CT_SIZE * sizeof (*ct_table); + ct_table = (struct ct_color **) xmalloc (size); + bzero (ct_table, size); + ct_colors_allocated = 0; +} + + +/* Free memory associated with the color table. */ + +static void +free_color_table () +{ + int i; + struct ct_color *p, *next; + + for (i = 0; i < CT_SIZE; ++i) + for (p = ct_table[i]; p; p = next) + { + next = p->next; + xfree (p); + } + + xfree (ct_table); + ct_table = NULL; +} + + +/* Value is a pixel color for RGB color R, G, B on frame F. If an + entry for that color already is in the color table, return the + pixel color of that entry. Otherwise, allocate a new color for R, + G, B, and make an entry in the color table. */ + +static unsigned long +lookup_rgb_color (f, r, g, b) + struct frame *f; + int r, g, b; +{ + unsigned hash = CT_HASH_RGB (r, g, b); + int i = hash % CT_SIZE; + struct ct_color *p; + Display_Info *dpyinfo; + + /* Handle TrueColor visuals specially, which improves performance by + two orders of magnitude. Freeing colors on TrueColor visuals is + a nop, and pixel colors specify RGB values directly. See also + the Xlib spec, chapter 3.1. */ + dpyinfo = FRAME_X_DISPLAY_INFO (f); + if (dpyinfo->red_bits > 0) + { + unsigned long pr, pg, pb; + + /* Apply gamma-correction like normal color allocation does. */ + if (f->gamma) + { + XColor color; + color.red = r, color.green = g, color.blue = b; + gamma_correct (f, &color); + r = color.red, g = color.green, b = color.blue; + } + + /* Scale down RGB values to the visual's bits per RGB, and shift + them to the right position in the pixel color. Note that the + original RGB values are 16-bit values, as usual in X. */ + pr = (r >> (16 - dpyinfo->red_bits)) << dpyinfo->red_offset; + pg = (g >> (16 - dpyinfo->green_bits)) << dpyinfo->green_offset; + pb = (b >> (16 - dpyinfo->blue_bits)) << dpyinfo->blue_offset; + + /* Assemble the pixel color. */ + return pr | pg | pb; + } + + for (p = ct_table[i]; p; p = p->next) + if (p->r == r && p->g == g && p->b == b) + break; + + if (p == NULL) + { + +#ifdef HAVE_X_WINDOWS + XColor color; + Colormap cmap; + int rc; + + color.red = r; + color.green = g; + color.blue = b; + + cmap = FRAME_X_COLORMAP (f); + rc = x_alloc_nearest_color (f, cmap, &color); + if (rc) + { + ++ct_colors_allocated; + p = (struct ct_color *) xmalloc (sizeof *p); + p->r = r; + p->g = g; + p->b = b; + p->pixel = color.pixel; + p->next = ct_table[i]; + ct_table[i] = p; + } + else + return FRAME_FOREGROUND_PIXEL (f); + +#else + COLORREF color; +#ifdef HAVE_NTGUI + color = PALETTERGB (r, g, b); +#else + color = RGB_TO_ULONG (r, g, b); +#endif /* HAVE_NTGUI */ + ++ct_colors_allocated; + p = (struct ct_color *) xmalloc (sizeof *p); + p->r = r; + p->g = g; + p->b = b; + p->pixel = color; + p->next = ct_table[i]; + ct_table[i] = p; +#endif /* HAVE_X_WINDOWS */ + + } + + return p->pixel; +} + + +/* Look up pixel color PIXEL which is used on frame F in the color + table. If not already present, allocate it. Value is PIXEL. */ + +static unsigned long +lookup_pixel_color (f, pixel) + struct frame *f; + unsigned long pixel; +{ + int i = pixel % CT_SIZE; + struct ct_color *p; + + for (p = ct_table[i]; p; p = p->next) + if (p->pixel == pixel) + break; + + if (p == NULL) + { + XColor color; + Colormap cmap; + int rc; + +#ifdef HAVE_X_WINDOWS + cmap = FRAME_X_COLORMAP (f); + color.pixel = pixel; + x_query_color (f, &color); + rc = x_alloc_nearest_color (f, cmap, &color); +#else + BLOCK_INPUT; + cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f)); + color.pixel = pixel; + XQueryColor (NULL, cmap, &color); + rc = x_alloc_nearest_color (f, cmap, &color); + UNBLOCK_INPUT; +#endif /* HAVE_X_WINDOWS */ + + if (rc) + { + ++ct_colors_allocated; + + p = (struct ct_color *) xmalloc (sizeof *p); + p->r = color.red; + p->g = color.green; + p->b = color.blue; + p->pixel = pixel; + p->next = ct_table[i]; + ct_table[i] = p; + } + else + return FRAME_FOREGROUND_PIXEL (f); + } + return p->pixel; +} + + +/* Value is a vector of all pixel colors contained in the color table, + allocated via xmalloc. Set *N to the number of colors. */ + +static unsigned long * +colors_in_color_table (n) + int *n; +{ + int i, j; + struct ct_color *p; + unsigned long *colors; + + if (ct_colors_allocated == 0) + { + *n = 0; + colors = NULL; + } + else + { + colors = (unsigned long *) xmalloc (ct_colors_allocated + * sizeof *colors); + *n = ct_colors_allocated; + + for (i = j = 0; i < CT_SIZE; ++i) + for (p = ct_table[i]; p; p = p->next) + colors[j++] = p->pixel; + } + + return colors; +} + +#else /* COLOR_TABLE_SUPPORT */ + +static unsigned long +lookup_rgb_color (f, r, g, b) + struct frame *f; + int r, g, b; +{ + unsigned long pixel; + +#ifdef MAC_OS + pixel = RGB_TO_ULONG (r >> 8, g >> 8, b >> 8); + gamma_correct (f, &pixel); +#endif /* MAC_OS */ + +#ifdef HAVE_NTGUI + pixel = PALETTERGB (r >> 8, g >> 8, b >> 8); +#endif /* HAVE_NTGUI */ + + return pixel; +} + +static void +init_color_table () +{ +} +#endif /* COLOR_TABLE_SUPPORT */ + + +/*********************************************************************** + Algorithms + ***********************************************************************/ + +static XColor *x_to_xcolors P_ ((struct frame *, struct image *, int)); +static void x_from_xcolors P_ ((struct frame *, struct image *, XColor *)); +static void x_detect_edges P_ ((struct frame *, struct image *, int[9], int)); + +#ifdef HAVE_NTGUI +static void XPutPixel (XImagePtr , int, int, COLORREF); +#endif /* HAVE_NTGUI */ + +/* Non-zero means draw a cross on images having `:conversion + disabled'. */ + +int cross_disabled_images; + +/* Edge detection matrices for different edge-detection + strategies. */ + +static int emboss_matrix[9] = { + /* x - 1 x x + 1 */ + 2, -1, 0, /* y - 1 */ + -1, 0, 1, /* y */ + 0, 1, -2 /* y + 1 */ +}; + +static int laplace_matrix[9] = { + /* x - 1 x x + 1 */ + 1, 0, 0, /* y - 1 */ + 0, 0, 0, /* y */ + 0, 0, -1 /* y + 1 */ +}; + +/* Value is the intensity of the color whose red/green/blue values + are R, G, and B. */ + +#define COLOR_INTENSITY(R, G, B) ((2 * (R) + 3 * (G) + (B)) / 6) + + +/* On frame F, return an array of XColor structures describing image + IMG->pixmap. Each XColor structure has its pixel color set. RGB_P + non-zero means also fill the red/green/blue members of the XColor + structures. Value is a pointer to the array of XColors structures, + allocated with xmalloc; it must be freed by the caller. */ + +static XColor * +x_to_xcolors (f, img, rgb_p) + struct frame *f; + struct image *img; + int rgb_p; +{ + int x, y; + XColor *colors, *p; + XImagePtr_or_DC ximg; +#ifdef HAVE_NTGUI + HDC hdc; + HGDIOBJ prev; +#endif /* HAVE_NTGUI */ + + colors = (XColor *) xmalloc (img->width * img->height * sizeof *colors); + +#ifndef HAVE_NTGUI + /* Get the X image IMG->pixmap. */ + ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap, + 0, 0, img->width, img->height, ~0, ZPixmap); +#else + /* Load the image into a memory device context. */ + hdc = get_frame_dc (f); + ximg = CreateCompatibleDC (hdc); + release_frame_dc (f, hdc); + prev = SelectObject (ximg, img->pixmap); +#endif /* HAVE_NTGUI */ + + /* Fill the `pixel' members of the XColor array. I wished there + were an easy and portable way to circumvent XGetPixel. */ + p = colors; + for (y = 0; y < img->height; ++y) + { + XColor *row = p; + +#ifdef HAVE_X_WINDOWS + for (x = 0; x < img->width; ++x, ++p) + p->pixel = XGetPixel (ximg, x, y); + if (rgb_p) + x_query_colors (f, row, img->width); + +#else + + for (x = 0; x < img->width; ++x, ++p) + { + /* W32_TODO: palette support needed here? */ + p->pixel = GET_PIXEL (ximg, x, y); + if (rgb_p) + { +#ifdef MAC_OS + p->red = RED16_FROM_ULONG (p->pixel); + p->green = GREEN16_FROM_ULONG (p->pixel); + p->blue = BLUE16_FROM_ULONG (p->pixel); +#endif /* MAC_OS */ +#ifdef HAVE_NTGUI + p->red = 256 * GetRValue (p->pixel); + p->green = 256 * GetGValue (p->pixel); + p->blue = 256 * GetBValue (p->pixel); +#endif /* HAVE_NTGUI */ + } + } +#endif /* HAVE_X_WINDOWS */ + } + + Destroy_Image (ximg, prev); + + return colors; +} + +#ifdef HAVE_NTGUI + +/* Put a pixel of COLOR at position X, Y in XIMG. XIMG must have been + created with CreateDIBSection, with the pointer to the bit values + stored in ximg->data. */ + +static void XPutPixel (ximg, x, y, color) + XImagePtr ximg; + int x, y; + COLORREF color; +{ + int width = ximg->info.bmiHeader.biWidth; + int height = ximg->info.bmiHeader.biHeight; + unsigned char * pixel; + + /* True color images. */ + if (ximg->info.bmiHeader.biBitCount == 24) + { + int rowbytes = width * 3; + /* Ensure scanlines are aligned on 4 byte boundaries. */ + if (rowbytes % 4) + rowbytes += 4 - (rowbytes % 4); + + pixel = ximg->data + y * rowbytes + x * 3; + /* Windows bitmaps are in BGR order. */ + *pixel = GetBValue (color); + *(pixel + 1) = GetGValue (color); + *(pixel + 2) = GetRValue (color); + } + /* Monochrome images. */ + else if (ximg->info.bmiHeader.biBitCount == 1) + { + int rowbytes = width / 8; + /* Ensure scanlines are aligned on 4 byte boundaries. */ + if (rowbytes % 4) + rowbytes += 4 - (rowbytes % 4); + pixel = ximg->data + y * rowbytes + x / 8; + /* Filter out palette info. */ + if (color & 0x00ffffff) + *pixel = *pixel | (1 << x % 8); + else + *pixel = *pixel & ~(1 << x % 8); + } + else + image_error ("XPutPixel: palette image not supported", Qnil, Qnil); +} + +#endif /* HAVE_NTGUI */ + +/* Create IMG->pixmap from an array COLORS of XColor structures, whose + RGB members are set. F is the frame on which this all happens. + COLORS will be freed; an existing IMG->pixmap will be freed, too. */ + +static void +x_from_xcolors (f, img, colors) + struct frame *f; + struct image *img; + XColor *colors; +{ + int x, y; + XImagePtr oimg; + Pixmap pixmap; + XColor *p; + + init_color_table (); + + x_create_x_image_and_pixmap (f, img->width, img->height, 0, + &oimg, &pixmap); + p = colors; + for (y = 0; y < img->height; ++y) + for (x = 0; x < img->width; ++x, ++p) + { + unsigned long pixel; + pixel = lookup_rgb_color (f, p->red, p->green, p->blue); + XPutPixel (oimg, x, y, pixel); + } + + xfree (colors); + x_clear_image_1 (f, img, 1, 0, 1); + + x_put_x_image (f, oimg, pixmap, img->width, img->height); + x_destroy_x_image (oimg); + img->pixmap = pixmap; +#ifdef COLOR_TABLE_SUPPORT + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); +#endif /* COLOR_TABLE_SUPPORT */ +} + + +/* On frame F, perform edge-detection on image IMG. + + MATRIX is a nine-element array specifying the transformation + matrix. See emboss_matrix for an example. + + COLOR_ADJUST is a color adjustment added to each pixel of the + outgoing image. */ + +static void +x_detect_edges (f, img, matrix, color_adjust) + struct frame *f; + struct image *img; + int matrix[9], color_adjust; +{ + XColor *colors = x_to_xcolors (f, img, 1); + XColor *new, *p; + int x, y, i, sum; + + for (i = sum = 0; i < 9; ++i) + sum += abs (matrix[i]); + +#define COLOR(A, X, Y) ((A) + (Y) * img->width + (X)) + + new = (XColor *) xmalloc (img->width * img->height * sizeof *new); + + for (y = 0; y < img->height; ++y) + { + p = COLOR (new, 0, y); + p->red = p->green = p->blue = 0xffff/2; + p = COLOR (new, img->width - 1, y); + p->red = p->green = p->blue = 0xffff/2; + } + + for (x = 1; x < img->width - 1; ++x) + { + p = COLOR (new, x, 0); + p->red = p->green = p->blue = 0xffff/2; + p = COLOR (new, x, img->height - 1); + p->red = p->green = p->blue = 0xffff/2; + } + + for (y = 1; y < img->height - 1; ++y) + { + p = COLOR (new, 1, y); + + for (x = 1; x < img->width - 1; ++x, ++p) + { + int r, g, b, y1, x1; + + r = g = b = i = 0; + for (y1 = y - 1; y1 < y + 2; ++y1) + for (x1 = x - 1; x1 < x + 2; ++x1, ++i) + if (matrix[i]) + { + XColor *t = COLOR (colors, x1, y1); + r += matrix[i] * t->red; + g += matrix[i] * t->green; + b += matrix[i] * t->blue; + } + + r = (r / sum + color_adjust) & 0xffff; + g = (g / sum + color_adjust) & 0xffff; + b = (b / sum + color_adjust) & 0xffff; + p->red = p->green = p->blue = COLOR_INTENSITY (r, g, b); + } + } + + xfree (colors); + x_from_xcolors (f, img, new); + +#undef COLOR +} + + +/* Perform the pre-defined `emboss' edge-detection on image IMG + on frame F. */ + +static void +x_emboss (f, img) + struct frame *f; + struct image *img; +{ + x_detect_edges (f, img, emboss_matrix, 0xffff / 2); +} + + +/* Transform image IMG which is used on frame F with a Laplace + edge-detection algorithm. The result is an image that can be used + to draw disabled buttons, for example. */ + +static void +x_laplace (f, img) + struct frame *f; + struct image *img; +{ + x_detect_edges (f, img, laplace_matrix, 45000); +} + + +/* Perform edge-detection on image IMG on frame F, with specified + transformation matrix MATRIX and color-adjustment COLOR_ADJUST. + + MATRIX must be either + + - a list of at least 9 numbers in row-major form + - a vector of at least 9 numbers + + COLOR_ADJUST nil means use a default; otherwise it must be a + number. */ + +static void +x_edge_detection (f, img, matrix, color_adjust) + struct frame *f; + struct image *img; + Lisp_Object matrix, color_adjust; +{ + int i = 0; + int trans[9]; + + if (CONSP (matrix)) + { + for (i = 0; + i < 9 && CONSP (matrix) && NUMBERP (XCAR (matrix)); + ++i, matrix = XCDR (matrix)) + trans[i] = XFLOATINT (XCAR (matrix)); + } + else if (VECTORP (matrix) && ASIZE (matrix) >= 9) + { + for (i = 0; i < 9 && NUMBERP (AREF (matrix, i)); ++i) + trans[i] = XFLOATINT (AREF (matrix, i)); + } + + if (NILP (color_adjust)) + color_adjust = make_number (0xffff / 2); + + if (i == 9 && NUMBERP (color_adjust)) + x_detect_edges (f, img, trans, (int) XFLOATINT (color_adjust)); +} + + +/* Transform image IMG on frame F so that it looks disabled. */ + +static void +x_disable_image (f, img) + struct frame *f; + struct image *img; +{ + Display_Info *dpyinfo = FRAME_X_DISPLAY_INFO (f); +#ifdef HAVE_NTGUI + int n_planes = dpyinfo->n_planes * dpyinfo->n_cbits; +#else + int n_planes = dpyinfo->n_planes; +#endif /* HAVE_NTGUI */ + + if (n_planes >= 2) + { + /* Color (or grayscale). Convert to gray, and equalize. Just + drawing such images with a stipple can look very odd, so + we're using this method instead. */ + XColor *colors = x_to_xcolors (f, img, 1); + XColor *p, *end; + const int h = 15000; + const int l = 30000; + + for (p = colors, end = colors + img->width * img->height; + p < end; + ++p) + { + int i = COLOR_INTENSITY (p->red, p->green, p->blue); + int i2 = (0xffff - h - l) * i / 0xffff + l; + p->red = p->green = p->blue = i2; + } + + x_from_xcolors (f, img, colors); + } + + /* Draw a cross over the disabled image, if we must or if we + should. */ + if (n_planes < 2 || cross_disabled_images) + { +#ifndef HAVE_NTGUI + Display *dpy = FRAME_X_DISPLAY (f); + GC gc; + +#ifdef MAC_OS +#define XCreateGC_pixmap(dpy, pixmap) XCreateGC (dpy, NULL, 0, NULL) +#define MaskForeground(f) PIX_MASK_DRAW (f) +#else +#define XCreateGC_pixmap(dpy, pixmap) XCreateGC (dpy, pixmap, 0, NULL) +#define MaskForeground(f) WHITE_PIX_DEFAULT (f) +#endif + + gc = XCreateGC_pixmap (dpy, img->pixmap); + XSetForeground (dpy, gc, BLACK_PIX_DEFAULT (f)); + XDrawLine (dpy, img->pixmap, gc, 0, 0, + img->width - 1, img->height - 1); + XDrawLine (dpy, img->pixmap, gc, 0, img->height - 1, + img->width - 1, 0); + XFreeGC (dpy, gc); + + if (img->mask) + { + gc = XCreateGC_pixmap (dpy, img->mask); + XSetForeground (dpy, gc, MaskForeground (f)); + XDrawLine (dpy, img->mask, gc, 0, 0, + img->width - 1, img->height - 1); + XDrawLine (dpy, img->mask, gc, 0, img->height - 1, + img->width - 1, 0); + XFreeGC (dpy, gc); + } +#else + HDC hdc, bmpdc; + HGDIOBJ prev; + + hdc = get_frame_dc (f); + bmpdc = CreateCompatibleDC (hdc); + release_frame_dc (f, hdc); + + prev = SelectObject (bmpdc, img->pixmap); + + SetTextColor (bmpdc, BLACK_PIX_DEFAULT (f)); + MoveToEx (bmpdc, 0, 0, NULL); + LineTo (bmpdc, img->width - 1, img->height - 1); + MoveToEx (bmpdc, 0, img->height - 1, NULL); + LineTo (bmpdc, img->width - 1, 0); + + if (img->mask) + { + SelectObject (bmpdc, img->mask); + SetTextColor (bmpdc, WHITE_PIX_DEFAULT (f)); + MoveToEx (bmpdc, 0, 0, NULL); + LineTo (bmpdc, img->width - 1, img->height - 1); + MoveToEx (bmpdc, 0, img->height - 1, NULL); + LineTo (bmpdc, img->width - 1, 0); + } + SelectObject (bmpdc, prev); + DeleteDC (bmpdc); +#endif /* HAVE_NTGUI */ + } +} + + +/* Build a mask for image IMG which is used on frame F. FILE is the + name of an image file, for error messages. HOW determines how to + determine the background color of IMG. If it is a list '(R G B)', + with R, G, and B being integers >= 0, take that as the color of the + background. Otherwise, determine the background color of IMG + heuristically. Value is non-zero if successful. */ + +static int +x_build_heuristic_mask (f, img, how) + struct frame *f; + struct image *img; + Lisp_Object how; +{ + XImagePtr_or_DC ximg; +#ifndef HAVE_NTGUI + XImagePtr mask_img; +#else + HDC frame_dc; + HGDIOBJ prev; + char *mask_img; + int row_width; +#endif /* HAVE_NTGUI */ + int x, y, rc, use_img_background; + unsigned long bg = 0; + + if (img->mask) + { + Free_Pixmap (FRAME_X_DISPLAY (f), img->mask); + img->mask = NO_PIXMAP; + img->background_transparent_valid = 0; + } + +#ifndef HAVE_NTGUI + /* Create an image and pixmap serving as mask. */ + rc = x_create_x_image_and_pixmap (f, img->width, img->height, 1, + &mask_img, &img->mask); + if (!rc) + return 0; + + /* Get the X image of IMG->pixmap. */ + ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap, 0, 0, + img->width, img->height, + ~0, ZPixmap); +#else + /* Create the bit array serving as mask. */ + row_width = (img->width + 7) / 8; + mask_img = xmalloc (row_width * img->height); + bzero (mask_img, row_width * img->height); + + /* Create a memory device context for IMG->pixmap. */ + frame_dc = get_frame_dc (f); + ximg = CreateCompatibleDC (frame_dc); + release_frame_dc (f, frame_dc); + prev = SelectObject (ximg, img->pixmap); +#endif /* HAVE_NTGUI */ + + /* Determine the background color of ximg. If HOW is `(R G B)' + take that as color. Otherwise, use the image's background color. */ + use_img_background = 1; + + if (CONSP (how)) + { + int rgb[3], i; + + for (i = 0; i < 3 && CONSP (how) && NATNUMP (XCAR (how)); ++i) + { + rgb[i] = XFASTINT (XCAR (how)) & 0xffff; + how = XCDR (how); + } + + if (i == 3 && NILP (how)) + { + char color_name[30]; + sprintf (color_name, "#%04x%04x%04x", rgb[0], rgb[1], rgb[2]); + bg = ( +#ifdef HAVE_NTGUI + 0x00ffffff & /* Filter out palette info. */ +#endif /* HAVE_NTGUI */ + x_alloc_image_color (f, img, build_string (color_name), 0)); + use_img_background = 0; + } + } + + if (use_img_background) + bg = four_corners_best (ximg, img->width, img->height); + + /* Set all bits in mask_img to 1 whose color in ximg is different + from the background color bg. */ +#ifndef HAVE_NTGUI + for (y = 0; y < img->height; ++y) + for (x = 0; x < img->width; ++x) + XPutPixel (mask_img, x, y, (XGetPixel (ximg, x, y) != bg + ? PIX_MASK_DRAW (f) : PIX_MASK_RETAIN (f))); + + /* Fill in the background_transparent field while we have the mask handy. */ + image_background_transparent (img, f, mask_img); + + /* Put mask_img into img->mask. */ + x_put_x_image (f, mask_img, img->mask, img->width, img->height); + x_destroy_x_image (mask_img); + +#else + for (y = 0; y < img->height; ++y) + for (x = 0; x < img->width; ++x) + { + COLORREF p = GetPixel (ximg, x, y); + if (p != bg) + mask_img[y * row_width + x / 8] |= 1 << (x % 8); + } + + /* Create the mask image. */ + img->mask = w32_create_pixmap_from_bitmap_data (img->width, img->height, + mask_img); + /* Fill in the background_transparent field while we have the mask handy. */ + SelectObject (ximg, img->mask); + image_background_transparent (img, f, ximg); + + /* Was: x_destroy_x_image ((XImagePtr )mask_img); which seems bogus ++kfs */ + xfree (mask_img); +#endif /* HAVE_NTGUI */ + + Destroy_Image (ximg, prev); + + return 1; +} + + +/*********************************************************************** + PBM (mono, gray, color) + ***********************************************************************/ + +static int pbm_image_p P_ ((Lisp_Object object)); +static int pbm_load P_ ((struct frame *f, struct image *img)); +static int pbm_scan_number P_ ((unsigned char **, unsigned char *)); + +/* The symbol `pbm' identifying images of this type. */ + +Lisp_Object Qpbm; + +/* Indices of image specification fields in gs_format, below. */ + +enum pbm_keyword_index +{ + PBM_TYPE, + PBM_FILE, + PBM_DATA, + PBM_ASCENT, + PBM_MARGIN, + PBM_RELIEF, + PBM_ALGORITHM, + PBM_HEURISTIC_MASK, + PBM_MASK, + PBM_FOREGROUND, + PBM_BACKGROUND, + PBM_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword pbm_format[PBM_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":file", IMAGE_STRING_VALUE, 0}, + {":data", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0} +}; + +/* Structure describing the image type `pbm'. */ + +static struct image_type pbm_type = +{ + &Qpbm, + pbm_image_p, + pbm_load, + x_clear_image, + NULL +}; + + +/* Return non-zero if OBJECT is a valid PBM image specification. */ + +static int +pbm_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[PBM_LAST]; + + bcopy (pbm_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, PBM_LAST, Qpbm)) + return 0; + + /* Must specify either :data or :file. */ + return fmt[PBM_DATA].count + fmt[PBM_FILE].count == 1; +} + + +/* Scan a decimal number from *S and return it. Advance *S while + reading the number. END is the end of the string. Value is -1 at + end of input. */ + +static int +pbm_scan_number (s, end) + unsigned char **s, *end; +{ + int c = 0, val = -1; + + while (*s < end) + { + /* Skip white-space. */ + while (*s < end && (c = *(*s)++, isspace (c))) + ; + + if (c == '#') + { + /* Skip comment to end of line. */ + while (*s < end && (c = *(*s)++, c != '\n')) + ; + } + else if (isdigit (c)) + { + /* Read decimal number. */ + val = c - '0'; + while (*s < end && (c = *(*s)++, isdigit (c))) + val = 10 * val + c - '0'; + break; + } + else + break; + } + + return val; +} + + +#ifdef HAVE_NTGUI +#if 0 /* Unused. ++kfs */ + +/* Read FILE into memory. Value is a pointer to a buffer allocated + with xmalloc holding FILE's contents. Value is null if an error + occurred. *SIZE is set to the size of the file. */ + +static char * +pbm_read_file (file, size) + Lisp_Object file; + int *size; +{ + FILE *fp = NULL; + char *buf = NULL; + struct stat st; + + if (stat (SDATA (file), &st) == 0 + && (fp = fopen (SDATA (file), "rb")) != NULL + && (buf = (char *) xmalloc (st.st_size), + fread (buf, 1, st.st_size, fp) == st.st_size)) + { + *size = st.st_size; + fclose (fp); + } + else + { + if (fp) + fclose (fp); + if (buf) + { + xfree (buf); + buf = NULL; + } + } + + return buf; +} +#endif +#endif /* HAVE_NTGUI */ + +/* Load PBM image IMG for use on frame F. */ + +static int +pbm_load (f, img) + struct frame *f; + struct image *img; +{ + int raw_p, x, y; + int width, height, max_color_idx = 0; + XImagePtr ximg; + Lisp_Object file, specified_file; + enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type; + struct gcpro gcpro1; + unsigned char *contents = NULL; + unsigned char *end, *p; + int size; + + specified_file = image_spec_value (img->spec, QCfile, NULL); + file = Qnil; + GCPRO1 (file); + + if (STRINGP (specified_file)) + { + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + + contents = slurp_file (SDATA (file), &size); + if (contents == NULL) + { + image_error ("Error reading `%s'", file, Qnil); + UNGCPRO; + return 0; + } + + p = contents; + end = contents + size; + } + else + { + Lisp_Object data; + data = image_spec_value (img->spec, QCdata, NULL); + p = SDATA (data); + end = p + SBYTES (data); + } + + /* Check magic number. */ + if (end - p < 2 || *p++ != 'P') + { + image_error ("Not a PBM image: `%s'", img->spec, Qnil); + error: + xfree (contents); + UNGCPRO; + return 0; + } + + switch (*p++) + { + case '1': + raw_p = 0, type = PBM_MONO; + break; + + case '2': + raw_p = 0, type = PBM_GRAY; + break; + + case '3': + raw_p = 0, type = PBM_COLOR; + break; + + case '4': + raw_p = 1, type = PBM_MONO; + break; + + case '5': + raw_p = 1, type = PBM_GRAY; + break; + + case '6': + raw_p = 1, type = PBM_COLOR; + break; + + default: + image_error ("Not a PBM image: `%s'", img->spec, Qnil); + goto error; + } + + /* Read width, height, maximum color-component. Characters + starting with `#' up to the end of a line are ignored. */ + width = pbm_scan_number (&p, end); + height = pbm_scan_number (&p, end); + + if (type != PBM_MONO) + { + max_color_idx = pbm_scan_number (&p, end); + if (raw_p && max_color_idx > 255) + max_color_idx = 255; + } + + if (width < 0 + || height < 0 + || (type != PBM_MONO && max_color_idx < 0)) + goto error; + + if (!x_create_x_image_and_pixmap (f, width, height, 0, + &ximg, &img->pixmap)) + goto error; + + /* Initialize the color hash table. */ + init_color_table (); + + if (type == PBM_MONO) + { + int c = 0, g; + struct image_keyword fmt[PBM_LAST]; + unsigned long fg = FRAME_FOREGROUND_PIXEL (f); + unsigned long bg = FRAME_BACKGROUND_PIXEL (f); + + /* Parse the image specification. */ + bcopy (pbm_format, fmt, sizeof fmt); + parse_image_spec (img->spec, fmt, PBM_LAST, Qpbm); + + /* Get foreground and background colors, maybe allocate colors. */ + if (fmt[PBM_FOREGROUND].count + && STRINGP (fmt[PBM_FOREGROUND].value)) + fg = x_alloc_image_color (f, img, fmt[PBM_FOREGROUND].value, fg); + if (fmt[PBM_BACKGROUND].count + && STRINGP (fmt[PBM_BACKGROUND].value)) + { + bg = x_alloc_image_color (f, img, fmt[PBM_BACKGROUND].value, bg); + img->background = bg; + img->background_valid = 1; + } + + for (y = 0; y < height; ++y) + for (x = 0; x < width; ++x) + { + if (raw_p) + { + if ((x & 7) == 0) + c = *p++; + g = c & 0x80; + c <<= 1; + } + else + g = pbm_scan_number (&p, end); + + XPutPixel (ximg, x, y, g ? fg : bg); + } + } + else + { + for (y = 0; y < height; ++y) + for (x = 0; x < width; ++x) + { + int r, g, b; + + if (type == PBM_GRAY) + r = g = b = raw_p ? *p++ : pbm_scan_number (&p, end); + else if (raw_p) + { + r = *p++; + g = *p++; + b = *p++; + } + else + { + r = pbm_scan_number (&p, end); + g = pbm_scan_number (&p, end); + b = pbm_scan_number (&p, end); + } + + if (r < 0 || g < 0 || b < 0) + { + x_destroy_x_image (ximg); + image_error ("Invalid pixel value in image `%s'", + img->spec, Qnil); + goto error; + } + + /* RGB values are now in the range 0..max_color_idx. + Scale this to the range 0..0xffff supported by X. */ + r = (double) r * 65535 / max_color_idx; + g = (double) g * 65535 / max_color_idx; + b = (double) b * 65535 / max_color_idx; + XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b)); + } + } + +#ifdef COLOR_TABLE_SUPPORT + /* Store in IMG->colors the colors allocated for the image, and + free the color table. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); +#endif /* COLOR_TABLE_SUPPORT */ + + img->width = width; + img->height = height; + + /* Maybe fill in the background field while we have ximg handy. */ + + if (NILP (image_spec_value (img->spec, QCbackground, NULL))) + IMAGE_BACKGROUND (img, f, ximg); + + /* Put the image into a pixmap. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + + /* X and W32 versions did it here, MAC version above. ++kfs + img->width = width; + img->height = height; */ + + UNGCPRO; + xfree (contents); + return 1; +} + + +/*********************************************************************** + PNG + ***********************************************************************/ + +#if defined (HAVE_PNG) || defined (MAC_OS) + +/* Function prototypes. */ + +static int png_image_p P_ ((Lisp_Object object)); +static int png_load P_ ((struct frame *f, struct image *img)); + +/* The symbol `png' identifying images of this type. */ + +Lisp_Object Qpng; + +/* Indices of image specification fields in png_format, below. */ + +enum png_keyword_index +{ + PNG_TYPE, + PNG_DATA, + PNG_FILE, + PNG_ASCENT, + PNG_MARGIN, + PNG_RELIEF, + PNG_ALGORITHM, + PNG_HEURISTIC_MASK, + PNG_MASK, + PNG_BACKGROUND, + PNG_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword png_format[PNG_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0} +}; + +/* Structure describing the image type `png'. */ + +static struct image_type png_type = +{ + &Qpng, + png_image_p, + png_load, + x_clear_image, + NULL +}; + +/* Return non-zero if OBJECT is a valid PNG image specification. */ + +static int +png_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[PNG_LAST]; + bcopy (png_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, PNG_LAST, Qpng)) + return 0; + + /* Must specify either the :data or :file keyword. */ + return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1; +} + +#endif /* HAVE_PNG || MAC_OS */ + + +#ifdef HAVE_PNG + +#if defined HAVE_LIBPNG_PNG_H +# include <libpng/png.h> +#else +# include <png.h> +#endif + +#ifdef HAVE_NTGUI +/* PNG library details. */ + +DEF_IMGLIB_FN (png_get_io_ptr); +DEF_IMGLIB_FN (png_check_sig); +DEF_IMGLIB_FN (png_create_read_struct); +DEF_IMGLIB_FN (png_create_info_struct); +DEF_IMGLIB_FN (png_destroy_read_struct); +DEF_IMGLIB_FN (png_set_read_fn); +DEF_IMGLIB_FN (png_init_io); +DEF_IMGLIB_FN (png_set_sig_bytes); +DEF_IMGLIB_FN (png_read_info); +DEF_IMGLIB_FN (png_get_IHDR); +DEF_IMGLIB_FN (png_get_valid); +DEF_IMGLIB_FN (png_set_strip_16); +DEF_IMGLIB_FN (png_set_expand); +DEF_IMGLIB_FN (png_set_gray_to_rgb); +DEF_IMGLIB_FN (png_set_background); +DEF_IMGLIB_FN (png_get_bKGD); +DEF_IMGLIB_FN (png_read_update_info); +DEF_IMGLIB_FN (png_get_channels); +DEF_IMGLIB_FN (png_get_rowbytes); +DEF_IMGLIB_FN (png_read_image); +DEF_IMGLIB_FN (png_read_end); +DEF_IMGLIB_FN (png_error); + +static int +init_png_functions (void) +{ + HMODULE library; + + /* Ensure zlib is loaded. Try debug version first. */ + if (!LoadLibrary ("zlibd.dll") + && !LoadLibrary ("zlib.dll")) + return 0; + + /* Try loading libpng under probable names. */ + if (!(library = LoadLibrary ("libpng13d.dll")) + && !(library = LoadLibrary ("libpng13.dll")) + && !(library = LoadLibrary ("libpng12d.dll")) + && !(library = LoadLibrary ("libpng12.dll")) + && !(library = LoadLibrary ("libpng.dll"))) + return 0; + + LOAD_IMGLIB_FN (library, png_get_io_ptr); + LOAD_IMGLIB_FN (library, png_check_sig); + LOAD_IMGLIB_FN (library, png_create_read_struct); + LOAD_IMGLIB_FN (library, png_create_info_struct); + LOAD_IMGLIB_FN (library, png_destroy_read_struct); + LOAD_IMGLIB_FN (library, png_set_read_fn); + LOAD_IMGLIB_FN (library, png_init_io); + LOAD_IMGLIB_FN (library, png_set_sig_bytes); + LOAD_IMGLIB_FN (library, png_read_info); + LOAD_IMGLIB_FN (library, png_get_IHDR); + LOAD_IMGLIB_FN (library, png_get_valid); + LOAD_IMGLIB_FN (library, png_set_strip_16); + LOAD_IMGLIB_FN (library, png_set_expand); + LOAD_IMGLIB_FN (library, png_set_gray_to_rgb); + LOAD_IMGLIB_FN (library, png_set_background); + LOAD_IMGLIB_FN (library, png_get_bKGD); + LOAD_IMGLIB_FN (library, png_read_update_info); + LOAD_IMGLIB_FN (library, png_get_channels); + LOAD_IMGLIB_FN (library, png_get_rowbytes); + LOAD_IMGLIB_FN (library, png_read_image); + LOAD_IMGLIB_FN (library, png_read_end); + LOAD_IMGLIB_FN (library, png_error); + return 1; +} +#else + +#define fn_png_get_io_ptr png_get_io_ptr +#define fn_png_check_sig png_check_sig +#define fn_png_create_read_struct png_create_read_struct +#define fn_png_create_info_struct png_create_info_struct +#define fn_png_destroy_read_struct png_destroy_read_struct +#define fn_png_set_read_fn png_set_read_fn +#define fn_png_init_io png_init_io +#define fn_png_set_sig_bytes png_set_sig_bytes +#define fn_png_read_info png_read_info +#define fn_png_get_IHDR png_get_IHDR +#define fn_png_get_valid png_get_valid +#define fn_png_set_strip_16 png_set_strip_16 +#define fn_png_set_expand png_set_expand +#define fn_png_set_gray_to_rgb png_set_gray_to_rgb +#define fn_png_set_background png_set_background +#define fn_png_get_bKGD png_get_bKGD +#define fn_png_read_update_info png_read_update_info +#define fn_png_get_channels png_get_channels +#define fn_png_get_rowbytes png_get_rowbytes +#define fn_png_read_image png_read_image +#define fn_png_read_end png_read_end +#define fn_png_error png_error + +#endif /* HAVE_NTGUI */ + +/* Error and warning handlers installed when the PNG library + is initialized. */ + +static void +my_png_error (png_ptr, msg) + png_struct *png_ptr; + char *msg; +{ + xassert (png_ptr != NULL); + image_error ("PNG error: %s", build_string (msg), Qnil); + longjmp (png_ptr->jmpbuf, 1); +} + + +static void +my_png_warning (png_ptr, msg) + png_struct *png_ptr; + char *msg; +{ + xassert (png_ptr != NULL); + image_error ("PNG warning: %s", build_string (msg), Qnil); +} + +/* Memory source for PNG decoding. */ + +struct png_memory_storage +{ + unsigned char *bytes; /* The data */ + size_t len; /* How big is it? */ + int index; /* Where are we? */ +}; + + +/* Function set as reader function when reading PNG image from memory. + PNG_PTR is a pointer to the PNG control structure. Copy LENGTH + bytes from the input to DATA. */ + +static void +png_read_from_memory (png_ptr, data, length) + png_structp png_ptr; + png_bytep data; + png_size_t length; +{ + struct png_memory_storage *tbr + = (struct png_memory_storage *) fn_png_get_io_ptr (png_ptr); + + if (length > tbr->len - tbr->index) + fn_png_error (png_ptr, "Read error"); + + bcopy (tbr->bytes + tbr->index, data, length); + tbr->index = tbr->index + length; +} + +/* Load PNG image IMG for use on frame F. Value is non-zero if + successful. */ + +static int +png_load (f, img) + struct frame *f; + struct image *img; +{ + Lisp_Object file, specified_file; + Lisp_Object specified_data; + int x, y, i; + XImagePtr ximg, mask_img = NULL; + struct gcpro gcpro1; + png_struct *png_ptr = NULL; + png_info *info_ptr = NULL, *end_info = NULL; + FILE *volatile fp = NULL; + png_byte sig[8]; + png_byte * volatile pixels = NULL; + png_byte ** volatile rows = NULL; + png_uint_32 width, height; + int bit_depth, color_type, interlace_type; + png_byte channels; + png_uint_32 row_bytes; + int transparent_p; + double screen_gamma; + struct png_memory_storage tbr; /* Data to be read */ + + /* Find out what file to load. */ + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + file = Qnil; + GCPRO1 (file); + + if (NILP (specified_data)) + { + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + + /* Open the image file. */ + fp = fopen (SDATA (file), "rb"); + if (!fp) + { + image_error ("Cannot open image file `%s'", file, Qnil); + UNGCPRO; + fclose (fp); + return 0; + } + + /* Check PNG signature. */ + if (fread (sig, 1, sizeof sig, fp) != sizeof sig + || !fn_png_check_sig (sig, sizeof sig)) + { + image_error ("Not a PNG file: `%s'", file, Qnil); + UNGCPRO; + fclose (fp); + return 0; + } + } + else + { + /* Read from memory. */ + tbr.bytes = SDATA (specified_data); + tbr.len = SBYTES (specified_data); + tbr.index = 0; + + /* Check PNG signature. */ + if (tbr.len < sizeof sig + || !fn_png_check_sig (tbr.bytes, sizeof sig)) + { + image_error ("Not a PNG image: `%s'", img->spec, Qnil); + UNGCPRO; + return 0; + } + + /* Need to skip past the signature. */ + tbr.bytes += sizeof (sig); + } + + /* Initialize read and info structs for PNG lib. */ + png_ptr = fn_png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL, + my_png_error, my_png_warning); + if (!png_ptr) + { + if (fp) fclose (fp); + UNGCPRO; + return 0; + } + + info_ptr = fn_png_create_info_struct (png_ptr); + if (!info_ptr) + { + fn_png_destroy_read_struct (&png_ptr, NULL, NULL); + if (fp) fclose (fp); + UNGCPRO; + return 0; + } + + end_info = fn_png_create_info_struct (png_ptr); + if (!end_info) + { + fn_png_destroy_read_struct (&png_ptr, &info_ptr, NULL); + if (fp) fclose (fp); + UNGCPRO; + return 0; + } + + /* Set error jump-back. We come back here when the PNG library + detects an error. */ + if (setjmp (png_ptr->jmpbuf)) + { + error: + if (png_ptr) + fn_png_destroy_read_struct (&png_ptr, &info_ptr, &end_info); + xfree (pixels); + xfree (rows); + if (fp) fclose (fp); + UNGCPRO; + return 0; + } + + /* Read image info. */ + if (!NILP (specified_data)) + fn_png_set_read_fn (png_ptr, (void *) &tbr, png_read_from_memory); + else + fn_png_init_io (png_ptr, fp); + + fn_png_set_sig_bytes (png_ptr, sizeof sig); + fn_png_read_info (png_ptr, info_ptr); + fn_png_get_IHDR (png_ptr, info_ptr, &width, &height, &bit_depth, &color_type, + &interlace_type, NULL, NULL); + + /* If image contains simply transparency data, we prefer to + construct a clipping mask. */ + if (fn_png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS)) + transparent_p = 1; + else + transparent_p = 0; + + /* This function is easier to write if we only have to handle + one data format: RGB or RGBA with 8 bits per channel. Let's + transform other formats into that format. */ + + /* Strip more than 8 bits per channel. */ + if (bit_depth == 16) + fn_png_set_strip_16 (png_ptr); + + /* Expand data to 24 bit RGB, or 8 bit grayscale, with alpha channel + if available. */ + fn_png_set_expand (png_ptr); + + /* Convert grayscale images to RGB. */ + if (color_type == PNG_COLOR_TYPE_GRAY + || color_type == PNG_COLOR_TYPE_GRAY_ALPHA) + fn_png_set_gray_to_rgb (png_ptr); + + screen_gamma = (f->gamma ? 1 / f->gamma / 0.45455 : 2.2); + +#if 0 /* Avoid double gamma correction for PNG images. */ + { /* Tell the PNG lib to handle gamma correction for us. */ + int intent; + double image_gamma; +#if defined(PNG_READ_sRGB_SUPPORTED) || defined(PNG_WRITE_sRGB_SUPPORTED) + if (png_get_sRGB (png_ptr, info_ptr, &intent)) + /* The libpng documentation says this is right in this case. */ + png_set_gamma (png_ptr, screen_gamma, 0.45455); + else +#endif + if (png_get_gAMA (png_ptr, info_ptr, &image_gamma)) + /* Image contains gamma information. */ + png_set_gamma (png_ptr, screen_gamma, image_gamma); + else + /* Use the standard default for the image gamma. */ + png_set_gamma (png_ptr, screen_gamma, 0.45455); + } +#endif /* if 0 */ + + /* Handle alpha channel by combining the image with a background + color. Do this only if a real alpha channel is supplied. For + simple transparency, we prefer a clipping mask. */ + if (!transparent_p) + { + png_color_16 *image_bg; + Lisp_Object specified_bg + = image_spec_value (img->spec, QCbackground, NULL); + + if (STRINGP (specified_bg)) + /* The user specified `:background', use that. */ + { + /* W32 version incorrectly used COLORREF here!! ++kfs */ + XColor color; + if (x_defined_color (f, SDATA (specified_bg), &color, 0)) + { + png_color_16 user_bg; + + bzero (&user_bg, sizeof user_bg); + user_bg.red = color.red >> PNG_BG_COLOR_SHIFT; + user_bg.green = color.green >> PNG_BG_COLOR_SHIFT; + user_bg.blue = color.blue >> PNG_BG_COLOR_SHIFT; + + fn_png_set_background (png_ptr, &user_bg, + PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); + } + } + else if (fn_png_get_bKGD (png_ptr, info_ptr, &image_bg)) + /* Image contains a background color with which to + combine the image. */ + fn_png_set_background (png_ptr, image_bg, + PNG_BACKGROUND_GAMMA_FILE, 1, 1.0); + else + { + /* Image does not contain a background color with which + to combine the image data via an alpha channel. Use + the frame's background instead. */ +#ifdef HAVE_X_WINDOWS + XColor color; + png_color_16 frame_background; + + color.pixel = FRAME_BACKGROUND_PIXEL (f); + x_query_color (f, &color); + + bzero (&frame_background, sizeof frame_background); + frame_background.red = color.red; + frame_background.green = color.green; + frame_background.blue = color.blue; +#endif /* HAVE_X_WINDOWS */ + +#ifdef HAVE_NTGUI + COLORREF color; + png_color_16 frame_background; + color = FRAME_BACKGROUND_PIXEL (f); +#if 0 /* W32 TODO : Colormap support. */ + x_query_color (f, &color); +#endif + bzero (&frame_background, sizeof frame_background); + frame_background.red = 256 * GetRValue (color); + frame_background.green = 256 * GetGValue (color); + frame_background.blue = 256 * GetBValue (color); +#endif /* HAVE_NTGUI */ + +#ifdef MAC_OS + unsigned long color; + png_color_16 frame_background; + color = FRAME_BACKGROUND_PIXEL (f); +#if 0 /* MAC/W32 TODO : Colormap support. */ + x_query_color (f, &color); +#endif + bzero (&frame_background, sizeof frame_background); + frame_background.red = RED_FROM_ULONG (color); + frame_background.green = GREEN_FROM_ULONG (color); + frame_background.blue = BLUE_FROM_ULONG (color); +#endif /* MAC_OS */ + + fn_png_set_background (png_ptr, &frame_background, + PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); + } + } + + /* Update info structure. */ + fn_png_read_update_info (png_ptr, info_ptr); + + /* Get number of channels. Valid values are 1 for grayscale images + and images with a palette, 2 for grayscale images with transparency + information (alpha channel), 3 for RGB images, and 4 for RGB + images with alpha channel, i.e. RGBA. If conversions above were + sufficient we should only have 3 or 4 channels here. */ + channels = fn_png_get_channels (png_ptr, info_ptr); + xassert (channels == 3 || channels == 4); + + /* Number of bytes needed for one row of the image. */ + row_bytes = fn_png_get_rowbytes (png_ptr, info_ptr); + + /* Allocate memory for the image. */ + pixels = (png_byte *) xmalloc (row_bytes * height * sizeof *pixels); + rows = (png_byte **) xmalloc (height * sizeof *rows); + for (i = 0; i < height; ++i) + rows[i] = pixels + i * row_bytes; + + /* Read the entire image. */ + fn_png_read_image (png_ptr, rows); + fn_png_read_end (png_ptr, info_ptr); + if (fp) + { + fclose (fp); + fp = NULL; + } + + /* Create the X image and pixmap. */ + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, + &img->pixmap)) + goto error; + + /* Create an image and pixmap serving as mask if the PNG image + contains an alpha channel. */ + if (channels == 4 + && !transparent_p + && !x_create_x_image_and_pixmap (f, width, height, 1, + &mask_img, &img->mask)) + { + x_destroy_x_image (ximg); + Free_Pixmap (FRAME_X_DISPLAY (f), img->pixmap); + img->pixmap = NO_PIXMAP; + goto error; + } + + /* Fill the X image and mask from PNG data. */ + init_color_table (); + + for (y = 0; y < height; ++y) + { + png_byte *p = rows[y]; + + for (x = 0; x < width; ++x) + { + unsigned r, g, b; + + r = *p++ << 8; + g = *p++ << 8; + b = *p++ << 8; + XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b)); + /* An alpha channel, aka mask channel, associates variable + transparency with an image. Where other image formats + support binary transparency---fully transparent or fully + opaque---PNG allows up to 254 levels of partial transparency. + The PNG library implements partial transparency by combining + the image with a specified background color. + + I'm not sure how to handle this here nicely: because the + background on which the image is displayed may change, for + real alpha channel support, it would be necessary to create + a new image for each possible background. + + What I'm doing now is that a mask is created if we have + boolean transparency information. Otherwise I'm using + the frame's background color to combine the image with. */ + + if (channels == 4) + { + if (mask_img) + XPutPixel (mask_img, x, y, *p > 0 ? PIX_MASK_DRAW (f) : PIX_MASK_RETAIN (f)); + ++p; + } + } + } + + if (NILP (image_spec_value (img->spec, QCbackground, NULL))) + /* Set IMG's background color from the PNG image, unless the user + overrode it. */ + { + png_color_16 *bg; + if (fn_png_get_bKGD (png_ptr, info_ptr, &bg)) + { + img->background = lookup_rgb_color (f, bg->red, bg->green, bg->blue); + img->background_valid = 1; + } + } + +#ifdef COLOR_TABLE_SUPPORT + /* Remember colors allocated for this image. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); +#endif /* COLOR_TABLE_SUPPORT */ + + /* Clean up. */ + fn_png_destroy_read_struct (&png_ptr, &info_ptr, &end_info); + xfree (rows); + xfree (pixels); + + img->width = width; + img->height = height; + + /* Maybe fill in the background field while we have ximg handy. */ + IMAGE_BACKGROUND (img, f, ximg); + + /* Put the image into the pixmap, then free the X image and its buffer. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + + /* Same for the mask. */ + if (mask_img) + { + /* Fill in the background_transparent field while we have the mask + handy. */ + image_background_transparent (img, f, mask_img); + + x_put_x_image (f, mask_img, img->mask, img->width, img->height); + x_destroy_x_image (mask_img); + } + + UNGCPRO; + return 1; +} + +#else /* HAVE_PNG */ + +#ifdef MAC_OS +static int +png_load (f, img) + struct frame *f; + struct image *img; +{ +#ifdef MAC_OSX + if (MyCGImageCreateWithPNGDataProvider) + return image_load_quartz2d (f, img, 1); + else +#endif + return image_load_quicktime (f, img, kQTFileTypePNG); +} +#endif /* MAC_OS */ + +#endif /* !HAVE_PNG */ + + + +/*********************************************************************** + JPEG + ***********************************************************************/ + +#if defined (HAVE_JPEG) || defined (MAC_OS) + +static int jpeg_image_p P_ ((Lisp_Object object)); +static int jpeg_load P_ ((struct frame *f, struct image *img)); + +/* The symbol `jpeg' identifying images of this type. */ + +Lisp_Object Qjpeg; + +/* Indices of image specification fields in gs_format, below. */ + +enum jpeg_keyword_index +{ + JPEG_TYPE, + JPEG_DATA, + JPEG_FILE, + JPEG_ASCENT, + JPEG_MARGIN, + JPEG_RELIEF, + JPEG_ALGORITHM, + JPEG_HEURISTIC_MASK, + JPEG_MASK, + JPEG_BACKGROUND, + JPEG_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword jpeg_format[JPEG_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversions", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0} +}; + +/* Structure describing the image type `jpeg'. */ + +static struct image_type jpeg_type = +{ + &Qjpeg, + jpeg_image_p, + jpeg_load, + x_clear_image, + NULL +}; + +/* Return non-zero if OBJECT is a valid JPEG image specification. */ + +static int +jpeg_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[JPEG_LAST]; + + bcopy (jpeg_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, JPEG_LAST, Qjpeg)) + return 0; + + /* Must specify either the :data or :file keyword. */ + return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1; +} + +#endif /* HAVE_JPEG || MAC_OS */ + +#ifdef HAVE_JPEG + +/* Work around a warning about HAVE_STDLIB_H being redefined in + jconfig.h. */ +#ifdef HAVE_STDLIB_H +#define HAVE_STDLIB_H_1 +#undef HAVE_STDLIB_H +#endif /* HAVE_STLIB_H */ + +#include <jpeglib.h> +#include <jerror.h> +#include <setjmp.h> + +#ifdef HAVE_STLIB_H_1 +#define HAVE_STDLIB_H 1 +#endif + +#ifdef HAVE_NTGUI + +/* JPEG library details. */ +DEF_IMGLIB_FN (jpeg_CreateDecompress); +DEF_IMGLIB_FN (jpeg_start_decompress); +DEF_IMGLIB_FN (jpeg_finish_decompress); +DEF_IMGLIB_FN (jpeg_destroy_decompress); +DEF_IMGLIB_FN (jpeg_read_header); +DEF_IMGLIB_FN (jpeg_read_scanlines); +DEF_IMGLIB_FN (jpeg_stdio_src); +DEF_IMGLIB_FN (jpeg_std_error); +DEF_IMGLIB_FN (jpeg_resync_to_restart); + +static int +init_jpeg_functions (void) +{ + HMODULE library; + + if (!(library = LoadLibrary ("libjpeg.dll")) + && !(library = LoadLibrary ("jpeg-62.dll")) + && !(library = LoadLibrary ("jpeg.dll"))) + return 0; + + LOAD_IMGLIB_FN (library, jpeg_finish_decompress); + LOAD_IMGLIB_FN (library, jpeg_read_scanlines); + LOAD_IMGLIB_FN (library, jpeg_start_decompress); + LOAD_IMGLIB_FN (library, jpeg_read_header); + LOAD_IMGLIB_FN (library, jpeg_stdio_src); + LOAD_IMGLIB_FN (library, jpeg_CreateDecompress); + LOAD_IMGLIB_FN (library, jpeg_destroy_decompress); + LOAD_IMGLIB_FN (library, jpeg_std_error); + LOAD_IMGLIB_FN (library, jpeg_resync_to_restart); + return 1; +} + +/* Wrapper since we can't directly assign the function pointer + to another function pointer that was declared more completely easily. */ +static boolean +jpeg_resync_to_restart_wrapper(cinfo, desired) + j_decompress_ptr cinfo; + int desired; +{ + return fn_jpeg_resync_to_restart (cinfo, desired); +} + +#else + +#define fn_jpeg_CreateDecompress(a,b,c) jpeg_create_decompress(a) +#define fn_jpeg_start_decompress jpeg_start_decompress +#define fn_jpeg_finish_decompress jpeg_finish_decompress +#define fn_jpeg_destroy_decompress jpeg_destroy_decompress +#define fn_jpeg_read_header jpeg_read_header +#define fn_jpeg_read_scanlines jpeg_read_scanlines +#define fn_jpeg_stdio_src jpeg_stdio_src +#define fn_jpeg_std_error jpeg_std_error +#define jpeg_resync_to_restart_wrapper jpeg_resync_to_restart + +#endif /* HAVE_NTGUI */ + +struct my_jpeg_error_mgr +{ + struct jpeg_error_mgr pub; + jmp_buf setjmp_buffer; +}; + + +static void +my_error_exit (cinfo) + j_common_ptr cinfo; +{ + struct my_jpeg_error_mgr *mgr = (struct my_jpeg_error_mgr *) cinfo->err; + longjmp (mgr->setjmp_buffer, 1); +} + + +/* Init source method for JPEG data source manager. Called by + jpeg_read_header() before any data is actually read. See + libjpeg.doc from the JPEG lib distribution. */ + +static void +our_init_source (cinfo) + j_decompress_ptr cinfo; +{ +} + + +/* Fill input buffer method for JPEG data source manager. Called + whenever more data is needed. We read the whole image in one step, + so this only adds a fake end of input marker at the end. */ + +static boolean +our_fill_input_buffer (cinfo) + j_decompress_ptr cinfo; +{ + /* Insert a fake EOI marker. */ + struct jpeg_source_mgr *src = cinfo->src; + static JOCTET buffer[2]; + + buffer[0] = (JOCTET) 0xFF; + buffer[1] = (JOCTET) JPEG_EOI; + + src->next_input_byte = buffer; + src->bytes_in_buffer = 2; + return TRUE; +} + + +/* Method to skip over NUM_BYTES bytes in the image data. CINFO->src + is the JPEG data source manager. */ + +static void +our_skip_input_data (cinfo, num_bytes) + j_decompress_ptr cinfo; + long num_bytes; +{ + struct jpeg_source_mgr *src = (struct jpeg_source_mgr *) cinfo->src; + + if (src) + { + if (num_bytes > src->bytes_in_buffer) + ERREXIT (cinfo, JERR_INPUT_EOF); + + src->bytes_in_buffer -= num_bytes; + src->next_input_byte += num_bytes; + } +} + + +/* Method to terminate data source. Called by + jpeg_finish_decompress() after all data has been processed. */ + +static void +our_term_source (cinfo) + j_decompress_ptr cinfo; +{ +} + + +/* Set up the JPEG lib for reading an image from DATA which contains + LEN bytes. CINFO is the decompression info structure created for + reading the image. */ + +static void +jpeg_memory_src (cinfo, data, len) + j_decompress_ptr cinfo; + JOCTET *data; + unsigned int len; +{ + struct jpeg_source_mgr *src; + + if (cinfo->src == NULL) + { + /* First time for this JPEG object? */ + cinfo->src = (struct jpeg_source_mgr *) + (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT, + sizeof (struct jpeg_source_mgr)); + src = (struct jpeg_source_mgr *) cinfo->src; + src->next_input_byte = data; + } + + src = (struct jpeg_source_mgr *) cinfo->src; + src->init_source = our_init_source; + src->fill_input_buffer = our_fill_input_buffer; + src->skip_input_data = our_skip_input_data; + src->resync_to_restart = jpeg_resync_to_restart_wrapper; /* Use default method. */ + src->term_source = our_term_source; + src->bytes_in_buffer = len; + src->next_input_byte = data; +} + + +/* Load image IMG for use on frame F. Patterned after example.c + from the JPEG lib. */ + +static int +jpeg_load (f, img) + struct frame *f; + struct image *img; +{ + struct jpeg_decompress_struct cinfo; + struct my_jpeg_error_mgr mgr; + Lisp_Object file, specified_file; + Lisp_Object specified_data; + FILE * volatile fp = NULL; + JSAMPARRAY buffer; + int row_stride, x, y; + XImagePtr ximg = NULL; + int rc; + unsigned long *colors; + int width, height; + struct gcpro gcpro1; + + /* Open the JPEG file. */ + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + file = Qnil; + GCPRO1 (file); + + if (NILP (specified_data)) + { + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + + fp = fopen (SDATA (file), "rb"); + if (fp == NULL) + { + image_error ("Cannot open `%s'", file, Qnil); + UNGCPRO; + return 0; + } + } + + /* Customize libjpeg's error handling to call my_error_exit when an + error is detected. This function will perform a longjmp. */ + cinfo.err = fn_jpeg_std_error (&mgr.pub); + mgr.pub.error_exit = my_error_exit; + + if ((rc = setjmp (mgr.setjmp_buffer)) != 0) + { + if (rc == 1) + { + /* Called from my_error_exit. Display a JPEG error. */ + char buffer[JMSG_LENGTH_MAX]; + cinfo.err->format_message ((j_common_ptr) &cinfo, buffer); + image_error ("Error reading JPEG image `%s': %s", img->spec, + build_string (buffer)); + } + + /* Close the input file and destroy the JPEG object. */ + if (fp) + fclose ((FILE *) fp); + fn_jpeg_destroy_decompress (&cinfo); + + /* If we already have an XImage, free that. */ + x_destroy_x_image (ximg); + + /* Free pixmap and colors. */ + x_clear_image (f, img); + + UNGCPRO; + return 0; + } + + /* Create the JPEG decompression object. Let it read from fp. + Read the JPEG image header. */ + fn_jpeg_CreateDecompress (&cinfo, JPEG_LIB_VERSION, sizeof (cinfo)); + + if (NILP (specified_data)) + fn_jpeg_stdio_src (&cinfo, (FILE *) fp); + else + jpeg_memory_src (&cinfo, SDATA (specified_data), + SBYTES (specified_data)); + + fn_jpeg_read_header (&cinfo, TRUE); + + /* Customize decompression so that color quantization will be used. + Start decompression. */ + cinfo.quantize_colors = TRUE; + fn_jpeg_start_decompress (&cinfo); + width = img->width = cinfo.output_width; + height = img->height = cinfo.output_height; + + /* Create X image and pixmap. */ + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) + longjmp (mgr.setjmp_buffer, 2); + + /* Allocate colors. When color quantization is used, + cinfo.actual_number_of_colors has been set with the number of + colors generated, and cinfo.colormap is a two-dimensional array + of color indices in the range 0..cinfo.actual_number_of_colors. + No more than 255 colors will be generated. */ + { + int i, ir, ig, ib; + + if (cinfo.out_color_components > 2) + ir = 0, ig = 1, ib = 2; + else if (cinfo.out_color_components > 1) + ir = 0, ig = 1, ib = 0; + else + ir = 0, ig = 0, ib = 0; + + /* Use the color table mechanism because it handles colors that + cannot be allocated nicely. Such colors will be replaced with + a default color, and we don't have to care about which colors + can be freed safely, and which can't. */ + init_color_table (); + colors = (unsigned long *) alloca (cinfo.actual_number_of_colors + * sizeof *colors); + + for (i = 0; i < cinfo.actual_number_of_colors; ++i) + { + /* Multiply RGB values with 255 because X expects RGB values + in the range 0..0xffff. */ + int r = cinfo.colormap[ir][i] << 8; + int g = cinfo.colormap[ig][i] << 8; + int b = cinfo.colormap[ib][i] << 8; + colors[i] = lookup_rgb_color (f, r, g, b); + } + +#ifdef COLOR_TABLE_SUPPORT + /* Remember those colors actually allocated. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); +#endif /* COLOR_TABLE_SUPPORT */ + } + + /* Read pixels. */ + row_stride = width * cinfo.output_components; + buffer = cinfo.mem->alloc_sarray ((j_common_ptr) &cinfo, JPOOL_IMAGE, + row_stride, 1); + for (y = 0; y < height; ++y) + { + fn_jpeg_read_scanlines (&cinfo, buffer, 1); + for (x = 0; x < cinfo.output_width; ++x) + XPutPixel (ximg, x, y, colors[buffer[0][x]]); + } + + /* Clean up. */ + fn_jpeg_finish_decompress (&cinfo); + fn_jpeg_destroy_decompress (&cinfo); + if (fp) + fclose ((FILE *) fp); + + /* Maybe fill in the background field while we have ximg handy. */ + if (NILP (image_spec_value (img->spec, QCbackground, NULL))) + IMAGE_BACKGROUND (img, f, ximg); + + /* Put the image into the pixmap. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + UNGCPRO; + return 1; +} + +#else /* HAVE_JPEG */ + +#ifdef MAC_OS +static int +jpeg_load (f, img) + struct frame *f; + struct image *img; +{ +#ifdef MAC_OSX + return image_load_quartz2d (f, img, 0); +#else + return image_load_quicktime (f, img, kQTFileTypeJPEG); +#endif +} +#endif /* MAC_OS */ + +#endif /* !HAVE_JPEG */ + + + +/*********************************************************************** + TIFF + ***********************************************************************/ + +#if defined (HAVE_TIFF) || defined (MAC_OS) + +static int tiff_image_p P_ ((Lisp_Object object)); +static int tiff_load P_ ((struct frame *f, struct image *img)); + +/* The symbol `tiff' identifying images of this type. */ + +Lisp_Object Qtiff; + +/* Indices of image specification fields in tiff_format, below. */ + +enum tiff_keyword_index +{ + TIFF_TYPE, + TIFF_DATA, + TIFF_FILE, + TIFF_ASCENT, + TIFF_MARGIN, + TIFF_RELIEF, + TIFF_ALGORITHM, + TIFF_HEURISTIC_MASK, + TIFF_MASK, + TIFF_BACKGROUND, + TIFF_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword tiff_format[TIFF_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversions", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0} +}; + +/* Structure describing the image type `tiff'. */ + +static struct image_type tiff_type = +{ + &Qtiff, + tiff_image_p, + tiff_load, + x_clear_image, + NULL +}; + +/* Return non-zero if OBJECT is a valid TIFF image specification. */ + +static int +tiff_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[TIFF_LAST]; + bcopy (tiff_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, TIFF_LAST, Qtiff)) + return 0; + + /* Must specify either the :data or :file keyword. */ + return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1; +} + +#endif /* HAVE_TIFF || MAC_OS */ + +#ifdef HAVE_TIFF + +#include <tiffio.h> + +#ifdef HAVE_NTGUI + +/* TIFF library details. */ +DEF_IMGLIB_FN (TIFFSetErrorHandler); +DEF_IMGLIB_FN (TIFFSetWarningHandler); +DEF_IMGLIB_FN (TIFFOpen); +DEF_IMGLIB_FN (TIFFClientOpen); +DEF_IMGLIB_FN (TIFFGetField); +DEF_IMGLIB_FN (TIFFReadRGBAImage); +DEF_IMGLIB_FN (TIFFClose); + +static int +init_tiff_functions (void) +{ + HMODULE library; + + if (!(library = LoadLibrary ("libtiff.dll"))) + return 0; + + LOAD_IMGLIB_FN (library, TIFFSetErrorHandler); + LOAD_IMGLIB_FN (library, TIFFSetWarningHandler); + LOAD_IMGLIB_FN (library, TIFFOpen); + LOAD_IMGLIB_FN (library, TIFFClientOpen); + LOAD_IMGLIB_FN (library, TIFFGetField); + LOAD_IMGLIB_FN (library, TIFFReadRGBAImage); + LOAD_IMGLIB_FN (library, TIFFClose); + return 1; +} + +#else + +#define fn_TIFFSetErrorHandler TIFFSetErrorHandler +#define fn_TIFFSetWarningHandler TIFFSetWarningHandler +#define fn_TIFFOpen TIFFOpen +#define fn_TIFFClientOpen TIFFClientOpen +#define fn_TIFFGetField TIFFGetField +#define fn_TIFFReadRGBAImage TIFFReadRGBAImage +#define fn_TIFFClose TIFFClose + +#endif /* HAVE_NTGUI */ + + +/* Reading from a memory buffer for TIFF images Based on the PNG + memory source, but we have to provide a lot of extra functions. + Blah. + + We really only need to implement read and seek, but I am not + convinced that the TIFF library is smart enough not to destroy + itself if we only hand it the function pointers we need to + override. */ + +typedef struct +{ + unsigned char *bytes; + size_t len; + int index; +} +tiff_memory_source; + +static size_t +tiff_read_from_memory (data, buf, size) + thandle_t data; + tdata_t buf; + tsize_t size; +{ + tiff_memory_source *src = (tiff_memory_source *) data; + + if (size > src->len - src->index) + return (size_t) -1; + bcopy (src->bytes + src->index, buf, size); + src->index += size; + return size; +} + +static size_t +tiff_write_from_memory (data, buf, size) + thandle_t data; + tdata_t buf; + tsize_t size; +{ + return (size_t) -1; +} + +static toff_t +tiff_seek_in_memory (data, off, whence) + thandle_t data; + toff_t off; + int whence; +{ + tiff_memory_source *src = (tiff_memory_source *) data; + int idx; + + switch (whence) + { + case SEEK_SET: /* Go from beginning of source. */ + idx = off; + break; + + case SEEK_END: /* Go from end of source. */ + idx = src->len + off; + break; + + case SEEK_CUR: /* Go from current position. */ + idx = src->index + off; + break; + + default: /* Invalid `whence'. */ + return -1; + } + + if (idx > src->len || idx < 0) + return -1; + + src->index = idx; + return src->index; +} + +static int +tiff_close_memory (data) + thandle_t data; +{ + /* NOOP */ + return 0; +} + +static int +tiff_mmap_memory (data, pbase, psize) + thandle_t data; + tdata_t *pbase; + toff_t *psize; +{ + /* It is already _IN_ memory. */ + return 0; +} + +static void +tiff_unmap_memory (data, base, size) + thandle_t data; + tdata_t base; + toff_t size; +{ + /* We don't need to do this. */ +} + +static toff_t +tiff_size_of_memory (data) + thandle_t data; +{ + return ((tiff_memory_source *) data)->len; +} + + +static void +tiff_error_handler (title, format, ap) + const char *title, *format; + va_list ap; +{ + char buf[512]; + int len; + + len = sprintf (buf, "TIFF error: %s ", title); + vsprintf (buf + len, format, ap); + add_to_log (buf, Qnil, Qnil); +} + + +static void +tiff_warning_handler (title, format, ap) + const char *title, *format; + va_list ap; +{ + char buf[512]; + int len; + + len = sprintf (buf, "TIFF warning: %s ", title); + vsprintf (buf + len, format, ap); + add_to_log (buf, Qnil, Qnil); +} + + +/* Load TIFF image IMG for use on frame F. Value is non-zero if + successful. */ + +static int +tiff_load (f, img) + struct frame *f; + struct image *img; +{ + Lisp_Object file, specified_file; + Lisp_Object specified_data; + TIFF *tiff; + int width, height, x, y; + uint32 *buf; + int rc; + XImagePtr ximg; + struct gcpro gcpro1; + tiff_memory_source memsrc; + + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + file = Qnil; + GCPRO1 (file); + + fn_TIFFSetErrorHandler (tiff_error_handler); + fn_TIFFSetWarningHandler (tiff_warning_handler); + + if (NILP (specified_data)) + { + /* Read from a file */ + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + + /* Try to open the image file. */ + tiff = fn_TIFFOpen (SDATA (file), "r"); + if (tiff == NULL) + { + image_error ("Cannot open `%s'", file, Qnil); + UNGCPRO; + return 0; + } + } + else + { + /* Memory source! */ + memsrc.bytes = SDATA (specified_data); + memsrc.len = SBYTES (specified_data); + memsrc.index = 0; + + tiff = fn_TIFFClientOpen ("memory_source", "r", &memsrc, + (TIFFReadWriteProc) tiff_read_from_memory, + (TIFFReadWriteProc) tiff_write_from_memory, + tiff_seek_in_memory, + tiff_close_memory, + tiff_size_of_memory, + tiff_mmap_memory, + tiff_unmap_memory); + + if (!tiff) + { + image_error ("Cannot open memory source for `%s'", img->spec, Qnil); + UNGCPRO; + return 0; + } + } + + /* Get width and height of the image, and allocate a raster buffer + of width x height 32-bit values. */ + fn_TIFFGetField (tiff, TIFFTAG_IMAGEWIDTH, &width); + fn_TIFFGetField (tiff, TIFFTAG_IMAGELENGTH, &height); + buf = (uint32 *) xmalloc (width * height * sizeof *buf); + + rc = fn_TIFFReadRGBAImage (tiff, width, height, buf, 0); + fn_TIFFClose (tiff); + if (!rc) + { + image_error ("Error reading TIFF image `%s'", img->spec, Qnil); + xfree (buf); + UNGCPRO; + return 0; + } + + /* Create the X image and pixmap. */ + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) + { + xfree (buf); + UNGCPRO; + return 0; + } + + /* Initialize the color table. */ + init_color_table (); + + /* Process the pixel raster. Origin is in the lower-left corner. */ + for (y = 0; y < height; ++y) + { + uint32 *row = buf + y * width; + + for (x = 0; x < width; ++x) + { + uint32 abgr = row[x]; + int r = TIFFGetR (abgr) << 8; + int g = TIFFGetG (abgr) << 8; + int b = TIFFGetB (abgr) << 8; + XPutPixel (ximg, x, height - 1 - y, lookup_rgb_color (f, r, g, b)); + } + } + +#ifdef COLOR_TABLE_SUPPORT + /* Remember the colors allocated for the image. Free the color table. */ + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); +#endif /* COLOR_TABLE_SUPPORT */ + + img->width = width; + img->height = height; + + /* Maybe fill in the background field while we have ximg handy. */ + if (NILP (image_spec_value (img->spec, QCbackground, NULL))) + IMAGE_BACKGROUND (img, f, ximg); + + /* Put the image into the pixmap, then free the X image and its buffer. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + xfree (buf); + + UNGCPRO; + return 1; +} + +#else /* HAVE_TIFF */ + +#ifdef MAC_OS +static int +tiff_load (f, img) + struct frame *f; + struct image *img; +{ + return image_load_quicktime (f, img, kQTFileTypeTIFF); +} +#endif /* MAC_OS */ + +#endif /* !HAVE_TIFF */ + + + +/*********************************************************************** + GIF + ***********************************************************************/ + +#if defined (HAVE_GIF) || defined (MAC_OS) + +static int gif_image_p P_ ((Lisp_Object object)); +static int gif_load P_ ((struct frame *f, struct image *img)); + +/* The symbol `gif' identifying images of this type. */ + +Lisp_Object Qgif; + +/* Indices of image specification fields in gif_format, below. */ + +enum gif_keyword_index +{ + GIF_TYPE, + GIF_DATA, + GIF_FILE, + GIF_ASCENT, + GIF_MARGIN, + GIF_RELIEF, + GIF_ALGORITHM, + GIF_HEURISTIC_MASK, + GIF_MASK, + GIF_IMAGE, + GIF_BACKGROUND, + GIF_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword gif_format[GIF_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":image", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0} +}; + +/* Structure describing the image type `gif'. */ + +static struct image_type gif_type = +{ + &Qgif, + gif_image_p, + gif_load, + x_clear_image, + NULL +}; + +/* Return non-zero if OBJECT is a valid GIF image specification. */ + +static int +gif_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[GIF_LAST]; + bcopy (gif_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, GIF_LAST, Qgif)) + return 0; + + /* Must specify either the :data or :file keyword. */ + return fmt[GIF_FILE].count + fmt[GIF_DATA].count == 1; +} + +#endif /* HAVE_GIF || MAC_OS */ + +#ifdef HAVE_GIF + +#if defined (HAVE_NTGUI) || defined (MAC_OS) +/* avoid conflict with QuickdrawText.h */ +#define DrawText gif_DrawText +#include <gif_lib.h> +#undef DrawText + +#else /* HAVE_NTGUI || MAC_OS */ + +#include <gif_lib.h> + +#endif /* HAVE_NTGUI || MAC_OS */ + + +#ifdef HAVE_NTGUI + +/* GIF library details. */ +DEF_IMGLIB_FN (DGifCloseFile); +DEF_IMGLIB_FN (DGifSlurp); +DEF_IMGLIB_FN (DGifOpen); +DEF_IMGLIB_FN (DGifOpenFileName); + +static int +init_gif_functions (void) +{ + HMODULE library; + + if (!(library = LoadLibrary ("libungif.dll"))) + return 0; + + LOAD_IMGLIB_FN (library, DGifCloseFile); + LOAD_IMGLIB_FN (library, DGifSlurp); + LOAD_IMGLIB_FN (library, DGifOpen); + LOAD_IMGLIB_FN (library, DGifOpenFileName); + return 1; +} + +#else + +#define fn_DGifCloseFile DGifCloseFile +#define fn_DGifSlurp DGifSlurp +#define fn_DGifOpen DGifOpen +#define fn_DGifOpenFileName DGifOpenFileName + +#endif /* HAVE_NTGUI */ + +/* Reading a GIF image from memory + Based on the PNG memory stuff to a certain extent. */ + +typedef struct +{ + unsigned char *bytes; + size_t len; + int index; +} +gif_memory_source; + +/* Make the current memory source available to gif_read_from_memory. + It's done this way because not all versions of libungif support + a UserData field in the GifFileType structure. */ +static gif_memory_source *current_gif_memory_src; + +static int +gif_read_from_memory (file, buf, len) + GifFileType *file; + GifByteType *buf; + int len; +{ + gif_memory_source *src = current_gif_memory_src; + + if (len > src->len - src->index) + return -1; + + bcopy (src->bytes + src->index, buf, len); + src->index += len; + return len; +} + + +/* Load GIF image IMG for use on frame F. Value is non-zero if + successful. */ + +static int +gif_load (f, img) + struct frame *f; + struct image *img; +{ + Lisp_Object file, specified_file; + Lisp_Object specified_data; + int rc, width, height, x, y, i; + XImagePtr ximg; + ColorMapObject *gif_color_map; + unsigned long pixel_colors[256]; + GifFileType *gif; + struct gcpro gcpro1; + Lisp_Object image; + int ino, image_left, image_top, image_width, image_height; + gif_memory_source memsrc; + unsigned char *raster; + + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + file = Qnil; + GCPRO1 (file); + + if (NILP (specified_data)) + { + file = x_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file, Qnil); + UNGCPRO; + return 0; + } + + /* Open the GIF file. */ + gif = fn_DGifOpenFileName (SDATA (file)); + if (gif == NULL) + { + image_error ("Cannot open `%s'", file, Qnil); + UNGCPRO; + return 0; + } + } + else + { + /* Read from memory! */ + current_gif_memory_src = &memsrc; + memsrc.bytes = SDATA (specified_data); + memsrc.len = SBYTES (specified_data); + memsrc.index = 0; + + gif = fn_DGifOpen(&memsrc, gif_read_from_memory); + if (!gif) + { + image_error ("Cannot open memory source `%s'", img->spec, Qnil); + UNGCPRO; + return 0; + } + } + + /* Read entire contents. */ + rc = fn_DGifSlurp (gif); + if (rc == GIF_ERROR) + { + image_error ("Error reading `%s'", img->spec, Qnil); + fn_DGifCloseFile (gif); + UNGCPRO; + return 0; + } + + image = image_spec_value (img->spec, QCindex, NULL); + ino = INTEGERP (image) ? XFASTINT (image) : 0; + if (ino >= gif->ImageCount) + { + image_error ("Invalid image number `%s' in image `%s'", + image, img->spec); + fn_DGifCloseFile (gif); + UNGCPRO; + return 0; + } + + width = img->width = max (gif->SWidth, gif->Image.Left + gif->Image.Width); + height = img->height = max (gif->SHeight, gif->Image.Top + gif->Image.Height); + + /* Create the X image and pixmap. */ + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) + { + fn_DGifCloseFile (gif); + UNGCPRO; + return 0; + } + + /* Allocate colors. */ + gif_color_map = gif->SavedImages[ino].ImageDesc.ColorMap; + if (!gif_color_map) + gif_color_map = gif->SColorMap; + init_color_table (); + bzero (pixel_colors, sizeof pixel_colors); + + for (i = 0; i < gif_color_map->ColorCount; ++i) + { + int r = gif_color_map->Colors[i].Red << 8; + int g = gif_color_map->Colors[i].Green << 8; + int b = gif_color_map->Colors[i].Blue << 8; + pixel_colors[i] = lookup_rgb_color (f, r, g, b); + } + +#ifdef COLOR_TABLE_SUPPORT + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); +#endif /* COLOR_TABLE_SUPPORT */ + + /* Clear the part of the screen image that are not covered by + the image from the GIF file. Full animated GIF support + requires more than can be done here (see the gif89 spec, + disposal methods). Let's simply assume that the part + not covered by a sub-image is in the frame's background color. */ + image_top = gif->SavedImages[ino].ImageDesc.Top; + image_left = gif->SavedImages[ino].ImageDesc.Left; + image_width = gif->SavedImages[ino].ImageDesc.Width; + image_height = gif->SavedImages[ino].ImageDesc.Height; + + for (y = 0; y < image_top; ++y) + for (x = 0; x < width; ++x) + XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); + + for (y = image_top + image_height; y < height; ++y) + for (x = 0; x < width; ++x) + XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); + + for (y = image_top; y < image_top + image_height; ++y) + { + for (x = 0; x < image_left; ++x) + XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); + for (x = image_left + image_width; x < width; ++x) + XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); + } + + /* Read the GIF image into the X image. We use a local variable + `raster' here because RasterBits below is a char *, and invites + problems with bytes >= 0x80. */ + raster = (unsigned char *) gif->SavedImages[ino].RasterBits; + + if (gif->SavedImages[ino].ImageDesc.Interlace) + { + static int interlace_start[] = {0, 4, 2, 1}; + static int interlace_increment[] = {8, 8, 4, 2}; + int pass; + int row = interlace_start[0]; + + pass = 0; + + for (y = 0; y < image_height; y++) + { + if (row >= image_height) + { + row = interlace_start[++pass]; + while (row >= image_height) + row = interlace_start[++pass]; + } + + for (x = 0; x < image_width; x++) + { + int i = raster[(y * image_width) + x]; + XPutPixel (ximg, x + image_left, row + image_top, + pixel_colors[i]); + } + + row += interlace_increment[pass]; + } + } + else + { + for (y = 0; y < image_height; ++y) + for (x = 0; x < image_width; ++x) + { + int i = raster[y * image_width + x]; + XPutPixel (ximg, x + image_left, y + image_top, pixel_colors[i]); + } + } + + fn_DGifCloseFile (gif); + + /* Maybe fill in the background field while we have ximg handy. */ + if (NILP (image_spec_value (img->spec, QCbackground, NULL))) + IMAGE_BACKGROUND (img, f, ximg); + + /* Put the image into the pixmap, then free the X image and its buffer. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + + UNGCPRO; + return 1; +} + +#else + +#ifdef MAC_OS +static int +gif_load (f, img) + struct frame *f; + struct image *img; +{ + Lisp_Object specified_file, file; + Lisp_Object specified_data; + OSErr err; + Boolean graphic_p, movie_p, prefer_graphic_p; + Handle dh = NULL; + Movie movie = NULL; + Lisp_Object image; + Track track = NULL; + Media media = NULL; + long nsamples; + Rect rect; + Lisp_Object specified_bg; + XColor color; + RGBColor bg_color; + int width, height; + XImagePtr ximg; + TimeValue time; + struct gcpro gcpro1; + int ino; + + specified_file = image_spec_value (img->spec, QCfile, NULL); + specified_data = image_spec_value (img->spec, QCdata, NULL); + + if (NILP (specified_data)) + { + /* Read from a file */ + FSSpec fss; + short refnum; + + err = find_image_fsspec (specified_file, &file, &fss); + if (err != noErr) + { + if (err == fnfErr) + image_error ("Cannot find image file `%s'", specified_file, Qnil); + else + goto open_error; + } + + err = CanQuickTimeOpenFile (&fss, kQTFileTypeGIF, 0, + &graphic_p, &movie_p, &prefer_graphic_p, 0); + if (err != noErr) + goto open_error; + + if (!graphic_p && !movie_p) + goto open_error; + if (prefer_graphic_p) + return image_load_qt_1 (f, img, kQTFileTypeGIF, &fss, NULL); + err = OpenMovieFile (&fss, &refnum, fsRdPerm); + if (err != noErr) + goto open_error; + err = NewMovieFromFile (&movie, refnum, NULL, NULL, 0, NULL); + CloseMovieFile (refnum); + if (err != noErr) + { + image_error ("Error reading `%s'", file, Qnil); + return 0; + } + } + else + { + /* Memory source! */ + Handle dref = NULL; + long file_type_atom[3]; + + err = PtrToHand (SDATA (specified_data), &dh, SBYTES (specified_data)); + if (err != noErr) + { + image_error ("Cannot allocate data handle for `%s'", + img->spec, Qnil); + goto error; + } + + file_type_atom[0] = EndianU32_NtoB (sizeof (long) * 3); + file_type_atom[1] = EndianU32_NtoB (kDataRefExtensionMacOSFileType); + file_type_atom[2] = EndianU32_NtoB (kQTFileTypeGIF); + err = PtrToHand (&dh, &dref, sizeof (Handle)); + if (err == noErr) + /* no file name */ + err = PtrAndHand ("\p", dref, 1); + if (err == noErr) + err = PtrAndHand (file_type_atom, dref, sizeof (long) * 3); + if (err != noErr) + { + image_error ("Cannot allocate handle data ref for `%s'", img->spec, Qnil); + goto error; + } + err = CanQuickTimeOpenDataRef (dref, HandleDataHandlerSubType, &graphic_p, + &movie_p, &prefer_graphic_p, 0); + if (err != noErr) + goto open_error; + + if (!graphic_p && !movie_p) + goto open_error; + if (prefer_graphic_p) + { + int success_p; + + DisposeHandle (dref); + success_p = image_load_qt_1 (f, img, kQTFileTypeGIF, NULL, dh); + DisposeHandle (dh); + return success_p; + } + err = NewMovieFromDataRef (&movie, 0, NULL, dref, + HandleDataHandlerSubType); + DisposeHandle (dref); + if (err != noErr) + goto open_error; + } + + image = image_spec_value (img->spec, QCindex, NULL); + ino = INTEGERP (image) ? XFASTINT (image) : 0; + track = GetMovieIndTrack (movie, 1); + media = GetTrackMedia (track); + nsamples = GetMediaSampleCount (media); + if (ino >= nsamples) + { + image_error ("Invalid image number `%s' in image `%s'", + image, img->spec); + goto error; + } + + specified_bg = image_spec_value (img->spec, QCbackground, NULL); + if (!STRINGP (specified_bg) || + !mac_defined_color (f, SDATA (specified_bg), &color, 0)) + { + color.pixel = FRAME_BACKGROUND_PIXEL (f); + color.red = RED16_FROM_ULONG (color.pixel); + color.green = GREEN16_FROM_ULONG (color.pixel); + color.blue = BLUE16_FROM_ULONG (color.pixel); + } + GetMovieBox (movie, &rect); + width = img->width = rect.right - rect.left; + height = img->height = rect.bottom - rect.top; + if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) + goto error; + + SetGWorld (ximg, NULL); + bg_color.red = color.red; + bg_color.green = color.green; + bg_color.blue = color.blue; + RGBBackColor (&bg_color); + SetMovieActive (movie, TRUE); + SetMovieGWorld (movie, ximg, NULL); + SampleNumToMediaTime (media, ino + 1, &time, NULL); + SetMovieTimeValue (movie, time); + MoviesTask (movie, 0L); + DisposeTrackMedia (media); + DisposeMovieTrack (track); + DisposeMovie (movie); + if (dh) + DisposeHandle (dh); + /* Maybe fill in the background field while we have ximg handy. */ + if (NILP (image_spec_value (img->spec, QCbackground, NULL))) + IMAGE_BACKGROUND (img, f, ximg); + + /* Put the image into the pixmap. */ + x_put_x_image (f, ximg, img->pixmap, width, height); + x_destroy_x_image (ximg); + return 1; + + open_error: + image_error ("Cannot open `%s'", file, Qnil); + error: + if (media) + DisposeTrackMedia (media); + if (track) + DisposeMovieTrack (track); + if (movie) + DisposeMovie (movie); + if (dh) + DisposeHandle (dh); + return 0; +} +#endif /* MAC_OS */ + +#endif /* HAVE_GIF */ + + + +/*********************************************************************** + Ghostscript + ***********************************************************************/ + +#ifdef HAVE_X_WINDOWS +#define HAVE_GHOSTSCRIPT 1 +#endif /* HAVE_X_WINDOWS */ + +/* The symbol `postscript' identifying images of this type. */ + +Lisp_Object Qpostscript; + +#ifdef HAVE_GHOSTSCRIPT + +static int gs_image_p P_ ((Lisp_Object object)); +static int gs_load P_ ((struct frame *f, struct image *img)); +static void gs_clear_image P_ ((struct frame *f, struct image *img)); + +/* Keyword symbols. */ + +Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height; + +/* Indices of image specification fields in gs_format, below. */ + +enum gs_keyword_index +{ + GS_TYPE, + GS_PT_WIDTH, + GS_PT_HEIGHT, + GS_FILE, + GS_LOADER, + GS_BOUNDING_BOX, + GS_ASCENT, + GS_MARGIN, + GS_RELIEF, + GS_ALGORITHM, + GS_HEURISTIC_MASK, + GS_MASK, + GS_BACKGROUND, + GS_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ + +static struct image_keyword gs_format[GS_LAST] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":pt-width", IMAGE_POSITIVE_INTEGER_VALUE, 1}, + {":pt-height", IMAGE_POSITIVE_INTEGER_VALUE, 1}, + {":file", IMAGE_STRING_VALUE, 1}, + {":loader", IMAGE_FUNCTION_VALUE, 0}, + {":bounding-box", IMAGE_DONT_CHECK_VALUE_TYPE, 1}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0} +}; + +/* Structure describing the image type `ghostscript'. */ + +static struct image_type gs_type = +{ + &Qpostscript, + gs_image_p, + gs_load, + gs_clear_image, + NULL +}; + + +/* Free X resources of Ghostscript image IMG which is used on frame F. */ + +static void +gs_clear_image (f, img) + struct frame *f; + struct image *img; +{ + /* IMG->data.ptr_val may contain a recorded colormap. */ + xfree (img->data.ptr_val); + x_clear_image (f, img); +} + + +/* Return non-zero if OBJECT is a valid Ghostscript image + specification. */ + +static int +gs_image_p (object) + Lisp_Object object; +{ + struct image_keyword fmt[GS_LAST]; + Lisp_Object tem; + int i; + + bcopy (gs_format, fmt, sizeof fmt); + + if (!parse_image_spec (object, fmt, GS_LAST, Qpostscript)) + return 0; + + /* Bounding box must be a list or vector containing 4 integers. */ + tem = fmt[GS_BOUNDING_BOX].value; + if (CONSP (tem)) + { + for (i = 0; i < 4; ++i, tem = XCDR (tem)) + if (!CONSP (tem) || !INTEGERP (XCAR (tem))) + return 0; + if (!NILP (tem)) + return 0; + } + else if (VECTORP (tem)) + { + if (XVECTOR (tem)->size != 4) + return 0; + for (i = 0; i < 4; ++i) + if (!INTEGERP (XVECTOR (tem)->contents[i])) + return 0; + } + else + return 0; + + return 1; +} + + +/* Load Ghostscript image IMG for use on frame F. Value is non-zero + if successful. */ + +static int +gs_load (f, img) + struct frame *f; + struct image *img; +{ + char buffer[100]; + Lisp_Object window_and_pixmap_id = Qnil, loader, pt_height, pt_width; + struct gcpro gcpro1, gcpro2; + Lisp_Object frame; + double in_width, in_height; + Lisp_Object pixel_colors = Qnil; + + /* Compute pixel size of pixmap needed from the given size in the + image specification. Sizes in the specification are in pt. 1 pt + = 1/72 in, xdpi and ydpi are stored in the frame's X display + info. */ + pt_width = image_spec_value (img->spec, QCpt_width, NULL); + in_width = XFASTINT (pt_width) / 72.0; + img->width = in_width * FRAME_X_DISPLAY_INFO (f)->resx; + pt_height = image_spec_value (img->spec, QCpt_height, NULL); + in_height = XFASTINT (pt_height) / 72.0; + img->height = in_height * FRAME_X_DISPLAY_INFO (f)->resy; + + /* Create the pixmap. */ + xassert (img->pixmap == NO_PIXMAP); + + /* Only W32 version did BLOCK_INPUT here. ++kfs */ + BLOCK_INPUT; + img->pixmap = XCreatePixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + img->width, img->height, + DefaultDepthOfScreen (FRAME_X_SCREEN (f))); + UNBLOCK_INPUT; + + if (!img->pixmap) + { + image_error ("Unable to create pixmap for `%s'", img->spec, Qnil); + return 0; + } + + /* Call the loader to fill the pixmap. It returns a process object + if successful. We do not record_unwind_protect here because + other places in redisplay like calling window scroll functions + don't either. Let the Lisp loader use `unwind-protect' instead. */ + GCPRO2 (window_and_pixmap_id, pixel_colors); + + sprintf (buffer, "%lu %lu", + (unsigned long) FRAME_X_WINDOW (f), + (unsigned long) img->pixmap); + window_and_pixmap_id = build_string (buffer); + + sprintf (buffer, "%lu %lu", + FRAME_FOREGROUND_PIXEL (f), + FRAME_BACKGROUND_PIXEL (f)); + pixel_colors = build_string (buffer); + + XSETFRAME (frame, f); + loader = image_spec_value (img->spec, QCloader, NULL); + if (NILP (loader)) + loader = intern ("gs-load-image"); + + img->data.lisp_val = call6 (loader, frame, img->spec, + make_number (img->width), + make_number (img->height), + window_and_pixmap_id, + pixel_colors); + UNGCPRO; + return PROCESSP (img->data.lisp_val); +} + + +/* Kill the Ghostscript process that was started to fill PIXMAP on + frame F. Called from XTread_socket when receiving an event + telling Emacs that Ghostscript has finished drawing. */ + +void +x_kill_gs_process (pixmap, f) + Pixmap pixmap; + struct frame *f; +{ + struct image_cache *c = FRAME_X_IMAGE_CACHE (f); + int class, i; + struct image *img; + + /* Find the image containing PIXMAP. */ + for (i = 0; i < c->used; ++i) + if (c->images[i]->pixmap == pixmap) + break; + + /* Should someone in between have cleared the image cache, for + instance, give up. */ + if (i == c->used) + return; + + /* Kill the GS process. We should have found PIXMAP in the image + cache and its image should contain a process object. */ + img = c->images[i]; + xassert (PROCESSP (img->data.lisp_val)); + Fkill_process (img->data.lisp_val, Qnil); + img->data.lisp_val = Qnil; + +#if defined (HAVE_X_WINDOWS) + + /* On displays with a mutable colormap, figure out the colors + allocated for the image by looking at the pixels of an XImage for + img->pixmap. */ + class = FRAME_X_VISUAL (f)->class; + if (class != StaticColor && class != StaticGray && class != TrueColor) + { + XImagePtr ximg; + + BLOCK_INPUT; + + /* Try to get an XImage for img->pixmep. */ + ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap, + 0, 0, img->width, img->height, ~0, ZPixmap); + if (ximg) + { + int x, y; + + /* Initialize the color table. */ + init_color_table (); + + /* For each pixel of the image, look its color up in the + color table. After having done so, the color table will + contain an entry for each color used by the image. */ + for (y = 0; y < img->height; ++y) + for (x = 0; x < img->width; ++x) + { + unsigned long pixel = XGetPixel (ximg, x, y); + lookup_pixel_color (f, pixel); + } + + /* Record colors in the image. Free color table and XImage. */ +#ifdef COLOR_TABLE_SUPPORT + img->colors = colors_in_color_table (&img->ncolors); + free_color_table (); +#endif + XDestroyImage (ximg); + +#if 0 /* This doesn't seem to be the case. If we free the colors + here, we get a BadAccess later in x_clear_image when + freeing the colors. */ + /* We have allocated colors once, but Ghostscript has also + allocated colors on behalf of us. So, to get the + reference counts right, free them once. */ + if (img->ncolors) + x_free_colors (f, img->colors, img->ncolors); +#endif + } + else + image_error ("Cannot get X image of `%s'; colors will not be freed", + img->spec, Qnil); + + UNBLOCK_INPUT; + } +#endif /* HAVE_X_WINDOWS */ + + /* Now that we have the pixmap, compute mask and transform the + image if requested. */ + BLOCK_INPUT; + postprocess_image (f, img); + UNBLOCK_INPUT; +} + +#endif /* HAVE_GHOSTSCRIPT */ + + +/*********************************************************************** + Tests + ***********************************************************************/ + +#if GLYPH_DEBUG + +DEFUN ("imagep", Fimagep, Simagep, 1, 1, 0, + doc: /* Value is non-nil if SPEC is a valid image specification. */) + (spec) + Lisp_Object spec; +{ + return valid_image_p (spec) ? Qt : Qnil; +} + + +DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, "") + (spec) + Lisp_Object spec; +{ + int id = -1; + + if (valid_image_p (spec)) + id = lookup_image (SELECTED_FRAME (), spec); + + debug_print (spec); + return make_number (id); +} + +#endif /* GLYPH_DEBUG != 0 */ + + +/*********************************************************************** + Initialization + ***********************************************************************/ + +void +syms_of_image () +{ + QCascent = intern (":ascent"); + staticpro (&QCascent); + QCmargin = intern (":margin"); + staticpro (&QCmargin); + QCrelief = intern (":relief"); + staticpro (&QCrelief); + QCconversion = intern (":conversion"); + staticpro (&QCconversion); + QCcolor_symbols = intern (":color-symbols"); + staticpro (&QCcolor_symbols); + QCheuristic_mask = intern (":heuristic-mask"); + staticpro (&QCheuristic_mask); + QCindex = intern (":index"); + staticpro (&QCindex); + QCmatrix = intern (":matrix"); + staticpro (&QCmatrix); + QCcolor_adjustment = intern (":color-adjustment"); + staticpro (&QCcolor_adjustment); + QCmask = intern (":mask"); + staticpro (&QCmask); + + Qlaplace = intern ("laplace"); + staticpro (&Qlaplace); + Qemboss = intern ("emboss"); + staticpro (&Qemboss); + Qedge_detection = intern ("edge-detection"); + staticpro (&Qedge_detection); + Qheuristic = intern ("heuristic"); + staticpro (&Qheuristic); + Qcenter = intern ("center"); + staticpro (&Qcenter); + + Qpostscript = intern ("postscript"); + staticpro (&Qpostscript); +#ifdef HAVE_GHOSTSCRIPT + QCloader = intern (":loader"); + staticpro (&QCloader); + QCbounding_box = intern (":bounding-box"); + staticpro (&QCbounding_box); + QCpt_width = intern (":pt-width"); + staticpro (&QCpt_width); + QCpt_height = intern (":pt-height"); + staticpro (&QCpt_height); +#endif /* HAVE_GHOSTSCRIPT */ + + Qpbm = intern ("pbm"); + staticpro (&Qpbm); + + Qxbm = intern ("xbm"); + staticpro (&Qxbm); + +#ifdef HAVE_XPM + Qxpm = intern ("xpm"); + staticpro (&Qxpm); +#endif + +#if defined (HAVE_JPEG) || defined (MAC_OS) + Qjpeg = intern ("jpeg"); + staticpro (&Qjpeg); +#endif + +#if defined (HAVE_TIFF) || defined (MAC_OS) + Qtiff = intern ("tiff"); + staticpro (&Qtiff); +#endif + +#if defined (HAVE_GIF) || defined (MAC_OS) + Qgif = intern ("gif"); + staticpro (&Qgif); +#endif + +#if defined (HAVE_PNG) || defined (MAC_OS) + Qpng = intern ("png"); + staticpro (&Qpng); +#endif + + defsubr (&Sclear_image_cache); + defsubr (&Simage_size); + defsubr (&Simage_mask_p); + +#if GLYPH_DEBUG + defsubr (&Simagep); + defsubr (&Slookup_image); +#endif + + DEFVAR_BOOL ("cross-disabled-images", &cross_disabled_images, + doc: /* Non-nil means always draw a cross over disabled images. +Disabled images are those having an `:conversion disabled' property. +A cross is always drawn on black & white displays. */); + cross_disabled_images = 0; + + DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path, + doc: /* List of directories to search for window system bitmap files. */); + Vx_bitmap_file_path = decode_env_path ((char *) 0, PATH_BITMAPS); + + DEFVAR_LISP ("image-cache-eviction-delay", &Vimage_cache_eviction_delay, + doc: /* Time after which cached images are removed from the cache. +When an image has not been displayed this many seconds, remove it +from the image cache. Value must be an integer or nil with nil +meaning don't clear the cache. */); + Vimage_cache_eviction_delay = make_number (30 * 60); +} + + +#ifdef HAVE_NTGUI +/* Image types that rely on external libraries are loaded dynamically + if the library is available. */ +#define IF_LIB_AVAILABLE(init_lib_fn) if (init_lib_fn()) +#else +#define IF_LIB_AVAILABLE(init_func) /* Load unconditionally */ +#endif /* HAVE_NTGUI */ + +void +init_image () +{ + image_types = NULL; + Vimage_types = Qnil; + + define_image_type (&xbm_type); + define_image_type (&pbm_type); + +#ifdef HAVE_XPM + IF_LIB_AVAILABLE(init_xpm_functions) + define_image_type (&xpm_type); +#endif + +#if defined (HAVE_JPEG) || defined (MAC_OS) + IF_LIB_AVAILABLE(init_jpeg_functions) + define_image_type (&jpeg_type); +#endif + +#if defined (HAVE_TIFF) || defined (MAC_OS) + IF_LIB_AVAILABLE(init_tiff_functions) + define_image_type (&tiff_type); +#endif + +#if defined (HAVE_GIF) || defined (MAC_OS) + IF_LIB_AVAILABLE(init_gif_functions) + define_image_type (&gif_type); +#endif + +#if defined (HAVE_PNG) || defined (MAC_OS) + IF_LIB_AVAILABLE(init_png_functions) + define_image_type (&png_type); +#endif + +#ifdef HAVE_GHOSTSCRIPT + define_image_type (&gs_type); +#endif + +#ifdef MAC_OS + /* Animated gifs use QuickTime Movie Toolbox. So initialize it here. */ + EnterMovies (); +#ifdef MAC_OSX + init_image_func_pointer (); +#endif +#endif +} + +/* arch-tag: 123c2a5e-14a8-4c53-ab95-af47d7db49b9 + (do not change this comment) */
--- a/src/lisp.h Thu Mar 11 02:31:12 2004 +0000 +++ b/src/lisp.h Tue Mar 16 20:27:22 2004 +0000 @@ -2296,6 +2296,10 @@ extern void init_fringe P_ ((void)); extern void init_fringe_once P_ ((void)); +/* Defined in image.c */ +extern void syms_of_image P_ ((void)); +extern void init_image P_ ((void)); + /* Defined in insdel.c */ extern Lisp_Object Qinhibit_modification_hooks; extern void move_gap P_ ((int)); @@ -3068,7 +3072,6 @@ #ifdef HAVE_X_WINDOWS /* Defined in xfns.c */ extern void syms_of_xfns P_ ((void)); -extern void init_xfns P_ ((void)); extern Lisp_Object Vx_resource_name; extern Lisp_Object Vx_resource_class; EXFUN (Fxw_display_color_p, 1);
--- a/src/macfns.c Thu Mar 11 02:31:12 2004 +0000 +++ b/src/macfns.c Tue Mar 16 20:27:22 2004 +0000 @@ -117,10 +117,6 @@ Lisp_Object Vx_no_window_manager; -/* Search path for bitmap files. */ - -Lisp_Object Vx_bitmap_file_path; - /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'. */ Lisp_Object Vx_pixel_size_width_font_regexp; @@ -163,7 +159,6 @@ Lisp_Object Qnone; Lisp_Object Qsuppress_icon; Lisp_Object Qundefined_color; -Lisp_Object Qcenter; Lisp_Object Qcancel_timer; Lisp_Object Qhyper; Lisp_Object Qsuper; @@ -177,21 +172,6 @@ extern int mac_initialized; -/* Functions in macterm.c. */ -extern void x_set_window_size (struct frame *, int, int, int); -extern void x_make_frame_visible (struct frame *); -extern struct mac_display_info *mac_term_init (Lisp_Object, char *, char *); -extern struct font_info *x_get_font_info (FRAME_PTR, int); -extern struct font_info *x_load_font (struct frame *, char *, int); -extern void x_find_ccl_program (struct font_info *); -extern struct font_info *x_query_font (struct frame *, char *); -extern void mac_initialize (); -extern Pixmap XCreatePixmap (Display *, WindowPtr, unsigned int, unsigned int, unsigned int); -extern Pixmap XCreatePixmapFromBitmapData (Display *, WindowPtr, char *, unsigned int, unsigned int, unsigned long, unsigned long, unsigned int); -extern void XFreePixmap (Display *, Pixmap); -extern void XSetForeground (Display *, GC, unsigned long); -extern void mac_draw_line_to_pixmap (Display *, Pixmap, GC, int, int, int, int); - /* compare two strings ignoring case */ @@ -321,303 +301,7 @@ } - -/* Code to deal with bitmaps. Bitmaps are referenced by their bitmap - id, which is just an int that this section returns. Bitmaps are - reference counted so they can be shared among frames. - - Bitmap indices are guaranteed to be > 0, so a negative number can - be used to indicate no bitmap. - - If you use x_create_bitmap_from_data, then you must keep track of - the bitmaps yourself. That is, creating a bitmap from the same - data more than once will not be caught. */ - - -/* Functions to access the contents of a bitmap, given an id. */ - -int -x_bitmap_height (f, id) - FRAME_PTR f; - int id; -{ - return FRAME_MAC_DISPLAY_INFO (f)->bitmaps[id - 1].height; -} - -int -x_bitmap_width (f, id) - FRAME_PTR f; - int id; -{ - return FRAME_MAC_DISPLAY_INFO (f)->bitmaps[id - 1].width; -} - -#if 0 /* MAC_TODO : not used anywhere (?) */ -int -x_bitmap_pixmap (f, id) - FRAME_PTR f; - int id; -{ - return (int) FRAME_MAC_DISPLAY_INFO (f)->bitmaps[id - 1].pixmap; -} -#endif - -/* Allocate a new bitmap record. Returns index of new record. */ - -static int -x_allocate_bitmap_record (f) - FRAME_PTR f; -{ - struct mac_display_info *dpyinfo = FRAME_MAC_DISPLAY_INFO (f); - int i; - - if (dpyinfo->bitmaps == NULL) - { - dpyinfo->bitmaps_size = 10; - dpyinfo->bitmaps = (struct mac_bitmap_record *) - xmalloc (dpyinfo->bitmaps_size * sizeof (struct mac_bitmap_record)); - dpyinfo->bitmaps_last = 1; - return 1; - } - - if (dpyinfo->bitmaps_last < dpyinfo->bitmaps_size) - return ++dpyinfo->bitmaps_last; - - for (i = 0; i < dpyinfo->bitmaps_size; ++i) - if (dpyinfo->bitmaps[i].refcount == 0) - return i + 1; - - dpyinfo->bitmaps_size *= 2; - dpyinfo->bitmaps = (struct mac_bitmap_record *) - xrealloc (dpyinfo->bitmaps, - dpyinfo->bitmaps_size * sizeof (struct mac_bitmap_record)); - return ++dpyinfo->bitmaps_last; -} - -/* Add one reference to the reference count of the bitmap with id - ID. */ - -void -x_reference_bitmap (f, id) - FRAME_PTR f; - int id; -{ - ++FRAME_MAC_DISPLAY_INFO (f)->bitmaps[id - 1].refcount; -} - -/* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at - BITS. */ - -int -x_create_bitmap_from_data (f, bits, width, height) - struct frame *f; - char *bits; - unsigned int width, height; -{ - struct x_display_info *dpyinfo = FRAME_MAC_DISPLAY_INFO (f); - int id; - - /* MAC_TODO: for now fail if width is not mod 16 (toolbox requires it) */ - - id = x_allocate_bitmap_record (f); - - if (width % 16 != 0) - return -1; - - dpyinfo->bitmaps[id - 1].bitmap_data = (char *) xmalloc (height * width); - if (! dpyinfo->bitmaps[id - 1].bitmap_data) - return -1; - - bcopy (bits, dpyinfo->bitmaps[id - 1].bitmap_data, height * width); - - dpyinfo->bitmaps[id - 1].refcount = 1; - dpyinfo->bitmaps[id - 1].height = height; - dpyinfo->bitmaps[id - 1].width = width; - - return id; -} - -/* Create bitmap from file FILE for frame F. */ - -int -x_create_bitmap_from_file (f, file) - struct frame *f; - Lisp_Object file; -{ - return -1; -#if 0 /* MAC_TODO : bitmap support */ - struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f); - unsigned int width, height; - HBITMAP bitmap; - int xhot, yhot, result, id; - Lisp_Object found; - int fd; - char *filename; - HINSTANCE hinst; - - /* Look for an existing bitmap with the same name. */ - for (id = 0; id < dpyinfo->bitmaps_last; ++id) - { - if (dpyinfo->bitmaps[id].refcount - && dpyinfo->bitmaps[id].file - && !strcmp (dpyinfo->bitmaps[id].file, (char *) SDATA (file))) - { - ++dpyinfo->bitmaps[id].refcount; - return id + 1; - } - } - - /* Search bitmap-file-path for the file, if appropriate. */ - fd = openp (Vx_bitmap_file_path, file, "", &found, Qnil); - if (fd < 0) - return -1; - /* LoadLibraryEx won't handle special files handled by Emacs handler. */ - if (fd == 0) - return -1; - emacs_close (fd); - - filename = (char *) SDATA (found); - - hinst = LoadLibraryEx (filename, NULL, LOAD_LIBRARY_AS_DATAFILE); - - if (hinst == NULL) - return -1; - - - result = XReadBitmapFile (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), - filename, &width, &height, &bitmap, &xhot, &yhot); - if (result != BitmapSuccess) - return -1; - - id = x_allocate_bitmap_record (f); - dpyinfo->bitmaps[id - 1].pixmap = bitmap; - dpyinfo->bitmaps[id - 1].refcount = 1; - dpyinfo->bitmaps[id - 1].file = (char *) xmalloc (SCHARS (file) + 1); - dpyinfo->bitmaps[id - 1].depth = 1; - dpyinfo->bitmaps[id - 1].height = height; - dpyinfo->bitmaps[id - 1].width = width; - strcpy (dpyinfo->bitmaps[id - 1].file, SDATA (file)); - - return id; -#endif /* MAC_TODO */ -} - -/* Remove reference to bitmap with id number ID. */ - -void -x_destroy_bitmap (f, id) - FRAME_PTR f; - int id; -{ - struct mac_display_info *dpyinfo = FRAME_MAC_DISPLAY_INFO (f); - - if (id > 0) - { - --dpyinfo->bitmaps[id - 1].refcount; - if (dpyinfo->bitmaps[id - 1].refcount == 0) - { - BLOCK_INPUT; - dpyinfo->bitmaps[id - 1].bitmap_data = NULL; - UNBLOCK_INPUT; - } - } -} - -/* Free all the bitmaps for the display specified by DPYINFO. */ - -static void -x_destroy_all_bitmaps (dpyinfo) - struct mac_display_info *dpyinfo; -{ - int i; - for (i = 0; i < dpyinfo->bitmaps_last; i++) - if (dpyinfo->bitmaps[i].refcount > 0) - xfree (dpyinfo->bitmaps[i].bitmap_data); - dpyinfo->bitmaps_last = 0; -} - - - -/* Mac equivalent of XImage. */ -typedef Pixmap XImagePtr; -#define ZPixmap 0 /* arbitrary */ - -static XImagePtr -XGetImage (display, pixmap, x, y, width, height, plane_mask, format) - Display *display; /* not used */ - Pixmap pixmap; - int x, y; /* not used */ - unsigned int width, height; /* not used */ - unsigned long plane_mask; /* not used */ - int format; /* not used */ -{ -#if GLYPH_DEBUG - xassert (x == 0 && y == 0); - { - Rect ri, rp; - SetRect (&ri, 0, 0, width, height); - xassert (EqualRect (&ri, GetPixBounds (GetGWorldPixMap (pixmap), &rp))); - } - xassert (! (pixelsLocked & GetPixelsState (GetGWorldPixMap (pixmap)))); -#endif - - LockPixels (GetGWorldPixMap (pixmap)); - - return pixmap; -} - -static void -XPutPixel (ximage, x, y, pixel) - XImagePtr ximage; - int x, y; - unsigned long pixel; -{ - RGBColor color; - - SetGWorld (ximage, NULL); - - color.red = RED16_FROM_ULONG (pixel); - color.green = GREEN16_FROM_ULONG (pixel); - color.blue = BLUE16_FROM_ULONG (pixel); - SetCPixel (x, y, &color); -} - -static unsigned long -XGetPixel (ximage, x, y) - XImagePtr ximage; - int x, y; -{ - RGBColor color; - - SetGWorld (ximage, NULL); - - GetCPixel (x, y, &color); - return RGB_TO_ULONG (color.red >> 8, color.green >> 8, color.blue >> 8); -} - -static void -XDestroyImage (ximg) - XImagePtr ximg; -{ - UnlockPixels (GetGWorldPixMap (ximg)); -} - - - -/* Useful functions defined in the section - `Image type independent image structures' below. */ - -static unsigned long four_corners_best P_ ((XImagePtr ximg, unsigned long width, - unsigned long height)); - -static int x_create_x_image_and_pixmap P_ ((struct frame *f, int width, int height, - int depth, XImagePtr *ximg, - Pixmap *pixmap)); - -static void x_destroy_x_image P_ ((XImagePtr ximg)); - static Lisp_Object unwind_create_frame P_ ((Lisp_Object)); -static void x_disable_image P_ ((struct frame *, struct image *)); void x_set_foreground_color P_ ((struct frame *, Lisp_Object, Lisp_Object)); void x_set_background_color P_ ((struct frame *, Lisp_Object, Lisp_Object)); @@ -640,14 +324,6 @@ Lisp_Object, char *, char *, int)); -static void x_edge_detection P_ ((struct frame *, struct image *, Lisp_Object, - Lisp_Object)); -static void init_color_table P_ ((void)); -static void free_color_table P_ ((void)); -static unsigned long *colors_in_color_table P_ ((int *n)); -static unsigned long lookup_rgb_color P_ ((struct frame *f, int r, int g, int b)); -static unsigned long lookup_pixel_color P_ ((struct frame *f, unsigned long p)); - /* Store the screen positions of frame F into XPTR and YPTR. These are the positions of the containing window manager window, not Emacs's own window. */ @@ -3611,5488 +3287,6 @@ return Qnil; } - - -/*********************************************************************** - Image types - ***********************************************************************/ - -/* Value is the number of elements of vector VECTOR. */ - -#define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR)) - -/* List of supported image types. Use define_image_type to add new - types. Use lookup_image_type to find a type for a given symbol. */ - -static struct image_type *image_types; - -/* The symbol `xbm' which is used as the type symbol for XBM images. */ - -Lisp_Object Qxbm; - -/* Keywords. */ - -extern Lisp_Object QCwidth, QCheight, QCforeground, QCbackground, QCfile; -extern Lisp_Object QCdata, QCtype; -Lisp_Object QCascent, QCmargin, QCrelief; -Lisp_Object QCconversion, QCcolor_symbols, QCheuristic_mask; -Lisp_Object QCindex, QCmatrix, QCcolor_adjustment, QCmask; - -/* Other symbols. */ - -Lisp_Object Qlaplace, Qemboss, Qedge_detection, Qheuristic; - -/* Time in seconds after which images should be removed from the cache - if not displayed. */ - -Lisp_Object Vimage_cache_eviction_delay; - -/* Function prototypes. */ - -static void define_image_type P_ ((struct image_type *type)); -static struct image_type *lookup_image_type P_ ((Lisp_Object symbol)); -static void image_error P_ ((char *format, Lisp_Object, Lisp_Object)); -static void x_laplace P_ ((struct frame *, struct image *)); -static void x_emboss P_ ((struct frame *, struct image *)); -static int x_build_heuristic_mask P_ ((struct frame *, struct image *, - Lisp_Object)); - - -/* Define a new image type from TYPE. This adds a copy of TYPE to - image_types and adds the symbol *TYPE->type to Vimage_types. */ - -static void -define_image_type (type) - struct image_type *type; -{ - /* Make a copy of TYPE to avoid a bus error in a dumped Emacs. - The initialized data segment is read-only. */ - struct image_type *p = (struct image_type *) xmalloc (sizeof *p); - bcopy (type, p, sizeof *p); - p->next = image_types; - image_types = p; - Vimage_types = Fcons (*p->type, Vimage_types); -} - - -/* Look up image type SYMBOL, and return a pointer to its image_type - structure. Value is null if SYMBOL is not a known image type. */ - -static INLINE struct image_type * -lookup_image_type (symbol) - Lisp_Object symbol; -{ - struct image_type *type; - - for (type = image_types; type; type = type->next) - if (EQ (symbol, *type->type)) - break; - - return type; -} - - -/* Value is non-zero if OBJECT is a valid Lisp image specification. A - valid image specification is a list whose car is the symbol - `image', and whose rest is a property list. The property list must - contain a value for key `:type'. That value must be the name of a - supported image type. The rest of the property list depends on the - image type. */ - -int -valid_image_p (object) - Lisp_Object object; -{ - int valid_p = 0; - - if (IMAGEP (object)) - { - Lisp_Object tem; - - for (tem = XCDR (object); CONSP (tem); tem = XCDR (tem)) - if (EQ (XCAR (tem), QCtype)) - { - tem = XCDR (tem); - if (CONSP (tem) && SYMBOLP (XCAR (tem))) - { - struct image_type *type; - type = lookup_image_type (XCAR (tem)); - if (type) - valid_p = type->valid_p (object); - } - - break; - } - } - - return valid_p; -} - - -/* Log error message with format string FORMAT and argument ARG. - Signaling an error, e.g. when an image cannot be loaded, is not a - good idea because this would interrupt redisplay, and the error - message display would lead to another redisplay. This function - therefore simply displays a message. */ - -static void -image_error (format, arg1, arg2) - char *format; - Lisp_Object arg1, arg2; -{ - add_to_log (format, arg1, arg2); -} - - - -/*********************************************************************** - Image specifications - ***********************************************************************/ - -enum image_value_type -{ - IMAGE_DONT_CHECK_VALUE_TYPE, - IMAGE_STRING_VALUE, - IMAGE_STRING_OR_NIL_VALUE, - IMAGE_SYMBOL_VALUE, - IMAGE_POSITIVE_INTEGER_VALUE, - IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, - IMAGE_NON_NEGATIVE_INTEGER_VALUE, - IMAGE_ASCENT_VALUE, - IMAGE_INTEGER_VALUE, - IMAGE_FUNCTION_VALUE, - IMAGE_NUMBER_VALUE, - IMAGE_BOOL_VALUE -}; - -/* Structure used when parsing image specifications. */ - -struct image_keyword -{ - /* Name of keyword. */ - char *name; - - /* The type of value allowed. */ - enum image_value_type type; - - /* Non-zero means key must be present. */ - int mandatory_p; - - /* Used to recognize duplicate keywords in a property list. */ - int count; - - /* The value that was found. */ - Lisp_Object value; -}; - - -static int parse_image_spec P_ ((Lisp_Object, struct image_keyword *, - int, Lisp_Object)); -static Lisp_Object image_spec_value P_ ((Lisp_Object, Lisp_Object, int *)); - - -/* Parse image spec SPEC according to KEYWORDS. A valid image spec - has the format (image KEYWORD VALUE ...). One of the keyword/ - value pairs must be `:type TYPE'. KEYWORDS is a vector of - image_keywords structures of size NKEYWORDS describing other - allowed keyword/value pairs. Value is non-zero if SPEC is valid. */ - -static int -parse_image_spec (spec, keywords, nkeywords, type) - Lisp_Object spec; - struct image_keyword *keywords; - int nkeywords; - Lisp_Object type; -{ - int i; - Lisp_Object plist; - - if (!IMAGEP (spec)) - return 0; - - plist = XCDR (spec); - while (CONSP (plist)) - { - Lisp_Object key, value; - - /* First element of a pair must be a symbol. */ - key = XCAR (plist); - plist = XCDR (plist); - if (!SYMBOLP (key)) - return 0; - - /* There must follow a value. */ - if (!CONSP (plist)) - return 0; - value = XCAR (plist); - plist = XCDR (plist); - - /* Find key in KEYWORDS. Error if not found. */ - for (i = 0; i < nkeywords; ++i) - if (strcmp (keywords[i].name, SDATA (SYMBOL_NAME (key))) == 0) - break; - - if (i == nkeywords) - continue; - - /* Record that we recognized the keyword. If a keywords - was found more than once, it's an error. */ - keywords[i].value = value; - ++keywords[i].count; - - if (keywords[i].count > 1) - return 0; - - /* Check type of value against allowed type. */ - switch (keywords[i].type) - { - case IMAGE_STRING_VALUE: - if (!STRINGP (value)) - return 0; - break; - - case IMAGE_STRING_OR_NIL_VALUE: - if (!STRINGP (value) && !NILP (value)) - return 0; - break; - - case IMAGE_SYMBOL_VALUE: - if (!SYMBOLP (value)) - return 0; - break; - - case IMAGE_POSITIVE_INTEGER_VALUE: - if (!INTEGERP (value) || XINT (value) <= 0) - return 0; - break; - - case IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR: - if (INTEGERP (value) && XINT (value) >= 0) - break; - if (CONSP (value) - && INTEGERP (XCAR (value)) && INTEGERP (XCDR (value)) - && XINT (XCAR (value)) >= 0 && XINT (XCDR (value)) >= 0) - break; - return 0; - - case IMAGE_ASCENT_VALUE: - if (SYMBOLP (value) && EQ (value, Qcenter)) - break; - else if (INTEGERP (value) - && XINT (value) >= 0 - && XINT (value) <= 100) - break; - return 0; - - case IMAGE_NON_NEGATIVE_INTEGER_VALUE: - if (!INTEGERP (value) || XINT (value) < 0) - return 0; - break; - - case IMAGE_DONT_CHECK_VALUE_TYPE: - break; - - case IMAGE_FUNCTION_VALUE: - value = indirect_function (value); - if (SUBRP (value) - || COMPILEDP (value) - || (CONSP (value) && EQ (XCAR (value), Qlambda))) - break; - return 0; - - case IMAGE_NUMBER_VALUE: - if (!INTEGERP (value) && !FLOATP (value)) - return 0; - break; - - case IMAGE_INTEGER_VALUE: - if (!INTEGERP (value)) - return 0; - break; - - case IMAGE_BOOL_VALUE: - if (!NILP (value) && !EQ (value, Qt)) - return 0; - break; - - default: - abort (); - break; - } - - if (EQ (key, QCtype) && !EQ (type, value)) - return 0; - } - - /* Check that all mandatory fields are present. */ - for (i = 0; i < nkeywords; ++i) - if (keywords[i].mandatory_p && keywords[i].count == 0) - return 0; - - return NILP (plist); -} - - -/* Return the value of KEY in image specification SPEC. Value is nil - if KEY is not present in SPEC. if FOUND is not null, set *FOUND - to 1 if KEY was found in SPEC, set it to 0 otherwise. */ - -static Lisp_Object -image_spec_value (spec, key, found) - Lisp_Object spec, key; - int *found; -{ - Lisp_Object tail; - - xassert (valid_image_p (spec)); - - for (tail = XCDR (spec); - CONSP (tail) && CONSP (XCDR (tail)); - tail = XCDR (XCDR (tail))) - { - if (EQ (XCAR (tail), key)) - { - if (found) - *found = 1; - return XCAR (XCDR (tail)); - } - } - - if (found) - *found = 0; - return Qnil; -} - - -DEFUN ("image-size", Fimage_size, Simage_size, 1, 3, 0, - doc: /* Return the size of image SPEC as pair (WIDTH . HEIGHT). -PIXELS non-nil means return the size in pixels, otherwise return the -size in canonical character units. -FRAME is the frame on which the image will be displayed. FRAME nil -or omitted means use the selected frame. */) - (spec, pixels, frame) - Lisp_Object spec, pixels, frame; -{ - Lisp_Object size; - - size = Qnil; - if (valid_image_p (spec)) - { - struct frame *f = check_x_frame (frame); - int id = lookup_image (f, spec); - struct image *img = IMAGE_FROM_ID (f, id); - int width = img->width + 2 * img->hmargin; - int height = img->height + 2 * img->vmargin; - - if (NILP (pixels)) - size = Fcons (make_float ((double) width / FRAME_COLUMN_WIDTH (f)), - make_float ((double) height / FRAME_LINE_HEIGHT (f))); - else - size = Fcons (make_number (width), make_number (height)); - } - else - error ("Invalid image specification"); - - return size; -} - - -DEFUN ("image-mask-p", Fimage_mask_p, Simage_mask_p, 1, 2, 0, - doc: /* Return t if image SPEC has a mask bitmap. -FRAME is the frame on which the image will be displayed. FRAME nil -or omitted means use the selected frame. */) - (spec, frame) - Lisp_Object spec, frame; -{ - Lisp_Object mask; - - mask = Qnil; - if (valid_image_p (spec)) - { - struct frame *f = check_x_frame (frame); - int id = lookup_image (f, spec); - struct image *img = IMAGE_FROM_ID (f, id); - if (img->mask) - mask = Qt; - } - else - error ("Invalid image specification"); - - return mask; -} - - - -/*********************************************************************** - Image type independent image structures - ***********************************************************************/ - -static struct image *make_image P_ ((Lisp_Object spec, unsigned hash)); -static void free_image P_ ((struct frame *f, struct image *img)); - - -/* Allocate and return a new image structure for image specification - SPEC. SPEC has a hash value of HASH. */ - -static struct image * -make_image (spec, hash) - Lisp_Object spec; - unsigned hash; -{ - struct image *img = (struct image *) xmalloc (sizeof *img); - - xassert (valid_image_p (spec)); - bzero (img, sizeof *img); - img->type = lookup_image_type (image_spec_value (spec, QCtype, NULL)); - xassert (img->type != NULL); - img->spec = spec; - img->data.lisp_val = Qnil; - img->ascent = DEFAULT_IMAGE_ASCENT; - img->hash = hash; - return img; -} - - -/* Free image IMG which was used on frame F, including its resources. */ - -static void -free_image (f, img) - struct frame *f; - struct image *img; -{ - if (img) - { - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - - /* Remove IMG from the hash table of its cache. */ - if (img->prev) - img->prev->next = img->next; - else - c->buckets[img->hash % IMAGE_CACHE_BUCKETS_SIZE] = img->next; - - if (img->next) - img->next->prev = img->prev; - - c->images[img->id] = NULL; - - /* Free resources, then free IMG. */ - img->type->free (f, img); - xfree (img); - } -} - - -/* Prepare image IMG for display on frame F. Must be called before - drawing an image. */ - -void -prepare_image_for_display (f, img) - struct frame *f; - struct image *img; -{ - EMACS_TIME t; - - /* We're about to display IMG, so set its timestamp to `now'. */ - EMACS_GET_TIME (t); - img->timestamp = EMACS_SECS (t); - - /* If IMG doesn't have a pixmap yet, load it now, using the image - type dependent loader function. */ - if (img->pixmap == 0 && !img->load_failed_p) - img->load_failed_p = img->type->load (f, img) == 0; -} - - -/* Value is the number of pixels for the ascent of image IMG when - drawn in face FACE. */ - -int -image_ascent (img, face) - struct image *img; - struct face *face; -{ - int height = img->height + img->vmargin; - int ascent; - - if (img->ascent == CENTERED_IMAGE_ASCENT) - { - if (face->font) - /* This expression is arranged so that if the image can't be - exactly centered, it will be moved slightly up. This is - because a typical font is `top-heavy' (due to the presence - uppercase letters), so the image placement should err towards - being top-heavy too. It also just generally looks better. */ - ascent = (height + face->font->ascent - face->font->descent + 1) / 2; - else - ascent = height / 2; - } - else - ascent = height * img->ascent / 100.0; - - return ascent; -} - - -/* Image background colors. */ - -static unsigned long -four_corners_best (ximg, width, height) - XImagePtr ximg; - unsigned long width, height; -{ - unsigned long corners[4], best; - int i, best_count; - - /* Get the colors at the corners of ximg. */ - corners[0] = XGetPixel (ximg, 0, 0); - corners[1] = XGetPixel (ximg, width - 1, 0); - corners[2] = XGetPixel (ximg, width - 1, height - 1); - corners[3] = XGetPixel (ximg, 0, height - 1); - - /* Choose the most frequently found color as background. */ - for (i = best_count = 0; i < 4; ++i) - { - int j, n; - - for (j = n = 0; j < 4; ++j) - if (corners[i] == corners[j]) - ++n; - - if (n > best_count) - best = corners[i], best_count = n; - } - - return best; -} - -/* Return the `background' field of IMG. If IMG doesn't have one yet, - it is guessed heuristically. If non-zero, XIMG is an existing XImage - object to use for the heuristic. */ - -unsigned long -image_background (img, f, ximg) - struct image *img; - struct frame *f; - XImagePtr ximg; -{ - if (! img->background_valid) - /* IMG doesn't have a background yet, try to guess a reasonable value. */ - { - int free_ximg = !ximg; - - if (! ximg) - ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap, - 0, 0, img->width, img->height, ~0, ZPixmap); - - img->background = four_corners_best (ximg, img->width, img->height); - - if (free_ximg) - XDestroyImage (ximg); - - img->background_valid = 1; - } - - return img->background; -} - -/* Return the `background_transparent' field of IMG. If IMG doesn't - have one yet, it is guessed heuristically. If non-zero, MASK is an - existing XImage object to use for the heuristic. */ - -int -image_background_transparent (img, f, mask) - struct image *img; - struct frame *f; - XImagePtr mask; -{ - if (! img->background_transparent_valid) - /* IMG doesn't have a background yet, try to guess a reasonable value. */ - { - if (img->mask) - { - int free_mask = !mask; - - if (! mask) - mask = XGetImage (FRAME_X_DISPLAY (f), img->mask, - 0, 0, img->width, img->height, ~0, ZPixmap); - - img->background_transparent - = four_corners_best (mask, img->width, img->height) == PIX_MASK_RETAIN (f); - - if (free_mask) - XDestroyImage (mask); - } - else - img->background_transparent = 0; - - img->background_transparent_valid = 1; - } - - return img->background_transparent; -} - - -/*********************************************************************** - Helper functions for X image types - ***********************************************************************/ - -static void x_clear_image_1 P_ ((struct frame *, struct image *, int, - int, int)); -static void x_clear_image P_ ((struct frame *f, struct image *img)); -static unsigned long x_alloc_image_color P_ ((struct frame *f, - struct image *img, - Lisp_Object color_name, - unsigned long dflt)); - - -/* Clear X resources of image IMG on frame F. PIXMAP_P non-zero means - free the pixmap if any. MASK_P non-zero means clear the mask - pixmap if any. COLORS_P non-zero means free colors allocated for - the image, if any. */ - -static void -x_clear_image_1 (f, img, pixmap_p, mask_p, colors_p) - struct frame *f; - struct image *img; - int pixmap_p, mask_p, colors_p; -{ - if (pixmap_p && img->pixmap) - { - XFreePixmap (FRAME_X_DISPLAY (f), img->pixmap); - img->pixmap = NULL; - img->background_valid = 0; - } - - if (mask_p && img->mask) - { - XFreePixmap (FRAME_X_DISPLAY (f), img->mask); - img->mask = NULL; - img->background_transparent_valid = 0; - } - - if (colors_p && img->ncolors) - { -#if 0 /* TODO: color table support. */ - x_free_colors (f, img->colors, img->ncolors); -#endif - xfree (img->colors); - img->colors = NULL; - img->ncolors = 0; - } -} - -/* Free X resources of image IMG which is used on frame F. */ - -static void -x_clear_image (f, img) - struct frame *f; - struct image *img; -{ - BLOCK_INPUT; - x_clear_image_1 (f, img, 1, 1, 1); - UNBLOCK_INPUT; -} - - -/* Allocate color COLOR_NAME for image IMG on frame F. If color - cannot be allocated, use DFLT. Add a newly allocated color to - IMG->colors, so that it can be freed again. Value is the pixel - color. */ - -static unsigned long -x_alloc_image_color (f, img, color_name, dflt) - struct frame *f; - struct image *img; - Lisp_Object color_name; - unsigned long dflt; -{ - XColor color; - unsigned long result; - - xassert (STRINGP (color_name)); - - if (mac_defined_color (f, SDATA (color_name), &color, 1)) - { - /* This isn't called frequently so we get away with simply - reallocating the color vector to the needed size, here. */ - ++img->ncolors; - img->colors = - (unsigned long *) xrealloc (img->colors, - img->ncolors * sizeof *img->colors); - img->colors[img->ncolors - 1] = color.pixel; - result = color.pixel; - } - else - result = dflt; - - return result; -} - - - -/*********************************************************************** - Image Cache - ***********************************************************************/ - -static void cache_image P_ ((struct frame *f, struct image *img)); -static void postprocess_image P_ ((struct frame *, struct image *)); - - -/* Return a new, initialized image cache that is allocated from the - heap. Call free_image_cache to free an image cache. */ - -struct image_cache * -make_image_cache () -{ - struct image_cache *c = (struct image_cache *) xmalloc (sizeof *c); - int size; - - bzero (c, sizeof *c); - c->size = 50; - c->images = (struct image **) xmalloc (c->size * sizeof *c->images); - size = IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets; - c->buckets = (struct image **) xmalloc (size); - bzero (c->buckets, size); - return c; -} - - -/* Free image cache of frame F. Be aware that X frames share images - caches. */ - -void -free_image_cache (f) - struct frame *f; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - if (c) - { - int i; - - /* Cache should not be referenced by any frame when freed. */ - xassert (c->refcount == 0); - - for (i = 0; i < c->used; ++i) - free_image (f, c->images[i]); - xfree (c->images); - xfree (c->buckets); - xfree (c); - FRAME_X_IMAGE_CACHE (f) = NULL; - } -} - - -/* Clear image cache of frame F. FORCE_P non-zero means free all - images. FORCE_P zero means clear only images that haven't been - displayed for some time. Should be called from time to time to - reduce the number of loaded images. If image-eviction-seconds is - non-nil, this frees images in the cache which weren't displayed for - at least that many seconds. */ - -void -clear_image_cache (f, force_p) - struct frame *f; - int force_p; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - - if (c && INTEGERP (Vimage_cache_eviction_delay)) - { - EMACS_TIME t; - unsigned long old; - int i, nfreed; - - EMACS_GET_TIME (t); - old = EMACS_SECS (t) - XFASTINT (Vimage_cache_eviction_delay); - - /* Block input so that we won't be interrupted by a SIGIO - while being in an inconsistent state. */ - BLOCK_INPUT; - - for (i = nfreed = 0; i < c->used; ++i) - { - struct image *img = c->images[i]; - if (img != NULL - && (force_p || img->timestamp < old)) - { - free_image (f, img); - ++nfreed; - } - } - - /* We may be clearing the image cache because, for example, - Emacs was iconified for a longer period of time. In that - case, current matrices may still contain references to - images freed above. So, clear these matrices. */ - if (nfreed) - { - Lisp_Object tail, frame; - - FOR_EACH_FRAME (tail, frame) - { - struct frame *f = XFRAME (frame); - if (FRAME_MAC_P (f) - && FRAME_X_IMAGE_CACHE (f) == c) - clear_current_matrices (f); - } - - ++windows_or_buffers_changed; - } - - UNBLOCK_INPUT; - } -} - - -DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache, - 0, 1, 0, - doc: /* Clear the image cache of FRAME. -FRAME nil or omitted means use the selected frame. -FRAME t means clear the image caches of all frames. */) - (frame) - Lisp_Object frame; -{ - if (EQ (frame, Qt)) - { - Lisp_Object tail; - - FOR_EACH_FRAME (tail, frame) - if (FRAME_MAC_P (XFRAME (frame))) - clear_image_cache (XFRAME (frame), 1); - } - else - clear_image_cache (check_x_frame (frame), 1); - - return Qnil; -} - - -/* Compute masks and transform image IMG on frame F, as specified - by the image's specification, */ - -static void -postprocess_image (f, img) - struct frame *f; - struct image *img; -{ - /* Manipulation of the image's mask. */ - if (img->pixmap) - { - Lisp_Object conversion, spec; - Lisp_Object mask; - - spec = img->spec; - - /* `:heuristic-mask t' - `:mask heuristic' - means build a mask heuristically. - `:heuristic-mask (R G B)' - `:mask (heuristic (R G B))' - means build a mask from color (R G B) in the - image. - `:mask nil' - means remove a mask, if any. */ - - mask = image_spec_value (spec, QCheuristic_mask, NULL); - if (!NILP (mask)) - x_build_heuristic_mask (f, img, mask); - else - { - int found_p; - - mask = image_spec_value (spec, QCmask, &found_p); - - if (EQ (mask, Qheuristic)) - x_build_heuristic_mask (f, img, Qt); - else if (CONSP (mask) - && EQ (XCAR (mask), Qheuristic)) - { - if (CONSP (XCDR (mask))) - x_build_heuristic_mask (f, img, XCAR (XCDR (mask))); - else - x_build_heuristic_mask (f, img, XCDR (mask)); - } - else if (NILP (mask) && found_p && img->mask) - { - XFreePixmap (FRAME_X_DISPLAY (f), img->mask); - img->mask = NULL; - } - } - - - /* Should we apply an image transformation algorithm? */ - conversion = image_spec_value (spec, QCconversion, NULL); - if (EQ (conversion, Qdisabled)) - x_disable_image (f, img); - else if (EQ (conversion, Qlaplace)) - x_laplace (f, img); - else if (EQ (conversion, Qemboss)) - x_emboss (f, img); - else if (CONSP (conversion) - && EQ (XCAR (conversion), Qedge_detection)) - { - Lisp_Object tem; - tem = XCDR (conversion); - if (CONSP (tem)) - x_edge_detection (f, img, - Fplist_get (tem, QCmatrix), - Fplist_get (tem, QCcolor_adjustment)); - } - } -} - - -/* Return the id of image with Lisp specification SPEC on frame F. - SPEC must be a valid Lisp image specification (see valid_image_p). */ - -int -lookup_image (f, spec) - struct frame *f; - Lisp_Object spec; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - struct image *img; - int i; - unsigned hash; - struct gcpro gcpro1; - EMACS_TIME now; - - /* F must be a window-system frame, and SPEC must be a valid image - specification. */ - xassert (FRAME_WINDOW_P (f)); - xassert (valid_image_p (spec)); - - GCPRO1 (spec); - - /* Look up SPEC in the hash table of the image cache. */ - hash = sxhash (spec, 0); - i = hash % IMAGE_CACHE_BUCKETS_SIZE; - - for (img = c->buckets[i]; img; img = img->next) - if (img->hash == hash && !NILP (Fequal (img->spec, spec))) - break; - - /* If not found, create a new image and cache it. */ - if (img == NULL) - { - extern Lisp_Object Qpostscript; - - BLOCK_INPUT; - img = make_image (spec, hash); - cache_image (f, img); - img->load_failed_p = img->type->load (f, img) == 0; - - /* If we can't load the image, and we don't have a width and - height, use some arbitrary width and height so that we can - draw a rectangle for it. */ - if (img->load_failed_p) - { - Lisp_Object value; - - value = image_spec_value (spec, QCwidth, NULL); - img->width = (INTEGERP (value) - ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH); - value = image_spec_value (spec, QCheight, NULL); - img->height = (INTEGERP (value) - ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT); - } - else - { - /* Handle image type independent image attributes - `:ascent ASCENT', `:margin MARGIN', `:relief RELIEF', - `:background COLOR'. */ - Lisp_Object ascent, margin, relief, bg; - - ascent = image_spec_value (spec, QCascent, NULL); - if (INTEGERP (ascent)) - img->ascent = XFASTINT (ascent); - else if (EQ (ascent, Qcenter)) - img->ascent = CENTERED_IMAGE_ASCENT; - - margin = image_spec_value (spec, QCmargin, NULL); - if (INTEGERP (margin) && XINT (margin) >= 0) - img->vmargin = img->hmargin = XFASTINT (margin); - else if (CONSP (margin) && INTEGERP (XCAR (margin)) - && INTEGERP (XCDR (margin))) - { - if (XINT (XCAR (margin)) > 0) - img->hmargin = XFASTINT (XCAR (margin)); - if (XINT (XCDR (margin)) > 0) - img->vmargin = XFASTINT (XCDR (margin)); - } - - relief = image_spec_value (spec, QCrelief, NULL); - if (INTEGERP (relief)) - { - img->relief = XINT (relief); - img->hmargin += abs (img->relief); - img->vmargin += abs (img->relief); - } - - if (! img->background_valid) - { - bg = image_spec_value (img->spec, QCbackground, NULL); - if (!NILP (bg)) - { - img->background - = x_alloc_image_color (f, img, bg, - FRAME_BACKGROUND_PIXEL (f)); - img->background_valid = 1; - } - } - - /* Do image transformations and compute masks, unless we - don't have the image yet. */ - if (!EQ (*img->type->type, Qpostscript)) - postprocess_image (f, img); - } - - UNBLOCK_INPUT; - } - - /* We're using IMG, so set its timestamp to `now'. */ - EMACS_GET_TIME (now); - img->timestamp = EMACS_SECS (now); - - UNGCPRO; - - /* Value is the image id. */ - return img->id; -} - - -/* Cache image IMG in the image cache of frame F. */ - -static void -cache_image (f, img) - struct frame *f; - struct image *img; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - int i; - - /* Find a free slot in c->images. */ - for (i = 0; i < c->used; ++i) - if (c->images[i] == NULL) - break; - - /* If no free slot found, maybe enlarge c->images. */ - if (i == c->used && c->used == c->size) - { - c->size *= 2; - c->images = (struct image **) xrealloc (c->images, - c->size * sizeof *c->images); - } - - /* Add IMG to c->images, and assign IMG an id. */ - c->images[i] = img; - img->id = i; - if (i == c->used) - ++c->used; - - /* Add IMG to the cache's hash table. */ - i = img->hash % IMAGE_CACHE_BUCKETS_SIZE; - img->next = c->buckets[i]; - if (img->next) - img->next->prev = img; - img->prev = NULL; - c->buckets[i] = img; -} - - -/* Call FN on every image in the image cache of frame F. Used to mark - Lisp Objects in the image cache. */ - -void -forall_images_in_image_cache (f, fn) - struct frame *f; - void (*fn) P_ ((struct image *img)); -{ - if (FRAME_LIVE_P (f) && FRAME_MAC_P (f)) - { - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - if (c) - { - int i; - for (i = 0; i < c->used; ++i) - if (c->images[i]) - fn (c->images[i]); - } - } -} - - - -/*********************************************************************** - Mac support code - ***********************************************************************/ - -static int x_create_x_image_and_pixmap P_ ((struct frame *, int, int, int, - XImagePtr *, Pixmap *)); -static void x_destroy_x_image P_ ((XImagePtr)); -static void x_put_x_image P_ ((struct frame *, XImagePtr, Pixmap, int, int)); - - -x_create_x_image_and_pixmap (f, width, height, depth, ximg, pixmap) - struct frame *f; - int width, height, depth; - XImagePtr *ximg; - Pixmap *pixmap; -{ - Display *display = FRAME_MAC_DISPLAY (f); - Window window = FRAME_MAC_WINDOW (f); - - xassert (interrupt_input_blocked); - - /* Allocate a pixmap of the same size. */ - *pixmap = XCreatePixmap (display, window, width, height, depth); - if (*pixmap == 0) - { - x_destroy_x_image (*ximg); - *ximg = NULL; - image_error ("Unable to create X pixmap", Qnil, Qnil); - return 0; - } - - LockPixels (GetGWorldPixMap (*pixmap)); - *ximg = *pixmap; - return 1; -} - -static void -x_destroy_x_image (ximg) - XImagePtr ximg; -{ - xassert (interrupt_input_blocked); - if (ximg) - XDestroyImage (ximg); -} - -static void -x_put_x_image (f, ximg, pixmap, width, height) - struct frame *f; - XImagePtr ximg; - Pixmap pixmap; -{ - xassert (ximg == pixmap); -} - - - -/*********************************************************************** - File Handling - ***********************************************************************/ - -static Lisp_Object x_find_image_file P_ ((Lisp_Object)); -static char *slurp_file P_ ((char *, int *)); - - -/* Find image file FILE. Look in data-directory, then - x-bitmap-file-path. Value is the full name of the file found, or - nil if not found. */ - -static Lisp_Object -x_find_image_file (file) - Lisp_Object file; -{ - Lisp_Object file_found, search_path; - struct gcpro gcpro1, gcpro2; - int fd; - - file_found = Qnil; - search_path = Fcons (Vdata_directory, Vx_bitmap_file_path); - GCPRO2 (file_found, search_path); - - /* Try to find FILE in data-directory, then x-bitmap-file-path. */ - fd = openp (search_path, file, Qnil, &file_found, Qnil); - - if (fd == -1) - file_found = Qnil; - else - close (fd); - - UNGCPRO; - return file_found; -} - - -/* Read FILE into memory. Value is a pointer to a buffer allocated - with xmalloc holding FILE's contents. Value is null if an error - occurred. *SIZE is set to the size of the file. */ - -static char * -slurp_file (file, size) - char *file; - int *size; -{ - FILE *fp = NULL; - char *buf = NULL; - struct stat st; - - if (stat (file, &st) == 0 - && (fp = fopen (file, "r")) != NULL - && (buf = (char *) xmalloc (st.st_size), - fread (buf, 1, st.st_size, fp) == st.st_size)) - { - *size = st.st_size; - fclose (fp); - } - else - { - if (fp) - fclose (fp); - if (buf) - { - xfree (buf); - buf = NULL; - } - } - - return buf; -} - - - -/*********************************************************************** - Image Load Functions - ***********************************************************************/ - -static int image_load_quicktime P_ ((struct frame *, struct image *img, - OSType)); -#ifdef MAC_OSX -static int image_load_quartz2d P_ ((struct frame *, struct image *img, int)); -#endif - - -static OSErr -find_image_fsspec (specified_file, file, fss) - Lisp_Object specified_file, *file; - FSSpec *fss; -{ -#if TARGET_API_MAC_CARBON - FSRef fsr; -#else - Str255 mac_pathname; -#endif - OSErr err; - - *file = x_find_image_file (specified_file); - if (!STRINGP (*file)) - return fnfErr; /* file or directory not found; - incomplete pathname */ - /* Try to open the image file. */ -#if TARGET_API_MAC_CARBON - err = FSPathMakeRef (SDATA (*file), &fsr, NULL); - if (err == noErr) - err = FSGetCatalogInfo (&fsr, kFSCatInfoNone, NULL, NULL, fss, NULL); -#else - if (posix_to_mac_pathname (SDATA (*file), mac_pathname, MAXPATHLEN+1) == 0) - return fnfErr; - c2pstr (mac_pathname); - err = FSMakeFSSpec (0, 0, mac_pathname, fss); -#endif - return err; -} - - -static int -image_load_qt_1 (f, img, type, fss, dh) - struct frame *f; - struct image *img; - OSType type; - FSSpec *fss; - Handle dh; -{ - OSErr err; - GraphicsImportComponent gi; - Rect rect; - int width, height; - short draw_all_pixels; - Lisp_Object specified_bg; - XColor color; - XImagePtr ximg; - RGBColor bg_color; - - err = OpenADefaultComponent (GraphicsImporterComponentType, - type, &gi); - if (err != noErr) - { - image_error ("Cannot get importer component for `%s'", img->spec, Qnil); - return 0; - } - if (dh == NULL) - { - /* read from file system spec */ - err = GraphicsImportSetDataFile (gi, fss); - if (err != noErr) - { - image_error ("Cannot set fsspec to graphics importer for '%s'", - img->spec, Qnil); - goto error; - } - } - else - { - /* read from data handle */ - err = GraphicsImportSetDataHandle (gi, dh); - if (err != noErr) - { - image_error ("Cannot set data handle to graphics importer for `%s'", - img->spec, Qnil); - goto error; - } - } - err = GraphicsImportGetNaturalBounds (gi, &rect); - if (err != noErr) - { - image_error ("Error reading `%s'", img->spec, Qnil); - goto error; - } - width = img->width = rect.right - rect.left; - height = img->height = rect.bottom - rect.top; - err = GraphicsImportDoesDrawAllPixels (gi, &draw_all_pixels); -#if 0 - /* Don't check the error code here. It may have an undocumented - value -32766. */ - if (err != noErr) - { - image_error ("Error reading `%s'", img->spec, Qnil); - goto error; - } -#endif - if (draw_all_pixels != graphicsImporterDrawsAllPixels) - { - specified_bg = image_spec_value (img->spec, QCbackground, NULL); - if (!STRINGP (specified_bg) || - !mac_defined_color (f, SDATA (specified_bg), &color, 0)) - { - color.pixel = FRAME_BACKGROUND_PIXEL (f); - color.red = RED16_FROM_ULONG (color.pixel); - color.green = GREEN16_FROM_ULONG (color.pixel); - color.blue = BLUE16_FROM_ULONG (color.pixel); - } - } - - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - goto error; - if (draw_all_pixels != graphicsImporterDrawsAllPixels) - { - SetGWorld (ximg, NULL); - bg_color.red = color.red; - bg_color.green = color.green; - bg_color.blue = color.blue; - RGBBackColor (&bg_color); -#if TARGET_API_MAC_CARBON - GetPortBounds (ximg, &rect); - EraseRect (&rect); -#else - EraseRect (&(ximg->portRect)); -#endif - } - GraphicsImportSetGWorld (gi, ximg, NULL); - GraphicsImportDraw (gi); - CloseComponent (gi); - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - return 1; - - error: - CloseComponent (gi); - return 0; -} - - -/* Load an image using the QuickTime Graphics Importer. - Note: The alpha channel does not work for PNG images. */ -static int -image_load_quicktime (f, img, type) - struct frame *f; - struct image *img; - OSType type; -{ - Lisp_Object specified_file; - Lisp_Object specified_data; - OSErr err; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - - if (NILP (specified_data)) - { - /* Read from a file */ - Lisp_Object file; - FSSpec fss; - - err = find_image_fsspec (specified_file, &file, &fss); - if (err != noErr) - { - if (err == fnfErr) - image_error ("Cannot find image file `%s'", specified_file, Qnil); - else - image_error ("Cannot open `%s'", file, Qnil); - return 0; - } - return image_load_qt_1 (f, img, type, &fss, NULL); - } - else - { - /* Memory source! */ - int success_p; - Handle dh; - - err = PtrToHand (SDATA (specified_data), &dh, SBYTES (specified_data)); - if (err != noErr) - { - image_error ("Cannot allocate data handle for `%s'", - img->spec, Qnil); - return 0; - } - success_p = image_load_qt_1 (f, img, type, NULL, dh); - DisposeHandle (dh); - return success_p; - } -} - - -#ifdef MAC_OSX -/* Load a PNG/JPEG image using Quartz 2D decoding routines. - CGImageCreateWithPNGDataProvider is provided after Mac OS X 10.2. - So don't use this function directly but determine at runtime - whether it exists. */ -typedef CGImageRef (*CGImageCreateWithPNGDataProviderProcType) - (CGDataProviderRef, const float [], bool, CGColorRenderingIntent); -static CGImageCreateWithPNGDataProviderProcType MyCGImageCreateWithPNGDataProvider; - - -static void -init_image_func_pointer () -{ - if (NSIsSymbolNameDefined ("_CGImageCreateWithPNGDataProvider")) - { - MyCGImageCreateWithPNGDataProvider - = (CGImageCreateWithPNGDataProviderProcType) - NSAddressOfSymbol (NSLookupAndBindSymbol - ("_CGImageCreateWithPNGDataProvider")); - } - else - MyCGImageCreateWithPNGDataProvider = NULL; -} - - -static int -image_load_quartz2d (f, img, png_p) - struct frame *f; - struct image *img; - int png_p; -{ - Lisp_Object file, specified_file; - Lisp_Object specified_data, specified_bg; - struct gcpro gcpro1; - CGDataProviderRef source; - CGImageRef image; - int width, height; - XColor color; - XImagePtr ximg = NULL; - CGContextRef context; - CGRect rectangle; - - /* Open the file. */ - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - - file = Qnil; - GCPRO1 (file); - - if (NILP (specified_data)) - { - CFStringRef path; - CFURLRef url; - - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - path = CFStringCreateWithCString (NULL, SDATA (file), - kCFStringEncodingUTF8); - url = CFURLCreateWithFileSystemPath (NULL, path, - kCFURLPOSIXPathStyle, 0); - CFRelease (path); - source = CGDataProviderCreateWithURL (url); - CFRelease (url); - } - else - source = CGDataProviderCreateWithData (NULL, SDATA (specified_data), - SBYTES (specified_data), NULL); - - if (png_p) - image = (*MyCGImageCreateWithPNGDataProvider) (source, NULL, FALSE, - kCGRenderingIntentDefault); - else - image = CGImageCreateWithJPEGDataProvider (source, NULL, FALSE, - kCGRenderingIntentDefault); - - CGDataProviderRelease (source); - if (image == NULL) - { - UNGCPRO; - image_error ("Error reading image `%s'", img->spec, Qnil); - return 0; - } - - if (png_p) - { - specified_bg = image_spec_value (img->spec, QCbackground, NULL); - if (!STRINGP (specified_bg) || - !mac_defined_color (f, SDATA (specified_bg), &color, 0)) - { - color.pixel = FRAME_BACKGROUND_PIXEL (f); - color.red = RED16_FROM_ULONG (color.pixel); - color.green = GREEN16_FROM_ULONG (color.pixel); - color.blue = BLUE16_FROM_ULONG (color.pixel); - } - } - width = img->width = CGImageGetWidth (image); - height = img->height = CGImageGetHeight (image); - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - { - CGImageRelease (image); - UNGCPRO; - return 0; - } - rectangle = CGRectMake (0, 0, width, height); - QDBeginCGContext (ximg, &context); - if (png_p) - { - CGContextSetRGBFillColor (context, color.red / 65535.0, - color.green / 65535.0, - color.blue / 65535.0, 1.0); - CGContextFillRect (context, rectangle); - } - CGContextDrawImage (context, rectangle, image); - QDEndCGContext (ximg, &context); - CGImageRelease (image); - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - UNGCPRO; - return 1; -} -#endif - - - -/*********************************************************************** - XBM images - ***********************************************************************/ - -static int xbm_scan P_ ((char **, char *, char *, int *)); -static int xbm_load P_ ((struct frame *f, struct image *img)); -static int xbm_load_image P_ ((struct frame *f, struct image *img, - char *, char *)); -static int xbm_image_p P_ ((Lisp_Object object)); -static int xbm_read_bitmap_data P_ ((char *, char *, int *, int *, - unsigned char **)); -static int xbm_file_p P_ ((Lisp_Object)); - - -/* Indices of image specification fields in xbm_format, below. */ - -enum xbm_keyword_index -{ - XBM_TYPE, - XBM_FILE, - XBM_WIDTH, - XBM_HEIGHT, - XBM_DATA, - XBM_FOREGROUND, - XBM_BACKGROUND, - XBM_ASCENT, - XBM_MARGIN, - XBM_RELIEF, - XBM_ALGORITHM, - XBM_HEURISTIC_MASK, - XBM_MASK, - XBM_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid XBM image specifications. */ - -static struct image_keyword xbm_format[XBM_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 0}, - {":width", IMAGE_POSITIVE_INTEGER_VALUE, 0}, - {":height", IMAGE_POSITIVE_INTEGER_VALUE, 0}, - {":data", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0} -}; - -/* Structure describing the image type XBM. */ - -static struct image_type xbm_type = -{ - &Qxbm, - xbm_image_p, - xbm_load, - x_clear_image, - NULL -}; - -/* Tokens returned from xbm_scan. */ - -enum xbm_token -{ - XBM_TK_IDENT = 256, - XBM_TK_NUMBER -}; - - -/* Return non-zero if OBJECT is a valid XBM-type image specification. - A valid specification is a list starting with the symbol `image' - The rest of the list is a property list which must contain an - entry `:type xbm.. - - If the specification specifies a file to load, it must contain - an entry `:file FILENAME' where FILENAME is a string. - - If the specification is for a bitmap loaded from memory it must - contain `:width WIDTH', `:height HEIGHT', and `:data DATA', where - WIDTH and HEIGHT are integers > 0. DATA may be: - - 1. a string large enough to hold the bitmap data, i.e. it must - have a size >= (WIDTH + 7) / 8 * HEIGHT - - 2. a bool-vector of size >= WIDTH * HEIGHT - - 3. a vector of strings or bool-vectors, one for each line of the - bitmap. - - 4. A string containing an in-memory XBM file. WIDTH and HEIGHT - may not be specified in this case because they are defined in the - XBM file. - - Both the file and data forms may contain the additional entries - `:background COLOR' and `:foreground COLOR'. If not present, - foreground and background of the frame on which the image is - displayed is used. */ - -static int -xbm_image_p (object) - Lisp_Object object; -{ - struct image_keyword kw[XBM_LAST]; - - bcopy (xbm_format, kw, sizeof kw); - if (!parse_image_spec (object, kw, XBM_LAST, Qxbm)) - return 0; - - xassert (EQ (kw[XBM_TYPE].value, Qxbm)); - - if (kw[XBM_FILE].count) - { - if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_DATA].count) - return 0; - } - else if (kw[XBM_DATA].count && xbm_file_p (kw[XBM_DATA].value)) - { - /* In-memory XBM file. */ - if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_FILE].count) - return 0; - } - else - { - Lisp_Object data; - int width, height; - - /* Entries for `:width', `:height' and `:data' must be present. */ - if (!kw[XBM_WIDTH].count - || !kw[XBM_HEIGHT].count - || !kw[XBM_DATA].count) - return 0; - - data = kw[XBM_DATA].value; - width = XFASTINT (kw[XBM_WIDTH].value); - height = XFASTINT (kw[XBM_HEIGHT].value); - - /* Check type of data, and width and height against contents of - data. */ - if (VECTORP (data)) - { - int i; - - /* Number of elements of the vector must be >= height. */ - if (XVECTOR (data)->size < height) - return 0; - - /* Each string or bool-vector in data must be large enough - for one line of the image. */ - for (i = 0; i < height; ++i) - { - Lisp_Object elt = XVECTOR (data)->contents[i]; - - if (STRINGP (elt)) - { - if (SCHARS (elt) - < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR) - return 0; - } - else if (BOOL_VECTOR_P (elt)) - { - if (XBOOL_VECTOR (elt)->size < width) - return 0; - } - else - return 0; - } - } - else if (STRINGP (data)) - { - if (SCHARS (data) - < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height) - return 0; - } - else if (BOOL_VECTOR_P (data)) - { - if (XBOOL_VECTOR (data)->size < width * height) - return 0; - } - else - return 0; - } - - return 1; -} - - -/* Scan a bitmap file. FP is the stream to read from. Value is - either an enumerator from enum xbm_token, or a character for a - single-character token, or 0 at end of file. If scanning an - identifier, store the lexeme of the identifier in SVAL. If - scanning a number, store its value in *IVAL. */ - -static int -xbm_scan (s, end, sval, ival) - char **s, *end; - char *sval; - int *ival; -{ - int c; - - loop: - - /* Skip white space. */ - while (*s < end && (c = *(*s)++, isspace (c))) - ; - - if (*s >= end) - c = 0; - else if (isdigit (c)) - { - int value = 0, digit; - - if (c == '0' && *s < end) - { - c = *(*s)++; - if (c == 'x' || c == 'X') - { - while (*s < end) - { - c = *(*s)++; - if (isdigit (c)) - digit = c - '0'; - else if (c >= 'a' && c <= 'f') - digit = c - 'a' + 10; - else if (c >= 'A' && c <= 'F') - digit = c - 'A' + 10; - else - break; - value = 16 * value + digit; - } - } - else if (isdigit (c)) - { - value = c - '0'; - while (*s < end - && (c = *(*s)++, isdigit (c))) - value = 8 * value + c - '0'; - } - } - else - { - value = c - '0'; - while (*s < end - && (c = *(*s)++, isdigit (c))) - value = 10 * value + c - '0'; - } - - if (*s < end) - *s = *s - 1; - *ival = value; - c = XBM_TK_NUMBER; - } - else if (isalpha (c) || c == '_') - { - *sval++ = c; - while (*s < end - && (c = *(*s)++, (isalnum (c) || c == '_'))) - *sval++ = c; - *sval = 0; - if (*s < end) - *s = *s - 1; - c = XBM_TK_IDENT; - } - else if (c == '/' && **s == '*') - { - /* C-style comment. */ - ++*s; - while (**s && (**s != '*' || *(*s + 1) != '/')) - ++*s; - if (**s) - { - *s += 2; - goto loop; - } - } - - return c; -} - - -/* Replacement for XReadBitmapFileData which isn't available under old - X versions. CONTENTS is a pointer to a buffer to parse; END is the - buffer's end. Set *WIDTH and *HEIGHT to the width and height of - the image. Return in *DATA the bitmap data allocated with xmalloc. - Value is non-zero if successful. DATA null means just test if - CONTENTS looks like an in-memory XBM file. */ - -static int -xbm_read_bitmap_data (contents, end, width, height, data) - char *contents, *end; - int *width, *height; - unsigned char **data; -{ - char *s = contents; - char buffer[BUFSIZ]; - int padding_p = 0; - int v10 = 0; - int bytes_per_line, i, nbytes; - unsigned char *p; - int value; - int LA1; - -#define match() \ - LA1 = xbm_scan (&s, end, buffer, &value) - -#define expect(TOKEN) \ - if (LA1 != (TOKEN)) \ - goto failure; \ - else \ - match () - -#define expect_ident(IDENT) \ - if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \ - match (); \ - else \ - goto failure - - *width = *height = -1; - if (data) - *data = NULL; - LA1 = xbm_scan (&s, end, buffer, &value); - - /* Parse defines for width, height and hot-spots. */ - while (LA1 == '#') - { - match (); - expect_ident ("define"); - expect (XBM_TK_IDENT); - - if (LA1 == XBM_TK_NUMBER); - { - char *p = strrchr (buffer, '_'); - p = p ? p + 1 : buffer; - if (strcmp (p, "width") == 0) - *width = value; - else if (strcmp (p, "height") == 0) - *height = value; - } - expect (XBM_TK_NUMBER); - } - - if (*width < 0 || *height < 0) - goto failure; - else if (data == NULL) - goto success; - - /* Parse bits. Must start with `static'. */ - expect_ident ("static"); - if (LA1 == XBM_TK_IDENT) - { - if (strcmp (buffer, "unsigned") == 0) - { - match (); - expect_ident ("char"); - } - else if (strcmp (buffer, "short") == 0) - { - match (); - v10 = 1; - if (*width % 16 && *width % 16 < 9) - padding_p = 1; - } - else if (strcmp (buffer, "char") == 0) - match (); - else - goto failure; - } - else - goto failure; - - expect (XBM_TK_IDENT); - expect ('['); - expect (']'); - expect ('='); - expect ('{'); - - bytes_per_line = (*width + 7) / 8 + padding_p; - nbytes = bytes_per_line * *height; - p = *data = (char *) xmalloc (nbytes); - - if (v10) - { - for (i = 0; i < nbytes; i += 2) - { - int val = value; - expect (XBM_TK_NUMBER); - - *p++ = val; - if (!padding_p || ((i + 2) % bytes_per_line)) - *p++ = value >> 8; - - if (LA1 == ',' || LA1 == '}') - match (); - else - goto failure; - } - } - else - { - for (i = 0; i < nbytes; ++i) - { - int val = value; - expect (XBM_TK_NUMBER); - - *p++ = val; - - if (LA1 == ',' || LA1 == '}') - match (); - else - goto failure; - } - } - - success: - return 1; - - failure: - - if (data && *data) - { - xfree (*data); - *data = NULL; - } - return 0; - -#undef match -#undef expect -#undef expect_ident -} - - -/* Load XBM image IMG which will be displayed on frame F from buffer - CONTENTS. END is the end of the buffer. Value is non-zero if - successful. */ - -static int -xbm_load_image (f, img, contents, end) - struct frame *f; - struct image *img; - char *contents, *end; -{ - int rc; - unsigned char *data; - int success_p = 0; - - rc = xbm_read_bitmap_data (contents, end, &img->width, &img->height, &data); - if (rc) - { - int depth = one_mac_display_info.n_planes; - unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); - unsigned long background = FRAME_BACKGROUND_PIXEL (f); - Lisp_Object value; - - xassert (img->width > 0 && img->height > 0); - - /* Get foreground and background colors, maybe allocate colors. */ - value = image_spec_value (img->spec, QCforeground, NULL); - if (!NILP (value)) - foreground = x_alloc_image_color (f, img, value, foreground); - value = image_spec_value (img->spec, QCbackground, NULL); - if (!NILP (value)) - { - background = x_alloc_image_color (f, img, value, background); - img->background = background; - img->background_valid = 1; - } - - img->pixmap - = XCreatePixmapFromBitmapData (FRAME_MAC_DISPLAY (f), - FRAME_MAC_WINDOW (f), - data, - img->width, img->height, - foreground, background, - depth); - xfree (data); - - if (img->pixmap == 0) - { - x_clear_image (f, img); - image_error ("Unable to create X pixmap for `%s'", img->spec, Qnil); - } - else - success_p = 1; - } - else - image_error ("Error loading XBM image `%s'", img->spec, Qnil); - - return success_p; -} - - -/* Value is non-zero if DATA looks like an in-memory XBM file. */ - -static int -xbm_file_p (data) - Lisp_Object data; -{ - int w, h; - return (STRINGP (data) - && xbm_read_bitmap_data (SDATA (data), - (SDATA (data) - + SBYTES (data)), - &w, &h, NULL)); -} - - -/* Fill image IMG which is used on frame F with pixmap data. Value is - non-zero if successful. */ - -static int -xbm_load (f, img) - struct frame *f; - struct image *img; -{ - int success_p = 0; - Lisp_Object file_name; - - xassert (xbm_image_p (img->spec)); - - /* If IMG->spec specifies a file name, create a non-file spec from it. */ - file_name = image_spec_value (img->spec, QCfile, NULL); - if (STRINGP (file_name)) - { - Lisp_Object file; - char *contents; - int size; - struct gcpro gcpro1; - - file = x_find_image_file (file_name); - GCPRO1 (file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", file_name, Qnil); - UNGCPRO; - return 0; - } - - contents = slurp_file (SDATA (file), &size); - if (contents == NULL) - { - image_error ("Error loading XBM image `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - - success_p = xbm_load_image (f, img, contents, contents + size); - UNGCPRO; - } - else - { - struct image_keyword fmt[XBM_LAST]; - Lisp_Object data; - int depth; - unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); - unsigned long background = FRAME_BACKGROUND_PIXEL (f); - char *bits; - int parsed_p; - int in_memory_file_p = 0; - - /* See if data looks like an in-memory XBM file. */ - data = image_spec_value (img->spec, QCdata, NULL); - in_memory_file_p = xbm_file_p (data); - - /* Parse the image specification. */ - bcopy (xbm_format, fmt, sizeof fmt); - parsed_p = parse_image_spec (img->spec, fmt, XBM_LAST, Qxbm); - xassert (parsed_p); - - /* Get specified width, and height. */ - if (!in_memory_file_p) - { - img->width = XFASTINT (fmt[XBM_WIDTH].value); - img->height = XFASTINT (fmt[XBM_HEIGHT].value); - xassert (img->width > 0 && img->height > 0); - } - - /* Get foreground and background colors, maybe allocate colors. */ - if (fmt[XBM_FOREGROUND].count - && STRINGP (fmt[XBM_FOREGROUND].value)) - foreground = x_alloc_image_color (f, img, fmt[XBM_FOREGROUND].value, - foreground); - if (fmt[XBM_BACKGROUND].count - && STRINGP (fmt[XBM_BACKGROUND].value)) - background = x_alloc_image_color (f, img, fmt[XBM_BACKGROUND].value, - background); - - if (in_memory_file_p) - success_p = xbm_load_image (f, img, SDATA (data), - (SDATA (data) - + SBYTES (data))); - else - { - if (VECTORP (data)) - { - int i; - char *p; - int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR; - - p = bits = (char *) alloca (nbytes * img->height); - for (i = 0; i < img->height; ++i, p += nbytes) - { - Lisp_Object line = XVECTOR (data)->contents[i]; - if (STRINGP (line)) - bcopy (SDATA (line), p, nbytes); - else - bcopy (XBOOL_VECTOR (line)->data, p, nbytes); - } - } - else if (STRINGP (data)) - bits = SDATA (data); - else - bits = XBOOL_VECTOR (data)->data; - - /* Create the pixmap. */ - depth = one_mac_display_info.n_planes; - img->pixmap - = XCreatePixmapFromBitmapData (FRAME_MAC_DISPLAY (f), - FRAME_MAC_WINDOW (f), - bits, - img->width, img->height, - foreground, background, - depth); - if (img->pixmap) - success_p = 1; - else - { - image_error ("Unable to create pixmap for XBM image `%s'", - img->spec, Qnil); - x_clear_image (f, img); - } - } - } - - return success_p; -} - - - -/*********************************************************************** - XPM images - ***********************************************************************/ - -#if HAVE_XPM - -static int xpm_image_p P_ ((Lisp_Object object)); -static int xpm_load P_ ((struct frame *f, struct image *img)); -static int xpm_valid_color_symbols_p P_ ((Lisp_Object)); - -#include "X11/xpm.h" - -/* The symbol `xpm' identifying XPM-format images. */ - -Lisp_Object Qxpm; - -/* Indices of image specification fields in xpm_format, below. */ - -enum xpm_keyword_index -{ - XPM_TYPE, - XPM_FILE, - XPM_DATA, - XPM_ASCENT, - XPM_MARGIN, - XPM_RELIEF, - XPM_ALGORITHM, - XPM_HEURISTIC_MASK, - XPM_MASK, - XPM_COLOR_SYMBOLS, - XPM_BACKGROUND, - XPM_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid XPM image specifications. */ - -static struct image_keyword xpm_format[XPM_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 0}, - {":data", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type XBM. */ - -static struct image_type xpm_type = -{ - &Qxpm, - xpm_image_p, - xpm_load, - x_clear_image, - NULL -}; - - -/* Value is non-zero if COLOR_SYMBOLS is a valid color symbols list - for XPM images. Such a list must consist of conses whose car and - cdr are strings. */ - -static int -xpm_valid_color_symbols_p (color_symbols) - Lisp_Object color_symbols; -{ - while (CONSP (color_symbols)) - { - Lisp_Object sym = XCAR (color_symbols); - if (!CONSP (sym) - || !STRINGP (XCAR (sym)) - || !STRINGP (XCDR (sym))) - break; - color_symbols = XCDR (color_symbols); - } - - return NILP (color_symbols); -} - - -/* Value is non-zero if OBJECT is a valid XPM image specification. */ - -static int -xpm_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[XPM_LAST]; - bcopy (xpm_format, fmt, sizeof fmt); - return (parse_image_spec (object, fmt, XPM_LAST, Qxpm) - /* Either `:file' or `:data' must be present. */ - && fmt[XPM_FILE].count + fmt[XPM_DATA].count == 1 - /* Either no `:color-symbols' or it's a list of conses - whose car and cdr are strings. */ - && (fmt[XPM_COLOR_SYMBOLS].count == 0 - || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value))); -} - - -/* Load image IMG which will be displayed on frame F. Value is - non-zero if successful. */ - -static int -xpm_load (f, img) - struct frame *f; - struct image *img; -{ - int rc; - XpmAttributes attrs; - Lisp_Object specified_file, color_symbols; - - /* Configure the XPM lib. Use the visual of frame F. Allocate - close colors. Return colors allocated. */ - bzero (&attrs, sizeof attrs); - attrs.visual = FRAME_X_VISUAL (f); - attrs.colormap = FRAME_X_COLORMAP (f); - attrs.valuemask |= XpmVisual; - attrs.valuemask |= XpmColormap; - attrs.valuemask |= XpmReturnAllocPixels; -#ifdef XpmAllocCloseColors - attrs.alloc_close_colors = 1; - attrs.valuemask |= XpmAllocCloseColors; -#else /* not XpmAllocCloseColors */ - attrs.closeness = 600; - attrs.valuemask |= XpmCloseness; -#endif /* not XpmAllocCloseColors */ - - /* If image specification contains symbolic color definitions, add - these to `attrs'. */ - color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL); - if (CONSP (color_symbols)) - { - Lisp_Object tail; - XpmColorSymbol *xpm_syms; - int i, size; - - attrs.valuemask |= XpmColorSymbols; - - /* Count number of symbols. */ - attrs.numsymbols = 0; - for (tail = color_symbols; CONSP (tail); tail = XCDR (tail)) - ++attrs.numsymbols; - - /* Allocate an XpmColorSymbol array. */ - size = attrs.numsymbols * sizeof *xpm_syms; - xpm_syms = (XpmColorSymbol *) alloca (size); - bzero (xpm_syms, size); - attrs.colorsymbols = xpm_syms; - - /* Fill the color symbol array. */ - for (tail = color_symbols, i = 0; - CONSP (tail); - ++i, tail = XCDR (tail)) - { - Lisp_Object name = XCAR (XCAR (tail)); - Lisp_Object color = XCDR (XCAR (tail)); - xpm_syms[i].name = (char *) alloca (SCHARS (name) + 1); - strcpy (xpm_syms[i].name, SDATA (name)); - xpm_syms[i].value = (char *) alloca (SCHARS (color) + 1); - strcpy (xpm_syms[i].value, SDATA (color)); - } - } - - /* Create a pixmap for the image, either from a file, or from a - string buffer containing data in the same format as an XPM file. */ - - specified_file = image_spec_value (img->spec, QCfile, NULL); - if (STRINGP (specified_file)) - { - Lisp_Object file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - return 0; - } - - rc = XpmReadFileToPixmap (FRAME_MAC_DISPLAY (f), FRAME_MAC_WINDOW (f), - SDATA (file), &img->pixmap, &img->mask, - &attrs); - } - else - { - Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL); - rc = XpmCreatePixmapFromBuffer (FRAME_MAC_DISPLAY (f), FRAME_MAC_WINDOW (f), - SDATA (buffer), - &img->pixmap, &img->mask, - &attrs); - } - - if (rc == XpmSuccess) - { - int i; - - img->ncolors = attrs.nalloc_pixels; - img->colors = (unsigned long *) xmalloc (img->ncolors - * sizeof *img->colors); - for (i = 0; i < attrs.nalloc_pixels; ++i) - img->colors[i] = attrs.alloc_pixels[i]; - - img->width = attrs.width; - img->height = attrs.height; - xassert (img->width > 0 && img->height > 0); - - /* The call to XpmFreeAttributes below frees attrs.alloc_pixels. */ - XpmFreeAttributes (&attrs); - } - else - { - switch (rc) - { - case XpmOpenFailed: - image_error ("Error opening XPM file (%s)", img->spec, Qnil); - break; - - case XpmFileInvalid: - image_error ("Invalid XPM file (%s)", img->spec, Qnil); - break; - - case XpmNoMemory: - image_error ("Out of memory (%s)", img->spec, Qnil); - break; - - case XpmColorFailed: - image_error ("Color allocation error (%s)", img->spec, Qnil); - break; - - default: - image_error ("Unknown error (%s)", img->spec, Qnil); - break; - } - } - - return rc == XpmSuccess; -} - -#endif /* HAVE_XPM != 0 */ - - -#if 0 /* MAC_TODO : Color tables on Mac. */ -/*********************************************************************** - Color table - ***********************************************************************/ - -/* An entry in the color table mapping an RGB color to a pixel color. */ - -struct ct_color -{ - int r, g, b; - unsigned long pixel; - - /* Next in color table collision list. */ - struct ct_color *next; -}; - -/* The bucket vector size to use. Must be prime. */ - -#define CT_SIZE 101 - -/* Value is a hash of the RGB color given by R, G, and B. */ - -#define CT_HASH_RGB(R, G, B) (((R) << 16) ^ ((G) << 8) ^ (B)) - -/* The color hash table. */ - -struct ct_color **ct_table; - -/* Number of entries in the color table. */ - -int ct_colors_allocated; - -/* Initialize the color table. */ - -static void -init_color_table () -{ - int size = CT_SIZE * sizeof (*ct_table); - ct_table = (struct ct_color **) xmalloc (size); - bzero (ct_table, size); - ct_colors_allocated = 0; -} - - -/* Free memory associated with the color table. */ - -static void -free_color_table () -{ - int i; - struct ct_color *p, *next; - - for (i = 0; i < CT_SIZE; ++i) - for (p = ct_table[i]; p; p = next) - { - next = p->next; - xfree (p); - } - - xfree (ct_table); - ct_table = NULL; -} - - -/* Value is a pixel color for RGB color R, G, B on frame F. If an - entry for that color already is in the color table, return the - pixel color of that entry. Otherwise, allocate a new color for R, - G, B, and make an entry in the color table. */ - -static unsigned long -lookup_rgb_color (f, r, g, b) - struct frame *f; - int r, g, b; -{ - unsigned hash = CT_HASH_RGB (r, g, b); - int i = hash % CT_SIZE; - struct ct_color *p; - - for (p = ct_table[i]; p; p = p->next) - if (p->r == r && p->g == g && p->b == b) - break; - - if (p == NULL) - { - COLORREF color; - Colormap cmap; - int rc; - - color = RGB_TO_ULONG (r, g, b); - - ++ct_colors_allocated; - - p = (struct ct_color *) xmalloc (sizeof *p); - p->r = r; - p->g = g; - p->b = b; - p->pixel = color; - p->next = ct_table[i]; - ct_table[i] = p; - } - - return p->pixel; -} - - -/* Look up pixel color PIXEL which is used on frame F in the color - table. If not already present, allocate it. Value is PIXEL. */ - -static unsigned long -lookup_pixel_color (f, pixel) - struct frame *f; - unsigned long pixel; -{ - int i = pixel % CT_SIZE; - struct ct_color *p; - - for (p = ct_table[i]; p; p = p->next) - if (p->pixel == pixel) - break; - - if (p == NULL) - { - XColor color; - Colormap cmap; - int rc; - - BLOCK_INPUT; - - cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f)); - color.pixel = pixel; - XQueryColor (NULL, cmap, &color); - rc = x_alloc_nearest_color (f, cmap, &color); - UNBLOCK_INPUT; - - if (rc) - { - ++ct_colors_allocated; - - p = (struct ct_color *) xmalloc (sizeof *p); - p->r = color.red; - p->g = color.green; - p->b = color.blue; - p->pixel = pixel; - p->next = ct_table[i]; - ct_table[i] = p; - } - else - return FRAME_FOREGROUND_PIXEL (f); - } - return p->pixel; -} - - -/* Value is a vector of all pixel colors contained in the color table, - allocated via xmalloc. Set *N to the number of colors. */ - -static unsigned long * -colors_in_color_table (n) - int *n; -{ - int i, j; - struct ct_color *p; - unsigned long *colors; - - if (ct_colors_allocated == 0) - { - *n = 0; - colors = NULL; - } - else - { - colors = (unsigned long *) xmalloc (ct_colors_allocated - * sizeof *colors); - *n = ct_colors_allocated; - - for (i = j = 0; i < CT_SIZE; ++i) - for (p = ct_table[i]; p; p = p->next) - colors[j++] = p->pixel; - } - - return colors; -} - -#else -static unsigned long -lookup_rgb_color (f, r, g, b) - struct frame *f; - int r, g, b; -{ - unsigned long pixel = RGB_TO_ULONG (r >> 8, g >> 8, b >> 8); - - gamma_correct (f, &pixel); - return pixel; -} -#endif /* MAC_TODO */ - - -/*********************************************************************** - Algorithms - ***********************************************************************/ - -static XColor *x_to_xcolors P_ ((struct frame *, struct image *, int)); -static void x_from_xcolors P_ ((struct frame *, struct image *, XColor *)); -static void x_detect_edges P_ ((struct frame *, struct image *, int[9], int)); - -/* Non-zero means draw a cross on images having `:conversion - disabled'. */ - -int cross_disabled_images; - -/* Edge detection matrices for different edge-detection - strategies. */ - -static int emboss_matrix[9] = { - /* x - 1 x x + 1 */ - 2, -1, 0, /* y - 1 */ - -1, 0, 1, /* y */ - 0, 1, -2 /* y + 1 */ -}; - -static int laplace_matrix[9] = { - /* x - 1 x x + 1 */ - 1, 0, 0, /* y - 1 */ - 0, 0, 0, /* y */ - 0, 0, -1 /* y + 1 */ -}; - -/* Value is the intensity of the color whose red/green/blue values - are R, G, and B. */ - -#define COLOR_INTENSITY(R, G, B) ((2 * (R) + 3 * (G) + (B)) / 6) - - -/* On frame F, return an array of XColor structures describing image - IMG->pixmap. Each XColor structure has its pixel color set. RGB_P - non-zero means also fill the red/green/blue members of the XColor - structures. Value is a pointer to the array of XColors structures, - allocated with xmalloc; it must be freed by the caller. */ - -static XColor * -x_to_xcolors (f, img, rgb_p) - struct frame *f; - struct image *img; - int rgb_p; -{ - int x, y; - XColor *colors, *p; - XImagePtr ximg; - - colors = (XColor *) xmalloc (img->width * img->height * sizeof *colors); - - /* Get the X image IMG->pixmap. */ - ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap, - 0, 0, img->width, img->height, ~0, ZPixmap); - - /* Fill the `pixel' members of the XColor array. I wished there - were an easy and portable way to circumvent XGetPixel. */ - p = colors; - for (y = 0; y < img->height; ++y) - { - XColor *row = p; - - for (x = 0; x < img->width; ++x, ++p) - { - p->pixel = XGetPixel (ximg, x, y); - - if (rgb_p) - { - p->red = RED16_FROM_ULONG (p->pixel); - p->green = GREEN16_FROM_ULONG (p->pixel); - p->blue = BLUE16_FROM_ULONG (p->pixel); - } - } - } - - XDestroyImage (ximg); - return colors; -} - - -/* Create IMG->pixmap from an array COLORS of XColor structures, whose - RGB members are set. F is the frame on which this all happens. - COLORS will be freed; an existing IMG->pixmap will be freed, too. */ - -static void -x_from_xcolors (f, img, colors) - struct frame *f; - struct image *img; - XColor *colors; -{ - int x, y; - XImagePtr oimg; - Pixmap pixmap; - XColor *p; - -#if 0 /* TODO: color tables. */ - init_color_table (); -#endif - - x_create_x_image_and_pixmap (f, img->width, img->height, 0, - &oimg, &pixmap); - p = colors; - for (y = 0; y < img->height; ++y) - for (x = 0; x < img->width; ++x, ++p) - { - unsigned long pixel; - pixel = lookup_rgb_color (f, p->red, p->green, p->blue); - XPutPixel (oimg, x, y, pixel); - } - - xfree (colors); - x_clear_image_1 (f, img, 1, 0, 1); - - x_put_x_image (f, oimg, pixmap, img->width, img->height); - x_destroy_x_image (oimg); - img->pixmap = pixmap; -#if 0 /* TODO: color tables. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif -} - - -/* On frame F, perform edge-detection on image IMG. - - MATRIX is a nine-element array specifying the transformation - matrix. See emboss_matrix for an example. - - COLOR_ADJUST is a color adjustment added to each pixel of the - outgoing image. */ - -static void -x_detect_edges (f, img, matrix, color_adjust) - struct frame *f; - struct image *img; - int matrix[9], color_adjust; -{ - XColor *colors = x_to_xcolors (f, img, 1); - XColor *new, *p; - int x, y, i, sum; - - for (i = sum = 0; i < 9; ++i) - sum += abs (matrix[i]); - -#define COLOR(A, X, Y) ((A) + (Y) * img->width + (X)) - - new = (XColor *) xmalloc (img->width * img->height * sizeof *new); - - for (y = 0; y < img->height; ++y) - { - p = COLOR (new, 0, y); - p->red = p->green = p->blue = 0xffff/2; - p = COLOR (new, img->width - 1, y); - p->red = p->green = p->blue = 0xffff/2; - } - - for (x = 1; x < img->width - 1; ++x) - { - p = COLOR (new, x, 0); - p->red = p->green = p->blue = 0xffff/2; - p = COLOR (new, x, img->height - 1); - p->red = p->green = p->blue = 0xffff/2; - } - - for (y = 1; y < img->height - 1; ++y) - { - p = COLOR (new, 1, y); - - for (x = 1; x < img->width - 1; ++x, ++p) - { - int r, g, b, y1, x1; - - r = g = b = i = 0; - for (y1 = y - 1; y1 < y + 2; ++y1) - for (x1 = x - 1; x1 < x + 2; ++x1, ++i) - if (matrix[i]) - { - XColor *t = COLOR (colors, x1, y1); - r += matrix[i] * t->red; - g += matrix[i] * t->green; - b += matrix[i] * t->blue; - } - - r = (r / sum + color_adjust) & 0xffff; - g = (g / sum + color_adjust) & 0xffff; - b = (b / sum + color_adjust) & 0xffff; - p->red = p->green = p->blue = COLOR_INTENSITY (r, g, b); - } - } - - xfree (colors); - x_from_xcolors (f, img, new); - -#undef COLOR -} - - -/* Perform the pre-defined `emboss' edge-detection on image IMG - on frame F. */ - -static void -x_emboss (f, img) - struct frame *f; - struct image *img; -{ - x_detect_edges (f, img, emboss_matrix, 0xffff / 2); -} - - -/* Perform the pre-defined `laplace' edge-detection on image IMG - on frame F. */ - -static void -x_laplace (f, img) - struct frame *f; - struct image *img; -{ - x_detect_edges (f, img, laplace_matrix, 45000); -} - - -/* Perform edge-detection on image IMG on frame F, with specified - transformation matrix MATRIX and color-adjustment COLOR_ADJUST. - - MATRIX must be either - - - a list of at least 9 numbers in row-major form - - a vector of at least 9 numbers - - COLOR_ADJUST nil means use a default; otherwise it must be a - number. */ - -static void -x_edge_detection (f, img, matrix, color_adjust) - struct frame *f; - struct image *img; - Lisp_Object matrix, color_adjust; -{ - int i = 0; - int trans[9]; - - if (CONSP (matrix)) - { - for (i = 0; - i < 9 && CONSP (matrix) && NUMBERP (XCAR (matrix)); - ++i, matrix = XCDR (matrix)) - trans[i] = XFLOATINT (XCAR (matrix)); - } - else if (VECTORP (matrix) && ASIZE (matrix) >= 9) - { - for (i = 0; i < 9 && NUMBERP (AREF (matrix, i)); ++i) - trans[i] = XFLOATINT (AREF (matrix, i)); - } - - if (NILP (color_adjust)) - color_adjust = make_number (0xffff / 2); - - if (i == 9 && NUMBERP (color_adjust)) - x_detect_edges (f, img, trans, (int) XFLOATINT (color_adjust)); -} - - -/* Transform image IMG on frame F so that it looks disabled. */ - -static void -x_disable_image (f, img) - struct frame *f; - struct image *img; -{ - struct x_display_info *dpyinfo = FRAME_MAC_DISPLAY_INFO (f); - - if (dpyinfo->n_planes >= 2) - { - /* Color (or grayscale). Convert to gray, and equalize. Just - drawing such images with a stipple can look very odd, so - we're using this method instead. */ - XColor *colors = x_to_xcolors (f, img, 1); - XColor *p, *end; - const int h = 15000; - const int l = 30000; - - for (p = colors, end = colors + img->width * img->height; - p < end; - ++p) - { - int i = COLOR_INTENSITY (p->red, p->green, p->blue); - int i2 = (0xffff - h - l) * i / 0xffff + l; - p->red = p->green = p->blue = i2; - } - - x_from_xcolors (f, img, colors); - } - - /* Draw a cross over the disabled image, if we must or if we - should. */ - if (dpyinfo->n_planes < 2 || cross_disabled_images) - { - Display *dpy = FRAME_MAC_DISPLAY (f); - GC gc; - - gc = XCreateGC (dpy, NULL /*img->pixmap*/, 0, NULL); - XSetForeground (dpy, gc, BLACK_PIX_DEFAULT (f)); - mac_draw_line_to_pixmap (dpy, img->pixmap, gc, 0, 0, - img->width - 1, img->height - 1); - mac_draw_line_to_pixmap (dpy, img->pixmap, gc, 0, img->height - 1, - img->width - 1, 0); - XFreeGC (dpy, gc); - - if (img->mask) - { - gc = XCreateGC (dpy, NULL /*img->mask*/, 0, NULL); - XSetForeground (dpy, gc, PIX_MASK_DRAW (f)); - mac_draw_line_to_pixmap (dpy, img->mask, gc, 0, 0, - img->width - 1, img->height - 1); - mac_draw_line_to_pixmap (dpy, img->mask, gc, 0, img->height - 1, - img->width - 1, 0); - XFreeGC (dpy, gc); - } - } -} - - -/* Build a mask for image IMG which is used on frame F. FILE is the - name of an image file, for error messages. HOW determines how to - determine the background color of IMG. If it is a list '(R G B)', - with R, G, and B being integers >= 0, take that as the color of the - background. Otherwise, determine the background color of IMG - heuristically. Value is non-zero if successful. */ - -static int -x_build_heuristic_mask (f, img, how) - struct frame *f; - struct image *img; - Lisp_Object how; -{ - Display *dpy = FRAME_X_DISPLAY (f); - XImagePtr ximg, mask_img; - int x, y, rc, use_img_background; - unsigned long bg = 0; - - if (img->mask) - { - XFreePixmap (FRAME_X_DISPLAY (f), img->mask); - img->mask = 0; - img->background_transparent_valid = 0; - } - - /* Create an image and pixmap serving as mask. */ - rc = x_create_x_image_and_pixmap (f, img->width, img->height, 1, - &mask_img, &img->mask); - if (!rc) - return 0; - - /* Get the X image of IMG->pixmap. */ - ximg = XGetImage (dpy, img->pixmap, 0, 0, img->width, img->height, - ~0, ZPixmap); - - /* Determine the background color of ximg. If HOW is `(R G B)' - take that as color. Otherwise, use the image's background color. */ - use_img_background = 1; - - if (CONSP (how)) - { - int rgb[3], i; - - for (i = 0; i < 3 && CONSP (how) && NATNUMP (XCAR (how)); ++i) - { - rgb[i] = XFASTINT (XCAR (how)) & 0xffff; - how = XCDR (how); - } - - if (i == 3 && NILP (how)) - { - char color_name[30]; - sprintf (color_name, "#%04x%04x%04x", rgb[0], rgb[1], rgb[2]); - bg = x_alloc_image_color (f, img, build_string (color_name), 0); - use_img_background = 0; - } - } - - if (use_img_background) - bg = four_corners_best (ximg, img->width, img->height); - - /* Set all bits in mask_img to 1 whose color in ximg is different - from the background color bg. */ - for (y = 0; y < img->height; ++y) - for (x = 0; x < img->width; ++x) - XPutPixel (mask_img, x, y, XGetPixel (ximg, x, y) != bg ? PIX_MASK_DRAW (f) : PIX_MASK_RETAIN (f)); - - /* Fill in the background_transparent field while we have the mask handy. */ - image_background_transparent (img, f, mask_img); - - /* Put mask_img into img->mask. */ - x_put_x_image (f, mask_img, img->mask, img->width, img->height); - x_destroy_x_image (mask_img); - XDestroyImage (ximg); - - return 1; -} - - - -/*********************************************************************** - PBM (mono, gray, color) - ***********************************************************************/ - -static int pbm_image_p P_ ((Lisp_Object object)); -static int pbm_load P_ ((struct frame *f, struct image *img)); -static int pbm_scan_number P_ ((unsigned char **, unsigned char *)); - -/* The symbol `pbm' identifying images of this type. */ - -Lisp_Object Qpbm; - -/* Indices of image specification fields in gs_format, below. */ - -enum pbm_keyword_index -{ - PBM_TYPE, - PBM_FILE, - PBM_DATA, - PBM_ASCENT, - PBM_MARGIN, - PBM_RELIEF, - PBM_ALGORITHM, - PBM_HEURISTIC_MASK, - PBM_MASK, - PBM_FOREGROUND, - PBM_BACKGROUND, - PBM_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword pbm_format[PBM_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 0}, - {":data", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `pbm'. */ - -static struct image_type pbm_type = -{ - &Qpbm, - pbm_image_p, - pbm_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid PBM image specification. */ - -static int -pbm_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[PBM_LAST]; - - bcopy (pbm_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, PBM_LAST, Qpbm)) - return 0; - - /* Must specify either :data or :file. */ - return fmt[PBM_DATA].count + fmt[PBM_FILE].count == 1; -} - - -/* Scan a decimal number from *S and return it. Advance *S while - reading the number. END is the end of the string. Value is -1 at - end of input. */ - -static int -pbm_scan_number (s, end) - unsigned char **s, *end; -{ - int c = 0, val = -1; - - while (*s < end) - { - /* Skip white-space. */ - while (*s < end && (c = *(*s)++, isspace (c))) - ; - - if (c == '#') - { - /* Skip comment to end of line. */ - while (*s < end && (c = *(*s)++, c != '\n')) - ; - } - else if (isdigit (c)) - { - /* Read decimal number. */ - val = c - '0'; - while (*s < end && (c = *(*s)++, isdigit (c))) - val = 10 * val + c - '0'; - break; - } - else - break; - } - - return val; -} - - -/* Load PBM image IMG for use on frame F. */ - -static int -pbm_load (f, img) - struct frame *f; - struct image *img; -{ - int raw_p, x, y; - int width, height, max_color_idx = 0; - XImagePtr ximg; - Lisp_Object file, specified_file; - enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type; - struct gcpro gcpro1; - unsigned char *contents = NULL; - unsigned char *end, *p; - int size; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - file = Qnil; - GCPRO1 (file); - - if (STRINGP (specified_file)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - contents = slurp_file (SDATA (file), &size); - if (contents == NULL) - { - image_error ("Error reading `%s'", file, Qnil); - UNGCPRO; - return 0; - } - - p = contents; - end = contents + size; - } - else - { - Lisp_Object data; - data = image_spec_value (img->spec, QCdata, NULL); - p = SDATA (data); - end = p + SBYTES (data); - } - - /* Check magic number. */ - if (end - p < 2 || *p++ != 'P') - { - image_error ("Not a PBM image: `%s'", img->spec, Qnil); - error: - xfree (contents); - UNGCPRO; - return 0; - } - - switch (*p++) - { - case '1': - raw_p = 0, type = PBM_MONO; - break; - - case '2': - raw_p = 0, type = PBM_GRAY; - break; - - case '3': - raw_p = 0, type = PBM_COLOR; - break; - - case '4': - raw_p = 1, type = PBM_MONO; - break; - - case '5': - raw_p = 1, type = PBM_GRAY; - break; - - case '6': - raw_p = 1, type = PBM_COLOR; - break; - - default: - image_error ("Not a PBM image: `%s'", img->spec, Qnil); - goto error; - } - - /* Read width, height, maximum color-component. Characters - starting with `#' up to the end of a line are ignored. */ - width = pbm_scan_number (&p, end); - height = pbm_scan_number (&p, end); - - if (type != PBM_MONO) - { - max_color_idx = pbm_scan_number (&p, end); - if (raw_p && max_color_idx > 255) - max_color_idx = 255; - } - - if (width < 0 - || height < 0 - || (type != PBM_MONO && max_color_idx < 0)) - goto error; - - if (!x_create_x_image_and_pixmap (f, width, height, 0, - &ximg, &img->pixmap)) - goto error; - -#if 0 /* TODO: color tables. */ - /* Initialize the color hash table. */ - init_color_table (); -#endif - - if (type == PBM_MONO) - { - int c = 0, g; - struct image_keyword fmt[PBM_LAST]; - unsigned long fg = FRAME_FOREGROUND_PIXEL (f); - unsigned long bg = FRAME_BACKGROUND_PIXEL (f); - - /* Parse the image specification. */ - bcopy (pbm_format, fmt, sizeof fmt); - parse_image_spec (img->spec, fmt, PBM_LAST, Qpbm); - - /* Get foreground and background colors, maybe allocate colors. */ - if (fmt[PBM_FOREGROUND].count - && STRINGP (fmt[PBM_FOREGROUND].value)) - fg = x_alloc_image_color (f, img, fmt[PBM_FOREGROUND].value, fg); - if (fmt[PBM_BACKGROUND].count - && STRINGP (fmt[PBM_BACKGROUND].value)) - { - bg = x_alloc_image_color (f, img, fmt[PBM_BACKGROUND].value, bg); - img->background = bg; - img->background_valid = 1; - } - - for (y = 0; y < height; ++y) - for (x = 0; x < width; ++x) - { - if (raw_p) - { - if ((x & 7) == 0) - c = *p++; - g = c & 0x80; - c <<= 1; - } - else - g = pbm_scan_number (&p, end); - - XPutPixel (ximg, x, y, g ? fg : bg); - } - } - else - { - for (y = 0; y < height; ++y) - for (x = 0; x < width; ++x) - { - int r, g, b; - - if (type == PBM_GRAY) - r = g = b = raw_p ? *p++ : pbm_scan_number (&p, end); - else if (raw_p) - { - r = *p++; - g = *p++; - b = *p++; - } - else - { - r = pbm_scan_number (&p, end); - g = pbm_scan_number (&p, end); - b = pbm_scan_number (&p, end); - } - - if (r < 0 || g < 0 || b < 0) - { - x_destroy_x_image (ximg); - image_error ("Invalid pixel value in image `%s'", - img->spec, Qnil); - goto error; - } - - /* RGB values are now in the range 0..max_color_idx. - Scale this to the range 0..0xffff supported by X. */ - r = (double) r * 65535 / max_color_idx; - g = (double) g * 65535 / max_color_idx; - b = (double) b * 65535 / max_color_idx; - XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b)); - } - } - -#if 0 /* TODO: color tables. */ - /* Store in IMG->colors the colors allocated for the image, and - free the color table. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif - - img->width = width; - img->height = height; - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into a pixmap. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - - UNGCPRO; - xfree (contents); - return 1; -} - - - -/*********************************************************************** - PNG - ***********************************************************************/ - - -/* Function prototypes. */ - -static int png_image_p P_ ((Lisp_Object object)); -static int png_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `png' identifying images of this type. */ - -Lisp_Object Qpng; - -/* Indices of image specification fields in png_format, below. */ - -enum png_keyword_index -{ - PNG_TYPE, - PNG_DATA, - PNG_FILE, - PNG_ASCENT, - PNG_MARGIN, - PNG_RELIEF, - PNG_ALGORITHM, - PNG_HEURISTIC_MASK, - PNG_MASK, - PNG_BACKGROUND, - PNG_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword png_format[PNG_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `png'. */ - -static struct image_type png_type = -{ - &Qpng, - png_image_p, - png_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid PNG image specification. */ - -static int -png_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[PNG_LAST]; - bcopy (png_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, PNG_LAST, Qpng)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1; -} - - -#ifndef HAVE_PNG -static int -png_load (f, img) - struct frame *f; - struct image *img; -{ -#ifdef MAC_OSX - if (MyCGImageCreateWithPNGDataProvider) - return image_load_quartz2d (f, img, 1); - else -#endif - return image_load_quicktime (f, img, kQTFileTypePNG); -} -#else - -#if defined HAVE_LIBPNG_PNG_H -# include <libpng/png.h> -#else -# include <png.h> -#endif - -/* Error and warning handlers installed when the PNG library - is initialized. */ - -static void -my_png_error (png_ptr, msg) - png_struct *png_ptr; - char *msg; -{ - xassert (png_ptr != NULL); - image_error ("PNG error: %s", build_string (msg), Qnil); - longjmp (png_ptr->jmpbuf, 1); -} - - -static void -my_png_warning (png_ptr, msg) - png_struct *png_ptr; - char *msg; -{ - xassert (png_ptr != NULL); - image_error ("PNG warning: %s", build_string (msg), Qnil); -} - -/* Memory source for PNG decoding. */ - -struct png_memory_storage -{ - unsigned char *bytes; /* The data */ - size_t len; /* How big is it? */ - int index; /* Where are we? */ -}; - - -/* Function set as reader function when reading PNG image from memory. - PNG_PTR is a pointer to the PNG control structure. Copy LENGTH - bytes from the input to DATA. */ - -static void -png_read_from_memory (png_ptr, data, length) - png_structp png_ptr; - png_bytep data; - png_size_t length; -{ - struct png_memory_storage *tbr - = (struct png_memory_storage *) png_get_io_ptr (png_ptr); - - if (length > tbr->len - tbr->index) - png_error (png_ptr, "Read error"); - - bcopy (tbr->bytes + tbr->index, data, length); - tbr->index = tbr->index + length; -} - -/* Load PNG image IMG for use on frame F. Value is non-zero if - successful. */ - -static int -png_load (f, img) - struct frame *f; - struct image *img; -{ - Lisp_Object file, specified_file; - Lisp_Object specified_data; - int x, y, i; - XImagePtr ximg, mask_img = NULL; - struct gcpro gcpro1; - png_struct *png_ptr = NULL; - png_info *info_ptr = NULL, *end_info = NULL; - FILE *volatile fp = NULL; - png_byte sig[8]; - png_byte * volatile pixels = NULL; - png_byte ** volatile rows = NULL; - png_uint_32 width, height; - int bit_depth, color_type, interlace_type; - png_byte channels; - png_uint_32 row_bytes; - int transparent_p; - double screen_gamma; - struct png_memory_storage tbr; /* Data to be read */ - - /* Find out what file to load. */ - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - if (NILP (specified_data)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - /* Open the image file. */ - fp = fopen (SDATA (file), "rb"); - if (!fp) - { - image_error ("Cannot open image file `%s'", file, Qnil); - UNGCPRO; - fclose (fp); - return 0; - } - - /* Check PNG signature. */ - if (fread (sig, 1, sizeof sig, fp) != sizeof sig - || !png_check_sig (sig, sizeof sig)) - { - image_error ("Not a PNG file: `%s'", file, Qnil); - UNGCPRO; - fclose (fp); - return 0; - } - } - else - { - /* Read from memory. */ - tbr.bytes = SDATA (specified_data); - tbr.len = SBYTES (specified_data); - tbr.index = 0; - - /* Check PNG signature. */ - if (tbr.len < sizeof sig - || !png_check_sig (tbr.bytes, sizeof sig)) - { - image_error ("Not a PNG image: `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - - /* Need to skip past the signature. */ - tbr.bytes += sizeof (sig); - } - - /* Initialize read and info structs for PNG lib. */ - png_ptr = png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL, - my_png_error, my_png_warning); - if (!png_ptr) - { - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - info_ptr = png_create_info_struct (png_ptr); - if (!info_ptr) - { - png_destroy_read_struct (&png_ptr, NULL, NULL); - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - end_info = png_create_info_struct (png_ptr); - if (!end_info) - { - png_destroy_read_struct (&png_ptr, &info_ptr, NULL); - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - /* Set error jump-back. We come back here when the PNG library - detects an error. */ - if (setjmp (png_ptr->jmpbuf)) - { - error: - if (png_ptr) - png_destroy_read_struct (&png_ptr, &info_ptr, &end_info); - xfree (pixels); - xfree (rows); - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - /* Read image info. */ - if (!NILP (specified_data)) - png_set_read_fn (png_ptr, (void *) &tbr, png_read_from_memory); - else - png_init_io (png_ptr, fp); - - png_set_sig_bytes (png_ptr, sizeof sig); - png_read_info (png_ptr, info_ptr); - png_get_IHDR (png_ptr, info_ptr, &width, &height, &bit_depth, &color_type, - &interlace_type, NULL, NULL); - - /* If image contains simply transparency data, we prefer to - construct a clipping mask. */ - if (png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS)) - transparent_p = 1; - else - transparent_p = 0; - - /* This function is easier to write if we only have to handle - one data format: RGB or RGBA with 8 bits per channel. Let's - transform other formats into that format. */ - - /* Strip more than 8 bits per channel. */ - if (bit_depth == 16) - png_set_strip_16 (png_ptr); - - /* Expand data to 24 bit RGB, or 8 bit grayscale, with alpha channel - if available. */ - png_set_expand (png_ptr); - - /* Convert grayscale images to RGB. */ - if (color_type == PNG_COLOR_TYPE_GRAY - || color_type == PNG_COLOR_TYPE_GRAY_ALPHA) - png_set_gray_to_rgb (png_ptr); - - screen_gamma = (f->gamma ? 1 / f->gamma / 0.45455 : 2.2); - -#if 0 /* Avoid double gamma correction for PNG images. */ - { /* Tell the PNG lib to handle gamma correction for us. */ - int intent; - double image_gamma; -#if defined(PNG_READ_sRGB_SUPPORTED) || defined(PNG_WRITE_sRGB_SUPPORTED) - if (png_get_sRGB (png_ptr, info_ptr, &intent)) - /* The libpng documentation says this is right in this case. */ - png_set_gamma (png_ptr, screen_gamma, 0.45455); - else -#endif - if (png_get_gAMA (png_ptr, info_ptr, &image_gamma)) - /* Image contains gamma information. */ - png_set_gamma (png_ptr, screen_gamma, image_gamma); - else - /* Use the standard default for the image gamma. */ - png_set_gamma (png_ptr, screen_gamma, 0.45455); - } -#endif /* if 0 */ - - /* Handle alpha channel by combining the image with a background - color. Do this only if a real alpha channel is supplied. For - simple transparency, we prefer a clipping mask. */ - if (!transparent_p) - { - png_color_16 *image_bg; - Lisp_Object specified_bg - = image_spec_value (img->spec, QCbackground, NULL); - - if (STRINGP (specified_bg)) - /* The user specified `:background', use that. */ - { - XColor color; - if (mac_defined_color (f, SDATA (specified_bg), &color, 0)) - { - png_color_16 user_bg; - - bzero (&user_bg, sizeof user_bg); - user_bg.red = color.red >> 8; - user_bg.green = color.green >> 8; - user_bg.blue = color.blue >> 8; - - png_set_background (png_ptr, &user_bg, - PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); - } - } - else if (png_get_bKGD (png_ptr, info_ptr, &image_bg)) - /* Image contains a background color with which to - combine the image. */ - png_set_background (png_ptr, image_bg, - PNG_BACKGROUND_GAMMA_FILE, 1, 1.0); - else - { - /* Image does not contain a background color with which - to combine the image data via an alpha channel. Use - the frame's background instead. */ - unsigned long color; - png_color_16 frame_background; - color = FRAME_BACKGROUND_PIXEL (f); -#if 0 /* TODO : Colormap support. */ - Colormap cmap; - - cmap = FRAME_X_COLORMAP (f); - x_query_color (f, &color); -#endif - bzero (&frame_background, sizeof frame_background); - frame_background.red = RED_FROM_ULONG (color); - frame_background.green = GREEN_FROM_ULONG (color); - frame_background.blue = BLUE_FROM_ULONG (color); - - png_set_background (png_ptr, &frame_background, - PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); - } - } - - /* Update info structure. */ - png_read_update_info (png_ptr, info_ptr); - - /* Get number of channels. Valid values are 1 for grayscale images - and images with a palette, 2 for grayscale images with transparency - information (alpha channel), 3 for RGB images, and 4 for RGB - images with alpha channel, i.e. RGBA. If conversions above were - sufficient we should only have 3 or 4 channels here. */ - channels = png_get_channels (png_ptr, info_ptr); - xassert (channels == 3 || channels == 4); - - /* Number of bytes needed for one row of the image. */ - row_bytes = png_get_rowbytes (png_ptr, info_ptr); - - /* Allocate memory for the image. */ - pixels = (png_byte *) xmalloc (row_bytes * height * sizeof *pixels); - rows = (png_byte **) xmalloc (height * sizeof *rows); - for (i = 0; i < height; ++i) - rows[i] = pixels + i * row_bytes; - - /* Read the entire image. */ - png_read_image (png_ptr, rows); - png_read_end (png_ptr, info_ptr); - if (fp) - { - fclose (fp); - fp = NULL; - } - - /* Create the X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, - &img->pixmap)) - goto error; - - /* Create an image and pixmap serving as mask if the PNG image - contains an alpha channel. */ - if (channels == 4 - && !transparent_p - && !x_create_x_image_and_pixmap (f, width, height, 1, - &mask_img, &img->mask)) - { - x_destroy_x_image (ximg); - XFreePixmap (FRAME_MAC_DISPLAY (f), img->pixmap); - img->pixmap = NULL; - goto error; - } - - /* Fill the X image and mask from PNG data. */ -#if 0 /* TODO: Color tables. */ - init_color_table (); -#endif - - for (y = 0; y < height; ++y) - { - png_byte *p = rows[y]; - - for (x = 0; x < width; ++x) - { - unsigned r, g, b; - - r = *p++ << 8; - g = *p++ << 8; - b = *p++ << 8; - XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b)); - - /* An alpha channel, aka mask channel, associates variable - transparency with an image. Where other image formats - support binary transparency---fully transparent or fully - opaque---PNG allows up to 254 levels of partial transparency. - The PNG library implements partial transparency by combining - the image with a specified background color. - - I'm not sure how to handle this here nicely: because the - background on which the image is displayed may change, for - real alpha channel support, it would be necessary to create - a new image for each possible background. - - What I'm doing now is that a mask is created if we have - boolean transparency information. Otherwise I'm using - the frame's background color to combine the image with. */ - - if (channels == 4) - { - if (mask_img) - XPutPixel (mask_img, x, y, *p > 0 ? PIX_MASK_DRAW (f) : PIX_MASK_RETAIN (f)); - ++p; - } - } - } - - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - /* Set IMG's background color from the PNG image, unless the user - overrode it. */ - { - png_color_16 *bg; - if (png_get_bKGD (png_ptr, info_ptr, &bg)) - { - img->background = lookup_rgb_color (f, bg->red, bg->green, bg->blue); - img->background_valid = 1; - } - } - -#if 0 /* TODO: Color tables. */ - /* Remember colors allocated for this image. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif - - /* Clean up. */ - png_destroy_read_struct (&png_ptr, &info_ptr, &end_info); - xfree (rows); - xfree (pixels); - - img->width = width; - img->height = height; - - /* Maybe fill in the background field while we have ximg handy. */ - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap, then free the X image and its buffer. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - - /* Same for the mask. */ - if (mask_img) - { - /* Fill in the background_transparent field while we have the mask - handy. */ - image_background_transparent (img, f, mask_img); - - x_put_x_image (f, mask_img, img->mask, img->width, img->height); - x_destroy_x_image (mask_img); - } - - UNGCPRO; - return 1; -} - -#endif /* HAVE_PNG */ - - - -/*********************************************************************** - JPEG - ***********************************************************************/ - -static int jpeg_image_p P_ ((Lisp_Object object)); -static int jpeg_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `jpeg' identifying images of this type. */ - -Lisp_Object Qjpeg; - -/* Indices of image specification fields in gs_format, below. */ - -enum jpeg_keyword_index -{ - JPEG_TYPE, - JPEG_DATA, - JPEG_FILE, - JPEG_ASCENT, - JPEG_MARGIN, - JPEG_RELIEF, - JPEG_ALGORITHM, - JPEG_HEURISTIC_MASK, - JPEG_MASK, - JPEG_BACKGROUND, - JPEG_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword jpeg_format[JPEG_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversions", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `jpeg'. */ - -static struct image_type jpeg_type = -{ - &Qjpeg, - jpeg_image_p, - jpeg_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid JPEG image specification. */ - -static int -jpeg_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[JPEG_LAST]; - - bcopy (jpeg_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, JPEG_LAST, Qjpeg)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1; -} - - -#ifndef HAVE_JPEG -static int -jpeg_load (f, img) - struct frame *f; - struct image *img; -{ -#ifdef MAC_OSX - return image_load_quartz2d (f, img, 0); -#else - return image_load_quicktime (f, img, kQTFileTypeJPEG); -#endif -} -#else - -/* Work around a warning about HAVE_STDLIB_H being redefined in - jconfig.h. */ -#ifdef HAVE_STDLIB_H -#define HAVE_STDLIB_H_1 -#undef HAVE_STDLIB_H -#endif /* HAVE_STLIB_H */ - -#include <jpeglib.h> -#include <jerror.h> -#include <setjmp.h> - -#ifdef HAVE_STLIB_H_1 -#define HAVE_STDLIB_H 1 -#endif - -struct my_jpeg_error_mgr -{ - struct jpeg_error_mgr pub; - jmp_buf setjmp_buffer; -}; - - -static void -my_error_exit (cinfo) - j_common_ptr cinfo; -{ - struct my_jpeg_error_mgr *mgr = (struct my_jpeg_error_mgr *) cinfo->err; - longjmp (mgr->setjmp_buffer, 1); -} - - -/* Init source method for JPEG data source manager. Called by - jpeg_read_header() before any data is actually read. See - libjpeg.doc from the JPEG lib distribution. */ - -static void -our_init_source (cinfo) - j_decompress_ptr cinfo; -{ -} - - -/* Fill input buffer method for JPEG data source manager. Called - whenever more data is needed. We read the whole image in one step, - so this only adds a fake end of input marker at the end. */ - -static boolean -our_fill_input_buffer (cinfo) - j_decompress_ptr cinfo; -{ - /* Insert a fake EOI marker. */ - struct jpeg_source_mgr *src = cinfo->src; - static JOCTET buffer[2]; - - buffer[0] = (JOCTET) 0xFF; - buffer[1] = (JOCTET) JPEG_EOI; - - src->next_input_byte = buffer; - src->bytes_in_buffer = 2; - return TRUE; -} - - -/* Method to skip over NUM_BYTES bytes in the image data. CINFO->src - is the JPEG data source manager. */ - -static void -our_skip_input_data (cinfo, num_bytes) - j_decompress_ptr cinfo; - long num_bytes; -{ - struct jpeg_source_mgr *src = (struct jpeg_source_mgr *) cinfo->src; - - if (src) - { - if (num_bytes > src->bytes_in_buffer) - ERREXIT (cinfo, JERR_INPUT_EOF); - - src->bytes_in_buffer -= num_bytes; - src->next_input_byte += num_bytes; - } -} - - -/* Method to terminate data source. Called by - jpeg_finish_decompress() after all data has been processed. */ - -static void -our_term_source (cinfo) - j_decompress_ptr cinfo; -{ -} - - -/* Set up the JPEG lib for reading an image from DATA which contains - LEN bytes. CINFO is the decompression info structure created for - reading the image. */ - -static void -jpeg_memory_src (cinfo, data, len) - j_decompress_ptr cinfo; - JOCTET *data; - unsigned int len; -{ - struct jpeg_source_mgr *src; - - if (cinfo->src == NULL) - { - /* First time for this JPEG object? */ - cinfo->src = (struct jpeg_source_mgr *) - (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT, - sizeof (struct jpeg_source_mgr)); - src = (struct jpeg_source_mgr *) cinfo->src; - src->next_input_byte = data; - } - - src = (struct jpeg_source_mgr *) cinfo->src; - src->init_source = our_init_source; - src->fill_input_buffer = our_fill_input_buffer; - src->skip_input_data = our_skip_input_data; - src->resync_to_restart = jpeg_resync_to_restart; /* Use default method. */ - src->term_source = our_term_source; - src->bytes_in_buffer = len; - src->next_input_byte = data; -} - - -/* Load image IMG for use on frame F. Patterned after example.c - from the JPEG lib. */ - -static int -jpeg_load (f, img) - struct frame *f; - struct image *img; -{ - struct jpeg_decompress_struct cinfo; - struct my_jpeg_error_mgr mgr; - Lisp_Object file, specified_file; - Lisp_Object specified_data; - FILE * volatile fp = NULL; - JSAMPARRAY buffer; - int row_stride, x, y; - XImagePtr ximg = NULL; - int rc; - unsigned long *colors; - int width, height; - struct gcpro gcpro1; - - /* Open the JPEG file. */ - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - if (NILP (specified_data)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - fp = fopen (SDATA (file), "r"); - if (fp == NULL) - { - image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; - return 0; - } - } - - /* Customize libjpeg's error handling to call my_error_exit when an - error is detected. This function will perform a longjmp. */ - cinfo.err = jpeg_std_error (&mgr.pub); - mgr.pub.error_exit = my_error_exit; - - if ((rc = setjmp (mgr.setjmp_buffer)) != 0) - { - if (rc == 1) - { - /* Called from my_error_exit. Display a JPEG error. */ - char buffer[JMSG_LENGTH_MAX]; - cinfo.err->format_message ((j_common_ptr) &cinfo, buffer); - image_error ("Error reading JPEG image `%s': %s", img->spec, - build_string (buffer)); - } - - /* Close the input file and destroy the JPEG object. */ - if (fp) - fclose ((FILE *) fp); - jpeg_destroy_decompress (&cinfo); - - /* If we already have an XImage, free that. */ - x_destroy_x_image (ximg); - - /* Free pixmap and colors. */ - x_clear_image (f, img); - - UNGCPRO; - return 0; - } - - /* Create the JPEG decompression object. Let it read from fp. - Read the JPEG image header. */ - jpeg_create_decompress (&cinfo); - - if (NILP (specified_data)) - jpeg_stdio_src (&cinfo, (FILE *) fp); - else - jpeg_memory_src (&cinfo, SDATA (specified_data), - SBYTES (specified_data)); - - jpeg_read_header (&cinfo, TRUE); - - /* Customize decompression so that color quantization will be used. - Start decompression. */ - cinfo.quantize_colors = TRUE; - jpeg_start_decompress (&cinfo); - width = img->width = cinfo.output_width; - height = img->height = cinfo.output_height; - - /* Create X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - longjmp (mgr.setjmp_buffer, 2); - - /* Allocate colors. When color quantization is used, - cinfo.actual_number_of_colors has been set with the number of - colors generated, and cinfo.colormap is a two-dimensional array - of color indices in the range 0..cinfo.actual_number_of_colors. - No more than 255 colors will be generated. */ - { - int i, ir, ig, ib; - - if (cinfo.out_color_components > 2) - ir = 0, ig = 1, ib = 2; - else if (cinfo.out_color_components > 1) - ir = 0, ig = 1, ib = 0; - else - ir = 0, ig = 0, ib = 0; - -#if 0 /* TODO: Color tables. */ - /* Use the color table mechanism because it handles colors that - cannot be allocated nicely. Such colors will be replaced with - a default color, and we don't have to care about which colors - can be freed safely, and which can't. */ - init_color_table (); -#endif - colors = (unsigned long *) alloca (cinfo.actual_number_of_colors - * sizeof *colors); - - for (i = 0; i < cinfo.actual_number_of_colors; ++i) - { - /* Multiply RGB values with 255 because X expects RGB values - in the range 0..0xffff. */ - int r = cinfo.colormap[ir][i] << 8; - int g = cinfo.colormap[ig][i] << 8; - int b = cinfo.colormap[ib][i] << 8; - colors[i] = lookup_rgb_color (f, r, g, b); - } - -#if 0 /* TODO: Color tables. */ - /* Remember those colors actually allocated. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif - } - - /* Read pixels. */ - row_stride = width * cinfo.output_components; - buffer = cinfo.mem->alloc_sarray ((j_common_ptr) &cinfo, JPOOL_IMAGE, - row_stride, 1); - for (y = 0; y < height; ++y) - { - jpeg_read_scanlines (&cinfo, buffer, 1); - for (x = 0; x < cinfo.output_width; ++x) - XPutPixel (ximg, x, y, colors[buffer[0][x]]); - } - - /* Clean up. */ - jpeg_finish_decompress (&cinfo); - jpeg_destroy_decompress (&cinfo); - if (fp) - fclose ((FILE *) fp); - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - UNGCPRO; - return 1; -} - -#endif /* HAVE_JPEG */ - - - -/*********************************************************************** - TIFF - ***********************************************************************/ - -static int tiff_image_p P_ ((Lisp_Object object)); -static int tiff_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `tiff' identifying images of this type. */ - -Lisp_Object Qtiff; - -/* Indices of image specification fields in tiff_format, below. */ - -enum tiff_keyword_index -{ - TIFF_TYPE, - TIFF_DATA, - TIFF_FILE, - TIFF_ASCENT, - TIFF_MARGIN, - TIFF_RELIEF, - TIFF_ALGORITHM, - TIFF_HEURISTIC_MASK, - TIFF_MASK, - TIFF_BACKGROUND, - TIFF_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword tiff_format[TIFF_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversions", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `tiff'. */ - -static struct image_type tiff_type = -{ - &Qtiff, - tiff_image_p, - tiff_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid TIFF image specification. */ - -static int -tiff_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[TIFF_LAST]; - bcopy (tiff_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, TIFF_LAST, Qtiff)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1; -} - -#ifndef HAVE_TIFF - -static int -tiff_load (f, img) - struct frame *f; - struct image *img; -{ - return image_load_quicktime (f, img, kQTFileTypeTIFF); -} - -#else - -#include <tiffio.h> - -/* Reading from a memory buffer for TIFF images Based on the PNG - memory source, but we have to provide a lot of extra functions. - Blah. - - We really only need to implement read and seek, but I am not - convinced that the TIFF library is smart enough not to destroy - itself if we only hand it the function pointers we need to - override. */ - -typedef struct -{ - unsigned char *bytes; - size_t len; - int index; -} -tiff_memory_source; - - -static size_t -tiff_read_from_memory (data, buf, size) - thandle_t data; - tdata_t buf; - tsize_t size; -{ - tiff_memory_source *src = (tiff_memory_source *) data; - - if (size > src->len - src->index) - return (size_t) -1; - bcopy (src->bytes + src->index, buf, size); - src->index += size; - return size; -} - - -static size_t -tiff_write_from_memory (data, buf, size) - thandle_t data; - tdata_t buf; - tsize_t size; -{ - return (size_t) -1; -} - - -static toff_t -tiff_seek_in_memory (data, off, whence) - thandle_t data; - toff_t off; - int whence; -{ - tiff_memory_source *src = (tiff_memory_source *) data; - int idx; - - switch (whence) - { - case SEEK_SET: /* Go from beginning of source. */ - idx = off; - break; - - case SEEK_END: /* Go from end of source. */ - idx = src->len + off; - break; - - case SEEK_CUR: /* Go from current position. */ - idx = src->index + off; - break; - - default: /* Invalid `whence'. */ - return -1; - } - - if (idx > src->len || idx < 0) - return -1; - - src->index = idx; - return src->index; -} - - -static int -tiff_close_memory (data) - thandle_t data; -{ - /* NOOP */ - return 0; -} - - -static int -tiff_mmap_memory (data, pbase, psize) - thandle_t data; - tdata_t *pbase; - toff_t *psize; -{ - /* It is already _IN_ memory. */ - return 0; -} - - -static void -tiff_unmap_memory (data, base, size) - thandle_t data; - tdata_t base; - toff_t size; -{ - /* We don't need to do this. */ -} - - -static toff_t -tiff_size_of_memory (data) - thandle_t data; -{ - return ((tiff_memory_source *) data)->len; -} - - -static void -tiff_error_handler (title, format, ap) - const char *title, *format; - va_list ap; -{ - char buf[512]; - int len; - - len = sprintf (buf, "TIFF error: %s ", title); - vsprintf (buf + len, format, ap); - add_to_log (buf, Qnil, Qnil); -} - - -static void -tiff_warning_handler (title, format, ap) - const char *title, *format; - va_list ap; -{ - char buf[512]; - int len; - - len = sprintf (buf, "TIFF warning: %s ", title); - vsprintf (buf + len, format, ap); - add_to_log (buf, Qnil, Qnil); -} - - -/* Load TIFF image IMG for use on frame F. Value is non-zero if - successful. */ - -static int -tiff_load (f, img) - struct frame *f; - struct image *img; -{ - Lisp_Object file, specified_file; - Lisp_Object specified_data; - TIFF *tiff; - int width, height, x, y; - uint32 *buf; - int rc; - XImagePtr ximg; - struct gcpro gcpro1; - tiff_memory_source memsrc; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - TIFFSetErrorHandler (tiff_error_handler); - TIFFSetWarningHandler (tiff_warning_handler); - - if (NILP (specified_data)) - { - /* Read from a file */ - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - /* Try to open the image file. */ - tiff = TIFFOpen (SDATA (file), "r"); - if (tiff == NULL) - { - image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; - return 0; - } - } - else - { - /* Memory source! */ - memsrc.bytes = SDATA (specified_data); - memsrc.len = SBYTES (specified_data); - memsrc.index = 0; - - tiff = TIFFClientOpen ("memory_source", "r", &memsrc, - (TIFFReadWriteProc) tiff_read_from_memory, - (TIFFReadWriteProc) tiff_write_from_memory, - tiff_seek_in_memory, - tiff_close_memory, - tiff_size_of_memory, - tiff_mmap_memory, - tiff_unmap_memory); - - if (!tiff) - { - image_error ("Cannot open memory source for `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - } - - /* Get width and height of the image, and allocate a raster buffer - of width x height 32-bit values. */ - TIFFGetField (tiff, TIFFTAG_IMAGEWIDTH, &width); - TIFFGetField (tiff, TIFFTAG_IMAGELENGTH, &height); - buf = (uint32 *) xmalloc (width * height * sizeof *buf); - - rc = TIFFReadRGBAImage (tiff, width, height, buf, 0); - TIFFClose (tiff); - if (!rc) - { - image_error ("Error reading TIFF image `%s'", img->spec, Qnil); - xfree (buf); - UNGCPRO; - return 0; - } - - /* Create the X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - { - xfree (buf); - UNGCPRO; - return 0; - } - -#if 0 /* TODO: Color tables. */ - /* Initialize the color table. */ - init_color_table (); -#endif - - /* Process the pixel raster. Origin is in the lower-left corner. */ - for (y = 0; y < height; ++y) - { - uint32 *row = buf + y * width; - - for (x = 0; x < width; ++x) - { - uint32 abgr = row[x]; - int r = TIFFGetR (abgr) << 8; - int g = TIFFGetG (abgr) << 8; - int b = TIFFGetB (abgr) << 8; - XPutPixel (ximg, x, height - 1 - y, lookup_rgb_color (f, r, g, b)); - } - } - -#if 0 /* TODO: Color tables. */ - /* Remember the colors allocated for the image. Free the color table. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif - - img->width = width; - img->height = height; - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap, then free the X image and its buffer. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - xfree (buf); - - UNGCPRO; - return 1; -} - -#endif /* HAVE_TIFF */ - - - -/*********************************************************************** - GIF - ***********************************************************************/ - -static int gif_image_p P_ ((Lisp_Object object)); -static int gif_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `gif' identifying images of this type. */ - -Lisp_Object Qgif; - -/* Indices of image specification fields in gif_format, below. */ - -enum gif_keyword_index -{ - GIF_TYPE, - GIF_DATA, - GIF_FILE, - GIF_ASCENT, - GIF_MARGIN, - GIF_RELIEF, - GIF_ALGORITHM, - GIF_HEURISTIC_MASK, - GIF_MASK, - GIF_IMAGE, - GIF_BACKGROUND, - GIF_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword gif_format[GIF_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":image", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `gif'. */ - -static struct image_type gif_type = -{ - &Qgif, - gif_image_p, - gif_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid GIF image specification. */ - -static int -gif_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[GIF_LAST]; - bcopy (gif_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, GIF_LAST, Qgif)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[GIF_FILE].count + fmt[GIF_DATA].count == 1; -} - -#ifndef HAVE_GIF - -static int -gif_load (f, img) - struct frame *f; - struct image *img; -{ - Lisp_Object specified_file, file; - Lisp_Object specified_data; - OSErr err; - Boolean graphic_p, movie_p, prefer_graphic_p; - Handle dh = NULL; - Movie movie = NULL; - Lisp_Object image; - Track track = NULL; - Media media = NULL; - long nsamples; - Rect rect; - Lisp_Object specified_bg; - XColor color; - RGBColor bg_color; - int width, height; - XImagePtr ximg; - TimeValue time; - struct gcpro gcpro1; - int ino; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - - if (NILP (specified_data)) - { - /* Read from a file */ - FSSpec fss; - short refnum; - - err = find_image_fsspec (specified_file, &file, &fss); - if (err != noErr) - { - if (err == fnfErr) - image_error ("Cannot find image file `%s'", specified_file, Qnil); - else - goto open_error; - } - - err = CanQuickTimeOpenFile (&fss, kQTFileTypeGIF, 0, - &graphic_p, &movie_p, &prefer_graphic_p, 0); - if (err != noErr) - goto open_error; - - if (!graphic_p && !movie_p) - goto open_error; - if (prefer_graphic_p) - return image_load_qt_1 (f, img, kQTFileTypeGIF, &fss, NULL); - err = OpenMovieFile (&fss, &refnum, fsRdPerm); - if (err != noErr) - goto open_error; - err = NewMovieFromFile (&movie, refnum, NULL, NULL, 0, NULL); - CloseMovieFile (refnum); - if (err != noErr) - { - image_error ("Error reading `%s'", file, Qnil); - return 0; - } - } - else - { - /* Memory source! */ - Handle dref = NULL; - long file_type_atom[3]; - - err = PtrToHand (SDATA (specified_data), &dh, SBYTES (specified_data)); - if (err != noErr) - { - image_error ("Cannot allocate data handle for `%s'", - img->spec, Qnil); - goto error; - } - - file_type_atom[0] = EndianU32_NtoB (sizeof (long) * 3); - file_type_atom[1] = EndianU32_NtoB (kDataRefExtensionMacOSFileType); - file_type_atom[2] = EndianU32_NtoB (kQTFileTypeGIF); - err = PtrToHand (&dh, &dref, sizeof (Handle)); - if (err == noErr) - /* no file name */ - err = PtrAndHand ("\p", dref, 1); - if (err == noErr) - err = PtrAndHand (file_type_atom, dref, sizeof (long) * 3); - if (err != noErr) - { - image_error ("Cannot allocate handle data ref for `%s'", img->spec, Qnil); - goto error; - } - err = CanQuickTimeOpenDataRef (dref, HandleDataHandlerSubType, &graphic_p, - &movie_p, &prefer_graphic_p, 0); - if (err != noErr) - goto open_error; - - if (!graphic_p && !movie_p) - goto open_error; - if (prefer_graphic_p) - { - int success_p; - - DisposeHandle (dref); - success_p = image_load_qt_1 (f, img, kQTFileTypeGIF, NULL, dh); - DisposeHandle (dh); - return success_p; - } - err = NewMovieFromDataRef (&movie, 0, NULL, dref, - HandleDataHandlerSubType); - DisposeHandle (dref); - if (err != noErr) - goto open_error; - } - - image = image_spec_value (img->spec, QCindex, NULL); - ino = INTEGERP (image) ? XFASTINT (image) : 0; - track = GetMovieIndTrack (movie, 1); - media = GetTrackMedia (track); - nsamples = GetMediaSampleCount (media); - if (ino >= nsamples) - { - image_error ("Invalid image number `%s' in image `%s'", - image, img->spec); - goto error; - } - - specified_bg = image_spec_value (img->spec, QCbackground, NULL); - if (!STRINGP (specified_bg) || - !mac_defined_color (f, SDATA (specified_bg), &color, 0)) - { - color.pixel = FRAME_BACKGROUND_PIXEL (f); - color.red = RED16_FROM_ULONG (color.pixel); - color.green = GREEN16_FROM_ULONG (color.pixel); - color.blue = BLUE16_FROM_ULONG (color.pixel); - } - GetMovieBox (movie, &rect); - width = img->width = rect.right - rect.left; - height = img->height = rect.bottom - rect.top; - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - goto error; - - SetGWorld (ximg, NULL); - bg_color.red = color.red; - bg_color.green = color.green; - bg_color.blue = color.blue; - RGBBackColor (&bg_color); - SetMovieActive (movie, TRUE); - SetMovieGWorld (movie, ximg, NULL); - SampleNumToMediaTime (media, ino + 1, &time, NULL); - SetMovieTimeValue (movie, time); - MoviesTask (movie, 0L); - DisposeTrackMedia (media); - DisposeMovieTrack (track); - DisposeMovie (movie); - if (dh) - DisposeHandle (dh); - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - return 1; - - open_error: - image_error ("Cannot open `%s'", file, Qnil); - error: - if (media) - DisposeTrackMedia (media); - if (track) - DisposeMovieTrack (track); - if (movie) - DisposeMovie (movie); - if (dh) - DisposeHandle (dh); - return 0; -} - -#else - -#define DrawText gif_DrawText /* avoid conflict with QuickdrawText.h */ -#include <gif_lib.h> -#undef DrawText - -/* Reading a GIF image from memory - Based on the PNG memory stuff to a certain extent. */ - -typedef struct -{ - unsigned char *bytes; - size_t len; - int index; -} -gif_memory_source; - - -/* Make the current memory source available to gif_read_from_memory. - It's done this way because not all versions of libungif support - a UserData field in the GifFileType structure. */ -static gif_memory_source *current_gif_memory_src; - -static int -gif_read_from_memory (file, buf, len) - GifFileType *file; - GifByteType *buf; - int len; -{ - gif_memory_source *src = current_gif_memory_src; - - if (len > src->len - src->index) - return -1; - - bcopy (src->bytes + src->index, buf, len); - src->index += len; - return len; -} - - -/* Load GIF image IMG for use on frame F. Value is non-zero if - successful. */ - -static int -gif_load (f, img) - struct frame *f; - struct image *img; -{ - Lisp_Object file, specified_file; - Lisp_Object specified_data; - int rc, width, height, x, y, i; - XImagePtr ximg; - ColorMapObject *gif_color_map; - unsigned long pixel_colors[256]; - GifFileType *gif; - struct gcpro gcpro1; - Lisp_Object image; - int ino, image_left, image_top, image_width, image_height; - gif_memory_source memsrc; - unsigned char *raster; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - if (NILP (specified_data)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - /* Open the GIF file. */ - gif = DGifOpenFileName (SDATA (file)); - if (gif == NULL) - { - image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; - return 0; - } - } - else - { - /* Read from memory! */ - current_gif_memory_src = &memsrc; - memsrc.bytes = SDATA (specified_data); - memsrc.len = SBYTES (specified_data); - memsrc.index = 0; - - gif = DGifOpen (&memsrc, gif_read_from_memory); - if (!gif) - { - image_error ("Cannot open memory source `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - } - - /* Read entire contents. */ - rc = DGifSlurp (gif); - if (rc == GIF_ERROR) - { - image_error ("Error reading `%s'", img->spec, Qnil); - DGifCloseFile (gif); - UNGCPRO; - return 0; - } - - image = image_spec_value (img->spec, QCindex, NULL); - ino = INTEGERP (image) ? XFASTINT (image) : 0; - if (ino >= gif->ImageCount) - { - image_error ("Invalid image number `%s' in image `%s'", - image, img->spec); - DGifCloseFile (gif); - UNGCPRO; - return 0; - } - - width = img->width = max (gif->SWidth, gif->Image.Left + gif->Image.Width); - height = img->height = max (gif->SHeight, gif->Image.Top + gif->Image.Height); - - /* Create the X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - { - DGifCloseFile (gif); - UNGCPRO; - return 0; - } - - /* Allocate colors. */ - gif_color_map = gif->SavedImages[ino].ImageDesc.ColorMap; - if (!gif_color_map) - gif_color_map = gif->SColorMap; -#if 0 /* TODO: Color tables */ - init_color_table (); -#endif - bzero (pixel_colors, sizeof pixel_colors); - - for (i = 0; i < gif_color_map->ColorCount; ++i) - { - int r = gif_color_map->Colors[i].Red << 8; - int g = gif_color_map->Colors[i].Green << 8; - int b = gif_color_map->Colors[i].Blue << 8; - pixel_colors[i] = lookup_rgb_color (f, r, g, b); - } - -#if 0 /* TODO: Color tables */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif - - /* Clear the part of the screen image that are not covered by - the image from the GIF file. Full animated GIF support - requires more than can be done here (see the gif89 spec, - disposal methods). Let's simply assume that the part - not covered by a sub-image is in the frame's background color. */ - image_top = gif->SavedImages[ino].ImageDesc.Top; - image_left = gif->SavedImages[ino].ImageDesc.Left; - image_width = gif->SavedImages[ino].ImageDesc.Width; - image_height = gif->SavedImages[ino].ImageDesc.Height; - - for (y = 0; y < image_top; ++y) - for (x = 0; x < width; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - - for (y = image_top + image_height; y < height; ++y) - for (x = 0; x < width; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - - for (y = image_top; y < image_top + image_height; ++y) - { - for (x = 0; x < image_left; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - for (x = image_left + image_width; x < width; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - } - - /* Read the GIF image into the X image. We use a local variable - `raster' here because RasterBits below is a char *, and invites - problems with bytes >= 0x80. */ - raster = (unsigned char *) gif->SavedImages[ino].RasterBits; - - if (gif->SavedImages[ino].ImageDesc.Interlace) - { - static int interlace_start[] = {0, 4, 2, 1}; - static int interlace_increment[] = {8, 8, 4, 2}; - int pass; - int row = interlace_start[0]; - - pass = 0; - - for (y = 0; y < image_height; y++) - { - if (row >= image_height) - { - row = interlace_start[++pass]; - while (row >= image_height) - row = interlace_start[++pass]; - } - - for (x = 0; x < image_width; x++) - { - int i = raster[(y * image_width) + x]; - XPutPixel (ximg, x + image_left, row + image_top, - pixel_colors[i]); - } - - row += interlace_increment[pass]; - } - } - else - { - for (y = 0; y < image_height; ++y) - for (x = 0; x < image_width; ++x) - { - int i = raster[y * image_width + x]; - XPutPixel (ximg, x + image_left, y + image_top, pixel_colors[i]); - } - } - - DGifCloseFile (gif); - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap, then free the X image and its buffer. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - - UNGCPRO; - return 1; -} -#endif /* HAVE_GIF */ - - - -/*********************************************************************** - Ghostscript - ***********************************************************************/ - -/* The symbol `postscript' identifying images of this type. */ - -Lisp_Object Qpostscript; - -/* Keyword symbols. */ - -Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height; - -#ifdef HAVE_GHOSTSCRIPT -static int gs_image_p P_ ((Lisp_Object object)); -static int gs_load P_ ((struct frame *f, struct image *img)); -static void gs_clear_image P_ ((struct frame *f, struct image *img)); - -/* Indices of image specification fields in gs_format, below. */ - -enum gs_keyword_index -{ - GS_TYPE, - GS_PT_WIDTH, - GS_PT_HEIGHT, - GS_FILE, - GS_LOADER, - GS_BOUNDING_BOX, - GS_ASCENT, - GS_MARGIN, - GS_RELIEF, - GS_ALGORITHM, - GS_HEURISTIC_MASK, - GS_MASK, - GS_BACKGROUND, - GS_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword gs_format[GS_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":pt-width", IMAGE_POSITIVE_INTEGER_VALUE, 1}, - {":pt-height", IMAGE_POSITIVE_INTEGER_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 1}, - {":loader", IMAGE_FUNCTION_VALUE, 0}, - {":bounding-box", IMAGE_DONT_CHECK_VALUE_TYPE, 1}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `ghostscript'. */ - -static struct image_type gs_type = -{ - &Qpostscript, - gs_image_p, - gs_load, - gs_clear_image, - NULL -}; - - -/* Free X resources of Ghostscript image IMG which is used on frame F. */ - -static void -gs_clear_image (f, img) - struct frame *f; - struct image *img; -{ - /* IMG->data.ptr_val may contain a recorded colormap. */ - xfree (img->data.ptr_val); - x_clear_image (f, img); -} - - -/* Return non-zero if OBJECT is a valid Ghostscript image - specification. */ - -static int -gs_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[GS_LAST]; - Lisp_Object tem; - int i; - - bcopy (gs_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, GS_LAST, Qpostscript)) - return 0; - - /* Bounding box must be a list or vector containing 4 integers. */ - tem = fmt[GS_BOUNDING_BOX].value; - if (CONSP (tem)) - { - for (i = 0; i < 4; ++i, tem = XCDR (tem)) - if (!CONSP (tem) || !INTEGERP (XCAR (tem))) - return 0; - if (!NILP (tem)) - return 0; - } - else if (VECTORP (tem)) - { - if (XVECTOR (tem)->size != 4) - return 0; - for (i = 0; i < 4; ++i) - if (!INTEGERP (XVECTOR (tem)->contents[i])) - return 0; - } - else - return 0; - - return 1; -} - - -/* Load Ghostscript image IMG for use on frame F. Value is non-zero - if successful. */ - -static int -gs_load (f, img) - struct frame *f; - struct image *img; -{ - char buffer[100]; - Lisp_Object window_and_pixmap_id = Qnil, loader, pt_height, pt_width; - struct gcpro gcpro1, gcpro2; - Lisp_Object frame; - double in_width, in_height; - Lisp_Object pixel_colors = Qnil; - - /* Compute pixel size of pixmap needed from the given size in the - image specification. Sizes in the specification are in pt. 1 pt - = 1/72 in, xdpi and ydpi are stored in the frame's X display - info. */ - pt_width = image_spec_value (img->spec, QCpt_width, NULL); - in_width = XFASTINT (pt_width) / 72.0; - img->width = in_width * FRAME_MAC_DISPLAY_INFO (f)->resx; - pt_height = image_spec_value (img->spec, QCpt_height, NULL); - in_height = XFASTINT (pt_height) / 72.0; - img->height = in_height * FRAME_MAC_DISPLAY_INFO (f)->resy; - - /* Create the pixmap. */ - xassert (img->pixmap == NULL); - img->pixmap = XCreatePixmap (FRAME_MAC_DISPLAY (f), FRAME_MAC_WINDOW (f), - img->width, img->height, - one_mac_display_info.n_planes); - - if (!img->pixmap) - { - image_error ("Unable to create pixmap for `%s'", img->spec, Qnil); - return 0; - } - - /* Call the loader to fill the pixmap. It returns a process object - if successful. We do not record_unwind_protect here because - other places in redisplay like calling window scroll functions - don't either. Let the Lisp loader use `unwind-protect' instead. */ - GCPRO2 (window_and_pixmap_id, pixel_colors); - - sprintf (buffer, "%lu %lu", - (unsigned long) FRAME_MAC_WINDOW (f), - (unsigned long) img->pixmap); - window_and_pixmap_id = build_string (buffer); - - sprintf (buffer, "%lu %lu", - FRAME_FOREGROUND_PIXEL (f), - FRAME_BACKGROUND_PIXEL (f)); - pixel_colors = build_string (buffer); - - XSETFRAME (frame, f); - loader = image_spec_value (img->spec, QCloader, NULL); - if (NILP (loader)) - loader = intern ("gs-load-image"); - - img->data.lisp_val = call6 (loader, frame, img->spec, - make_number (img->width), - make_number (img->height), - window_and_pixmap_id, - pixel_colors); - UNGCPRO; - return PROCESSP (img->data.lisp_val); -} - - -/* Kill the Ghostscript process that was started to fill PIXMAP on - frame F. Called from XTread_socket when receiving an event - telling Emacs that Ghostscript has finished drawing. */ - -void -x_kill_gs_process (pixmap, f) - Pixmap pixmap; - struct frame *f; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - int class, i; - struct image *img; - - /* Find the image containing PIXMAP. */ - for (i = 0; i < c->used; ++i) - if (c->images[i]->pixmap == pixmap) - break; - - /* Should someone in between have cleared the image cache, for - instance, give up. */ - if (i == c->used) - return; - - /* Kill the GS process. We should have found PIXMAP in the image - cache and its image should contain a process object. */ - img = c->images[i]; - xassert (PROCESSP (img->data.lisp_val)); - Fkill_process (img->data.lisp_val, Qnil); - img->data.lisp_val = Qnil; - -#if 0 - /* On displays with a mutable colormap, figure out the colors - allocated for the image by looking at the pixels of an XImage for - img->pixmap. */ - class = FRAME_MAC_DISPLAY_INFO (f)->visual->class; - if (class != StaticColor && class != StaticGray && class != TrueColor) - { - XImagePtr ximg; - - BLOCK_INPUT; - - /* Try to get an XImage for img->pixmep. */ - ximg = XGetImage (FRAME_MAC_DISPLAY (f), img->pixmap, - 0, 0, img->width, img->height, ~0, ZPixmap); - if (ximg) - { - int x, y; - - /* Initialize the color table. */ - init_color_table (); - - /* For each pixel of the image, look its color up in the - color table. After having done so, the color table will - contain an entry for each color used by the image. */ - for (y = 0; y < img->height; ++y) - for (x = 0; x < img->width; ++x) - { - unsigned long pixel = XGetPixel (ximg, x, y); - lookup_pixel_color (f, pixel); - } - - /* Record colors in the image. Free color table and XImage. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); - XDestroyImage (ximg); - -#if 0 /* This doesn't seem to be the case. If we free the colors - here, we get a BadAccess later in x_clear_image when - freeing the colors. */ - /* We have allocated colors once, but Ghostscript has also - allocated colors on behalf of us. So, to get the - reference counts right, free them once. */ - if (img->ncolors) - x_free_colors (f, img->colors, img->ncolors); -#endif - } - else - image_error ("Cannot get X image of `%s'; colors will not be freed", - img->spec, Qnil); - - UNBLOCK_INPUT; - } -#endif - - /* Now that we have the pixmap, compute mask and transform the - image if requested. */ - BLOCK_INPUT; - postprocess_image (f, img); - UNBLOCK_INPUT; -} - -#endif /* HAVE_GHOSTSCRIPT */ - /*********************************************************************** Window properties @@ -10001,38 +4195,6 @@ /*********************************************************************** - Tests - ***********************************************************************/ - -#if GLYPH_DEBUG - -DEFUN ("imagep", Fimagep, Simagep, 1, 1, 0, - doc: /* Value is non-nil if SPEC is a valid image specification. */) - (spec) - Lisp_Object spec; -{ - return valid_image_p (spec) ? Qt : Qnil; -} - - -DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, "") - (spec) - Lisp_Object spec; -{ - int id = -1; - - if (valid_image_p (spec)) - id = lookup_image (SELECTED_FRAME (), spec); - - debug_print (spec); - return make_number (id); -} - -#endif /* GLYPH_DEBUG != 0 */ - - - -/*********************************************************************** Initialization ***********************************************************************/ @@ -10087,8 +4249,6 @@ staticpro (&Qsuppress_icon); Qundefined_color = intern ("undefined-color"); staticpro (&Qundefined_color); - Qcenter = intern ("center"); - staticpro (&Qcenter); /* This is the end of symbol initialization. */ Qhyper = intern ("hyper"); @@ -10110,22 +4270,6 @@ Vtext_property_default_nonsticky = Fcons (Fcons (Qdisplay, Qt), Vtext_property_default_nonsticky); - - Qlaplace = intern ("laplace"); - staticpro (&Qlaplace); - Qemboss = intern ("emboss"); - staticpro (&Qemboss); - Qedge_detection = intern ("edge-detection"); - staticpro (&Qedge_detection); - Qheuristic = intern ("heuristic"); - staticpro (&Qheuristic); - QCmatrix = intern (":matrix"); - staticpro (&QCmatrix); - QCcolor_adjustment = intern (":color-adjustment"); - staticpro (&QCcolor_adjustment); - QCmask = intern (":mask"); - staticpro (&QCmask); - Qface_set_after_frame_default = intern ("face-set-after-frame-default"); staticpro (&Qface_set_after_frame_default); @@ -10134,16 +4278,6 @@ Fput (Qundefined_color, Qerror_message, build_string ("Undefined color")); - DEFVAR_BOOL ("cross-disabled-images", &cross_disabled_images, - doc: /* Non-nil means always draw a cross over disabled images. -Disabled images are those having an `:conversion disabled' property. -A cross is always drawn on black & white displays. */); - cross_disabled_images = 0; - - DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path, - doc: /* List of directories to search for window system bitmap files. */); - Vx_bitmap_file_path = decode_env_path ((char *) 0, "PATH"); - DEFVAR_LISP ("x-pointer-shape", &Vx_pointer_shape, doc: /* The shape of the pointer when over text. Changing the value does not affect existing frames @@ -10198,13 +4332,6 @@ Chinese, Japanese, and Korean. */); Vx_pixel_size_width_font_regexp = Qnil; - DEFVAR_LISP ("image-cache-eviction-delay", &Vimage_cache_eviction_delay, - doc: /* Time after which cached images are removed from the cache. -When an image has not been displayed this many seconds, remove it -from the image cache. Value must be an integer or nil with nil -meaning don't clear the cache. */); - Vimage_cache_eviction_delay = make_number (30 * 60); - /* X window properties. */ defsubr (&Sx_change_window_property); defsubr (&Sx_delete_window_property); @@ -10249,62 +4376,6 @@ set_frame_fontset_func = x_set_font; check_window_system_func = check_mac; - /* Images. */ - Qxbm = intern ("xbm"); - staticpro (&Qxbm); - QCconversion = intern (":conversion"); - staticpro (&QCconversion); - QCheuristic_mask = intern (":heuristic-mask"); - staticpro (&QCheuristic_mask); - QCcolor_symbols = intern (":color-symbols"); - staticpro (&QCcolor_symbols); - QCascent = intern (":ascent"); - staticpro (&QCascent); - QCmargin = intern (":margin"); - staticpro (&QCmargin); - QCrelief = intern (":relief"); - staticpro (&QCrelief); - Qpostscript = intern ("postscript"); - staticpro (&Qpostscript); - QCloader = intern (":loader"); - staticpro (&QCloader); - QCbounding_box = intern (":bounding-box"); - staticpro (&QCbounding_box); - QCpt_width = intern (":pt-width"); - staticpro (&QCpt_width); - QCpt_height = intern (":pt-height"); - staticpro (&QCpt_height); - QCindex = intern (":index"); - staticpro (&QCindex); - Qpbm = intern ("pbm"); - staticpro (&Qpbm); - -#if HAVE_XPM - Qxpm = intern ("xpm"); - staticpro (&Qxpm); -#endif - - Qjpeg = intern ("jpeg"); - staticpro (&Qjpeg); - - Qtiff = intern ("tiff"); - staticpro (&Qtiff); - - Qgif = intern ("gif"); - staticpro (&Qgif); - - Qpng = intern ("png"); - staticpro (&Qpng); - - defsubr (&Sclear_image_cache); - defsubr (&Simage_size); - defsubr (&Simage_mask_p); - -#if GLYPH_DEBUG - defsubr (&Simagep); - defsubr (&Slookup_image); -#endif - hourglass_atimer = NULL; hourglass_shown_p = 0; @@ -10320,35 +4391,5 @@ #endif } - -void -init_xfns () -{ - image_types = NULL; - Vimage_types = Qnil; - - define_image_type (&xbm_type); -#if HAVE_GHOSTSCRIPT - define_image_type (&gs_type); -#endif - define_image_type (&pbm_type); - -#if HAVE_XPM - define_image_type (&xpm_type); -#endif - - define_image_type (&jpeg_type); - define_image_type (&tiff_type); - define_image_type (&gif_type); - define_image_type (&png_type); - - /* Animated gifs use QuickTime Movie Toolbox. So initialize it - here. */ - EnterMovies (); -#ifdef MAC_OSX - init_image_func_pointer (); -#endif -} - /* arch-tag: d7591289-f374-4377-b245-12f5dbbb8edc (do not change this comment) */
--- a/src/macterm.c Thu Mar 11 02:31:12 2004 +0000 +++ b/src/macterm.c Tue Mar 16 20:27:22 2004 +0000 @@ -8262,7 +8262,6 @@ { Lisp_Object window; - inev.kind = MOUSE_CLICK_EVENT; XSETFRAME (inev.frame_or_window, mwp->mFP); if (er.what == mouseDown) mouse_tracking_in_progress @@ -8285,6 +8284,8 @@ ); break; } + else + inev.kind = MOUSE_CLICK_EVENT; } #if USE_CARBON_EVENTS
--- a/src/macterm.h Thu Mar 11 02:31:12 2004 +0000 +++ b/src/macterm.h Tue Mar 16 20:27:22 2004 +0000 @@ -56,6 +56,7 @@ struct mac_bitmap_record { char *bitmap_data; + char *file; int refcount; int height, width; }; @@ -239,6 +240,12 @@ extern struct mac_display_info *mac_term_init (); +extern Lisp_Object x_list_fonts P_ ((struct frame *, Lisp_Object, int, int)); +extern struct font_info *x_get_font_info P_ ((struct frame *f, int)); +extern struct font_info *x_load_font P_ ((struct frame *, char *, int)); +extern struct font_info *x_query_font P_ ((struct frame *, char *)); +extern void x_find_ccl_program P_ ((struct font_info *)); + /* When Emacs uses a tty window, tty_display in frame.c points to an x_output struct . */ struct x_output @@ -561,6 +568,22 @@ void activate_scroll_bars (FRAME_PTR); void deactivate_scroll_bars (FRAME_PTR); +/* Defined in macterm.c. */ + +extern void x_set_window_size P_ ((struct frame *, int, int, int)); +extern void x_make_frame_visible P_ ((struct frame *)); +extern void mac_initialize P_ ((void)); +extern Pixmap XCreatePixmap P_ ((Display *, WindowPtr, unsigned int, + unsigned int, unsigned int)); +extern Pixmap XCreatePixmapFromBitmapData P_ ((Display *, WindowPtr, char *, + unsigned int, unsigned int, + unsigned long, unsigned long, + unsigned int)); +extern void XFreePixmap P_ ((Display *, Pixmap)); +extern void XSetForeground P_ ((Display *, GC, unsigned long)); +extern void mac_draw_line_to_pixmap P_ ((Display *, Pixmap, GC, int, int, + int, int)); + #define FONT_TYPE_FOR_UNIBYTE(font, ch) 0 #define FONT_TYPE_FOR_MULTIBYTE(font, ch) 0
--- a/src/makefile.w32-in Thu Mar 11 02:31:12 2004 +0000 +++ b/src/makefile.w32-in Tue Mar 16 20:27:22 2004 +0000 @@ -119,7 +119,8 @@ $(BLD)/category.$(O) \ $(BLD)/ccl.$(O) \ $(BLD)/fontset.$(O) \ - $(BLD)/fringe.$(O) + $(BLD)/fringe.$(O) \ + $(BLD)/image.$(O) WIN32OBJ = $(BLD)/w32term.$(O) \ $(BLD)/w32xfns.$(O) \ @@ -746,6 +747,24 @@ $(EMACS_ROOT)/nt/inc/sys/param.h \ $(SRC)/getpagesize.h +$(BLD)/image.$(O): \ + $(SRC)/image.c \ + $(EMACS_ROOT)/src/s/ms-w32.h \ + $(EMACS_ROOT)/src/m/intel386.h \ + $(EMACS_ROOT)/src/config.h \ + $(SRC)/atimer.h \ + $(SRC)/blockinput.h \ + $(SRC)/dispextern.h \ + $(SRC)/epaths.h \ + $(SRC)/frame.h \ + $(SRC)/systime.h \ + $(SRC)/termhooks.h \ + $(SRC)/w32bdf.h \ + $(SRC)/w32gui.h \ + $(SRC)/w32heap.h \ + $(SRC)/w32term.h \ + $(SRC)/window.h + $(BLD)/indent.$(O) : \ $(SRC)/indent.c \ $(EMACS_ROOT)/src/s/ms-w32.h \
--- a/src/w32fns.c Thu Mar 11 02:31:12 2004 +0000 +++ b/src/w32fns.c Tue Mar 16 20:27:22 2004 +0000 @@ -58,7 +58,6 @@ void syms_of_w32fns (); void globals_of_w32fns (); -static void init_external_image_libraries (); extern void free_frame_menubar (); extern double atof (); @@ -171,10 +170,6 @@ static int w32_in_use; -/* Search path for bitmap files. */ - -Lisp_Object Vx_bitmap_file_path; - /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'. */ Lisp_Object Vx_pixel_size_width_font_regexp; @@ -200,7 +195,6 @@ Lisp_Object Qnone; Lisp_Object Qsuppress_icon; Lisp_Object Qundefined_color; -Lisp_Object Qcenter; Lisp_Object Qcancel_timer; Lisp_Object Qhyper; Lisp_Object Qsuper; @@ -396,225 +390,6 @@ } - -/* Code to deal with bitmaps. Bitmaps are referenced by their bitmap - id, which is just an int that this section returns. Bitmaps are - reference counted so they can be shared among frames. - - Bitmap indices are guaranteed to be > 0, so a negative number can - be used to indicate no bitmap. - - If you use x_create_bitmap_from_data, then you must keep track of - the bitmaps yourself. That is, creating a bitmap from the same - data more than once will not be caught. */ - - -/* Functions to access the contents of a bitmap, given an id. */ - -int -x_bitmap_height (f, id) - FRAME_PTR f; - int id; -{ - return FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].height; -} - -int -x_bitmap_width (f, id) - FRAME_PTR f; - int id; -{ - return FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].width; -} - -int -x_bitmap_pixmap (f, id) - FRAME_PTR f; - int id; -{ - return (int) FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].pixmap; -} - - -/* Allocate a new bitmap record. Returns index of new record. */ - -static int -x_allocate_bitmap_record (f) - FRAME_PTR f; -{ - struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f); - int i; - - if (dpyinfo->bitmaps == NULL) - { - dpyinfo->bitmaps_size = 10; - dpyinfo->bitmaps - = (struct w32_bitmap_record *) xmalloc (dpyinfo->bitmaps_size * sizeof (struct w32_bitmap_record)); - dpyinfo->bitmaps_last = 1; - return 1; - } - - if (dpyinfo->bitmaps_last < dpyinfo->bitmaps_size) - return ++dpyinfo->bitmaps_last; - - for (i = 0; i < dpyinfo->bitmaps_size; ++i) - if (dpyinfo->bitmaps[i].refcount == 0) - return i + 1; - - dpyinfo->bitmaps_size *= 2; - dpyinfo->bitmaps - = (struct w32_bitmap_record *) xrealloc (dpyinfo->bitmaps, - dpyinfo->bitmaps_size * sizeof (struct w32_bitmap_record)); - return ++dpyinfo->bitmaps_last; -} - -/* Add one reference to the reference count of the bitmap with id ID. */ - -void -x_reference_bitmap (f, id) - FRAME_PTR f; - int id; -{ - ++FRAME_W32_DISPLAY_INFO (f)->bitmaps[id - 1].refcount; -} - -/* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at BITS. */ - -int -x_create_bitmap_from_data (f, bits, width, height) - struct frame *f; - char *bits; - unsigned int width, height; -{ - struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f); - Pixmap bitmap; - int id; - - bitmap = CreateBitmap (width, height, - FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_planes, - FRAME_W32_DISPLAY_INFO (XFRAME (frame))->n_cbits, - bits); - - if (! bitmap) - return -1; - - id = x_allocate_bitmap_record (f); - dpyinfo->bitmaps[id - 1].pixmap = bitmap; - dpyinfo->bitmaps[id - 1].file = NULL; - dpyinfo->bitmaps[id - 1].hinst = NULL; - dpyinfo->bitmaps[id - 1].refcount = 1; - dpyinfo->bitmaps[id - 1].depth = 1; - dpyinfo->bitmaps[id - 1].height = height; - dpyinfo->bitmaps[id - 1].width = width; - - return id; -} - -/* Create bitmap from file FILE for frame F. */ - -int -x_create_bitmap_from_file (f, file) - struct frame *f; - Lisp_Object file; -{ - return -1; -#if 0 /* TODO : bitmap support */ - struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f); - unsigned int width, height; - HBITMAP bitmap; - int xhot, yhot, result, id; - Lisp_Object found; - int fd; - char *filename; - HINSTANCE hinst; - - /* Look for an existing bitmap with the same name. */ - for (id = 0; id < dpyinfo->bitmaps_last; ++id) - { - if (dpyinfo->bitmaps[id].refcount - && dpyinfo->bitmaps[id].file - && !strcmp (dpyinfo->bitmaps[id].file, (char *) SDATA (file))) - { - ++dpyinfo->bitmaps[id].refcount; - return id + 1; - } - } - - /* Search bitmap-file-path for the file, if appropriate. */ - fd = openp (Vx_bitmap_file_path, file, Qnil, &found, Qnil); - if (fd < 0) - return -1; - emacs_close (fd); - - filename = (char *) SDATA (found); - - hinst = LoadLibraryEx (filename, NULL, LOAD_LIBRARY_AS_DATAFILE); - - if (hinst == NULL) - return -1; - - - result = XReadBitmapFile (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), - filename, &width, &height, &bitmap, &xhot, &yhot); - if (result != BitmapSuccess) - return -1; - - id = x_allocate_bitmap_record (f); - dpyinfo->bitmaps[id - 1].pixmap = bitmap; - dpyinfo->bitmaps[id - 1].refcount = 1; - dpyinfo->bitmaps[id - 1].file = (char *) xmalloc (SCHARS (file) + 1); - dpyinfo->bitmaps[id - 1].depth = 1; - dpyinfo->bitmaps[id - 1].height = height; - dpyinfo->bitmaps[id - 1].width = width; - strcpy (dpyinfo->bitmaps[id - 1].file, SDATA (file)); - - return id; -#endif /* TODO */ -} - -/* Remove reference to bitmap with id number ID. */ - -void -x_destroy_bitmap (f, id) - FRAME_PTR f; - int id; -{ - struct w32_display_info *dpyinfo = FRAME_W32_DISPLAY_INFO (f); - - if (id > 0) - { - --dpyinfo->bitmaps[id - 1].refcount; - if (dpyinfo->bitmaps[id - 1].refcount == 0) - { - BLOCK_INPUT; - DeleteObject (dpyinfo->bitmaps[id - 1].pixmap); - if (dpyinfo->bitmaps[id - 1].file) - { - xfree (dpyinfo->bitmaps[id - 1].file); - dpyinfo->bitmaps[id - 1].file = NULL; - } - UNBLOCK_INPUT; - } - } -} - -/* Free all the bitmaps for the display specified by DPYINFO. */ - -static void -x_destroy_all_bitmaps (dpyinfo) - struct w32_display_info *dpyinfo; -{ - int i; - for (i = 0; i < dpyinfo->bitmaps_last; i++) - if (dpyinfo->bitmaps[i].refcount > 0) - { - DeleteObject (dpyinfo->bitmaps[i].pixmap); - if (dpyinfo->bitmaps[i].file) - xfree (dpyinfo->bitmaps[i].file); - } - dpyinfo->bitmaps_last = 0; -} - BOOL my_show_window P_ ((struct frame *, HWND, int)); void my_set_window_pos P_ ((HWND, HWND, int, int, int, int, UINT)); static Lisp_Object unwind_create_frame P_ ((Lisp_Object)); @@ -6929,5475 +6704,6 @@ return Qnil; } - -/*********************************************************************** - Image types - ***********************************************************************/ - -/* Value is the number of elements of vector VECTOR. */ - -#define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR)) - -/* List of supported image types. Use define_image_type to add new - types. Use lookup_image_type to find a type for a given symbol. */ - -static struct image_type *image_types; - -/* The symbol `xbm' which is used as the type symbol for XBM images. */ - -Lisp_Object Qxbm; - -/* Keywords. */ - -extern Lisp_Object QCwidth, QCheight, QCforeground, QCbackground, QCfile; -extern Lisp_Object QCdata, QCtype; -Lisp_Object QCascent, QCmargin, QCrelief; -Lisp_Object QCconversion, QCcolor_symbols, QCheuristic_mask; -Lisp_Object QCindex, QCmatrix, QCcolor_adjustment, QCmask; - -/* Other symbols. */ - -Lisp_Object Qlaplace, Qemboss, Qedge_detection, Qheuristic; - -/* Time in seconds after which images should be removed from the cache - if not displayed. */ - -Lisp_Object Vimage_cache_eviction_delay; - -/* Function prototypes. */ - -static void define_image_type P_ ((struct image_type *type)); -static struct image_type *lookup_image_type P_ ((Lisp_Object symbol)); -static void image_error P_ ((char *format, Lisp_Object, Lisp_Object)); -static void x_laplace P_ ((struct frame *, struct image *)); -static void x_emboss P_ ((struct frame *, struct image *)); -static int x_build_heuristic_mask P_ ((struct frame *, struct image *, - Lisp_Object)); - - -/* Define a new image type from TYPE. This adds a copy of TYPE to - image_types and adds the symbol *TYPE->type to Vimage_types. */ - -static void -define_image_type (type) - struct image_type *type; -{ - /* Make a copy of TYPE to avoid a bus error in a dumped Emacs. - The initialized data segment is read-only. */ - struct image_type *p = (struct image_type *) xmalloc (sizeof *p); - bcopy (type, p, sizeof *p); - p->next = image_types; - image_types = p; - Vimage_types = Fcons (*p->type, Vimage_types); -} - - -/* Look up image type SYMBOL, and return a pointer to its image_type - structure. Value is null if SYMBOL is not a known image type. */ - -static INLINE struct image_type * -lookup_image_type (symbol) - Lisp_Object symbol; -{ - struct image_type *type; - - for (type = image_types; type; type = type->next) - if (EQ (symbol, *type->type)) - break; - - return type; -} - - -/* Value is non-zero if OBJECT is a valid Lisp image specification. A - valid image specification is a list whose car is the symbol - `image', and whose rest is a property list. The property list must - contain a value for key `:type'. That value must be the name of a - supported image type. The rest of the property list depends on the - image type. */ - -int -valid_image_p (object) - Lisp_Object object; -{ - int valid_p = 0; - - if (IMAGEP (object)) - { - Lisp_Object tem; - - for (tem = XCDR (object); CONSP (tem); tem = XCDR (tem)) - if (EQ (XCAR (tem), QCtype)) - { - tem = XCDR (tem); - if (CONSP (tem) && SYMBOLP (XCAR (tem))) - { - struct image_type *type; - type = lookup_image_type (XCAR (tem)); - if (type) - valid_p = type->valid_p (object); - } - - break; - } - } - - return valid_p; -} - - -/* Log error message with format string FORMAT and argument ARG. - Signaling an error, e.g. when an image cannot be loaded, is not a - good idea because this would interrupt redisplay, and the error - message display would lead to another redisplay. This function - therefore simply displays a message. */ - -static void -image_error (format, arg1, arg2) - char *format; - Lisp_Object arg1, arg2; -{ - add_to_log (format, arg1, arg2); -} - - - -/*********************************************************************** - Image specifications - ***********************************************************************/ - -enum image_value_type -{ - IMAGE_DONT_CHECK_VALUE_TYPE, - IMAGE_STRING_VALUE, - IMAGE_STRING_OR_NIL_VALUE, - IMAGE_SYMBOL_VALUE, - IMAGE_POSITIVE_INTEGER_VALUE, - IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, - IMAGE_NON_NEGATIVE_INTEGER_VALUE, - IMAGE_ASCENT_VALUE, - IMAGE_INTEGER_VALUE, - IMAGE_FUNCTION_VALUE, - IMAGE_NUMBER_VALUE, - IMAGE_BOOL_VALUE -}; - -/* Structure used when parsing image specifications. */ - -struct image_keyword -{ - /* Name of keyword. */ - char *name; - - /* The type of value allowed. */ - enum image_value_type type; - - /* Non-zero means key must be present. */ - int mandatory_p; - - /* Used to recognize duplicate keywords in a property list. */ - int count; - - /* The value that was found. */ - Lisp_Object value; -}; - - -static int parse_image_spec P_ ((Lisp_Object, struct image_keyword *, - int, Lisp_Object)); -static Lisp_Object image_spec_value P_ ((Lisp_Object, Lisp_Object, int *)); - - -/* Parse image spec SPEC according to KEYWORDS. A valid image spec - has the format (image KEYWORD VALUE ...). One of the keyword/ - value pairs must be `:type TYPE'. KEYWORDS is a vector of - image_keywords structures of size NKEYWORDS describing other - allowed keyword/value pairs. Value is non-zero if SPEC is valid. */ - -static int -parse_image_spec (spec, keywords, nkeywords, type) - Lisp_Object spec; - struct image_keyword *keywords; - int nkeywords; - Lisp_Object type; -{ - int i; - Lisp_Object plist; - - if (!IMAGEP (spec)) - return 0; - - plist = XCDR (spec); - while (CONSP (plist)) - { - Lisp_Object key, value; - - /* First element of a pair must be a symbol. */ - key = XCAR (plist); - plist = XCDR (plist); - if (!SYMBOLP (key)) - return 0; - - /* There must follow a value. */ - if (!CONSP (plist)) - return 0; - value = XCAR (plist); - plist = XCDR (plist); - - /* Find key in KEYWORDS. Error if not found. */ - for (i = 0; i < nkeywords; ++i) - if (strcmp (keywords[i].name, SDATA (SYMBOL_NAME (key))) == 0) - break; - - if (i == nkeywords) - continue; - - /* Record that we recognized the keyword. If a keywords - was found more than once, it's an error. */ - keywords[i].value = value; - ++keywords[i].count; - - if (keywords[i].count > 1) - return 0; - - /* Check type of value against allowed type. */ - switch (keywords[i].type) - { - case IMAGE_STRING_VALUE: - if (!STRINGP (value)) - return 0; - break; - - case IMAGE_STRING_OR_NIL_VALUE: - if (!STRINGP (value) && !NILP (value)) - return 0; - break; - - case IMAGE_SYMBOL_VALUE: - if (!SYMBOLP (value)) - return 0; - break; - - case IMAGE_POSITIVE_INTEGER_VALUE: - if (!INTEGERP (value) || XINT (value) <= 0) - return 0; - break; - - case IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR: - if (INTEGERP (value) && XINT (value) >= 0) - break; - if (CONSP (value) - && INTEGERP (XCAR (value)) && INTEGERP (XCDR (value)) - && XINT (XCAR (value)) >= 0 && XINT (XCDR (value)) >= 0) - break; - return 0; - - case IMAGE_ASCENT_VALUE: - if (SYMBOLP (value) && EQ (value, Qcenter)) - break; - else if (INTEGERP (value) - && XINT (value) >= 0 - && XINT (value) <= 100) - break; - return 0; - - case IMAGE_NON_NEGATIVE_INTEGER_VALUE: - if (!INTEGERP (value) || XINT (value) < 0) - return 0; - break; - - case IMAGE_DONT_CHECK_VALUE_TYPE: - break; - - case IMAGE_FUNCTION_VALUE: - value = indirect_function (value); - if (SUBRP (value) - || COMPILEDP (value) - || (CONSP (value) && EQ (XCAR (value), Qlambda))) - break; - return 0; - - case IMAGE_NUMBER_VALUE: - if (!INTEGERP (value) && !FLOATP (value)) - return 0; - break; - - case IMAGE_INTEGER_VALUE: - if (!INTEGERP (value)) - return 0; - break; - - case IMAGE_BOOL_VALUE: - if (!NILP (value) && !EQ (value, Qt)) - return 0; - break; - - default: - abort (); - break; - } - - if (EQ (key, QCtype) && !EQ (type, value)) - return 0; - } - - /* Check that all mandatory fields are present. */ - for (i = 0; i < nkeywords; ++i) - if (keywords[i].mandatory_p && keywords[i].count == 0) - return 0; - - return NILP (plist); -} - - -/* Return the value of KEY in image specification SPEC. Value is nil - if KEY is not present in SPEC. if FOUND is not null, set *FOUND - to 1 if KEY was found in SPEC, set it to 0 otherwise. */ - -static Lisp_Object -image_spec_value (spec, key, found) - Lisp_Object spec, key; - int *found; -{ - Lisp_Object tail; - - xassert (valid_image_p (spec)); - - for (tail = XCDR (spec); - CONSP (tail) && CONSP (XCDR (tail)); - tail = XCDR (XCDR (tail))) - { - if (EQ (XCAR (tail), key)) - { - if (found) - *found = 1; - return XCAR (XCDR (tail)); - } - } - - if (found) - *found = 0; - return Qnil; -} - - -DEFUN ("image-size", Fimage_size, Simage_size, 1, 3, 0, - doc: /* Return the size of image SPEC as pair (WIDTH . HEIGHT). -PIXELS non-nil means return the size in pixels, otherwise return the -size in canonical character units. -FRAME is the frame on which the image will be displayed. FRAME nil -or omitted means use the selected frame. */) - (spec, pixels, frame) - Lisp_Object spec, pixels, frame; -{ - Lisp_Object size; - - size = Qnil; - if (valid_image_p (spec)) - { - struct frame *f = check_x_frame (frame); - int id = lookup_image (f, spec); - struct image *img = IMAGE_FROM_ID (f, id); - int width = img->width + 2 * img->hmargin; - int height = img->height + 2 * img->vmargin; - - if (NILP (pixels)) - size = Fcons (make_float ((double) width / FRAME_COLUMN_WIDTH (f)), - make_float ((double) height / FRAME_LINE_HEIGHT (f))); - else - size = Fcons (make_number (width), make_number (height)); - } - else - error ("Invalid image specification"); - - return size; -} - - -DEFUN ("image-mask-p", Fimage_mask_p, Simage_mask_p, 1, 2, 0, - doc: /* Return t if image SPEC has a mask bitmap. -FRAME is the frame on which the image will be displayed. FRAME nil -or omitted means use the selected frame. */) - (spec, frame) - Lisp_Object spec, frame; -{ - Lisp_Object mask; - - mask = Qnil; - if (valid_image_p (spec)) - { - struct frame *f = check_x_frame (frame); - int id = lookup_image (f, spec); - struct image *img = IMAGE_FROM_ID (f, id); - if (img->mask) - mask = Qt; - } - else - error ("Invalid image specification"); - - return mask; -} - - -/*********************************************************************** - Image type independent image structures - ***********************************************************************/ - -static struct image *make_image P_ ((Lisp_Object spec, unsigned hash)); -static void free_image P_ ((struct frame *f, struct image *img)); -static void x_destroy_x_image P_ ((XImage *)); - - -/* Allocate and return a new image structure for image specification - SPEC. SPEC has a hash value of HASH. */ - -static struct image * -make_image (spec, hash) - Lisp_Object spec; - unsigned hash; -{ - struct image *img = (struct image *) xmalloc (sizeof *img); - - xassert (valid_image_p (spec)); - bzero (img, sizeof *img); - img->type = lookup_image_type (image_spec_value (spec, QCtype, NULL)); - xassert (img->type != NULL); - img->spec = spec; - img->data.lisp_val = Qnil; - img->ascent = DEFAULT_IMAGE_ASCENT; - img->hash = hash; - return img; -} - - -/* Free image IMG which was used on frame F, including its resources. */ - -static void -free_image (f, img) - struct frame *f; - struct image *img; -{ - if (img) - { - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - - /* Remove IMG from the hash table of its cache. */ - if (img->prev) - img->prev->next = img->next; - else - c->buckets[img->hash % IMAGE_CACHE_BUCKETS_SIZE] = img->next; - - if (img->next) - img->next->prev = img->prev; - - c->images[img->id] = NULL; - - /* Free resources, then free IMG. */ - img->type->free (f, img); - xfree (img); - } -} - - -/* Prepare image IMG for display on frame F. Must be called before - drawing an image. */ - -void -prepare_image_for_display (f, img) - struct frame *f; - struct image *img; -{ - EMACS_TIME t; - - /* We're about to display IMG, so set its timestamp to `now'. */ - EMACS_GET_TIME (t); - img->timestamp = EMACS_SECS (t); - - /* If IMG doesn't have a pixmap yet, load it now, using the image - type dependent loader function. */ - if (img->pixmap == 0 && !img->load_failed_p) - img->load_failed_p = img->type->load (f, img) == 0; -} - - -/* Value is the number of pixels for the ascent of image IMG when - drawn in face FACE. */ - -int -image_ascent (img, face) - struct image *img; - struct face *face; -{ - int height = img->height + img->vmargin; - int ascent; - - if (img->ascent == CENTERED_IMAGE_ASCENT) - { - if (face->font) - ascent = height / 2 - (FONT_DESCENT(face->font) - - FONT_BASE(face->font)) / 2; - else - ascent = height / 2; - } - else - ascent = (int) (height * img->ascent / 100.0); - - return ascent; -} - - - -/* Image background colors. */ - -/* Find the "best" corner color of a bitmap. XIMG is assumed to a device - context with the bitmap selected. */ -static COLORREF -four_corners_best (img_dc, width, height) - HDC img_dc; - unsigned long width, height; -{ - COLORREF corners[4], best; - int i, best_count; - - /* Get the colors at the corners of img_dc. */ - corners[0] = GetPixel (img_dc, 0, 0); - corners[1] = GetPixel (img_dc, width - 1, 0); - corners[2] = GetPixel (img_dc, width - 1, height - 1); - corners[3] = GetPixel (img_dc, 0, height - 1); - - /* Choose the most frequently found color as background. */ - for (i = best_count = 0; i < 4; ++i) - { - int j, n; - - for (j = n = 0; j < 4; ++j) - if (corners[i] == corners[j]) - ++n; - - if (n > best_count) - best = corners[i], best_count = n; - } - - return best; -} - -/* Return the `background' field of IMG. If IMG doesn't have one yet, - it is guessed heuristically. If non-zero, IMG_DC is an existing - device context with the image selected to use for the heuristic. */ - -unsigned long -image_background (img, f, img_dc) - struct image *img; - struct frame *f; - HDC img_dc; -{ - if (! img->background_valid) - /* IMG doesn't have a background yet, try to guess a reasonable value. */ - { - int free_ximg = !img_dc; - HGDIOBJ prev; - - if (free_ximg) - { - HDC frame_dc = get_frame_dc (f); - img_dc = CreateCompatibleDC (frame_dc); - release_frame_dc (f, frame_dc); - - prev = SelectObject (img_dc, img->pixmap); - } - - img->background = four_corners_best (img_dc, img->width, img->height); - - if (free_ximg) - { - SelectObject (img_dc, prev); - DeleteDC (img_dc); - } - - img->background_valid = 1; - } - - return img->background; -} - -/* Return the `background_transparent' field of IMG. If IMG doesn't - have one yet, it is guessed heuristically. If non-zero, MASK is an - existing XImage object to use for the heuristic. */ - -int -image_background_transparent (img, f, mask) - struct image *img; - struct frame *f; - HDC mask; -{ - if (! img->background_transparent_valid) - /* IMG doesn't have a background yet, try to guess a reasonable value. */ - { - if (img->mask) - { - int free_mask = !mask; - HGDIOBJ prev; - - if (free_mask) - { - HDC frame_dc = get_frame_dc (f); - mask = CreateCompatibleDC (frame_dc); - release_frame_dc (f, frame_dc); - - prev = SelectObject (mask, img->mask); - } - - img->background_transparent - = !four_corners_best (mask, img->width, img->height); - - if (free_mask) - { - SelectObject (mask, prev); - DeleteDC (mask); - } - } - else - img->background_transparent = 0; - - img->background_transparent_valid = 1; - } - - return img->background_transparent; -} - - -/*********************************************************************** - Helper functions for X image types - ***********************************************************************/ - -static void x_clear_image_1 P_ ((struct frame *, struct image *, int, - int, int)); -static void x_clear_image P_ ((struct frame *f, struct image *img)); -static unsigned long x_alloc_image_color P_ ((struct frame *f, - struct image *img, - Lisp_Object color_name, - unsigned long dflt)); - - -/* Clear X resources of image IMG on frame F. PIXMAP_P non-zero means - free the pixmap if any. MASK_P non-zero means clear the mask - pixmap if any. COLORS_P non-zero means free colors allocated for - the image, if any. */ - -static void -x_clear_image_1 (f, img, pixmap_p, mask_p, colors_p) - struct frame *f; - struct image *img; - int pixmap_p, mask_p, colors_p; -{ - if (pixmap_p && img->pixmap) - { - DeleteObject (img->pixmap); - img->pixmap = NULL; - img->background_valid = 0; - } - - if (mask_p && img->mask) - { - DeleteObject (img->mask); - img->mask = NULL; - img->background_transparent_valid = 0; - } - - if (colors_p && img->ncolors) - { -#if 0 /* TODO: color table support. */ - x_free_colors (f, img->colors, img->ncolors); -#endif - xfree (img->colors); - img->colors = NULL; - img->ncolors = 0; - } -} - -/* Free X resources of image IMG which is used on frame F. */ - -static void -x_clear_image (f, img) - struct frame *f; - struct image *img; -{ - if (img->pixmap) - { - BLOCK_INPUT; - DeleteObject (img->pixmap); - img->pixmap = 0; - UNBLOCK_INPUT; - } - - if (img->ncolors) - { -#if 0 /* TODO: color table support */ - - int class = FRAME_W32_DISPLAY_INFO (f)->visual->class; - - /* If display has an immutable color map, freeing colors is not - necessary and some servers don't allow it. So don't do it. */ - if (class != StaticColor - && class != StaticGray - && class != TrueColor) - { - Colormap cmap; - BLOCK_INPUT; - cmap = DefaultColormapOfScreen (FRAME_W32_DISPLAY_INFO (f)->screen); - XFreeColors (FRAME_W32_DISPLAY (f), cmap, img->colors, - img->ncolors, 0); - UNBLOCK_INPUT; - } -#endif - - xfree (img->colors); - img->colors = NULL; - img->ncolors = 0; - } -} - - -/* Allocate color COLOR_NAME for image IMG on frame F. If color - cannot be allocated, use DFLT. Add a newly allocated color to - IMG->colors, so that it can be freed again. Value is the pixel - color. */ - -static unsigned long -x_alloc_image_color (f, img, color_name, dflt) - struct frame *f; - struct image *img; - Lisp_Object color_name; - unsigned long dflt; -{ - XColor color; - unsigned long result; - - xassert (STRINGP (color_name)); - - if (w32_defined_color (f, SDATA (color_name), &color, 1)) - { - /* This isn't called frequently so we get away with simply - reallocating the color vector to the needed size, here. */ - ++img->ncolors; - img->colors = - (unsigned long *) xrealloc (img->colors, - img->ncolors * sizeof *img->colors); - img->colors[img->ncolors - 1] = color.pixel; - result = color.pixel; - } - else - result = dflt; - return result; -} - - - -/*********************************************************************** - Image Cache - ***********************************************************************/ - -static void cache_image P_ ((struct frame *f, struct image *img)); -static void postprocess_image P_ ((struct frame *, struct image *)); -static void x_disable_image P_ ((struct frame *, struct image *)); - - -/* Return a new, initialized image cache that is allocated from the - heap. Call free_image_cache to free an image cache. */ - -struct image_cache * -make_image_cache () -{ - struct image_cache *c = (struct image_cache *) xmalloc (sizeof *c); - int size; - - bzero (c, sizeof *c); - c->size = 50; - c->images = (struct image **) xmalloc (c->size * sizeof *c->images); - size = IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets; - c->buckets = (struct image **) xmalloc (size); - bzero (c->buckets, size); - return c; -} - - -/* Free image cache of frame F. Be aware that X frames share images - caches. */ - -void -free_image_cache (f) - struct frame *f; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - if (c) - { - int i; - - /* Cache should not be referenced by any frame when freed. */ - xassert (c->refcount == 0); - - for (i = 0; i < c->used; ++i) - free_image (f, c->images[i]); - xfree (c->images); - xfree (c); - xfree (c->buckets); - FRAME_X_IMAGE_CACHE (f) = NULL; - } -} - - -/* Clear image cache of frame F. FORCE_P non-zero means free all - images. FORCE_P zero means clear only images that haven't been - displayed for some time. Should be called from time to time to - reduce the number of loaded images. If image-eviction-seconds is - non-nil, this frees images in the cache which weren't displayed for - at least that many seconds. */ - -void -clear_image_cache (f, force_p) - struct frame *f; - int force_p; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - - if (c && INTEGERP (Vimage_cache_eviction_delay)) - { - EMACS_TIME t; - unsigned long old; - int i, nfreed; - - EMACS_GET_TIME (t); - old = EMACS_SECS (t) - XFASTINT (Vimage_cache_eviction_delay); - - /* Block input so that we won't be interrupted by a SIGIO - while being in an inconsistent state. */ - BLOCK_INPUT; - - for (i = nfreed = 0; i < c->used; ++i) - { - struct image *img = c->images[i]; - if (img != NULL - && (force_p || (img->timestamp < old))) - { - free_image (f, img); - ++nfreed; - } - } - - /* We may be clearing the image cache because, for example, - Emacs was iconified for a longer period of time. In that - case, current matrices may still contain references to - images freed above. So, clear these matrices. */ - if (nfreed) - { - Lisp_Object tail, frame; - - FOR_EACH_FRAME (tail, frame) - { - struct frame *f = XFRAME (frame); - if (FRAME_W32_P (f) - && FRAME_X_IMAGE_CACHE (f) == c) - clear_current_matrices (f); - } - - ++windows_or_buffers_changed; - } - - UNBLOCK_INPUT; - } -} - - -DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache, - 0, 1, 0, - doc: /* Clear the image cache of FRAME. -FRAME nil or omitted means use the selected frame. -FRAME t means clear the image caches of all frames. */) - (frame) - Lisp_Object frame; -{ - if (EQ (frame, Qt)) - { - Lisp_Object tail; - - FOR_EACH_FRAME (tail, frame) - if (FRAME_W32_P (XFRAME (frame))) - clear_image_cache (XFRAME (frame), 1); - } - else - clear_image_cache (check_x_frame (frame), 1); - - return Qnil; -} - - -/* Compute masks and transform image IMG on frame F, as specified - by the image's specification, */ - -static void -postprocess_image (f, img) - struct frame *f; - struct image *img; -{ - /* Manipulation of the image's mask. */ - if (img->pixmap) - { - Lisp_Object conversion, spec; - Lisp_Object mask; - - spec = img->spec; - - /* `:heuristic-mask t' - `:mask heuristic' - means build a mask heuristically. - `:heuristic-mask (R G B)' - `:mask (heuristic (R G B))' - means build a mask from color (R G B) in the - image. - `:mask nil' - means remove a mask, if any. */ - - mask = image_spec_value (spec, QCheuristic_mask, NULL); - if (!NILP (mask)) - x_build_heuristic_mask (f, img, mask); - else - { - int found_p; - - mask = image_spec_value (spec, QCmask, &found_p); - - if (EQ (mask, Qheuristic)) - x_build_heuristic_mask (f, img, Qt); - else if (CONSP (mask) - && EQ (XCAR (mask), Qheuristic)) - { - if (CONSP (XCDR (mask))) - x_build_heuristic_mask (f, img, XCAR (XCDR (mask))); - else - x_build_heuristic_mask (f, img, XCDR (mask)); - } - else if (NILP (mask) && found_p && img->mask) - { - DeleteObject (img->mask); - img->mask = NULL; - } - } - - - /* Should we apply an image transformation algorithm? */ - conversion = image_spec_value (spec, QCconversion, NULL); - if (EQ (conversion, Qdisabled)) - x_disable_image (f, img); - else if (EQ (conversion, Qlaplace)) - x_laplace (f, img); - else if (EQ (conversion, Qemboss)) - x_emboss (f, img); - else if (CONSP (conversion) - && EQ (XCAR (conversion), Qedge_detection)) - { - Lisp_Object tem; - tem = XCDR (conversion); - if (CONSP (tem)) - x_edge_detection (f, img, - Fplist_get (tem, QCmatrix), - Fplist_get (tem, QCcolor_adjustment)); - } - } -} - - -/* Return the id of image with Lisp specification SPEC on frame F. - SPEC must be a valid Lisp image specification (see valid_image_p). */ - -int -lookup_image (f, spec) - struct frame *f; - Lisp_Object spec; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - struct image *img; - int i; - unsigned hash; - struct gcpro gcpro1; - EMACS_TIME now; - - /* F must be a window-system frame, and SPEC must be a valid image - specification. */ - xassert (FRAME_WINDOW_P (f)); - xassert (valid_image_p (spec)); - - GCPRO1 (spec); - - /* Look up SPEC in the hash table of the image cache. */ - hash = sxhash (spec, 0); - i = hash % IMAGE_CACHE_BUCKETS_SIZE; - - for (img = c->buckets[i]; img; img = img->next) - if (img->hash == hash && !NILP (Fequal (img->spec, spec))) - break; - - /* If not found, create a new image and cache it. */ - if (img == NULL) - { - extern Lisp_Object Qpostscript; - - BLOCK_INPUT; - img = make_image (spec, hash); - cache_image (f, img); - img->load_failed_p = img->type->load (f, img) == 0; - - /* If we can't load the image, and we don't have a width and - height, use some arbitrary width and height so that we can - draw a rectangle for it. */ - if (img->load_failed_p) - { - Lisp_Object value; - - value = image_spec_value (spec, QCwidth, NULL); - img->width = (INTEGERP (value) - ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH); - value = image_spec_value (spec, QCheight, NULL); - img->height = (INTEGERP (value) - ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT); - } - else - { - /* Handle image type independent image attributes - `:ascent ASCENT', `:margin MARGIN', `:relief RELIEF', - `:background COLOR'. */ - Lisp_Object ascent, margin, relief, bg; - - ascent = image_spec_value (spec, QCascent, NULL); - if (INTEGERP (ascent)) - img->ascent = XFASTINT (ascent); - else if (EQ (ascent, Qcenter)) - img->ascent = CENTERED_IMAGE_ASCENT; - - margin = image_spec_value (spec, QCmargin, NULL); - if (INTEGERP (margin) && XINT (margin) >= 0) - img->vmargin = img->hmargin = XFASTINT (margin); - else if (CONSP (margin) && INTEGERP (XCAR (margin)) - && INTEGERP (XCDR (margin))) - { - if (XINT (XCAR (margin)) > 0) - img->hmargin = XFASTINT (XCAR (margin)); - if (XINT (XCDR (margin)) > 0) - img->vmargin = XFASTINT (XCDR (margin)); - } - - relief = image_spec_value (spec, QCrelief, NULL); - if (INTEGERP (relief)) - { - img->relief = XINT (relief); - img->hmargin += abs (img->relief); - img->vmargin += abs (img->relief); - } - - if (! img->background_valid) - { - bg = image_spec_value (img->spec, QCbackground, NULL); - if (!NILP (bg)) - { - img->background - = x_alloc_image_color (f, img, bg, - FRAME_BACKGROUND_PIXEL (f)); - img->background_valid = 1; - } - } - - /* Do image transformations and compute masks, unless we - don't have the image yet. */ - if (!EQ (*img->type->type, Qpostscript)) - postprocess_image (f, img); - } - - UNBLOCK_INPUT; - xassert (!interrupt_input_blocked); - } - - /* We're using IMG, so set its timestamp to `now'. */ - EMACS_GET_TIME (now); - img->timestamp = EMACS_SECS (now); - - UNGCPRO; - - /* Value is the image id. */ - return img->id; -} - - -/* Cache image IMG in the image cache of frame F. */ - -static void -cache_image (f, img) - struct frame *f; - struct image *img; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - int i; - - /* Find a free slot in c->images. */ - for (i = 0; i < c->used; ++i) - if (c->images[i] == NULL) - break; - - /* If no free slot found, maybe enlarge c->images. */ - if (i == c->used && c->used == c->size) - { - c->size *= 2; - c->images = (struct image **) xrealloc (c->images, - c->size * sizeof *c->images); - } - - /* Add IMG to c->images, and assign IMG an id. */ - c->images[i] = img; - img->id = i; - if (i == c->used) - ++c->used; - - /* Add IMG to the cache's hash table. */ - i = img->hash % IMAGE_CACHE_BUCKETS_SIZE; - img->next = c->buckets[i]; - if (img->next) - img->next->prev = img; - img->prev = NULL; - c->buckets[i] = img; -} - - -/* Call FN on every image in the image cache of frame F. Used to mark - Lisp Objects in the image cache. */ - -void -forall_images_in_image_cache (f, fn) - struct frame *f; - void (*fn) P_ ((struct image *img)); -{ - if (FRAME_LIVE_P (f) && FRAME_W32_P (f)) - { - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - if (c) - { - int i; - for (i = 0; i < c->used; ++i) - if (c->images[i]) - fn (c->images[i]); - } - } -} - - - -/*********************************************************************** - W32 support code - ***********************************************************************/ - -/* Macro for defining functions that will be loaded from image DLLs. */ -#define DEF_IMGLIB_FN(func) FARPROC fn_##func - -/* Macro for loading those image functions from the library. */ -#define LOAD_IMGLIB_FN(lib,func) { \ - fn_##func = (void *) GetProcAddress (lib, #func); \ - if (!fn_##func) return 0; \ - } - -static int x_create_x_image_and_pixmap P_ ((struct frame *, int, int, int, - XImage **, Pixmap *)); -static void x_put_x_image P_ ((struct frame *, XImage *, Pixmap, int, int)); - - -/* Create an XImage and a pixmap of size WIDTH x HEIGHT for use on - frame F. Set *XIMG and *PIXMAP to the XImage and Pixmap created. - Set (*XIMG)->data to a raster of WIDTH x HEIGHT pixels allocated - via xmalloc. DEPTH of zero signifies a 24 bit image, otherwise - DEPTH should indicate the bit depth of the image. Print error - messages via image_error if an error occurs. Value is non-zero if - successful. */ - -static int -x_create_x_image_and_pixmap (f, width, height, depth, ximg, pixmap) - struct frame *f; - int width, height, depth; - XImage **ximg; - Pixmap *pixmap; -{ - BITMAPINFOHEADER *header; - HDC hdc; - int scanline_width_bits; - int remainder; - int palette_colors = 0; - - if (depth == 0) - depth = 24; - - if (depth != 1 && depth != 4 && depth != 8 - && depth != 16 && depth != 24 && depth != 32) - { - image_error ("Invalid image bit depth specified", Qnil, Qnil); - return 0; - } - - scanline_width_bits = width * depth; - remainder = scanline_width_bits % 32; - - if (remainder) - scanline_width_bits += 32 - remainder; - - /* Bitmaps with a depth less than 16 need a palette. */ - /* BITMAPINFO structure already contains the first RGBQUAD. */ - if (depth < 16) - palette_colors = 1 << depth - 1; - - *ximg = xmalloc (sizeof (XImage) + palette_colors * sizeof (RGBQUAD)); - if (*ximg == NULL) - { - image_error ("Unable to allocate memory for XImage", Qnil, Qnil); - return 0; - } - - header = &((*ximg)->info.bmiHeader); - bzero (&((*ximg)->info), sizeof (BITMAPINFO)); - header->biSize = sizeof (*header); - header->biWidth = width; - header->biHeight = -height; /* negative indicates a top-down bitmap. */ - header->biPlanes = 1; - header->biBitCount = depth; - header->biCompression = BI_RGB; - header->biClrUsed = palette_colors; - - /* TODO: fill in palette. */ - if (depth == 1) - { - (*ximg)->info.bmiColors[0].rgbBlue = 0; - (*ximg)->info.bmiColors[0].rgbGreen = 0; - (*ximg)->info.bmiColors[0].rgbRed = 0; - (*ximg)->info.bmiColors[0].rgbReserved = 0; - (*ximg)->info.bmiColors[1].rgbBlue = 255; - (*ximg)->info.bmiColors[1].rgbGreen = 255; - (*ximg)->info.bmiColors[1].rgbRed = 255; - (*ximg)->info.bmiColors[1].rgbReserved = 0; - } - - hdc = get_frame_dc (f); - - /* Create a DIBSection and raster array for the bitmap, - and store its handle in *pixmap. */ - *pixmap = CreateDIBSection (hdc, &((*ximg)->info), - (depth < 16) ? DIB_PAL_COLORS : DIB_RGB_COLORS, - &((*ximg)->data), NULL, 0); - - /* Realize display palette and garbage all frames. */ - release_frame_dc (f, hdc); - - if (*pixmap == NULL) - { - DWORD err = GetLastError(); - Lisp_Object errcode; - /* All system errors are < 10000, so the following is safe. */ - XSETINT (errcode, (int) err); - image_error ("Unable to create bitmap, error code %d", errcode, Qnil); - x_destroy_x_image (*ximg); - return 0; - } - - return 1; -} - - -/* Destroy XImage XIMG. Free XIMG->data. */ - -static void -x_destroy_x_image (ximg) - XImage *ximg; -{ - xassert (interrupt_input_blocked); - if (ximg) - { - /* Data will be freed by DestroyObject. */ - ximg->data = NULL; - xfree (ximg); - } -} - - -/* Put XImage XIMG into pixmap PIXMAP on frame F. WIDTH and HEIGHT - are width and height of both the image and pixmap. */ - -static void -x_put_x_image (f, ximg, pixmap, width, height) - struct frame *f; - XImage *ximg; - Pixmap pixmap; - int width, height; -{ -#if 0 /* I don't think this is necessary looking at where it is used. */ - HDC hdc = get_frame_dc (f); - SetDIBits (hdc, pixmap, 0, height, ximg->data, &(ximg->info), DIB_RGB_COLORS); - release_frame_dc (f, hdc); -#endif -} - - -/*********************************************************************** - File Handling - ***********************************************************************/ - -static Lisp_Object x_find_image_file P_ ((Lisp_Object)); -static unsigned char *slurp_file P_ ((char *, int *)); - - -/* Find image file FILE. Look in data-directory, then - x-bitmap-file-path. Value is the full name of the file found, or - nil if not found. */ - -static Lisp_Object -x_find_image_file (file) - Lisp_Object file; -{ - Lisp_Object file_found, search_path; - struct gcpro gcpro1, gcpro2; - int fd; - - file_found = Qnil; - search_path = Fcons (Vdata_directory, Vx_bitmap_file_path); - GCPRO2 (file_found, search_path); - - /* Try to find FILE in data-directory, then x-bitmap-file-path. */ - fd = openp (search_path, file, Qnil, &file_found, Qnil); - - if (fd == -1) - file_found = Qnil; - else - close (fd); - - UNGCPRO; - return file_found; -} - - -/* Read FILE into memory. Value is a pointer to a buffer allocated - with xmalloc holding FILE's contents. Value is null if an error - occurred. *SIZE is set to the size of the file. */ - -static unsigned char * -slurp_file (file, size) - char *file; - int *size; -{ - FILE *fp = NULL; - unsigned char *buf = NULL; - struct stat st; - - if (stat (file, &st) == 0 - && (fp = fopen (file, "rb")) != NULL - && (buf = (char *) xmalloc (st.st_size), - fread (buf, 1, st.st_size, fp) == st.st_size)) - { - *size = st.st_size; - fclose (fp); - } - else - { - if (fp) - fclose (fp); - if (buf) - { - xfree (buf); - buf = NULL; - } - } - - return buf; -} - - - -/*********************************************************************** - XBM images - ***********************************************************************/ - -static int xbm_scan P_ ((unsigned char **, unsigned char *, char *, int *)); -static int xbm_load P_ ((struct frame *f, struct image *img)); -static int xbm_load_image P_ ((struct frame *f, struct image *img, - unsigned char *, unsigned char *)); -static int xbm_image_p P_ ((Lisp_Object object)); -static int xbm_read_bitmap_data P_ ((unsigned char *, unsigned char *, - int *, int *, unsigned char **)); -static int xbm_file_p P_ ((Lisp_Object)); - - -/* Indices of image specification fields in xbm_format, below. */ - -enum xbm_keyword_index -{ - XBM_TYPE, - XBM_FILE, - XBM_WIDTH, - XBM_HEIGHT, - XBM_DATA, - XBM_FOREGROUND, - XBM_BACKGROUND, - XBM_ASCENT, - XBM_MARGIN, - XBM_RELIEF, - XBM_ALGORITHM, - XBM_HEURISTIC_MASK, - XBM_MASK, - XBM_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid XBM image specifications. */ - -static struct image_keyword xbm_format[XBM_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 0}, - {":width", IMAGE_POSITIVE_INTEGER_VALUE, 0}, - {":height", IMAGE_POSITIVE_INTEGER_VALUE, 0}, - {":data", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0} -}; - -/* Structure describing the image type XBM. */ - -static struct image_type xbm_type = -{ - &Qxbm, - xbm_image_p, - xbm_load, - x_clear_image, - NULL -}; - -/* Tokens returned from xbm_scan. */ - -enum xbm_token -{ - XBM_TK_IDENT = 256, - XBM_TK_NUMBER -}; - - -/* Return non-zero if OBJECT is a valid XBM-type image specification. - A valid specification is a list starting with the symbol `image' - The rest of the list is a property list which must contain an - entry `:type xbm.. - - If the specification specifies a file to load, it must contain - an entry `:file FILENAME' where FILENAME is a string. - - If the specification is for a bitmap loaded from memory it must - contain `:width WIDTH', `:height HEIGHT', and `:data DATA', where - WIDTH and HEIGHT are integers > 0. DATA may be: - - 1. a string large enough to hold the bitmap data, i.e. it must - have a size >= (WIDTH + 7) / 8 * HEIGHT - - 2. a bool-vector of size >= WIDTH * HEIGHT - - 3. a vector of strings or bool-vectors, one for each line of the - bitmap. - - 4. A string containing an in-memory XBM file. WIDTH and HEIGHT - may not be specified in this case because they are defined in the - XBM file. - - Both the file and data forms may contain the additional entries - `:background COLOR' and `:foreground COLOR'. If not present, - foreground and background of the frame on which the image is - displayed is used. */ - -static int -xbm_image_p (object) - Lisp_Object object; -{ - struct image_keyword kw[XBM_LAST]; - - bcopy (xbm_format, kw, sizeof kw); - if (!parse_image_spec (object, kw, XBM_LAST, Qxbm)) - return 0; - - xassert (EQ (kw[XBM_TYPE].value, Qxbm)); - - if (kw[XBM_FILE].count) - { - if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_DATA].count) - return 0; - } - else if (kw[XBM_DATA].count && xbm_file_p (kw[XBM_DATA].value)) - { - /* In-memory XBM file. */ - if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_FILE].count) - return 0; - } - else - { - Lisp_Object data; - int width, height; - - /* Entries for `:width', `:height' and `:data' must be present. */ - if (!kw[XBM_WIDTH].count - || !kw[XBM_HEIGHT].count - || !kw[XBM_DATA].count) - return 0; - - data = kw[XBM_DATA].value; - width = XFASTINT (kw[XBM_WIDTH].value); - height = XFASTINT (kw[XBM_HEIGHT].value); - - /* Check type of data, and width and height against contents of - data. */ - if (VECTORP (data)) - { - int i; - - /* Number of elements of the vector must be >= height. */ - if (XVECTOR (data)->size < height) - return 0; - - /* Each string or bool-vector in data must be large enough - for one line of the image. */ - for (i = 0; i < height; ++i) - { - Lisp_Object elt = XVECTOR (data)->contents[i]; - - if (STRINGP (elt)) - { - if (SCHARS (elt) - < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR) - return 0; - } - else if (BOOL_VECTOR_P (elt)) - { - if (XBOOL_VECTOR (elt)->size < width) - return 0; - } - else - return 0; - } - } - else if (STRINGP (data)) - { - if (SCHARS (data) - < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height) - return 0; - } - else if (BOOL_VECTOR_P (data)) - { - if (XBOOL_VECTOR (data)->size < width * height) - return 0; - } - else - return 0; - } - - return 1; -} - - -/* Scan a bitmap file. FP is the stream to read from. Value is - either an enumerator from enum xbm_token, or a character for a - single-character token, or 0 at end of file. If scanning an - identifier, store the lexeme of the identifier in SVAL. If - scanning a number, store its value in *IVAL. */ - -static int -xbm_scan (s, end, sval, ival) - unsigned char **s, *end; - char *sval; - int *ival; -{ - unsigned int c; - - loop: - - /* Skip white space. */ - while (*s < end && (c = *(*s)++, isspace (c))) - ; - - if (*s >= end) - c = 0; - else if (isdigit (c)) - { - int value = 0, digit; - - if (c == '0' && *s < end) - { - c = *(*s)++; - if (c == 'x' || c == 'X') - { - while (*s < end) - { - c = *(*s)++; - if (isdigit (c)) - digit = c - '0'; - else if (c >= 'a' && c <= 'f') - digit = c - 'a' + 10; - else if (c >= 'A' && c <= 'F') - digit = c - 'A' + 10; - else - break; - value = 16 * value + digit; - } - } - else if (isdigit (c)) - { - value = c - '0'; - while (*s < end - && (c = *(*s)++, isdigit (c))) - value = 8 * value + c - '0'; - } - } - else - { - value = c - '0'; - while (*s < end - && (c = *(*s)++, isdigit (c))) - value = 10 * value + c - '0'; - } - - if (*s < end) - *s = *s - 1; - *ival = value; - c = XBM_TK_NUMBER; - } - else if (isalpha (c) || c == '_') - { - *sval++ = c; - while (*s < end - && (c = *(*s)++, (isalnum (c) || c == '_'))) - *sval++ = c; - *sval = 0; - if (*s < end) - *s = *s - 1; - c = XBM_TK_IDENT; - } - else if (c == '/' && **s == '*') - { - /* C-style comment. */ - ++*s; - while (**s && (**s != '*' || *(*s + 1) != '/')) - ++*s; - if (**s) - { - *s += 2; - goto loop; - } - } - - return c; -} - - -/* XBM bits seem to be backward within bytes compared with how - Windows does things. */ -static unsigned char reflect_byte (unsigned char orig) -{ - int i; - unsigned char reflected = 0x00; - for (i = 0; i < 8; i++) - { - if (orig & (0x01 << i)) - reflected |= 0x80 >> i; - } - return reflected; -} - - -/* Create a Windows bitmap from X bitmap data. */ -static HBITMAP -w32_create_pixmap_from_bitmap_data (int width, int height, char *data) -{ - int i, j, w1, w2; - char *bits, *p; - HBITMAP bmp; - - w1 = (width + 7) / 8; /* nb of 8bits elt in X bitmap */ - w2 = ((width + 15) / 16) * 2; /* nb of 16bits elt in W32 bitmap */ - bits = (char *) alloca (height * w2); - bzero (bits, height * w2); - for (i = 0; i < height; i++) - { - p = bits + i*w2; - for (j = 0; j < w1; j++) - *p++ = reflect_byte(*data++); - } - bmp = CreateBitmap (width, height, 1, 1, bits); - - return bmp; -} - - -/* Replacement for XReadBitmapFileData which isn't available under old - X versions. CONTENTS is a pointer to a buffer to parse; END is the - buffer's end. Set *WIDTH and *HEIGHT to the width and height of - the image. Return in *DATA the bitmap data allocated with xmalloc. - Value is non-zero if successful. DATA null means just test if - CONTENTS looks like an in-memory XBM file. */ - -static int -xbm_read_bitmap_data (contents, end, width, height, data) - unsigned char *contents, *end; - int *width, *height; - unsigned char **data; -{ - unsigned char *s = contents; - char buffer[BUFSIZ]; - int padding_p = 0; - int v10 = 0; - int bytes_per_line, i, nbytes; - unsigned char *p; - int value; - int LA1; - -#define match() \ - LA1 = xbm_scan (&s, end, buffer, &value) - -#define expect(TOKEN) \ - if (LA1 != (TOKEN)) \ - goto failure; \ - else \ - match () - -#define expect_ident(IDENT) \ - if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \ - match (); \ - else \ - goto failure - - *width = *height = -1; - if (data) - *data = NULL; - LA1 = xbm_scan (&s, end, buffer, &value); - - /* Parse defines for width, height and hot-spots. */ - while (LA1 == '#') - { - match (); - expect_ident ("define"); - expect (XBM_TK_IDENT); - - if (LA1 == XBM_TK_NUMBER); - { - char *p = strrchr (buffer, '_'); - p = p ? p + 1 : buffer; - if (strcmp (p, "width") == 0) - *width = value; - else if (strcmp (p, "height") == 0) - *height = value; - } - expect (XBM_TK_NUMBER); - } - - if (*width < 0 || *height < 0) - goto failure; - else if (data == NULL) - goto success; - - /* Parse bits. Must start with `static'. */ - expect_ident ("static"); - if (LA1 == XBM_TK_IDENT) - { - if (strcmp (buffer, "unsigned") == 0) - { - match (); - expect_ident ("char"); - } - else if (strcmp (buffer, "short") == 0) - { - match (); - v10 = 1; - if (*width % 16 && *width % 16 < 9) - padding_p = 1; - } - else if (strcmp (buffer, "char") == 0) - match (); - else - goto failure; - } - else - goto failure; - - expect (XBM_TK_IDENT); - expect ('['); - expect (']'); - expect ('='); - expect ('{'); - - bytes_per_line = (*width + 7) / 8 + padding_p; - nbytes = bytes_per_line * *height; - p = *data = (char *) xmalloc (nbytes); - - if (v10) - { - for (i = 0; i < nbytes; i += 2) - { - int val = value; - expect (XBM_TK_NUMBER); - - *p++ = ~ val; - if (!padding_p || ((i + 2) % bytes_per_line)) - *p++ = ~ (value >> 8); - - if (LA1 == ',' || LA1 == '}') - match (); - else - goto failure; - } - } - else - { - for (i = 0; i < nbytes; ++i) - { - int val = value; - expect (XBM_TK_NUMBER); - - *p++ = ~ val; - - if (LA1 == ',' || LA1 == '}') - match (); - else - goto failure; - } - } - - success: - return 1; - - failure: - - if (data && *data) - { - xfree (*data); - *data = NULL; - } - return 0; - -#undef match -#undef expect -#undef expect_ident -} - -static void convert_mono_to_color_image (f, img, foreground, background) - struct frame *f; - struct image *img; - COLORREF foreground, background; -{ - HDC hdc, old_img_dc, new_img_dc; - HGDIOBJ old_prev, new_prev; - HBITMAP new_pixmap; - - hdc = get_frame_dc (f); - old_img_dc = CreateCompatibleDC (hdc); - new_img_dc = CreateCompatibleDC (hdc); - new_pixmap = CreateCompatibleBitmap (hdc, img->width, img->height); - release_frame_dc (f, hdc); - old_prev = SelectObject (old_img_dc, img->pixmap); - new_prev = SelectObject (new_img_dc, new_pixmap); - SetTextColor (new_img_dc, foreground); - SetBkColor (new_img_dc, background); - - BitBlt (new_img_dc, 0, 0, img->width, img->height, old_img_dc, - 0, 0, SRCCOPY); - - SelectObject (old_img_dc, old_prev); - SelectObject (new_img_dc, new_prev); - DeleteDC (old_img_dc); - DeleteDC (new_img_dc); - DeleteObject (img->pixmap); - if (new_pixmap == 0) - fprintf (stderr, "Failed to convert image to color.\n"); - else - img->pixmap = new_pixmap; -} - -/* Load XBM image IMG which will be displayed on frame F from buffer - CONTENTS. END is the end of the buffer. Value is non-zero if - successful. */ - -static int -xbm_load_image (f, img, contents, end) - struct frame *f; - struct image *img; - unsigned char *contents, *end; -{ - int rc; - unsigned char *data; - int success_p = 0; - - rc = xbm_read_bitmap_data (contents, end, &img->width, &img->height, &data); - if (rc) - { - unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); - unsigned long background = FRAME_BACKGROUND_PIXEL (f); - int non_default_colors = 0; - Lisp_Object value; - - xassert (img->width > 0 && img->height > 0); - - /* Get foreground and background colors, maybe allocate colors. */ - value = image_spec_value (img->spec, QCforeground, NULL); - if (!NILP (value)) - { - foreground = x_alloc_image_color (f, img, value, foreground); - non_default_colors = 1; - } - value = image_spec_value (img->spec, QCbackground, NULL); - if (!NILP (value)) - { - background = x_alloc_image_color (f, img, value, background); - img->background = background; - img->background_valid = 1; - non_default_colors = 1; - } - img->pixmap - = w32_create_pixmap_from_bitmap_data (img->width, img->height, data); - - /* If colors were specified, transfer the bitmap to a color one. */ - if (non_default_colors) - convert_mono_to_color_image (f, img, foreground, background); - - xfree (data); - - if (img->pixmap == 0) - { - x_clear_image (f, img); - image_error ("Unable to create X pixmap for `%s'", img->spec, Qnil); - } - else - success_p = 1; - } - else - image_error ("Error loading XBM image `%s'", img->spec, Qnil); - - return success_p; -} - - -/* Value is non-zero if DATA looks like an in-memory XBM file. */ - -static int -xbm_file_p (data) - Lisp_Object data; -{ - int w, h; - return (STRINGP (data) - && xbm_read_bitmap_data (SDATA (data), - (SDATA (data) - + SBYTES (data)), - &w, &h, NULL)); -} - - -/* Fill image IMG which is used on frame F with pixmap data. Value is - non-zero if successful. */ - -static int -xbm_load (f, img) - struct frame *f; - struct image *img; -{ - int success_p = 0; - Lisp_Object file_name; - - xassert (xbm_image_p (img->spec)); - - /* If IMG->spec specifies a file name, create a non-file spec from it. */ - file_name = image_spec_value (img->spec, QCfile, NULL); - if (STRINGP (file_name)) - { - Lisp_Object file; - unsigned char *contents; - int size; - struct gcpro gcpro1; - - file = x_find_image_file (file_name); - GCPRO1 (file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", file_name, Qnil); - UNGCPRO; - return 0; - } - - contents = slurp_file (SDATA (file), &size); - if (contents == NULL) - { - image_error ("Error loading XBM image `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - - success_p = xbm_load_image (f, img, contents, contents + size); - UNGCPRO; - } - else - { - struct image_keyword fmt[XBM_LAST]; - Lisp_Object data; - unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); - unsigned long background = FRAME_BACKGROUND_PIXEL (f); - int non_default_colors = 0; - char *bits; - int parsed_p; - int in_memory_file_p = 0; - - /* See if data looks like an in-memory XBM file. */ - data = image_spec_value (img->spec, QCdata, NULL); - in_memory_file_p = xbm_file_p (data); - - /* Parse the image specification. */ - bcopy (xbm_format, fmt, sizeof fmt); - parsed_p = parse_image_spec (img->spec, fmt, XBM_LAST, Qxbm); - xassert (parsed_p); - - /* Get specified width, and height. */ - if (!in_memory_file_p) - { - img->width = XFASTINT (fmt[XBM_WIDTH].value); - img->height = XFASTINT (fmt[XBM_HEIGHT].value); - xassert (img->width > 0 && img->height > 0); - } - - /* Get foreground and background colors, maybe allocate colors. */ - if (fmt[XBM_FOREGROUND].count - && STRINGP (fmt[XBM_FOREGROUND].value)) - { - foreground = x_alloc_image_color (f, img, fmt[XBM_FOREGROUND].value, - foreground); - non_default_colors = 1; - } - - if (fmt[XBM_BACKGROUND].count - && STRINGP (fmt[XBM_BACKGROUND].value)) - { - background = x_alloc_image_color (f, img, fmt[XBM_BACKGROUND].value, - background); - non_default_colors = 1; - } - - if (in_memory_file_p) - success_p = xbm_load_image (f, img, SDATA (data), - (SDATA (data) - + SBYTES (data))); - else - { - if (VECTORP (data)) - { - int i; - char *p; - int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR; - - p = bits = (char *) alloca (nbytes * img->height); - for (i = 0; i < img->height; ++i, p += nbytes) - { - Lisp_Object line = XVECTOR (data)->contents[i]; - if (STRINGP (line)) - bcopy (SDATA (line), p, nbytes); - else - bcopy (XBOOL_VECTOR (line)->data, p, nbytes); - } - } - else if (STRINGP (data)) - bits = SDATA (data); - else - bits = XBOOL_VECTOR (data)->data; - - /* Create the pixmap. */ - img->pixmap - = w32_create_pixmap_from_bitmap_data (img->width, img->height, - bits); - - /* If colors were specified, transfer the bitmap to a color one. */ - if (non_default_colors) - convert_mono_to_color_image (f, img, foreground, background); - - if (img->pixmap) - success_p = 1; - else - { - image_error ("Unable to create pixmap for XBM image `%s'", - img->spec, Qnil); - x_clear_image (f, img); - } - } - } - - return success_p; -} - - - -/*********************************************************************** - XPM images - ***********************************************************************/ - -#if HAVE_XPM - -static int xpm_image_p P_ ((Lisp_Object object)); -static int xpm_load P_ ((struct frame *f, struct image *img)); -static int xpm_valid_color_symbols_p P_ ((Lisp_Object)); - -/* Indicate to xpm.h that we don't have Xlib. */ -#define FOR_MSW -/* simx.h in xpm defines XColor and XImage differently than Emacs. */ -#define XColor xpm_XColor -#define XImage xpm_XImage -#define PIXEL_ALREADY_TYPEDEFED -#include "X11/xpm.h" -#undef FOR_MSW -#undef XColor -#undef XImage -#undef PIXEL_ALREADY_TYPEDEFED - -/* The symbol `xpm' identifying XPM-format images. */ - -Lisp_Object Qxpm; - -/* Indices of image specification fields in xpm_format, below. */ - -enum xpm_keyword_index -{ - XPM_TYPE, - XPM_FILE, - XPM_DATA, - XPM_ASCENT, - XPM_MARGIN, - XPM_RELIEF, - XPM_ALGORITHM, - XPM_HEURISTIC_MASK, - XPM_MASK, - XPM_COLOR_SYMBOLS, - XPM_BACKGROUND, - XPM_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid XPM image specifications. */ - -static struct image_keyword xpm_format[XPM_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 0}, - {":data", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type XPM. */ - -static struct image_type xpm_type = -{ - &Qxpm, - xpm_image_p, - xpm_load, - x_clear_image, - NULL -}; - - -/* XPM library details. */ - -DEF_IMGLIB_FN (XpmFreeAttributes); -DEF_IMGLIB_FN (XpmCreateImageFromBuffer); -DEF_IMGLIB_FN (XpmReadFileToImage); -DEF_IMGLIB_FN (XImageFree); - - -static int -init_xpm_functions (library) - HMODULE library; -{ - LOAD_IMGLIB_FN (library, XpmFreeAttributes); - LOAD_IMGLIB_FN (library, XpmCreateImageFromBuffer); - LOAD_IMGLIB_FN (library, XpmReadFileToImage); - LOAD_IMGLIB_FN (library, XImageFree); - - return 1; -} - -/* Value is non-zero if COLOR_SYMBOLS is a valid color symbols list - for XPM images. Such a list must consist of conses whose car and - cdr are strings. */ - -static int -xpm_valid_color_symbols_p (color_symbols) - Lisp_Object color_symbols; -{ - while (CONSP (color_symbols)) - { - Lisp_Object sym = XCAR (color_symbols); - if (!CONSP (sym) - || !STRINGP (XCAR (sym)) - || !STRINGP (XCDR (sym))) - break; - color_symbols = XCDR (color_symbols); - } - - return NILP (color_symbols); -} - - -/* Value is non-zero if OBJECT is a valid XPM image specification. */ - -static int -xpm_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[XPM_LAST]; - bcopy (xpm_format, fmt, sizeof fmt); - return (parse_image_spec (object, fmt, XPM_LAST, Qxpm) - /* Either `:file' or `:data' must be present. */ - && fmt[XPM_FILE].count + fmt[XPM_DATA].count == 1 - /* Either no `:color-symbols' or it's a list of conses - whose car and cdr are strings. */ - && (fmt[XPM_COLOR_SYMBOLS].count == 0 - || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value))); -} - - -/* Load image IMG which will be displayed on frame F. Value is - non-zero if successful. */ - -static int -xpm_load (f, img) - struct frame *f; - struct image *img; -{ - HDC hdc; - int rc; - XpmAttributes attrs; - Lisp_Object specified_file, color_symbols; - xpm_XImage * xpm_image, * xpm_mask; - - /* Configure the XPM lib. Use the visual of frame F. Allocate - close colors. Return colors allocated. */ - bzero (&attrs, sizeof attrs); - xpm_image = xpm_mask = NULL; - -#if 0 - attrs.visual = FRAME_X_VISUAL (f); - attrs.colormap = FRAME_X_COLORMAP (f); - attrs.valuemask |= XpmVisual; - attrs.valuemask |= XpmColormap; -#endif - attrs.valuemask |= XpmReturnAllocPixels; -#ifdef XpmAllocCloseColors - attrs.alloc_close_colors = 1; - attrs.valuemask |= XpmAllocCloseColors; -#else - attrs.closeness = 600; - attrs.valuemask |= XpmCloseness; -#endif - - /* If image specification contains symbolic color definitions, add - these to `attrs'. */ - color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL); - if (CONSP (color_symbols)) - { - Lisp_Object tail; - XpmColorSymbol *xpm_syms; - int i, size; - - attrs.valuemask |= XpmColorSymbols; - - /* Count number of symbols. */ - attrs.numsymbols = 0; - for (tail = color_symbols; CONSP (tail); tail = XCDR (tail)) - ++attrs.numsymbols; - - /* Allocate an XpmColorSymbol array. */ - size = attrs.numsymbols * sizeof *xpm_syms; - xpm_syms = (XpmColorSymbol *) alloca (size); - bzero (xpm_syms, size); - attrs.colorsymbols = xpm_syms; - - /* Fill the color symbol array. */ - for (tail = color_symbols, i = 0; - CONSP (tail); - ++i, tail = XCDR (tail)) - { - Lisp_Object name = XCAR (XCAR (tail)); - Lisp_Object color = XCDR (XCAR (tail)); - xpm_syms[i].name = (char *) alloca (SCHARS (name) + 1); - strcpy (xpm_syms[i].name, SDATA (name)); - xpm_syms[i].value = (char *) alloca (SCHARS (color) + 1); - strcpy (xpm_syms[i].value, SDATA (color)); - } - } - - /* Create a pixmap for the image, either from a file, or from a - string buffer containing data in the same format as an XPM file. */ - - specified_file = image_spec_value (img->spec, QCfile, NULL); - - { - HDC frame_dc = get_frame_dc (f); - hdc = CreateCompatibleDC (frame_dc); - release_frame_dc (f, frame_dc); - } - - if (STRINGP (specified_file)) - { - Lisp_Object file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - return 0; - } - - /* XpmReadFileToPixmap is not available in the Windows port of - libxpm. But XpmReadFileToImage almost does what we want. */ - rc = fn_XpmReadFileToImage (&hdc, SDATA (file), - &xpm_image, &xpm_mask, - &attrs); - } - else - { - Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL); - /* XpmCreatePixmapFromBuffer is not available in the Windows port - of libxpm. But XpmCreateImageFromBuffer almost does what we want. */ - rc = fn_XpmCreateImageFromBuffer (&hdc, SDATA (buffer), - &xpm_image, &xpm_mask, - &attrs); - } - - if (rc == XpmSuccess) - { - int i; - - /* W32 XPM uses XImage to wrap what W32 Emacs calls a Pixmap, - plus some duplicate attributes. */ - if (xpm_image && xpm_image->bitmap) - { - img->pixmap = xpm_image->bitmap; - /* XImageFree in libXpm frees XImage struct without destroying - the bitmap, which is what we want. */ - fn_XImageFree (xpm_image); - } - if (xpm_mask && xpm_mask->bitmap) - { - /* The mask appears to be inverted compared with what we expect. - TODO: invert our expectations. See other places where we - have to invert bits because our idea of masks is backwards. */ - HGDIOBJ old_obj; - old_obj = SelectObject (hdc, xpm_mask->bitmap); - - PatBlt (hdc, 0, 0, xpm_mask->width, xpm_mask->height, DSTINVERT); - SelectObject (hdc, old_obj); - - img->mask = xpm_mask->bitmap; - fn_XImageFree (xpm_mask); - DeleteDC (hdc); - } - - DeleteDC (hdc); - - /* Remember allocated colors. */ - img->ncolors = attrs.nalloc_pixels; - img->colors = (unsigned long *) xmalloc (img->ncolors - * sizeof *img->colors); - for (i = 0; i < attrs.nalloc_pixels; ++i) - img->colors[i] = attrs.alloc_pixels[i]; - - img->width = attrs.width; - img->height = attrs.height; - xassert (img->width > 0 && img->height > 0); - - /* The call to XpmFreeAttributes below frees attrs.alloc_pixels. */ - fn_XpmFreeAttributes (&attrs); - } - else - { - DeleteDC (hdc); - - switch (rc) - { - case XpmOpenFailed: - image_error ("Error opening XPM file (%s)", img->spec, Qnil); - break; - - case XpmFileInvalid: - image_error ("Invalid XPM file (%s)", img->spec, Qnil); - break; - - case XpmNoMemory: - image_error ("Out of memory (%s)", img->spec, Qnil); - break; - - case XpmColorFailed: - image_error ("Color allocation error (%s)", img->spec, Qnil); - break; - - default: - image_error ("Unknown error (%s)", img->spec, Qnil); - break; - } - } - - return rc == XpmSuccess; -} - -#endif /* HAVE_XPM != 0 */ - - -#if 0 /* TODO : Color tables on W32. */ -/*********************************************************************** - Color table - ***********************************************************************/ - -/* An entry in the color table mapping an RGB color to a pixel color. */ - -struct ct_color -{ - int r, g, b; - unsigned long pixel; - - /* Next in color table collision list. */ - struct ct_color *next; -}; - -/* The bucket vector size to use. Must be prime. */ - -#define CT_SIZE 101 - -/* Value is a hash of the RGB color given by R, G, and B. */ - -#define CT_HASH_RGB(R, G, B) (((R) << 16) ^ ((G) << 8) ^ (B)) - -/* The color hash table. */ - -struct ct_color **ct_table; - -/* Number of entries in the color table. */ - -int ct_colors_allocated; - -/* Function prototypes. */ - -static void init_color_table P_ ((void)); -static void free_color_table P_ ((void)); -static unsigned long *colors_in_color_table P_ ((int *n)); -static unsigned long lookup_rgb_color P_ ((struct frame *f, int r, int g, int b)); -static unsigned long lookup_pixel_color P_ ((struct frame *f, unsigned long p)); - - -/* Initialize the color table. */ - -static void -init_color_table () -{ - int size = CT_SIZE * sizeof (*ct_table); - ct_table = (struct ct_color **) xmalloc (size); - bzero (ct_table, size); - ct_colors_allocated = 0; -} - - -/* Free memory associated with the color table. */ - -static void -free_color_table () -{ - int i; - struct ct_color *p, *next; - - for (i = 0; i < CT_SIZE; ++i) - for (p = ct_table[i]; p; p = next) - { - next = p->next; - xfree (p); - } - - xfree (ct_table); - ct_table = NULL; -} - - -/* Value is a pixel color for RGB color R, G, B on frame F. If an - entry for that color already is in the color table, return the - pixel color of that entry. Otherwise, allocate a new color for R, - G, B, and make an entry in the color table. */ - -static unsigned long -lookup_rgb_color (f, r, g, b) - struct frame *f; - int r, g, b; -{ - unsigned hash = CT_HASH_RGB (r, g, b); - int i = hash % CT_SIZE; - struct ct_color *p; - - for (p = ct_table[i]; p; p = p->next) - if (p->r == r && p->g == g && p->b == b) - break; - - if (p == NULL) - { - COLORREF color; - Colormap cmap; - int rc; - - color = PALETTERGB (r, g, b); - - ++ct_colors_allocated; - - p = (struct ct_color *) xmalloc (sizeof *p); - p->r = r; - p->g = g; - p->b = b; - p->pixel = color; - p->next = ct_table[i]; - ct_table[i] = p; - } - - return p->pixel; -} - - -/* Look up pixel color PIXEL which is used on frame F in the color - table. If not already present, allocate it. Value is PIXEL. */ - -static unsigned long -lookup_pixel_color (f, pixel) - struct frame *f; - unsigned long pixel; -{ - int i = pixel % CT_SIZE; - struct ct_color *p; - - for (p = ct_table[i]; p; p = p->next) - if (p->pixel == pixel) - break; - - if (p == NULL) - { - XColor color; - Colormap cmap; - int rc; - - BLOCK_INPUT; - - cmap = DefaultColormapOfScreen (FRAME_X_SCREEN (f)); - color.pixel = pixel; - XQueryColor (NULL, cmap, &color); - rc = x_alloc_nearest_color (f, cmap, &color); - UNBLOCK_INPUT; - - if (rc) - { - ++ct_colors_allocated; - - p = (struct ct_color *) xmalloc (sizeof *p); - p->r = color.red; - p->g = color.green; - p->b = color.blue; - p->pixel = pixel; - p->next = ct_table[i]; - ct_table[i] = p; - } - else - return FRAME_FOREGROUND_PIXEL (f); - } - return p->pixel; -} - - -/* Value is a vector of all pixel colors contained in the color table, - allocated via xmalloc. Set *N to the number of colors. */ - -static unsigned long * -colors_in_color_table (n) - int *n; -{ - int i, j; - struct ct_color *p; - unsigned long *colors; - - if (ct_colors_allocated == 0) - { - *n = 0; - colors = NULL; - } - else - { - colors = (unsigned long *) xmalloc (ct_colors_allocated - * sizeof *colors); - *n = ct_colors_allocated; - - for (i = j = 0; i < CT_SIZE; ++i) - for (p = ct_table[i]; p; p = p->next) - colors[j++] = p->pixel; - } - - return colors; -} - -#endif /* TODO */ - - -/*********************************************************************** - Algorithms - ***********************************************************************/ -static XColor *x_to_xcolors P_ ((struct frame *, struct image *, int)); -static void x_from_xcolors P_ ((struct frame *, struct image *, XColor *)); -static void x_detect_edges P_ ((struct frame *, struct image *, int[9], int)); -static void XPutPixel (XImage *, int, int, COLORREF); - -/* Non-zero means draw a cross on images having `:conversion - disabled'. */ - -int cross_disabled_images; - -/* Edge detection matrices for different edge-detection - strategies. */ - -static int emboss_matrix[9] = { - /* x - 1 x x + 1 */ - 2, -1, 0, /* y - 1 */ - -1, 0, 1, /* y */ - 0, 1, -2 /* y + 1 */ -}; - -static int laplace_matrix[9] = { - /* x - 1 x x + 1 */ - 1, 0, 0, /* y - 1 */ - 0, 0, 0, /* y */ - 0, 0, -1 /* y + 1 */ -}; - -/* Value is the intensity of the color whose red/green/blue values - are R, G, and B. */ - -#define COLOR_INTENSITY(R, G, B) ((2 * (R) + 3 * (G) + (B)) / 6) - - -/* On frame F, return an array of XColor structures describing image - IMG->pixmap. Each XColor structure has its pixel color set. RGB_P - non-zero means also fill the red/green/blue members of the XColor - structures. Value is a pointer to the array of XColors structures, - allocated with xmalloc; it must be freed by the caller. */ - -static XColor * -x_to_xcolors (f, img, rgb_p) - struct frame *f; - struct image *img; - int rgb_p; -{ - int x, y; - XColor *colors, *p; - HDC hdc, bmpdc; - HGDIOBJ prev; - - colors = (XColor *) xmalloc (img->width * img->height * sizeof *colors); - - /* Load the image into a memory device context. */ - hdc = get_frame_dc (f); - bmpdc = CreateCompatibleDC (hdc); - release_frame_dc (f, hdc); - prev = SelectObject (bmpdc, img->pixmap); - - /* Fill the `pixel' members of the XColor array. I wished there - were an easy and portable way to circumvent XGetPixel. */ - p = colors; - for (y = 0; y < img->height; ++y) - { - XColor *row = p; - - for (x = 0; x < img->width; ++x, ++p) - { - /* TODO: palette support needed here? */ - p->pixel = GetPixel (bmpdc, x, y); - - if (rgb_p) - { - p->red = 256 * GetRValue (p->pixel); - p->green = 256 * GetGValue (p->pixel); - p->blue = 256 * GetBValue (p->pixel); - } - } - } - - SelectObject (bmpdc, prev); - DeleteDC (bmpdc); - - return colors; -} - -/* Put a pixel of COLOR at position X, Y in XIMG. XIMG must have been - created with CreateDIBSection, with the pointer to the bit values - stored in ximg->data. */ - -static void XPutPixel (ximg, x, y, color) - XImage * ximg; - int x, y; - COLORREF color; -{ - int width = ximg->info.bmiHeader.biWidth; - int height = ximg->info.bmiHeader.biHeight; - unsigned char * pixel; - - /* True color images. */ - if (ximg->info.bmiHeader.biBitCount == 24) - { - int rowbytes = width * 3; - /* Ensure scanlines are aligned on 4 byte boundaries. */ - if (rowbytes % 4) - rowbytes += 4 - (rowbytes % 4); - - pixel = ximg->data + y * rowbytes + x * 3; - /* Windows bitmaps are in BGR order. */ - *pixel = GetBValue (color); - *(pixel + 1) = GetGValue (color); - *(pixel + 2) = GetRValue (color); - } - /* Monochrome images. */ - else if (ximg->info.bmiHeader.biBitCount == 1) - { - int rowbytes = width / 8; - /* Ensure scanlines are aligned on 4 byte boundaries. */ - if (rowbytes % 4) - rowbytes += 4 - (rowbytes % 4); - pixel = ximg->data + y * rowbytes + x / 8; - /* Filter out palette info. */ - if (color & 0x00ffffff) - *pixel = *pixel | (1 << x % 8); - else - *pixel = *pixel & ~(1 << x % 8); - } - else - image_error ("XPutPixel: palette image not supported", Qnil, Qnil); -} - -/* Create IMG->pixmap from an array COLORS of XColor structures, whose - RGB members are set. F is the frame on which this all happens. - COLORS will be freed; an existing IMG->pixmap will be freed, too. */ - -static void -x_from_xcolors (f, img, colors) - struct frame *f; - struct image *img; - XColor *colors; -{ - int x, y; - XImage *oimg; - Pixmap pixmap; - XColor *p; -#if 0 /* TODO: color tables. */ - init_color_table (); -#endif - x_create_x_image_and_pixmap (f, img->width, img->height, 0, - &oimg, &pixmap); - p = colors; - for (y = 0; y < img->height; ++y) - for (x = 0; x < img->width; ++x, ++p) - { - unsigned long pixel; -#if 0 /* TODO: color tables. */ - pixel = lookup_rgb_color (f, p->red, p->green, p->blue); -#else - pixel = PALETTERGB (p->red / 256, p->green / 256, p->blue / 256); -#endif - XPutPixel (oimg, x, y, pixel); - } - - xfree (colors); - x_clear_image_1 (f, img, 1, 0, 1); - - x_put_x_image (f, oimg, pixmap, img->width, img->height); - x_destroy_x_image (oimg); - img->pixmap = pixmap; -#if 0 /* TODO: color tables. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif -} - - -/* On frame F, perform edge-detection on image IMG. - - MATRIX is a nine-element array specifying the transformation - matrix. See emboss_matrix for an example. - - COLOR_ADJUST is a color adjustment added to each pixel of the - outgoing image. */ - -static void -x_detect_edges (f, img, matrix, color_adjust) - struct frame *f; - struct image *img; - int matrix[9], color_adjust; -{ - XColor *colors = x_to_xcolors (f, img, 1); - XColor *new, *p; - int x, y, i, sum; - - for (i = sum = 0; i < 9; ++i) - sum += abs (matrix[i]); - -#define COLOR(A, X, Y) ((A) + (Y) * img->width + (X)) - - new = (XColor *) xmalloc (img->width * img->height * sizeof *new); - - for (y = 0; y < img->height; ++y) - { - p = COLOR (new, 0, y); - p->red = p->green = p->blue = 0xffff/2; - p = COLOR (new, img->width - 1, y); - p->red = p->green = p->blue = 0xffff/2; - } - - for (x = 1; x < img->width - 1; ++x) - { - p = COLOR (new, x, 0); - p->red = p->green = p->blue = 0xffff/2; - p = COLOR (new, x, img->height - 1); - p->red = p->green = p->blue = 0xffff/2; - } - - for (y = 1; y < img->height - 1; ++y) - { - p = COLOR (new, 1, y); - - for (x = 1; x < img->width - 1; ++x, ++p) - { - int r, g, b, y1, x1; - - r = g = b = i = 0; - for (y1 = y - 1; y1 < y + 2; ++y1) - for (x1 = x - 1; x1 < x + 2; ++x1, ++i) - if (matrix[i]) - { - XColor *t = COLOR (colors, x1, y1); - r += matrix[i] * t->red; - g += matrix[i] * t->green; - b += matrix[i] * t->blue; - } - - r = (r / sum + color_adjust) & 0xffff; - g = (g / sum + color_adjust) & 0xffff; - b = (b / sum + color_adjust) & 0xffff; - p->red = p->green = p->blue = COLOR_INTENSITY (r, g, b); - } - } - - xfree (colors); - x_from_xcolors (f, img, new); - -#undef COLOR -} - - -/* Perform the pre-defined `emboss' edge-detection on image IMG - on frame F. */ - -static void -x_emboss (f, img) - struct frame *f; - struct image *img; -{ - x_detect_edges (f, img, emboss_matrix, 0xffff / 2); -} - - -/* Transform image IMG which is used on frame F with a Laplace - edge-detection algorithm. The result is an image that can be used - to draw disabled buttons, for example. */ - -static void -x_laplace (f, img) - struct frame *f; - struct image *img; -{ - x_detect_edges (f, img, laplace_matrix, 45000); -} - - -/* Perform edge-detection on image IMG on frame F, with specified - transformation matrix MATRIX and color-adjustment COLOR_ADJUST. - - MATRIX must be either - - - a list of at least 9 numbers in row-major form - - a vector of at least 9 numbers - - COLOR_ADJUST nil means use a default; otherwise it must be a - number. */ - -static void -x_edge_detection (f, img, matrix, color_adjust) - struct frame *f; - struct image *img; - Lisp_Object matrix, color_adjust; -{ - int i = 0; - int trans[9]; - - if (CONSP (matrix)) - { - for (i = 0; - i < 9 && CONSP (matrix) && NUMBERP (XCAR (matrix)); - ++i, matrix = XCDR (matrix)) - trans[i] = XFLOATINT (XCAR (matrix)); - } - else if (VECTORP (matrix) && ASIZE (matrix) >= 9) - { - for (i = 0; i < 9 && NUMBERP (AREF (matrix, i)); ++i) - trans[i] = XFLOATINT (AREF (matrix, i)); - } - - if (NILP (color_adjust)) - color_adjust = make_number (0xffff / 2); - - if (i == 9 && NUMBERP (color_adjust)) - x_detect_edges (f, img, trans, (int) XFLOATINT (color_adjust)); -} - - -/* Transform image IMG on frame F so that it looks disabled. */ - -static void -x_disable_image (f, img) - struct frame *f; - struct image *img; -{ - struct w32_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f); - - if (dpyinfo->n_planes * dpyinfo->n_cbits >= 2) - { - /* Color (or grayscale). Convert to gray, and equalize. Just - drawing such images with a stipple can look very odd, so - we're using this method instead. */ - XColor *colors = x_to_xcolors (f, img, 1); - XColor *p, *end; - const int h = 15000; - const int l = 30000; - - for (p = colors, end = colors + img->width * img->height; - p < end; - ++p) - { - int i = COLOR_INTENSITY (p->red, p->green, p->blue); - int i2 = (0xffff - h - l) * i / 0xffff + l; - p->red = p->green = p->blue = i2; - } - - x_from_xcolors (f, img, colors); - } - - /* Draw a cross over the disabled image, if we must or if we - should. */ - if (dpyinfo->n_planes * dpyinfo->n_cbits < 2 || cross_disabled_images) - { - HDC hdc, bmpdc; - HGDIOBJ prev; - - hdc = get_frame_dc (f); - bmpdc = CreateCompatibleDC (hdc); - release_frame_dc (f, hdc); - - prev = SelectObject (bmpdc, img->pixmap); - - SetTextColor (bmpdc, BLACK_PIX_DEFAULT (f)); - MoveToEx (bmpdc, 0, 0, NULL); - LineTo (bmpdc, img->width - 1, img->height - 1); - MoveToEx (bmpdc, 0, img->height - 1, NULL); - LineTo (bmpdc, img->width - 1, 0); - - if (img->mask) - { - SelectObject (bmpdc, img->mask); - SetTextColor (bmpdc, WHITE_PIX_DEFAULT (f)); - MoveToEx (bmpdc, 0, 0, NULL); - LineTo (bmpdc, img->width - 1, img->height - 1); - MoveToEx (bmpdc, 0, img->height - 1, NULL); - LineTo (bmpdc, img->width - 1, 0); - } - SelectObject (bmpdc, prev); - DeleteDC (bmpdc); - } -} - - -/* Build a mask for image IMG which is used on frame F. FILE is the - name of an image file, for error messages. HOW determines how to - determine the background color of IMG. If it is a list '(R G B)', - with R, G, and B being integers >= 0, take that as the color of the - background. Otherwise, determine the background color of IMG - heuristically. Value is non-zero if successful. */ - -static int -x_build_heuristic_mask (f, img, how) - struct frame *f; - struct image *img; - Lisp_Object how; -{ - HDC img_dc, frame_dc; - HGDIOBJ prev; - char *mask_img; - int x, y, rc, use_img_background; - unsigned long bg = 0; - int row_width; - - if (img->mask) - { - DeleteObject (img->mask); - img->mask = NULL; - img->background_transparent_valid = 0; - } - - /* Create the bit array serving as mask. */ - row_width = (img->width + 7) / 8; - mask_img = xmalloc (row_width * img->height); - bzero (mask_img, row_width * img->height); - - /* Create a memory device context for IMG->pixmap. */ - frame_dc = get_frame_dc (f); - img_dc = CreateCompatibleDC (frame_dc); - release_frame_dc (f, frame_dc); - prev = SelectObject (img_dc, img->pixmap); - - /* Determine the background color of img_dc. If HOW is `(R G B)' - take that as color. Otherwise, use the image's background color. */ - use_img_background = 1; - - if (CONSP (how)) - { - int rgb[3], i; - - for (i = 0; i < 3 && CONSP (how) && NATNUMP (XCAR (how)); ++i) - { - rgb[i] = XFASTINT (XCAR (how)) & 0xffff; - how = XCDR (how); - } - - if (i == 3 && NILP (how)) - { - char color_name[30]; - sprintf (color_name, "#%04x%04x%04x", rgb[0], rgb[1], rgb[2]); - bg = x_alloc_image_color (f, img, build_string (color_name), 0) - & 0x00ffffff; /* Filter out palette info. */ - use_img_background = 0; - } - } - - if (use_img_background) - bg = four_corners_best (img_dc, img->width, img->height); - - /* Set all bits in mask_img to 1 whose color in ximg is different - from the background color bg. */ - for (y = 0; y < img->height; ++y) - for (x = 0; x < img->width; ++x) - { - COLORREF p = GetPixel (img_dc, x, y); - if (p != bg) - mask_img[y * row_width + x / 8] |= 1 << (x % 8); - } - - /* Create the mask image. */ - img->mask = w32_create_pixmap_from_bitmap_data (img->width, img->height, - mask_img); - - /* Fill in the background_transparent field while we have the mask handy. */ - SelectObject (img_dc, img->mask); - - image_background_transparent (img, f, img_dc); - - /* Put mask_img into img->mask. */ - x_destroy_x_image ((XImage *)mask_img); - SelectObject (img_dc, prev); - DeleteDC (img_dc); - - return 1; -} - - -/*********************************************************************** - PBM (mono, gray, color) - ***********************************************************************/ - -static int pbm_image_p P_ ((Lisp_Object object)); -static int pbm_load P_ ((struct frame *f, struct image *img)); -static int pbm_scan_number P_ ((unsigned char **, unsigned char *)); - -/* The symbol `pbm' identifying images of this type. */ - -Lisp_Object Qpbm; - -/* Indices of image specification fields in gs_format, below. */ - -enum pbm_keyword_index -{ - PBM_TYPE, - PBM_FILE, - PBM_DATA, - PBM_ASCENT, - PBM_MARGIN, - PBM_RELIEF, - PBM_ALGORITHM, - PBM_HEURISTIC_MASK, - PBM_MASK, - PBM_FOREGROUND, - PBM_BACKGROUND, - PBM_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword pbm_format[PBM_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 0}, - {":data", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `pbm'. */ - -static struct image_type pbm_type = -{ - &Qpbm, - pbm_image_p, - pbm_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid PBM image specification. */ - -static int -pbm_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[PBM_LAST]; - - bcopy (pbm_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, PBM_LAST, Qpbm)) - return 0; - - /* Must specify either :data or :file. */ - return fmt[PBM_DATA].count + fmt[PBM_FILE].count == 1; -} - - -/* Scan a decimal number from *S and return it. Advance *S while - reading the number. END is the end of the string. Value is -1 at - end of input. */ - -static int -pbm_scan_number (s, end) - unsigned char **s, *end; -{ - int c, val = -1; - - while (*s < end) - { - /* Skip white-space. */ - while (*s < end && (c = *(*s)++, isspace (c))) - ; - - if (c == '#') - { - /* Skip comment to end of line. */ - while (*s < end && (c = *(*s)++, c != '\n')) - ; - } - else if (isdigit (c)) - { - /* Read decimal number. */ - val = c - '0'; - while (*s < end && (c = *(*s)++, isdigit (c))) - val = 10 * val + c - '0'; - break; - } - else - break; - } - - return val; -} - - -/* Read FILE into memory. Value is a pointer to a buffer allocated - with xmalloc holding FILE's contents. Value is null if an error - occurred. *SIZE is set to the size of the file. */ - -static char * -pbm_read_file (file, size) - Lisp_Object file; - int *size; -{ - FILE *fp = NULL; - char *buf = NULL; - struct stat st; - - if (stat (SDATA (file), &st) == 0 - && (fp = fopen (SDATA (file), "rb")) != NULL - && (buf = (char *) xmalloc (st.st_size), - fread (buf, 1, st.st_size, fp) == st.st_size)) - { - *size = st.st_size; - fclose (fp); - } - else - { - if (fp) - fclose (fp); - if (buf) - { - xfree (buf); - buf = NULL; - } - } - - return buf; -} - - -/* Load PBM image IMG for use on frame F. */ - -static int -pbm_load (f, img) - struct frame *f; - struct image *img; -{ - int raw_p, x, y; - int width, height, max_color_idx = 0; - XImage *ximg; - Lisp_Object file, specified_file; - enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type; - struct gcpro gcpro1; - unsigned char *contents = NULL; - unsigned char *end, *p; - int size; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - file = Qnil; - GCPRO1 (file); - - if (STRINGP (specified_file)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - contents = slurp_file (SDATA (file), &size); - if (contents == NULL) - { - image_error ("Error reading `%s'", file, Qnil); - UNGCPRO; - return 0; - } - - p = contents; - end = contents + size; - } - else - { - Lisp_Object data; - data = image_spec_value (img->spec, QCdata, NULL); - p = SDATA (data); - end = p + SBYTES (data); - } - - /* Check magic number. */ - if (end - p < 2 || *p++ != 'P') - { - image_error ("Not a PBM image: `%s'", img->spec, Qnil); - error: - xfree (contents); - UNGCPRO; - return 0; - } - - switch (*p++) - { - case '1': - raw_p = 0, type = PBM_MONO; - break; - - case '2': - raw_p = 0, type = PBM_GRAY; - break; - - case '3': - raw_p = 0, type = PBM_COLOR; - break; - - case '4': - raw_p = 1, type = PBM_MONO; - break; - - case '5': - raw_p = 1, type = PBM_GRAY; - break; - - case '6': - raw_p = 1, type = PBM_COLOR; - break; - - default: - image_error ("Not a PBM image: `%s'", img->spec, Qnil); - goto error; - } - - /* Read width, height, maximum color-component. Characters - starting with `#' up to the end of a line are ignored. */ - width = pbm_scan_number (&p, end); - height = pbm_scan_number (&p, end); - - if (type != PBM_MONO) - { - max_color_idx = pbm_scan_number (&p, end); - if (raw_p && max_color_idx > 255) - max_color_idx = 255; - } - - if (width < 0 - || height < 0 - || (type != PBM_MONO && max_color_idx < 0)) - goto error; - - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - goto error; - -#if 0 /* TODO: color tables. */ - /* Initialize the color hash table. */ - init_color_table (); -#endif - - if (type == PBM_MONO) - { - int c = 0, g; - struct image_keyword fmt[PBM_LAST]; - unsigned long fg = FRAME_FOREGROUND_PIXEL (f); - unsigned long bg = FRAME_BACKGROUND_PIXEL (f); - - /* Parse the image specification. */ - bcopy (pbm_format, fmt, sizeof fmt); - parse_image_spec (img->spec, fmt, PBM_LAST, Qpbm); - - /* Get foreground and background colors, maybe allocate colors. */ - if (fmt[PBM_FOREGROUND].count - && STRINGP (fmt[PBM_FOREGROUND].value)) - fg = x_alloc_image_color (f, img, fmt[PBM_FOREGROUND].value, fg); - if (fmt[PBM_BACKGROUND].count - && STRINGP (fmt[PBM_BACKGROUND].value)) - { - bg = x_alloc_image_color (f, img, fmt[PBM_BACKGROUND].value, bg); - img->background = bg; - img->background_valid = 1; - } - - for (y = 0; y < height; ++y) - for (x = 0; x < width; ++x) - { - if (raw_p) - { - if ((x & 7) == 0) - c = *p++; - g = c & 0x80; - c <<= 1; - } - else - g = pbm_scan_number (&p, end); - - XPutPixel (ximg, x, y, g ? fg : bg); - } - } - else - { - for (y = 0; y < height; ++y) - for (x = 0; x < width; ++x) - { - int r, g, b; - - if (type == PBM_GRAY) - r = g = b = raw_p ? *p++ : pbm_scan_number (&p, end); - else if (raw_p) - { - r = *p++; - g = *p++; - b = *p++; - } - else - { - r = pbm_scan_number (&p, end); - g = pbm_scan_number (&p, end); - b = pbm_scan_number (&p, end); - } - - if (r < 0 || g < 0 || b < 0) - { - x_destroy_x_image (ximg); - image_error ("Invalid pixel value in image `%s'", - img->spec, Qnil); - goto error; - } - - /* RGB values are now in the range 0..max_color_idx. - Scale this to the range 0..0xff supported by W32. */ - r = (int) ((double) r * 255 / max_color_idx); - g = (int) ((double) g * 255 / max_color_idx); - b = (int) ((double) b * 255 / max_color_idx); - XPutPixel (ximg, x, y, -#if 0 /* TODO: color tables. */ - lookup_rgb_color (f, r, g, b)); -#else - PALETTERGB (r, g, b)); -#endif - } - } - -#if 0 /* TODO: color tables. */ - /* Store in IMG->colors the colors allocated for the image, and - free the color table. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into a pixmap. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - - img->width = width; - img->height = height; - - UNGCPRO; - xfree (contents); - return 1; -} - - -/*********************************************************************** - PNG - ***********************************************************************/ - -#if HAVE_PNG - -#include <png.h> - -/* Function prototypes. */ - -static int png_image_p P_ ((Lisp_Object object)); -static int png_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `png' identifying images of this type. */ - -Lisp_Object Qpng; - -/* Indices of image specification fields in png_format, below. */ - -enum png_keyword_index -{ - PNG_TYPE, - PNG_DATA, - PNG_FILE, - PNG_ASCENT, - PNG_MARGIN, - PNG_RELIEF, - PNG_ALGORITHM, - PNG_HEURISTIC_MASK, - PNG_MASK, - PNG_BACKGROUND, - PNG_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword png_format[PNG_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `png'. */ - -static struct image_type png_type = -{ - &Qpng, - png_image_p, - png_load, - x_clear_image, - NULL -}; - -/* PNG library details. */ - -DEF_IMGLIB_FN (png_get_io_ptr); -DEF_IMGLIB_FN (png_check_sig); -DEF_IMGLIB_FN (png_create_read_struct); -DEF_IMGLIB_FN (png_create_info_struct); -DEF_IMGLIB_FN (png_destroy_read_struct); -DEF_IMGLIB_FN (png_set_read_fn); -DEF_IMGLIB_FN (png_init_io); -DEF_IMGLIB_FN (png_set_sig_bytes); -DEF_IMGLIB_FN (png_read_info); -DEF_IMGLIB_FN (png_get_IHDR); -DEF_IMGLIB_FN (png_get_valid); -DEF_IMGLIB_FN (png_set_strip_16); -DEF_IMGLIB_FN (png_set_expand); -DEF_IMGLIB_FN (png_set_gray_to_rgb); -DEF_IMGLIB_FN (png_set_background); -DEF_IMGLIB_FN (png_get_bKGD); -DEF_IMGLIB_FN (png_read_update_info); -DEF_IMGLIB_FN (png_get_channels); -DEF_IMGLIB_FN (png_get_rowbytes); -DEF_IMGLIB_FN (png_read_image); -DEF_IMGLIB_FN (png_read_end); -DEF_IMGLIB_FN (png_error); - -static int -init_png_functions (library) - HMODULE library; -{ - LOAD_IMGLIB_FN (library, png_get_io_ptr); - LOAD_IMGLIB_FN (library, png_check_sig); - LOAD_IMGLIB_FN (library, png_create_read_struct); - LOAD_IMGLIB_FN (library, png_create_info_struct); - LOAD_IMGLIB_FN (library, png_destroy_read_struct); - LOAD_IMGLIB_FN (library, png_set_read_fn); - LOAD_IMGLIB_FN (library, png_init_io); - LOAD_IMGLIB_FN (library, png_set_sig_bytes); - LOAD_IMGLIB_FN (library, png_read_info); - LOAD_IMGLIB_FN (library, png_get_IHDR); - LOAD_IMGLIB_FN (library, png_get_valid); - LOAD_IMGLIB_FN (library, png_set_strip_16); - LOAD_IMGLIB_FN (library, png_set_expand); - LOAD_IMGLIB_FN (library, png_set_gray_to_rgb); - LOAD_IMGLIB_FN (library, png_set_background); - LOAD_IMGLIB_FN (library, png_get_bKGD); - LOAD_IMGLIB_FN (library, png_read_update_info); - LOAD_IMGLIB_FN (library, png_get_channels); - LOAD_IMGLIB_FN (library, png_get_rowbytes); - LOAD_IMGLIB_FN (library, png_read_image); - LOAD_IMGLIB_FN (library, png_read_end); - LOAD_IMGLIB_FN (library, png_error); - return 1; -} - -/* Return non-zero if OBJECT is a valid PNG image specification. */ - -static int -png_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[PNG_LAST]; - bcopy (png_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, PNG_LAST, Qpng)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1; -} - - -/* Error and warning handlers installed when the PNG library - is initialized. */ - -static void -my_png_error (png_ptr, msg) - png_struct *png_ptr; - char *msg; -{ - xassert (png_ptr != NULL); - image_error ("PNG error: %s", build_string (msg), Qnil); - longjmp (png_ptr->jmpbuf, 1); -} - - -static void -my_png_warning (png_ptr, msg) - png_struct *png_ptr; - char *msg; -{ - xassert (png_ptr != NULL); - image_error ("PNG warning: %s", build_string (msg), Qnil); -} - -/* Memory source for PNG decoding. */ - -struct png_memory_storage -{ - unsigned char *bytes; /* The data */ - size_t len; /* How big is it? */ - int index; /* Where are we? */ -}; - - -/* Function set as reader function when reading PNG image from memory. - PNG_PTR is a pointer to the PNG control structure. Copy LENGTH - bytes from the input to DATA. */ - -static void -png_read_from_memory (png_ptr, data, length) - png_structp png_ptr; - png_bytep data; - png_size_t length; -{ - struct png_memory_storage *tbr - = (struct png_memory_storage *) fn_png_get_io_ptr (png_ptr); - - if (length > tbr->len - tbr->index) - fn_png_error (png_ptr, "Read error"); - - bcopy (tbr->bytes + tbr->index, data, length); - tbr->index = tbr->index + length; -} - -/* Load PNG image IMG for use on frame F. Value is non-zero if - successful. */ - -static int -png_load (f, img) - struct frame *f; - struct image *img; -{ - Lisp_Object file, specified_file; - Lisp_Object specified_data; - int x, y, i; - XImage *ximg, *mask_img = NULL; - struct gcpro gcpro1; - png_struct *png_ptr = NULL; - png_info *info_ptr = NULL, *end_info = NULL; - FILE *volatile fp = NULL; - png_byte sig[8]; - png_byte * volatile pixels = NULL; - png_byte ** volatile rows = NULL; - png_uint_32 width, height; - int bit_depth, color_type, interlace_type; - png_byte channels; - png_uint_32 row_bytes; - int transparent_p; - double screen_gamma, image_gamma; - int intent; - struct png_memory_storage tbr; /* Data to be read */ - - /* Find out what file to load. */ - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - if (NILP (specified_data)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - /* Open the image file. */ - fp = fopen (SDATA (file), "rb"); - if (!fp) - { - image_error ("Cannot open image file `%s'", file, Qnil); - UNGCPRO; - fclose (fp); - return 0; - } - - /* Check PNG signature. */ - if (fread (sig, 1, sizeof sig, fp) != sizeof sig - || !fn_png_check_sig (sig, sizeof sig)) - { - image_error ("Not a PNG file: `%s'", file, Qnil); - UNGCPRO; - fclose (fp); - return 0; - } - } - else - { - /* Read from memory. */ - tbr.bytes = SDATA (specified_data); - tbr.len = SBYTES (specified_data); - tbr.index = 0; - - /* Check PNG signature. */ - if (tbr.len < sizeof sig - || !fn_png_check_sig (tbr.bytes, sizeof sig)) - { - image_error ("Not a PNG image: `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - - /* Need to skip past the signature. */ - tbr.bytes += sizeof (sig); - } - - /* Initialize read and info structs for PNG lib. */ - png_ptr = fn_png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL, - my_png_error, my_png_warning); - if (!png_ptr) - { - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - info_ptr = fn_png_create_info_struct (png_ptr); - if (!info_ptr) - { - fn_png_destroy_read_struct (&png_ptr, NULL, NULL); - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - end_info = fn_png_create_info_struct (png_ptr); - if (!end_info) - { - fn_png_destroy_read_struct (&png_ptr, &info_ptr, NULL); - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - /* Set error jump-back. We come back here when the PNG library - detects an error. */ - if (setjmp (png_ptr->jmpbuf)) - { - error: - if (png_ptr) - fn_png_destroy_read_struct (&png_ptr, &info_ptr, &end_info); - xfree (pixels); - xfree (rows); - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - /* Read image info. */ - if (!NILP (specified_data)) - fn_png_set_read_fn (png_ptr, (void *) &tbr, png_read_from_memory); - else - fn_png_init_io (png_ptr, fp); - - fn_png_set_sig_bytes (png_ptr, sizeof sig); - fn_png_read_info (png_ptr, info_ptr); - fn_png_get_IHDR (png_ptr, info_ptr, &width, &height, &bit_depth, &color_type, - &interlace_type, NULL, NULL); - - /* If image contains simply transparency data, we prefer to - construct a clipping mask. */ - if (fn_png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS)) - transparent_p = 1; - else - transparent_p = 0; - - /* This function is easier to write if we only have to handle - one data format: RGB or RGBA with 8 bits per channel. Let's - transform other formats into that format. */ - - /* Strip more than 8 bits per channel. */ - if (bit_depth == 16) - fn_png_set_strip_16 (png_ptr); - - /* Expand data to 24 bit RGB, or 8 bit grayscale, with alpha channel - if available. */ - fn_png_set_expand (png_ptr); - - /* Convert grayscale images to RGB. */ - if (color_type == PNG_COLOR_TYPE_GRAY - || color_type == PNG_COLOR_TYPE_GRAY_ALPHA) - fn_png_set_gray_to_rgb (png_ptr); - - screen_gamma = (f->gamma ? 1 / f->gamma / 0.45455 : 2.2); - -#if 0 /* Avoid double gamma correction for PNG images. */ - /* Tell the PNG lib to handle gamma correction for us. */ -#if defined(PNG_READ_sRGB_SUPPORTED) || defined(PNG_WRITE_sRGB_SUPPORTED) - if (png_get_sRGB (png_ptr, info_ptr, &intent)) - /* The libpng documentation says this is right in this case. */ - png_set_gamma (png_ptr, screen_gamma, 0.45455); - else -#endif - if (png_get_gAMA (png_ptr, info_ptr, &image_gamma)) - /* Image contains gamma information. */ - png_set_gamma (png_ptr, screen_gamma, image_gamma); - else - /* Use the standard default for the image gamma. */ - png_set_gamma (png_ptr, screen_gamma, 0.45455); -#endif /* if 0 */ - - /* Handle alpha channel by combining the image with a background - color. Do this only if a real alpha channel is supplied. For - simple transparency, we prefer a clipping mask. */ - if (!transparent_p) - { - png_color_16 *image_bg; - Lisp_Object specified_bg - = image_spec_value (img->spec, QCbackground, NULL); - - if (STRINGP (specified_bg)) - /* The user specified `:background', use that. */ - { - COLORREF color; - if (w32_defined_color (f, SDATA (specified_bg), &color, 0)) - { - png_color_16 user_bg; - - bzero (&user_bg, sizeof user_bg); - user_bg.red = 256 * GetRValue (color); - user_bg.green = 256 * GetGValue (color); - user_bg.blue = 256 * GetBValue (color); - - fn_png_set_background (png_ptr, &user_bg, - PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); - } - } - else if (fn_png_get_bKGD (png_ptr, info_ptr, &image_bg)) - /* Image contains a background color with which to - combine the image. */ - fn_png_set_background (png_ptr, image_bg, - PNG_BACKGROUND_GAMMA_FILE, 1, 1.0); - else - { - /* Image does not contain a background color with which - to combine the image data via an alpha channel. Use - the frame's background instead. */ - COLORREF color; - png_color_16 frame_background; - color = FRAME_BACKGROUND_PIXEL (f); -#if 0 /* TODO : Colormap support. */ - Colormap cmap; - - cmap = FRAME_X_COLORMAP (f); - x_query_color (f, &color); -#endif - - bzero (&frame_background, sizeof frame_background); - frame_background.red = 256 * GetRValue (color); - frame_background.green = 256 * GetGValue (color); - frame_background.blue = 256 * GetBValue (color); - - fn_png_set_background (png_ptr, &frame_background, - PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); - } - } - - /* Update info structure. */ - fn_png_read_update_info (png_ptr, info_ptr); - - /* Get number of channels. Valid values are 1 for grayscale images - and images with a palette, 2 for grayscale images with transparency - information (alpha channel), 3 for RGB images, and 4 for RGB - images with alpha channel, i.e. RGBA. If conversions above were - sufficient we should only have 3 or 4 channels here. */ - channels = fn_png_get_channels (png_ptr, info_ptr); - xassert (channels == 3 || channels == 4); - - /* Number of bytes needed for one row of the image. */ - row_bytes = fn_png_get_rowbytes (png_ptr, info_ptr); - - /* Allocate memory for the image. */ - pixels = (png_byte *) xmalloc (row_bytes * height * sizeof *pixels); - rows = (png_byte **) xmalloc (height * sizeof *rows); - for (i = 0; i < height; ++i) - rows[i] = pixels + i * row_bytes; - - /* Read the entire image. */ - fn_png_read_image (png_ptr, rows); - fn_png_read_end (png_ptr, info_ptr); - if (fp) - { - fclose (fp); - fp = NULL; - } - - /* Create the X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, - &img->pixmap)) - goto error; - - /* Create an image and pixmap serving as mask if the PNG image - contains an alpha channel. */ - if (channels == 4 - && !transparent_p - && !x_create_x_image_and_pixmap (f, width, height, 1, - &mask_img, &img->mask)) - { - x_destroy_x_image (ximg); - DeleteObject (img->pixmap); - img->pixmap = 0; - goto error; - } - /* Fill the X image and mask from PNG data. */ -#if 0 /* TODO: Color tables. */ - init_color_table (); -#endif - - for (y = 0; y < height; ++y) - { - png_byte *p = rows[y]; - - for (x = 0; x < width; ++x) - { - unsigned r, g, b; - - r = *p++; - g = *p++; - b = *p++; -#if 0 /* TODO: Color tables. */ - XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b)); -#else - XPutPixel (ximg, x, y, PALETTERGB (r, g, b)); -#endif - /* An alpha channel, aka mask channel, associates variable - transparency with an image. Where other image formats - support binary transparency---fully transparent or fully - opaque---PNG allows up to 254 levels of partial transparency. - The PNG library implements partial transparency by combining - the image with a specified background color. - - I'm not sure how to handle this here nicely: because the - background on which the image is displayed may change, for - real alpha channel support, it would be necessary to create - a new image for each possible background. - - What I'm doing now is that a mask is created if we have - boolean transparency information. Otherwise I'm using - the frame's background color to combine the image with. */ - - if (channels == 4) - { - if (mask_img) - XPutPixel (mask_img, x, y, *p > 0); - ++p; - } - } - } - - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - /* Set IMG's background color from the PNG image, unless the user - overrode it. */ - { - png_color_16 *bg; - if (fn_png_get_bKGD (png_ptr, info_ptr, &bg)) - { -#if 0 /* TODO: Color tables. */ - img->background = lookup_rgb_color (f, bg->red, bg->green, bg->blue); -#else - img->background = PALETTERGB (bg->red / 256, bg->green / 256, - bg->blue / 256); -#endif - img->background_valid = 1; - } - } - -#if 0 /* TODO: Color tables. */ - /* Remember colors allocated for this image. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif - - /* Clean up. */ - fn_png_destroy_read_struct (&png_ptr, &info_ptr, &end_info); - xfree (rows); - xfree (pixels); - - img->width = width; - img->height = height; - - /* Maybe fill in the background field while we have ximg handy. */ - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap, then free the X image and its buffer. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - - /* Same for the mask. */ - if (mask_img) - { - /* Fill in the background_transparent field while we have the mask - handy. */ - image_background_transparent (img, f, mask_img); - - x_put_x_image (f, mask_img, img->mask, img->width, img->height); - x_destroy_x_image (mask_img); - } - - UNGCPRO; - return 1; -} - -#endif /* HAVE_PNG != 0 */ - - - -/*********************************************************************** - JPEG - ***********************************************************************/ - -#if HAVE_JPEG - -/* Work around a warning about HAVE_STDLIB_H being redefined in - jconfig.h. */ -#ifdef HAVE_STDLIB_H -#define HAVE_STDLIB_H_1 -#undef HAVE_STDLIB_H -#endif /* HAVE_STLIB_H */ - -#include <jpeglib.h> -#include <jerror.h> -#include <setjmp.h> - -#ifdef HAVE_STLIB_H_1 -#define HAVE_STDLIB_H 1 -#endif - -static int jpeg_image_p P_ ((Lisp_Object object)); -static int jpeg_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `jpeg' identifying images of this type. */ - -Lisp_Object Qjpeg; - -/* Indices of image specification fields in gs_format, below. */ - -enum jpeg_keyword_index -{ - JPEG_TYPE, - JPEG_DATA, - JPEG_FILE, - JPEG_ASCENT, - JPEG_MARGIN, - JPEG_RELIEF, - JPEG_ALGORITHM, - JPEG_HEURISTIC_MASK, - JPEG_MASK, - JPEG_BACKGROUND, - JPEG_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword jpeg_format[JPEG_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversions", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `jpeg'. */ - -static struct image_type jpeg_type = -{ - &Qjpeg, - jpeg_image_p, - jpeg_load, - x_clear_image, - NULL -}; - - -/* JPEG library details. */ -DEF_IMGLIB_FN (jpeg_CreateDecompress); -DEF_IMGLIB_FN (jpeg_start_decompress); -DEF_IMGLIB_FN (jpeg_finish_decompress); -DEF_IMGLIB_FN (jpeg_destroy_decompress); -DEF_IMGLIB_FN (jpeg_read_header); -DEF_IMGLIB_FN (jpeg_read_scanlines); -DEF_IMGLIB_FN (jpeg_stdio_src); -DEF_IMGLIB_FN (jpeg_std_error); -DEF_IMGLIB_FN (jpeg_resync_to_restart); - -static int -init_jpeg_functions (library) - HMODULE library; -{ - LOAD_IMGLIB_FN (library, jpeg_finish_decompress); - LOAD_IMGLIB_FN (library, jpeg_read_scanlines); - LOAD_IMGLIB_FN (library, jpeg_start_decompress); - LOAD_IMGLIB_FN (library, jpeg_read_header); - LOAD_IMGLIB_FN (library, jpeg_stdio_src); - LOAD_IMGLIB_FN (library, jpeg_CreateDecompress); - LOAD_IMGLIB_FN (library, jpeg_destroy_decompress); - LOAD_IMGLIB_FN (library, jpeg_std_error); - LOAD_IMGLIB_FN (library, jpeg_resync_to_restart); - return 1; -} - -/* Wrapper since we can't directly assign the function pointer - to another function pointer that was declared more completely easily. */ -static boolean -jpeg_resync_to_restart_wrapper(cinfo, desired) - j_decompress_ptr cinfo; - int desired; -{ - return fn_jpeg_resync_to_restart (cinfo, desired); -} - - -/* Return non-zero if OBJECT is a valid JPEG image specification. */ - -static int -jpeg_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[JPEG_LAST]; - - bcopy (jpeg_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, JPEG_LAST, Qjpeg)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1; -} - - -struct my_jpeg_error_mgr -{ - struct jpeg_error_mgr pub; - jmp_buf setjmp_buffer; -}; - - -static void -my_error_exit (cinfo) - j_common_ptr cinfo; -{ - struct my_jpeg_error_mgr *mgr = (struct my_jpeg_error_mgr *) cinfo->err; - longjmp (mgr->setjmp_buffer, 1); -} - - -/* Init source method for JPEG data source manager. Called by - jpeg_read_header() before any data is actually read. See - libjpeg.doc from the JPEG lib distribution. */ - -static void -our_init_source (cinfo) - j_decompress_ptr cinfo; -{ -} - - -/* Fill input buffer method for JPEG data source manager. Called - whenever more data is needed. We read the whole image in one step, - so this only adds a fake end of input marker at the end. */ - -static boolean -our_fill_input_buffer (cinfo) - j_decompress_ptr cinfo; -{ - /* Insert a fake EOI marker. */ - struct jpeg_source_mgr *src = cinfo->src; - static JOCTET buffer[2]; - - buffer[0] = (JOCTET) 0xFF; - buffer[1] = (JOCTET) JPEG_EOI; - - src->next_input_byte = buffer; - src->bytes_in_buffer = 2; - return TRUE; -} - - -/* Method to skip over NUM_BYTES bytes in the image data. CINFO->src - is the JPEG data source manager. */ - -static void -our_skip_input_data (cinfo, num_bytes) - j_decompress_ptr cinfo; - long num_bytes; -{ - struct jpeg_source_mgr *src = (struct jpeg_source_mgr *) cinfo->src; - - if (src) - { - if (num_bytes > src->bytes_in_buffer) - ERREXIT (cinfo, JERR_INPUT_EOF); - - src->bytes_in_buffer -= num_bytes; - src->next_input_byte += num_bytes; - } -} - - -/* Method to terminate data source. Called by - jpeg_finish_decompress() after all data has been processed. */ - -static void -our_term_source (cinfo) - j_decompress_ptr cinfo; -{ -} - - -/* Set up the JPEG lib for reading an image from DATA which contains - LEN bytes. CINFO is the decompression info structure created for - reading the image. */ - -static void -jpeg_memory_src (cinfo, data, len) - j_decompress_ptr cinfo; - JOCTET *data; - unsigned int len; -{ - struct jpeg_source_mgr *src; - - if (cinfo->src == NULL) - { - /* First time for this JPEG object? */ - cinfo->src = (struct jpeg_source_mgr *) - (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT, - sizeof (struct jpeg_source_mgr)); - src = (struct jpeg_source_mgr *) cinfo->src; - src->next_input_byte = data; - } - - src = (struct jpeg_source_mgr *) cinfo->src; - src->init_source = our_init_source; - src->fill_input_buffer = our_fill_input_buffer; - src->skip_input_data = our_skip_input_data; - src->resync_to_restart = jpeg_resync_to_restart_wrapper; /* Use default method. */ - src->term_source = our_term_source; - src->bytes_in_buffer = len; - src->next_input_byte = data; -} - - -/* Load image IMG for use on frame F. Patterned after example.c - from the JPEG lib. */ - -static int -jpeg_load (f, img) - struct frame *f; - struct image *img; -{ - struct jpeg_decompress_struct cinfo; - struct my_jpeg_error_mgr mgr; - Lisp_Object file, specified_file; - Lisp_Object specified_data; - FILE * volatile fp = NULL; - JSAMPARRAY buffer; - int row_stride, x, y; - XImage *ximg = NULL; - int rc; - unsigned long *colors; - int width, height; - struct gcpro gcpro1; - - /* Open the JPEG file. */ - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - if (NILP (specified_data)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - fp = fopen (SDATA (file), "rb"); - if (fp == NULL) - { - image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; - return 0; - } - } - - /* Customize libjpeg's error handling to call my_error_exit when an - error is detected. This function will perform a longjmp. */ - cinfo.err = fn_jpeg_std_error (&mgr.pub); - mgr.pub.error_exit = my_error_exit; - - if ((rc = setjmp (mgr.setjmp_buffer)) != 0) - { - if (rc == 1) - { - /* Called from my_error_exit. Display a JPEG error. */ - char buffer[JMSG_LENGTH_MAX]; - cinfo.err->format_message ((j_common_ptr) &cinfo, buffer); - image_error ("Error reading JPEG image `%s': %s", img->spec, - build_string (buffer)); - } - - /* Close the input file and destroy the JPEG object. */ - if (fp) - fclose ((FILE *) fp); - fn_jpeg_destroy_decompress (&cinfo); - - /* If we already have an XImage, free that. */ - x_destroy_x_image (ximg); - - /* Free pixmap and colors. */ - x_clear_image (f, img); - - UNGCPRO; - return 0; - } - - /* Create the JPEG decompression object. Let it read from fp. - Read the JPEG image header. */ - fn_jpeg_CreateDecompress (&cinfo, JPEG_LIB_VERSION, sizeof (cinfo)); - - if (NILP (specified_data)) - fn_jpeg_stdio_src (&cinfo, (FILE *) fp); - else - jpeg_memory_src (&cinfo, SDATA (specified_data), - SBYTES (specified_data)); - - fn_jpeg_read_header (&cinfo, TRUE); - - /* Customize decompression so that color quantization will be used. - Start decompression. */ - cinfo.quantize_colors = TRUE; - fn_jpeg_start_decompress (&cinfo); - width = img->width = cinfo.output_width; - height = img->height = cinfo.output_height; - - /* Create X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - longjmp (mgr.setjmp_buffer, 2); - - /* Allocate colors. When color quantization is used, - cinfo.actual_number_of_colors has been set with the number of - colors generated, and cinfo.colormap is a two-dimensional array - of color indices in the range 0..cinfo.actual_number_of_colors. - No more than 255 colors will be generated. */ - { - int i, ir, ig, ib; - - if (cinfo.out_color_components > 2) - ir = 0, ig = 1, ib = 2; - else if (cinfo.out_color_components > 1) - ir = 0, ig = 1, ib = 0; - else - ir = 0, ig = 0, ib = 0; - -#if 0 /* TODO: Color tables. */ - /* Use the color table mechanism because it handles colors that - cannot be allocated nicely. Such colors will be replaced with - a default color, and we don't have to care about which colors - can be freed safely, and which can't. */ - init_color_table (); -#endif - colors = (unsigned long *) alloca (cinfo.actual_number_of_colors - * sizeof *colors); - - for (i = 0; i < cinfo.actual_number_of_colors; ++i) - { - int r = cinfo.colormap[ir][i]; - int g = cinfo.colormap[ig][i]; - int b = cinfo.colormap[ib][i]; -#if 0 /* TODO: Color tables. */ - colors[i] = lookup_rgb_color (f, r, g, b); -#else - colors[i] = PALETTERGB (r, g, b); -#endif - } - -#if 0 /* TODO: Color tables. */ - /* Remember those colors actually allocated. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif - } - - /* Read pixels. */ - row_stride = width * cinfo.output_components; - buffer = cinfo.mem->alloc_sarray ((j_common_ptr) &cinfo, JPOOL_IMAGE, - row_stride, 1); - for (y = 0; y < height; ++y) - { - fn_jpeg_read_scanlines (&cinfo, buffer, 1); - for (x = 0; x < cinfo.output_width; ++x) - XPutPixel (ximg, x, y, colors[buffer[0][x]]); - } - - /* Clean up. */ - fn_jpeg_finish_decompress (&cinfo); - fn_jpeg_destroy_decompress (&cinfo); - if (fp) - fclose ((FILE *) fp); - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - UNGCPRO; - return 1; -} - -#endif /* HAVE_JPEG */ - - - -/*********************************************************************** - TIFF - ***********************************************************************/ - -#if HAVE_TIFF - -#include <tiffio.h> - -static int tiff_image_p P_ ((Lisp_Object object)); -static int tiff_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `tiff' identifying images of this type. */ - -Lisp_Object Qtiff; - -/* Indices of image specification fields in tiff_format, below. */ - -enum tiff_keyword_index -{ - TIFF_TYPE, - TIFF_DATA, - TIFF_FILE, - TIFF_ASCENT, - TIFF_MARGIN, - TIFF_RELIEF, - TIFF_ALGORITHM, - TIFF_HEURISTIC_MASK, - TIFF_MASK, - TIFF_BACKGROUND, - TIFF_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword tiff_format[TIFF_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversions", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `tiff'. */ - -static struct image_type tiff_type = -{ - &Qtiff, - tiff_image_p, - tiff_load, - x_clear_image, - NULL -}; - -/* TIFF library details. */ -DEF_IMGLIB_FN (TIFFSetErrorHandler); -DEF_IMGLIB_FN (TIFFSetWarningHandler); -DEF_IMGLIB_FN (TIFFOpen); -DEF_IMGLIB_FN (TIFFClientOpen); -DEF_IMGLIB_FN (TIFFGetField); -DEF_IMGLIB_FN (TIFFReadRGBAImage); -DEF_IMGLIB_FN (TIFFClose); - -static int -init_tiff_functions (library) - HMODULE library; -{ - LOAD_IMGLIB_FN (library, TIFFSetErrorHandler); - LOAD_IMGLIB_FN (library, TIFFSetWarningHandler); - LOAD_IMGLIB_FN (library, TIFFOpen); - LOAD_IMGLIB_FN (library, TIFFClientOpen); - LOAD_IMGLIB_FN (library, TIFFGetField); - LOAD_IMGLIB_FN (library, TIFFReadRGBAImage); - LOAD_IMGLIB_FN (library, TIFFClose); - return 1; -} - -/* Return non-zero if OBJECT is a valid TIFF image specification. */ - -static int -tiff_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[TIFF_LAST]; - bcopy (tiff_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, TIFF_LAST, Qtiff)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1; -} - - -/* Reading from a memory buffer for TIFF images Based on the PNG - memory source, but we have to provide a lot of extra functions. - Blah. - - We really only need to implement read and seek, but I am not - convinced that the TIFF library is smart enough not to destroy - itself if we only hand it the function pointers we need to - override. */ - -typedef struct -{ - unsigned char *bytes; - size_t len; - int index; -} -tiff_memory_source; - -static size_t -tiff_read_from_memory (data, buf, size) - thandle_t data; - tdata_t buf; - tsize_t size; -{ - tiff_memory_source *src = (tiff_memory_source *) data; - - if (size > src->len - src->index) - return (size_t) -1; - bcopy (src->bytes + src->index, buf, size); - src->index += size; - return size; -} - -static size_t -tiff_write_from_memory (data, buf, size) - thandle_t data; - tdata_t buf; - tsize_t size; -{ - return (size_t) -1; -} - -static toff_t -tiff_seek_in_memory (data, off, whence) - thandle_t data; - toff_t off; - int whence; -{ - tiff_memory_source *src = (tiff_memory_source *) data; - int idx; - - switch (whence) - { - case SEEK_SET: /* Go from beginning of source. */ - idx = off; - break; - - case SEEK_END: /* Go from end of source. */ - idx = src->len + off; - break; - - case SEEK_CUR: /* Go from current position. */ - idx = src->index + off; - break; - - default: /* Invalid `whence'. */ - return -1; - } - - if (idx > src->len || idx < 0) - return -1; - - src->index = idx; - return src->index; -} - -static int -tiff_close_memory (data) - thandle_t data; -{ - /* NOOP */ - return 0; -} - -static int -tiff_mmap_memory (data, pbase, psize) - thandle_t data; - tdata_t *pbase; - toff_t *psize; -{ - /* It is already _IN_ memory. */ - return 0; -} - -static void -tiff_unmap_memory (data, base, size) - thandle_t data; - tdata_t base; - toff_t size; -{ - /* We don't need to do this. */ -} - -static toff_t -tiff_size_of_memory (data) - thandle_t data; -{ - return ((tiff_memory_source *) data)->len; -} - - -static void -tiff_error_handler (title, format, ap) - const char *title, *format; - va_list ap; -{ - char buf[512]; - int len; - - len = sprintf (buf, "TIFF error: %s ", title); - vsprintf (buf + len, format, ap); - add_to_log (buf, Qnil, Qnil); -} - - -static void -tiff_warning_handler (title, format, ap) - const char *title, *format; - va_list ap; -{ - char buf[512]; - int len; - - len = sprintf (buf, "TIFF warning: %s ", title); - vsprintf (buf + len, format, ap); - add_to_log (buf, Qnil, Qnil); -} - - -/* Load TIFF image IMG for use on frame F. Value is non-zero if - successful. */ - -static int -tiff_load (f, img) - struct frame *f; - struct image *img; -{ - Lisp_Object file, specified_file; - Lisp_Object specified_data; - TIFF *tiff; - int width, height, x, y; - uint32 *buf; - int rc; - XImage *ximg; - struct gcpro gcpro1; - tiff_memory_source memsrc; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - fn_TIFFSetErrorHandler (tiff_error_handler); - fn_TIFFSetWarningHandler (tiff_warning_handler); - - if (NILP (specified_data)) - { - /* Read from a file */ - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", file, Qnil); - UNGCPRO; - return 0; - } - - /* Try to open the image file. */ - tiff = fn_TIFFOpen (SDATA (file), "r"); - if (tiff == NULL) - { - image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; - return 0; - } - } - else - { - /* Memory source! */ - memsrc.bytes = SDATA (specified_data); - memsrc.len = SBYTES (specified_data); - memsrc.index = 0; - - tiff = fn_TIFFClientOpen ("memory_source", "r", &memsrc, - (TIFFReadWriteProc) tiff_read_from_memory, - (TIFFReadWriteProc) tiff_write_from_memory, - tiff_seek_in_memory, - tiff_close_memory, - tiff_size_of_memory, - tiff_mmap_memory, - tiff_unmap_memory); - - if (!tiff) - { - image_error ("Cannot open memory source for `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - } - - /* Get width and height of the image, and allocate a raster buffer - of width x height 32-bit values. */ - fn_TIFFGetField (tiff, TIFFTAG_IMAGEWIDTH, &width); - fn_TIFFGetField (tiff, TIFFTAG_IMAGELENGTH, &height); - buf = (uint32 *) xmalloc (width * height * sizeof *buf); - - rc = fn_TIFFReadRGBAImage (tiff, width, height, buf, 0); - fn_TIFFClose (tiff); - if (!rc) - { - image_error ("Error reading TIFF image `%s'", img->spec, Qnil); - xfree (buf); - UNGCPRO; - return 0; - } - - /* Create the X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - { - xfree (buf); - UNGCPRO; - return 0; - } - -#if 0 /* TODO: Color tables. */ - /* Initialize the color table. */ - init_color_table (); -#endif - - /* Process the pixel raster. Origin is in the lower-left corner. */ - for (y = 0; y < height; ++y) - { - uint32 *row = buf + y * width; - - for (x = 0; x < width; ++x) - { - uint32 abgr = row[x]; - int r = TIFFGetR (abgr); - int g = TIFFGetG (abgr); - int b = TIFFGetB (abgr); -#if 0 /* TODO: Color tables. */ - XPutPixel (ximg, x, height - 1 - y, lookup_rgb_color (f, r, g, b)); -#else - XPutPixel (ximg, x, height - 1 - y, PALETTERGB (r, g, b)); -#endif - } - } - -#if 0 /* TODO: Color tables. */ - /* Remember the colors allocated for the image. Free the color table. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif - - img->width = width; - img->height = height; - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap, then free the X image and its buffer. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - xfree (buf); - - UNGCPRO; - return 1; -} - -#endif /* HAVE_TIFF != 0 */ - - - -/*********************************************************************** - GIF - ***********************************************************************/ - -#if HAVE_GIF - -#define DrawText gif_DrawText -#include <gif_lib.h> -#undef DrawText - -static int gif_image_p P_ ((Lisp_Object object)); -static int gif_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `gif' identifying images of this type. */ - -Lisp_Object Qgif; - -/* Indices of image specification fields in gif_format, below. */ - -enum gif_keyword_index -{ - GIF_TYPE, - GIF_DATA, - GIF_FILE, - GIF_ASCENT, - GIF_MARGIN, - GIF_RELIEF, - GIF_ALGORITHM, - GIF_HEURISTIC_MASK, - GIF_MASK, - GIF_IMAGE, - GIF_BACKGROUND, - GIF_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword gif_format[GIF_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":image", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `gif'. */ - -static struct image_type gif_type = -{ - &Qgif, - gif_image_p, - gif_load, - x_clear_image, - NULL -}; - - -/* GIF library details. */ -DEF_IMGLIB_FN (DGifCloseFile); -DEF_IMGLIB_FN (DGifSlurp); -DEF_IMGLIB_FN (DGifOpen); -DEF_IMGLIB_FN (DGifOpenFileName); - -static int -init_gif_functions (library) - HMODULE library; -{ - LOAD_IMGLIB_FN (library, DGifCloseFile); - LOAD_IMGLIB_FN (library, DGifSlurp); - LOAD_IMGLIB_FN (library, DGifOpen); - LOAD_IMGLIB_FN (library, DGifOpenFileName); - return 1; -} - - -/* Return non-zero if OBJECT is a valid GIF image specification. */ - -static int -gif_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[GIF_LAST]; - bcopy (gif_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, GIF_LAST, Qgif)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[GIF_FILE].count + fmt[GIF_DATA].count == 1; -} - -/* Reading a GIF image from memory - Based on the PNG memory stuff to a certain extent. */ - -typedef struct -{ - unsigned char *bytes; - size_t len; - int index; -} -gif_memory_source; - -/* Make the current memory source available to gif_read_from_memory. - It's done this way because not all versions of libungif support - a UserData field in the GifFileType structure. */ -static gif_memory_source *current_gif_memory_src; - -static int -gif_read_from_memory (file, buf, len) - GifFileType *file; - GifByteType *buf; - int len; -{ - gif_memory_source *src = current_gif_memory_src; - - if (len > src->len - src->index) - return -1; - - bcopy (src->bytes + src->index, buf, len); - src->index += len; - return len; -} - - -/* Load GIF image IMG for use on frame F. Value is non-zero if - successful. */ - -static int -gif_load (f, img) - struct frame *f; - struct image *img; -{ - Lisp_Object file, specified_file; - Lisp_Object specified_data; - int rc, width, height, x, y, i; - XImage *ximg; - ColorMapObject *gif_color_map; - unsigned long pixel_colors[256]; - GifFileType *gif; - struct gcpro gcpro1; - Lisp_Object image; - int ino, image_left, image_top, image_width, image_height; - gif_memory_source memsrc; - unsigned char *raster; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - if (NILP (specified_data)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - /* Open the GIF file. */ - gif = fn_DGifOpenFileName (SDATA (file)); - if (gif == NULL) - { - image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; - return 0; - } - } - else - { - /* Read from memory! */ - current_gif_memory_src = &memsrc; - memsrc.bytes = SDATA (specified_data); - memsrc.len = SBYTES (specified_data); - memsrc.index = 0; - - gif = fn_DGifOpen(&memsrc, gif_read_from_memory); - if (!gif) - { - image_error ("Cannot open memory source `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - } - - /* Read entire contents. */ - rc = fn_DGifSlurp (gif); - if (rc == GIF_ERROR) - { - image_error ("Error reading `%s'", img->spec, Qnil); - fn_DGifCloseFile (gif); - UNGCPRO; - return 0; - } - - image = image_spec_value (img->spec, QCindex, NULL); - ino = INTEGERP (image) ? XFASTINT (image) : 0; - if (ino >= gif->ImageCount) - { - image_error ("Invalid image number `%s' in image `%s'", - image, img->spec); - fn_DGifCloseFile (gif); - UNGCPRO; - return 0; - } - - width = img->width = max (gif->SWidth, gif->Image.Left + gif->Image.Width); - height = img->height = max (gif->SHeight, gif->Image.Top + gif->Image.Height); - - /* Create the X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - { - fn_DGifCloseFile (gif); - UNGCPRO; - return 0; - } - - /* Allocate colors. */ - gif_color_map = gif->SavedImages[ino].ImageDesc.ColorMap; - if (!gif_color_map) - gif_color_map = gif->SColorMap; -#if 0 /* TODO: Color tables */ - init_color_table (); -#endif - bzero (pixel_colors, sizeof pixel_colors); - - for (i = 0; i < gif_color_map->ColorCount; ++i) - { - int r = gif_color_map->Colors[i].Red; - int g = gif_color_map->Colors[i].Green; - int b = gif_color_map->Colors[i].Blue; -#if 0 /* TODO: Color tables */ - pixel_colors[i] = lookup_rgb_color (f, r, g, b); -#else - pixel_colors[i] = PALETTERGB (r, g, b); -#endif - } - -#if 0 /* TODO: Color tables */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -#endif - - /* Clear the part of the screen image that are not covered by - the image from the GIF file. Full animated GIF support - requires more than can be done here (see the gif89 spec, - disposal methods). Let's simply assume that the part - not covered by a sub-image is in the frame's background color. */ - image_top = gif->SavedImages[ino].ImageDesc.Top; - image_left = gif->SavedImages[ino].ImageDesc.Left; - image_width = gif->SavedImages[ino].ImageDesc.Width; - image_height = gif->SavedImages[ino].ImageDesc.Height; - - for (y = 0; y < image_top; ++y) - for (x = 0; x < width; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - - for (y = image_top + image_height; y < height; ++y) - for (x = 0; x < width; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - - for (y = image_top; y < image_top + image_height; ++y) - { - for (x = 0; x < image_left; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - for (x = image_left + image_width; x < width; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - } - - /* Read the GIF image into the X image. We use a local variable - `raster' here because RasterBits below is a char *, and invites - problems with bytes >= 0x80. */ - raster = (unsigned char *) gif->SavedImages[ino].RasterBits; - - if (gif->SavedImages[ino].ImageDesc.Interlace) - { - static int interlace_start[] = {0, 4, 2, 1}; - static int interlace_increment[] = {8, 8, 4, 2}; - int pass; - int row = interlace_start[0]; - - pass = 0; - - for (y = 0; y < image_height; y++) - { - if (row >= image_height) - { - row = interlace_start[++pass]; - while (row >= image_height) - row = interlace_start[++pass]; - } - - for (x = 0; x < image_width; x++) - { - int i = raster[(y * image_width) + x]; - XPutPixel (ximg, x + image_left, row + image_top, - pixel_colors[i]); - } - - row += interlace_increment[pass]; - } - } - else - { - for (y = 0; y < image_height; ++y) - for (x = 0; x < image_width; ++x) - { - int i = raster[y* image_width + x]; - XPutPixel (ximg, x + image_left, y + image_top, pixel_colors[i]); - } - } - - fn_DGifCloseFile (gif); - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap, then free the X image and its buffer. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - - UNGCPRO; - return 1; -} - -#endif /* HAVE_GIF != 0 */ - - - -/*********************************************************************** - Ghostscript - ***********************************************************************/ - -Lisp_Object Qpostscript; - -/* Keyword symbols. */ - -Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height; - -#ifdef HAVE_GHOSTSCRIPT -static int gs_image_p P_ ((Lisp_Object object)); -static int gs_load P_ ((struct frame *f, struct image *img)); -static void gs_clear_image P_ ((struct frame *f, struct image *img)); - -/* The symbol `postscript' identifying images of this type. */ - -/* Keyword symbols. */ - -Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height; - -/* Indices of image specification fields in gs_format, below. */ - -enum gs_keyword_index -{ - GS_TYPE, - GS_PT_WIDTH, - GS_PT_HEIGHT, - GS_FILE, - GS_LOADER, - GS_BOUNDING_BOX, - GS_ASCENT, - GS_MARGIN, - GS_RELIEF, - GS_ALGORITHM, - GS_HEURISTIC_MASK, - GS_MASK, - GS_BACKGROUND, - GS_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword gs_format[GS_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":pt-width", IMAGE_POSITIVE_INTEGER_VALUE, 1}, - {":pt-height", IMAGE_POSITIVE_INTEGER_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 1}, - {":loader", IMAGE_FUNCTION_VALUE, 0}, - {":bounding-box", IMAGE_DONT_CHECK_VALUE_TYPE, 1}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `ghostscript'. */ - -static struct image_type gs_type = -{ - &Qpostscript, - gs_image_p, - gs_load, - gs_clear_image, - NULL -}; - - -/* Free X resources of Ghostscript image IMG which is used on frame F. */ - -static void -gs_clear_image (f, img) - struct frame *f; - struct image *img; -{ - /* IMG->data.ptr_val may contain a recorded colormap. */ - xfree (img->data.ptr_val); - x_clear_image (f, img); -} - - -/* Return non-zero if OBJECT is a valid Ghostscript image - specification. */ - -static int -gs_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[GS_LAST]; - Lisp_Object tem; - int i; - - bcopy (gs_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, GS_LAST, Qpostscript)) - return 0; - - /* Bounding box must be a list or vector containing 4 integers. */ - tem = fmt[GS_BOUNDING_BOX].value; - if (CONSP (tem)) - { - for (i = 0; i < 4; ++i, tem = XCDR (tem)) - if (!CONSP (tem) || !INTEGERP (XCAR (tem))) - return 0; - if (!NILP (tem)) - return 0; - } - else if (VECTORP (tem)) - { - if (XVECTOR (tem)->size != 4) - return 0; - for (i = 0; i < 4; ++i) - if (!INTEGERP (XVECTOR (tem)->contents[i])) - return 0; - } - else - return 0; - - return 1; -} - - -/* Load Ghostscript image IMG for use on frame F. Value is non-zero - if successful. */ - -static int -gs_load (f, img) - struct frame *f; - struct image *img; -{ - char buffer[100]; - Lisp_Object window_and_pixmap_id = Qnil, loader, pt_height, pt_width; - struct gcpro gcpro1, gcpro2; - Lisp_Object frame; - double in_width, in_height; - Lisp_Object pixel_colors = Qnil; - - /* Compute pixel size of pixmap needed from the given size in the - image specification. Sizes in the specification are in pt. 1 pt - = 1/72 in, xdpi and ydpi are stored in the frame's X display - info. */ - pt_width = image_spec_value (img->spec, QCpt_width, NULL); - in_width = XFASTINT (pt_width) / 72.0; - img->width = in_width * FRAME_W32_DISPLAY_INFO (f)->resx; - pt_height = image_spec_value (img->spec, QCpt_height, NULL); - in_height = XFASTINT (pt_height) / 72.0; - img->height = in_height * FRAME_W32_DISPLAY_INFO (f)->resy; - - /* Create the pixmap. */ - BLOCK_INPUT; - xassert (img->pixmap == 0); - img->pixmap = XCreatePixmap (FRAME_W32_DISPLAY (f), FRAME_W32_WINDOW (f), - img->width, img->height, - one_w32_display_info.n_cbits); - UNBLOCK_INPUT; - - if (!img->pixmap) - { - image_error ("Unable to create pixmap for `%s'", img->spec, Qnil); - return 0; - } - - /* Call the loader to fill the pixmap. It returns a process object - if successful. We do not record_unwind_protect here because - other places in redisplay like calling window scroll functions - don't either. Let the Lisp loader use `unwind-protect' instead. */ - GCPRO2 (window_and_pixmap_id, pixel_colors); - - sprintf (buffer, "%lu %lu", - (unsigned long) FRAME_W32_WINDOW (f), - (unsigned long) img->pixmap); - window_and_pixmap_id = build_string (buffer); - - sprintf (buffer, "%lu %lu", - FRAME_FOREGROUND_PIXEL (f), - FRAME_BACKGROUND_PIXEL (f)); - pixel_colors = build_string (buffer); - - XSETFRAME (frame, f); - loader = image_spec_value (img->spec, QCloader, NULL); - if (NILP (loader)) - loader = intern ("gs-load-image"); - - img->data.lisp_val = call6 (loader, frame, img->spec, - make_number (img->width), - make_number (img->height), - window_and_pixmap_id, - pixel_colors); - UNGCPRO; - return PROCESSP (img->data.lisp_val); -} - - -/* Kill the Ghostscript process that was started to fill PIXMAP on - frame F. Called from XTread_socket when receiving an event - telling Emacs that Ghostscript has finished drawing. */ - -void -x_kill_gs_process (pixmap, f) - Pixmap pixmap; - struct frame *f; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - int class, i; - struct image *img; - - /* Find the image containing PIXMAP. */ - for (i = 0; i < c->used; ++i) - if (c->images[i]->pixmap == pixmap) - break; - - /* Should someone in between have cleared the image cache, for - instance, give up. */ - if (i == c->used) - return; - - /* Kill the GS process. We should have found PIXMAP in the image - cache and its image should contain a process object. */ - img = c->images[i]; - xassert (PROCESSP (img->data.lisp_val)); - Fkill_process (img->data.lisp_val, Qnil); - img->data.lisp_val = Qnil; - - /* On displays with a mutable colormap, figure out the colors - allocated for the image by looking at the pixels of an XImage for - img->pixmap. */ - class = FRAME_W32_DISPLAY_INFO (f)->visual->class; - if (class != StaticColor && class != StaticGray && class != TrueColor) - { - XImage *ximg; - - BLOCK_INPUT; - - /* Try to get an XImage for img->pixmep. */ - ximg = XGetImage (FRAME_W32_DISPLAY (f), img->pixmap, - 0, 0, img->width, img->height, ~0, ZPixmap); - if (ximg) - { - int x, y; - - /* Initialize the color table. */ - init_color_table (); - - /* For each pixel of the image, look its color up in the - color table. After having done so, the color table will - contain an entry for each color used by the image. */ - for (y = 0; y < img->height; ++y) - for (x = 0; x < img->width; ++x) - { - unsigned long pixel = XGetPixel (ximg, x, y); - lookup_pixel_color (f, pixel); - } - - /* Record colors in the image. Free color table and XImage. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); - XDestroyImage (ximg); - -#if 0 /* This doesn't seem to be the case. If we free the colors - here, we get a BadAccess later in x_clear_image when - freeing the colors. */ - /* We have allocated colors once, but Ghostscript has also - allocated colors on behalf of us. So, to get the - reference counts right, free them once. */ - if (img->ncolors) - x_free_colors (FRAME_W32_DISPLAY (f), cmap, - img->colors, img->ncolors, 0); -#endif - } - else - image_error ("Cannot get X image of `%s'; colors will not be freed", - img->spec, Qnil); - - UNBLOCK_INPUT; - } - - /* Now that we have the pixmap, compute mask and transform the - image if requested. */ - BLOCK_INPUT; - postprocess_image (f, img); - UNBLOCK_INPUT; -} - -#endif /* HAVE_GHOSTSCRIPT */ /*********************************************************************** @@ -14066,8 +8372,6 @@ staticpro (&Qsuppress_icon); Qundefined_color = intern ("undefined-color"); staticpro (&Qundefined_color); - Qcenter = intern ("center"); - staticpro (&Qcenter); Qcancel_timer = intern ("cancel-timer"); staticpro (&Qcancel_timer); @@ -14092,21 +8396,6 @@ = Fcons (Fcons (Qdisplay, Qt), Vtext_property_default_nonsticky); - Qlaplace = intern ("laplace"); - staticpro (&Qlaplace); - Qemboss = intern ("emboss"); - staticpro (&Qemboss); - Qedge_detection = intern ("edge-detection"); - staticpro (&Qedge_detection); - Qheuristic = intern ("heuristic"); - staticpro (&Qheuristic); - QCmatrix = intern (":matrix"); - staticpro (&QCmatrix); - QCcolor_adjustment = intern (":color-adjustment"); - staticpro (&QCcolor_adjustment); - QCmask = intern (":mask"); - staticpro (&QCmask); - Fput (Qundefined_color, Qerror_conditions, Fcons (Qundefined_color, Fcons (Qerror, Qnil))); Fput (Qundefined_color, Qerror_message, @@ -14237,10 +8526,6 @@ system to handle them. */); w32_pass_extra_mouse_buttons_to_system = 0; - DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path, - doc: /* List of directories to search for window system bitmap files. */); - Vx_bitmap_file_path = decode_env_path ((char *) 0, "PATH"); - DEFVAR_LISP ("x-pointer-shape", &Vx_pointer_shape, doc: /* The shape of the pointer when over text. Changing the value does not affect existing frames @@ -14307,13 +8592,6 @@ Chinese, Japanese, and Korean. */); Vx_pixel_size_width_font_regexp = Qnil; - DEFVAR_LISP ("image-cache-eviction-delay", &Vimage_cache_eviction_delay, - doc: /* Time after which cached images are removed from the cache. -When an image has not been displayed this many seconds, remove it -from the image cache. Value must be an integer or nil with nil -meaning don't clear the cache. */); - Vimage_cache_eviction_delay = make_number (30 * 60); - DEFVAR_LISP ("w32-bdf-filename-alist", &Vw32_bdf_filename_alist, doc: /* List of bdf fonts and their corresponding filenames. */); @@ -14478,64 +8756,6 @@ set_frame_fontset_func = x_set_font; check_window_system_func = check_w32; - /* Images. */ - Qxbm = intern ("xbm"); - staticpro (&Qxbm); - QCconversion = intern (":conversion"); - staticpro (&QCconversion); - QCheuristic_mask = intern (":heuristic-mask"); - staticpro (&QCheuristic_mask); - QCcolor_symbols = intern (":color-symbols"); - staticpro (&QCcolor_symbols); - QCascent = intern (":ascent"); - staticpro (&QCascent); - QCmargin = intern (":margin"); - staticpro (&QCmargin); - QCrelief = intern (":relief"); - staticpro (&QCrelief); - Qpostscript = intern ("postscript"); - staticpro (&Qpostscript); - QCloader = intern (":loader"); - staticpro (&QCloader); - QCbounding_box = intern (":bounding-box"); - staticpro (&QCbounding_box); - QCpt_width = intern (":pt-width"); - staticpro (&QCpt_width); - QCpt_height = intern (":pt-height"); - staticpro (&QCpt_height); - QCindex = intern (":index"); - staticpro (&QCindex); - Qpbm = intern ("pbm"); - staticpro (&Qpbm); - -#if HAVE_XPM - Qxpm = intern ("xpm"); - staticpro (&Qxpm); -#endif - -#if HAVE_JPEG - Qjpeg = intern ("jpeg"); - staticpro (&Qjpeg); -#endif - -#if HAVE_TIFF - Qtiff = intern ("tiff"); - staticpro (&Qtiff); -#endif - -#if HAVE_GIF - Qgif = intern ("gif"); - staticpro (&Qgif); -#endif - -#if HAVE_PNG - Qpng = intern ("png"); - staticpro (&Qpng); -#endif - - defsubr (&Sclear_image_cache); - defsubr (&Simage_size); - defsubr (&Simage_mask_p); hourglass_atimer = NULL; hourglass_shown_p = 0; @@ -14575,84 +8795,6 @@ GetProcAddress (user32_lib, "GetClipboardSequenceNumber"); } -/* Initialize image types. Based on which libraries are available. */ -static void -init_external_image_libraries () -{ - HINSTANCE library; - -#if HAVE_XPM - if ((library = LoadLibrary ("libXpm.dll"))) - { - if (init_xpm_functions (library)) - define_image_type (&xpm_type); - } - -#endif - -#if HAVE_JPEG - /* Try loading jpeg library under probable names. */ - if ((library = LoadLibrary ("libjpeg.dll")) - || (library = LoadLibrary ("jpeg-62.dll")) - || (library = LoadLibrary ("jpeg.dll"))) - { - if (init_jpeg_functions (library)) - define_image_type (&jpeg_type); - } -#endif - -#if HAVE_TIFF - if (library = LoadLibrary ("libtiff.dll")) - { - if (init_tiff_functions (library)) - define_image_type (&tiff_type); - } -#endif - -#if HAVE_GIF - if (library = LoadLibrary ("libungif.dll")) - { - if (init_gif_functions (library)) - define_image_type (&gif_type); - } -#endif - -#if HAVE_PNG - /* Ensure zlib is loaded. Try debug version first. */ - if (!LoadLibrary ("zlibd.dll")) - LoadLibrary ("zlib.dll"); - - /* Try loading libpng under probable names. */ - if ((library = LoadLibrary ("libpng13d.dll")) - || (library = LoadLibrary ("libpng13.dll")) - || (library = LoadLibrary ("libpng12d.dll")) - || (library = LoadLibrary ("libpng12.dll")) - || (library = LoadLibrary ("libpng.dll"))) - { - if (init_png_functions (library)) - define_image_type (&png_type); - } -#endif -} - -void -init_xfns () -{ - image_types = NULL; - Vimage_types = Qnil; - - define_image_type (&pbm_type); - define_image_type (&xbm_type); - -#if 0 /* TODO : Ghostscript support for W32 */ - define_image_type (&gs_type); -#endif - - /* Image types that rely on external libraries are loaded dynamically - if the library is available. */ - init_external_image_libraries (); -} - #undef abort void
--- a/src/xfns.c Thu Mar 11 02:31:12 2004 +0000 +++ b/src/xfns.c Tue Mar 16 20:27:22 2004 +0000 @@ -179,10 +179,6 @@ Lisp_Object Vx_no_window_manager; -/* Search path for bitmap files. */ - -Lisp_Object Vx_bitmap_file_path; - /* Regexp matching a font name whose width is the same as `PIXEL_SIZE'. */ Lisp_Object Vx_pixel_size_width_font_regexp; @@ -190,7 +186,6 @@ Lisp_Object Qnone; Lisp_Object Qsuppress_icon; Lisp_Object Qundefined_color; -Lisp_Object Qcenter; Lisp_Object Qcompound_text, Qcancel_timer; /* In dispnew.c */ @@ -521,331 +516,8 @@ -/* Code to deal with bitmaps. Bitmaps are referenced by their bitmap - id, which is just an int that this section returns. Bitmaps are - reference counted so they can be shared among frames. - - Bitmap indices are guaranteed to be > 0, so a negative number can - be used to indicate no bitmap. - - If you use x_create_bitmap_from_data, then you must keep track of - the bitmaps yourself. That is, creating a bitmap from the same - data more than once will not be caught. */ - - -/* Functions to access the contents of a bitmap, given an id. */ - -int -x_bitmap_height (f, id) - FRAME_PTR f; - int id; -{ - return FRAME_X_DISPLAY_INFO (f)->bitmaps[id - 1].height; -} - -int -x_bitmap_width (f, id) - FRAME_PTR f; - int id; -{ - return FRAME_X_DISPLAY_INFO (f)->bitmaps[id - 1].width; -} - -int -x_bitmap_pixmap (f, id) - FRAME_PTR f; - int id; -{ - return FRAME_X_DISPLAY_INFO (f)->bitmaps[id - 1].pixmap; -} - -int -x_bitmap_mask (f, id) - FRAME_PTR f; - int id; -{ - return FRAME_X_DISPLAY_INFO (f)->bitmaps[id - 1].mask; -} - - -/* Allocate a new bitmap record. Returns index of new record. */ - -static int -x_allocate_bitmap_record (f) - FRAME_PTR f; -{ - struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f); - int i; - - if (dpyinfo->bitmaps == NULL) - { - dpyinfo->bitmaps_size = 10; - dpyinfo->bitmaps - = (struct x_bitmap_record *) xmalloc (dpyinfo->bitmaps_size * sizeof (struct x_bitmap_record)); - dpyinfo->bitmaps_last = 1; - return 1; - } - - if (dpyinfo->bitmaps_last < dpyinfo->bitmaps_size) - return ++dpyinfo->bitmaps_last; - - for (i = 0; i < dpyinfo->bitmaps_size; ++i) - if (dpyinfo->bitmaps[i].refcount == 0) - return i + 1; - - dpyinfo->bitmaps_size *= 2; - dpyinfo->bitmaps - = (struct x_bitmap_record *) xrealloc (dpyinfo->bitmaps, - dpyinfo->bitmaps_size * sizeof (struct x_bitmap_record)); - return ++dpyinfo->bitmaps_last; -} - -/* Add one reference to the reference count of the bitmap with id ID. */ - -void -x_reference_bitmap (f, id) - FRAME_PTR f; - int id; -{ - ++FRAME_X_DISPLAY_INFO (f)->bitmaps[id - 1].refcount; -} - -/* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at BITS. */ - -int -x_create_bitmap_from_data (f, bits, width, height) - struct frame *f; - char *bits; - unsigned int width, height; -{ - struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f); - Pixmap bitmap; - int id; - - bitmap = XCreateBitmapFromData (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - bits, width, height); - - - - if (! bitmap) - return -1; - - id = x_allocate_bitmap_record (f); - dpyinfo->bitmaps[id - 1].pixmap = bitmap; - dpyinfo->bitmaps[id - 1].have_mask = 0; - dpyinfo->bitmaps[id - 1].file = NULL; - dpyinfo->bitmaps[id - 1].refcount = 1; - dpyinfo->bitmaps[id - 1].depth = 1; - dpyinfo->bitmaps[id - 1].height = height; - dpyinfo->bitmaps[id - 1].width = width; - - return id; -} - -/* Create bitmap from file FILE for frame F. */ - -int -x_create_bitmap_from_file (f, file) - struct frame *f; - Lisp_Object file; -{ - struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f); - unsigned int width, height; - Pixmap bitmap; - int xhot, yhot, result, id; - Lisp_Object found; - int fd; - char *filename; - - /* Look for an existing bitmap with the same name. */ - for (id = 0; id < dpyinfo->bitmaps_last; ++id) - { - if (dpyinfo->bitmaps[id].refcount - && dpyinfo->bitmaps[id].file - && !strcmp (dpyinfo->bitmaps[id].file, (char *) SDATA (file))) - { - ++dpyinfo->bitmaps[id].refcount; - return id + 1; - } - } - - /* Search bitmap-file-path for the file, if appropriate. */ - fd = openp (Vx_bitmap_file_path, file, Qnil, &found, Qnil); - if (fd < 0) - return -1; - emacs_close (fd); - - filename = (char *) SDATA (found); - - result = XReadBitmapFile (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - filename, &width, &height, &bitmap, &xhot, &yhot); - if (result != BitmapSuccess) - return -1; - - id = x_allocate_bitmap_record (f); - dpyinfo->bitmaps[id - 1].pixmap = bitmap; - dpyinfo->bitmaps[id - 1].have_mask = 0; - dpyinfo->bitmaps[id - 1].refcount = 1; - dpyinfo->bitmaps[id - 1].file - = (char *) xmalloc (SBYTES (file) + 1); - dpyinfo->bitmaps[id - 1].depth = 1; - dpyinfo->bitmaps[id - 1].height = height; - dpyinfo->bitmaps[id - 1].width = width; - strcpy (dpyinfo->bitmaps[id - 1].file, SDATA (file)); - - return id; -} - -/* Remove reference to bitmap with id number ID. */ - -void -x_destroy_bitmap (f, id) - FRAME_PTR f; - int id; -{ - struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f); - - if (id > 0) - { - --dpyinfo->bitmaps[id - 1].refcount; - if (dpyinfo->bitmaps[id - 1].refcount == 0) - { - BLOCK_INPUT; - XFreePixmap (FRAME_X_DISPLAY (f), dpyinfo->bitmaps[id - 1].pixmap); - if (dpyinfo->bitmaps[id - 1].have_mask) - XFreePixmap (FRAME_X_DISPLAY (f), dpyinfo->bitmaps[id - 1].mask); - if (dpyinfo->bitmaps[id - 1].file) - { - xfree (dpyinfo->bitmaps[id - 1].file); - dpyinfo->bitmaps[id - 1].file = NULL; - } - UNBLOCK_INPUT; - } - } -} - -/* Free all the bitmaps for the display specified by DPYINFO. */ - -static void -x_destroy_all_bitmaps (dpyinfo) - struct x_display_info *dpyinfo; -{ - int i; - for (i = 0; i < dpyinfo->bitmaps_last; i++) - if (dpyinfo->bitmaps[i].refcount > 0) - { - XFreePixmap (dpyinfo->display, dpyinfo->bitmaps[i].pixmap); - if (dpyinfo->bitmaps[i].have_mask) - XFreePixmap (dpyinfo->display, dpyinfo->bitmaps[i].mask); - if (dpyinfo->bitmaps[i].file) - xfree (dpyinfo->bitmaps[i].file); - } - dpyinfo->bitmaps_last = 0; -} - - - - -/* Useful functions defined in the section - `Image type independent image structures' below. */ - -static unsigned long four_corners_best P_ ((XImage *ximg, unsigned long width, - unsigned long height)); - -static int x_create_x_image_and_pixmap P_ ((struct frame *f, int width, int height, - int depth, XImage **ximg, - Pixmap *pixmap)); - -static void x_destroy_x_image P_ ((XImage *ximg)); - - -/* Create a mask of a bitmap. Note is this not a perfect mask. - It's nicer with some borders in this context */ - -int -x_create_bitmap_mask (f, id) - struct frame *f; - int id; -{ - Pixmap pixmap, mask; - XImage *ximg, *mask_img; - unsigned long width, height; - int result; - unsigned long bg; - unsigned long x, y, xp, xm, yp, ym; - GC gc; - - struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f); - - if (!(id > 0)) - return -1; - - pixmap = x_bitmap_pixmap (f, id); - width = x_bitmap_width (f, id); - height = x_bitmap_height (f, id); - - BLOCK_INPUT; - ximg = XGetImage (FRAME_X_DISPLAY (f), pixmap, 0, 0, width, height, - ~0, ZPixmap); - - if (!ximg) - { - UNBLOCK_INPUT; - return -1; - } - - result = x_create_x_image_and_pixmap (f, width, height, 1, &mask_img, &mask); - - UNBLOCK_INPUT; - if (!result) - { - XDestroyImage (ximg); - return -1; - } - - bg = four_corners_best (ximg, width, height); - - for (y = 0; y < ximg->height; ++y) - { - for (x = 0; x < ximg->width; ++x) - { - xp = x != ximg->width - 1 ? x + 1 : 0; - xm = x != 0 ? x - 1 : ximg->width - 1; - yp = y != ximg->height - 1 ? y + 1 : 0; - ym = y != 0 ? y - 1 : ximg->height - 1; - if (XGetPixel (ximg, x, y) == bg - && XGetPixel (ximg, x, yp) == bg - && XGetPixel (ximg, x, ym) == bg - && XGetPixel (ximg, xp, y) == bg - && XGetPixel (ximg, xp, yp) == bg - && XGetPixel (ximg, xp, ym) == bg - && XGetPixel (ximg, xm, y) == bg - && XGetPixel (ximg, xm, yp) == bg - && XGetPixel (ximg, xm, ym) == bg) - XPutPixel (mask_img, x, y, 0); - else - XPutPixel (mask_img, x, y, 1); - } - } - - xassert (interrupt_input_blocked); - gc = XCreateGC (FRAME_X_DISPLAY (f), mask, 0, NULL); - XPutImage (FRAME_X_DISPLAY (f), mask, gc, mask_img, 0, 0, 0, 0, - width, height); - XFreeGC (FRAME_X_DISPLAY (f), gc); - - dpyinfo->bitmaps[id - 1].have_mask = 1; - dpyinfo->bitmaps[id - 1].mask = mask; - - XDestroyImage (ximg); - x_destroy_x_image (mask_img); - - return 0; -} - static Lisp_Object unwind_create_frame P_ ((Lisp_Object)); static Lisp_Object unwind_create_tip_frame P_ ((Lisp_Object)); -static void x_disable_image P_ ((struct frame *, struct image *)); void x_set_foreground_color P_ ((struct frame *, Lisp_Object, Lisp_Object)); static void x_set_wait_for_wm P_ ((struct frame *, Lisp_Object, Lisp_Object)); @@ -869,16 +541,6 @@ Lisp_Object, char *, char *, int)); -static void x_edge_detection P_ ((struct frame *, struct image *, Lisp_Object, - Lisp_Object)); -static void init_color_table P_ ((void)); -static void free_color_table P_ ((void)); -static unsigned long *colors_in_color_table P_ ((int *n)); -static unsigned long lookup_rgb_color P_ ((struct frame *f, int r, int g, int b)); -static unsigned long lookup_pixel_color P_ ((struct frame *f, unsigned long p)); - - - /* Store the screen positions of frame F into XPTR and YPTR. @@ -1100,8 +762,6 @@ #ifdef USE_GTK -static Lisp_Object x_find_image_file P_ ((Lisp_Object file)); - /* Set icon from FILE for frame F. By using GTK functions the icon may be any format that GdkPixbuf knows about, i.e. not just bitmaps. */ @@ -4300,5191 +3960,6 @@ /*********************************************************************** - Image types - ***********************************************************************/ - -/* Value is the number of elements of vector VECTOR. */ - -#define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR)) - -/* List of supported image types. Use define_image_type to add new - types. Use lookup_image_type to find a type for a given symbol. */ - -static struct image_type *image_types; - -/* The symbol `xbm' which is used as the type symbol for XBM images. */ - -Lisp_Object Qxbm; - -/* Keywords. */ - -extern Lisp_Object QCwidth, QCheight, QCforeground, QCbackground, QCfile; -extern Lisp_Object QCdata, QCtype; -Lisp_Object QCascent, QCmargin, QCrelief; -Lisp_Object QCconversion, QCcolor_symbols, QCheuristic_mask; -Lisp_Object QCindex, QCmatrix, QCcolor_adjustment, QCmask; - -/* Other symbols. */ - -Lisp_Object Qlaplace, Qemboss, Qedge_detection, Qheuristic; - -/* Time in seconds after which images should be removed from the cache - if not displayed. */ - -Lisp_Object Vimage_cache_eviction_delay; - -/* Function prototypes. */ - -static void define_image_type P_ ((struct image_type *type)); -static struct image_type *lookup_image_type P_ ((Lisp_Object symbol)); -static void image_error P_ ((char *format, Lisp_Object, Lisp_Object)); -static void x_laplace P_ ((struct frame *, struct image *)); -static void x_emboss P_ ((struct frame *, struct image *)); -static int x_build_heuristic_mask P_ ((struct frame *, struct image *, - Lisp_Object)); - - -/* Define a new image type from TYPE. This adds a copy of TYPE to - image_types and adds the symbol *TYPE->type to Vimage_types. */ - -static void -define_image_type (type) - struct image_type *type; -{ - /* Make a copy of TYPE to avoid a bus error in a dumped Emacs. - The initialized data segment is read-only. */ - struct image_type *p = (struct image_type *) xmalloc (sizeof *p); - bcopy (type, p, sizeof *p); - p->next = image_types; - image_types = p; - Vimage_types = Fcons (*p->type, Vimage_types); -} - - -/* Look up image type SYMBOL, and return a pointer to its image_type - structure. Value is null if SYMBOL is not a known image type. */ - -static INLINE struct image_type * -lookup_image_type (symbol) - Lisp_Object symbol; -{ - struct image_type *type; - - for (type = image_types; type; type = type->next) - if (EQ (symbol, *type->type)) - break; - - return type; -} - - -/* Value is non-zero if OBJECT is a valid Lisp image specification. A - valid image specification is a list whose car is the symbol - `image', and whose rest is a property list. The property list must - contain a value for key `:type'. That value must be the name of a - supported image type. The rest of the property list depends on the - image type. */ - -int -valid_image_p (object) - Lisp_Object object; -{ - int valid_p = 0; - - if (IMAGEP (object)) - { - Lisp_Object tem; - - for (tem = XCDR (object); CONSP (tem); tem = XCDR (tem)) - if (EQ (XCAR (tem), QCtype)) - { - tem = XCDR (tem); - if (CONSP (tem) && SYMBOLP (XCAR (tem))) - { - struct image_type *type; - type = lookup_image_type (XCAR (tem)); - if (type) - valid_p = type->valid_p (object); - } - - break; - } - } - - return valid_p; -} - - -/* Log error message with format string FORMAT and argument ARG. - Signaling an error, e.g. when an image cannot be loaded, is not a - good idea because this would interrupt redisplay, and the error - message display would lead to another redisplay. This function - therefore simply displays a message. */ - -static void -image_error (format, arg1, arg2) - char *format; - Lisp_Object arg1, arg2; -{ - add_to_log (format, arg1, arg2); -} - - - -/*********************************************************************** - Image specifications - ***********************************************************************/ - -enum image_value_type -{ - IMAGE_DONT_CHECK_VALUE_TYPE, - IMAGE_STRING_VALUE, - IMAGE_STRING_OR_NIL_VALUE, - IMAGE_SYMBOL_VALUE, - IMAGE_POSITIVE_INTEGER_VALUE, - IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, - IMAGE_NON_NEGATIVE_INTEGER_VALUE, - IMAGE_ASCENT_VALUE, - IMAGE_INTEGER_VALUE, - IMAGE_FUNCTION_VALUE, - IMAGE_NUMBER_VALUE, - IMAGE_BOOL_VALUE -}; - -/* Structure used when parsing image specifications. */ - -struct image_keyword -{ - /* Name of keyword. */ - char *name; - - /* The type of value allowed. */ - enum image_value_type type; - - /* Non-zero means key must be present. */ - int mandatory_p; - - /* Used to recognize duplicate keywords in a property list. */ - int count; - - /* The value that was found. */ - Lisp_Object value; -}; - - -static int parse_image_spec P_ ((Lisp_Object, struct image_keyword *, - int, Lisp_Object)); -static Lisp_Object image_spec_value P_ ((Lisp_Object, Lisp_Object, int *)); - - -/* Parse image spec SPEC according to KEYWORDS. A valid image spec - has the format (image KEYWORD VALUE ...). One of the keyword/ - value pairs must be `:type TYPE'. KEYWORDS is a vector of - image_keywords structures of size NKEYWORDS describing other - allowed keyword/value pairs. Value is non-zero if SPEC is valid. */ - -static int -parse_image_spec (spec, keywords, nkeywords, type) - Lisp_Object spec; - struct image_keyword *keywords; - int nkeywords; - Lisp_Object type; -{ - int i; - Lisp_Object plist; - - if (!IMAGEP (spec)) - return 0; - - plist = XCDR (spec); - while (CONSP (plist)) - { - Lisp_Object key, value; - - /* First element of a pair must be a symbol. */ - key = XCAR (plist); - plist = XCDR (plist); - if (!SYMBOLP (key)) - return 0; - - /* There must follow a value. */ - if (!CONSP (plist)) - return 0; - value = XCAR (plist); - plist = XCDR (plist); - - /* Find key in KEYWORDS. Error if not found. */ - for (i = 0; i < nkeywords; ++i) - if (strcmp (keywords[i].name, SDATA (SYMBOL_NAME (key))) == 0) - break; - - if (i == nkeywords) - continue; - - /* Record that we recognized the keyword. If a keywords - was found more than once, it's an error. */ - keywords[i].value = value; - ++keywords[i].count; - - if (keywords[i].count > 1) - return 0; - - /* Check type of value against allowed type. */ - switch (keywords[i].type) - { - case IMAGE_STRING_VALUE: - if (!STRINGP (value)) - return 0; - break; - - case IMAGE_STRING_OR_NIL_VALUE: - if (!STRINGP (value) && !NILP (value)) - return 0; - break; - - case IMAGE_SYMBOL_VALUE: - if (!SYMBOLP (value)) - return 0; - break; - - case IMAGE_POSITIVE_INTEGER_VALUE: - if (!INTEGERP (value) || XINT (value) <= 0) - return 0; - break; - - case IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR: - if (INTEGERP (value) && XINT (value) >= 0) - break; - if (CONSP (value) - && INTEGERP (XCAR (value)) && INTEGERP (XCDR (value)) - && XINT (XCAR (value)) >= 0 && XINT (XCDR (value)) >= 0) - break; - return 0; - - case IMAGE_ASCENT_VALUE: - if (SYMBOLP (value) && EQ (value, Qcenter)) - break; - else if (INTEGERP (value) - && XINT (value) >= 0 - && XINT (value) <= 100) - break; - return 0; - - case IMAGE_NON_NEGATIVE_INTEGER_VALUE: - if (!INTEGERP (value) || XINT (value) < 0) - return 0; - break; - - case IMAGE_DONT_CHECK_VALUE_TYPE: - break; - - case IMAGE_FUNCTION_VALUE: - value = indirect_function (value); - if (SUBRP (value) - || COMPILEDP (value) - || (CONSP (value) && EQ (XCAR (value), Qlambda))) - break; - return 0; - - case IMAGE_NUMBER_VALUE: - if (!INTEGERP (value) && !FLOATP (value)) - return 0; - break; - - case IMAGE_INTEGER_VALUE: - if (!INTEGERP (value)) - return 0; - break; - - case IMAGE_BOOL_VALUE: - if (!NILP (value) && !EQ (value, Qt)) - return 0; - break; - - default: - abort (); - break; - } - - if (EQ (key, QCtype) && !EQ (type, value)) - return 0; - } - - /* Check that all mandatory fields are present. */ - for (i = 0; i < nkeywords; ++i) - if (keywords[i].mandatory_p && keywords[i].count == 0) - return 0; - - return NILP (plist); -} - - -/* Return the value of KEY in image specification SPEC. Value is nil - if KEY is not present in SPEC. if FOUND is not null, set *FOUND - to 1 if KEY was found in SPEC, set it to 0 otherwise. */ - -static Lisp_Object -image_spec_value (spec, key, found) - Lisp_Object spec, key; - int *found; -{ - Lisp_Object tail; - - xassert (valid_image_p (spec)); - - for (tail = XCDR (spec); - CONSP (tail) && CONSP (XCDR (tail)); - tail = XCDR (XCDR (tail))) - { - if (EQ (XCAR (tail), key)) - { - if (found) - *found = 1; - return XCAR (XCDR (tail)); - } - } - - if (found) - *found = 0; - return Qnil; -} - - -DEFUN ("image-size", Fimage_size, Simage_size, 1, 3, 0, - doc: /* Return the size of image SPEC as pair (WIDTH . HEIGHT). -PIXELS non-nil means return the size in pixels, otherwise return the -size in canonical character units. -FRAME is the frame on which the image will be displayed. FRAME nil -or omitted means use the selected frame. */) - (spec, pixels, frame) - Lisp_Object spec, pixels, frame; -{ - Lisp_Object size; - - size = Qnil; - if (valid_image_p (spec)) - { - struct frame *f = check_x_frame (frame); - int id = lookup_image (f, spec); - struct image *img = IMAGE_FROM_ID (f, id); - int width = img->width + 2 * img->hmargin; - int height = img->height + 2 * img->vmargin; - - if (NILP (pixels)) - size = Fcons (make_float ((double) width / FRAME_COLUMN_WIDTH (f)), - make_float ((double) height / FRAME_LINE_HEIGHT (f))); - else - size = Fcons (make_number (width), make_number (height)); - } - else - error ("Invalid image specification"); - - return size; -} - - -DEFUN ("image-mask-p", Fimage_mask_p, Simage_mask_p, 1, 2, 0, - doc: /* Return t if image SPEC has a mask bitmap. -FRAME is the frame on which the image will be displayed. FRAME nil -or omitted means use the selected frame. */) - (spec, frame) - Lisp_Object spec, frame; -{ - Lisp_Object mask; - - mask = Qnil; - if (valid_image_p (spec)) - { - struct frame *f = check_x_frame (frame); - int id = lookup_image (f, spec); - struct image *img = IMAGE_FROM_ID (f, id); - if (img->mask) - mask = Qt; - } - else - error ("Invalid image specification"); - - return mask; -} - - - -/*********************************************************************** - Image type independent image structures - ***********************************************************************/ - -static struct image *make_image P_ ((Lisp_Object spec, unsigned hash)); -static void free_image P_ ((struct frame *f, struct image *img)); - - -/* Allocate and return a new image structure for image specification - SPEC. SPEC has a hash value of HASH. */ - -static struct image * -make_image (spec, hash) - Lisp_Object spec; - unsigned hash; -{ - struct image *img = (struct image *) xmalloc (sizeof *img); - - xassert (valid_image_p (spec)); - bzero (img, sizeof *img); - img->type = lookup_image_type (image_spec_value (spec, QCtype, NULL)); - xassert (img->type != NULL); - img->spec = spec; - img->data.lisp_val = Qnil; - img->ascent = DEFAULT_IMAGE_ASCENT; - img->hash = hash; - return img; -} - - -/* Free image IMG which was used on frame F, including its resources. */ - -static void -free_image (f, img) - struct frame *f; - struct image *img; -{ - if (img) - { - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - - /* Remove IMG from the hash table of its cache. */ - if (img->prev) - img->prev->next = img->next; - else - c->buckets[img->hash % IMAGE_CACHE_BUCKETS_SIZE] = img->next; - - if (img->next) - img->next->prev = img->prev; - - c->images[img->id] = NULL; - - /* Free resources, then free IMG. */ - img->type->free (f, img); - xfree (img); - } -} - - -/* Prepare image IMG for display on frame F. Must be called before - drawing an image. */ - -void -prepare_image_for_display (f, img) - struct frame *f; - struct image *img; -{ - EMACS_TIME t; - - /* We're about to display IMG, so set its timestamp to `now'. */ - EMACS_GET_TIME (t); - img->timestamp = EMACS_SECS (t); - - /* If IMG doesn't have a pixmap yet, load it now, using the image - type dependent loader function. */ - if (img->pixmap == None && !img->load_failed_p) - img->load_failed_p = img->type->load (f, img) == 0; -} - - -/* Value is the number of pixels for the ascent of image IMG when - drawn in face FACE. */ - -int -image_ascent (img, face) - struct image *img; - struct face *face; -{ - int height = img->height + img->vmargin; - int ascent; - - if (img->ascent == CENTERED_IMAGE_ASCENT) - { - if (face->font) - /* This expression is arranged so that if the image can't be - exactly centered, it will be moved slightly up. This is - because a typical font is `top-heavy' (due to the presence - uppercase letters), so the image placement should err towards - being top-heavy too. It also just generally looks better. */ - ascent = (height + face->font->ascent - face->font->descent + 1) / 2; - else - ascent = height / 2; - } - else - ascent = height * img->ascent / 100.0; - - return ascent; -} - - -/* Image background colors. */ - -static unsigned long -four_corners_best (ximg, width, height) - XImage *ximg; - unsigned long width, height; -{ - unsigned long corners[4], best; - int i, best_count; - - /* Get the colors at the corners of ximg. */ - corners[0] = XGetPixel (ximg, 0, 0); - corners[1] = XGetPixel (ximg, width - 1, 0); - corners[2] = XGetPixel (ximg, width - 1, height - 1); - corners[3] = XGetPixel (ximg, 0, height - 1); - - /* Choose the most frequently found color as background. */ - for (i = best_count = 0; i < 4; ++i) - { - int j, n; - - for (j = n = 0; j < 4; ++j) - if (corners[i] == corners[j]) - ++n; - - if (n > best_count) - best = corners[i], best_count = n; - } - - return best; -} - -/* Return the `background' field of IMG. If IMG doesn't have one yet, - it is guessed heuristically. If non-zero, XIMG is an existing XImage - object to use for the heuristic. */ - -unsigned long -image_background (img, f, ximg) - struct image *img; - struct frame *f; - XImage *ximg; -{ - if (! img->background_valid) - /* IMG doesn't have a background yet, try to guess a reasonable value. */ - { - int free_ximg = !ximg; - - if (! ximg) - ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap, - 0, 0, img->width, img->height, ~0, ZPixmap); - - img->background = four_corners_best (ximg, img->width, img->height); - - if (free_ximg) - XDestroyImage (ximg); - - img->background_valid = 1; - } - - return img->background; -} - -/* Return the `background_transparent' field of IMG. If IMG doesn't - have one yet, it is guessed heuristically. If non-zero, MASK is an - existing XImage object to use for the heuristic. */ - -int -image_background_transparent (img, f, mask) - struct image *img; - struct frame *f; - XImage *mask; -{ - if (! img->background_transparent_valid) - /* IMG doesn't have a background yet, try to guess a reasonable value. */ - { - if (img->mask) - { - int free_mask = !mask; - - if (! mask) - mask = XGetImage (FRAME_X_DISPLAY (f), img->mask, - 0, 0, img->width, img->height, ~0, ZPixmap); - - img->background_transparent - = !four_corners_best (mask, img->width, img->height); - - if (free_mask) - XDestroyImage (mask); - } - else - img->background_transparent = 0; - - img->background_transparent_valid = 1; - } - - return img->background_transparent; -} - - -/*********************************************************************** - Helper functions for X image types - ***********************************************************************/ - -static void x_clear_image_1 P_ ((struct frame *, struct image *, int, - int, int)); -static void x_clear_image P_ ((struct frame *f, struct image *img)); -static unsigned long x_alloc_image_color P_ ((struct frame *f, - struct image *img, - Lisp_Object color_name, - unsigned long dflt)); - - -/* Clear X resources of image IMG on frame F. PIXMAP_P non-zero means - free the pixmap if any. MASK_P non-zero means clear the mask - pixmap if any. COLORS_P non-zero means free colors allocated for - the image, if any. */ - -static void -x_clear_image_1 (f, img, pixmap_p, mask_p, colors_p) - struct frame *f; - struct image *img; - int pixmap_p, mask_p, colors_p; -{ - if (pixmap_p && img->pixmap) - { - XFreePixmap (FRAME_X_DISPLAY (f), img->pixmap); - img->pixmap = None; - img->background_valid = 0; - } - - if (mask_p && img->mask) - { - XFreePixmap (FRAME_X_DISPLAY (f), img->mask); - img->mask = None; - img->background_transparent_valid = 0; - } - - if (colors_p && img->ncolors) - { - x_free_colors (f, img->colors, img->ncolors); - xfree (img->colors); - img->colors = NULL; - img->ncolors = 0; - } -} - -/* Free X resources of image IMG which is used on frame F. */ - -static void -x_clear_image (f, img) - struct frame *f; - struct image *img; -{ - BLOCK_INPUT; - x_clear_image_1 (f, img, 1, 1, 1); - UNBLOCK_INPUT; -} - - -/* Allocate color COLOR_NAME for image IMG on frame F. If color - cannot be allocated, use DFLT. Add a newly allocated color to - IMG->colors, so that it can be freed again. Value is the pixel - color. */ - -static unsigned long -x_alloc_image_color (f, img, color_name, dflt) - struct frame *f; - struct image *img; - Lisp_Object color_name; - unsigned long dflt; -{ - XColor color; - unsigned long result; - - xassert (STRINGP (color_name)); - - if (x_defined_color (f, SDATA (color_name), &color, 1)) - { - /* This isn't called frequently so we get away with simply - reallocating the color vector to the needed size, here. */ - ++img->ncolors; - img->colors = - (unsigned long *) xrealloc (img->colors, - img->ncolors * sizeof *img->colors); - img->colors[img->ncolors - 1] = color.pixel; - result = color.pixel; - } - else - result = dflt; - - return result; -} - - - -/*********************************************************************** - Image Cache - ***********************************************************************/ - -static void cache_image P_ ((struct frame *f, struct image *img)); -static void postprocess_image P_ ((struct frame *, struct image *)); - - -/* Return a new, initialized image cache that is allocated from the - heap. Call free_image_cache to free an image cache. */ - -struct image_cache * -make_image_cache () -{ - struct image_cache *c = (struct image_cache *) xmalloc (sizeof *c); - int size; - - bzero (c, sizeof *c); - c->size = 50; - c->images = (struct image **) xmalloc (c->size * sizeof *c->images); - size = IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets; - c->buckets = (struct image **) xmalloc (size); - bzero (c->buckets, size); - return c; -} - - -/* Free image cache of frame F. Be aware that X frames share images - caches. */ - -void -free_image_cache (f) - struct frame *f; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - if (c) - { - int i; - - /* Cache should not be referenced by any frame when freed. */ - xassert (c->refcount == 0); - - for (i = 0; i < c->used; ++i) - free_image (f, c->images[i]); - xfree (c->images); - xfree (c->buckets); - xfree (c); - FRAME_X_IMAGE_CACHE (f) = NULL; - } -} - - -/* Clear image cache of frame F. FORCE_P non-zero means free all - images. FORCE_P zero means clear only images that haven't been - displayed for some time. Should be called from time to time to - reduce the number of loaded images. If image-eviction-seconds is - non-nil, this frees images in the cache which weren't displayed for - at least that many seconds. */ - -void -clear_image_cache (f, force_p) - struct frame *f; - int force_p; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - - if (c && INTEGERP (Vimage_cache_eviction_delay)) - { - EMACS_TIME t; - unsigned long old; - int i, nfreed; - - EMACS_GET_TIME (t); - old = EMACS_SECS (t) - XFASTINT (Vimage_cache_eviction_delay); - - /* Block input so that we won't be interrupted by a SIGIO - while being in an inconsistent state. */ - BLOCK_INPUT; - - for (i = nfreed = 0; i < c->used; ++i) - { - struct image *img = c->images[i]; - if (img != NULL - && (force_p || img->timestamp < old)) - { - free_image (f, img); - ++nfreed; - } - } - - /* We may be clearing the image cache because, for example, - Emacs was iconified for a longer period of time. In that - case, current matrices may still contain references to - images freed above. So, clear these matrices. */ - if (nfreed) - { - Lisp_Object tail, frame; - - FOR_EACH_FRAME (tail, frame) - { - struct frame *f = XFRAME (frame); - if (FRAME_X_P (f) - && FRAME_X_IMAGE_CACHE (f) == c) - clear_current_matrices (f); - } - - ++windows_or_buffers_changed; - } - - UNBLOCK_INPUT; - } -} - - -DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache, - 0, 1, 0, - doc: /* Clear the image cache of FRAME. -FRAME nil or omitted means use the selected frame. -FRAME t means clear the image caches of all frames. */) - (frame) - Lisp_Object frame; -{ - if (EQ (frame, Qt)) - { - Lisp_Object tail; - - FOR_EACH_FRAME (tail, frame) - if (FRAME_X_P (XFRAME (frame))) - clear_image_cache (XFRAME (frame), 1); - } - else - clear_image_cache (check_x_frame (frame), 1); - - return Qnil; -} - - -/* Compute masks and transform image IMG on frame F, as specified - by the image's specification, */ - -static void -postprocess_image (f, img) - struct frame *f; - struct image *img; -{ - /* Manipulation of the image's mask. */ - if (img->pixmap) - { - Lisp_Object conversion, spec; - Lisp_Object mask; - - spec = img->spec; - - /* `:heuristic-mask t' - `:mask heuristic' - means build a mask heuristically. - `:heuristic-mask (R G B)' - `:mask (heuristic (R G B))' - means build a mask from color (R G B) in the - image. - `:mask nil' - means remove a mask, if any. */ - - mask = image_spec_value (spec, QCheuristic_mask, NULL); - if (!NILP (mask)) - x_build_heuristic_mask (f, img, mask); - else - { - int found_p; - - mask = image_spec_value (spec, QCmask, &found_p); - - if (EQ (mask, Qheuristic)) - x_build_heuristic_mask (f, img, Qt); - else if (CONSP (mask) - && EQ (XCAR (mask), Qheuristic)) - { - if (CONSP (XCDR (mask))) - x_build_heuristic_mask (f, img, XCAR (XCDR (mask))); - else - x_build_heuristic_mask (f, img, XCDR (mask)); - } - else if (NILP (mask) && found_p && img->mask) - { - XFreePixmap (FRAME_X_DISPLAY (f), img->mask); - img->mask = None; - } - } - - - /* Should we apply an image transformation algorithm? */ - conversion = image_spec_value (spec, QCconversion, NULL); - if (EQ (conversion, Qdisabled)) - x_disable_image (f, img); - else if (EQ (conversion, Qlaplace)) - x_laplace (f, img); - else if (EQ (conversion, Qemboss)) - x_emboss (f, img); - else if (CONSP (conversion) - && EQ (XCAR (conversion), Qedge_detection)) - { - Lisp_Object tem; - tem = XCDR (conversion); - if (CONSP (tem)) - x_edge_detection (f, img, - Fplist_get (tem, QCmatrix), - Fplist_get (tem, QCcolor_adjustment)); - } - } -} - - -/* Return the id of image with Lisp specification SPEC on frame F. - SPEC must be a valid Lisp image specification (see valid_image_p). */ - -int -lookup_image (f, spec) - struct frame *f; - Lisp_Object spec; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - struct image *img; - int i; - unsigned hash; - struct gcpro gcpro1; - EMACS_TIME now; - - /* F must be a window-system frame, and SPEC must be a valid image - specification. */ - xassert (FRAME_WINDOW_P (f)); - xassert (valid_image_p (spec)); - - GCPRO1 (spec); - - /* Look up SPEC in the hash table of the image cache. */ - hash = sxhash (spec, 0); - i = hash % IMAGE_CACHE_BUCKETS_SIZE; - - for (img = c->buckets[i]; img; img = img->next) - if (img->hash == hash && !NILP (Fequal (img->spec, spec))) - break; - - /* If not found, create a new image and cache it. */ - if (img == NULL) - { - extern Lisp_Object Qpostscript; - - BLOCK_INPUT; - img = make_image (spec, hash); - cache_image (f, img); - img->load_failed_p = img->type->load (f, img) == 0; - - /* If we can't load the image, and we don't have a width and - height, use some arbitrary width and height so that we can - draw a rectangle for it. */ - if (img->load_failed_p) - { - Lisp_Object value; - - value = image_spec_value (spec, QCwidth, NULL); - img->width = (INTEGERP (value) - ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH); - value = image_spec_value (spec, QCheight, NULL); - img->height = (INTEGERP (value) - ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT); - } - else - { - /* Handle image type independent image attributes - `:ascent ASCENT', `:margin MARGIN', `:relief RELIEF', - `:background COLOR'. */ - Lisp_Object ascent, margin, relief, bg; - - ascent = image_spec_value (spec, QCascent, NULL); - if (INTEGERP (ascent)) - img->ascent = XFASTINT (ascent); - else if (EQ (ascent, Qcenter)) - img->ascent = CENTERED_IMAGE_ASCENT; - - margin = image_spec_value (spec, QCmargin, NULL); - if (INTEGERP (margin) && XINT (margin) >= 0) - img->vmargin = img->hmargin = XFASTINT (margin); - else if (CONSP (margin) && INTEGERP (XCAR (margin)) - && INTEGERP (XCDR (margin))) - { - if (XINT (XCAR (margin)) > 0) - img->hmargin = XFASTINT (XCAR (margin)); - if (XINT (XCDR (margin)) > 0) - img->vmargin = XFASTINT (XCDR (margin)); - } - - relief = image_spec_value (spec, QCrelief, NULL); - if (INTEGERP (relief)) - { - img->relief = XINT (relief); - img->hmargin += abs (img->relief); - img->vmargin += abs (img->relief); - } - - if (! img->background_valid) - { - bg = image_spec_value (img->spec, QCbackground, NULL); - if (!NILP (bg)) - { - img->background - = x_alloc_image_color (f, img, bg, - FRAME_BACKGROUND_PIXEL (f)); - img->background_valid = 1; - } - } - - /* Do image transformations and compute masks, unless we - don't have the image yet. */ - if (!EQ (*img->type->type, Qpostscript)) - postprocess_image (f, img); - } - - UNBLOCK_INPUT; - } - - /* We're using IMG, so set its timestamp to `now'. */ - EMACS_GET_TIME (now); - img->timestamp = EMACS_SECS (now); - - UNGCPRO; - - /* Value is the image id. */ - return img->id; -} - - -/* Cache image IMG in the image cache of frame F. */ - -static void -cache_image (f, img) - struct frame *f; - struct image *img; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - int i; - - /* Find a free slot in c->images. */ - for (i = 0; i < c->used; ++i) - if (c->images[i] == NULL) - break; - - /* If no free slot found, maybe enlarge c->images. */ - if (i == c->used && c->used == c->size) - { - c->size *= 2; - c->images = (struct image **) xrealloc (c->images, - c->size * sizeof *c->images); - } - - /* Add IMG to c->images, and assign IMG an id. */ - c->images[i] = img; - img->id = i; - if (i == c->used) - ++c->used; - - /* Add IMG to the cache's hash table. */ - i = img->hash % IMAGE_CACHE_BUCKETS_SIZE; - img->next = c->buckets[i]; - if (img->next) - img->next->prev = img; - img->prev = NULL; - c->buckets[i] = img; -} - - -/* Call FN on every image in the image cache of frame F. Used to mark - Lisp Objects in the image cache. */ - -void -forall_images_in_image_cache (f, fn) - struct frame *f; - void (*fn) P_ ((struct image *img)); -{ - if (FRAME_LIVE_P (f) && FRAME_X_P (f)) - { - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - if (c) - { - int i; - for (i = 0; i < c->used; ++i) - if (c->images[i]) - fn (c->images[i]); - } - } -} - - - -/*********************************************************************** - X support code - ***********************************************************************/ - -static int x_create_x_image_and_pixmap P_ ((struct frame *, int, int, int, - XImage **, Pixmap *)); -static void x_destroy_x_image P_ ((XImage *)); -static void x_put_x_image P_ ((struct frame *, XImage *, Pixmap, int, int)); - - -/* Create an XImage and a pixmap of size WIDTH x HEIGHT for use on - frame F. Set *XIMG and *PIXMAP to the XImage and Pixmap created. - Set (*XIMG)->data to a raster of WIDTH x HEIGHT pixels allocated - via xmalloc. Print error messages via image_error if an error - occurs. Value is non-zero if successful. */ - -static int -x_create_x_image_and_pixmap (f, width, height, depth, ximg, pixmap) - struct frame *f; - int width, height, depth; - XImage **ximg; - Pixmap *pixmap; -{ - Display *display = FRAME_X_DISPLAY (f); - Screen *screen = FRAME_X_SCREEN (f); - Window window = FRAME_X_WINDOW (f); - - xassert (interrupt_input_blocked); - - if (depth <= 0) - depth = DefaultDepthOfScreen (screen); - *ximg = XCreateImage (display, DefaultVisualOfScreen (screen), - depth, ZPixmap, 0, NULL, width, height, - depth > 16 ? 32 : depth > 8 ? 16 : 8, 0); - if (*ximg == NULL) - { - image_error ("Unable to allocate X image", Qnil, Qnil); - return 0; - } - - /* Allocate image raster. */ - (*ximg)->data = (char *) xmalloc ((*ximg)->bytes_per_line * height); - - /* Allocate a pixmap of the same size. */ - *pixmap = XCreatePixmap (display, window, width, height, depth); - if (*pixmap == None) - { - x_destroy_x_image (*ximg); - *ximg = NULL; - image_error ("Unable to create X pixmap", Qnil, Qnil); - return 0; - } - - return 1; -} - - -/* Destroy XImage XIMG. Free XIMG->data. */ - -static void -x_destroy_x_image (ximg) - XImage *ximg; -{ - xassert (interrupt_input_blocked); - if (ximg) - { - xfree (ximg->data); - ximg->data = NULL; - XDestroyImage (ximg); - } -} - - -/* Put XImage XIMG into pixmap PIXMAP on frame F. WIDTH and HEIGHT - are width and height of both the image and pixmap. */ - -static void -x_put_x_image (f, ximg, pixmap, width, height) - struct frame *f; - XImage *ximg; - Pixmap pixmap; - int width, height; -{ - GC gc; - - xassert (interrupt_input_blocked); - gc = XCreateGC (FRAME_X_DISPLAY (f), pixmap, 0, NULL); - XPutImage (FRAME_X_DISPLAY (f), pixmap, gc, ximg, 0, 0, 0, 0, width, height); - XFreeGC (FRAME_X_DISPLAY (f), gc); -} - - - -/*********************************************************************** - File Handling - ***********************************************************************/ - -static Lisp_Object x_find_image_file P_ ((Lisp_Object)); -static char *slurp_file P_ ((char *, int *)); - - -/* Find image file FILE. Look in data-directory, then - x-bitmap-file-path. Value is the full name of the file found, or - nil if not found. */ - -static Lisp_Object -x_find_image_file (file) - Lisp_Object file; -{ - Lisp_Object file_found, search_path; - struct gcpro gcpro1, gcpro2; - int fd; - - file_found = Qnil; - search_path = Fcons (Vdata_directory, Vx_bitmap_file_path); - GCPRO2 (file_found, search_path); - - /* Try to find FILE in data-directory, then x-bitmap-file-path. */ - fd = openp (search_path, file, Qnil, &file_found, Qnil); - - if (fd == -1) - file_found = Qnil; - else - close (fd); - - UNGCPRO; - return file_found; -} - - -/* Read FILE into memory. Value is a pointer to a buffer allocated - with xmalloc holding FILE's contents. Value is null if an error - occurred. *SIZE is set to the size of the file. */ - -static char * -slurp_file (file, size) - char *file; - int *size; -{ - FILE *fp = NULL; - char *buf = NULL; - struct stat st; - - if (stat (file, &st) == 0 - && (fp = fopen (file, "r")) != NULL - && (buf = (char *) xmalloc (st.st_size), - fread (buf, 1, st.st_size, fp) == st.st_size)) - { - *size = st.st_size; - fclose (fp); - } - else - { - if (fp) - fclose (fp); - if (buf) - { - xfree (buf); - buf = NULL; - } - } - - return buf; -} - - - -/*********************************************************************** - XBM images - ***********************************************************************/ - -static int xbm_scan P_ ((char **, char *, char *, int *)); -static int xbm_load P_ ((struct frame *f, struct image *img)); -static int xbm_load_image P_ ((struct frame *f, struct image *img, - char *, char *)); -static int xbm_image_p P_ ((Lisp_Object object)); -static int xbm_read_bitmap_data P_ ((char *, char *, int *, int *, - unsigned char **)); -static int xbm_file_p P_ ((Lisp_Object)); - - -/* Indices of image specification fields in xbm_format, below. */ - -enum xbm_keyword_index -{ - XBM_TYPE, - XBM_FILE, - XBM_WIDTH, - XBM_HEIGHT, - XBM_DATA, - XBM_FOREGROUND, - XBM_BACKGROUND, - XBM_ASCENT, - XBM_MARGIN, - XBM_RELIEF, - XBM_ALGORITHM, - XBM_HEURISTIC_MASK, - XBM_MASK, - XBM_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid XBM image specifications. */ - -static struct image_keyword xbm_format[XBM_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 0}, - {":width", IMAGE_POSITIVE_INTEGER_VALUE, 0}, - {":height", IMAGE_POSITIVE_INTEGER_VALUE, 0}, - {":data", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0} -}; - -/* Structure describing the image type XBM. */ - -static struct image_type xbm_type = -{ - &Qxbm, - xbm_image_p, - xbm_load, - x_clear_image, - NULL -}; - -/* Tokens returned from xbm_scan. */ - -enum xbm_token -{ - XBM_TK_IDENT = 256, - XBM_TK_NUMBER -}; - - -/* Return non-zero if OBJECT is a valid XBM-type image specification. - A valid specification is a list starting with the symbol `image' - The rest of the list is a property list which must contain an - entry `:type xbm.. - - If the specification specifies a file to load, it must contain - an entry `:file FILENAME' where FILENAME is a string. - - If the specification is for a bitmap loaded from memory it must - contain `:width WIDTH', `:height HEIGHT', and `:data DATA', where - WIDTH and HEIGHT are integers > 0. DATA may be: - - 1. a string large enough to hold the bitmap data, i.e. it must - have a size >= (WIDTH + 7) / 8 * HEIGHT - - 2. a bool-vector of size >= WIDTH * HEIGHT - - 3. a vector of strings or bool-vectors, one for each line of the - bitmap. - - 4. A string containing an in-memory XBM file. WIDTH and HEIGHT - may not be specified in this case because they are defined in the - XBM file. - - Both the file and data forms may contain the additional entries - `:background COLOR' and `:foreground COLOR'. If not present, - foreground and background of the frame on which the image is - displayed is used. */ - -static int -xbm_image_p (object) - Lisp_Object object; -{ - struct image_keyword kw[XBM_LAST]; - - bcopy (xbm_format, kw, sizeof kw); - if (!parse_image_spec (object, kw, XBM_LAST, Qxbm)) - return 0; - - xassert (EQ (kw[XBM_TYPE].value, Qxbm)); - - if (kw[XBM_FILE].count) - { - if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_DATA].count) - return 0; - } - else if (kw[XBM_DATA].count && xbm_file_p (kw[XBM_DATA].value)) - { - /* In-memory XBM file. */ - if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_FILE].count) - return 0; - } - else - { - Lisp_Object data; - int width, height; - - /* Entries for `:width', `:height' and `:data' must be present. */ - if (!kw[XBM_WIDTH].count - || !kw[XBM_HEIGHT].count - || !kw[XBM_DATA].count) - return 0; - - data = kw[XBM_DATA].value; - width = XFASTINT (kw[XBM_WIDTH].value); - height = XFASTINT (kw[XBM_HEIGHT].value); - - /* Check type of data, and width and height against contents of - data. */ - if (VECTORP (data)) - { - int i; - - /* Number of elements of the vector must be >= height. */ - if (XVECTOR (data)->size < height) - return 0; - - /* Each string or bool-vector in data must be large enough - for one line of the image. */ - for (i = 0; i < height; ++i) - { - Lisp_Object elt = XVECTOR (data)->contents[i]; - - if (STRINGP (elt)) - { - if (SCHARS (elt) - < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR) - return 0; - } - else if (BOOL_VECTOR_P (elt)) - { - if (XBOOL_VECTOR (elt)->size < width) - return 0; - } - else - return 0; - } - } - else if (STRINGP (data)) - { - if (SCHARS (data) - < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height) - return 0; - } - else if (BOOL_VECTOR_P (data)) - { - if (XBOOL_VECTOR (data)->size < width * height) - return 0; - } - else - return 0; - } - - return 1; -} - - -/* Scan a bitmap file. FP is the stream to read from. Value is - either an enumerator from enum xbm_token, or a character for a - single-character token, or 0 at end of file. If scanning an - identifier, store the lexeme of the identifier in SVAL. If - scanning a number, store its value in *IVAL. */ - -static int -xbm_scan (s, end, sval, ival) - char **s, *end; - char *sval; - int *ival; -{ - int c; - - loop: - - /* Skip white space. */ - while (*s < end && (c = *(*s)++, isspace (c))) - ; - - if (*s >= end) - c = 0; - else if (isdigit (c)) - { - int value = 0, digit; - - if (c == '0' && *s < end) - { - c = *(*s)++; - if (c == 'x' || c == 'X') - { - while (*s < end) - { - c = *(*s)++; - if (isdigit (c)) - digit = c - '0'; - else if (c >= 'a' && c <= 'f') - digit = c - 'a' + 10; - else if (c >= 'A' && c <= 'F') - digit = c - 'A' + 10; - else - break; - value = 16 * value + digit; - } - } - else if (isdigit (c)) - { - value = c - '0'; - while (*s < end - && (c = *(*s)++, isdigit (c))) - value = 8 * value + c - '0'; - } - } - else - { - value = c - '0'; - while (*s < end - && (c = *(*s)++, isdigit (c))) - value = 10 * value + c - '0'; - } - - if (*s < end) - *s = *s - 1; - *ival = value; - c = XBM_TK_NUMBER; - } - else if (isalpha (c) || c == '_') - { - *sval++ = c; - while (*s < end - && (c = *(*s)++, (isalnum (c) || c == '_'))) - *sval++ = c; - *sval = 0; - if (*s < end) - *s = *s - 1; - c = XBM_TK_IDENT; - } - else if (c == '/' && **s == '*') - { - /* C-style comment. */ - ++*s; - while (**s && (**s != '*' || *(*s + 1) != '/')) - ++*s; - if (**s) - { - *s += 2; - goto loop; - } - } - - return c; -} - - -/* Replacement for XReadBitmapFileData which isn't available under old - X versions. CONTENTS is a pointer to a buffer to parse; END is the - buffer's end. Set *WIDTH and *HEIGHT to the width and height of - the image. Return in *DATA the bitmap data allocated with xmalloc. - Value is non-zero if successful. DATA null means just test if - CONTENTS looks like an in-memory XBM file. */ - -static int -xbm_read_bitmap_data (contents, end, width, height, data) - char *contents, *end; - int *width, *height; - unsigned char **data; -{ - char *s = contents; - char buffer[BUFSIZ]; - int padding_p = 0; - int v10 = 0; - int bytes_per_line, i, nbytes; - unsigned char *p; - int value; - int LA1; - -#define match() \ - LA1 = xbm_scan (&s, end, buffer, &value) - -#define expect(TOKEN) \ - if (LA1 != (TOKEN)) \ - goto failure; \ - else \ - match () - -#define expect_ident(IDENT) \ - if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \ - match (); \ - else \ - goto failure - - *width = *height = -1; - if (data) - *data = NULL; - LA1 = xbm_scan (&s, end, buffer, &value); - - /* Parse defines for width, height and hot-spots. */ - while (LA1 == '#') - { - match (); - expect_ident ("define"); - expect (XBM_TK_IDENT); - - if (LA1 == XBM_TK_NUMBER); - { - char *p = strrchr (buffer, '_'); - p = p ? p + 1 : buffer; - if (strcmp (p, "width") == 0) - *width = value; - else if (strcmp (p, "height") == 0) - *height = value; - } - expect (XBM_TK_NUMBER); - } - - if (*width < 0 || *height < 0) - goto failure; - else if (data == NULL) - goto success; - - /* Parse bits. Must start with `static'. */ - expect_ident ("static"); - if (LA1 == XBM_TK_IDENT) - { - if (strcmp (buffer, "unsigned") == 0) - { - match (); - expect_ident ("char"); - } - else if (strcmp (buffer, "short") == 0) - { - match (); - v10 = 1; - if (*width % 16 && *width % 16 < 9) - padding_p = 1; - } - else if (strcmp (buffer, "char") == 0) - match (); - else - goto failure; - } - else - goto failure; - - expect (XBM_TK_IDENT); - expect ('['); - expect (']'); - expect ('='); - expect ('{'); - - bytes_per_line = (*width + 7) / 8 + padding_p; - nbytes = bytes_per_line * *height; - p = *data = (char *) xmalloc (nbytes); - - if (v10) - { - for (i = 0; i < nbytes; i += 2) - { - int val = value; - expect (XBM_TK_NUMBER); - - *p++ = val; - if (!padding_p || ((i + 2) % bytes_per_line)) - *p++ = value >> 8; - - if (LA1 == ',' || LA1 == '}') - match (); - else - goto failure; - } - } - else - { - for (i = 0; i < nbytes; ++i) - { - int val = value; - expect (XBM_TK_NUMBER); - - *p++ = val; - - if (LA1 == ',' || LA1 == '}') - match (); - else - goto failure; - } - } - - success: - return 1; - - failure: - - if (data && *data) - { - xfree (*data); - *data = NULL; - } - return 0; - -#undef match -#undef expect -#undef expect_ident -} - - -/* Load XBM image IMG which will be displayed on frame F from buffer - CONTENTS. END is the end of the buffer. Value is non-zero if - successful. */ - -static int -xbm_load_image (f, img, contents, end) - struct frame *f; - struct image *img; - char *contents, *end; -{ - int rc; - unsigned char *data; - int success_p = 0; - - rc = xbm_read_bitmap_data (contents, end, &img->width, &img->height, &data); - if (rc) - { - int depth = DefaultDepthOfScreen (FRAME_X_SCREEN (f)); - unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); - unsigned long background = FRAME_BACKGROUND_PIXEL (f); - Lisp_Object value; - - xassert (img->width > 0 && img->height > 0); - - /* Get foreground and background colors, maybe allocate colors. */ - value = image_spec_value (img->spec, QCforeground, NULL); - if (!NILP (value)) - foreground = x_alloc_image_color (f, img, value, foreground); - value = image_spec_value (img->spec, QCbackground, NULL); - if (!NILP (value)) - { - background = x_alloc_image_color (f, img, value, background); - img->background = background; - img->background_valid = 1; - } - - img->pixmap - = XCreatePixmapFromBitmapData (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), - data, - img->width, img->height, - foreground, background, - depth); - xfree (data); - - if (img->pixmap == None) - { - x_clear_image (f, img); - image_error ("Unable to create X pixmap for `%s'", img->spec, Qnil); - } - else - success_p = 1; - } - else - image_error ("Error loading XBM image `%s'", img->spec, Qnil); - - return success_p; -} - - -/* Value is non-zero if DATA looks like an in-memory XBM file. */ - -static int -xbm_file_p (data) - Lisp_Object data; -{ - int w, h; - return (STRINGP (data) - && xbm_read_bitmap_data (SDATA (data), - (SDATA (data) - + SBYTES (data)), - &w, &h, NULL)); -} - - -/* Fill image IMG which is used on frame F with pixmap data. Value is - non-zero if successful. */ - -static int -xbm_load (f, img) - struct frame *f; - struct image *img; -{ - int success_p = 0; - Lisp_Object file_name; - - xassert (xbm_image_p (img->spec)); - - /* If IMG->spec specifies a file name, create a non-file spec from it. */ - file_name = image_spec_value (img->spec, QCfile, NULL); - if (STRINGP (file_name)) - { - Lisp_Object file; - char *contents; - int size; - struct gcpro gcpro1; - - file = x_find_image_file (file_name); - GCPRO1 (file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", file_name, Qnil); - UNGCPRO; - return 0; - } - - contents = slurp_file (SDATA (file), &size); - if (contents == NULL) - { - image_error ("Error loading XBM image `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - - success_p = xbm_load_image (f, img, contents, contents + size); - UNGCPRO; - } - else - { - struct image_keyword fmt[XBM_LAST]; - Lisp_Object data; - int depth; - unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); - unsigned long background = FRAME_BACKGROUND_PIXEL (f); - char *bits; - int parsed_p; - int in_memory_file_p = 0; - - /* See if data looks like an in-memory XBM file. */ - data = image_spec_value (img->spec, QCdata, NULL); - in_memory_file_p = xbm_file_p (data); - - /* Parse the image specification. */ - bcopy (xbm_format, fmt, sizeof fmt); - parsed_p = parse_image_spec (img->spec, fmt, XBM_LAST, Qxbm); - xassert (parsed_p); - - /* Get specified width, and height. */ - if (!in_memory_file_p) - { - img->width = XFASTINT (fmt[XBM_WIDTH].value); - img->height = XFASTINT (fmt[XBM_HEIGHT].value); - xassert (img->width > 0 && img->height > 0); - } - - /* Get foreground and background colors, maybe allocate colors. */ - if (fmt[XBM_FOREGROUND].count - && STRINGP (fmt[XBM_FOREGROUND].value)) - foreground = x_alloc_image_color (f, img, fmt[XBM_FOREGROUND].value, - foreground); - if (fmt[XBM_BACKGROUND].count - && STRINGP (fmt[XBM_BACKGROUND].value)) - background = x_alloc_image_color (f, img, fmt[XBM_BACKGROUND].value, - background); - - if (in_memory_file_p) - success_p = xbm_load_image (f, img, SDATA (data), - (SDATA (data) - + SBYTES (data))); - else - { - if (VECTORP (data)) - { - int i; - char *p; - int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR; - - p = bits = (char *) alloca (nbytes * img->height); - for (i = 0; i < img->height; ++i, p += nbytes) - { - Lisp_Object line = XVECTOR (data)->contents[i]; - if (STRINGP (line)) - bcopy (SDATA (line), p, nbytes); - else - bcopy (XBOOL_VECTOR (line)->data, p, nbytes); - } - } - else if (STRINGP (data)) - bits = SDATA (data); - else - bits = XBOOL_VECTOR (data)->data; - - /* Create the pixmap. */ - depth = DefaultDepthOfScreen (FRAME_X_SCREEN (f)); - img->pixmap - = XCreatePixmapFromBitmapData (FRAME_X_DISPLAY (f), - FRAME_X_WINDOW (f), - bits, - img->width, img->height, - foreground, background, - depth); - if (img->pixmap) - success_p = 1; - else - { - image_error ("Unable to create pixmap for XBM image `%s'", - img->spec, Qnil); - x_clear_image (f, img); - } - } - } - - return success_p; -} - - - -/*********************************************************************** - XPM images - ***********************************************************************/ - -#if HAVE_XPM - -static int xpm_image_p P_ ((Lisp_Object object)); -static int xpm_load P_ ((struct frame *f, struct image *img)); -static int xpm_valid_color_symbols_p P_ ((Lisp_Object)); - -#include "X11/xpm.h" - -/* The symbol `xpm' identifying XPM-format images. */ - -Lisp_Object Qxpm; - -/* Indices of image specification fields in xpm_format, below. */ - -enum xpm_keyword_index -{ - XPM_TYPE, - XPM_FILE, - XPM_DATA, - XPM_ASCENT, - XPM_MARGIN, - XPM_RELIEF, - XPM_ALGORITHM, - XPM_HEURISTIC_MASK, - XPM_MASK, - XPM_COLOR_SYMBOLS, - XPM_BACKGROUND, - XPM_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid XPM image specifications. */ - -static struct image_keyword xpm_format[XPM_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 0}, - {":data", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type XBM. */ - -static struct image_type xpm_type = -{ - &Qxpm, - xpm_image_p, - xpm_load, - x_clear_image, - NULL -}; - - -/* Define ALLOC_XPM_COLORS if we can use Emacs' own color allocation - functions for allocating image colors. Our own functions handle - color allocation failures more gracefully than the ones on the XPM - lib. */ - -#if defined XpmAllocColor && defined XpmFreeColors && defined XpmColorClosure -#define ALLOC_XPM_COLORS -#endif - -#ifdef ALLOC_XPM_COLORS - -static void xpm_init_color_cache P_ ((struct frame *, XpmAttributes *)); -static void xpm_free_color_cache P_ ((void)); -static int xpm_lookup_color P_ ((struct frame *, char *, XColor *)); -static int xpm_color_bucket P_ ((char *)); -static struct xpm_cached_color *xpm_cache_color P_ ((struct frame *, char *, - XColor *, int)); - -/* An entry in a hash table used to cache color definitions of named - colors. This cache is necessary to speed up XPM image loading in - case we do color allocations ourselves. Without it, we would need - a call to XParseColor per pixel in the image. */ - -struct xpm_cached_color -{ - /* Next in collision chain. */ - struct xpm_cached_color *next; - - /* Color definition (RGB and pixel color). */ - XColor color; - - /* Color name. */ - char name[1]; -}; - -/* The hash table used for the color cache, and its bucket vector - size. */ - -#define XPM_COLOR_CACHE_BUCKETS 1001 -struct xpm_cached_color **xpm_color_cache; - -/* Initialize the color cache. */ - -static void -xpm_init_color_cache (f, attrs) - struct frame *f; - XpmAttributes *attrs; -{ - size_t nbytes = XPM_COLOR_CACHE_BUCKETS * sizeof *xpm_color_cache; - xpm_color_cache = (struct xpm_cached_color **) xmalloc (nbytes); - memset (xpm_color_cache, 0, nbytes); - init_color_table (); - - if (attrs->valuemask & XpmColorSymbols) - { - int i; - XColor color; - - for (i = 0; i < attrs->numsymbols; ++i) - if (XParseColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), - attrs->colorsymbols[i].value, &color)) - { - color.pixel = lookup_rgb_color (f, color.red, color.green, - color.blue); - xpm_cache_color (f, attrs->colorsymbols[i].name, &color, -1); - } - } -} - - -/* Free the color cache. */ - -static void -xpm_free_color_cache () -{ - struct xpm_cached_color *p, *next; - int i; - - for (i = 0; i < XPM_COLOR_CACHE_BUCKETS; ++i) - for (p = xpm_color_cache[i]; p; p = next) - { - next = p->next; - xfree (p); - } - - xfree (xpm_color_cache); - xpm_color_cache = NULL; - free_color_table (); -} - - -/* Return the bucket index for color named COLOR_NAME in the color - cache. */ - -static int -xpm_color_bucket (color_name) - char *color_name; -{ - unsigned h = 0; - char *s; - - for (s = color_name; *s; ++s) - h = (h << 2) ^ *s; - return h %= XPM_COLOR_CACHE_BUCKETS; -} - - -/* On frame F, cache values COLOR for color with name COLOR_NAME. - BUCKET, if >= 0, is a precomputed bucket index. Value is the cache - entry added. */ - -static struct xpm_cached_color * -xpm_cache_color (f, color_name, color, bucket) - struct frame *f; - char *color_name; - XColor *color; - int bucket; -{ - size_t nbytes; - struct xpm_cached_color *p; - - if (bucket < 0) - bucket = xpm_color_bucket (color_name); - - nbytes = sizeof *p + strlen (color_name); - p = (struct xpm_cached_color *) xmalloc (nbytes); - strcpy (p->name, color_name); - p->color = *color; - p->next = xpm_color_cache[bucket]; - xpm_color_cache[bucket] = p; - return p; -} - - -/* Look up color COLOR_NAME for frame F in the color cache. If found, - return the cached definition in *COLOR. Otherwise, make a new - entry in the cache and allocate the color. Value is zero if color - allocation failed. */ - -static int -xpm_lookup_color (f, color_name, color) - struct frame *f; - char *color_name; - XColor *color; -{ - struct xpm_cached_color *p; - int h = xpm_color_bucket (color_name); - - for (p = xpm_color_cache[h]; p; p = p->next) - if (strcmp (p->name, color_name) == 0) - break; - - if (p != NULL) - *color = p->color; - else if (XParseColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), - color_name, color)) - { - color->pixel = lookup_rgb_color (f, color->red, color->green, - color->blue); - p = xpm_cache_color (f, color_name, color, h); - } - /* You get `opaque' at least from ImageMagick converting pbm to xpm - with transparency, and it's useful. */ - else if (strcmp ("opaque", color_name) == 0) - { - bzero (color, sizeof (XColor)); /* Is this necessary/correct? */ - color->pixel = FRAME_FOREGROUND_PIXEL (f); - p = xpm_cache_color (f, color_name, color, h); - } - - return p != NULL; -} - - -/* Callback for allocating color COLOR_NAME. Called from the XPM lib. - CLOSURE is a pointer to the frame on which we allocate the - color. Return in *COLOR the allocated color. Value is non-zero - if successful. */ - -static int -xpm_alloc_color (dpy, cmap, color_name, color, closure) - Display *dpy; - Colormap cmap; - char *color_name; - XColor *color; - void *closure; -{ - return xpm_lookup_color ((struct frame *) closure, color_name, color); -} - - -/* Callback for freeing NPIXELS colors contained in PIXELS. CLOSURE - is a pointer to the frame on which we allocate the color. Value is - non-zero if successful. */ - -static int -xpm_free_colors (dpy, cmap, pixels, npixels, closure) - Display *dpy; - Colormap cmap; - Pixel *pixels; - int npixels; - void *closure; -{ - return 1; -} - -#endif /* ALLOC_XPM_COLORS */ - - -/* Value is non-zero if COLOR_SYMBOLS is a valid color symbols list - for XPM images. Such a list must consist of conses whose car and - cdr are strings. */ - -static int -xpm_valid_color_symbols_p (color_symbols) - Lisp_Object color_symbols; -{ - while (CONSP (color_symbols)) - { - Lisp_Object sym = XCAR (color_symbols); - if (!CONSP (sym) - || !STRINGP (XCAR (sym)) - || !STRINGP (XCDR (sym))) - break; - color_symbols = XCDR (color_symbols); - } - - return NILP (color_symbols); -} - - -/* Value is non-zero if OBJECT is a valid XPM image specification. */ - -static int -xpm_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[XPM_LAST]; - bcopy (xpm_format, fmt, sizeof fmt); - return (parse_image_spec (object, fmt, XPM_LAST, Qxpm) - /* Either `:file' or `:data' must be present. */ - && fmt[XPM_FILE].count + fmt[XPM_DATA].count == 1 - /* Either no `:color-symbols' or it's a list of conses - whose car and cdr are strings. */ - && (fmt[XPM_COLOR_SYMBOLS].count == 0 - || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value))); -} - - -/* Load image IMG which will be displayed on frame F. Value is - non-zero if successful. */ - -static int -xpm_load (f, img) - struct frame *f; - struct image *img; -{ - int rc; - XpmAttributes attrs; - Lisp_Object specified_file, color_symbols; - - /* Configure the XPM lib. Use the visual of frame F. Allocate - close colors. Return colors allocated. */ - bzero (&attrs, sizeof attrs); - attrs.visual = FRAME_X_VISUAL (f); - attrs.colormap = FRAME_X_COLORMAP (f); - attrs.valuemask |= XpmVisual; - attrs.valuemask |= XpmColormap; - -#ifdef ALLOC_XPM_COLORS - /* Allocate colors with our own functions which handle - failing color allocation more gracefully. */ - attrs.color_closure = f; - attrs.alloc_color = xpm_alloc_color; - attrs.free_colors = xpm_free_colors; - attrs.valuemask |= XpmAllocColor | XpmFreeColors | XpmColorClosure; -#else /* not ALLOC_XPM_COLORS */ - /* Let the XPM lib allocate colors. */ - attrs.valuemask |= XpmReturnAllocPixels; -#ifdef XpmAllocCloseColors - attrs.alloc_close_colors = 1; - attrs.valuemask |= XpmAllocCloseColors; -#else /* not XpmAllocCloseColors */ - attrs.closeness = 600; - attrs.valuemask |= XpmCloseness; -#endif /* not XpmAllocCloseColors */ -#endif /* ALLOC_XPM_COLORS */ - - /* If image specification contains symbolic color definitions, add - these to `attrs'. */ - color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL); - if (CONSP (color_symbols)) - { - Lisp_Object tail; - XpmColorSymbol *xpm_syms; - int i, size; - - attrs.valuemask |= XpmColorSymbols; - - /* Count number of symbols. */ - attrs.numsymbols = 0; - for (tail = color_symbols; CONSP (tail); tail = XCDR (tail)) - ++attrs.numsymbols; - - /* Allocate an XpmColorSymbol array. */ - size = attrs.numsymbols * sizeof *xpm_syms; - xpm_syms = (XpmColorSymbol *) alloca (size); - bzero (xpm_syms, size); - attrs.colorsymbols = xpm_syms; - - /* Fill the color symbol array. */ - for (tail = color_symbols, i = 0; - CONSP (tail); - ++i, tail = XCDR (tail)) - { - Lisp_Object name = XCAR (XCAR (tail)); - Lisp_Object color = XCDR (XCAR (tail)); - xpm_syms[i].name = (char *) alloca (SCHARS (name) + 1); - strcpy (xpm_syms[i].name, SDATA (name)); - xpm_syms[i].value = (char *) alloca (SCHARS (color) + 1); - strcpy (xpm_syms[i].value, SDATA (color)); - } - } - - /* Create a pixmap for the image, either from a file, or from a - string buffer containing data in the same format as an XPM file. */ -#ifdef ALLOC_XPM_COLORS - xpm_init_color_cache (f, &attrs); -#endif - - specified_file = image_spec_value (img->spec, QCfile, NULL); - if (STRINGP (specified_file)) - { - Lisp_Object file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - return 0; - } - - rc = XpmReadFileToPixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - SDATA (file), &img->pixmap, &img->mask, - &attrs); - } - else - { - Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL); - rc = XpmCreatePixmapFromBuffer (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - SDATA (buffer), - &img->pixmap, &img->mask, - &attrs); - } - - if (rc == XpmSuccess) - { -#ifdef ALLOC_XPM_COLORS - img->colors = colors_in_color_table (&img->ncolors); -#else /* not ALLOC_XPM_COLORS */ - int i; - - img->ncolors = attrs.nalloc_pixels; - img->colors = (unsigned long *) xmalloc (img->ncolors - * sizeof *img->colors); - for (i = 0; i < attrs.nalloc_pixels; ++i) - { - img->colors[i] = attrs.alloc_pixels[i]; -#ifdef DEBUG_X_COLORS - register_color (img->colors[i]); -#endif - } -#endif /* not ALLOC_XPM_COLORS */ - - img->width = attrs.width; - img->height = attrs.height; - xassert (img->width > 0 && img->height > 0); - - /* The call to XpmFreeAttributes below frees attrs.alloc_pixels. */ - XpmFreeAttributes (&attrs); - } - else - { - switch (rc) - { - case XpmOpenFailed: - image_error ("Error opening XPM file (%s)", img->spec, Qnil); - break; - - case XpmFileInvalid: - image_error ("Invalid XPM file (%s)", img->spec, Qnil); - break; - - case XpmNoMemory: - image_error ("Out of memory (%s)", img->spec, Qnil); - break; - - case XpmColorFailed: - image_error ("Color allocation error (%s)", img->spec, Qnil); - break; - - default: - image_error ("Unknown error (%s)", img->spec, Qnil); - break; - } - } - -#ifdef ALLOC_XPM_COLORS - xpm_free_color_cache (); -#endif - return rc == XpmSuccess; -} - -#endif /* HAVE_XPM != 0 */ - - -/*********************************************************************** - Color table - ***********************************************************************/ - -/* An entry in the color table mapping an RGB color to a pixel color. */ - -struct ct_color -{ - int r, g, b; - unsigned long pixel; - - /* Next in color table collision list. */ - struct ct_color *next; -}; - -/* The bucket vector size to use. Must be prime. */ - -#define CT_SIZE 101 - -/* Value is a hash of the RGB color given by R, G, and B. */ - -#define CT_HASH_RGB(R, G, B) (((R) << 16) ^ ((G) << 8) ^ (B)) - -/* The color hash table. */ - -struct ct_color **ct_table; - -/* Number of entries in the color table. */ - -int ct_colors_allocated; - -/* Initialize the color table. */ - -static void -init_color_table () -{ - int size = CT_SIZE * sizeof (*ct_table); - ct_table = (struct ct_color **) xmalloc (size); - bzero (ct_table, size); - ct_colors_allocated = 0; -} - - -/* Free memory associated with the color table. */ - -static void -free_color_table () -{ - int i; - struct ct_color *p, *next; - - for (i = 0; i < CT_SIZE; ++i) - for (p = ct_table[i]; p; p = next) - { - next = p->next; - xfree (p); - } - - xfree (ct_table); - ct_table = NULL; -} - - -/* Value is a pixel color for RGB color R, G, B on frame F. If an - entry for that color already is in the color table, return the - pixel color of that entry. Otherwise, allocate a new color for R, - G, B, and make an entry in the color table. */ - -static unsigned long -lookup_rgb_color (f, r, g, b) - struct frame *f; - int r, g, b; -{ - unsigned hash = CT_HASH_RGB (r, g, b); - int i = hash % CT_SIZE; - struct ct_color *p; - struct x_display_info *dpyinfo; - - /* Handle TrueColor visuals specially, which improves performance by - two orders of magnitude. Freeing colors on TrueColor visuals is - a nop, and pixel colors specify RGB values directly. See also - the Xlib spec, chapter 3.1. */ - dpyinfo = FRAME_X_DISPLAY_INFO (f); - if (dpyinfo->red_bits > 0) - { - unsigned long pr, pg, pb; - - /* Apply gamma-correction like normal color allocation does. */ - if (f->gamma) - { - XColor color; - color.red = r, color.green = g, color.blue = b; - gamma_correct (f, &color); - r = color.red, g = color.green, b = color.blue; - } - - /* Scale down RGB values to the visual's bits per RGB, and shift - them to the right position in the pixel color. Note that the - original RGB values are 16-bit values, as usual in X. */ - pr = (r >> (16 - dpyinfo->red_bits)) << dpyinfo->red_offset; - pg = (g >> (16 - dpyinfo->green_bits)) << dpyinfo->green_offset; - pb = (b >> (16 - dpyinfo->blue_bits)) << dpyinfo->blue_offset; - - /* Assemble the pixel color. */ - return pr | pg | pb; - } - - for (p = ct_table[i]; p; p = p->next) - if (p->r == r && p->g == g && p->b == b) - break; - - if (p == NULL) - { - XColor color; - Colormap cmap; - int rc; - - color.red = r; - color.green = g; - color.blue = b; - - cmap = FRAME_X_COLORMAP (f); - rc = x_alloc_nearest_color (f, cmap, &color); - - if (rc) - { - ++ct_colors_allocated; - - p = (struct ct_color *) xmalloc (sizeof *p); - p->r = r; - p->g = g; - p->b = b; - p->pixel = color.pixel; - p->next = ct_table[i]; - ct_table[i] = p; - } - else - return FRAME_FOREGROUND_PIXEL (f); - } - - return p->pixel; -} - - -/* Look up pixel color PIXEL which is used on frame F in the color - table. If not already present, allocate it. Value is PIXEL. */ - -static unsigned long -lookup_pixel_color (f, pixel) - struct frame *f; - unsigned long pixel; -{ - int i = pixel % CT_SIZE; - struct ct_color *p; - - for (p = ct_table[i]; p; p = p->next) - if (p->pixel == pixel) - break; - - if (p == NULL) - { - XColor color; - Colormap cmap; - int rc; - - cmap = FRAME_X_COLORMAP (f); - color.pixel = pixel; - x_query_color (f, &color); - rc = x_alloc_nearest_color (f, cmap, &color); - - if (rc) - { - ++ct_colors_allocated; - - p = (struct ct_color *) xmalloc (sizeof *p); - p->r = color.red; - p->g = color.green; - p->b = color.blue; - p->pixel = pixel; - p->next = ct_table[i]; - ct_table[i] = p; - } - else - return FRAME_FOREGROUND_PIXEL (f); - } - - return p->pixel; -} - - -/* Value is a vector of all pixel colors contained in the color table, - allocated via xmalloc. Set *N to the number of colors. */ - -static unsigned long * -colors_in_color_table (n) - int *n; -{ - int i, j; - struct ct_color *p; - unsigned long *colors; - - if (ct_colors_allocated == 0) - { - *n = 0; - colors = NULL; - } - else - { - colors = (unsigned long *) xmalloc (ct_colors_allocated - * sizeof *colors); - *n = ct_colors_allocated; - - for (i = j = 0; i < CT_SIZE; ++i) - for (p = ct_table[i]; p; p = p->next) - colors[j++] = p->pixel; - } - - return colors; -} - - - -/*********************************************************************** - Algorithms - ***********************************************************************/ - -static XColor *x_to_xcolors P_ ((struct frame *, struct image *, int)); -static void x_from_xcolors P_ ((struct frame *, struct image *, XColor *)); -static void x_detect_edges P_ ((struct frame *, struct image *, int[9], int)); - -/* Non-zero means draw a cross on images having `:conversion - disabled'. */ - -int cross_disabled_images; - -/* Edge detection matrices for different edge-detection - strategies. */ - -static int emboss_matrix[9] = { - /* x - 1 x x + 1 */ - 2, -1, 0, /* y - 1 */ - -1, 0, 1, /* y */ - 0, 1, -2 /* y + 1 */ -}; - -static int laplace_matrix[9] = { - /* x - 1 x x + 1 */ - 1, 0, 0, /* y - 1 */ - 0, 0, 0, /* y */ - 0, 0, -1 /* y + 1 */ -}; - -/* Value is the intensity of the color whose red/green/blue values - are R, G, and B. */ - -#define COLOR_INTENSITY(R, G, B) ((2 * (R) + 3 * (G) + (B)) / 6) - - -/* On frame F, return an array of XColor structures describing image - IMG->pixmap. Each XColor structure has its pixel color set. RGB_P - non-zero means also fill the red/green/blue members of the XColor - structures. Value is a pointer to the array of XColors structures, - allocated with xmalloc; it must be freed by the caller. */ - -static XColor * -x_to_xcolors (f, img, rgb_p) - struct frame *f; - struct image *img; - int rgb_p; -{ - int x, y; - XColor *colors, *p; - XImage *ximg; - - colors = (XColor *) xmalloc (img->width * img->height * sizeof *colors); - - /* Get the X image IMG->pixmap. */ - ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap, - 0, 0, img->width, img->height, ~0, ZPixmap); - - /* Fill the `pixel' members of the XColor array. I wished there - were an easy and portable way to circumvent XGetPixel. */ - p = colors; - for (y = 0; y < img->height; ++y) - { - XColor *row = p; - - for (x = 0; x < img->width; ++x, ++p) - p->pixel = XGetPixel (ximg, x, y); - - if (rgb_p) - x_query_colors (f, row, img->width); - } - - XDestroyImage (ximg); - return colors; -} - - -/* Create IMG->pixmap from an array COLORS of XColor structures, whose - RGB members are set. F is the frame on which this all happens. - COLORS will be freed; an existing IMG->pixmap will be freed, too. */ - -static void -x_from_xcolors (f, img, colors) - struct frame *f; - struct image *img; - XColor *colors; -{ - int x, y; - XImage *oimg; - Pixmap pixmap; - XColor *p; - - init_color_table (); - - x_create_x_image_and_pixmap (f, img->width, img->height, 0, - &oimg, &pixmap); - p = colors; - for (y = 0; y < img->height; ++y) - for (x = 0; x < img->width; ++x, ++p) - { - unsigned long pixel; - pixel = lookup_rgb_color (f, p->red, p->green, p->blue); - XPutPixel (oimg, x, y, pixel); - } - - xfree (colors); - x_clear_image_1 (f, img, 1, 0, 1); - - x_put_x_image (f, oimg, pixmap, img->width, img->height); - x_destroy_x_image (oimg); - img->pixmap = pixmap; - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); -} - - -/* On frame F, perform edge-detection on image IMG. - - MATRIX is a nine-element array specifying the transformation - matrix. See emboss_matrix for an example. - - COLOR_ADJUST is a color adjustment added to each pixel of the - outgoing image. */ - -static void -x_detect_edges (f, img, matrix, color_adjust) - struct frame *f; - struct image *img; - int matrix[9], color_adjust; -{ - XColor *colors = x_to_xcolors (f, img, 1); - XColor *new, *p; - int x, y, i, sum; - - for (i = sum = 0; i < 9; ++i) - sum += abs (matrix[i]); - -#define COLOR(A, X, Y) ((A) + (Y) * img->width + (X)) - - new = (XColor *) xmalloc (img->width * img->height * sizeof *new); - - for (y = 0; y < img->height; ++y) - { - p = COLOR (new, 0, y); - p->red = p->green = p->blue = 0xffff/2; - p = COLOR (new, img->width - 1, y); - p->red = p->green = p->blue = 0xffff/2; - } - - for (x = 1; x < img->width - 1; ++x) - { - p = COLOR (new, x, 0); - p->red = p->green = p->blue = 0xffff/2; - p = COLOR (new, x, img->height - 1); - p->red = p->green = p->blue = 0xffff/2; - } - - for (y = 1; y < img->height - 1; ++y) - { - p = COLOR (new, 1, y); - - for (x = 1; x < img->width - 1; ++x, ++p) - { - int r, g, b, y1, x1; - - r = g = b = i = 0; - for (y1 = y - 1; y1 < y + 2; ++y1) - for (x1 = x - 1; x1 < x + 2; ++x1, ++i) - if (matrix[i]) - { - XColor *t = COLOR (colors, x1, y1); - r += matrix[i] * t->red; - g += matrix[i] * t->green; - b += matrix[i] * t->blue; - } - - r = (r / sum + color_adjust) & 0xffff; - g = (g / sum + color_adjust) & 0xffff; - b = (b / sum + color_adjust) & 0xffff; - p->red = p->green = p->blue = COLOR_INTENSITY (r, g, b); - } - } - - xfree (colors); - x_from_xcolors (f, img, new); - -#undef COLOR -} - - -/* Perform the pre-defined `emboss' edge-detection on image IMG - on frame F. */ - -static void -x_emboss (f, img) - struct frame *f; - struct image *img; -{ - x_detect_edges (f, img, emboss_matrix, 0xffff / 2); -} - - -/* Perform the pre-defined `laplace' edge-detection on image IMG - on frame F. */ - -static void -x_laplace (f, img) - struct frame *f; - struct image *img; -{ - x_detect_edges (f, img, laplace_matrix, 45000); -} - - -/* Perform edge-detection on image IMG on frame F, with specified - transformation matrix MATRIX and color-adjustment COLOR_ADJUST. - - MATRIX must be either - - - a list of at least 9 numbers in row-major form - - a vector of at least 9 numbers - - COLOR_ADJUST nil means use a default; otherwise it must be a - number. */ - -static void -x_edge_detection (f, img, matrix, color_adjust) - struct frame *f; - struct image *img; - Lisp_Object matrix, color_adjust; -{ - int i = 0; - int trans[9]; - - if (CONSP (matrix)) - { - for (i = 0; - i < 9 && CONSP (matrix) && NUMBERP (XCAR (matrix)); - ++i, matrix = XCDR (matrix)) - trans[i] = XFLOATINT (XCAR (matrix)); - } - else if (VECTORP (matrix) && ASIZE (matrix) >= 9) - { - for (i = 0; i < 9 && NUMBERP (AREF (matrix, i)); ++i) - trans[i] = XFLOATINT (AREF (matrix, i)); - } - - if (NILP (color_adjust)) - color_adjust = make_number (0xffff / 2); - - if (i == 9 && NUMBERP (color_adjust)) - x_detect_edges (f, img, trans, (int) XFLOATINT (color_adjust)); -} - - -/* Transform image IMG on frame F so that it looks disabled. */ - -static void -x_disable_image (f, img) - struct frame *f; - struct image *img; -{ - struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f); - - if (dpyinfo->n_planes >= 2) - { - /* Color (or grayscale). Convert to gray, and equalize. Just - drawing such images with a stipple can look very odd, so - we're using this method instead. */ - XColor *colors = x_to_xcolors (f, img, 1); - XColor *p, *end; - const int h = 15000; - const int l = 30000; - - for (p = colors, end = colors + img->width * img->height; - p < end; - ++p) - { - int i = COLOR_INTENSITY (p->red, p->green, p->blue); - int i2 = (0xffff - h - l) * i / 0xffff + l; - p->red = p->green = p->blue = i2; - } - - x_from_xcolors (f, img, colors); - } - - /* Draw a cross over the disabled image, if we must or if we - should. */ - if (dpyinfo->n_planes < 2 || cross_disabled_images) - { - Display *dpy = FRAME_X_DISPLAY (f); - GC gc; - - gc = XCreateGC (dpy, img->pixmap, 0, NULL); - XSetForeground (dpy, gc, BLACK_PIX_DEFAULT (f)); - XDrawLine (dpy, img->pixmap, gc, 0, 0, - img->width - 1, img->height - 1); - XDrawLine (dpy, img->pixmap, gc, 0, img->height - 1, - img->width - 1, 0); - XFreeGC (dpy, gc); - - if (img->mask) - { - gc = XCreateGC (dpy, img->mask, 0, NULL); - XSetForeground (dpy, gc, WHITE_PIX_DEFAULT (f)); - XDrawLine (dpy, img->mask, gc, 0, 0, - img->width - 1, img->height - 1); - XDrawLine (dpy, img->mask, gc, 0, img->height - 1, - img->width - 1, 0); - XFreeGC (dpy, gc); - } - } -} - - -/* Build a mask for image IMG which is used on frame F. FILE is the - name of an image file, for error messages. HOW determines how to - determine the background color of IMG. If it is a list '(R G B)', - with R, G, and B being integers >= 0, take that as the color of the - background. Otherwise, determine the background color of IMG - heuristically. Value is non-zero if successful. */ - -static int -x_build_heuristic_mask (f, img, how) - struct frame *f; - struct image *img; - Lisp_Object how; -{ - Display *dpy = FRAME_X_DISPLAY (f); - XImage *ximg, *mask_img; - int x, y, rc, use_img_background; - unsigned long bg = 0; - - if (img->mask) - { - XFreePixmap (FRAME_X_DISPLAY (f), img->mask); - img->mask = None; - img->background_transparent_valid = 0; - } - - /* Create an image and pixmap serving as mask. */ - rc = x_create_x_image_and_pixmap (f, img->width, img->height, 1, - &mask_img, &img->mask); - if (!rc) - return 0; - - /* Get the X image of IMG->pixmap. */ - ximg = XGetImage (dpy, img->pixmap, 0, 0, img->width, img->height, - ~0, ZPixmap); - - /* Determine the background color of ximg. If HOW is `(R G B)' - take that as color. Otherwise, use the image's background color. */ - use_img_background = 1; - - if (CONSP (how)) - { - int rgb[3], i; - - for (i = 0; i < 3 && CONSP (how) && NATNUMP (XCAR (how)); ++i) - { - rgb[i] = XFASTINT (XCAR (how)) & 0xffff; - how = XCDR (how); - } - - if (i == 3 && NILP (how)) - { - char color_name[30]; - sprintf (color_name, "#%04x%04x%04x", rgb[0], rgb[1], rgb[2]); - bg = x_alloc_image_color (f, img, build_string (color_name), 0); - use_img_background = 0; - } - } - - if (use_img_background) - bg = four_corners_best (ximg, img->width, img->height); - - /* Set all bits in mask_img to 1 whose color in ximg is different - from the background color bg. */ - for (y = 0; y < img->height; ++y) - for (x = 0; x < img->width; ++x) - XPutPixel (mask_img, x, y, XGetPixel (ximg, x, y) != bg); - - /* Fill in the background_transparent field while we have the mask handy. */ - image_background_transparent (img, f, mask_img); - - /* Put mask_img into img->mask. */ - x_put_x_image (f, mask_img, img->mask, img->width, img->height); - x_destroy_x_image (mask_img); - XDestroyImage (ximg); - - return 1; -} - - - -/*********************************************************************** - PBM (mono, gray, color) - ***********************************************************************/ - -static int pbm_image_p P_ ((Lisp_Object object)); -static int pbm_load P_ ((struct frame *f, struct image *img)); -static int pbm_scan_number P_ ((unsigned char **, unsigned char *)); - -/* The symbol `pbm' identifying images of this type. */ - -Lisp_Object Qpbm; - -/* Indices of image specification fields in gs_format, below. */ - -enum pbm_keyword_index -{ - PBM_TYPE, - PBM_FILE, - PBM_DATA, - PBM_ASCENT, - PBM_MARGIN, - PBM_RELIEF, - PBM_ALGORITHM, - PBM_HEURISTIC_MASK, - PBM_MASK, - PBM_FOREGROUND, - PBM_BACKGROUND, - PBM_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword pbm_format[PBM_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 0}, - {":data", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `pbm'. */ - -static struct image_type pbm_type = -{ - &Qpbm, - pbm_image_p, - pbm_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid PBM image specification. */ - -static int -pbm_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[PBM_LAST]; - - bcopy (pbm_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, PBM_LAST, Qpbm)) - return 0; - - /* Must specify either :data or :file. */ - return fmt[PBM_DATA].count + fmt[PBM_FILE].count == 1; -} - - -/* Scan a decimal number from *S and return it. Advance *S while - reading the number. END is the end of the string. Value is -1 at - end of input. */ - -static int -pbm_scan_number (s, end) - unsigned char **s, *end; -{ - int c = 0, val = -1; - - while (*s < end) - { - /* Skip white-space. */ - while (*s < end && (c = *(*s)++, isspace (c))) - ; - - if (c == '#') - { - /* Skip comment to end of line. */ - while (*s < end && (c = *(*s)++, c != '\n')) - ; - } - else if (isdigit (c)) - { - /* Read decimal number. */ - val = c - '0'; - while (*s < end && (c = *(*s)++, isdigit (c))) - val = 10 * val + c - '0'; - break; - } - else - break; - } - - return val; -} - - -/* Load PBM image IMG for use on frame F. */ - -static int -pbm_load (f, img) - struct frame *f; - struct image *img; -{ - int raw_p, x, y; - int width, height, max_color_idx = 0; - XImage *ximg; - Lisp_Object file, specified_file; - enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type; - struct gcpro gcpro1; - unsigned char *contents = NULL; - unsigned char *end, *p; - int size; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - file = Qnil; - GCPRO1 (file); - - if (STRINGP (specified_file)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - contents = slurp_file (SDATA (file), &size); - if (contents == NULL) - { - image_error ("Error reading `%s'", file, Qnil); - UNGCPRO; - return 0; - } - - p = contents; - end = contents + size; - } - else - { - Lisp_Object data; - data = image_spec_value (img->spec, QCdata, NULL); - p = SDATA (data); - end = p + SBYTES (data); - } - - /* Check magic number. */ - if (end - p < 2 || *p++ != 'P') - { - image_error ("Not a PBM image: `%s'", img->spec, Qnil); - error: - xfree (contents); - UNGCPRO; - return 0; - } - - switch (*p++) - { - case '1': - raw_p = 0, type = PBM_MONO; - break; - - case '2': - raw_p = 0, type = PBM_GRAY; - break; - - case '3': - raw_p = 0, type = PBM_COLOR; - break; - - case '4': - raw_p = 1, type = PBM_MONO; - break; - - case '5': - raw_p = 1, type = PBM_GRAY; - break; - - case '6': - raw_p = 1, type = PBM_COLOR; - break; - - default: - image_error ("Not a PBM image: `%s'", img->spec, Qnil); - goto error; - } - - /* Read width, height, maximum color-component. Characters - starting with `#' up to the end of a line are ignored. */ - width = pbm_scan_number (&p, end); - height = pbm_scan_number (&p, end); - - if (type != PBM_MONO) - { - max_color_idx = pbm_scan_number (&p, end); - if (raw_p && max_color_idx > 255) - max_color_idx = 255; - } - - if (width < 0 - || height < 0 - || (type != PBM_MONO && max_color_idx < 0)) - goto error; - - if (!x_create_x_image_and_pixmap (f, width, height, 0, - &ximg, &img->pixmap)) - goto error; - - /* Initialize the color hash table. */ - init_color_table (); - - if (type == PBM_MONO) - { - int c = 0, g; - struct image_keyword fmt[PBM_LAST]; - unsigned long fg = FRAME_FOREGROUND_PIXEL (f); - unsigned long bg = FRAME_BACKGROUND_PIXEL (f); - - /* Parse the image specification. */ - bcopy (pbm_format, fmt, sizeof fmt); - parse_image_spec (img->spec, fmt, PBM_LAST, Qpbm); - - /* Get foreground and background colors, maybe allocate colors. */ - if (fmt[PBM_FOREGROUND].count - && STRINGP (fmt[PBM_FOREGROUND].value)) - fg = x_alloc_image_color (f, img, fmt[PBM_FOREGROUND].value, fg); - if (fmt[PBM_BACKGROUND].count - && STRINGP (fmt[PBM_BACKGROUND].value)) - { - bg = x_alloc_image_color (f, img, fmt[PBM_BACKGROUND].value, bg); - img->background = bg; - img->background_valid = 1; - } - - for (y = 0; y < height; ++y) - for (x = 0; x < width; ++x) - { - if (raw_p) - { - if ((x & 7) == 0) - c = *p++; - g = c & 0x80; - c <<= 1; - } - else - g = pbm_scan_number (&p, end); - - XPutPixel (ximg, x, y, g ? fg : bg); - } - } - else - { - for (y = 0; y < height; ++y) - for (x = 0; x < width; ++x) - { - int r, g, b; - - if (type == PBM_GRAY) - r = g = b = raw_p ? *p++ : pbm_scan_number (&p, end); - else if (raw_p) - { - r = *p++; - g = *p++; - b = *p++; - } - else - { - r = pbm_scan_number (&p, end); - g = pbm_scan_number (&p, end); - b = pbm_scan_number (&p, end); - } - - if (r < 0 || g < 0 || b < 0) - { - xfree (ximg->data); - ximg->data = NULL; - XDestroyImage (ximg); - image_error ("Invalid pixel value in image `%s'", - img->spec, Qnil); - goto error; - } - - /* RGB values are now in the range 0..max_color_idx. - Scale this to the range 0..0xffff supported by X. */ - r = (double) r * 65535 / max_color_idx; - g = (double) g * 65535 / max_color_idx; - b = (double) b * 65535 / max_color_idx; - XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b)); - } - } - - /* Store in IMG->colors the colors allocated for the image, and - free the color table. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into a pixmap. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - - img->width = width; - img->height = height; - - UNGCPRO; - xfree (contents); - return 1; -} - - - -/*********************************************************************** - PNG - ***********************************************************************/ - -#if HAVE_PNG - -#if defined HAVE_LIBPNG_PNG_H -# include <libpng/png.h> -#else -# include <png.h> -#endif - -/* Function prototypes. */ - -static int png_image_p P_ ((Lisp_Object object)); -static int png_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `png' identifying images of this type. */ - -Lisp_Object Qpng; - -/* Indices of image specification fields in png_format, below. */ - -enum png_keyword_index -{ - PNG_TYPE, - PNG_DATA, - PNG_FILE, - PNG_ASCENT, - PNG_MARGIN, - PNG_RELIEF, - PNG_ALGORITHM, - PNG_HEURISTIC_MASK, - PNG_MASK, - PNG_BACKGROUND, - PNG_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword png_format[PNG_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `png'. */ - -static struct image_type png_type = -{ - &Qpng, - png_image_p, - png_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid PNG image specification. */ - -static int -png_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[PNG_LAST]; - bcopy (png_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, PNG_LAST, Qpng)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1; -} - - -/* Error and warning handlers installed when the PNG library - is initialized. */ - -static void -my_png_error (png_ptr, msg) - png_struct *png_ptr; - char *msg; -{ - xassert (png_ptr != NULL); - image_error ("PNG error: %s", build_string (msg), Qnil); - longjmp (png_ptr->jmpbuf, 1); -} - - -static void -my_png_warning (png_ptr, msg) - png_struct *png_ptr; - char *msg; -{ - xassert (png_ptr != NULL); - image_error ("PNG warning: %s", build_string (msg), Qnil); -} - -/* Memory source for PNG decoding. */ - -struct png_memory_storage -{ - unsigned char *bytes; /* The data */ - size_t len; /* How big is it? */ - int index; /* Where are we? */ -}; - - -/* Function set as reader function when reading PNG image from memory. - PNG_PTR is a pointer to the PNG control structure. Copy LENGTH - bytes from the input to DATA. */ - -static void -png_read_from_memory (png_ptr, data, length) - png_structp png_ptr; - png_bytep data; - png_size_t length; -{ - struct png_memory_storage *tbr - = (struct png_memory_storage *) png_get_io_ptr (png_ptr); - - if (length > tbr->len - tbr->index) - png_error (png_ptr, "Read error"); - - bcopy (tbr->bytes + tbr->index, data, length); - tbr->index = tbr->index + length; -} - -/* Load PNG image IMG for use on frame F. Value is non-zero if - successful. */ - -static int -png_load (f, img) - struct frame *f; - struct image *img; -{ - Lisp_Object file, specified_file; - Lisp_Object specified_data; - int x, y, i; - XImage *ximg, *mask_img = NULL; - struct gcpro gcpro1; - png_struct *png_ptr = NULL; - png_info *info_ptr = NULL, *end_info = NULL; - FILE *volatile fp = NULL; - png_byte sig[8]; - png_byte * volatile pixels = NULL; - png_byte ** volatile rows = NULL; - png_uint_32 width, height; - int bit_depth, color_type, interlace_type; - png_byte channels; - png_uint_32 row_bytes; - int transparent_p; - double screen_gamma; - struct png_memory_storage tbr; /* Data to be read */ - - /* Find out what file to load. */ - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - if (NILP (specified_data)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - /* Open the image file. */ - fp = fopen (SDATA (file), "rb"); - if (!fp) - { - image_error ("Cannot open image file `%s'", file, Qnil); - UNGCPRO; - fclose (fp); - return 0; - } - - /* Check PNG signature. */ - if (fread (sig, 1, sizeof sig, fp) != sizeof sig - || !png_check_sig (sig, sizeof sig)) - { - image_error ("Not a PNG file: `%s'", file, Qnil); - UNGCPRO; - fclose (fp); - return 0; - } - } - else - { - /* Read from memory. */ - tbr.bytes = SDATA (specified_data); - tbr.len = SBYTES (specified_data); - tbr.index = 0; - - /* Check PNG signature. */ - if (tbr.len < sizeof sig - || !png_check_sig (tbr.bytes, sizeof sig)) - { - image_error ("Not a PNG image: `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - - /* Need to skip past the signature. */ - tbr.bytes += sizeof (sig); - } - - /* Initialize read and info structs for PNG lib. */ - png_ptr = png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL, - my_png_error, my_png_warning); - if (!png_ptr) - { - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - info_ptr = png_create_info_struct (png_ptr); - if (!info_ptr) - { - png_destroy_read_struct (&png_ptr, NULL, NULL); - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - end_info = png_create_info_struct (png_ptr); - if (!end_info) - { - png_destroy_read_struct (&png_ptr, &info_ptr, NULL); - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - /* Set error jump-back. We come back here when the PNG library - detects an error. */ - if (setjmp (png_ptr->jmpbuf)) - { - error: - if (png_ptr) - png_destroy_read_struct (&png_ptr, &info_ptr, &end_info); - xfree (pixels); - xfree (rows); - if (fp) fclose (fp); - UNGCPRO; - return 0; - } - - /* Read image info. */ - if (!NILP (specified_data)) - png_set_read_fn (png_ptr, (void *) &tbr, png_read_from_memory); - else - png_init_io (png_ptr, fp); - - png_set_sig_bytes (png_ptr, sizeof sig); - png_read_info (png_ptr, info_ptr); - png_get_IHDR (png_ptr, info_ptr, &width, &height, &bit_depth, &color_type, - &interlace_type, NULL, NULL); - - /* If image contains simply transparency data, we prefer to - construct a clipping mask. */ - if (png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS)) - transparent_p = 1; - else - transparent_p = 0; - - /* This function is easier to write if we only have to handle - one data format: RGB or RGBA with 8 bits per channel. Let's - transform other formats into that format. */ - - /* Strip more than 8 bits per channel. */ - if (bit_depth == 16) - png_set_strip_16 (png_ptr); - - /* Expand data to 24 bit RGB, or 8 bit grayscale, with alpha channel - if available. */ - png_set_expand (png_ptr); - - /* Convert grayscale images to RGB. */ - if (color_type == PNG_COLOR_TYPE_GRAY - || color_type == PNG_COLOR_TYPE_GRAY_ALPHA) - png_set_gray_to_rgb (png_ptr); - - screen_gamma = (f->gamma ? 1 / f->gamma / 0.45455 : 2.2); - -#if 0 /* Avoid double gamma correction for PNG images. */ - { /* Tell the PNG lib to handle gamma correction for us. */ - int intent; - double image_gamma; -#if defined(PNG_READ_sRGB_SUPPORTED) || defined(PNG_WRITE_sRGB_SUPPORTED) - if (png_get_sRGB (png_ptr, info_ptr, &intent)) - /* The libpng documentation says this is right in this case. */ - png_set_gamma (png_ptr, screen_gamma, 0.45455); - else -#endif - if (png_get_gAMA (png_ptr, info_ptr, &image_gamma)) - /* Image contains gamma information. */ - png_set_gamma (png_ptr, screen_gamma, image_gamma); - else - /* Use the standard default for the image gamma. */ - png_set_gamma (png_ptr, screen_gamma, 0.45455); - } -#endif /* if 0 */ - - /* Handle alpha channel by combining the image with a background - color. Do this only if a real alpha channel is supplied. For - simple transparency, we prefer a clipping mask. */ - if (!transparent_p) - { - png_color_16 *image_bg; - Lisp_Object specified_bg - = image_spec_value (img->spec, QCbackground, NULL); - - if (STRINGP (specified_bg)) - /* The user specified `:background', use that. */ - { - XColor color; - if (x_defined_color (f, SDATA (specified_bg), &color, 0)) - { - png_color_16 user_bg; - - bzero (&user_bg, sizeof user_bg); - user_bg.red = color.red; - user_bg.green = color.green; - user_bg.blue = color.blue; - - png_set_background (png_ptr, &user_bg, - PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); - } - } - else if (png_get_bKGD (png_ptr, info_ptr, &image_bg)) - /* Image contains a background color with which to - combine the image. */ - png_set_background (png_ptr, image_bg, - PNG_BACKGROUND_GAMMA_FILE, 1, 1.0); - else - { - /* Image does not contain a background color with which - to combine the image data via an alpha channel. Use - the frame's background instead. */ - XColor color; - Colormap cmap; - png_color_16 frame_background; - - cmap = FRAME_X_COLORMAP (f); - color.pixel = FRAME_BACKGROUND_PIXEL (f); - x_query_color (f, &color); - - bzero (&frame_background, sizeof frame_background); - frame_background.red = color.red; - frame_background.green = color.green; - frame_background.blue = color.blue; - - png_set_background (png_ptr, &frame_background, - PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); - } - } - - /* Update info structure. */ - png_read_update_info (png_ptr, info_ptr); - - /* Get number of channels. Valid values are 1 for grayscale images - and images with a palette, 2 for grayscale images with transparency - information (alpha channel), 3 for RGB images, and 4 for RGB - images with alpha channel, i.e. RGBA. If conversions above were - sufficient we should only have 3 or 4 channels here. */ - channels = png_get_channels (png_ptr, info_ptr); - xassert (channels == 3 || channels == 4); - - /* Number of bytes needed for one row of the image. */ - row_bytes = png_get_rowbytes (png_ptr, info_ptr); - - /* Allocate memory for the image. */ - pixels = (png_byte *) xmalloc (row_bytes * height * sizeof *pixels); - rows = (png_byte **) xmalloc (height * sizeof *rows); - for (i = 0; i < height; ++i) - rows[i] = pixels + i * row_bytes; - - /* Read the entire image. */ - png_read_image (png_ptr, rows); - png_read_end (png_ptr, info_ptr); - if (fp) - { - fclose (fp); - fp = NULL; - } - - /* Create the X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, - &img->pixmap)) - goto error; - - /* Create an image and pixmap serving as mask if the PNG image - contains an alpha channel. */ - if (channels == 4 - && !transparent_p - && !x_create_x_image_and_pixmap (f, width, height, 1, - &mask_img, &img->mask)) - { - x_destroy_x_image (ximg); - XFreePixmap (FRAME_X_DISPLAY (f), img->pixmap); - img->pixmap = None; - goto error; - } - - /* Fill the X image and mask from PNG data. */ - init_color_table (); - - for (y = 0; y < height; ++y) - { - png_byte *p = rows[y]; - - for (x = 0; x < width; ++x) - { - unsigned r, g, b; - - r = *p++ << 8; - g = *p++ << 8; - b = *p++ << 8; - XPutPixel (ximg, x, y, lookup_rgb_color (f, r, g, b)); - - /* An alpha channel, aka mask channel, associates variable - transparency with an image. Where other image formats - support binary transparency---fully transparent or fully - opaque---PNG allows up to 254 levels of partial transparency. - The PNG library implements partial transparency by combining - the image with a specified background color. - - I'm not sure how to handle this here nicely: because the - background on which the image is displayed may change, for - real alpha channel support, it would be necessary to create - a new image for each possible background. - - What I'm doing now is that a mask is created if we have - boolean transparency information. Otherwise I'm using - the frame's background color to combine the image with. */ - - if (channels == 4) - { - if (mask_img) - XPutPixel (mask_img, x, y, *p > 0); - ++p; - } - } - } - - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - /* Set IMG's background color from the PNG image, unless the user - overrode it. */ - { - png_color_16 *bg; - if (png_get_bKGD (png_ptr, info_ptr, &bg)) - { - img->background = lookup_rgb_color (f, bg->red, bg->green, bg->blue); - img->background_valid = 1; - } - } - - /* Remember colors allocated for this image. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); - - /* Clean up. */ - png_destroy_read_struct (&png_ptr, &info_ptr, &end_info); - xfree (rows); - xfree (pixels); - - img->width = width; - img->height = height; - - /* Maybe fill in the background field while we have ximg handy. */ - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap, then free the X image and its buffer. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - - /* Same for the mask. */ - if (mask_img) - { - /* Fill in the background_transparent field while we have the mask - handy. */ - image_background_transparent (img, f, mask_img); - - x_put_x_image (f, mask_img, img->mask, img->width, img->height); - x_destroy_x_image (mask_img); - } - - UNGCPRO; - return 1; -} - -#endif /* HAVE_PNG != 0 */ - - - -/*********************************************************************** - JPEG - ***********************************************************************/ - -#if HAVE_JPEG - -/* Work around a warning about HAVE_STDLIB_H being redefined in - jconfig.h. */ -#ifdef HAVE_STDLIB_H -#define HAVE_STDLIB_H_1 -#undef HAVE_STDLIB_H -#endif /* HAVE_STLIB_H */ - -#include <jpeglib.h> -#include <jerror.h> -#include <setjmp.h> - -#ifdef HAVE_STLIB_H_1 -#define HAVE_STDLIB_H 1 -#endif - -static int jpeg_image_p P_ ((Lisp_Object object)); -static int jpeg_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `jpeg' identifying images of this type. */ - -Lisp_Object Qjpeg; - -/* Indices of image specification fields in gs_format, below. */ - -enum jpeg_keyword_index -{ - JPEG_TYPE, - JPEG_DATA, - JPEG_FILE, - JPEG_ASCENT, - JPEG_MARGIN, - JPEG_RELIEF, - JPEG_ALGORITHM, - JPEG_HEURISTIC_MASK, - JPEG_MASK, - JPEG_BACKGROUND, - JPEG_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword jpeg_format[JPEG_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversions", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `jpeg'. */ - -static struct image_type jpeg_type = -{ - &Qjpeg, - jpeg_image_p, - jpeg_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid JPEG image specification. */ - -static int -jpeg_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[JPEG_LAST]; - - bcopy (jpeg_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, JPEG_LAST, Qjpeg)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1; -} - - -struct my_jpeg_error_mgr -{ - struct jpeg_error_mgr pub; - jmp_buf setjmp_buffer; -}; - - -static void -my_error_exit (cinfo) - j_common_ptr cinfo; -{ - struct my_jpeg_error_mgr *mgr = (struct my_jpeg_error_mgr *) cinfo->err; - longjmp (mgr->setjmp_buffer, 1); -} - - -/* Init source method for JPEG data source manager. Called by - jpeg_read_header() before any data is actually read. See - libjpeg.doc from the JPEG lib distribution. */ - -static void -our_init_source (cinfo) - j_decompress_ptr cinfo; -{ -} - - -/* Fill input buffer method for JPEG data source manager. Called - whenever more data is needed. We read the whole image in one step, - so this only adds a fake end of input marker at the end. */ - -static boolean -our_fill_input_buffer (cinfo) - j_decompress_ptr cinfo; -{ - /* Insert a fake EOI marker. */ - struct jpeg_source_mgr *src = cinfo->src; - static JOCTET buffer[2]; - - buffer[0] = (JOCTET) 0xFF; - buffer[1] = (JOCTET) JPEG_EOI; - - src->next_input_byte = buffer; - src->bytes_in_buffer = 2; - return TRUE; -} - - -/* Method to skip over NUM_BYTES bytes in the image data. CINFO->src - is the JPEG data source manager. */ - -static void -our_skip_input_data (cinfo, num_bytes) - j_decompress_ptr cinfo; - long num_bytes; -{ - struct jpeg_source_mgr *src = (struct jpeg_source_mgr *) cinfo->src; - - if (src) - { - if (num_bytes > src->bytes_in_buffer) - ERREXIT (cinfo, JERR_INPUT_EOF); - - src->bytes_in_buffer -= num_bytes; - src->next_input_byte += num_bytes; - } -} - - -/* Method to terminate data source. Called by - jpeg_finish_decompress() after all data has been processed. */ - -static void -our_term_source (cinfo) - j_decompress_ptr cinfo; -{ -} - - -/* Set up the JPEG lib for reading an image from DATA which contains - LEN bytes. CINFO is the decompression info structure created for - reading the image. */ - -static void -jpeg_memory_src (cinfo, data, len) - j_decompress_ptr cinfo; - JOCTET *data; - unsigned int len; -{ - struct jpeg_source_mgr *src; - - if (cinfo->src == NULL) - { - /* First time for this JPEG object? */ - cinfo->src = (struct jpeg_source_mgr *) - (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT, - sizeof (struct jpeg_source_mgr)); - src = (struct jpeg_source_mgr *) cinfo->src; - src->next_input_byte = data; - } - - src = (struct jpeg_source_mgr *) cinfo->src; - src->init_source = our_init_source; - src->fill_input_buffer = our_fill_input_buffer; - src->skip_input_data = our_skip_input_data; - src->resync_to_restart = jpeg_resync_to_restart; /* Use default method. */ - src->term_source = our_term_source; - src->bytes_in_buffer = len; - src->next_input_byte = data; -} - - -/* Load image IMG for use on frame F. Patterned after example.c - from the JPEG lib. */ - -static int -jpeg_load (f, img) - struct frame *f; - struct image *img; -{ - struct jpeg_decompress_struct cinfo; - struct my_jpeg_error_mgr mgr; - Lisp_Object file, specified_file; - Lisp_Object specified_data; - FILE * volatile fp = NULL; - JSAMPARRAY buffer; - int row_stride, x, y; - XImage *ximg = NULL; - int rc; - unsigned long *colors; - int width, height; - struct gcpro gcpro1; - - /* Open the JPEG file. */ - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - if (NILP (specified_data)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - fp = fopen (SDATA (file), "r"); - if (fp == NULL) - { - image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; - return 0; - } - } - - /* Customize libjpeg's error handling to call my_error_exit when an - error is detected. This function will perform a longjmp. */ - cinfo.err = jpeg_std_error (&mgr.pub); - mgr.pub.error_exit = my_error_exit; - - if ((rc = setjmp (mgr.setjmp_buffer)) != 0) - { - if (rc == 1) - { - /* Called from my_error_exit. Display a JPEG error. */ - char buffer[JMSG_LENGTH_MAX]; - cinfo.err->format_message ((j_common_ptr) &cinfo, buffer); - image_error ("Error reading JPEG image `%s': %s", img->spec, - build_string (buffer)); - } - - /* Close the input file and destroy the JPEG object. */ - if (fp) - fclose ((FILE *) fp); - jpeg_destroy_decompress (&cinfo); - - /* If we already have an XImage, free that. */ - x_destroy_x_image (ximg); - - /* Free pixmap and colors. */ - x_clear_image (f, img); - - UNGCPRO; - return 0; - } - - /* Create the JPEG decompression object. Let it read from fp. - Read the JPEG image header. */ - jpeg_create_decompress (&cinfo); - - if (NILP (specified_data)) - jpeg_stdio_src (&cinfo, (FILE *) fp); - else - jpeg_memory_src (&cinfo, SDATA (specified_data), - SBYTES (specified_data)); - - jpeg_read_header (&cinfo, TRUE); - - /* Customize decompression so that color quantization will be used. - Start decompression. */ - cinfo.quantize_colors = TRUE; - jpeg_start_decompress (&cinfo); - width = img->width = cinfo.output_width; - height = img->height = cinfo.output_height; - - /* Create X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - longjmp (mgr.setjmp_buffer, 2); - - /* Allocate colors. When color quantization is used, - cinfo.actual_number_of_colors has been set with the number of - colors generated, and cinfo.colormap is a two-dimensional array - of color indices in the range 0..cinfo.actual_number_of_colors. - No more than 255 colors will be generated. */ - { - int i, ir, ig, ib; - - if (cinfo.out_color_components > 2) - ir = 0, ig = 1, ib = 2; - else if (cinfo.out_color_components > 1) - ir = 0, ig = 1, ib = 0; - else - ir = 0, ig = 0, ib = 0; - - /* Use the color table mechanism because it handles colors that - cannot be allocated nicely. Such colors will be replaced with - a default color, and we don't have to care about which colors - can be freed safely, and which can't. */ - init_color_table (); - colors = (unsigned long *) alloca (cinfo.actual_number_of_colors - * sizeof *colors); - - for (i = 0; i < cinfo.actual_number_of_colors; ++i) - { - /* Multiply RGB values with 255 because X expects RGB values - in the range 0..0xffff. */ - int r = cinfo.colormap[ir][i] << 8; - int g = cinfo.colormap[ig][i] << 8; - int b = cinfo.colormap[ib][i] << 8; - colors[i] = lookup_rgb_color (f, r, g, b); - } - - /* Remember those colors actually allocated. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); - } - - /* Read pixels. */ - row_stride = width * cinfo.output_components; - buffer = cinfo.mem->alloc_sarray ((j_common_ptr) &cinfo, JPOOL_IMAGE, - row_stride, 1); - for (y = 0; y < height; ++y) - { - jpeg_read_scanlines (&cinfo, buffer, 1); - for (x = 0; x < cinfo.output_width; ++x) - XPutPixel (ximg, x, y, colors[buffer[0][x]]); - } - - /* Clean up. */ - jpeg_finish_decompress (&cinfo); - jpeg_destroy_decompress (&cinfo); - if (fp) - fclose ((FILE *) fp); - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - UNGCPRO; - return 1; -} - -#endif /* HAVE_JPEG */ - - - -/*********************************************************************** - TIFF - ***********************************************************************/ - -#if HAVE_TIFF - -#include <tiffio.h> - -static int tiff_image_p P_ ((Lisp_Object object)); -static int tiff_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `tiff' identifying images of this type. */ - -Lisp_Object Qtiff; - -/* Indices of image specification fields in tiff_format, below. */ - -enum tiff_keyword_index -{ - TIFF_TYPE, - TIFF_DATA, - TIFF_FILE, - TIFF_ASCENT, - TIFF_MARGIN, - TIFF_RELIEF, - TIFF_ALGORITHM, - TIFF_HEURISTIC_MASK, - TIFF_MASK, - TIFF_BACKGROUND, - TIFF_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword tiff_format[TIFF_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversions", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `tiff'. */ - -static struct image_type tiff_type = -{ - &Qtiff, - tiff_image_p, - tiff_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid TIFF image specification. */ - -static int -tiff_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[TIFF_LAST]; - bcopy (tiff_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, TIFF_LAST, Qtiff)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1; -} - - -/* Reading from a memory buffer for TIFF images Based on the PNG - memory source, but we have to provide a lot of extra functions. - Blah. - - We really only need to implement read and seek, but I am not - convinced that the TIFF library is smart enough not to destroy - itself if we only hand it the function pointers we need to - override. */ - -typedef struct -{ - unsigned char *bytes; - size_t len; - int index; -} -tiff_memory_source; - - -static size_t -tiff_read_from_memory (data, buf, size) - thandle_t data; - tdata_t buf; - tsize_t size; -{ - tiff_memory_source *src = (tiff_memory_source *) data; - - if (size > src->len - src->index) - return (size_t) -1; - bcopy (src->bytes + src->index, buf, size); - src->index += size; - return size; -} - - -static size_t -tiff_write_from_memory (data, buf, size) - thandle_t data; - tdata_t buf; - tsize_t size; -{ - return (size_t) -1; -} - - -static toff_t -tiff_seek_in_memory (data, off, whence) - thandle_t data; - toff_t off; - int whence; -{ - tiff_memory_source *src = (tiff_memory_source *) data; - int idx; - - switch (whence) - { - case SEEK_SET: /* Go from beginning of source. */ - idx = off; - break; - - case SEEK_END: /* Go from end of source. */ - idx = src->len + off; - break; - - case SEEK_CUR: /* Go from current position. */ - idx = src->index + off; - break; - - default: /* Invalid `whence'. */ - return -1; - } - - if (idx > src->len || idx < 0) - return -1; - - src->index = idx; - return src->index; -} - - -static int -tiff_close_memory (data) - thandle_t data; -{ - /* NOOP */ - return 0; -} - - -static int -tiff_mmap_memory (data, pbase, psize) - thandle_t data; - tdata_t *pbase; - toff_t *psize; -{ - /* It is already _IN_ memory. */ - return 0; -} - - -static void -tiff_unmap_memory (data, base, size) - thandle_t data; - tdata_t base; - toff_t size; -{ - /* We don't need to do this. */ -} - - -static toff_t -tiff_size_of_memory (data) - thandle_t data; -{ - return ((tiff_memory_source *) data)->len; -} - - -static void -tiff_error_handler (title, format, ap) - const char *title, *format; - va_list ap; -{ - char buf[512]; - int len; - - len = sprintf (buf, "TIFF error: %s ", title); - vsprintf (buf + len, format, ap); - add_to_log (buf, Qnil, Qnil); -} - - -static void -tiff_warning_handler (title, format, ap) - const char *title, *format; - va_list ap; -{ - char buf[512]; - int len; - - len = sprintf (buf, "TIFF warning: %s ", title); - vsprintf (buf + len, format, ap); - add_to_log (buf, Qnil, Qnil); -} - - -/* Load TIFF image IMG for use on frame F. Value is non-zero if - successful. */ - -static int -tiff_load (f, img) - struct frame *f; - struct image *img; -{ - Lisp_Object file, specified_file; - Lisp_Object specified_data; - TIFF *tiff; - int width, height, x, y; - uint32 *buf; - int rc; - XImage *ximg; - struct gcpro gcpro1; - tiff_memory_source memsrc; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - TIFFSetErrorHandler (tiff_error_handler); - TIFFSetWarningHandler (tiff_warning_handler); - - if (NILP (specified_data)) - { - /* Read from a file */ - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", file, Qnil); - UNGCPRO; - return 0; - } - - /* Try to open the image file. */ - tiff = TIFFOpen (SDATA (file), "r"); - if (tiff == NULL) - { - image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; - return 0; - } - } - else - { - /* Memory source! */ - memsrc.bytes = SDATA (specified_data); - memsrc.len = SBYTES (specified_data); - memsrc.index = 0; - - tiff = TIFFClientOpen ("memory_source", "r", &memsrc, - (TIFFReadWriteProc) tiff_read_from_memory, - (TIFFReadWriteProc) tiff_write_from_memory, - tiff_seek_in_memory, - tiff_close_memory, - tiff_size_of_memory, - tiff_mmap_memory, - tiff_unmap_memory); - - if (!tiff) - { - image_error ("Cannot open memory source for `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - } - - /* Get width and height of the image, and allocate a raster buffer - of width x height 32-bit values. */ - TIFFGetField (tiff, TIFFTAG_IMAGEWIDTH, &width); - TIFFGetField (tiff, TIFFTAG_IMAGELENGTH, &height); - buf = (uint32 *) xmalloc (width * height * sizeof *buf); - - rc = TIFFReadRGBAImage (tiff, width, height, buf, 0); - TIFFClose (tiff); - if (!rc) - { - image_error ("Error reading TIFF image `%s'", img->spec, Qnil); - xfree (buf); - UNGCPRO; - return 0; - } - - /* Create the X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - { - xfree (buf); - UNGCPRO; - return 0; - } - - /* Initialize the color table. */ - init_color_table (); - - /* Process the pixel raster. Origin is in the lower-left corner. */ - for (y = 0; y < height; ++y) - { - uint32 *row = buf + y * width; - - for (x = 0; x < width; ++x) - { - uint32 abgr = row[x]; - int r = TIFFGetR (abgr) << 8; - int g = TIFFGetG (abgr) << 8; - int b = TIFFGetB (abgr) << 8; - XPutPixel (ximg, x, height - 1 - y, lookup_rgb_color (f, r, g, b)); - } - } - - /* Remember the colors allocated for the image. Free the color table. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); - - img->width = width; - img->height = height; - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap, then free the X image and its buffer. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - xfree (buf); - - UNGCPRO; - return 1; -} - -#endif /* HAVE_TIFF != 0 */ - - - -/*********************************************************************** - GIF - ***********************************************************************/ - -#if HAVE_GIF - -#include <gif_lib.h> - -static int gif_image_p P_ ((Lisp_Object object)); -static int gif_load P_ ((struct frame *f, struct image *img)); - -/* The symbol `gif' identifying images of this type. */ - -Lisp_Object Qgif; - -/* Indices of image specification fields in gif_format, below. */ - -enum gif_keyword_index -{ - GIF_TYPE, - GIF_DATA, - GIF_FILE, - GIF_ASCENT, - GIF_MARGIN, - GIF_RELIEF, - GIF_ALGORITHM, - GIF_HEURISTIC_MASK, - GIF_MASK, - GIF_IMAGE, - GIF_BACKGROUND, - GIF_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword gif_format[GIF_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":data", IMAGE_STRING_VALUE, 0}, - {":file", IMAGE_STRING_VALUE, 0}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":image", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `gif'. */ - -static struct image_type gif_type = -{ - &Qgif, - gif_image_p, - gif_load, - x_clear_image, - NULL -}; - - -/* Return non-zero if OBJECT is a valid GIF image specification. */ - -static int -gif_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[GIF_LAST]; - bcopy (gif_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, GIF_LAST, Qgif)) - return 0; - - /* Must specify either the :data or :file keyword. */ - return fmt[GIF_FILE].count + fmt[GIF_DATA].count == 1; -} - - -/* Reading a GIF image from memory - Based on the PNG memory stuff to a certain extent. */ - -typedef struct -{ - unsigned char *bytes; - size_t len; - int index; -} -gif_memory_source; - - -/* Make the current memory source available to gif_read_from_memory. - It's done this way because not all versions of libungif support - a UserData field in the GifFileType structure. */ -static gif_memory_source *current_gif_memory_src; - -static int -gif_read_from_memory (file, buf, len) - GifFileType *file; - GifByteType *buf; - int len; -{ - gif_memory_source *src = current_gif_memory_src; - - if (len > src->len - src->index) - return -1; - - bcopy (src->bytes + src->index, buf, len); - src->index += len; - return len; -} - - -/* Load GIF image IMG for use on frame F. Value is non-zero if - successful. */ - -static int -gif_load (f, img) - struct frame *f; - struct image *img; -{ - Lisp_Object file, specified_file; - Lisp_Object specified_data; - int rc, width, height, x, y, i; - XImage *ximg; - ColorMapObject *gif_color_map; - unsigned long pixel_colors[256]; - GifFileType *gif; - struct gcpro gcpro1; - Lisp_Object image; - int ino, image_left, image_top, image_width, image_height; - gif_memory_source memsrc; - unsigned char *raster; - - specified_file = image_spec_value (img->spec, QCfile, NULL); - specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); - - if (NILP (specified_data)) - { - file = x_find_image_file (specified_file); - if (!STRINGP (file)) - { - image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; - return 0; - } - - /* Open the GIF file. */ - gif = DGifOpenFileName (SDATA (file)); - if (gif == NULL) - { - image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; - return 0; - } - } - else - { - /* Read from memory! */ - current_gif_memory_src = &memsrc; - memsrc.bytes = SDATA (specified_data); - memsrc.len = SBYTES (specified_data); - memsrc.index = 0; - - gif = DGifOpen (&memsrc, gif_read_from_memory); - if (!gif) - { - image_error ("Cannot open memory source `%s'", img->spec, Qnil); - UNGCPRO; - return 0; - } - } - - /* Read entire contents. */ - rc = DGifSlurp (gif); - if (rc == GIF_ERROR) - { - image_error ("Error reading `%s'", img->spec, Qnil); - DGifCloseFile (gif); - UNGCPRO; - return 0; - } - - image = image_spec_value (img->spec, QCindex, NULL); - ino = INTEGERP (image) ? XFASTINT (image) : 0; - if (ino >= gif->ImageCount) - { - image_error ("Invalid image number `%s' in image `%s'", - image, img->spec); - DGifCloseFile (gif); - UNGCPRO; - return 0; - } - - width = img->width = max (gif->SWidth, gif->Image.Left + gif->Image.Width); - height = img->height = max (gif->SHeight, gif->Image.Top + gif->Image.Height); - - /* Create the X image and pixmap. */ - if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) - { - DGifCloseFile (gif); - UNGCPRO; - return 0; - } - - /* Allocate colors. */ - gif_color_map = gif->SavedImages[ino].ImageDesc.ColorMap; - if (!gif_color_map) - gif_color_map = gif->SColorMap; - init_color_table (); - bzero (pixel_colors, sizeof pixel_colors); - - for (i = 0; i < gif_color_map->ColorCount; ++i) - { - int r = gif_color_map->Colors[i].Red << 8; - int g = gif_color_map->Colors[i].Green << 8; - int b = gif_color_map->Colors[i].Blue << 8; - pixel_colors[i] = lookup_rgb_color (f, r, g, b); - } - - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); - - /* Clear the part of the screen image that are not covered by - the image from the GIF file. Full animated GIF support - requires more than can be done here (see the gif89 spec, - disposal methods). Let's simply assume that the part - not covered by a sub-image is in the frame's background color. */ - image_top = gif->SavedImages[ino].ImageDesc.Top; - image_left = gif->SavedImages[ino].ImageDesc.Left; - image_width = gif->SavedImages[ino].ImageDesc.Width; - image_height = gif->SavedImages[ino].ImageDesc.Height; - - for (y = 0; y < image_top; ++y) - for (x = 0; x < width; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - - for (y = image_top + image_height; y < height; ++y) - for (x = 0; x < width; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - - for (y = image_top; y < image_top + image_height; ++y) - { - for (x = 0; x < image_left; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - for (x = image_left + image_width; x < width; ++x) - XPutPixel (ximg, x, y, FRAME_BACKGROUND_PIXEL (f)); - } - - /* Read the GIF image into the X image. We use a local variable - `raster' here because RasterBits below is a char *, and invites - problems with bytes >= 0x80. */ - raster = (unsigned char *) gif->SavedImages[ino].RasterBits; - - if (gif->SavedImages[ino].ImageDesc.Interlace) - { - static int interlace_start[] = {0, 4, 2, 1}; - static int interlace_increment[] = {8, 8, 4, 2}; - int pass; - int row = interlace_start[0]; - - pass = 0; - - for (y = 0; y < image_height; y++) - { - if (row >= image_height) - { - row = interlace_start[++pass]; - while (row >= image_height) - row = interlace_start[++pass]; - } - - for (x = 0; x < image_width; x++) - { - int i = raster[(y * image_width) + x]; - XPutPixel (ximg, x + image_left, row + image_top, - pixel_colors[i]); - } - - row += interlace_increment[pass]; - } - } - else - { - for (y = 0; y < image_height; ++y) - for (x = 0; x < image_width; ++x) - { - int i = raster[y * image_width + x]; - XPutPixel (ximg, x + image_left, y + image_top, pixel_colors[i]); - } - } - - DGifCloseFile (gif); - - /* Maybe fill in the background field while we have ximg handy. */ - if (NILP (image_spec_value (img->spec, QCbackground, NULL))) - IMAGE_BACKGROUND (img, f, ximg); - - /* Put the image into the pixmap, then free the X image and its buffer. */ - x_put_x_image (f, ximg, img->pixmap, width, height); - x_destroy_x_image (ximg); - - UNGCPRO; - return 1; -} - -#endif /* HAVE_GIF != 0 */ - - - -/*********************************************************************** - Ghostscript - ***********************************************************************/ - -static int gs_image_p P_ ((Lisp_Object object)); -static int gs_load P_ ((struct frame *f, struct image *img)); -static void gs_clear_image P_ ((struct frame *f, struct image *img)); - -/* The symbol `postscript' identifying images of this type. */ - -Lisp_Object Qpostscript; - -/* Keyword symbols. */ - -Lisp_Object QCloader, QCbounding_box, QCpt_width, QCpt_height; - -/* Indices of image specification fields in gs_format, below. */ - -enum gs_keyword_index -{ - GS_TYPE, - GS_PT_WIDTH, - GS_PT_HEIGHT, - GS_FILE, - GS_LOADER, - GS_BOUNDING_BOX, - GS_ASCENT, - GS_MARGIN, - GS_RELIEF, - GS_ALGORITHM, - GS_HEURISTIC_MASK, - GS_MASK, - GS_BACKGROUND, - GS_LAST -}; - -/* Vector of image_keyword structures describing the format - of valid user-defined image specifications. */ - -static struct image_keyword gs_format[GS_LAST] = -{ - {":type", IMAGE_SYMBOL_VALUE, 1}, - {":pt-width", IMAGE_POSITIVE_INTEGER_VALUE, 1}, - {":pt-height", IMAGE_POSITIVE_INTEGER_VALUE, 1}, - {":file", IMAGE_STRING_VALUE, 1}, - {":loader", IMAGE_FUNCTION_VALUE, 0}, - {":bounding-box", IMAGE_DONT_CHECK_VALUE_TYPE, 1}, - {":ascent", IMAGE_ASCENT_VALUE, 0}, - {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0}, - {":relief", IMAGE_INTEGER_VALUE, 0}, - {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, - {":background", IMAGE_STRING_OR_NIL_VALUE, 0} -}; - -/* Structure describing the image type `ghostscript'. */ - -static struct image_type gs_type = -{ - &Qpostscript, - gs_image_p, - gs_load, - gs_clear_image, - NULL -}; - - -/* Free X resources of Ghostscript image IMG which is used on frame F. */ - -static void -gs_clear_image (f, img) - struct frame *f; - struct image *img; -{ - /* IMG->data.ptr_val may contain a recorded colormap. */ - xfree (img->data.ptr_val); - x_clear_image (f, img); -} - - -/* Return non-zero if OBJECT is a valid Ghostscript image - specification. */ - -static int -gs_image_p (object) - Lisp_Object object; -{ - struct image_keyword fmt[GS_LAST]; - Lisp_Object tem; - int i; - - bcopy (gs_format, fmt, sizeof fmt); - - if (!parse_image_spec (object, fmt, GS_LAST, Qpostscript)) - return 0; - - /* Bounding box must be a list or vector containing 4 integers. */ - tem = fmt[GS_BOUNDING_BOX].value; - if (CONSP (tem)) - { - for (i = 0; i < 4; ++i, tem = XCDR (tem)) - if (!CONSP (tem) || !INTEGERP (XCAR (tem))) - return 0; - if (!NILP (tem)) - return 0; - } - else if (VECTORP (tem)) - { - if (XVECTOR (tem)->size != 4) - return 0; - for (i = 0; i < 4; ++i) - if (!INTEGERP (XVECTOR (tem)->contents[i])) - return 0; - } - else - return 0; - - return 1; -} - - -/* Load Ghostscript image IMG for use on frame F. Value is non-zero - if successful. */ - -static int -gs_load (f, img) - struct frame *f; - struct image *img; -{ - char buffer[100]; - Lisp_Object window_and_pixmap_id = Qnil, loader, pt_height, pt_width; - struct gcpro gcpro1, gcpro2; - Lisp_Object frame; - double in_width, in_height; - Lisp_Object pixel_colors = Qnil; - - /* Compute pixel size of pixmap needed from the given size in the - image specification. Sizes in the specification are in pt. 1 pt - = 1/72 in, xdpi and ydpi are stored in the frame's X display - info. */ - pt_width = image_spec_value (img->spec, QCpt_width, NULL); - in_width = XFASTINT (pt_width) / 72.0; - img->width = in_width * FRAME_X_DISPLAY_INFO (f)->resx; - pt_height = image_spec_value (img->spec, QCpt_height, NULL); - in_height = XFASTINT (pt_height) / 72.0; - img->height = in_height * FRAME_X_DISPLAY_INFO (f)->resy; - - /* Create the pixmap. */ - xassert (img->pixmap == None); - img->pixmap = XCreatePixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - img->width, img->height, - DefaultDepthOfScreen (FRAME_X_SCREEN (f))); - - if (!img->pixmap) - { - image_error ("Unable to create pixmap for `%s'", img->spec, Qnil); - return 0; - } - - /* Call the loader to fill the pixmap. It returns a process object - if successful. We do not record_unwind_protect here because - other places in redisplay like calling window scroll functions - don't either. Let the Lisp loader use `unwind-protect' instead. */ - GCPRO2 (window_and_pixmap_id, pixel_colors); - - sprintf (buffer, "%lu %lu", - (unsigned long) FRAME_X_WINDOW (f), - (unsigned long) img->pixmap); - window_and_pixmap_id = build_string (buffer); - - sprintf (buffer, "%lu %lu", - FRAME_FOREGROUND_PIXEL (f), - FRAME_BACKGROUND_PIXEL (f)); - pixel_colors = build_string (buffer); - - XSETFRAME (frame, f); - loader = image_spec_value (img->spec, QCloader, NULL); - if (NILP (loader)) - loader = intern ("gs-load-image"); - - img->data.lisp_val = call6 (loader, frame, img->spec, - make_number (img->width), - make_number (img->height), - window_and_pixmap_id, - pixel_colors); - UNGCPRO; - return PROCESSP (img->data.lisp_val); -} - - -/* Kill the Ghostscript process that was started to fill PIXMAP on - frame F. Called from XTread_socket when receiving an event - telling Emacs that Ghostscript has finished drawing. */ - -void -x_kill_gs_process (pixmap, f) - Pixmap pixmap; - struct frame *f; -{ - struct image_cache *c = FRAME_X_IMAGE_CACHE (f); - int class, i; - struct image *img; - - /* Find the image containing PIXMAP. */ - for (i = 0; i < c->used; ++i) - if (c->images[i]->pixmap == pixmap) - break; - - /* Should someone in between have cleared the image cache, for - instance, give up. */ - if (i == c->used) - return; - - /* Kill the GS process. We should have found PIXMAP in the image - cache and its image should contain a process object. */ - img = c->images[i]; - xassert (PROCESSP (img->data.lisp_val)); - Fkill_process (img->data.lisp_val, Qnil); - img->data.lisp_val = Qnil; - - /* On displays with a mutable colormap, figure out the colors - allocated for the image by looking at the pixels of an XImage for - img->pixmap. */ - class = FRAME_X_VISUAL (f)->class; - if (class != StaticColor && class != StaticGray && class != TrueColor) - { - XImage *ximg; - - BLOCK_INPUT; - - /* Try to get an XImage for img->pixmep. */ - ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap, - 0, 0, img->width, img->height, ~0, ZPixmap); - if (ximg) - { - int x, y; - - /* Initialize the color table. */ - init_color_table (); - - /* For each pixel of the image, look its color up in the - color table. After having done so, the color table will - contain an entry for each color used by the image. */ - for (y = 0; y < img->height; ++y) - for (x = 0; x < img->width; ++x) - { - unsigned long pixel = XGetPixel (ximg, x, y); - lookup_pixel_color (f, pixel); - } - - /* Record colors in the image. Free color table and XImage. */ - img->colors = colors_in_color_table (&img->ncolors); - free_color_table (); - XDestroyImage (ximg); - -#if 0 /* This doesn't seem to be the case. If we free the colors - here, we get a BadAccess later in x_clear_image when - freeing the colors. */ - /* We have allocated colors once, but Ghostscript has also - allocated colors on behalf of us. So, to get the - reference counts right, free them once. */ - if (img->ncolors) - x_free_colors (f, img->colors, img->ncolors); -#endif - } - else - image_error ("Cannot get X image of `%s'; colors will not be freed", - img->spec, Qnil); - - UNBLOCK_INPUT; - } - - /* Now that we have the pixmap, compute mask and transform the - image if requested. */ - BLOCK_INPUT; - postprocess_image (f, img); - UNBLOCK_INPUT; -} - - - -/*********************************************************************** Window properties ***********************************************************************/ @@ -10925,8 +5400,6 @@ staticpro (&Qsuppress_icon); Qundefined_color = intern ("undefined-color"); staticpro (&Qundefined_color); - Qcenter = intern ("center"); - staticpro (&Qcenter); Qcompound_text = intern ("compound-text"); staticpro (&Qcompound_text); Qcancel_timer = intern ("cancel-timer"); @@ -10938,36 +5411,11 @@ = Fcons (Fcons (Qdisplay, Qt), Vtext_property_default_nonsticky); - Qlaplace = intern ("laplace"); - staticpro (&Qlaplace); - Qemboss = intern ("emboss"); - staticpro (&Qemboss); - Qedge_detection = intern ("edge-detection"); - staticpro (&Qedge_detection); - Qheuristic = intern ("heuristic"); - staticpro (&Qheuristic); - QCmatrix = intern (":matrix"); - staticpro (&QCmatrix); - QCcolor_adjustment = intern (":color-adjustment"); - staticpro (&QCcolor_adjustment); - QCmask = intern (":mask"); - staticpro (&QCmask); - Fput (Qundefined_color, Qerror_conditions, Fcons (Qundefined_color, Fcons (Qerror, Qnil))); Fput (Qundefined_color, Qerror_message, build_string ("Undefined color")); - DEFVAR_BOOL ("cross-disabled-images", &cross_disabled_images, - doc: /* Non-nil means always draw a cross over disabled images. -Disabled images are those having an `:conversion disabled' property. -A cross is always drawn on black & white displays. */); - cross_disabled_images = 0; - - DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path, - doc: /* List of directories to search for window system bitmap files. */); - Vx_bitmap_file_path = decode_env_path ((char *) 0, PATH_BITMAPS); - DEFVAR_LISP ("x-pointer-shape", &Vx_pointer_shape, doc: /* The shape of the pointer when over text. Changing the value does not affect existing frames @@ -11046,13 +5494,6 @@ Chinese, Japanese, and Korean. */); Vx_pixel_size_width_font_regexp = Qnil; - DEFVAR_LISP ("image-cache-eviction-delay", &Vimage_cache_eviction_delay, - doc: /* Time after which cached images are removed from the cache. -When an image has not been displayed this many seconds, remove it -from the image cache. Value must be an integer or nil with nil -meaning don't clear the cache. */); - Vimage_cache_eviction_delay = make_number (30 * 60); - #ifdef USE_X_TOOLKIT Fprovide (intern ("x-toolkit"), Qnil); #ifdef USE_MOTIF @@ -11121,65 +5562,6 @@ set_frame_fontset_func = x_set_font; check_window_system_func = check_x; - /* Images. */ - Qxbm = intern ("xbm"); - staticpro (&Qxbm); - QCconversion = intern (":conversion"); - staticpro (&QCconversion); - QCheuristic_mask = intern (":heuristic-mask"); - staticpro (&QCheuristic_mask); - QCcolor_symbols = intern (":color-symbols"); - staticpro (&QCcolor_symbols); - QCascent = intern (":ascent"); - staticpro (&QCascent); - QCmargin = intern (":margin"); - staticpro (&QCmargin); - QCrelief = intern (":relief"); - staticpro (&QCrelief); - Qpostscript = intern ("postscript"); - staticpro (&Qpostscript); - QCloader = intern (":loader"); - staticpro (&QCloader); - QCbounding_box = intern (":bounding-box"); - staticpro (&QCbounding_box); - QCpt_width = intern (":pt-width"); - staticpro (&QCpt_width); - QCpt_height = intern (":pt-height"); - staticpro (&QCpt_height); - QCindex = intern (":index"); - staticpro (&QCindex); - Qpbm = intern ("pbm"); - staticpro (&Qpbm); - -#if HAVE_XPM - Qxpm = intern ("xpm"); - staticpro (&Qxpm); -#endif - -#if HAVE_JPEG - Qjpeg = intern ("jpeg"); - staticpro (&Qjpeg); -#endif - -#if HAVE_TIFF - Qtiff = intern ("tiff"); - staticpro (&Qtiff); -#endif - -#if HAVE_GIF - Qgif = intern ("gif"); - staticpro (&Qgif); -#endif - -#if HAVE_PNG - Qpng = intern ("png"); - staticpro (&Qpng); -#endif - - defsubr (&Sclear_image_cache); - defsubr (&Simage_size); - defsubr (&Simage_mask_p); - hourglass_atimer = NULL; hourglass_shown_p = 0; @@ -11198,38 +5580,6 @@ #endif } - -void -init_xfns () -{ - image_types = NULL; - Vimage_types = Qnil; - - define_image_type (&xbm_type); - define_image_type (&gs_type); - define_image_type (&pbm_type); - -#if HAVE_XPM - define_image_type (&xpm_type); -#endif - -#if HAVE_JPEG - define_image_type (&jpeg_type); -#endif - -#if HAVE_TIFF - define_image_type (&tiff_type); -#endif - -#if HAVE_GIF - define_image_type (&gif_type); -#endif - -#if HAVE_PNG - define_image_type (&png_type); -#endif -} - #endif /* HAVE_X_WINDOWS */ /* arch-tag: 55040d02-5485-4d58-8b22-95a7a05f3288
--- a/src/xterm.h Thu Mar 11 02:31:12 2004 +0000 +++ b/src/xterm.h Tue Mar 16 20:27:22 2004 +0000 @@ -1028,15 +1028,6 @@ extern struct x_display_info * check_x_display_info P_ ((Lisp_Object frame)); extern int have_menus_p P_ ((void)); -extern int x_bitmap_height P_ ((struct frame *, int)); -extern int x_bitmap_width P_ ((struct frame *, int)); -extern int x_bitmap_pixmap P_ ((struct frame *, int)); -extern void x_reference_bitmap P_ ((struct frame *, int)); -extern int x_create_bitmap_from_data P_ ((struct frame *, char *, - unsigned int, unsigned int)); -extern int x_create_bitmap_from_file P_ ((struct frame *, Lisp_Object)); -extern void x_destroy_bitmap P_ ((struct frame *, int)); -extern int x_create_bitmap_mask P_ ((struct frame * , int)); #ifdef USE_GTK extern int xg_set_icon P_ ((struct frame *, Lisp_Object));