Description: Add w3m-e23.el for emacs23
w3m-e23.el: New file to byte-compile with emacs23 and emacs-snapshot,
from the upstream development version on 2007-02-02.
Origin: upstream, http://cvs.namazu.org/Development/emacs-w3m/w3m-e23.el?revision=1.23&view=markup
--- w3m-el-1.4.4.orig/w3m-e23.el 1970-01-01 09:00:00.000000000 +0900
+++ w3m-el-1.4.4/w3m-e23.el 2007-02-02 12:03:53.000000000 +0900
@@ -0,0 +1,999 @@
+;;; w3m-e23.el --- The stuffs to use emacs-w3m on Emacs 23
+
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
+;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
+
+;; Authors: Yuuichi Teranishi <teranisi@gohome.org>,
+;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>,
+;; Katsumi Yamaoka <yamaoka@jpl.org>
+;; Keywords: w3m, WWW, hypermedia
+
+;; This file is a part of emacs-w3m.
+
+;; This program 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.
+
+;; This program 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 this program; if not, you can either send email to this
+;; program's maintainer or write to: The Free Software Foundation,
+;; Inc.; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+
+;;; Commentary:
+
+;; This file contains the stuffs to use emacs-w3m on Emacs 23. For
+;; more detail about emacs-w3m, see:
+;;
+;; http://emacs-w3m.namazu.org/
+
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+(require 'w3m-util)
+(require 'w3m-proc)
+(require 'w3m-image)
+(require 'w3m-favicon)
+(require 'w3m-fsf)
+(require 'w3m-ccl)
+(require 'wid-edit)
+
+;; Functions and variables which should be defined in the other module
+;; at run-time.
+(eval-when-compile
+ (defvar w3m-current-process)
+ (defvar w3m-current-url)
+ (defvar w3m-current-title)
+ (defvar w3m-display-inline-images)
+ (defvar w3m-favicon-image)
+ (defvar w3m-form-use-fancy-faces)
+ (defvar w3m-icon-directory)
+ (defvar w3m-mode-map)
+ (defvar w3m-modeline-process-status-on)
+ (defvar w3m-process-queue)
+ (defvar w3m-show-graphic-icons-in-header-line)
+ (defvar w3m-show-graphic-icons-in-mode-line)
+ (defvar w3m-toolbar)
+ (defvar w3m-toolbar-buttons)
+ (defvar w3m-use-favicon)
+ (defvar w3m-use-header-line)
+ (defvar w3m-use-tab)
+ (defvar w3m-work-buffer-name)
+ (defvar w3m-work-buffer-list)
+ (defvar w3m-new-session-in-background)
+ (autoload 'w3m-copy-buffer "w3m")
+ (autoload 'w3m-delete-buffer "w3m")
+ (autoload 'w3m-image-type "w3m")
+ (autoload 'w3m-retrieve "w3m")
+ (autoload 'iswitchb-read-buffer "iswitchb"))
+
+;;; Coding system.
+
+(defun w3m-make-ccl-coding-system
+ (coding-system mnemonic docstring decoder encoder)
+ "Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER.
+CODING-SYSTEM, DECODER and ENCODER must be symbol."
+ (make-coding-system coding-system 4 mnemonic docstring
+ (cons decoder encoder)))
+
+(unless (fboundp 'w3m-ucs-to-char)
+ (defun w3m-ucs-to-char (codepoint)
+ (or (decode-char 'ucs codepoint) ?~)))
+
+(defun w3m-add-local-hook (hook function &optional append)
+ "Add to the buffer-local value of HOOK the function FUNCTION."
+ (add-hook hook function append t))
+
+;; Function which returns non-nil when the current display device can
+;; show images inline.
+(defalias 'w3m-display-graphic-p 'display-images-p)
+
+(defun w3m-display-inline-images-p ()
+ "Returns non-nil when images can be displayed under the present
+circumstances."
+ (and w3m-display-inline-images (display-images-p)))
+
+(defun w3m-create-image (url &optional no-cache referer size handler)
+ "Retrieve data from URL and create an image object.
+If optional argument NO-CACHE is non-nil, cache is not used.
+If second optional argument REFERER is non-nil, it is used as Referer: field.
+If third optional argument SIZE is non-nil, its car element is used as width
+and its cdr element is used as height."
+ (if (not handler)
+ (w3m-process-with-wait-handler
+ (w3m-create-image url no-cache referer size handler))
+ (lexical-let ((set-size size)
+ (url url)
+ image size)
+ (w3m-process-do-with-temp-buffer
+ (type (progn
+ (set-buffer-multibyte nil)
+ (w3m-retrieve url 'raw no-cache nil referer handler)))
+ (when (w3m-image-type-available-p (setq type (w3m-image-type type)))
+ (setq image (create-image (buffer-string) type t :ascent 'center))
+ (if (and w3m-resize-images set-size)
+ (progn
+ (set-buffer-multibyte t)
+ (setq size (image-size image 'pixels))
+ (if (and (null (car set-size)) (cdr set-size))
+ (setcar set-size
+ (/ (* (car size) (cdr set-size)) (cdr size))))
+ (if (and (null (cdr set-size)) (car set-size))
+ (setcdr set-size
+ (/ (* (cdr size) (car set-size)) (car size))))
+ (if (or (not (eq (car size)
+ (car set-size))) ; width is different
+ (not (eq (cdr size)
+ (cdr set-size)))) ; height is different
+ (lexical-let ((image image))
+ (w3m-process-do
+ (resized (w3m-resize-image
+ (plist-get (cdr image) :data)
+ (car set-size)(cdr set-size)
+ handler))
+ (if resized (plist-put (cdr image) :data resized))
+ image))
+ image))
+ image))))))
+
+(defun w3m-create-resized-image (url rate &optional referer size handler)
+ "Resize an cached image object.
+URL is the image file's url.
+RATE is resize percentage.
+If REFERER is non-nil, it is used as Referer: field.
+If SIZE is non-nil, its car element is used as width
+and its cdr element is used as height."
+ (if (not handler)
+ (w3m-process-with-wait-handler
+ (w3m-create-image url nil referer size handler))
+ (lexical-let ((url url)
+ (rate rate)
+ image)
+ (w3m-process-do-with-temp-buffer
+ (type (progn
+ (set-buffer-multibyte nil)
+ (w3m-retrieve url 'raw nil nil referer handler)))
+ (when (w3m-image-type-available-p (setq type (w3m-image-type type)))
+ (setq image (create-image (buffer-string) type t :ascent 'center))
+ (progn
+ (set-buffer-multibyte t)
+ (w3m-process-do
+ (resized (w3m-resize-image-by-rate
+ (plist-get (cdr image) :data)
+ rate
+ handler))
+ (if resized (plist-put (cdr image) :data resized))
+ image)))))))
+
+(defun w3m-insert-image (beg end image &rest args)
+ "Display image on the current buffer.
+Buffer string between BEG and END are replaced with IMAGE."
+ (let ((faces (get-text-property beg 'face))
+ (idx 0)
+ orig len face)
+ (add-text-properties beg end (list 'display image
+ 'intangible image
+ 'invisible nil))
+ ;; Hide underlines behind inline images.
+ ;; Gerd Moellmann <gerd@gnu.org>, the maintainer of Emacs 21, wrote in
+ ;; the article <86heyi7vks.fsf@gerd.segv.de> in the list emacs-pretest-
+ ;; bug@gnu.org on 18 May 2001 that to show an underline of a text even
+ ;; if it has an image as a text property is the feature of Emacs 21.
+ ;; However, that behavior is not welcome to the w3m buffers, so we do
+ ;; to fix it with the following stuffs.
+ (when faces
+ (unless (listp faces)
+ (setq faces (list faces)))
+ (setq orig (copy-sequence faces)
+ len (length orig))
+ (while (< idx len)
+ (when (face-underline-p (setq face (nth idx orig)))
+ (setq faces (delq face faces)))
+ (setq idx (1+ idx)))
+ (when (< (length faces) len)
+ (put-text-property beg end 'face faces)
+ (put-text-property beg end 'w3m-faces-with-underline orig)))))
+
+(defun w3m-remove-image (beg end)
+ "Remove an image which is inserted between BEG and END."
+ (remove-text-properties beg end '(display nil intangible nil))
+ (let ((underline (get-text-property beg 'w3m-faces-with-underline)))
+ (when underline
+ (add-text-properties
+ beg end (list 'face underline 'w3m-faces-with-underline nil)))))
+
+(defun w3m-image-type-available-p (image-type)
+ "Return non-nil if an image with IMAGE-TYPE can be displayed inline."
+ (and (display-images-p)
+ (image-type-available-p image-type)))
+
+;;; Form buttons
+(defface w3m-form-button-face
+ '((((type x w32 mac) (class color))
+ :background "lightgrey" :foreground "black"
+ :box (:line-width 2 :style released-button))
+ (((class color) (background light)) (:foreground "cyan" :underline t))
+ (((class color) (background dark)) (:foreground "red" :underline t))
+ (t (:underline t)))
+ "*Face to fontify buttons in forms."
+ :group 'w3m-face)
+
+(defface w3m-form-button-mouse-face
+ '((((type x w32 mac) (class color))
+ :background "DarkSeaGreen1" :foreground "black"
+ :box (:line-width 2 :style released-button))
+ (((class color) (background light)) (:foreground "cyan" :underline t))
+ (((class color) (background dark)) (:foreground "red" :underline t))
+ (t (:underline t)))
+ "*Face to fontify focused buttons in forms."
+ :group 'w3m-face)
+
+(defface w3m-form-button-pressed-face
+ '((((type x w32 mac) (class color))
+ :background "lightgrey" :foreground "black"
+ :box (:line-width 2 :style pressed-button))
+ (((class color) (background light)) (:foreground "cyan" :underline t))
+ (((class color) (background dark)) (:foreground "red" :underline t))
+ (t (:underline t)))
+ "*Face to fontify pressed buttons in forms."
+ :group 'w3m-face)
+
+(defvar w3m-form-button-keymap
+ (let ((map (copy-keymap widget-keymap)))
+ (substitute-key-definition 'widget-forward nil map)
+ (substitute-key-definition 'widget-backward nil map)
+ map))
+
+(define-widget 'w3m-form-button 'push-button
+ "Widget for w3m form button."
+ :keymap w3m-form-button-keymap
+ :action (function (lambda (widget &optional e)
+ (eval (widget-get widget :w3m-form-action)))))
+
+(defun w3m-form-make-button (start end properties)
+ "Make button on the region from START to END."
+ (if w3m-form-use-fancy-faces
+ (progn
+ (unless (memq (face-attribute 'w3m-form-button-face :box)
+ '(nil unspecified))
+ (and (eq ?\[ (char-after start))
+ (eq ?\] (char-before end))
+ (save-excursion
+ (goto-char start)
+ (delete-char 1)
+ (insert " ")
+ (goto-char end)
+ (delete-char -1)
+ (insert " ")
+ (setq start (1+ start)
+ end (1- end)))))
+ (let ((w (widget-convert-button
+ 'w3m-form-button start end
+ :w3m-form-action (plist-get properties 'w3m-action))))
+ (overlay-put (widget-get w :button-overlay) 'evaporate t))
+ (add-text-properties start end properties))
+ (w3m-add-face-property start end 'w3m-form-face)))
+
+(defun w3m-setup-widget-faces ()
+ (make-local-variable 'widget-button-face)
+ (make-local-variable 'widget-mouse-face)
+ (make-local-variable 'widget-button-pressed-face)
+ (setq widget-button-face 'w3m-form-button-face)
+ (setq widget-mouse-face 'w3m-form-button-mouse-face)
+ (setq widget-button-pressed-face 'w3m-form-button-pressed-face))
+
+;;; Menu bar
+(defun w3m-menu-on-forefront (arg &optional curbuf)
+ "Place emacs-w3m menus on the forfront of the menu bar if ARG is non-nil.
+If CURBUF is given, this function works only in the current buffer,
+otherwise works in all the emacs-w3m buffers."
+ (if curbuf
+ (if arg
+ (let ((items (mapcar 'car (cdr (lookup-key global-map [menu-bar])))))
+ (when items
+ (set (make-local-variable 'menu-bar-final-items) items)))
+ (kill-local-variable 'menu-bar-final-items))
+ (save-current-buffer
+ (dolist (buffer (w3m-list-buffers t))
+ (set-buffer buffer)
+ (w3m-menu-on-forefront arg t)))))
+
+;;; Toolbar
+(defcustom w3m-use-toolbar
+ (and (featurep 'tool-bar)
+ ;; Emacs 22 and greater return t for `(featurep 'tool-bar)'
+ ;; even if being launched with the -nw option.
+ (display-images-p)
+ (or (featurep 'gtk)
+ (image-type-available-p 'xpm)))
+ "Non-nil activates toolbar of w3m."
+ :group 'w3m
+ :type 'boolean)
+
+(defcustom w3m-toolbar-icon-preferred-image-types
+ (if (featurep 'gtk)
+ '(png)
+ '(xpm))
+ "List of image types that you prefer to use for the tool bar icons.
+By default, `png' is most preferred for Emacs built with GTK and `xpm'
+is for others."
+ :group 'w3m
+ :type '(repeat (symbol :tag "Image type"))
+ :set (lambda (symbol value)
+ (prog1
+ (custom-set-default symbol value)
+ (when (and (not noninteractive) (boundp 'w3m-toolbar-buttons))
+ (w3m-update-toolbars)))))
+
+(defcustom w3m-toolbar-use-single-image-per-icon nil
+ "Non-nil means use single image (named possibly *-up) per icon.
+If it is nil, subsidiaries, e.g., *-down and *-disabled, if any, are
+used together."
+ :group 'w3m
+ :type 'boolean
+ :set (lambda (symbol value)
+ (prog1
+ (custom-set-default symbol value)
+ (when (and (not noninteractive) (boundp 'w3m-toolbar-buttons))
+ (w3m-update-toolbars)))))
+
+(defcustom w3m-toolbar-configurations
+ `((tool-bar-button-margin . global)
+ ,@(unless (featurep 'gtk)
+ '((tool-bar-button-relief . global))))
+ "Alist of the variables and the values controls the tool bar appearance.
+The value `global' means to use the global value of the variable."
+ :group 'w3m
+ :type '(repeat (cons :format "%v"
+ (symbol :tag "Variable")
+ (radio :format "%v"
+ (const :format "%v " global)
+ (sexp :tag "Local Value"))))
+ :set (lambda (symbol value)
+ (prog1
+ (custom-set-default symbol value)
+ (when (and (not noninteractive) (featurep 'w3m))
+ (w3m-toolbar-set-configurations)))))
+
+(defun w3m-toolbar-define-keys (keymap defs)
+ ;; Invalidate the default bindings.
+ (let ((keys (cdr (key-binding [tool-bar] t)))
+ item)
+ (while (setq item (pop keys))
+ (when (setq item (car-safe item))
+ (define-key keymap (vector 'tool-bar item) 'undefined))))
+ (let ((n (length defs))
+ def)
+ (while (>= n 0)
+ (setq n (1- n)
+ def (nth n defs))
+ (define-key keymap (vector 'tool-bar (aref def 1))
+ (list 'menu-item (aref def 3) (aref def 1)
+ :enable (aref def 2)
+ :image (symbol-value (aref def 0)))))))
+
+(defun w3m-find-image (name &optional directory)
+ "Find image file for NAME and return cons of file name and type.
+This function searches only in DIRECTORY, that defaults to the value of
+`w3m-icon-directory', for an image file of which the base name is NAME.
+Files of types that Emacs does not support are ignored."
+ (unless directory
+ (setq directory w3m-icon-directory))
+ (when (and directory
+ (file-directory-p directory)
+ (display-images-p))
+ (let* ((case-fold-search nil)
+ (files (directory-files directory t
+ (concat "\\`" (regexp-quote name) "\\.")))
+ (types (append w3m-toolbar-icon-preferred-image-types image-types))
+ file type rest)
+ (while files
+ (when (string-match "\\.\\([^.]+\\)\\'" (setq file (pop files)))
+ (setq type (intern (downcase (match-string 1 file))))
+ (setq type (or (cdr (assq type '((tif . tiff)
+ (jpg . jpeg)
+ (ps . postscript)
+ (pgm . pbm)
+ (ppm . pbm))))
+ type))
+ (push (cons file (memq type types)) rest)))
+ (setq rest (car (sort rest (lambda (a b) (> (length a) (length b))))))
+ (when (cdr rest)
+ (cons (car rest) (cadr rest))))))
+
+(defun w3m-toolbar-make-buttons (buttons &optional force)
+ (let ((xpm-props '(:color-symbols (("backgroundToolBarColor" . "None"))))
+ button icon down disabled up)
+ (while buttons
+ (setq button (pop buttons)
+ icon (intern (concat "w3m-toolbar-" button "-icon")))
+ (when (or force (not (boundp icon)))
+ (setq down (w3m-find-image (concat button "-down"))
+ disabled (w3m-find-image (concat button "-disabled")))
+ (if (setq up (or (w3m-find-image (concat button "-up"))
+ (prog1
+ (or down disabled (w3m-find-image button))
+ (setq down nil
+ disabled nil))))
+ (progn
+ (setq up (apply 'create-image (car up) (cdr up) nil
+ :ascent 'center
+ (when (eq (cdr up) 'xpm)
+ xpm-props)))
+ (if (or w3m-toolbar-use-single-image-per-icon
+ (not (or down disabled)))
+ (set icon up)
+ (when down
+ (setq down (apply 'create-image (car down) (cdr down) nil
+ :ascent 'center
+ (when (eq (cdr up) 'xpm)
+ xpm-props))))
+ (when disabled
+ (setq disabled (apply 'create-image
+ (car disabled) (cdr disabled) nil
+ :ascent 'center
+ (when (eq (cdr disabled) 'xpm)
+ xpm-props))))
+ (set icon (vector down up disabled disabled))))
+ (error "Icon file %s-up.* not found" button))))))
+
+(defun w3m-toolbar-set-configurations (&optional curbuf)
+ "Set values of variables according to `w3m-toolbar-configurations'.
+If CURBUF is given, this function works only in the current buffer,
+otherwise works in all the emacs-w3m buffers."
+ (if curbuf
+ (dolist (config w3m-toolbar-configurations)
+ (if (eq (cdr config) 'global)
+ (kill-local-variable (car config))
+ (set (make-local-variable (car config)) (cdr config))))
+ (let ((cur (selected-frame))
+ buffer buffers)
+ (walk-windows
+ (lambda (window)
+ (setq buffer (window-buffer window))
+ (unless (memq buffer buffers)
+ (set-buffer buffer)
+ (when (eq major-mode 'w3m-mode)
+ (push buffer buffers)
+ (select-frame (window-frame window))
+ ;;(set-buffer buffer)
+ (w3m-toolbar-set-configurations t))))
+ 'ignore 'visible)
+ (select-frame-set-input-focus cur)
+ (save-current-buffer
+ (dolist (buffer (w3m-list-buffers t))
+ (unless (memq buffer buffers)
+ (set-buffer buffer)
+ (w3m-toolbar-set-configurations t))))
+ (select-frame-set-input-focus cur))))
+
+(defun w3m-setup-toolbar ()
+ (when (and w3m-use-toolbar
+ (w3m-find-image "antenna-up"))
+ (w3m-toolbar-make-buttons w3m-toolbar-buttons)
+ (w3m-toolbar-set-configurations t)
+ (w3m-toolbar-define-keys w3m-mode-map w3m-toolbar)))
+
+(defalias 'w3m-update-toolbar 'ignore)
+
+(defun w3m-update-toolbars ()
+ (when (and w3m-use-toolbar
+ (w3m-find-image "antenna-up"))
+ (w3m-toolbar-make-buttons w3m-toolbar-buttons t)
+ (w3m-toolbar-set-configurations)
+ (w3m-toolbar-define-keys w3m-mode-map w3m-toolbar)))
+
+;;; Header line & Tabs
+(defcustom w3m-tab-width 16
+ "w3m tab width."
+ :group 'w3m
+ :set (lambda (symbol value)
+ (custom-set-default symbol
+ (if (and (numberp value) (> value 0))
+ value
+ 16)))
+ :type '(integer :size 0))
+
+(defface w3m-tab-unselected-face
+ '((((type x w32 mac) (class color))
+ :background "Gray50" :foreground "Gray20"
+ :box (:line-width -1 :style released-button))
+ (((class color))
+ (:background "blue" :foreground "black")))
+ "*Face to fontify unselected tabs."
+ :group 'w3m-face)
+
+(defface w3m-tab-unselected-retrieving-face
+ '((((type x w32 mac) (class color))
+ :background "Gray50" :foreground "OrangeRed"
+ :box (:line-width -1 :style released-button))
+ (((class color))
+ (:background "blue" :foreground "OrangeRed")))
+ "*Face to fontify unselected tabs which are retrieving their pages."
+ :group 'w3m-face)
+
+(defface w3m-tab-selected-face
+ '((((type x w32 mac) (class color))
+ :background "Gray85" :foreground "black"
+ :box (:line-width -1 :style released-button))
+ (((class color))
+ (:background "cyan" :foreground "black"))
+ (t (:underline t)))
+ "*Face to fontify selected tab."
+ :group 'w3m-face)
+
+(defface w3m-tab-selected-retrieving-face
+ '((((type x w32 mac) (class color))
+ :background "Gray85" :foreground "red"
+ :box (:line-width -1 :style released-button))
+ (((class color))
+ (:background "cyan" :foreground "red"))
+ (t (:underline t)))
+ "*Face to fontify selected tab which is retrieving its page."
+ :group 'w3m-face)
+
+(defface w3m-tab-background-face
+ '((((type x w32 mac) (class color))
+ :background "LightSteelBlue" :foreground "black")
+ (((class color))
+ (:background "white" :foreground "black")))
+ "*Face to fontify background of tab line."
+ :group 'w3m-face)
+
+(defface w3m-tab-selected-background-face
+ '((((type x w32 mac) (class color))
+ :background "LightSteelBlue" :foreground "black")
+ (((class color))
+ (:background "white" :foreground "black")))
+ "*Face to fontify selected background tab."
+ :group 'w3m-face)
+
+(defface w3m-tab-mouse-face
+ '((((type x w32 mac) (class color))
+ :background "Gray65" :foreground "white"
+ :box (:line-width -1 :style released-button)))
+ "*Face used to highlight tabs under the mouse."
+ :group 'w3m-face)
+
+(defvar w3m-modeline-spinner-map nil
+ "Keymap used on the spinner in the mode-line.")
+
+(defvar w3m-spinner-map-help-echo "mouse-2 kills the current process"
+ "String used for the :help-echo property on the spinner.")
+
+(defun w3m-setup-header-line ()
+ (setq header-line-format
+ (cond (w3m-use-tab
+ '(:eval (w3m-tab-line)))
+ (w3m-use-header-line
+ (list
+ (propertize
+ "Location: "
+ 'face (list 'w3m-header-line-location-title-face))
+ `(:eval
+ (propertize
+ (if (stringp w3m-current-url)
+ (replace-regexp-in-string "%" "%%" w3m-current-url)
+ "")
+ 'face (list 'w3m-header-line-location-content-face)
+ 'mouse-face '(highlight :foreground
+ ,(face-foreground 'default))
+ 'local-map (let ((map (make-sparse-keymap)))
+ (define-key map [header-line mouse-2]
+ 'w3m-goto-url)
+ map)
+ 'help-echo "mouse-2 prompts to input URL")))))))
+
+;; Use `defalias' instead of `defun' in order to avoid a compile warning
+;; which is issued because w3m-util.el defines it as `ignore' in advance.
+(defalias 'w3m-force-window-update
+ (lambda (&optional window)
+ "Force redisplay of WINDOW which defaults to the selected window."
+ (force-window-update (or window (selected-window)))))
+
+(defun w3m-tab-drag-mouse-function (event buffer)
+ (let ((window (posn-window (event-end event)))
+ mpos)
+ (when (framep window) ; dropped at outside of the frame.
+ (setq window nil
+ mpos (mouse-position))
+ (and (framep (car mpos))
+ (car (cdr mpos))
+ (cdr (cdr mpos))
+ (setq window (window-at (car (cdr mpos))
+ (cdr (cdr mpos))
+ (car mpos))))
+ (unless window
+ (when (one-window-p 'nomini)
+ (split-window))
+ (setq window (next-window))))
+ (unless (eq (window-buffer window) buffer)
+ (select-window window)
+ (switch-to-buffer buffer)
+ (w3m-force-window-update window))))
+
+(defun w3m-tab-click-mouse-function (event buffer)
+ (let ((window (posn-window (event-start event))))
+ (select-window window)
+ (switch-to-buffer buffer)
+ (w3m-force-window-update window)))
+
+(defun w3m-tab-double-click-mouse1-function (event buffer)
+ (let ((window (posn-window (event-start event))))
+ (when (eq major-mode 'w3m-mode)
+ (if w3m-new-session-in-background
+ (save-window-excursion
+ (w3m-copy-buffer))
+ (w3m-copy-buffer)))
+ (w3m-force-window-update window)))
+
+(defun w3m-tab-double-click-mouse2-function (event buffer)
+ (let ((window (posn-window (event-start event))))
+ (when (eq major-mode 'w3m-mode)
+ (w3m-delete-buffer))
+ (w3m-force-window-update window)))
+
+(defvar w3m-tab-map nil)
+(make-variable-buffer-local 'w3m-tab-map)
+
+(defvar w3m-tab-spinner-map nil)
+(make-variable-buffer-local 'w3m-tab-spinner-map)
+
+(defun w3m-tab-make-keymap ()
+ (unless w3m-tab-map
+ (setq w3m-tab-map (make-sparse-keymap))
+ (let* ((buffer (current-buffer))
+ (drag-action `(lambda (e)
+ (interactive "e")
+ (w3m-tab-drag-mouse-function e ,buffer)))
+ (single-action `(lambda (e)
+ (interactive "e")
+ (w3m-tab-click-mouse-function e ,buffer)))
+ (double-action1 `(lambda (e)
+ (interactive "e")
+ (w3m-tab-double-click-mouse1-function e ,buffer)))
+ (double-action2 `(lambda (e)
+ (interactive "e")
+ (w3m-tab-double-click-mouse2-function e ,buffer)))
+ (menu-action `(lambda (e)
+ (interactive "e")
+ (w3m-tab-button-menu e ,buffer)))
+ (menu-action2 `(lambda (e)
+ (interactive "e")
+ (w3m-tab-button-menu2 e ,buffer))))
+ (define-key w3m-tab-map [header-line down-mouse-1] 'ignore)
+ (define-key w3m-tab-map [header-line down-mouse-2] 'ignore)
+ (define-key w3m-tab-map [header-line mouse-1] single-action)
+ (define-key w3m-tab-map [header-line mouse-2] single-action)
+ (define-key w3m-tab-map [header-line drag-mouse-1] drag-action)
+ (define-key w3m-tab-map [header-line drag-mouse-2] drag-action)
+ (define-key w3m-tab-map [header-line double-mouse-1] double-action1)
+ (define-key w3m-tab-map [header-line double-mouse-2] double-action2)
+ (define-key w3m-tab-map [header-line mouse-3] menu-action)
+ (define-key w3m-tab-map [header-line wheel-up] 'w3m-previous-buffer)
+ (define-key w3m-tab-map [header-line wheel-down] 'w3m-next-buffer)
+ (define-key w3m-tab-map [header-line mouse-4] 'w3m-previous-buffer)
+ (define-key w3m-tab-map [header-line mouse-5] 'w3m-next-buffer)
+ (define-key w3m-mode-map [header-line double-mouse-1]
+ 'w3m-goto-new-session-url)
+ (define-key w3m-mode-map [header-line mouse-3] menu-action2))
+ (unless w3m-tab-spinner-map
+ (setq w3m-tab-spinner-map (make-sparse-keymap))
+ (define-key w3m-tab-spinner-map [header-line mouse-2]
+ `(lambda (e)
+ (interactive "e")
+ (save-current-buffer
+ ;; Why the `(w3m-process-stop BUFFER)' doesn't work?
+ (set-buffer ,(current-buffer))
+ (call-interactively 'w3m-process-stop)))))))
+
+(defvar w3m-tab-line-format nil
+ "Internal variable used to keep contents to be shown in the header-line.
+This is a buffer-local variable.")
+(make-variable-buffer-local 'w3m-tab-line-format)
+
+(defvar w3m-tab-timer nil
+ "Internal variable used to say time has not gone by after the tab-line
+was updated last time. It is used to control the `w3m-tab-line'
+function running too frequently, set by the function itself and
+cleared by a timer.")
+(make-variable-buffer-local 'w3m-tab-timer)
+
+(defvar w3m-tab-half-space
+ (propertize " " 'display '(space :width 0.5))
+ "The space of half width.")
+
+(defvar w3m-tab-separator
+ (propertize " "
+ 'face (list 'w3m-tab-background-face)
+ 'mouse-face 'w3m-tab-selected-background-face
+ 'display '(space :width 0.5))
+ "String used to separate tabs.")
+
+(defun w3m-tab-line ()
+ (or (and w3m-tab-timer w3m-tab-line-format)
+ (let* ((current (current-buffer))
+ (buffers (w3m-list-buffers))
+ (breadth 1)
+ (fringes (window-fringes))
+ (width (+ (window-width)
+ (/ (float (+ (or (car fringes) 0)
+ (or (nth 1 fringes) 0)))
+ (frame-char-width))
+ ;; Assume that the vertical scroll-bar has
+ ;; the width of two space characters.
+ (if (car (frame-current-scroll-bars)) 2 0)))
+ (nbuf (length buffers))
+ (graphic (and window-system
+ w3m-show-graphic-icons-in-header-line))
+ (margin (if window-system
+ (+ (if graphic 3.0 0.5)
+ ;; Right and left shadows.
+ (/ 2.0 (frame-char-width)))
+ 1))
+ (spinner (when w3m-process-queue
+ (w3m-make-spinner-image)))
+ buffer title data datum process favicon keymap face icon line)
+ (setq w3m-tab-timer t)
+ (run-at-time 0.1 nil
+ (lambda (buffer)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (setq w3m-tab-timer nil)
+ (when (and (eq (selected-window)
+ (get-buffer-window buffer))
+ w3m-process-queue)
+ (inline (w3m-force-window-update))))))
+ current)
+ (save-current-buffer
+ (while buffers
+ (set-buffer (setq buffer (pop buffers)))
+ (setq title (w3m-current-title))
+ (setq breadth
+ (max breadth
+ ;; There may be a wide character in the beginning of
+ ;; the title.
+ (if (> (length title) 0)
+ (char-width (aref title 0))
+ 0)))
+ (push (list (eq current buffer)
+ w3m-current-process
+ title
+ (when w3m-use-favicon w3m-favicon-image)
+ w3m-tab-map)
+ data)))
+ (setq width (if (> (* nbuf (+ margin w3m-tab-width)) width)
+ (max (truncate (- (/ width nbuf) margin)) breadth)
+ w3m-tab-width))
+ (while data
+ (setq datum (pop data)
+ current (car datum)
+ process (nth 1 datum)
+ title (nth 2 datum)
+ favicon (nth 3 datum)
+ keymap (nth 4 datum)
+ face (list
+ (if process
+ (if current
+ 'w3m-tab-selected-retrieving-face
+ 'w3m-tab-unselected-retrieving-face)
+ (if current
+ 'w3m-tab-selected-face
+ 'w3m-tab-unselected-face)))
+ icon (when graphic
+ (cond
+ (process
+ (when spinner
+ (propertize
+ " "
+ 'display spinner
+ 'face face
+ 'local-map w3m-tab-spinner-map
+ 'help-echo w3m-spinner-map-help-echo)))
+ (favicon
+ (propertize
+ " "
+ 'display favicon
+ 'face face
+ 'local-map keymap
+ 'help-echo title))))
+ breadth (cond (icon width)
+ (graphic (+ 2 width))
+ (t width)))
+ (push
+ (list
+ icon
+ (propertize
+ (concat
+ (when graphic w3m-tab-half-space)
+ (replace-regexp-in-string
+ "%" "%%"
+ (if (and (> (string-width title) breadth)
+ (> breadth 6))
+ (truncate-string-to-width
+ (concat (truncate-string-to-width title (- breadth 3))
+ "...")
+ breadth nil ?.)
+ (truncate-string-to-width title breadth nil ?\ ))))
+ 'face face
+ 'mouse-face 'w3m-tab-mouse-face
+ 'local-map keymap
+ 'help-echo title)
+ w3m-tab-separator)
+ line))
+ (setq w3m-tab-line-format
+ (concat (apply 'concat (apply 'nconc line))
+ (propertize (make-string (window-width) ?\ )
+ 'face (list 'w3m-tab-background-face)
+ 'mouse-face 'w3m-tab-selected-background-face))))))
+
+(defun w3m-update-tab-line ()
+ "Update tab line by a side effect."
+ (when w3m-use-tab
+ ;; The following form will cause a problem if a user doesn't set the
+ ;; cursor color explicitly, because the `cursor-color' value is always
+ ;; black in such a case whatever the color of the default face may be.
+ ;; cf. <URL:http://news.gmane.org/group/gmane.emacs.w3m/thread=4605>
+
+ ;;(set-cursor-color (frame-parameter (selected-frame) 'cursor-color))))
+
+ ;; We use wobbling of the window size instead.
+ (let ((window-min-height 0))
+ (enlarge-window 1)
+ (unless (eq (next-window nil 'ignore-minibuf) (selected-window))
+ (shrink-window 1)))))
+
+(defun w3m-switch-to-buffer (buffer &optional norecord)
+ "Run `switch-to-buffer' and redisplay the header-line.
+Redisplaying is done by wobbling the window size."
+ (interactive (list (if iswitchb-mode
+ (iswitchb-read-buffer "iswitch ")
+ (read-buffer "Switch to buffer: "))))
+ (prog1
+ (switch-to-buffer buffer norecord)
+ (when (and header-line-format
+ (eq major-mode 'w3m-mode))
+ (w3m-force-window-update))))
+
+(defun w3m-subst-switch-to-buffer-keys ()
+ "Substitute keys for `switch-to-buffer' with `w3m-switch-to-buffer'."
+ (substitute-key-definition 'switch-to-buffer 'w3m-switch-to-buffer
+ w3m-mode-map global-map))
+
+(add-hook 'w3m-mode-setup-functions 'w3m-tab-make-keymap)
+(add-hook 'w3m-mode-setup-functions 'w3m-setup-header-line)
+(add-hook 'w3m-mode-setup-functions 'w3m-setup-widget-faces)
+(add-hook 'w3m-mode-setup-functions 'w3m-subst-switch-to-buffer-keys)
+(add-hook 'w3m-select-buffer-hook 'w3m-force-window-update)
+
+;; Graphic icons.
+(defcustom w3m-space-before-modeline-icon ""
+ "String of space character(s) to be put in front of the mode-line icon.
+It may be better to use one or more spaces if you are using oblique or
+italic font in the modeline."
+ :group 'w3m
+ :type 'string)
+
+(defvar w3m-spinner-image-file nil
+ "Image file used to show a spinner in the header-line.")
+
+(defvar w3m-spinner-image-frames 3
+ "Number of frames which the spinner image contains.")
+
+(defvar w3m-spinner-image-index 0
+ "Counter used to rotate spinner images. This is a buffer-local variable.")
+(make-variable-buffer-local 'w3m-spinner-image-index)
+
+;; Images to be displayed in the modeline.
+(defvar w3m-modeline-process-status-on-icon nil)
+(defvar w3m-modeline-image-status-on-icon nil)
+(defvar w3m-modeline-status-off-icon nil)
+(defvar w3m-modeline-ssl-image-status-on-icon nil)
+(defvar w3m-modeline-ssl-status-off-icon nil)
+
+(defun w3m-initialize-graphic-icons (&optional force)
+ "Make icon images which will be displayed in the mode-line."
+ (interactive "P")
+ ;; Prefer xpm icons rather than png icons since Emacs doesn't display
+ ;; background colors of icon images other than xpm images transparently
+ ;; in the mode line.
+ (let* ((w3m-toolbar-icon-preferred-image-types '(xpm))
+ (defs `((w3m-modeline-status-off-icon
+ ,(w3m-find-image "state-00")
+ w3m-modeline-status-off)
+ (w3m-modeline-image-status-on-icon
+ ,(w3m-find-image "state-01")
+ w3m-modeline-image-status-on)
+ (w3m-modeline-ssl-status-off-icon
+ ,(w3m-find-image "state-10")
+ w3m-modeline-ssl-status-off)
+ (w3m-modeline-ssl-image-status-on-icon
+ ,(w3m-find-image "state-11")
+ w3m-modeline-ssl-image-status-on)))
+ def icon file type status keymap)
+ (while defs
+ (setq def (car defs)
+ defs (cdr defs)
+ icon (car def)
+ file (car (nth 1 def))
+ type (cdr (nth 1 def))
+ status (nth 2 def))
+ (if (and w3m-show-graphic-icons-in-mode-line file)
+ (progn
+ (when (or force (not (symbol-value icon)))
+ (unless keymap
+ (setq keymap (make-mode-line-mouse-map 'mouse-2
+ 'w3m-reload-this-page)))
+ (set icon (propertize
+ " "
+ 'display (create-image file type nil :ascent 'center)
+ 'local-map keymap
+ 'mouse-face 'mode-line-highlight
+ 'help-echo "mouse-2 reloads this page"))
+ (put icon 'risky-local-variable t)
+ (put status 'risky-local-variable t))
+ (when (stringp (symbol-value status))
+ ;; Save the original status strings as properties.
+ (put status 'string (symbol-value status)))
+ (set status (list "" 'w3m-space-before-modeline-icon icon)))
+ ;; Don't use graphic icons.
+ (when (get status 'string)
+ (set status (get status 'string)))))
+ ;; Spinner
+ (when (and (or force (not w3m-spinner-image-file))
+ (image-type-available-p 'gif)
+ w3m-icon-directory
+ (file-directory-p w3m-icon-directory)
+ (file-exists-p
+ (setq file (expand-file-name "spinner.gif"
+ w3m-icon-directory))))
+ (setq w3m-spinner-image-file file)
+ (define-key (setq w3m-modeline-spinner-map (make-sparse-keymap))
+ [mode-line mouse-2]
+ 'w3m-process-stop)
+ (put 'w3m-modeline-process-status-on 'risky-local-variable t)
+ (put 'w3m-modeline-process-status-on-icon 'risky-local-variable t))
+ (if (and window-system
+ w3m-show-graphic-icons-in-mode-line
+ w3m-spinner-image-file)
+ (progn
+ (when (stringp w3m-modeline-process-status-on)
+ ;; Save the original status strings as properties.
+ (put 'w3m-modeline-process-status-on 'string
+ w3m-modeline-process-status-on))
+ (setq w3m-modeline-process-status-on
+ '(""
+ w3m-space-before-modeline-icon
+ w3m-modeline-process-status-on-icon)))
+ (when (get 'w3m-modeline-process-status-on 'string)
+ (setq w3m-modeline-process-status-on
+ (get 'w3m-modeline-process-status-on 'string))))))
+
+(defun w3m-make-spinner-image ()
+ "Make an image used to show a spinner.
+It should be called periodically in order to spin the spinner."
+ (when w3m-spinner-image-file
+ (unless (< (incf w3m-spinner-image-index) w3m-spinner-image-frames)
+ (setq w3m-spinner-image-index 0))
+ (let ((image (create-image w3m-spinner-image-file 'gif nil
+ :ascent 'center :mask 'heuristic
+ :index w3m-spinner-image-index)))
+ (setq w3m-modeline-process-status-on-icon
+ (propertize " "
+ 'display image
+ 'local-map w3m-modeline-spinner-map
+ 'help-echo w3m-spinner-map-help-echo))
+ image)))
+
+(provide 'w3m-e23)
+
+;;; w3m-e23.el ends here
![[patchlogo]](http://patch-tracker.debian.org/static/img/swirlpatch.png)