cgit.sxemacs.org Git - gnus/blob - contrib/compface.el

   1 ;;; compface.el --- functions for converting X-Face headers
   2 ;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;      TAKAI Kousuke <tak@kmc.gr.jp>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (defgroup compface nil
  30   "X-Face image conversion."
  31   :group 'extensions)
  32
  33 (defcustom uncompface-use-external (and (not noninteractive)
  34                                         (executable-find "uncompface")
  35                                         (executable-find "icontopbm")
  36                                         'undecided)
  37   "*Specify which of the internal or the external decoder should be used.
  38 nil means to use the internal ELisp-based uncompface program.  t means
  39 to use the external decoder.  In the later case, you need to have the
  40 external `uncompface' and `icontopbm' programs installed.  The default
  41 value is nil if those external programs aren't available, otherwise
  42 `undecided' which means to determine it by checking whether the host
  43 machine is slow.  See also `uncompface-use-external-threshold'.  You
  44 can skip that check by setting this value as nil or t explicitly."
  45   :type '(choice (const :tag "Use the internal decoder" nil)
  46                  (const :tag "Use the external decoder" t)
  47                  (const :tag "Autodetection" undecided))
  48   :group 'compface)
  49
  50 (defcustom uncompface-use-external-threshold 0.1
  51   "*Number of seconds to check whether the host machine is slow.
  52 If the host takes time larger than this value for decoding an X-Face
  53 using the internal ELisp-based uncompface program, it will be changed
  54 to using the external `uncompface' and `icontopbm' programs if they
  55 are available.  Note that the measurement may never be exact."
  56   :type 'number
  57   :group 'compface)
  58
  59 (eval-when-compile
  60   (defmacro uncompface-float-time (&optional specified-time)
  61     (if (fboundp 'float-time)
  62         `(float-time ,specified-time)
  63       `(let ((time (or ,specified-time (current-time))))
  64          (+ (* (car time) 65536.0)
  65             (cadr time)
  66             (cond ((consp (setq time (cddr time)))
  67                    (/ (car time) 1000000.0))
  68                   (time
  69                    (/ time 1000000.0))
  70                   (t
  71                    0)))))))
  72
  73 (defun uncompface (face)
  74   "Convert FACE to pbm.
  75 If `uncompface-use-external' is t, it requires the external programs
  76 `uncompface', and `icontopbm'.  On a GNU/Linux system these might be
  77 in packages with names like `compface' or `faces-xface' and `netpbm'
  78 or `libgr-progs', for instance."
  79   (cond ((eq uncompface-use-external nil)
  80          (uncompface-internal face))
  81         ((eq uncompface-use-external t)
  82          (with-temp-buffer
  83            (insert face)
  84            (and (eq 0 (apply 'call-process-region (point-min) (point-max)
  85                              "uncompface"
  86                              'delete '(t nil) nil))
  87                 (progn
  88                   (goto-char (point-min))
  89                   (insert "/* Width=48, Height=48 */\n")
  90                   ;; I just can't get "icontopbm" to work correctly on its
  91                   ;; own in XEmacs.  And Emacs doesn't understand un-raw pbm
  92                   ;; files.
  93                   (if (not (featurep 'xemacs))
  94                       (eq 0 (call-process-region (point-min) (point-max)
  95                                                  "icontopbm"
  96                                                  'delete '(t nil)))
  97                     (shell-command-on-region (point-min) (point-max)
  98                                              "icontopbm | pnmnoraw"
  99                                              (current-buffer) t)
 100                     t))
 101                 (buffer-string))))
 102         (t
 103          (let* ((gc-cons-threshold (eval '(lsh -1 -1)))
 104                 (start (current-time)))
 105            (prog1
 106                (uncompface-internal face)
 107              (setq uncompface-use-external
 108                    (and (> (- (uncompface-float-time (current-time))
 109                               (uncompface-float-time start))
 110                            uncompface-use-external-threshold)
 111                         (executable-find "uncompface")
 112                         (executable-find "icontopbm")
 113                         t))
 114              (message "Setting `uncompface-use-external' to `%s'"
 115                       uncompface-use-external))))))
 116
 117 ;; The following section is a bug-for-bug compatible version of
 118 ;; `uncompface' program entirely implemented in Emacs-Lisp.
 119
 120 (eval-when-compile
 121   ;; The size of 48x48 is actually hard-coded into the code itself,
 122   ;; so you cannot simply change those values.  So we hard-code
 123   ;; them into the compiled code.
 124   (defconst uncompface-width 48
 125     "Width of X-Face bitmap image.")
 126   (defconst uncompface-height 48
 127     "Height of X-Face bitmap image.")
 128
 129   ;; Again, this is also hard-coded into the compiled code.
 130   (defconst uncompface-guesses
 131     (mapcar (lambda (x)
 132               (mapcar (lambda (x)
 133                         (let ((vector (make-vector (length x) nil))
 134                               (i 0))
 135                           (while x
 136                             (or (zerop (car x))
 137                                 (aset vector i t))
 138                             (setq x (cdr x)
 139                                   i (1+ i)))
 140                           vector))
 141                       x))
 142             '((;; g_00
 143                (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
 144                 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1
 145                 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
 146                 1 1 1 0 0 0 1 1 1 1 0 1 1 1 1 1
 147                 0 0 0 0 0 1 0 1 0 0 0 1 0 1 1 1
 148         &nb