/[emacs]/emacs/lisp/gnus/gnus-ems.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-ems.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.15.2.2 by miles, Tue Oct 14 23:34:50 2003 UTC revision 1.15.2.3 by miles, Thu Sep 16 00:12:15 2004 UTC
# Line 1  Line 1 
1  ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen  ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
2  ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000  ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
3  ;;        Free Software Foundation, Inc.  ;;        Free Software Foundation, Inc.
4    
5  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
# Line 45  Line 45 
45  (eval-and-compile  (eval-and-compile
46    (autoload 'gnus-xmas-define "gnus-xmas")    (autoload 'gnus-xmas-define "gnus-xmas")
47    (autoload 'gnus-xmas-redefine "gnus-xmas")    (autoload 'gnus-xmas-redefine "gnus-xmas")
48    (autoload 'appt-select-lowest-window "appt"))    (autoload 'appt-select-lowest-window "appt")
49      (autoload 'gnus-get-buffer-create "gnus")
50  (if (featurep 'xemacs)    (autoload 'nnheader-find-etc-directory "nnheader"))
51      (autoload 'gnus-smiley-display "smiley")  
52    (autoload 'gnus-smiley-display "smiley-ems") ; override XEmacs version  (autoload 'smiley-region "smiley")
53  )  ;; Fixme: shouldn't require message
54    (autoload 'message-text-with-property "message")
55    
56  (defun gnus-kill-all-overlays ()  (defun gnus-kill-all-overlays ()
57    "Delete all overlays in the current buffer."    "Delete all overlays in the current buffer."
# Line 71  Line 72 
72         valstr)))         valstr)))
73    
74  (eval-and-compile  (eval-and-compile
75      (defalias 'gnus-char-width
76        (if (fboundp 'char-width)
77            'char-width
78          (lambda (ch) 1)))) ;; A simple hack.
79    
80    (eval-and-compile
81    (if (featurep 'xemacs)    (if (featurep 'xemacs)
82        (gnus-xmas-define)        (gnus-xmas-define)
83      (defvar gnus-mouse-face-prop 'mouse-face      (defvar gnus-mouse-face-prop 'mouse-face
84        "Property used for highlighting mouse regions.")))        "Property used for highlighting mouse regions.")))
85    
86  (defvar gnus-tmp-unread)  (eval-when-compile
87  (defvar gnus-tmp-replied)    (defvar gnus-tmp-unread)
88  (defvar gnus-tmp-score-char)    (defvar gnus-tmp-replied)
89  (defvar gnus-tmp-indentation)    (defvar gnus-tmp-score-char)
90  (defvar gnus-tmp-opening-bracket)    (defvar gnus-tmp-indentation)
91  (defvar gnus-tmp-lines)    (defvar gnus-tmp-opening-bracket)
92  (defvar gnus-tmp-name)    (defvar gnus-tmp-lines)
93  (defvar gnus-tmp-closing-bracket)    (defvar gnus-tmp-name)
94  (defvar gnus-tmp-subject-or-nil)    (defvar gnus-tmp-closing-bracket)
95      (defvar gnus-tmp-subject-or-nil)
96      (defvar gnus-check-before-posting)
97      (defvar gnus-mouse-face)
98      (defvar gnus-group-buffer))
99    
100  (defun gnus-ems-redefine ()  (defun gnus-ems-redefine ()
101    (cond    (cond
# Line 96  Line 107 
107    
108      ;; [Note] Now there are three kinds of mule implementations,      ;; [Note] Now there are three kinds of mule implementations,
109      ;; original MULE, XEmacs/mule and Emacs 20+ including      ;; original MULE, XEmacs/mule and Emacs 20+ including
110      ;; MULE features.  Unfortunately these API are different.  In      ;; MULE features.  Unfortunately these APIs are different.  In
111      ;; particular, Emacs (including original MULE) and XEmacs are      ;; particular, Emacs (including original Mule) and XEmacs are
112      ;; quite different.  However, this version of Gnus doesn't support      ;; quite different.  However, this version of Gnus doesn't support
113      ;; anything other than XEmacs 20+ and Emacs 20.3+.      ;; anything other than XEmacs 20+ and Emacs 20.3+.
114    
115      ;; Predicates to check are following:      ;; Predicates to check are following:
116      ;; (boundp 'MULE) is t only if MULE (original; anything older than      ;; (boundp 'MULE) is t only if Mule (original; anything older than
117      ;;                     Mule 2.3) is running.      ;;                     Mule 2.3) is running.
118      ;; (featurep 'mule) is t when every mule variants are running.      ;; (featurep 'mule) is t when other mule variants are running.
119    
120      ;; It is possible to detect XEmacs/mule by (featurep 'mule) and      ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
121      ;; checking `emacs-version'.  In this case, the implementation for      ;; (featurep 'xemacs).  In this case, the implementation for
122      ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.      ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
123    
124      (defvar gnus-summary-display-table nil      (defvar gnus-summary-display-table nil
# Line 144  Line 155 
155         (boundp 'mark-active)         (boundp 'mark-active)
156         mark-active))         mark-active))
157    
158    (defun gnus-mark-active-p ()
159      "Non-nil means the mark and region are currently active in this buffer."
160      mark-active) ; aliased to region-exists-p in XEmacs.
161    
162  (if (fboundp 'add-minor-mode)  (if (fboundp 'add-minor-mode)
163      (defalias 'gnus-add-minor-mode 'add-minor-mode)      (defalias 'gnus-add-minor-mode 'add-minor-mode)
164    (defun gnus-add-minor-mode (mode name map &rest rest)    (defun gnus-add-minor-mode (mode name map &rest rest)
# Line 166  Line 181 
181          (when (and dir          (when (and dir
182                     (file-exists-p (setq file                     (file-exists-p (setq file
183                                          (expand-file-name "x-splash" dir))))                                          (expand-file-name "x-splash" dir))))
184            (with-temp-buffer            (let ((coding-system-for-read 'raw-text)
185              (insert-file-contents file)                  default-enable-multibyte-characters)
186              (goto-char (point-min))              (with-temp-buffer
187              (ignore-errors                (insert-file-contents file)
188                (setq pixmap (read (current-buffer))))))                (goto-char (point-min))
189                  (ignore-errors
190                    (setq pixmap (read (current-buffer)))))))
191          (when pixmap          (when pixmap
192            (make-face 'gnus-splash)            (make-face 'gnus-splash)
193            (setq height (/ (car pixmap) (frame-char-height))            (setq height (/ (car pixmap) (frame-char-height))
# Line 189  Line 206 
206            (goto-char (point-min))            (goto-char (point-min))
207            (sit-for 0))))))            (sit-for 0))))))
208    
209  (defvar gnus-article-xface-ring-internal nil  ;;; Image functions.
   "Cache for face data.")  
210    
211  ;; Worth customizing?  (defun gnus-image-type-available-p (type)
212  (defvar gnus-article-xface-ring-size 6    (and (fboundp 'image-type-available-p)
213    "Length of the ring used for `gnus-article-xface-ring-internal'.")         (image-type-available-p type)))
214    
215  (defvar gnus-article-compface-xbm  (defun gnus-create-image (file &optional type data-p &rest props)
216    (eq 0 (string-match "#define" (shell-command-to-string "uncompface -X")))    (let ((face (plist-get props :face)))
217    "Non-nil means the compface program supports the -X option.      (when face
218  That produces XBM output.")        (setq props (plist-put props :foreground (face-foreground face)))
219          (setq props (plist-put props :background (face-background face))))
220  (defun gnus-article-display-xface (beg end)      (apply 'create-image file type data-p props)))
221    "Display an XFace header from between BEG and END in the current article.  
222  Requires support for images in your Emacs and the external programs  (defun gnus-put-image (glyph &optional string category)
223  `uncompface', and `icontopbm'.  On a GNU/Linux system these    (let ((point (point)))
224  might be in packages with names like `compface' or `faces-xface' and      (insert-image glyph (or string " "))
225  `netpbm' or `libgr-progs', for instance.  See also      (put-text-property point (point) 'gnus-image-category category)
226  `gnus-article-compface-xbm'.      (unless string
227          (put-text-property (1- (point)) (point)
228  This function is for Emacs 21+.  See `gnus-xmas-article-display-xface'                           'gnus-image-text-deletable t))
229  for XEmacs."      glyph))
230    ;; It might be worth converting uncompface's output in Lisp.  
231    (defun gnus-remove-image (image &optional category)
232    (when (if (fboundp 'display-graphic-p)    (dolist (position (message-text-with-property 'display))
233              (display-graphic-p))      (when (and (equal (get-text-property position 'display) image)
234      (unless gnus-article-xface-ring-internal ; Only load ring when needed.                 (equal (get-text-property position 'gnus-image-category)
235        (setq gnus-article-xface-ring-internal                        category))
236              (make-ring gnus-article-xface-ring-size)))        (put-text-property position (1+ position) 'display nil)
237      (save-excursion        (when (get-text-property position 'gnus-image-text-deletable)
238        (let* ((cur (current-buffer))          (delete-region position (1+ position))))))
              (data (buffer-substring beg end))  
              (image (cdr-safe (assoc data (ring-elements  
                                            gnus-article-xface-ring-internal))))  
              default-enable-multibyte-characters)  
         (unless image  
           (with-temp-buffer  
             (insert data)  
             (and (eq 0 (apply #'call-process-region (point-min) (point-max)  
                               "uncompface"  
                               'delete '(t nil) nil  
                               (if gnus-article-compface-xbm  
                                   '("-X"))))  
                  (if gnus-article-compface-xbm  
                      t  
                    (goto-char (point-min))  
                    (progn (insert "/* Width=48, Height=48 */\n") t)  
                    (eq 0 (call-process-region (point-min) (point-max)  
                                               "icontopbm"  
                                               'delete '(t nil))))  
                  ;; Miles Bader says that faces don't look right as  
                  ;; light on dark.  
                  (if (eq 'dark (cdr-safe (assq 'background-mode  
                                                (frame-parameters))))  
                      (setq image (create-image (buffer-string)  
                                                (if gnus-article-compface-xbm  
                                                    'xbm  
                                                  'pbm)  
                                                t  
                                                :ascent 'center  
                                                :foreground "black"  
                                                :background "white"))  
                    (setq image (create-image (buffer-string)  
                                              (if gnus-article-compface-xbm  
                                                  'xbm  
                                                'pbm)  
                                              t  
                                              :ascent 'center)))))  
           (ring-insert gnus-article-xface-ring-internal (cons data image)))  
         (when image  
           (goto-char (point-min))  
           (re-search-forward "^From:" nil 'move)  
           (while (get-text-property (point) 'display)  
             (goto-char (next-single-property-change (point) 'display)))  
           (insert-image image))))))  
239    
240  (provide 'gnus-ems)  (provide 'gnus-ems)
241    

Legend:
Removed from v.1.15.2.2  
changed lines
  Added in v.1.15.2.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26