procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge: add word to sentence in trunk/doc/lispintro/emacs-lisp-intro.texi, in section Finding More Information

Browse source
This commit is contained in:
Robert J. Chassell 2010-02-24 22:07:26 +00:00
parent 32e737d7ca
commit 0ca10bb75f
38 changed files with 877198 additions and 15615 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18817
configure vendored
View file

File diff suppressed because it is too large Load diff

2
doc/lispintro/emacs-lisp-intro.texi
View file

@ -4764,7 +4764,7 @@ the @file{/usr/local/share/emacs/} directory; thus you would use the
@code{M-x visit-tags-table} command and specify a pathname such as
@file{/usr/local/share/emacs/22.1.1/lisp/TAGS}. If the tags table
has not already been created, you will have to create it yourself. It
will in a file such as @file{/usr/local/src/emacs/src/TAGS}.
will be in a file such as @file{/usr/local/src/emacs/src/TAGS}.
@need 1250
To create a @file{TAGS} file in a specific directory, switch to that

817351
log-n0.out Normal file
View file

File diff suppressed because it is too large Load diff

10203
share/emacs/site-lisp/w3m/ChangeLog Normal file
View file

File diff suppressed because it is too large Load diff

6731
share/emacs/site-lisp/w3m/ChangeLog.1 Normal file
View file

File diff suppressed because it is too large Load diff

474
share/emacs/site-lisp/w3m/mew-w3m.el Normal file
View file

@ -0,0 +1,474 @@
;; mew-w3m.el --- View Text/Html content with w3m in Mew
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2008, 2009, 2010
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Author: Shun-ichi GOTO <gotoh@taiyo.co.jp>,
;; Hideyuki SHIRAI <shirai@meadowy.org>
;; Created: Wed Feb 28 03:31:00 2001
;; Version: $Revision: 1.69 $
;; Keywords: Mew, mail, 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This package is for viewing formatted (rendered) Text/Html content
;; in Mew's message buffer.
;;; Installation:
;; (1) Simply load this file and add followings in your ~/.mew file.
;;
;; (require 'mew-w3m)
;;
;; (2) And you can use keymap of w3m-mode as mew-w3m-minor-mode.
;; To activate this feaeture, add followings also:
;;
;; (setq mew-use-w3m-minor-mode t)
;; (add-hook 'mew-message-hook 'mew-w3m-minor-mode-setter)
;;
;; (3) If you use mew-1.95b118 or later on which Emacs 21, 22 or XEmacs,
;; can display the images in the Text/Html message.
;; To activate this feaeture, add following in your ~/.mew file.
;;
;; (define-key mew-summary-mode-map "T" 'mew-w3m-view-inline-image)
;;
;; Press "T": Toggle the visibility of the images included its message only.
;; Press "C-uT": Display the all images included its Text/Html part."
;;
;; (4) You can use emacs-w3m to fetch and/or browse
;; `external-body with URL access'. To activate this feaeture,
;; add followings also:
;;
;; (setq mew-ext-url-alist
;; '(("^application/" "Fetch by emacs-w3m" mew-w3m-ext-url-fetch nil)
;; (t "Browse by emacs-w3m" mew-w3m-ext-url-show nil)))
;; or
;; (setq mew-ext-url-alist
;; '((t "Browse by emacs-w3m" mew-w3m-ext-url-show nil)))
;;
;;; Usage:
;; There's nothing special. Browse messages in usual way.
;; On viewing Text/Html file, rendered text is appeared in message
;; buffer instead of usual "HTML" banner.
;; C-c C-e operation is also allowed to view with external browser.
;;
;; If mew-use-w3m-minor-mode is t, key operations of w3m-mode is
;; allowed (as minor-mode-map) and jump links in message buffer.
;; NOTE: This feature is not complete. You may confuse.
;;
;;
;;; Code:
(require 'mew)
(require 'w3m)
(eval-when-compile (require 'cl))
;;; initializer for mew
(defgroup mew-w3m nil
"mew-w3m - Inline HTML rendering extension of Mew"
:group 'w3m)
(defcustom mew-use-w3m-minor-mode nil
"*Use w3m minor mode in message buffer.
Non-nil means that the minor mode whose keymap contains keys binded to
some emacs-w3m commands are activated in message buffer, when viewing
Text/Html contents."
:group 'mew-w3m
:type 'boolean)
(defcustom mew-w3m-auto-insert-image nil
"*If non-nil, images are inserted automatically in Multipart/Related message.
This variable is effective only in XEmacs, Emacs 21 and Emacs 22."
:group 'mew-w3m
:type 'boolean)
(defcustom mew-w3m-cid-retrieve-hook nil
"*Hook run after cid retrieved"
:group 'mew-w3m
:type 'hook)
(defcustom mew-w3m-region-cite-mark "&gt;&nbsp;"
"*Method of converting `blockquote'."
:group 'mew-w3m
:type '(choice (const :tag "Use Indent" nil)
(const :tag "Use Cite Mark \"> \"" "&gt;&nbsp;")
(string :tag "Use Other Mark")))
(defconst mew-w3m-safe-url-regexp "\\`cid:")
;; Avoid bytecompile error and warnings.
(eval-when-compile
(defvar mew-use-text/html)
(unless (fboundp 'mew-current-get-fld)
(autoload 'mew-coding-system-p "mew")
(autoload 'mew-current-get-fld "mew")
(autoload 'mew-current-get-msg "mew")
(autoload 'mew-syntax-get-entry-by-cid "mew")
(defun mew-cache-hit (&rest args) ())))
(defmacro mew-w3m-add-text-properties (props)
`(add-text-properties (point-min)
(min (1+ (point-min)) (point-max))
,props))
(defun mew-w3m-minor-mode-setter ()
"Check message buffer and activate w3m-minor-mode."
(w3m-minor-mode (or (and (get-text-property (point-min) 'w3m)
mew-use-w3m-minor-mode)
0)))
(defvar mew-w3m-use-safe-url-regexp t)
(defun mew-w3m-view-inline-image (&optional allimage)
"Display the images of Text/Html part.
\\<mew-summary-mode-map>
'\\[mew-w3m-view-inline-image]' Toggle display the images included its message only.
'\\[universal-argument]\\[mew-w3m-view-inline-image]' Display the all images included its Text/Html part."
(interactive "P")
(mew-summary-msg-or-part
(if allimage
(let ((mew-use-text/html t)
(mew-w3m-auto-insert-image t)
(mew-w3m-use-safe-url-regexp nil))
(mew-summary-display 'force))
(with-current-buffer (mew-buffer-message)
(let* ((image (get-text-property (point-min) 'w3m-images))
(w3m-display-inline-images image)
(w3m-safe-url-regexp (when mew-w3m-use-safe-url-regexp
mew-w3m-safe-url-regexp)))
(w3m-toggle-inline-images)
(mew-elet
(mew-w3m-add-text-properties `(w3m-images ,(not image)))
(set-buffer-modified-p nil)))))))
(defun mew-w3m-region (start end &optional url charset)
"w3m-region with inserting the cite mark."
(if (null mew-w3m-region-cite-mark)
(w3m-region start end url charset)
(save-restriction
(narrow-to-region start end)
(let ((case-fold-search t)
pos lines tagbeg0 tagend0 tagbeg1 tagend1)
(goto-char (point-min))
(while (w3m-search-tag "blockquote")
(setq tagbeg0 (match-beginning 0))
(setq tagend0 (match-end 0))
(when (w3m-search-tag "/blockquote")
(setq tagbeg1 (match-beginning 0))
(setq tagend1 (match-end 0))
(setq lines (buffer-substring tagend0 tagbeg1))
(delete-region tagbeg0 tagend1)
(insert (with-temp-buffer
(insert lines)
(goto-char (point-min))
(if (and (w3m-search-tag "pre")
(setq tagbeg0 (match-beginning 0))
(setq tagend0 (match-end 0))
(w3m-search-tag "/pre")
(setq tagbeg1 (match-beginning 0))
(setq tagend1 (match-end 0)))
(progn
(delete-region tagbeg1 tagend1)
(delete-region tagbeg0 tagend0))
;; delete <br>
(goto-char (point-min))
(while (w3m-search-tag "br")
(delete-region (match-beginning 0) (match-end 0))
(unless (looking-at "[\n\r]") (insert "\n"))))
(goto-char (point-max))
(skip-chars-backward " \t\n\f\r")
(delete-region (point) (point-max))
(goto-char (point-min))
(skip-chars-forward " \t\n\f\r")
(delete-region (point-min) (point))
(goto-char (point-min))
(while (not (eobp))
(insert mew-w3m-region-cite-mark)
(forward-line 1))
(goto-char (point-min))
(insert "<pre>\n")
(goto-char (point-max))
(insert "\n</pre>\n")
(buffer-substring (point-min) (point-max)))))))
(w3m-region (point-min) (point-max) url charset))))
;; processing Text/Html contents with w3m.
(defun mew-mime-text/html-w3m (&rest args)
"View Text/Html contents with w3m rendering output."
(let ((w3m-display-inline-images mew-w3m-auto-insert-image)
(w3m-safe-url-regexp (when mew-w3m-use-safe-url-regexp
mew-w3m-safe-url-regexp))
w3m-force-redisplay ;; don't redraw
charset wcs xref
cache begin end params execute)
(if (= (length args) 2)
;; Mew-2
(setq begin (nth 0 args) end (nth 1 args))
;; Old Mew
(setq cache (nth 0 args))
(setq begin (nth 1 args))
(setq end (nth 2 args))
(setq params (nth 3 args))
(setq execute (nth 4 args)))
(if (and cache (or execute (<= end begin)))
;; 'C-cC-e' + Old Mew
(apply 'mew-mime-text/html (list cache begin end params execute))
(save-excursion
;; search Xref: Header in SHIMBUN article
(when cache (set-buffer cache))
(goto-char (point-min))
(when (re-search-forward mew-eoh nil t)
(let ((eoh (point))
(case-fold-search t))
(goto-char (point-min))
(when (and (re-search-forward "^X-Shimbun-Id: " eoh t)
(goto-char (point-min))
(re-search-forward "^Xref: \\(.+\\)\n" eoh t))
(setq xref (match-string 1))
(w3m-static-if (fboundp 'match-string-no-properties)
(setq xref (match-string-no-properties 1))
(setq xref (match-string 1))
(set-text-properties 0 (length xref) nil xref))))))
(mew-elet
(cond
((and (null cache) (eq w3m-type 'w3m-m17n))
;; Mew-2 + w3m-m17n.
;; Coding-system and charset are decided by Mew.
(let ((w3m-input-coding-system w3m-input-coding-system)
(w3m-output-coding-system w3m-output-coding-system)
(w3m-halfdump-command-arguments w3m-halfdump-command-arguments))
(when (setq charset (mew-charset-guess-region begin end))
(setq wcs (mew-charset-to-cs charset)))
(when (and charset wcs (mew-coding-system-p wcs))
;; guess correctly and not us-ascii
(setq w3m-input-coding-system wcs)
(setq w3m-output-coding-system wcs)
(setq w3m-halfdump-command-arguments
(list "-halfdump"
"-I" charset "-O" charset
"-o" "ext_halfdump=1"
"-o" "pre_conv=1"
"-o" "strict_iso2022=0")))
(mew-w3m-region begin end xref)))
((null cache) ;; Mew-2 + w3m, w3mmee
(mew-w3m-region begin end xref (mew-charset-guess-region begin end)))
(t ;; Old Mew
(setq charset (or (mew-syntax-get-param params "charset")
(with-current-buffer cache
(mew-charset-guess-region begin end))))
(if charset
(setq wcs (mew-charset-to-cs charset))
(setq wcs mew-cs-text-for-write))
(mew-frwlet
mew-cs-dummy wcs
(mew-w3m-region (point)
(progn (insert-buffer-substring cache begin end)
(point))
xref))))
(mew-w3m-add-text-properties `(w3m t w3m-images ,mew-w3m-auto-insert-image))))))
(defvar w3m-mew-support-cid (and (boundp 'mew-version-number)
(fboundp 'mew-syntax-get-entry-by-cid)))
(defun mew-w3m-cid-retrieve (url &rest args)
(let ((output-buffer (current-buffer)))
(with-current-buffer w3m-current-buffer
(when (and w3m-mew-support-cid
(string-match "^cid:\\(.+\\)" url))
(setq url (match-string 1 url))
(let* ((fld (mew-current-get-fld (mew-frame-id)))
(msg (mew-current-get-msg (mew-frame-id)))
(cache (mew-cache-hit fld msg 'must-hit))
(syntax (mew-cache-decode-syntax cache))
cidstx beg end)
(if (string< "4.0.53" mew-version-number)
(setq cidstx (mew-syntax-get-entry-by-cid syntax (concat "<" url ">")))
(setq cidstx (mew-syntax-get-entry-by-cid syntax url)))
(when cidstx
(setq beg (mew-syntax-get-begin cidstx))
(setq end (mew-syntax-get-end cidstx))
(prog1
(with-current-buffer output-buffer
(set-buffer-multibyte t)
(insert-buffer-substring cache beg end)
(set-buffer-multibyte nil)
(downcase (car (mew-syntax-get-ct cidstx))))
(run-hooks 'mew-w3m-cid-retrieve-hook))))))))
(when w3m-mew-support-cid
(push (cons 'mew-message-mode 'mew-w3m-cid-retrieve)
w3m-cid-retrieve-function-alist))
(defun mew-w3m-ext-url-show (dummy url)
(pop-to-buffer (mew-buffer-message))
(w3m url))
(defun mew-w3m-ext-url-fetch (dummy url)
(lexical-let ((url url)
(name (file-name-nondirectory url))
handler)
(w3m-process-do
(success (prog1
(w3m-download url nil nil handler)
(message "Download: %s..." name)))
(if success
(message "Download: %s...done" name)
(message "Download: %s...failed" name))
(sit-for 1))))
(defun w3m-mail-compose-with-mew (source url charset content-type
to subject other-headers)
"Compose a mail using Mew."
(when (one-window-p)
(split-window))
(select-window (next-window))
(condition-case nil
(unless (and (boundp 'mew-init-p) mew-init-p
(progn
(mew-summary-jump-to-draft-buffer)
(and (eq major-mode 'mew-draft-mode)
(y-or-n-p "Attatch this draft? "))))
(mew-user-agent-compose to subject other-headers))
(quit
(if (y-or-n-p "Create new draft? ")
(mew-user-agent-compose to subject other-headers)
(delete-window)
(error "Abort mail composing"))))
(let* ((basename (file-name-nondirectory (w3m-url-strip-query url)))
(ct (downcase content-type))
(mew-attach-move-next-after-copy nil)
(i 1)
(pos -1)
(csorig (mew-charset-to-cs (symbol-name charset)))
last filename cs)
(unless (mew-attach-p)
(mew-draft-prepare-attachments))
;; goto last attachment
(setq last (catch 'last
(while (not (= pos (point)))
(setq i (1+ i))
(mew-attach-goto-number 'here `(,i))
(when (mew-attach-line-lastp)
(throw 'last t)))))
(when (eq csorig mew-cs-unknown)
(setq csorig nil))
(if (or (not last) (not (mew-attach-not-line012-1)))
(message "Can not attach from emacs-w3m here!")
;; Application/.*xml is not inline view with Mew.
(cond
((string= "application/xhtml+xml" ct)
(setq ct "text/html"))
((string-match "^application/.*xml$" ct)
(setq ct "text/xml")))
(setq filename (expand-file-name (cond
((and (string-match "^[\t ]*$" basename)
(string= ct "text/html"))
"index.html")
((and (string-match "^[\t ]*$" basename)
(string= ct "text/xml"))
"index.xml")
((string-match "^[\t ]*$" basename)
"dummy")
(t
basename))
mew-temp-dir))
(with-temp-buffer
(cond
((string= "text/html" ct)
(insert source)
(setq cs (w3m-static-if (fboundp 'mew-text/html-detect-cs)
(mew-text/html-detect-cs (point-min) (point-max))))
(when (or (eq cs mew-cs-unknown) (not cs))
(cond
(csorig
(setq cs csorig))
(t
(setq cs mew-cs-autoconv)))))
((string= "text/xml" ct)
(insert source)
(setq cs (w3m-static-if (fboundp 'mew-text/html-detect-cs)
(mew-text/html-detect-cs (point-min) (point-max))))
(when (or (eq cs mew-cs-unknown) (not cs))
(cond
(csorig
(setq cs csorig))
((mew-coding-system-p 'utf-8)
(setq cs 'utf-8))
(t
(setq cs mew-cs-autoconv)))))
((string-match "^text/" ct)
(insert source)
(setq cs mew-cs-autoconv))
(t
(mew-set-buffer-multibyte nil)
(insert source)
(setq cs mew-cs-binary)))
(setq charset (cond
((eq cs mew-cs-autoconv)
(mew-charset-guess-region (point-min) (point-max)))
((eq cs mew-cs-binary)
nil)
(t
(mew-cs-to-charset cs))))
(mew-frwlet
mew-cs-text-for-read cs
(write-region (point-min) (point-max) filename nil 'nomsg)))
(when ct
(setq ct (mew-capitalize ct)))
(mew-attach-copy filename (file-name-nondirectory filename))
;; content-type check & set
(let* ((nums (mew-syntax-nums))
(syntax (mew-syntax-get-entry mew-encode-syntax nums))
(file (mew-syntax-get-file syntax))
(ctl (mew-syntax-get-ct syntax))
(ct-orig (mew-syntax-get-value ctl 'cap))
cte)
(unless (string= ct ct-orig)
(setq ctl (list ct))
(mew-syntax-set-ct syntax ctl)
(setq cte (mew-ctdb-cte (mew-ctdb-by-ct ct)))
(mew-syntax-set-cte syntax cte)
(mew-syntax-set-cdp syntax (mew-syntax-cdp-format ct file))
(mew-encode-syntax-print mew-encode-syntax)))
;; charset set
(let* ((nums (mew-syntax-nums))
(syntax (mew-syntax-get-entry mew-encode-syntax nums))
(file (mew-syntax-get-file syntax))
(ctl (mew-syntax-get-ct syntax))
(ct (mew-syntax-get-value ctl 'cap))
(params (mew-syntax-get-params ctl))
(ocharset "charset"))
(when (and (string-match "^Text" ct) charset)
(setq params (mew-delete ocharset params))
(setq ctl (cons ct (cons (list ocharset charset) params)))
(mew-syntax-set-ct syntax ctl))
(mew-syntax-set-cd syntax url)
(mew-encode-syntax-print mew-encode-syntax))
(message "Compose a mail using Mew with %s...done" url)
(when (and (file-exists-p filename) (file-writable-p filename))
(delete-file filename)))))
;;;
(provide 'mew-w3m)
;; mew-w3m.el ends here

227
share/emacs/site-lisp/w3m/mime-w3m.el Normal file
View file

@ -0,0 +1,227 @@
;;; mime-w3m.el --- mime-view content filter for text
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2009
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>,
;; Akihiro Arisawa <ari@mbf.sphere.ne.jp>
;; Keywords: HTML, MIME, multimedia, mail, news
;; This file is *NOT* yet part of SEMI (Suite of Emacs MIME Interfaces).
;; 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Install:
;; (1) Install SEMI.
;; (2) Put this file to appropriate directory.
;; (3) Write these following code to your ~/.emacs or ~/.gnus.
;;
;; (require 'mime-w3m)
;;; Code:
(eval-when-compile
(require 'cl)
;; mime-parse.el should be loaded before mime.el so as not to make
;; `mime-uri-parse-cid' an autoloaded function to which the byte
;; compiler might issue a nonsense warning.
(require 'mime-parse)
(require 'mime)
(require 'w3m)
(defvar mime-preview-condition)
(defvar mime-setup-enable-inline-html)
(defvar mime-view-mode-default-map))
(eval-and-compile
(when (featurep 'xemacs)
(require 'font)))
(defcustom mime-w3m-display-inline-images 'default
"*Non-nil means that inline images are displayed.
When this option is equal to `default',
`w3m-default-display-inline-images' is refered instead of this option,
to decide whether inline images are displayed."
:group 'w3m
:group 'mime-view
:type '(radio (const :format "%v " nil)
(sexp :format "non-nil "
:match
(lambda (widget value)
(and value (not (eq value 'default))))
:value-to-internal
(lambda (widget value)
(if (and value (not (equal value "default")))
(widget-sexp-value-to-internal widget value)
"t")))
(const default)))
(defcustom mime-w3m-safe-url-regexp "\\`cid:"
"*Regexp that matches safe url names.
Some HTML mails might have the trick of spammers using <img> tags. It
is likely to be intended to verify whether you have read the mail.
You can prevent your personal informations from leaking by setting
this to the regexp which matches the safe url names. The value of the
variable `w3m-safe-url-regexp' will be bound with this value. You may
set this value to nil if you consider all the urls to be safe."
:group 'mime-w3m
:type '(choice (regexp :format "%t: %v\n" :size 0)
(const :tag "All URLs are safe" nil)))
(defcustom mime-w3m-after-cursor-move-hook
'(w3m-print-this-url)
"*Hook run each time after the cursor moves in mime-w3m buffers.
This hook is called by the `mime-w3m-check-current-position' function
by way of `post-command-hook'."
:group 'mime-w3m
:type 'hook)
(defcustom mime-w3m-setup-hook nil
"*Hook run at the end of function `mime-w3m-setup'."
:group 'mime-w3m
:type 'hook)
(defvar mime-w3m-message-structure nil)
(make-variable-buffer-local 'mime-w3m-message-structure)
(defun mime-w3m-insinuate ()
"Insinuate `mime-w3m' module to SEMI."
(setq mime-setup-enable-inline-html nil)
(let (flag)
(when (boundp 'mime-preview-condition)
(labels ((overwrite (x)
(if (symbolp x)
(if (eq x 'mime-preview-text/html)
(setq flag 'mime-w3m-preview-text/html)
(when (eq x 'mime-w3m-preview-text/html)
(setq flag t))
x)
(if (consp x)
(cons (overwrite (car x)) (overwrite (cdr x)))
x))))
(setq mime-preview-condition
(overwrite mime-preview-condition))))
(unless flag
(eval-after-load "mime-view"
'(progn
(ctree-set-calist-strictly
'mime-preview-condition
'((type . text)
(subtype . html)
(body . visible)
(body-presentation-method . mime-w3m-preview-text/html)))
(set-alist 'mime-view-type-subtype-score-alist
'(text . html) 3))))))
(defun mime-w3m-setup ()
"Setup `mime-w3m' module."
(require 'w3m)
(when (eq mime-w3m-display-inline-images 'default)
(setq mime-w3m-display-inline-images w3m-default-display-inline-images))
(unless (assq 'mime-view-mode w3m-cid-retrieve-function-alist)
(push (cons 'mime-view-mode 'mime-w3m-cid-retrieve)
w3m-cid-retrieve-function-alist))
(run-hooks 'mime-w3m-setup-hook))
(def-edebug-spec mime-w3m-save-background-color t)
(defmacro mime-w3m-save-background-color (&rest body)
(if (featurep 'xemacs)
`(let ((color (color-name (face-background 'default))))
(prog1
(progn ,@body)
(font-set-face-background 'default color (current-buffer))))
(cons 'progn body)))
;;;###autoload
(defun mime-w3m-preview-text/html (entity situation)
(mime-w3m-setup)
(setq mime-w3m-message-structure (mime-find-root-entity entity))
(let ((p (point))
(xref
(or (mime-entity-fetch-field entity "xref")
(mime-entity-fetch-field mime-w3m-message-structure "xref"))))
(goto-char p)
(insert "\n")
(goto-char p)
(mime-w3m-save-background-color
(save-restriction
(narrow-to-region p p)
(mime-insert-text-content entity)
(run-hooks 'mime-text-decode-hook)
(condition-case err
(let ((w3m-safe-url-regexp mime-w3m-safe-url-regexp)
(w3m-display-inline-images mime-w3m-display-inline-images)
w3m-force-redisplay)
(w3m-region p (point-max)
(and (stringp xref)
(string-match "\\`http://" xref)
xref)
(mime-content-type-parameter
(mime-entity-content-type entity)
"charset"))
(add-text-properties p (point-max)
(list 'keymap w3m-minor-mode-map
'text-rendered-by-mime-w3m t)))
(error (message "%s" err)))))))
(let (current-load-list)
(defadvice mime-display-message
(after mime-w3m-add-local-hook activate compile)
"Advised by emacs-w3m.
Set hooks run arround each command is executed."
(when (featurep 'w3m)
(w3m-add-local-hook 'pre-command-hook
'w3m-store-current-position)
(w3m-add-local-hook 'post-command-hook
'mime-w3m-check-current-position))))
(defun mime-w3m-check-current-position ()
"Run `mime-w3m-after-cursor-move-hook' if the cursor has been moved."
(when (and (/= (point) (car w3m-current-position))
(ignore-errors
(or (get-text-property (point)
'text-rendered-by-mime-w3m)
(get-text-property (car w3m-current-position)
'text-rendered-by-mime-w3m))))
(run-hooks 'mime-w3m-after-cursor-move-hook)))
(defun mime-w3m-cid-retrieve (url &rest args)
(let ((entity (mime-find-entity-from-content-id
(mime-uri-parse-cid url)
(with-current-buffer w3m-current-buffer
mime-w3m-message-structure))))
(when entity
;; `mime-decode-string' should be performed in a unibyte buffer.
(w3m-insert-string (mime-entity-content entity))
(mime-entity-type/subtype entity))))
(let (current-load-list)
(defadvice kill-new (before strip-keymap-properties-from-kill activate)
"Advised by emacs-w3m.
Strip `keymap' or `local-map' properties from a killed string."
(if (text-property-any 0 (length (ad-get-arg 0))
'text-rendered-by-mime-w3m t (ad-get-arg 0))
(remove-text-properties 0 (length (ad-get-arg 0))
'(keymap nil local-map nil)
(ad-get-arg 0)))))
(mime-w3m-insinuate)
(provide 'mime-w3m)
;;; mime-w3m.el ends here

547
share/emacs/site-lisp/w3m/octet.el Normal file
View file

@ -0,0 +1,547 @@
;;; octet.el --- An octet stream viewer.
;; Copyright (C) 2000, 2002, 2003, 2004, 2005
;; Yuuichi Teranishi <teranisi@gohome.org>
;; Author: Yuuichi Teranishi <teranisi@gohome.org>
;; Created: 2000/05/19
;; Keywords: octet-stream, broken document
;; 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 GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;; Display application/octet-stream inline on the emacs buffer.
;;
;; This program requires:
;;
;; emacs-w3m for HTML rendereing.
;; (http://emacs-w3m.namazu.org/)
;; Mule-UCS for UTF-8 decoding.
;; (ftp://ftp.m17n.org/pub/mule/Mule-UCS/)
;; wvHtml for MS Word document.
;; (http://www.wvware.com/)
;; xlHtml for MS Excel document.
;; (http://chicago.sourceforge.net/xlhtml/)
;; pptHtml for MS PowerPoint document.
;; (http://chicago.sourceforge.net/xlhtml/)
;; gunzip for decoding gzipped file.
;; bunzip2 for decoding bzip2ed file.
;; Put follwing line in your setting file:
;;
;; (require 'octet)
;;
;; To display octet data file, execute following command.
;;
;; M-x octet-find-file
;;
;; If you use SEMI, put following lines in your setting file:
;;
;; (require 'octet)
;; (octet-mime-setup)
;;
;; Then you can toggle displaying application/octet-stream messages.
;;; History:
;;
;; This file is created in 2000/05/19.
;; All part was rewrote in 2002/01/28.
;; Added to emacs-w3m repository in 2002/01/29.
;;; Code:
(eval-when-compile
(require 'cl))
(require 'poe) ; for compatibility
(require 'pces) ; as-binary-process
(require 'mime) ; SEMI
(require 'static)
(require 'w3m-util); w3m-insert-string
(defvar octet-temp-directory temporary-file-directory
"A directory to create temporal files.")
(defvar octet-html-render-function 'octet-w3m-region
"A function for HTML rendering.")
(defvar octet-suffix-type-alist
'(("xls" . msexcel)
("ppt" . msppt)
("doc" . msword)
("gz" . gzip)
("bz2" . bzip2)
("html" . html)
("jpg" . jpeg)
("jpeg" . jpeg)
("gif" . gif)
("png" . png)
("tif" . tiff)
("tiff" . tiff)
("txt" . text)
("lzh" . lzh)
("tar" . tar)
("pdf" . pdf))
"Alist of suffix-to-octet-type.")
(defvar octet-content-type-alist
'(("application/vnd\\.ms-excel" . msexcel)
("application/vnd\\.ms-powerpoint" . msppt)
("application/x-msexcel" . msexcel)
("application/msword" . msword)
("image/jpeg" . jpeg)
("image/gif" . gif)
("image/png" . png)
("image/tiff" . tiff)
("audio/midi" . ignore)
("video/mpeg" . ignore)
("text/html" . html-un)
("application/x-tar" . tar)
("application/pdf" . pdf))
"Alist of content-type-regexp-to-octet-type.")
(defvar octet-magic-type-alist
'(("^\377\330\377[\340\356]..JFIF" image jpeg)
("^\211PNG" image png)
("^GIF8[79]" image gif)
("^II\\*\000" image tiff)
("^MM\000\\*" image tiff)
("^MThd" audio midi)
("^\000\000\001\263" video mpeg)
("^<!doctype html" text html)
("^<head" text html)
("^<title" text html)
("^<html" text html))
"*Alist of regexp about magic-number vs. corresponding content-types.
Each element looks like (REGEXP TYPE SUBTYPE).
REGEXP is a regular expression to match against the beginning of the
content of entity.
TYPE is symbol to indicate primary type of content-type.
SUBTYPE is symbol to indicate subtype of content-type.")
(defvar octet-type-filter-alist
`((msexcel octet-filter-call1 "xlhtml" ("-te") html-u8)
(msppt octet-filter-call1 "ppthtml" nil html-u8)
(msword octet-filter-call2-extra "wvHtml" nil html-u8)
(html octet-render-html nil nil nil)
(html-u8 octet-decode-u8-text nil nil html)
(html-un octet-decode-text nil nil html)
(gzip octet-filter-call1 "gunzip" ("-c") guess)
(bzip2 octet-filter-call1 "bunzip2" ("-c") guess)
(text octet-decode-text nil nil nil)
(ignore ignore nil nil nil)
(jpeg octet-decode-image nil jpeg nil)
(gif octet-decode-image nil gif nil)
(png octet-decode-image nil png nil)
(tiff octet-decode-image nil tiff nil)
(guess octet-filter-guess nil nil nil)
(lzh octet-filter-call1 "lha" ("-v") text)
(tar octet-tar-mode nil nil nil)
(pdf octet-filter-call2 "pdftotext" ("-q" "-eucjp" "-raw") text))
"Alist of type-to-filter-program.
Each element should have the form like:
\(TYPE FUNCTION FILTER_PROGRAM ARGUMENT NEW-TYPE\)
nil in NEW-TYPE means filtering is completed.")
(defvar octet-find-file-hook nil)
(defvar octet-attachments nil)
(make-variable-buffer-local 'octet-attachments)
(defun octet-render-html (&rest args)
(funcall octet-html-render-function (point-min) (point-max))
0)
(defun octet-decode-text (&rest args)
(let ((string (buffer-string)))
(erase-buffer)
(set-buffer-multibyte t)
(insert (decode-coding-string string 'undecided)))
0)
;;; HTML rendering by w3m.el
(defun w3m-about-octet-attachments (url &optional no-decode no-cache
&rest args)
(let (buffer attachments pair)
(set-buffer-multibyte nil)
(when (string-match "\\`about://octet-attachments/\\([^/]+\\)/" url)
(setq buffer (get-buffer (base64-decode-string (match-string 1 url)))
url (substring url (match-end 0))
attachments (with-current-buffer buffer
octet-attachments))
(when (and buffer attachments
(setq pair (assoc url attachments)))
(insert (cdr pair)))))
(car (funcall (symbol-function 'w3m-local-file-type) url)))
(defun octet-w3m-region (beg end)
(let ((w3m-display-inline-images t)
(w3m-url-hierarchical-schemes '("about")))
(funcall (symbol-function 'w3m-region)
beg end (concat "about://octet-attachments/"
(base64-encode-string
(buffer-name (current-buffer))) "/"))
(setq octet-attachments nil))
0)
;; Decode image
(static-cond
((featurep 'xemacs)
(defun octet-decode-image (ignore &rest args)
(let (glyph)
(if (memq (car args) (image-instantiator-format-list))
(progn
(setq glyph (make-glyph (vector (car args) :data (buffer-string))))
(if glyph
(progn (erase-buffer)
(set-extent-end-glyph
(make-extent (point-min)(point-min))
glyph)
0)
1))
1))))
(t
(defun octet-decode-image (ignore &rest args)
(let (image)
(if (image-type-available-p (car args))
(progn
(setq image (create-image (buffer-string) (car args) 'data))
(if image
(progn (erase-buffer)
(insert-image image) 0)
1))
1)))))
(defun octet-decode-u8-text (&rest args)
(let ((string (buffer-string)))
(erase-buffer)
(set-buffer-multibyte t)
(insert (decode-coding-string string 'utf-8)))
0)
(defun octet-filter-call2 (filter &optional args)
"Call octed filter with two arguments (infile, outfile).
Current buffer content is replaced.
Returns 0 if succeed."
(let ((infile (file-name-nondirectory
(make-temp-file (expand-file-name "octet"
octet-temp-directory))))
(outfile (file-name-nondirectory
(make-temp-file (expand-file-name "octet"
octet-temp-directory))))
(last-dir default-directory)
result)
(cd octet-temp-directory)
(write-region-as-binary (point-min) (point-max) infile nil 'no-msg)
(unwind-protect
(progn
(as-binary-process
(setq result (apply 'call-process filter nil nil nil
(append args (list infile outfile)))))
(when (and (numberp result)
(zerop result))
(erase-buffer)
(insert-file-contents-as-binary outfile))
0)
(if (file-exists-p infile) (delete-file infile))
(if (file-exists-p outfile) (delete-file outfile))
(cd last-dir))))
(defun octet-filter-call2-extra (filter &optional args)
"Call octed filter with two arguments (infile, outfile).
Current buffer content is replaced.
Also, exta attachments are collected to `octet-attachments'.
Returns 0 if succeed."
(let ((infile (file-name-nondirectory
(make-temp-file (expand-file-name "octet"
octet-temp-directory))))
(outfile (file-name-nondirectory
(make-temp-file (expand-file-name "octet"
octet-temp-directory))))
(last-dir default-directory)
result)
(cd octet-temp-directory)
(write-region-as-binary (point-min) (point-max) infile nil 'no-msg)
(unwind-protect
(progn
(as-binary-process
(setq result (apply 'call-process filter nil nil nil
(append args (list infile outfile)))))
(when (and (numberp result)
(zerop result))
(erase-buffer)
(insert-file-contents-as-binary outfile)
(dolist (attach (directory-files "." nil (concat
(regexp-quote outfile)
".*\\..*")))
(setq octet-attachments
(cons (cons
attach
(with-temp-buffer
(insert-file-contents-as-binary attach)
(buffer-string)))
octet-attachments))
(if (file-exists-p attach) (delete-file attach))
))
0)
(if (file-exists-p infile) (delete-file infile))
(if (file-exists-p outfile) (delete-file outfile))
(cd last-dir))))
(defun octet-filter-call1 (filter &optional args)
"Call external octed filter with two arguments (infile) and obtain stdout.
Current buffer content is replaced.
Returns 0 if succeed."
(let ((infile (file-name-nondirectory
(make-temp-file (expand-file-name "octet"
octet-temp-directory))))
(last-dir default-directory)
result)
(cd octet-temp-directory)
(write-region-as-binary (point-min) (point-max) infile nil 'no-msg)
(unwind-protect
(progn
(erase-buffer)
(as-binary-process
(setq result (apply 'call-process filter nil t nil
(append args (list infile)))))
(if (numberp result) result 1))
(if (file-exists-p infile) (delete-file infile))
(cd last-dir))))
(defun octet-filter-guess (&rest args)
(let (buffer-file-name)
(octet-buffer)
0))
(defun octet-tar-mode (&rest args)
(funcall (symbol-function 'tar-mode))
0)
(defun octet-guess-type-from-name (name)
(when (string-match "\\.\\([a-z0-9]+\\)\\'" name)
(cdr (assoc (downcase (match-string 1 name))
octet-suffix-type-alist))))
(defun octet-guess-type-from-content-type (content-type)
(let ((alist octet-content-type-alist)
type)
(while alist
(when (string-match (car (car alist)) content-type)
(setq type (cdr (car alist))
alist nil))
(setq alist (cdr alist)))
type))
(defun octet-guess-type-from-magic ()
(let ((rest octet-magic-type-alist)
type subtype)
(goto-char (point-min))
(while (not (let ((cell (car rest)))
(if cell
(if (looking-at (car cell))
(setq type (nth 1 cell)
subtype (nth 2 cell)))
t)))
(setq rest (cdr rest)))
(if type
(octet-guess-type-from-content-type
(concat (symbol-name type) "/" (symbol-name subtype))))))
(defun octet-filter-buffer (type)
"Call a filter function in `octet-type-filter-alist'.
TYPE is the symbol of type.
Returns NEW-TYPE."
(let ((elem (assq type octet-type-filter-alist)))
(if (zerop (apply (nth 1 elem) (list (nth 2 elem) (nth 3 elem))))
(nth 4 elem))))
;;;###autoload
(defun octet-buffer (&optional name content-type)
"View octet-stream content according to `octet-type-filter-alist'.
Optional NAME is the filename.
If optional CONTENT-TYPE is specified, it is used for type guess."
(interactive)
(let ((type (or (and content-type
(octet-guess-type-from-content-type
content-type))
(octet-guess-type-from-magic)
(and (or name buffer-file-name)
(octet-guess-type-from-name
(or name buffer-file-name)))
(intern (condition-case nil
(completing-read "Octet Type(text): "
(mapcar
(lambda (pair)
(list (symbol-name
(cdr pair))))
octet-suffix-type-alist)
nil 'require-match nil nil
"text")
(quit "text"))))))
(while (setq type (octet-filter-buffer type)))))
(static-if (featurep 'xemacs)
(defun octet-insert-buffer (from)
"Insert after point the contents of BUFFER and the image."
(let (extent glyph)
(with-current-buffer from
(if (setq extent (extent-at (point-min) nil nil nil 'at))
(setq glyph (extent-end-glyph extent))))
(insert-buffer-substring from)
(if glyph
(set-extent-end-glyph (make-extent (point) (point))
glyph))))
(defalias 'octet-insert-buffer 'insert-buffer))
;;;###autoload
(defun octet-find-file (file)
"Find FILE with octet-stream decoding."
(interactive "fFilename: ")
(as-binary-input-file (find-file file))
(unwind-protect
(let (buffer-read-only)
(octet-buffer))
(goto-char (point-min))
(set-buffer-modified-p nil)
(auto-save-mode -1)
(setq buffer-read-only t
truncate-lines t)
(run-hooks 'octet-find-file-hook)))
;;;
;; Functions for SEMI.
;;
(defvar mime-preview-octet-hook nil)
(defvar mime-view-octet-hook nil)
;;;###autoload
(defun mime-preview-octet (entity situation)
"A method for mime-view to preview octet message."
(goto-char (point-max))
(let ((p (point))
(name (mime-entity-filename entity))
from-buf to-buf)
(insert "\n")
(goto-char p)
(save-restriction
(narrow-to-region p p)
(setq to-buf (current-buffer))
(with-temp-buffer
(setq from-buf (current-buffer))
(w3m-insert-string (mime-entity-content entity))
(octet-buffer name (mime-entity-type/subtype entity))
(with-current-buffer to-buf
(octet-insert-buffer from-buf)
(run-hooks 'mime-preview-octet-hook))))))
;;;###autoload
(defun mime-view-octet (entity situation)
"A method for mime-view to display octet message."
(let (type subtype)
(let ((mdata (mime-entity-content entity))
(rest octet-magic-type-alist))
(while (not (let ((cell (car rest)))
(if cell
(if (string-match (car cell) mdata)
(setq type (nth 1 cell)
subtype (nth 2 cell)))
t)))
(setq rest (cdr rest)))
(if type
(progn
(setq situation (del-alist 'method (copy-alist situation)))
(funcall (symbol-function 'mime-play-entity)
entity
(put-alist 'type type
(put-alist 'subtype subtype
situation))
'mime-view-octet))
(let ((buf (get-buffer-create
(format "%s-%s" (buffer-name) (mime-entity-number entity))))
(name (mime-entity-filename entity)))
(with-current-buffer buf
(set-buffer-multibyte nil)
(setq buffer-read-only nil)
(erase-buffer)
(w3m-insert-string mdata)
(octet-buffer name (mime-entity-type/subtype entity))
(setq buffer-read-only t
truncate-lines t)
(set-buffer-multibyte t)
(set-buffer-modified-p nil))
(let ((win (get-buffer-window (current-buffer))))
(or (eq (selected-window) win)
(select-window (or win (get-largest-window)))))
(view-buffer buf)
(run-hooks 'mime-view-octet-hook)
(goto-char (point-min)))))))
;;;###autoload
(defun octet-mime-setup ()
"Octet setting for MIME module."
(eval-after-load "mime-view"
'(progn
(ctree-set-calist-strictly
'mime-acting-condition
'((mode . "play")
(type . application)(subtype . msword)
(method . mime-view-octet)))
(ctree-set-calist-strictly
'mime-acting-condition
'((mode . "play")
(type . application)(subtype . excel)
(method . mime-view-octet)))
(ctree-set-calist-strictly
'mime-acting-condition
'((mode . "play")
(type . application)(subtype . x-msexcel)
(method . mime-view-octet)))
(ctree-set-calist-strictly
'mime-acting-condition
'((mode . "play")
(type . application)(subtype . vnd.ms-excel)
(method . mime-view-octet)))
(ctree-set-calist-strictly
'mime-acting-condition
'((mode . "play")
(type . application)(subtype . vnd.ms-powerpoint)
(method . mime-view-octet)))
(ctree-set-calist-strictly
'mime-acting-condition
'((mode . "play")
(type . application)(subtype . octet-stream)
(method . mime-view-octet)))
(ctree-set-calist-strictly
'mime-preview-condition
'((type . application)(subtype . t)
(encoding . t)
(body . invisible)
(body-presentation-method . mime-preview-octet)))
;; another condition?
)))
(provide 'octet)
;;; octet.el ends here

659
share/emacs/site-lisp/w3m/w3m-antenna.el Normal file
View file

@ -0,0 +1,659 @@
;;; w3m-antenna.el --- Utility to detect changes of WEB
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; w3m-antenna.el is the add-on utility of emacs-w3m to detect changes
;; of WEB pages. For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; How to install:
;; Please put this file to appropriate directory, and if you want
;; byte-compile it. And add following lisp expressions to your
;; ~/.emacs.
;;
;; (autoload 'w3m-antenna "w3m-antenna" "Report changes of WEB sites." t)
;;; Code:
(eval-when-compile (require 'cl))
(require 'w3m-util)
(require 'w3m-rss)
(require 'w3m)
(defgroup w3m-antenna nil
"w3m-antenna - Utility to detect changes of WEB."
:group 'w3m
:prefix "w3m-antenna-")
(define-widget 'w3m-antenna-string 'string
"String widget with default value.
When creating a new widget, its value is given by an expression specified
with :value-from."
:tag "URL"
:value-from nil
:create 'w3m-antenna-string-create)
(defun w3m-antenna-string-create (widget)
(if (string= "" (widget-get widget :value))
;; No value is given.
(widget-put widget :value
(let* ((symbol (widget-get widget :value-from))
(value (eval symbol)))
(if value
(set symbol nil)
(setq value ""))
value)))
(widget-default-create widget))
(eval-when-compile
;; Compiler warning in Emacs 19.
(autoload 'widget-default-get "wid-edit"))
(apply 'define-widget 'w3m-antenna-function 'function
"Bug-fixed version of the `function' widget.
In Emacs 20.7 through 21.4 and XEmacs, it doesn't represent a value as
a string internally, converts it into a string in the customization
buffer, and provides the default value as `ignore'."
(if (and (fboundp 'widget-default-get)
(widget-default-get
'(function :value-to-external ignore :value foo)))
'(:value-create
(lambda (widget)
(widget-put widget :value
(widget-sexp-value-to-internal widget value))
(widget-field-value-create widget))
:value-to-internal
(lambda (widget value) value)
:value ignore)))
(defvar w3m-antenna-alist nil
"A list of site information (internal variable). nil means that
antenna database is not initialized. Each site information is a list
that consists of:
0. Format string of URL.
1. Title.
2. Class (Normal, HNS or TIME).
3. Real URL.
4. Last modification time.
5. Size in bytes.
6. Time when size modification is detected.
")
(defmacro w3m-antenna-site-key (site)
`(car ,site))
(defmacro w3m-antenna-site-title (site)
`(nth 1 ,site))
(defmacro w3m-antenna-site-class (site)
`(nth 2 ,site))
(defmacro w3m-antenna-site-url (site)
`(nth 3 ,site))
(defmacro w3m-antenna-site-last-modified (site)
`(nth 4 ,site))
(defmacro w3m-antenna-site-size (site)
`(nth 5 ,site))
(defmacro w3m-antenna-site-size-detected (site)
`(nth 6 ,site))
(defcustom w3m-antenna-file
(expand-file-name ".antenna" w3m-profile-directory)
"File which has list of antenna URLs."
:group 'w3m-antenna
:type '(file :size 0))
(defcustom w3m-antenna-refresh-interval nil
"Interval time to update (to refresh) the antenna page automatically.
The value should be a positive integer in seconds, or nil which means
not to update the page."
:group 'w3m-antenna
:type '(choice
(const :tag "Not reload." nil)
(integer :tag "Interval second.")))
(defcustom w3m-antenna-sites
(unless noninteractive
(mapcar (lambda (site)
(list (w3m-antenna-site-key site)
(w3m-antenna-site-title site)
(w3m-antenna-site-class site)))
(w3m-load-list w3m-antenna-file)))
"List of WEB sites, watched by `w3m-antenna'."
:group 'w3m-antenna
:type `(repeat
(group
:indent 7
(w3m-antenna-string :format "URL: %v\n" :size 0
:value-from w3m-antenna-tmp-url)
(w3m-antenna-string :format "Title: %v\n" :size 0
:value-from w3m-antenna-tmp-title)
(choice
:tag "Procedure"
(const :tag "Check either its last modified time or its size" nil)
(const :tag "Check its last modified time only" time)
(const :tag "Check its current date provided by Hyper Nikki System"
hns)
(list :tag "Check RSS"
(function-item :format "" w3m-antenna-check-rss)
(string :format "URL: %v\n" :value ""))
(list :tag "Check the another changelog page"
(function-item :format "" w3m-antenna-check-another-page)
(string :format "URL: %v\n" :value ""))
(list :tag "Check the page linked by the anchor that matches"
(function-item :format "" w3m-antenna-check-anchor)
(regexp :value "")
(integer :value 0))
(cons :tag "Check with a user defined function"
(w3m-antenna-function
:match (lambda (widget value)
(and (functionp value)
(not (memq value
'(w3m-antenna-check-rss
w3m-antenna-check-another-page
w3m-antenna-check-anchor))))))
(repeat :tag "Arguments" sexp))))))
(defcustom w3m-antenna-html-skelton
(eval-when-compile
(concat "<!doctype html public \"-//W3C//DTD HTML 3.2//EN\">\n"
"<html>\n<head>\n<title>Antenna</title>\n%R</head>\n<body>\n"
"<h1>Antenna</h1>\n<p align=\"right\">Checked at %D.</p>\n"
"<h2>Updated</h2>\n<ul>\n%C</ul>\n"
"<h2>Visited</h2>\n<ul>\n%U</ul>\n"
"</body>\n</html>\n"))
"HTML skelton of antenna."
:group 'w3m-antenna
:type 'string)
(defcustom w3m-antenna-make-summary-function
'w3m-antenna-make-summary-like-natsumican
"Function to make summary of site information."
:group 'w3m-antenna
:type '(choice
:format "%{%t%}:\n %[Value Menu%] %v"
(function-item :tag "Simple style." w3m-antenna-make-summary)
(function-item :tag "Natsumican style."
w3m-antenna-make-summary-like-natsumican)
(function :format "User function: %v\n" :size 0)))
(defcustom w3m-antenna-sort-changed-sites-function
'w3m-antenna-sort-sites-by-time
"Function to sort list of changed sites."
:group 'w3m-antenna
:type '(choice
:format "%{%t%}:\n %[Value Menu%] %v"
(function-item :tag "Sort by last modification time."
w3m-antenna-sort-sites-by-time)
(function-item :tag "Sort by title." w3m-antenna-sort-sites-by-title)
(function-item :tag "Do nothing." identity)
(function :format "User function: %v\n" :size 0)))
(defcustom w3m-antenna-sort-unchanged-sites-function
'w3m-antenna-sort-sites-by-time
"Function to sort list of unchanged sites."
:group 'w3m-antenna
:type '(choice
:format "%{%t%}:\n %[Value Menu%] %v"
(function-item :tag "Sort by last modification time."
w3m-antenna-sort-sites-by-time)
(function-item :tag "Sort by title." w3m-antenna-sort-sites-by-title)
(function-item :tag "Do nothing." identity)
(function :format "User function: %v\n" :size 0)))
(defun w3m-antenna-alist ()
(let ((alist (w3m-load-list w3m-antenna-file)))
(mapcar (lambda (site)
(let ((l (assoc (w3m-antenna-site-key site) alist)))
(if l
(progn
(setf (w3m-antenna-site-class l)
(w3m-antenna-site-class site))
l)
(append site (list nil nil nil nil)))))
w3m-antenna-sites)))
(defun w3m-antenna-hns-last-modified (url handler)
(w3m-process-do-with-temp-buffer
(type (w3m-retrieve (w3m-expand-url "di.cgi" url) nil t nil nil handler))
(when type
(or (let (start str)
;; Process a line such as "Tue, 27 Mar 2001 12:43:16 GMT<br>".
(goto-char (point-min))
(and
(search-forward "\nLast-Modified: " nil t)
(setq start (match-end 0))
(search-forward "<br>" nil t)
(setq str (buffer-substring start (match-beginning 0)))
;; Ignore format such as "2001, 27 03 GMT", which is used
;; by old HNS.
(not (string-match
" *[0-9][0-9][0-9][0-9], +[0-9][0-9] +[0-9][0-9] +" str))
(w3m-time-parse-string str)))
(progn
;; Process a line such as "newest day is 2001/03/15".
(goto-char (point-min))
(and
(re-search-forward "\
^newest day is \\([0-9][0-9][0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([0-9][0-9]\\)$"
nil t)
(encode-time 0 0 0
(string-to-number (match-string 3))
(string-to-number (match-string 2))
(string-to-number (match-string 1))
32400)))))))
(defun w3m-antenna-check-hns (site handler)
"Check the page served by HNS (Hyper Nikki System) asynchronously."
(lexical-let ((site site))
(w3m-process-do
(time
(w3m-antenna-hns-last-modified (w3m-antenna-site-key site) handler))
(if time
(w3m-antenna-site-update site (w3m-antenna-site-key site) time nil)
(w3m-antenna-check-page site handler)))))
(defun w3m-antenna-check-rss (site handler url)
"Check RSS to detect change of SITE asynchronously.
In order to use this function, `xml.el' is required."
(lexical-let ((url url)
(site site))
(w3m-process-do-with-temp-buffer
(type (w3m-retrieve url nil t nil nil handler))
(let (link date dates)
(when type
(w3m-decode-buffer url)
(let* ((xml (ignore-errors
(xml-parse-region (point-min) (point-max))))
(dc-ns (w3m-rss-get-namespace-prefix
xml "http://purl.org/dc/elements/1.1/"))
(rss-ns (w3m-rss-get-namespace-prefix
xml "http://purl.org/rss/1.0/"))
(channel (car (w3m-rss-find-el
(intern (concat rss-ns "channel"))
xml)))
(items (w3m-rss-find-el
(intern (concat rss-ns "item"))
xml)))
(setq link (nth 2 (car (w3m-rss-find-el
(intern (concat rss-ns "link"))
channel))))
(setq dates (append
(w3m-rss-find-el
(intern (concat dc-ns "date"))
channel)
(w3m-rss-find-el
(intern (concat dc-ns "date"))
items)
(w3m-rss-find-el 'pubDate channel)
(w3m-rss-find-el 'pubDate items)))
(when dates
;; Ignore future entries to display site announcements.
(let ((now (current-time)))
(let ((low (+ (nth 1 now) 3600))) ; 3600 = clock skew margin
(setq now
(if (>= low 65536)
(list (1+ (car now))
(- low 65536)
(nth 2 now))
(list (car now)
low
(nth 2 now)))))
(setq date '(0 0))
(dolist (tmp dates)
(setq tmp (w3m-rss-parse-date-string (nth 2 tmp)))
(and (w3m-time-newer-p tmp date)
(w3m-time-newer-p now tmp)
(setq date tmp)))))))
(if (and link date)
(w3m-antenna-site-update site link date nil)
(w3m-antenna-check-page site handler))))))
(defun w3m-antenna-check-another-page (site handler url)
"Check the another page to detect change of SITE asynchronously.
This function checks the another page specified by the URL before
checking the SITE itself. This function is useful when the SITE's
owner either maintains the page which describes the change of the
SITE."
(lexical-let ((site site))
(w3m-process-do-with-temp-buffer
(time (w3m-last-modified url t handler))
(if time
(w3m-antenna-site-update site (w3m-antenna-site-key site) time nil)
(w3m-antenna-check-page site handler)))))
(defun w3m-antenna-check-anchor (site handler regexp number)
"Check the page linked from SITE asynchronously.
This function checks the page linked by an anchor that matches REGEXP
from the page that is specified by SITE's key attribute."
(lexical-let ((site site)
(regexp regexp)
(number (or number 0)))
(w3m-process-do-with-temp-buffer
(type (w3m-retrieve (w3m-antenna-site-key site)
nil nil nil nil handler))
(w3m-antenna-check-page site
handler
(when type
(w3m-decode-buffer (w3m-antenna-site-key site))
(goto-char (point-min))
(when (re-search-forward regexp nil t)
(w3m-expand-url
(match-string number)
(w3m-antenna-site-key site))))))))
;; To avoid byte-compile warning.
(eval-and-compile
(autoload 'w3m-filter "w3m-filter"))
(defun w3m-antenna-check-page (site handler &optional url)
"Check SITE with the generic procedure.
It consists of 3 steps:
\(1\) Check the time when the SITE was last modified with HEAD request.
\(2\) Check the size of the SITE with HEAD request.
\(3\) Get the real content of the SITE, and check its size.
"
(lexical-let ((site site)
(url (or url
(w3m-antenna-site-url site)
(w3m-antenna-site-key site))))
(w3m-process-do
(attr (w3m-attributes url t handler))
(when attr
(if (nth 4 attr) ; Use the value of Last-modified header.
(w3m-antenna-site-update site url (nth 4 attr) (nth 2 attr))
(unless (eq 'time (w3m-antenna-site-class site))
(if (nth 2 attr) ; Use the value of Content-Length header.
(w3m-antenna-site-update site url nil (nth 2 attr))
;; Get the real content of the SITE, and calculate its size.
(w3m-process-do-with-temp-buffer
(type (w3m-retrieve url nil t nil nil handler))
(when type
(w3m-decode-buffer url nil type)
(w3m-remove-comments)
(when w3m-use-filter
(w3m-filter url))
(w3m-antenna-site-update site url nil (buffer-size)))))))))))
(defun w3m-antenna-site-update (site url time size)
"Update SITE's status information with specified TIME and SIZE."
;; (w3m-antenna-site-size-detected site) keeps the time when SITE's
;; size attribute is checked.
(setf (w3m-antenna-site-size-detected site)
(when size
(or (when (and url
(w3m-antenna-site-url site)
(string= url (w3m-antenna-site-url site))
(w3m-antenna-site-size site)
(= size (w3m-antenna-site-size site)))
(w3m-antenna-site-size-detected site))
(current-time))))
(setf (w3m-antenna-site-url site) url)
(setf (w3m-antenna-site-last-modified site) time)
(setf (w3m-antenna-site-size site) size)
site)
(defun w3m-antenna-check-site (site handler)
"Check SITE asynchronously.
If a class attribute of the SITE is a list that consists of a function
to check SITE and its options, call it. When a class attribute of the
SITE is equal to the symbol `hns', call `w3m-antenna-check-hns'.
Otherwise, call `w3m-antenna-check-page'."
(if (and (listp (w3m-antenna-site-class site))
(functionp (car (w3m-antenna-site-class site))))
(apply (car (w3m-antenna-site-class site))
site handler (cdr (w3m-antenna-site-class site)))
(if (eq 'hns (w3m-antenna-site-class site))
(w3m-antenna-check-hns site handler)
(w3m-antenna-check-page site
handler
(format-time-string (w3m-antenna-site-key site)
(current-time))))))
(defun w3m-antenna-mapcar (function sequence handler)
"Apply FUNCTION to each element of SEQUENCE asynchronously, and make
a list of the results."
(let ((index -1)
(table (make-symbol "table"))
(buffer (make-symbol "buffer")))
(set table (make-vector (length sequence) nil))
(set buffer (current-buffer))
(dolist (element sequence)
(aset (symbol-value table)
(incf index)
(funcall function
element
(cons `(lambda (x)
(aset ,table ,index x)
(w3m-antenna-mapcar-after ,table ,buffer))
handler))))
(w3m-antenna-mapcar-after (symbol-value table) (symbol-value buffer))))
(defun w3m-antenna-mapcar-after (result buffer)
"Handler function of `w3m-antenna-mapcar'.
If all asynchronous processes have finished, return a list of the
results for the further handler functions. Otherwise, return an
asynchronous process that has not finished yet."
(or (catch 'found-proces
(let ((index -1))
(while (< (incf index) (length result))
(when (w3m-process-p (aref result index))
(throw 'found-proces (aref result index))))))
(progn
(set-buffer buffer)
(append result nil))))
(defun w3m-antenna-check-all-sites (&optional handler)
"Check all sites specified in `w3m-antenna-sites'."
(unless w3m-antenna-alist
(setq w3m-antenna-alist (w3m-antenna-alist)))
(if (not handler)
(w3m-process-with-wait-handler
(w3m-antenna-check-all-sites handler))
(w3m-process-do
(result
(w3m-antenna-mapcar 'w3m-antenna-check-site
w3m-antenna-alist
handler))
(prog1 w3m-antenna-alist
(w3m-save-list w3m-antenna-file w3m-antenna-alist)
(setq w3m-antenna-alist nil)))))
(defun w3m-antenna-make-summary (site)
(format "<li><a href=\"%s\">%s</a> %s"
(or (w3m-antenna-site-url site)
(w3m-antenna-site-key site))
(w3m-antenna-site-title site)
(cond
((w3m-antenna-site-last-modified site)
(current-time-string (w3m-antenna-site-last-modified site)))
((w3m-antenna-site-size site) "Size")
(t ""))))
(defun w3m-antenna-make-summary-like-natsumican (site)
(let ((t1 (w3m-antenna-site-last-modified site))
(t2 (w3m-antenna-site-size-detected site)))
(format "<li>%20s&nbsp;&nbsp;(%s)&nbsp;&nbsp;<a href=\"%s\">%s</a>"
(if (or t1 t2)
(format-time-string "%Y/%m/%d %R" (or t1 t2))
"----/--/-- --:--")
(cond
(t1 "T")
(t2 "S")
(t "?"))
(or (w3m-antenna-site-url site)
(w3m-antenna-site-key site))
(w3m-antenna-site-title site))))
(defun w3m-antenna-sort-sites-by-time (sites)
(sort sites
(lambda (a b)
(w3m-time-newer-p
(or (w3m-antenna-site-last-modified a)
(w3m-antenna-site-size-detected a))
(or (w3m-antenna-site-last-modified b)
(w3m-antenna-site-size-detected b))))))
(defun w3m-antenna-sort-sites-by-title (sites)
(sort sites
(lambda (a b)
(string< (w3m-antenna-site-title a)
(w3m-antenna-site-title b)))))
(defun w3m-antenna-make-contents (changed-sites unchanged-sites)
(insert w3m-antenna-html-skelton)
(goto-char (point-min))
(while (re-search-forward "%\\(.\\)" nil t)
(let ((c (char-after (match-beginning 1))))
(cond
((memq c '(?C ?U))
(save-restriction
(narrow-to-region (match-beginning 0) (match-end 0))
(delete-region (point-min) (point-max))
(goto-char (point-min))
(dolist (site (if (eq c ?C)
changed-sites
unchanged-sites))
(insert (funcall w3m-antenna-make-summary-function site)
"\n"))
(goto-char (point-max))))
((eq c '?D)
(goto-char (match-beginning 0))
(delete-region (match-beginning 0) (match-end 0))
(insert (let ((time (nth 5 (file-attributes w3m-antenna-file))))
(if time
(current-time-string time)
"(unknown)"))))
((eq c '?R)
(save-restriction
(narrow-to-region (match-beginning 0) (match-end 0))
(delete-region (point-min) (point-max))
(when (and w3m-antenna-refresh-interval
(integerp w3m-antenna-refresh-interval)
(< 0 w3m-antenna-refresh-interval))
(insert (format "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d\">\n"
w3m-antenna-refresh-interval)))))))))
;;;###autoload
(defun w3m-about-antenna (url &optional no-decode no-cache
post-data referer handler)
(w3m-process-do
(alist (if no-cache
(w3m-antenna-check-all-sites handler)
(or w3m-antenna-alist (w3m-antenna-alist))))
(let (changed unchanged)
(dolist (site alist)
(if (w3m-time-newer-p (or (w3m-antenna-site-last-modified site)
(w3m-antenna-site-size-detected site))
(or (w3m-arrived-last-modified
(w3m-antenna-site-url site))
(w3m-arrived-time
(w3m-antenna-site-url site))))
(progn
(w3m-cache-remove (w3m-antenna-site-url site))
(push site changed))
(push site unchanged)))
(w3m-antenna-make-contents
(funcall w3m-antenna-sort-changed-sites-function (nreverse changed))
(funcall w3m-antenna-sort-unchanged-sites-function (nreverse unchanged)))
"text/html")))
;;;###autoload
(defun w3m-antenna (&optional no-cache)
"Report changes of WEB sites, which is specified in `w3m-antenna-sites'."
(interactive "P")
(w3m-goto-url "about://antenna/" no-cache))
(defvar w3m-antenna-tmp-url nil)
(defvar w3m-antenna-tmp-title nil)
(defun w3m-antenna-add-current-url (&optional arg)
"Add link of current page to antenna.
With prefix, ask new url to add instead of current page."
(interactive "P")
(w3m-antenna-add (if arg (w3m-input-url) w3m-current-url)
(w3m-encode-specials-string w3m-current-title)))
(defun w3m-antenna-add (url &optional title)
"Add URL to antenna.
Optional argument TITLE is title of link."
(setq w3m-antenna-tmp-url url)
(setq w3m-antenna-tmp-title title)
(customize-variable 'w3m-antenna-sites)
;; dirty...
(goto-char (point-max))
(re-search-backward "INS")
(widget-button-press (point))
(re-search-forward "State:\\|\\(\\[State\\]:\\)")
(backward-char (if (match-beginning 1) 3 2)))
(defvar w3m-antenna-mode-map
(let ((map (make-sparse-keymap)))
(substitute-key-definition 'w3m-edit-current-url 'w3m-antenna-edit
map w3m-mode-map)
map)
"*Keymap for `w3m-antenna-mode'.")
(defvar w3m-antenna-mode nil "Non-nil if w3m antenna mode is enabled.")
(make-variable-buffer-local 'w3m-antenna-mode)
(unless (assq 'w3m-antenna-mode minor-mode-alist)
(push (list 'w3m-antenna-mode " antenna") minor-mode-alist))
(unless (assq 'w3m-antenna-mode minor-mode-map-alist)
(push (cons 'w3m-antenna-mode w3m-antenna-mode-map) minor-mode-map-alist))
(defun w3m-antenna-mode (&optional arg)
"\\<w3m-antenna-mode-map>
Minor mode to edit antenna.
\\[w3m-antenna-edit] Customize `w3m-antenna-sites'.
"
(interactive "P")
(when (setq w3m-antenna-mode
(if arg
(> (prefix-numeric-value arg) 0)
(not w3m-antenna-mode)))
(run-hooks 'w3m-antenna-mode-hook)))
(defun w3m-antenna-mode-setter (url)
"Activate `w3m-antenna-mode', when visiting page shows antenna."
(w3m-antenna-mode (if (string-match "\\`about://antenna/" url)
(progn
(setq default-directory
(file-name-directory w3m-antenna-file))
1)
0)))
(add-hook 'w3m-display-functions 'w3m-antenna-mode-setter)
(defun w3m-antenna-edit ()
"Start customize of `w3m-antenna-sites'."
(interactive)
(customize-variable 'w3m-antenna-sites))
(provide 'w3m-antenna)
;;; w3m-antenna.el ends here

588
share/emacs/site-lisp/w3m/w3m-bookmark.el Normal file
View file

@ -0,0 +1,588 @@
;;; w3m-bookmark.el --- Functions to operate bookmark file of w3m
;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: Shun-ichi GOTO <gotoh@taiyo.co.jp>,
;; TSUCHIYA Masatoshi <tsuchiya@namazu.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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; w3m-bookmark.el is the add-on program of emacs-w3m to operate
;; bookmark file. For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; Code:
(eval-when-compile (require 'cl))
(require 'w3m-util)
(require 'w3m)
(require 'easymenu)
(defcustom w3m-bookmark-file
(expand-file-name "bookmark.html" w3m-profile-directory)
"Bookmark file of w3m."
:group 'w3m
:type '(file :size 0))
(defcustom w3m-bookmark-file-coding-system 'euc-japan
"Coding system for a created bookmark file.
This option is used when a new bookmark file is created, or when an
existing bookmark file includes ASCII characters only. If the coding
system which is used to encode your using bookmark file is different
from the value of this option, emacs-w3m does not change the encoding
of your bookmark file."
:group 'w3m
:type '(coding-system :size 0))
(defcustom w3m-bookmark-default-section
nil
"Default section to add new entry."
:group 'w3m
:type '(radio (const :tag "Not specified" nil)
(string :format "Default section name: %v\n" :size 0)))
(defcustom w3m-bookmark-mode-hook nil
"*Hook run at the end of function `w3m-bookmark-mode'."
:group 'w3m
:type 'hook)
(defcustom w3m-bookmark-menu-open-new-session nil
"If non-nil, \"Bookmark\" menu item open new session."
:group 'w3m
:type 'boolean)
(eval-and-compile
(defconst w3m-bookmark-section-delimiter
"<!--End of section (do not delete this comment)-->\n"))
(eval-and-compile
(defconst w3m-bookmark-section-format
(eval-when-compile
(concat "<h2>%s</h2>\n<ul>\n"
"<li><a href=\"%s\">%s</a>\n"
w3m-bookmark-section-delimiter
"</ul>\n"))))
(defconst w3m-bookmark-initial-format
(eval-when-compile
(concat "<html><head><title>Bookmarks</title></head>\n"
"<body>\n<h1>Bookmarks</h1>\n"
w3m-bookmark-section-format
"</body>\n</html>\n")))
(defvar w3m-bookmark-section-history nil)
(defvar w3m-bookmark-title-history nil)
(defvar w3m-bookmark-buffer-file-name nil
"Non-nil means that `w3m-bookmark-file' has been loaded to this buffer.")
(make-variable-buffer-local 'w3m-bookmark-buffer-file-name)
(defvar w3m-bookmark-mode-map
(let ((map (make-sparse-keymap))
(table '((kill-line . w3m-bookmark-kill-entry)
(undo . w3m-bookmark-undo))))
(dolist (pair table)
(substitute-key-definition (car pair) (cdr pair) map global-map))
(substitute-key-definition 'w3m-edit-current-url 'w3m-bookmark-edit
map w3m-mode-map)
map)
"*Keymap for `w3m-bookmark-mode'.")
(defvar w3m-bookmark-mode nil "Non-nil if w3m bookmark mode is enabled.")
(make-variable-buffer-local 'w3m-bookmark-mode)
(unless (assq 'w3m-bookmark-mode minor-mode-alist)
(push (list 'w3m-bookmark-mode " bookmark") minor-mode-alist))
(unless (assq 'w3m-bookmark-mode minor-mode-map-alist)
(push (cons 'w3m-bookmark-mode w3m-bookmark-mode-map) minor-mode-map-alist))
(defun w3m-bookmark-mode (&optional arg)
"\\<w3m-bookmark-mode-map>
Minor mode to edit bookmark.
\\[w3m-bookmark-kill-entry] Kill the current entry of this bookmark.
\\[w3m-bookmark-undo] Undo some previous changes on this bookmark.
\\[w3m-bookmark-edit] Open `w3m-bookmark-file'.
"
(interactive "P")
(when (setq w3m-bookmark-mode
(if arg
(> (prefix-numeric-value arg) 0)
(not w3m-bookmark-mode)))
(run-hooks 'w3m-bookmark-mode-hook)))
(defun w3m-bookmark-mode-setter (url)
"Activate `w3m-bookmark-mode', when visiting page shows bookmark."
(w3m-bookmark-mode (if (string-match "\\`about://bookmark/" url)
(progn
(setq default-directory
(file-name-directory w3m-bookmark-file))
1)
0)))
(add-hook 'w3m-display-functions 'w3m-bookmark-mode-setter)
(defun w3m-bookmark-file-modtime ()
"Return the modification time of the bookmark file `w3m-bookmark-file'.
The value is a list of two time values `(HIGH LOW)' if the bookmark
file exists, otherwise nil."
(nth 5 (file-attributes w3m-bookmark-file)))
(defun w3m-bookmark-buffer (&optional no-verify-modtime)
"Return the buffer reading `w3m-bookmark-file' current."
(let ((buffer (get-file-buffer w3m-bookmark-file)))
(if buffer
;; When a buffer visiting `w3m-bookmark-file' is found, return
;; it instead of a working buffer. In this case, kill the
;; working buffer which was generated in the past.
(progn (w3m-kill-buffer " *w3m bookmark*") buffer)
;; Generate a working buffer.
(with-current-buffer (w3m-get-buffer-create " *w3m bookmark*")
(unless (and w3m-bookmark-buffer-file-name
(or no-verify-modtime
(equal (w3m-visited-file-modtime)
(w3m-bookmark-file-modtime))))
(when (file-readable-p w3m-bookmark-file)
(buffer-disable-undo)
(erase-buffer)
(let ((coding-system-for-read 'binary))
(insert-file-contents w3m-bookmark-file))
(w3m-decode-buffer
(w3m-expand-file-name-as-url w3m-bookmark-file))
(set-buffer-file-coding-system
(if (memq w3m-current-coding-system
'(undecided undecided-dos undecided-mac undecided-unix))
w3m-bookmark-file-coding-system
w3m-current-coding-system))
(set-buffer-modified-p nil))
(setq w3m-bookmark-buffer-file-name w3m-bookmark-file)
(set-visited-file-modtime (or (w3m-bookmark-file-modtime)
;; No bookmark file.
(with-temp-buffer
;; 0 in Emacs; (0 . 0) in XEmacs
(visited-file-modtime))))
(buffer-enable-undo))
(current-buffer)))))
(defun w3m-bookmark-verify-modtime ()
(unless (equal (w3m-visited-file-modtime)
(w3m-bookmark-file-modtime))
(if (buffer-file-name)
(ask-user-about-supersession-threat w3m-bookmark-file)
(let ((modified (buffer-modified-p))
(name (buffer-name)))
(unwind-protect
(progn
(set-visited-file-name w3m-bookmark-file)
(ask-user-about-supersession-threat w3m-bookmark-file))
(set-visited-file-name nil)
(rename-buffer name)
(set-buffer-modified-p modified))))))
(defun w3m-bookmark-sections ()
"Return collection of registered sections."
(let (sections)
(with-current-buffer (w3m-bookmark-buffer)
(goto-char (point-min))
(while (search-forward "<h2>" nil t)
(push (cons (buffer-substring-no-properties
(point)
(if (search-forward "</h2>" nil t)
(match-beginning 0)
(point-at-eol)))
nil)
sections)))
(nreverse sections)))
(defun w3m-bookmark-save-buffer ()
"Save this current buffer to `w3m-bookmark-file'."
(cond
((buffer-file-name)
(basic-save-buffer))
((buffer-modified-p)
(let ((backup-info (find-backup-file-name w3m-bookmark-file))
(modes (when (file-exists-p w3m-bookmark-file)
(file-modes w3m-bookmark-file))))
(when (and modes ; means that `w3m-bookmark-file' exists.
make-backup-files
(funcall backup-enable-predicate w3m-bookmark-file))
(rename-file w3m-bookmark-file (car backup-info) t))
(write-region (point-min) (point-max) w3m-bookmark-file)
(when modes
(set-file-modes w3m-bookmark-file modes))
(set-visited-file-modtime (w3m-bookmark-file-modtime))
(set-buffer-modified-p nil)
(dolist (file (cdr backup-info))
(condition-case ()
(delete-file file)
(file-error nil)))))))
(defun w3m-bookmark-safe-string (string format)
(labels ((filter (s c) (decode-coding-string (encode-coding-string s c) c)))
(if (let ((encoding (w3m-static-when (featurep 'mule)
buffer-file-coding-system)))
(or (string= string (filter string encoding))
(when w3m-use-mule-ucs
(string= (setq string
(filter string
(if w3m-accept-japanese-characters
'w3m-euc-japan
'w3m-iso-latin-1)))
(filter string encoding)))))
string
(error format string))))
(defun w3m-bookmark-write-file (url title section)
"Make new bookmark with specified spec, and save it."
(with-current-buffer (w3m-bookmark-buffer)
(setq title (w3m-bookmark-safe-string
title
"Specified title includes unsafe character(s): %s")
section (w3m-bookmark-safe-string
section
"Specified section includes unsafe character(s): %s"))
(if (zerop (buffer-size))
;; New bookmark file.
(progn
(insert (format w3m-bookmark-initial-format section url title))
(set-buffer-file-coding-system w3m-bookmark-file-coding-system))
(goto-char (point-min))
(if (search-forward (format "<h2>%s</h2>" section) nil t)
(progn
(unless (search-forward w3m-bookmark-section-delimiter nil t)
(error "Can't find section delimiter: %s" section))
(goto-char (match-beginning 0))
(insert (format "<li><a href=\"%s\">%s</a>\n" url title)))
;; New section.
(unless (search-forward "</body>\n" nil t)
(error "%s" "Can't find terminator of bookmark"))
(goto-char (match-beginning 0))
(insert (format w3m-bookmark-section-format
section url title))))
(w3m-bookmark-save-buffer)))
(defun w3m-bookmark-add (url &optional title)
"Add URL to bookmark.
Optional argument TITLE is title of link."
(let ((section (completing-read
(if w3m-bookmark-default-section
(format "Section (default %s): "
w3m-bookmark-default-section)
"Section: ")
(w3m-bookmark-sections) nil nil nil
'w3m-bookmark-section-history)))
(and (string= section "")
(setq section w3m-bookmark-default-section))
(when (or (not section)
(string-match section "^ *$"))
(error "%s" "You must specify section name"))
(setq title (read-string "Title: " title 'w3m-bookmark-title-history))
(when (or (not title)
(string-match title "^ *$"))
(error "%s" "You must specify title"))
(w3m-bookmark-write-file url
(w3m-encode-specials-string title)
(w3m-encode-specials-string section))))
;;;###autoload
(defun w3m-bookmark-add-this-url ()
"Add link under cursor to bookmark."
(interactive)
(if (null (w3m-anchor))
(message "No anchor") ; nothing to do
(let ((url (w3m-anchor))
(title (buffer-substring-no-properties
(previous-single-property-change (1+ (point))
'w3m-href-anchor)
(next-single-property-change (point) 'w3m-href-anchor))))
(w3m-bookmark-add url title))
(message "Added")))
;;;###autoload
(defun w3m-bookmark-add-current-url (&optional arg)
"Add a url of the current page to the bookmark.
With prefix, ask for a new url instead of the present one."
(interactive "P")
(w3m-bookmark-add (if arg (w3m-input-url) w3m-current-url)
w3m-current-title)
(message "Added"))
;;;###autoload
(defun w3m-bookmark-add-all-urls ()
"Add urls of all pages being visited to the bookmark."
(interactive)
(let ((buffers (w3m-list-buffers)))
(if (and w3m-use-tab
(>= (length buffers) 2))
(while buffers
(switch-to-buffer (pop buffers))
(condition-case nil
(w3m-bookmark-add-current-url)
(quit)))
(message
"Use the `%s' command instead"
(key-description (car (where-is-internal 'w3m-bookmark-add-current-url
w3m-mode-map)))))))
;;;###autoload
(defun w3m-bookmark-add-current-url-group ()
"Add link of the group of current urls to the bookmark."
(interactive)
(w3m-bookmark-add
(concat "group:"
(mapconcat
'w3m-url-encode-string
(mapcar (lambda (buffer)
(with-current-buffer buffer w3m-current-url))
(w3m-list-buffers))
"&")))
(message "Added as URL group"))
;;;###autoload
(defun w3m-bookmark-view (&optional reload)
"Display the bookmark."
(interactive "P")
(if (file-exists-p w3m-bookmark-file)
(w3m-goto-url "about://bookmark/" reload)
(message "No bookmark file is available")))
;;;###autoload
(defun w3m-bookmark-view-new-session (&optional reload)
"Display the bookmark on a new session."
(interactive "P")
(if (not (eq major-mode 'w3m-mode))
(message "This command can be used in w3m mode only")
(if (file-exists-p w3m-bookmark-file)
(w3m-view-this-url-1 "about://bookmark/" reload 'new-session)
(message "No bookmark file is available"))))
;;;###autoload
(defun w3m-about-bookmark (&rest args)
(insert-buffer-substring (w3m-bookmark-buffer))
(let ((ident) (i 0) (j 0))
(goto-char (point-min))
(while (search-forward (setq ident (format "w3mbk%d." i)) nil t)
(incf i))
(setq i 0)
(goto-char (point-min))
(while (re-search-forward "\n<\\(?:h2\\|\\(li\\)\\)>" nil t)
(forward-char -1)
(insert (if (match-beginning 1)
(format " id=\"%s%d.%d\"" ident i (incf j))
(format " id=\"%s%d\"" ident (incf i))))))
"text/html")
(defun w3m-bookmark-current-number ()
"Return the ordinal number of the current bookmark entry."
(let ((x (car (get-text-property (point-at-eol) 'w3m-name-anchor))))
(and x
(string-match "\\`w3mbk[0-9]+\\.[0-9]+\\.\\([0-9]+\\)\\'" x)
(string-to-number (match-string 1 x)))))
(defun w3m-bookmark-kill-entry (num)
"Kill the bookmark entry of the current line.
With prefix argument, kill that many entries from point."
(interactive "p")
(let ((entries (w3m-bookmark-current-number)))
(when entries
(setq entries (list entries))
(while (> (decf num) 0)
(push (1+ (car entries)) entries))
(condition-case nil
(w3m-bookmark-kill-entries entries)
(file-supersession nil))
(w3m-bookmark-view t))))
(defun w3m-bookmark-kill-entries (entries)
(with-current-buffer (w3m-bookmark-buffer t)
(w3m-bookmark-verify-modtime)
(goto-char (point-min))
(let ((i 0))
(while (search-forward "\n<li>" nil t)
(when (memq (incf i) entries)
(let ((beg (point-at-bol))
(end (progn
(search-forward w3m-bookmark-section-delimiter)
(match-beginning 0))))
(delete-region (goto-char beg)
(if (search-forward "\n<li>" end t)
(point-at-bol)
end))
(goto-char (1- beg))))))
(w3m-bookmark-save-buffer)))
(defun w3m-bookmark-undo (&optional arg)
"Undo some previous changes on bookmark."
(interactive "p")
(condition-case nil
(with-current-buffer (w3m-bookmark-buffer t)
(w3m-bookmark-verify-modtime)
(undo arg)
(w3m-bookmark-save-buffer))
(file-supersession nil))
(w3m-bookmark-view t))
(defun w3m-bookmark-edit ()
"Edit the bookmark file."
(interactive)
(w3m-edit-url (w3m-expand-file-name-as-url w3m-bookmark-file)))
;; Bookmark menu
(defvar w3m-bookmark-menu-items
(let ((etsu (when w3m-use-japanese-menu
(decode-coding-string "\e$B1\\\e(B" 'iso-2022-jp)))) ;; $B1\(B
`(([,(w3m-make-menu-item (concat "$B%V%C%/%^!<%/$N(B" etsu "$BMw(B") "View Bookmark")
w3m-bookmark-view t]
[,(w3m-make-menu-item (concat "$B?7%;%C%7%g%s$G%V%C%/%^!<%/$N(B" etsu "$BMw(B")
"View Bookmark in a New Session")
w3m-bookmark-view-new-session t]
[,(w3m-make-menu-item "$B%V%C%/%^!<%/$NJT=8(B" "Edit Bookmark")
w3m-bookmark-edit t]
"----"
[,(w3m-make-menu-item "$B$3$N%Z!<%8$r%V%C%/%^!<%/(B" "Add Current URL to Bookmark")
w3m-bookmark-add-current-url t]
[,(w3m-make-menu-item "$B$9$Y$F$N(B URL $B$r%V%C%/%^!<%/(B" "Add These URLs to Bookmark")
w3m-bookmark-add-current-url-group t]
[,(w3m-make-menu-item "$B$3$N(B URL $B$r%V%C%/%^!<%/(B" "Add This URL to Bookmark")
w3m-bookmark-add-this-url (w3m-anchor)])
.
([,(w3m-make-menu-item "$B$3$N%(%s%H%j$r>C5n(B" "Kill Current Entry")
w3m-bookmark-kill-entry
(text-property-not-all (point-at-bol) (point-at-eol)
'w3m-href-anchor nil)]
[,(w3m-make-menu-item "$B$b$H$KLa$9(B" "Undo")
w3m-bookmark-undo t]
[,(w3m-make-menu-item "$B%V%C%/%^!<%/$NJT=8(B" "Edit Bookmark")
w3m-bookmark-edit t])))
"*List of the bookmark menu items.
The car is used if `w3m-bookmark-mode' is nil, otherwise the cdr is used.")
;;;###autoload
(defun w3m-setup-bookmark-menu ()
"Setup w3m bookmark items in menubar."
(w3m-static-if (featurep 'xemacs)
(unless (car (find-menu-item current-menubar '("Bookmark")))
(easy-menu-define w3m-bookmark-menu w3m-mode-map
"" '("Bookmark" ["(empty)" ignore nil]))
(easy-menu-add w3m-bookmark-menu)
(add-hook 'activate-menubar-hook 'w3m-bookmark-menubar-update))
(unless (lookup-key w3m-mode-map [menu-bar Bookmark])
(easy-menu-define w3m-bookmark-menu w3m-mode-map "" '("Bookmark"))
(easy-menu-add w3m-bookmark-menu)
(add-hook 'menu-bar-update-hook 'w3m-bookmark-menubar-update))))
(defun w3m-bookmark-menubar-update ()
"Update w3m bookmark menubar."
(when (and (eq major-mode 'w3m-mode)
(w3m-static-if (featurep 'xemacs)
(frame-property (selected-frame) 'menubar-visible-p)
menu-bar-mode))
(let ((items (if w3m-bookmark-mode
(cdr w3m-bookmark-menu-items)
(car w3m-bookmark-menu-items)))
(pages (w3m-bookmark-make-menu-items)))
(easy-menu-define w3m-bookmark-menu w3m-mode-map
"The menu kepmap for the emacs-w3m bookmark."
(cons "Bookmark" (if pages
(append items '("----") pages)
items)))
(w3m-static-when (featurep 'xemacs)
(when (setq items (car (find-menu-item current-menubar '("Bookmark"))))
(setcdr items (cdr w3m-bookmark-menu))
(set-buffer-menubar current-menubar))))))
(defun w3m-bookmark-iterator ()
"Iteration bookmark groups/entries.
Format as (list (\"Group name\" . (\"Entry URL\" . \"Entry name\")* )* )."
(let ((entries nil))
(with-current-buffer (w3m-bookmark-buffer)
(goto-char (point-min))
(let (group entry beg end)
(while (re-search-forward "<h2>\\([^<]+\\)</h2>" nil t)
(setq group (match-string-no-properties 1))
(setq beg (match-beginning 0))
(setq end (re-search-forward "</ul>" nil t))
(save-excursion
(let (urls)
(narrow-to-region beg end)
(goto-char (point-min))
(while (re-search-forward
"<a href=\"\\([^\"]+\\)\">\\([^<]+\\)</a>"
nil t)
(push (cons (match-string-no-properties 1)
(match-string-no-properties 2))
urls))
(setq entry (cons group (nreverse urls)))
(push entry entries)
(widen)))
(goto-char (match-end 0))))
(nreverse entries))))
(defun w3m-bookmark-menu-open-item (url)
"Open URL at current/new buffer"
(if w3m-bookmark-menu-open-new-session
(w3m-goto-url-new-session url)
(w3m-goto-url url)))
(defvar w3m-bookmark-menu-items-pre nil)
(defvar w3m-bookmark-menu-items-time nil)
(defvar w3m-bookmark-make-item-xmas
(and (equal "Japanese" w3m-language) (featurep 'xemacs)))
(defun w3m-bookmark-make-item (item)
(if w3m-bookmark-make-item-xmas
(concat item "%_ ")
item))
(defun w3m-bookmark-make-menu-items (&optional nomenu)
"Create w3m bookmark menu items."
(when (not nomenu)
(if (and w3m-bookmark-menu-items-pre
w3m-bookmark-menu-items-time
(equal w3m-bookmark-menu-items-time
(w3m-bookmark-file-modtime)))
w3m-bookmark-menu-items-pre
(setq w3m-bookmark-menu-items-time (w3m-bookmark-file-modtime))
(let ((entries (when (file-exists-p w3m-bookmark-file)
(w3m-bookmark-iterator))))
(setq w3m-bookmark-menu-items-pre
(and entries
(mapcar
(lambda (entry)
(let ((group (car entry))
(items (cdr entry)))
(cons (w3m-bookmark-make-item group)
(and items
(mapcar
(lambda (item)
(vector
(w3m-bookmark-make-item (cdr item))
`(w3m-bookmark-menu-open-item
,(car item))))
items)))))
entries)))))))
(provide 'w3m-bookmark)
;;; w3m-bookmark.el ends here

192
share/emacs/site-lisp/w3m/w3m-bug.el Normal file
View file

@ -0,0 +1,192 @@
;;; w3m-bug.el --- command to report emacs-w3m bugs -*- coding: euc-japan -*-
;; Copyright (C) 2002, 2003, 2005, 2007, 2010
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Author: 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; `M-x report-emacs-w3m-bug' starts an email note to the emacs-w3m
;; developers describing a problem.
;;; Code:
(defvar report-emacs-w3m-bug-address "emacs-w3m@namazu.org"
"*Address of mailing list for emacs-w3m bugs.")
(defvar report-emacs-w3m-bug-no-explanations nil
"*If non-nil, suppress the explanations given for the sake of novice users.")
(defconst report-emacs-w3m-bug-system-informations
(eval
'`(emacs-w3m-version
emacs-version
,@(if (or (boundp 'mule-version)
(functionp 'mule-version))
'(mule-version))
,@(cond ((featurep 'xemacs)
'((featurep 'mule)
(featurep 'file-coding)))
((or (boundp 'Meadow-version)
(functionp 'Meadow-version))
'(Meadow-version)))
system-type
(featurep 'gtk)
w3m-version
w3m-type
w3m-compile-options
w3m-language
w3m-command-arguments
w3m-command-arguments-alist
w3m-command-environment
w3m-input-coding-system
w3m-output-coding-system
w3m-use-mule-ucs))
"List of the system informations. Users should NEVER modify the value."
;; For the developers:
;; It is possible that it would be a security hole. To prevent those
;; rogue attacks, this constant should be reloaded for each time to
;; send a bug report. Each element can be the symbol of a variable,
;; a Lisp function with no argument or any Lisp form to be evaluated.
)
(eval-when-compile
(require 'cl))
(defun report-emacs-w3m-bug (topic &optional buffer)
"Report a bug in emacs-w3m.
Prompts for bug subject. Leaves you in a mail buffer."
(interactive
(let* ((buffer (current-buffer))
(buffers (cons buffer (delq buffer (buffer-list))))
(inhibit-point-motion-hooks t)
keymap)
(save-current-buffer
(while buffers
(setq buffer (car buffers)
buffers (cdr buffers))
(set-buffer buffer)
(save-restriction
(widen)
(if (or (eq major-mode 'w3m-mode)
(and (keymapp (setq keymap
(or (get-text-property
(max (1- (point-max)) (point-min))
'keymap)
(get-text-property
(max (1- (point-max)) (point-min))
'local-map)))))
(where-is-internal 'w3m-print-current-url keymap))
(setq buffers nil)
(setq buffer nil)))))
(list (read-string "Bug Subject: ") buffer)))
(let (after-load-alist)
;; See the comment for `report-emacs-w3m-bug-system-informations'.
(load "w3m-bug"))
(compose-mail report-emacs-w3m-bug-address topic nil 'new)
(goto-char (point-min))
(re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
(forward-line 1)
(unless buffer
(insert
(if (and (boundp 'w3m-language)
(equal (symbol-value 'w3m-language) "Japanese"))
"もし可能なら emacs-w3m を起動してからやり直してください。\n"
"It is if possible, please redo after starting emacs-w3m.\n")
"\
================================================================\n"))
(unless report-emacs-w3m-bug-no-explanations
;; Insert warnings for the novice users.
(if (and (boundp 'w3m-language)
(equal (symbol-value 'w3m-language) "Japanese"))
(progn
(insert "このバグリポートは emacs-w3m 開発チームに送られます。\n")
(put-text-property (point)
(progn
(insert "\
あなたのローカルサイトの管理者宛てではありません!!")
(point))
'face 'underline)
(insert "\n\nできるだけ簡潔に述べてください:
\t- 何が起きましたか?
\t- 本当はどうなるべきだったと思いますか?
\t- そのとき何をしましたか? (正確に)
もし Lisp のバックトレースがあれば添付してください。\n"))
(insert "\
This bug report will be sent to the emacs-w3m development team,\n")
(put-text-property (point)
(progn
(insert " not to your local site managers!!")
(point))
'face 'italic)
(insert "\nPlease write in ")
(put-text-property (point) (progn
(insert "simple")
(point))
'face 'italic)
(insert " English, because the emacs-w3m developers
aren't good at English reading. ;-)
Please describe as succinctly as possible:
\t- What happened.
\t- What you thought should have happened.
\t- Precisely what you were doing at the time.
Please also include any Lisp back-traces that you may have.\n"))
(insert "\
================================================================\n"))
(insert "Dear Bug Team!\n\n")
(let ((user-point (point))
(print-escape-newlines t)
(print-quoted t)
infos print-length print-level)
(insert "\n
================================================================
System Info to help track down your bug:
---------------------------------------\n")
(with-current-buffer (or buffer (current-buffer))
(dolist (info report-emacs-w3m-bug-system-informations)
(push (prin1-to-string info) infos)
(push "\n => " infos)
(push (cond ((functionp info)
(prin1-to-string (condition-case code
(funcall info)
(error
code))))
((symbolp info)
(prin1-to-string (condition-case code
(symbol-value info)
(error
code))))
((consp info)
(prin1-to-string (condition-case code
(eval info)
(error
code)))))
infos)
(push "\n" infos)))
(apply 'insert (nreverse infos))
(goto-char user-point)))
;;; w3m-bug.el ends here

202
share/emacs/site-lisp/w3m/w3m-ccl.el Normal file
View file

@ -0,0 +1,202 @@
;;; w3m-ccl.el --- CCL programs to process Unicode and internal characters.
;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.org>,
;; ARISAWA Akihiro <ari@mbf.sphere.ne.jp>
;; 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file contains CCL programs to process Unicode and internal
;; characters of w3m. For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; MEMO:
;; It is possible to support multi scripts without Mule-UCS. For more
;; detail, see [emacs-w3m:01950]
;;; Code:
(eval-and-compile
(cond
((featurep 'xemacs)
(require 'pccl))
(t
(require 'ccl))))
;;; CCL programs:
(eval-when-compile
(when (and (not (fboundp 'charset-id))
(fboundp 'charset-id-internal))
(defmacro charset-id (charset)
"Return charset identification number of CHARSET."
`(charset-id-internal ,charset))))
(eval-and-compile
(defconst w3m-internal-characters-alist
'((?\x90 . ? ) ; ANSP (use for empty anchor)
(?\x91 . ? ) ; IMSP (blank around image)
(?\xa0 . ? )) ; NBSP (non breakble space)
"Alist of internal characters v.s. ASCII characters.")
(defun w3m-ccl-write-repeat (charset &optional r0 r1)
(unless r0
(setq r0 'r0))
(unless r1
(setq r1 (if (eq r0 'r1) 'r0 'r1)))
(let ((unibyte (memq charset '(latin-iso8859-1 katakana-jisx0201))))
(if (fboundp 'ccl-compile-write-multibyte-character)
`((,r1 &= ?\x7f)
,@(unless unibyte
`((,r1 |= ((,r0 & ?\x7f) << 7))))
(,r0 = ,(charset-id charset))
(write-multibyte-character ,r0 ,r1)
(repeat))
`((write ,(charset-id charset))
,@(unless unibyte
`((write ,r0)))
(write-repeat ,r1)))))
(defconst w3m-ccl-write-euc-japan-character
(when (fboundp 'ccl-compile-read-multibyte-character)
`((read-multibyte-character r1 r0)
(if (r1 == ,(charset-id 'ascii))
;; (1) ASCII characters
(write-repeat r0))
(if (r1 == ,(charset-id 'latin-jisx0201))
;; (2) Latin Part of Japanese JISX0201.1976
;; Convert to ASCII
(write-repeat r0))
(r2 = (r1 == ,(charset-id 'japanese-jisx0208-1978)))
(if ((r1 == ,(charset-id 'japanese-jisx0208)) | r2)
;; (3) Characters of Japanese JISX0208.
((r1 = ((r0 & 127) | 128))
(r0 = ((r0 >> 7) | 128))
(write r0)
(write-repeat r1)))
(if (r1 == ,(charset-id 'katakana-jisx0201))
;; (4) Katakana Part of Japanese JISX0201.1976
((r0 |= 128)
(write ?\x8e)
(write-repeat r0)))))
"CCL program to write characters represented in `euc-japan'.")
(defconst w3m-ccl-write-iso-latin-1-character
(when (fboundp 'ccl-compile-read-multibyte-character)
`((read-multibyte-character r1 r0)
(if (r1 == ,(charset-id 'ascii))
;; (1) ASCII characters
(write-repeat r0))
(if (r1 == ,(charset-id 'latin-jisx0201))
;; (2) Latin Part of Japanese JISX0201.1976
;; Convert to ASCII
(write-repeat r0))
(if (r1 == ,(charset-id 'latin-iso8859-1))
;; (3) Latin-1 characters
((r0 |= ?\x80)
(write-repeat r0)))))
"CCL program to write characters represented in `iso-latin-1'.")
(defconst w3m-ccl-generate-ncr
`((r1 = 0)
(r2 = 0)
(loop
(r1 = (r1 << 4))
(r1 |= (r0 & 15))
(r0 = (r0 >> 4))
(if (r0 == 0)
(break)
((r2 += 1)
(repeat))))
(write "&#x")
(loop
(branch (r1 & 15)
,@(mapcar
(lambda (i)
(list 'write (string-to-char (format "%x" i))))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))
(r1 = (r1 >> 4))
(if (r2 == 0)
((write ?\;)
(break))
((r2 -= 1)
(repeat))))
(repeat))
"CCL program to generate a string which represents a UCS codepoint
in NCR (Numeric Character References)."))
(define-ccl-program w3m-euc-japan-decoder
`(2
(loop
(read r0)
;; Process normal EUC characters.
(if (r0 < ?\x80)
(write-repeat r0))
(if (r0 > ?\xa0)
((read r1)
,@(w3m-ccl-write-repeat 'japanese-jisx0208)))
(if (r0 == ?\x8e)
((read r1)
,@(w3m-ccl-write-repeat 'katakana-jisx0201)))
(if (r0 == ?\x8f)
((read r0)
(read r1)
,@(w3m-ccl-write-repeat 'japanese-jisx0212)))
;; Process internal characters used in w3m.
,@(mapcar (lambda (pair)
`(if (r0 == ,(car pair))
(write-repeat ,(cdr pair))))
w3m-internal-characters-alist)
(write-repeat r0))))
(unless (get 'w3m-euc-japan-encoder 'ccl-program-idx)
(define-ccl-program w3m-euc-japan-encoder
`(1 (loop (read r0) (write-repeat r0)))))
(define-ccl-program w3m-iso-latin-1-decoder
`(2
(loop
(read r0)
;; Process ASCII characters.
(if (r0 < ?\x80)
(write-repeat r0))
;; Process Latin-1 characters.
(if (r0 > ?\xa0)
(,@(w3m-ccl-write-repeat 'latin-iso8859-1 'r1)))
;; Process internal characters used in w3m.
,@(mapcar (lambda (pair)
`(if (r0 == ,(car pair))
(write-repeat ,(cdr pair))))
w3m-internal-characters-alist)
(write-repeat r0))))
(unless (get 'w3m-iso-latin-1-encoder 'ccl-program-idx)
(define-ccl-program w3m-iso-latin-1-encoder
`(1 (loop (read r0) (write-repeat r0)))))
(provide 'w3m-ccl)
;;; w3m-ccl.el ends here

578
share/emacs/site-lisp/w3m/w3m-cookie.el Normal file
View file

@ -0,0 +1,578 @@
;;; w3m-cookie.el --- Functions for cookie processing
;; Copyright (C) 2002, 2003, 2005, 2006, 2008, 2009, 2010
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: Teranishi Yuuichi <teranisi@gohome.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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file contains the functions for cookies. For more detail
;; about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;; Reference for version 0 cookie:
;; http://www.netscape.com/newsref/std/cookie_spec.html
;; Reference for version 1 cookie:
;; http://www.ietf.org/rfc/rfc2965.txt
;;
;;; Code:
(eval-when-compile
(require 'cl))
(require 'w3m-util)
(require 'w3m)
(defvar w3m-cookies nil
"A list of cookie elements.
Currently only browser local cookies are stored.")
(defconst w3m-cookie-two-dot-domains-regexp
(concat "\\.\\(?:"
(mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int")
"\\|")
"\\)$")
"A regular expression of top-level domains that only require two matching
'.'s in the domain name in order to set a cookie.")
(defcustom w3m-cookie-accept-domains nil
"A list of trusted domain name string."
:group 'w3m
:type '(repeat (string :format "Domain name: %v\n" :size 0)))
(defcustom w3m-cookie-reject-domains nil
"A list of untrusted domain name string."
:group 'w3m
:type '(repeat (string :format "Domain name: %v\n" :size 0)))
(defcustom w3m-cookie-accept-bad-cookies nil
"If nil, don't accept bad cookies.
If t, accept bad cookies.
If ask, ask user whether accept bad cookies or not."
:group 'w3m
:type '(radio
(const :tag "Don't accept bad cookies" nil)
(const :tag "Ask accepting bad cookies" ask)
(const :tag "Always accept bad cookies" t)))
(defcustom w3m-cookie-save-cookies t
"*Non-nil means save cookies when emacs-w3m cookie system shutdown."
:group 'w3m
:type 'boolean)
(defcustom w3m-cookie-file
(expand-file-name ".cookie" w3m-profile-directory)
"File in which cookies are kept."
:group 'w3m
:type '(file :size 0))
;;; Cookie accessor.
(defmacro w3m-cookie-url (cookie)
`(aref ,cookie 0))
(defmacro w3m-cookie-domain (cookie)
`(aref ,cookie 1))
(defmacro w3m-cookie-secure (cookie)
`(aref ,cookie 2))
(defmacro w3m-cookie-name (cookie)
`(aref ,cookie 3))
(defmacro w3m-cookie-value (cookie)
`(aref ,cookie 4))
(defmacro w3m-cookie-path (cookie)
`(aref ,cookie 5))
(defmacro w3m-cookie-version (cookie)
`(aref ,cookie 6))
(defmacro w3m-cookie-expires (cookie)
`(aref ,cookie 7))
(defmacro w3m-cookie-ignore (cookie)
`(aref ,cookie 8))
(defun w3m-cookie-create (&rest args)
(let ((cookie (make-vector 9 nil)))
(setf (w3m-cookie-url cookie) (plist-get args :url))
(setf (w3m-cookie-domain cookie) (plist-get args :domain))
(setf (w3m-cookie-secure cookie) (plist-get args :secure))
(setf (w3m-cookie-name cookie) (plist-get args :name))
(setf (w3m-cookie-value cookie) (plist-get args :value))
(setf (w3m-cookie-path cookie) (plist-get args :path))
(setf (w3m-cookie-version cookie) (or (plist-get args :version) 0))
(setf (w3m-cookie-expires cookie) (plist-get args :expires))
(setf (w3m-cookie-ignore cookie) (plist-get args :ignore))
cookie))
(defun w3m-cookie-store (cookie)
"Store COOKIE."
(let (ignored)
(catch 'found
(dolist (c w3m-cookies)
(when (and (string= (w3m-cookie-domain c)
(w3m-cookie-domain cookie))
(string= (w3m-cookie-path c)
(w3m-cookie-path cookie))
(string= (w3m-cookie-name c)
(w3m-cookie-name cookie)))
(if (w3m-cookie-ignore c)
(setq ignored t)
(setq w3m-cookies (delq c w3m-cookies)))
(throw 'found t))))
(unless ignored
(push cookie w3m-cookies))))
(defun w3m-cookie-remove (domain path name)
"Remove COOKIE if stored."
(dolist (c w3m-cookies)
(when (and (string= (w3m-cookie-domain c)
domain)
(string= (w3m-cookie-path c)
path)
(string= (w3m-cookie-name c)
name))
(setq w3m-cookies (delq c w3m-cookies)))))
(defun w3m-cookie-retrieve (host path &optional secure)
"Retrieve cookies for DOMAIN and PATH."
(let ((case-fold-search t)
expires cookies)
(dolist (c w3m-cookies)
(if (and (w3m-cookie-expires c)
(w3m-time-newer-p (current-time)
(w3m-time-parse-string
(w3m-cookie-expires c))))
(push c expires)
(when (and (not (w3m-cookie-ignore c))
(or
;; A special case that domain name is ".hostname".
(string= (concat "." host) (w3m-cookie-domain c))
(string-match (concat
(regexp-quote (w3m-cookie-domain c)) "$")
host))
(string-match (concat
"^" (regexp-quote (w3m-cookie-path c)))
path))
(if (w3m-cookie-secure c)
(if secure
(push c cookies))
(push c cookies)))))
;; Delete expired cookies.
(dolist (expire expires)
(setq w3m-cookies (delq expire w3m-cookies)))
cookies))
;; HTTP URL parser.
(defun w3m-parse-http-url (url)
"Parse an absolute HTTP URL."
(let (secure split)
(w3m-string-match-url-components url)
(when (and (match-beginning 4)
(or (equal (match-string 2 url) "http")
(setq secure (equal (match-string 2 url) "https"))))
(setq split (save-match-data
(split-string (match-string 4 url) ":")))
(vector secure
(nth 0 split)
(string-to-number (or (nth 1 split) "80"))
(if (eq (length (match-string 5 url)) 0)
"/"
(match-string 5 url))))))
(defsubst w3m-http-url-secure (http-url)
"Secure flag of the HTTP-URL."
(aref http-url 0))
(defsubst w3m-http-url-host (http-url)
"Host name of the HTTP-URL."
(aref http-url 1))
(defsubst w3m-http-url-port (http-url)
"Port number of the HTTP-URL."
(aref http-url 2))
(defsubst w3m-http-url-path (http-url)
"Path of the HTTP-URL."
(aref http-url 3))
;;; Cookie parser.
(defvar w3m-cookie-parse-args-syntax-table
(copy-syntax-table emacs-lisp-mode-syntax-table)
"A syntax table for parsing sgml attributes.")
(modify-syntax-entry ?' "\"" w3m-cookie-parse-args-syntax-table)
(modify-syntax-entry ?` "\"" w3m-cookie-parse-args-syntax-table)
(modify-syntax-entry ?{ "(" w3m-cookie-parse-args-syntax-table)
(modify-syntax-entry ?} ")" w3m-cookie-parse-args-syntax-table)
(defun w3m-cookie-parse-args (str &optional nodowncase)
(let (name value results name-pos val-pos)
(with-current-buffer (get-buffer-create " *w3m-cookie-parse-temp*")
(erase-buffer)
(set-syntax-table w3m-cookie-parse-args-syntax-table)
(insert str)
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward "; \n\t")
(setq name-pos (point))
(skip-chars-forward "^ \n\t=;")
(unless nodowncase
(downcase-region name-pos (point)))
(setq name (buffer-substring name-pos (point)))
(skip-chars-forward " \t\n")
(if (/= (or (char-after (point)) 0) ?=) ; There is no value
(setq value nil)
(skip-chars-forward " \t\n=")
(setq val-pos (point)
value
(cond
((or (= (or (char-after val-pos) 0) ?\")
(= (or (char-after val-pos) 0) ?'))
(buffer-substring (1+ val-pos)
(condition-case ()
(prog2
(forward-sexp 1)
(1- (point))
(skip-chars-forward "\""))
(error
(skip-chars-forward "^ \t\n")
(point)))))
(t
(buffer-substring val-pos
(progn
(skip-chars-forward "^;")
(skip-chars-backward " \t")
(point)))))))
(push (cons name value) results)
(skip-chars-forward "; \n\t"))
results)))
(defun w3m-cookie-trusted-host-p (host)
"Returns non-nil when the HOST is specified as trusted by user."
(let ((accept w3m-cookie-accept-domains)
(reject w3m-cookie-reject-domains)
(trusted t)
regexp tlen rlen)
(while accept
(cond
((string= (car accept) ".")
(setq regexp ".*"))
((string= (car accept) ".local")
(setq regexp "^[^\\.]+$"))
((eq (string-to-char (car accept)) ?.)
(setq regexp (concat (regexp-quote (car accept)) "$")))
(t (setq regexp (concat "^" (regexp-quote (car accept)) "$"))))
(when (string-match regexp host)
(setq tlen (length (car accept))
accept nil))
(pop accept))
(while reject
(cond
((string= (car reject) ".")
(setq regexp ".*"))
((string= (car reject) ".local")
(setq regexp "^[^\\.]+$"))
((eq (string-to-char (car reject)) ?.)
(setq regexp (concat (regexp-quote (car reject)) "$")))
(t (setq regexp (concat "^" (regexp-quote (car reject)) "$"))))
(when (string-match (concat regexp "$") host)
(setq rlen (length (car reject))
reject nil))
(pop reject))
(if tlen
(if rlen
(if (<= tlen rlen)
(setq trusted nil)))
(if rlen
(setq trusted nil)))
trusted))
;;; Version 0 cookie.
(defun w3m-cookie-1-acceptable-p (host domain)
(let ((numdots 0)
(last nil)
(case-fold-search t)
(mindots 3))
(while (setq last (string-match "\\." domain last))
(setq numdots (1+ numdots)
last (1+ last)))
(if (string-match w3m-cookie-two-dot-domains-regexp domain)
(setq mindots 2))
(cond
((string= host domain) ; Apparently netscape lets you do this
t)
;; A special case that domain name is ".hostname".
((string= (concat "." host) domain)
t)
((>= numdots mindots) ; We have enough dots in domain name
;; Need to check and make sure the host is actually _in_ the
;; domain it wants to set a cookie for though.
(string-match (concat (regexp-quote domain) "$") host))
(t
nil))))
(defun w3m-cookie-1-set (url &rest args)
;; Set-Cookie:, version 0 cookie.
(let ((http-url (w3m-parse-http-url url))
(case-fold-search t)
secure domain expires path rest)
(when http-url
(setq secure (and (w3m-assoc-ignore-case "secure" args) t)
domain (or (cdr-safe (w3m-assoc-ignore-case "domain" args))
(w3m-http-url-host http-url))
expires (cdr-safe (w3m-assoc-ignore-case "expires" args))
path (or (cdr-safe (w3m-assoc-ignore-case "path" args))
(file-name-directory
(w3m-http-url-path http-url))))
(while args
(if (not (member (downcase (car (car args)))
'("secure" "domain" "expires" "path")))
(setq rest (cons (car args) rest)))
(setq args (cdr args)))
(cond
((not (w3m-cookie-trusted-host-p (w3m-http-url-host http-url)))
;; The site was explicity marked as untrusted by the user
nil)
((or (w3m-cookie-1-acceptable-p (w3m-http-url-host http-url) domain)
(eq w3m-cookie-accept-bad-cookies t)
(and (eq w3m-cookie-accept-bad-cookies 'ask)
(y-or-n-p (format "Accept bad cookie from %s for %s? "
(w3m-http-url-host http-url) domain))))
;; Cookie is accepted by the user, and passes our security checks
(dolist (elem rest)
;; If a CGI script wishes to delete a cookie, it can do so by
;; returning a cookie with the same name, and an expires time
;; which is in the past.
(when (and expires
(w3m-time-newer-p (current-time)
(w3m-time-parse-string expires)))
(w3m-cookie-remove domain path (car elem)))
(w3m-cookie-store
(w3m-cookie-create :url url
:domain domain
:name (car elem)
:value (cdr elem)
:path path
:expires expires
:secure secure))))
(t
(message "%s tried to set a cookie for domain %s - rejected."
(w3m-http-url-host http-url) domain))))))
;;; Version 1 cookie.
(defun w3m-cookie-2-acceptable-p (http-url domain)
;; A user agent rejects (SHALL NOT store its information) if the Version
;; attribute is missing. Moreover, a user agent rejects (SHALL NOT
;; store its information) if any of the following is true of the
;; attributes explicitly present in the Set-Cookie2 response header:
;; * The value for the Path attribute is not a prefix of the
;; request-URI.
;; * The value for the Domain attribute contains no embedded dots,
;; and the value is not .local.
;; * The effective host name that derives from the request-host does
;; not domain-match the Domain attribute.
;; * The request-host is a HDN (not IP address) and has the form HD,
;; where D is the value of the Domain attribute, and H is a string
;; that contains one or more dots.
;; * The Port attribute has a "port-list", and the request-port was
;; not in the list.
)
(defun w3m-cookie-2-set (url &rest args)
;; Set-Cookie2:, version 1 cookie.
;; Not implemented yet.
)
;;; Save & Load
(defvar w3m-cookie-init nil)
(defun w3m-cookie-clear ()
"Clear cookie list."
(setq w3m-cookies nil))
(defun w3m-cookie-save (&optional domain)
"Save cookies.
When DOMAIN is non-nil, only save cookies whose domains match it."
(interactive)
(let (cookies)
(dolist (cookie w3m-cookies)
(when (and (or (not domain)
(string= (w3m-cookie-domain cookie) domain))
(w3m-cookie-expires cookie)
(w3m-time-newer-p (w3m-time-parse-string
(w3m-cookie-expires cookie))
(current-time)))
(push cookie cookies)))
(w3m-save-list w3m-cookie-file cookies)))
(defun w3m-cookie-save-current-site-cookies ()
"Save cookies for the current site."
(interactive)
(when (and w3m-current-url
(not (w3m-url-local-p w3m-current-url)))
(w3m-string-match-url-components w3m-current-url)
(w3m-cookie-save (match-string 4 w3m-current-url))))
(defun w3m-cookie-load ()
"Load cookies."
(when (null w3m-cookies)
(setq w3m-cookies
(w3m-load-list w3m-cookie-file))))
(defun w3m-cookie-setup ()
"Setup cookies. Returns immediataly if already initialized."
(interactive)
(unless w3m-cookie-init
(w3m-cookie-load)
(setq w3m-cookie-init t)))
;;;###autoload
(defun w3m-cookie-shutdown ()
"Save cookies, and reset cookies' data."
(interactive)
(when w3m-cookie-save-cookies
(w3m-cookie-save))
(setq w3m-cookie-init nil)
(w3m-cookie-clear)
(if (get-buffer " *w3m-cookie-parse-temp*")
(kill-buffer (get-buffer " *w3m-cookie-parse-temp*"))))
;;;###autoload
(defun w3m-cookie-set (url beg end)
"Register cookies which correspond to URL.
BEG and END should be an HTTP response header region on current buffer."
(w3m-cookie-setup)
(when (and url beg end)
(save-excursion
(let ((case-fold-search t)
(version 0)
data)
(goto-char beg)
(while (re-search-forward
"^\\(?:Set-Cookie\\(2\\)?:\\) *\\(.*\\(?:\n[ \t].*\\)*\\)\n"
end t)
(setq data (match-string 2))
(if (match-beginning 1)
(setq version 1))
(apply
(case version
(0 'w3m-cookie-1-set)
(1 'w3m-cookie-2-set))
url (w3m-cookie-parse-args data 'nodowncase)))))))
;;;###autoload
(defun w3m-cookie-get (url)
"Get a cookie field string which corresponds to the URL."
(w3m-cookie-setup)
(let* ((http-url (w3m-parse-http-url url))
(cookies (and http-url
(w3m-cookie-retrieve (w3m-http-url-host http-url)
(w3m-http-url-path http-url)
(w3m-http-url-secure http-url)))))
;; When sending cookies to a server, all cookies with a more specific path
;; mapping should be sent before cookies with less specific path mappings.
(setq cookies (sort cookies
(lambda (x y)
(< (length (w3m-cookie-path x))
(length (w3m-cookie-path y))))))
(when cookies
(mapconcat (lambda (cookie)
(concat (w3m-cookie-name cookie)
"=" (w3m-cookie-value cookie)))
cookies
"; "))))
;;;###autoload
(defun w3m-cookie (&optional no-cache)
"Display cookies and enable you to manage them."
(interactive "P")
(w3m-goto-url "about://cookie/" no-cache))
;;;###autoload
(defun w3m-about-cookie (url &optional no-decode no-cache post-data &rest args)
"Make the html contents to display and to enable you to manage cookies."
(unless w3m-use-cookies (error "You must enable emacs-w3m to use cookies."))
(w3m-cookie-setup)
(let ((pos 0))
(when post-data
(dolist (pair (split-string post-data "&"))
(setq pair (split-string pair "="))
(setf (w3m-cookie-ignore
(nth (string-to-number (car pair)) w3m-cookies))
(eq (string-to-number (cadr pair)) 0))))
(insert
(concat
"\
<html><head><title>Cookies</title></head>
<body><center><b>Cookies</b></center>
<p><form method=\"post\" action=\"about://cookie/\">
<ol>"))
(dolist (cookie w3m-cookies)
(insert
(concat
"<li><h1><a href=\""
(w3m-cookie-url cookie)
"\">"
(w3m-cookie-url cookie)
"</a></h1>"
"<table cellpadding=0>"
"<tr><td width=\"80\"><b>Cookie:</b></td><td>"
(w3m-cookie-name cookie) "=" (w3m-cookie-value cookie)
"</td></tr>"
(when (w3m-cookie-expires cookie)
(concat
"<tr><td width=\"80\"><b>Expires:</b></td><td>"
(w3m-cookie-expires cookie)
"</td></tr>"))
"<tr><td width=\"80\"><b>Version:</b></td><td>"
(number-to-string (w3m-cookie-version cookie))
"</td></tr>"
(when (w3m-cookie-domain cookie)
(concat
"<tr><td width=\"80\"><b>Domain:</b></td><td>"
(w3m-cookie-domain cookie)
"</td></tr>"))
(when (w3m-cookie-path cookie)
(concat
"<tr><td width=\"80\"><b>Path:</b></td><td>"
(w3m-cookie-path cookie)
"</td></tr>"))
"<tr><td width=\"80\"><b>Secure:</b></td><td>"
(if (w3m-cookie-secure cookie) "Yes" "No")
"</td></tr><tr><td>"
"<tr><td width=\"80\"><b>Use:</b></td><td>"
(format "<input type=radio name=\"%d\" value=1%s>Yes"
pos (if (w3m-cookie-ignore cookie) "" " checked"))
"&nbsp;&nbsp;"
(format "<input type=radio name=\"%d\" value=0%s>No"
pos (if (w3m-cookie-ignore cookie) " checked" ""))
"</td></tr><tr><td><input type=submit value=\"OK\"></table><p>"))
(setq pos (1+ pos)))
(insert "</ol></form></body></html>")
"text/html"))
(provide 'w3m-cookie)
;;; w3m-cookie.el ends here

239
share/emacs/site-lisp/w3m/w3m-dtree.el Normal file
View file

@ -0,0 +1,239 @@
;;; w3m-dtree.el --- The add-on program to display local directory tree.
;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2009
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Author: Hideyuki SHIRAI <shirai@meadowy.org>,
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Keywords: w3m, WWW, hypermedia, directory, tree
;; 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; w3m-dtree.el is the add-on program of emacs-w3m to display local
;; directory tree. For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; Code:
(require 'w3m)
(defcustom w3m-dtree-default-allfiles nil
"*If non-nil, set 'allfiles' to default."
:group 'w3m
:type 'boolean)
(defcustom w3m-dtree-directory-depth 8
"*Interger of a depth of the viewing directory."
:group 'w3m
:type '(choice
(const :tag "No limit" nil)
(integer :format "%t: %v\n" :size 0 :tag "depth" 10)))
(defcustom w3m-dtree-indent-strings ["|-" "+-" "| " " "]
"*Vector of strings to be used for indentation with w3m-dtree.
If use default value or choice 'ASCII', display like this,
/home/shirai/work/emacs-w3m/
|-CVS/
|-icons/
| +-CVS/
+-shimbun/
+-CVS/
If you care for another style, set manually and try it :-).
"
:group 'w3m
:type '(radio
(const :format "ASCII: " ["|-" "+-" "| " " "])
(vector
:convert-widget w3m-widget-type-convert-widget
(let ((defaults (if (equal w3m-language "Japanese")
(vconcat
(mapcar
(lambda (s)
(decode-coding-string s 'iso-2022-7bit))
'("\e$B('\e(B" "\e$B(&\e(B"
"\e$B(\"\e(B" "\e$B!!\e(B")))
["|-" "+-" "| " " "])))
`(:format "Others:\n%v" :indent 4
(string :format "%{|-%} %v\n"
:sample-face widget-field-face :size 0
:value ,(aref defaults 0))
(string :format "%{+-%} %v\n"
:sample-face widget-field-face :size 0
:value ,(aref defaults 1))
(string :format "%{| %} %v\n"
:sample-face widget-field-face :size 0
:value ,(aref defaults 2))
(string :format "%{ %} %v"
:sample-face widget-field-face :size 0
:value ,(aref defaults 3)))))))
(defcustom w3m-dtree-stop-strings ["|=" "+="]
"*Vector of strings to be used for indentation when a depth of directory
over the 'w3m-dtree-directory-depth'."
:group 'w3m
:type '(radio
(const :format "ASCII: " ["|=" "+="])
(const :format "ASCII Bold: " ["<b>|-</b>" "<b>+-</b>"])
(vector
:convert-widget w3m-widget-type-convert-widget
(let ((defaults (if (equal w3m-language "Japanese")
(vconcat
(mapcar
(lambda (s)
(decode-coding-string s 'iso-2022-7bit))
'("\e$B(<\e(B" "\e$B(1\e(B")))
["|=" "+="])))
`(:format "Others:\n%v" :indent 4
(string :format "|= %{|=%} %v\n"
:sample-face bold :size 0
:value ,(aref defaults 0))
(string :format "+= %{+=%} %v\n"
:sample-face bold :size 0
:value ,(aref defaults 1)))))))
(defun w3m-dtree-expand-file-name (path)
(if (string-match "^\\(.\\):\\(.*\\)" path)
(if w3m-use-cygdrive
(concat "/cygdrive/"
(match-string 1 path) (match-string 2 path))
(concat "/" (match-string 1 path) "|" (match-string 2 path)))
path))
(defun w3m-dtree-directory-name (path)
(when (and w3m-treat-drive-letter
(string-match
"^/\\(?:\\([A-Za-z]\\)[|:]?\\|cygdrive/\\([A-Za-z]\\)\\)/"
path))
(setq path (concat
(or (match-string 1 path)
(match-string 2 path))
":/"
(substring path (match-end 0)))))
path)
(defmacro w3m-dtree-has-child (path)
`(let ((w32-get-true-file-link-count t)) ;; true link count for Meadow
(and (nth 1 (file-attributes ,path))
(/= (nth 1 (file-attributes ,path)) 2))))
(defun w3m-dtree-create-sub (path allfiles dirprefix fileprefix indent depth)
(let* ((files (directory-files path t))
(limit (and (integerp w3m-dtree-directory-depth)
(>= depth w3m-dtree-directory-depth)))
(indent-sub1 (if limit
(aref w3m-dtree-stop-strings 0)
(aref w3m-dtree-indent-strings 0)))
(indent-sub2 (aref w3m-dtree-indent-strings 2))
file fullpath tmp)
(setq files (delete (concat (file-name-as-directory path) ".")
(delete (concat (file-name-as-directory path) "..")
files)))
(unless allfiles
(setq tmp files)
(while (setq file (car tmp))
(unless (file-directory-p file)
(setq files (delete file files)))
(setq tmp (cdr tmp))))
(while (setq fullpath (car files))
(when (= (length files) 1)
(if limit
(setq indent-sub1 (aref w3m-dtree-stop-strings 1))
(setq indent-sub1 (aref w3m-dtree-indent-strings 1)))
(setq indent-sub2 (aref w3m-dtree-indent-strings 3)))
(setq file (file-name-nondirectory fullpath))
(cond
((or (not allfiles) (file-directory-p fullpath))
(insert (format "%s%s%s<A HREF=\"%s%s\">%s</A>\n"
indent indent-sub1
(if allfiles "<B>[d]</B>" "")
dirprefix
(w3m-dtree-expand-file-name (file-name-as-directory fullpath))
(concat file "/")))
(when (and (null limit)
(or allfiles (w3m-dtree-has-child fullpath)))
(w3m-dtree-create-sub fullpath allfiles dirprefix fileprefix
(concat indent indent-sub2) (1+ depth))))
((and allfiles (file-exists-p fullpath))
(insert (format "%s%s%s<A HREF=\"%s%s\">%s</A>\n"
indent indent-sub1
(if allfiles "(f)" "")
fileprefix (w3m-dtree-expand-file-name fullpath)
file))))
(setq files (cdr files)))))
(defun w3m-dtree-create (path allfiles dirprefix fileprefix)
(let ((charset (or (car (rassq w3m-file-name-coding-system
w3m-charset-coding-system-alist))
w3m-file-name-coding-system)))
(insert "<!doctype html public \"-//W3C//DTD HTML 3.2//EN\">\n"
"<html>\n<head>\n"
"<meta http-equiv=\"CONTENT-TYPE\" "
"content=\"text/html; charset="
(symbol-name charset)
"\">\n"
"<title>"
path
"</title>\n</head>\n<body>\n<pre>\n")
(insert (format "<A HREF=\"%s%s\">%s</A>%s\n"
dirprefix (w3m-dtree-expand-file-name path) path
(if allfiles " (allfiles)" "")))
(if (file-directory-p path)
(w3m-dtree-create-sub path allfiles dirprefix fileprefix " " 0)
(insert (format "\n<h3>Warning: Directory not found.</h3>\n")))
(insert "</pre>\n</body>\n</html>\n")))
;;;###autoload
(defun w3m-about-dtree (url &optional nodecode allfiles &rest args)
(let ((prelen (length "about://dtree"))
(dirprefix "about://dtree")
(fileprefix "file://")
path)
(if (string-match "\\?allfiles=\\(?:\\(true\\)\\|false\\)$" url)
(progn
(setq path (substring url prelen (match-beginning 0)))
(if (match-beginning 1) (setq allfiles t)))
(if w3m-dtree-default-allfiles
(setq allfiles (not allfiles)))
(setq path (substring url prelen)))
;; counter drive letter
(setq path (file-name-as-directory (w3m-dtree-directory-name path)))
(setq default-directory path)
(w3m-message "Dtree (%s)..." path)
(w3m-dtree-create path allfiles dirprefix fileprefix)
(w3m-message "Dtree...done")
"text/html"))
;;;###autoload
(defun w3m-dtree (allfiles path)
"Display directory tree on local file system.
If called with 'prefix argument', display all directorys and files."
(interactive "P\nDDtree directory: ")
(if w3m-dtree-default-allfiles
(setq allfiles (not allfiles)))
(w3m-goto-url (format "about://dtree%s%s"
(w3m-dtree-expand-file-name
(file-name-as-directory
(expand-file-name path)))
(if allfiles "?allfiles=true" ""))))
(provide 'w3m-dtree)
;;; w3m-dtree.el ends here

1410
share/emacs/site-lisp/w3m/w3m-ems.el Normal file
View file

File diff suppressed because it is too large Load diff

367
share/emacs/site-lisp/w3m/w3m-favicon.el Normal file
View file

@ -0,0 +1,367 @@
;;; w3m-favicon.el --- utilities for handling favicon in emacs-w3m
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2009
;; 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
(eval-when-compile
(require 'cl))
;;(require 'w3m-util)
;;(require 'w3m-proc)
(require 'w3m-image)
(eval-when-compile
(defvar w3m-current-buffer)
(defvar w3m-current-url)
(defvar w3m-favicon-image)
(defvar w3m-icon-data)
(defvar w3m-modeline-favicon)
(defvar w3m-profile-directory)
(defvar w3m-use-favicon)
(defvar w3m-work-buffer-name)
(defvar w3m-work-buffer-list)
(autoload 'w3m-expand-url "w3m")
(autoload 'w3m-load-list "w3m")
(autoload 'w3m-message "w3m")
(autoload 'w3m-retrieve "w3m")
(autoload 'w3m-save-list "w3m")
(autoload 'w3m-url-readable-string "w3m"))
(defcustom w3m-favicon-size nil
"Size of favicon. The value should be `(WIDTH . HEIGHT)' or nil.
Where WIDTH and HEIGHT are positive integers; both or any of them can
be omitted."
:group 'w3m
:type '(radio (const :tag "Not specified" nil)
(cons :format "%v"
(integer :format "Width: %v " :size 0 :value 16)
(integer :format "Height: %v " :size 0 :value 16))))
(defconst w3m-favicon-name "favicon.ico"
"The favicon name.")
(add-hook 'w3m-display-functions 'w3m-favicon-setup)
(defcustom w3m-favicon-use-cache-file nil
"*If non-nil, use favicon cache file."
:group 'w3m
:type 'boolean)
(defcustom w3m-favicon-cache-file nil
"Filename of saving favicon cache.
It defaults to the file named \".favicon\" under the directory specified
by the `w3m-profile-directory' variable."
:group 'w3m
:type '(radio (const :format "Not specified\n")
(file :format "%t: %v\n" :size 0)))
(defcustom w3m-favicon-cache-expire-wait (* 30 24 60 60)
"*The cache will be expired after specified seconds passed since retrieval.
If this variable is nil, never expired."
:group 'w3m
:type '(integer :size 0))
(defcustom w3m-favicon-type
(let ((types '(png gif pbm xpm bmp))
type)
(catch 'det
(while types
(setq type (car types)
types (cdr types))
(if (if (featurep 'xemacs)
(featurep type)
(image-type-available-p type))
(throw 'det type)))))
"*Image type of display favicon."
:group 'w3m
:type (cons 'radio
(let ((types (if (or
(featurep 'xemacs)
(not (fboundp 'image-types)))
(delq nil
(mapcar (lambda (type)
(if (featurep type) type))
'(gif jpeg png tiff xpm)))
(delq 'postscript (copy-sequence image-types)))))
(nconc (mapcar (lambda (x)
`(const :format "%v " ,x))
(butlast types))
`((const ,(car (last types))))))))
(defcustom w3m-space-before-favicon " "
"String of space char(s) to be put in front of favicon in the mode-line.
It may be better to use two or more spaces if you are using oblique or
italic font in the modeline."
:group 'w3m
:type 'string)
(defcustom w3m-favicon-convert-args nil
"List of additional arguments passed to ImageMagick's convert program.
Args that are always passed to convert in addition to this value are:
\(\"-geometry\" \"WIDTHxHEIGHT\" \"fromTYPE:temp-file\" \"toTYPE:-\")
Args might also contain (\"-transparent\" \"COLOR\") in the beginning.
Note that this value is effective only with Emacs 22 and greater."
:group 'w3m
:type `(repeat (group :inline t
:match-inline
(lambda (widget vals)
(if (and (eq (aref (car vals) 0) ?-)
(cdr vals)
(not (eq (aref (nth 1 vals) 0) ?-)))
(cons (list (car vals) (nth 1 vals))
(nthcdr 2 vals))
(cons (list (car vals)) (cdr vals))))
(string :format "Arg: %v " :value "-" :size 0)
(checklist :inline t
(string :format "Value: %v\n" :size 0)))))
(defcustom w3m-favicon-default-background nil
"Color name used as transparent color of favicon image.
Nil means to use the background color of the Emacs frame. The null
string \"\" is special, that will be replaced with the background color
of the header line or the mode line on which the favicon is displayed.
Note that this value is effective only with Emacs 22 and greater."
:group 'w3m
:type '(radio (string :format "Color: %v\n" :size 0
:match (lambda (widget value)
(and (stringp value) (> (length value) 0))))
(const :tag "Use the background color of the Emacs frame" nil)
(const :tag "Null string" "")))
(defvar w3m-favicon-type-alist '((pbm . ppm))
"A list of a difference type of image between Emacs and ImageMagick.
0. Type of Emacs
1. Type of ImageMagick")
(defvar w3m-favicon-cache-data nil
"A list of favicon cache (internal variable).
Each information is a list whose elements are:
0. URL
1. (RAW_DATA . TYPE)
2. DATE when the RAW_DATA was retrieved
3. IMAGE
Where IMAGE highly depends on the Emacs version and is not saved in
the cache file.")
(w3m-static-if (featurep 'xemacs)
(set 'w3m-modeline-favicon
'("" w3m-space-before-favicon w3m-favicon-image))
(put 'w3m-modeline-favicon 'risky-local-variable t))
(make-variable-buffer-local 'w3m-modeline-favicon)
(make-variable-buffer-local 'w3m-favicon-image)
(defmacro w3m-favicon-cache-p (url)
"Say whether the favicon data for URL has been chached."
`(assoc ,url w3m-favicon-cache-data))
(defmacro w3m-favicon-cache-favicon (url)
"Pull out the favicon image corresponding to URL from the cache."
`(nth 3 (assoc ,url w3m-favicon-cache-data)))
(defmacro w3m-favicon-cache-retrieved (url)
"Return the time when the favicon data for URL was retrieved."
`(nth 2 (assoc ,url w3m-favicon-cache-data)))
(defmacro w3m-favicon-set-image (image)
"Set IMAGE to `w3m-favicon-image' and `w3m-modeline-favicon'."
(if (featurep 'xemacs)
`(set 'w3m-favicon-image ,image)
`(when (setq w3m-favicon-image ,image)
(set 'w3m-modeline-favicon
(list ""
'w3m-space-before-favicon
(propertize " " 'display w3m-favicon-image)
(propertize " " 'display '(space :width 0.5)))))))
(defun w3m-favicon-setup (url)
"Set up the favicon data in the current buffer. The buffer-local
variable `w3m-favicon-image' will be set to non-nil value when the
favicon is ready."
(w3m-favicon-set-image nil)
(when (and w3m-use-favicon
w3m-current-url
(w3m-static-if (featurep 'xemacs)
(and (device-on-window-system-p)
(featurep w3m-favicon-type))
(and (display-images-p)
(image-type-available-p w3m-favicon-type))))
(let (icon)
(cond
((and (string-match "\\`about://\\([^/]+\\)/" url)
(setq icon (intern-soft (concat "w3m-about-" (match-string 1 url)
"-favicon"))))
(with-current-buffer w3m-current-buffer
(w3m-favicon-set-image
(w3m-favicon-convert
(base64-decode-string (symbol-value icon)) 'ico))))
((or (string-match "\\`https?://" url)
(and (string-match "\\`about://\\(?:header\\|source\\)/https?://"
url)
(setq url (substring url 15))))
(if w3m-icon-data
(w3m-favicon-retrieve (car w3m-icon-data) (cdr w3m-icon-data)
w3m-current-buffer)
(w3m-favicon-retrieve (w3m-expand-url (concat "/" w3m-favicon-name)
url)
'ico w3m-current-buffer)))))))
(defun w3m-favicon-convert (data type)
"Convert the favicon DATA in TYPE to the favicon image and return it."
(when (or (not (eq type 'ico))
;; Since most of favicons are the `ico' types, we make sure
;; of the magic-numbers only as for them.
(string-equal "\x00\x00\x01\x00" (substring data 0 4)))
(let ((height (or (cdr w3m-favicon-size)
(w3m-static-if (featurep 'xemacs)
(face-height 'default)
(frame-char-height))))
(new (w3m-static-unless (featurep 'xemacs)
(>= emacs-major-version 22)))
bg args img)
;; Examine the transparent color of the image.
(when (and w3m-imagick-identify-program
(equal w3m-favicon-default-background ""))
(with-temp-buffer
(set-buffer-multibyte nil)
(insert data)
(let ((coding-system-for-read 'raw-text)
(coding-system-for-write 'binary))
(condition-case nil
(call-process-region (point-min) (point-max)
w3m-imagick-identify-program
t t nil "-verbose" (format "%s:-" type))
(error)))
(goto-char (point-min))
(setq case-fold-search t)
(while (and (not bg)
(re-search-forward "^ *Transparent +color: *\
\\([^\n ]+\\(?: +[^\n ]+\\)*\\)" nil t))
(when (string-match "\\`none\\'" (setq bg (match-string 1)))
(setq bg nil)))))
(setq args (list "-geometry"
(format "%dx%d"
(or (car w3m-favicon-size) height) height)))
(w3m-static-unless (featurep 'xemacs)
(when new
;; "-transparent" should precede the other arguments.
(setq args (nconc (when bg (list "-transparent" bg))
args
w3m-favicon-convert-args))))
(setq img (apply
#'w3m-imagick-convert-data
data (symbol-name type)
(symbol-name (or (cdr (assq w3m-favicon-type
w3m-favicon-type-alist))
w3m-favicon-type))
args))
(when img
(w3m-static-if (featurep 'xemacs)
(make-glyph
(make-image-instance (vector w3m-favicon-type :data img)))
(if new
(create-image img w3m-favicon-type t
:ascent 'center
:background w3m-favicon-default-background)
(create-image img w3m-favicon-type t :ascent 'center)))))))
(defun w3m-favicon-retrieve (url type target)
"Retrieve favicon from URL and convert it to image as TYPE in TARGET.
TYPE is a symbol like `ico' and TARGET is a buffer where the image is
stored in the `w3m-favicon-image' buffer-local variable."
(if (and (w3m-favicon-cache-p url)
(or (null w3m-favicon-cache-expire-wait)
(< (- (w3m-float-time)
(w3m-float-time (w3m-favicon-cache-retrieved url)))
w3m-favicon-cache-expire-wait)))
(with-current-buffer target
(w3m-favicon-set-image (w3m-favicon-cache-favicon url)))
(lexical-let ((url url)
(type type)
(target target)
(silent w3m-message-silent))
(w3m-process-with-null-handler
(w3m-process-do-with-temp-buffer
(ok (w3m-retrieve url 'raw nil nil nil handler))
(let ((w3m-message-silent silent)
idata image)
(if (and ok
;; Some broken servers provides empty contents.
(>= (buffer-size) 4))
(setq idata (buffer-string)
image (w3m-favicon-convert idata type))
(w3m-message "Reading %s...done (no favicon)"
(w3m-url-readable-string url)))
(with-current-buffer target
(w3m-favicon-set-image image)
(push (list url idata (current-time) w3m-favicon-image)
w3m-favicon-cache-data)))))))
;; Emacs frame needs to be redisplayed to make favicon come out.
(w3m-force-window-update-later target 1))
(defun w3m-favicon-save-cache-file ()
"Save the cached favicon data into the local file."
(when w3m-favicon-use-cache-file
(w3m-save-list (or w3m-favicon-cache-file
(expand-file-name ".favicon" w3m-profile-directory))
(delq nil (mapcar (lambda (elem)
(when (= (length elem) 4)
(butlast elem)))
w3m-favicon-cache-data))
'binary)))
(defun w3m-favicon-load-cache-file ()
"Load the cached favicon data from the local file."
(when (and w3m-favicon-use-cache-file
(null w3m-favicon-cache-data))
(let ((cache (w3m-load-list
(or w3m-favicon-cache-file
(expand-file-name ".favicon" w3m-profile-directory))
'binary))
elem data image)
(while cache
(setq elem (car cache)
cache (cdr cache)
data (cadr elem))
(when (stringp data)
(setcar (cdr elem) (setq data (cons data 'ico))))
(when (setq image (condition-case nil
(w3m-favicon-convert (car data) (cdr data))
(error nil)))
(push (nconc elem (list image)) w3m-favicon-cache-data))))))
(add-hook 'w3m-arrived-setup-functions 'w3m-favicon-load-cache-file)
(add-hook 'w3m-arrived-shutdown-functions 'w3m-favicon-save-cache-file)
(provide 'w3m-favicon)
;;; w3m-favicon.el ends here

208
share/emacs/site-lisp/w3m/w3m-fb.el Normal file
View file

@ -0,0 +1,208 @@
;;; w3m-fb.el --- frame-local buffers support for Emacs-w3m
;;; Copyright (C) 2005, 2006 Matthew P. Hodges
;; Author: Matthew P. Hodges <MPHodges@member.fsf.org>
;; Version: $Id: w3m-fb.el,v 1.4 2006/09/20 09:26:42 yamaoka Exp $
;; w3m-fb.el 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.
;; w3m-fb.el 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.
;;; Commentary:
;;
;; With this mode switched on, W3M buffers are associated with the
;; frame on which they were created. Only tabs for the current
;; frame's W3M buffers are shown (with non-nil w3m-use-tab); other
;; affected commands are w3m-next-buffer w3m-previous-buffer,
;; w3m-select-buffer and w3m-quit.
;;
;; Switch the mode on programmatically with:
;;
;; (w3m-fb-mode 1)
;;
;; or toggle interactively with M-x w3m-fb-mode RET.
;;; Code:
(defconst w3m-fb-version "1.0.0"
"Version number of this package.")
(eval-when-compile
(autoload 'w3m-delete-buffer "w3m" nil t)
(autoload 'w3m-list-buffers "w3m-util")
(autoload 'w3m-next-buffer "w3m" nil t)
(defvar w3m-pop-up-frames))
(eval-and-compile
(defalias 'w3m-fb-frame-parameter
(cond
((fboundp 'frame-parameter)
'frame-parameter)
((fboundp 'frame-property)
'frame-property)
(t
(error "No frame parameter/property function")))))
(defvar w3m-fb-delete-frame-functions
(cond
((boundp 'delete-frame-functions)
'delete-frame-functions)
((boundp 'delete-frame-hook)
'delete-frame-hook)
(t
(error "No delete-frame hook/functions variable found")))
"Symbol associated with `delete-frame' hooks.")
(defvar w3m-fb-list-buffers-frame nil
"Frame to list buffers for in `w3m-list-buffers'.
Bind this if the buffers associated with a frame other than the
selected frame are required.")
;; Customizable variables
(defgroup w3m-fb nil
"Frame local buffers for Emacs-w3m."
:group 'w3m)
(defcustom w3m-fb-delete-frame-kill-buffers t
"If non-nil, kill W3M buffers after deleting frames."
:group 'w3m-fb
:type 'boolean
:set (lambda (sym val)
(set sym val)
(when (boundp 'w3m-fb-mode)
(if w3m-fb-mode
(add-hook w3m-fb-delete-frame-functions
'w3m-fb-delete-frame-buffers)
(remove-hook w3m-fb-delete-frame-functions
'w3m-fb-delete-frame-buffers)))))
;; Internal variables
(defvar w3m-fb-buffer-list nil
"List of w3m buffers associated with the selected frame.")
(defvar w3m-fb-inhibit-buffer-selection nil
"Non-nil to inhibit selecting a suitable w3m buffer.")
;; Internal functions
(defun w3m-fb-delete-frame-buffers (&optional frame)
"Delete W3M buffers associated with frame FRAME."
(let* ((w3m-fb-list-buffers-frame frame)
(buffers (w3m-list-buffers))
;; Now bind w3m-fb-mode to nil so that w3m-delete-buffer
;; doesn't call w3m-quit when there are w3m buffers belonging
;; to other frames.
(w3m-fb-mode nil)
(w3m-fb-inhibit-buffer-selection t))
(save-window-excursion
(dolist (b buffers)
(with-current-buffer b
(w3m-delete-buffer))))))
;; Could use set-frame-parameter here, but it isn't portable
(defun w3m-fb-set-frame-parameter (frame parameter value)
"Set for frame FRAME parameter PARAMETER to VALUE."
(modify-frame-parameters frame (list (cons parameter value))))
(defun w3m-fb-add ()
"Add current buffer to `w3m-fb-buffer-list'."
(let ((val (w3m-fb-frame-parameter nil 'w3m-fb-buffer-list)))
(w3m-fb-set-frame-parameter
nil 'w3m-fb-buffer-list (nconc val (list (current-buffer))))))
(defun w3m-fb-remove ()
"Remove current buffer from `w3m-fb-buffer-list'.
Applies to all frames."
(when (eq major-mode 'w3m-mode)
(let (val)
(dolist (f (frame-list))
(setq val (w3m-fb-frame-parameter f 'w3m-fb-buffer-list))
(w3m-fb-set-frame-parameter
f 'w3m-fb-buffer-list (delq (current-buffer) val))))))
(defun w3m-fb-associate ()
"Associate all `w3m-mode' buffers with a frame."
(let (buffers done rest)
;; Buffers displayed in windows
(dolist (f (frame-list))
(setq buffers nil)
(dolist (w (window-list f nil (frame-selected-window f)))
(when (with-current-buffer (window-buffer w)
(eq major-mode 'w3m-mode))
(setq buffers (nconc buffers (list (window-buffer w))))
(setq done (nconc done (list (window-buffer w))))))
(w3m-fb-set-frame-parameter
f 'w3m-fb-buffer-list buffers))
;; Buffers not displayed in windows; add to selected frame
(let ((w3m-fb-mode nil))
(setq rest (w3m-list-buffers)))
(dolist (b done)
(setq rest (delq b rest)))
(when rest
(w3m-fb-set-frame-parameter
nil 'w3m-fb-buffer-list
(nconc (w3m-fb-frame-parameter nil 'w3m-fb-buffer-list) rest)))))
(defun w3m-fb-dissociate ()
"Disassociate `w3m-mode' buffers from frames."
(dolist (f (frame-list))
(w3m-fb-set-frame-parameter f 'w3m-fb-buffer-list nil)))
(defun w3m-fb-select-buffer ()
"Select an appropriate W3M buffer to display."
;; If there are w3m buffers belonging to this frame, ensure one is
;; selected; if not make sure that we're not displaying a w3m
;; buffer
(cond
;; Select w3m buffer belonging to frame, if one is available
((w3m-list-buffers)
(unless (memq (current-buffer) (w3m-list-buffers))
(w3m-next-buffer -1)))
(t
;; If no w3m buffers belong to frame, don't display any w3m buffer
(while (eq major-mode 'w3m-mode)
;; (assert (eq (current-buffer)
;; (window-buffer (selected-window))))
(bury-buffer)))))
;; Minor mode setup
;;;###autoload
(define-minor-mode w3m-fb-mode
"Toggle W3M Frame Buffer mode.
This allows frame-local lists of buffers (tabs)."
:init-value nil
:group 'w3m-fb
:global t
(if (and w3m-fb-mode
(if w3m-pop-up-frames
(prog1
(setq w3m-fb-mode nil)
(message "\
W3M Frame Buffer mode not activated (non-nil w3m-pop-up-frames)")
(sit-for 2))
t))
(progn
(add-hook 'w3m-mode-hook 'w3m-fb-add)
(add-hook 'kill-buffer-hook 'w3m-fb-remove)
(when w3m-fb-delete-frame-kill-buffers
(add-hook w3m-fb-delete-frame-functions
'w3m-fb-delete-frame-buffers))
(w3m-fb-associate))
(remove-hook 'w3m-mode-hook 'w3m-fb-add)
(remove-hook 'kill-buffer-hook 'w3m-fb-remove)
(remove-hook w3m-fb-delete-frame-functions 'w3m-fb-delete-frame-buffers)
(w3m-fb-dissociate)))
(provide 'w3m-fb)
;;; w3m-fb.el ends here

367
share/emacs/site-lisp/w3m/w3m-filter.el Normal file
View file

@ -0,0 +1,367 @@
;;; w3m-filter.el --- filtering utility of advertisements on WEB sites -*- coding: euc-japan -*-
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; w3m-filter.el is the add-on utility to filter advertisements on WEB
;; sites.
;;; Code:
(provide 'w3m-filter)
(eval-when-compile
(require 'cl))
(require 'w3m)
(defcustom w3m-filter-rules
`(("\\`http://www\\.geocities\\.co\\.jp/"
w3m-filter-delete-regions
"<DIV ALIGN=CENTER>\n<!--*/GeoGuide/*-->" "<!--*/GeoGuide/*-->\n</DIV>")
("\\`http://[a-z]+\\.hp\\.infoseek\\.co\\.jp/"
w3m-filter-delete-regions
"<!-- start AD -->" "<!-- end AD -->")
("\\`http://linux\\.ascii24\\.com/linux/"
w3m-filter-delete-regions
"<!-- DAC CHANNEL AD START -->" "<!-- DAC CHANNEL AD END -->")
("\\`http://\\(www\\|images\\|news\\|maps\\|groups\\)\\.google\\."
w3m-filter-google)
("\\`https?://\\(?:www\\.\\)?amazon\\.\
\\(?:com\\|co\\.\\(?:jp\\|uk\\)\\|fr\\|de\\)/"
w3m-filter-amazon)
("\\`https?://mixi\\.jp" w3m-filter-mixi)
("\\`http://eow\\.alc\\.co\\.jp/[^/]+/UTF-8" w3m-filter-alc)
("\\`http://www\\.asahi\\.com/" w3m-filter-asahi-shimbun)
("\\`http://imepita\\.jp/[0-9]+/[0-9]+" w3m-filter-imepita)
("\\`http://allatanys\\.jp/" w3m-filter-allatanys)
("\\`http://.*\\.wikipedia\\.org/" w3m-filter-wikipedia)
("" w3m-filter-iframe))
"Rules to filter advertisements on WEB sites."
:group 'w3m
:type '(repeat
(cons :format "%v" :indent 4
(regexp :format "Regexp: %v\n" :size 0)
(choice
:tag "Filtering Rule"
(list :tag "Delete regions surrounded with these patterns"
(function-item :format "" w3m-filter-delete-region)
(regexp :tag "Start")
(regexp :tag "End"))
(list :tag "Filter with a user defined function"
function
(repeat :tag "Arguments" sexp))))))
(defcustom w3m-filter-google-use-utf8
(or (featurep 'un-define) (fboundp 'utf-translate-cjk-mode)
(and (not (equal "Japanese" w3m-language))
(w3m-find-coding-system 'utf-8)))
"*Use the converting rule to UTF-8 on the site of Google."
:group 'w3m
:type 'boolean)
(defcustom w3m-filter-google-use-ruled-line t
"*Use the ruled line on the site of Google."
:group 'w3m
:type 'boolean)
(defcustom w3m-filter-google-separator "<hr>"
"Field separator for Google's search results ."
:group 'w3m
:type 'string)
(defcustom w3m-filter-amazon-regxp
(concat
"\\`\\(https?://\\(?:www\\.\\)?amazon\\."
"\\(?:com\\|co\\.\\(?:jp\\|uk\\)\\|fr\\|de\\)"
;; "Joyo.com"
"\\)/"
"\\(?:"
"\\(?:exec/obidos\\|o\\)/ASIN"
"\\|"
"gp/product"
"\\|"
"\\(?:[^/]+/\\)?dp"
"\\)"
"/\\([0-9]+\\)")
"*Regexp to extract ASIN number for Amazon."
:group 'w3m
:type '(string :size 0))
(defcustom w3m-filter-amazon-short-url-bottom nil
"*Amazon short URLs insert bottom position."
:group 'w3m
:type 'boolean)
;;;###autoload
(defun w3m-filter (url)
"Apply filtering rule of URL against a content in this buffer."
(save-match-data
(dolist (elem w3m-filter-rules)
(when (string-match (car elem) url)
(apply (cadr elem) url (cddr elem))))))
(defun w3m-filter-delete-regions (url start end)
"Delete regions surrounded with a START pattern and an END pattern."
(goto-char (point-min))
(let (p (i 0))
(while (and (search-forward start nil t)
(setq p (match-beginning 0))
(search-forward end nil t))
(delete-region p (match-end 0))
(incf i))
(> i 0)))
(defun w3m-filter-replace-regexp (url regexp to-string)
"Replace all occurrences of REGEXP with TO-STRING."
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(replace-match to-string nil nil)))
;; Filter functions:
(defun w3m-filter-asahi-shimbun (url)
"Convert entity reference of UCS."
(when w3m-use-mule-ucs
(goto-char (point-min))
(let ((case-fold-search t)
end ucs)
(while (re-search-forward "alt=\"\\([^\"]+\\)" nil t)
(goto-char (match-beginning 1))
(setq end (set-marker (make-marker) (match-end 1)))
(while (re-search-forward "&#\\([0-9]+\\);" (max end (point)) t)
(setq ucs (string-to-number (match-string 1)))
(delete-region (match-beginning 0) (match-end 0))
(insert-char (w3m-ucs-to-char ucs) 1))))))
(defun w3m-filter-google (url)
"Insert separator within items."
(goto-char (point-min))
(let ((endm (make-marker))
(case-fold-search t)
pos beg end)
(when (and w3m-filter-google-use-utf8
(re-search-forward "\
<a class=. href=\"http://\\(www\\|images\\|news\\|maps\\|groups\\)\\.google\\."
nil t)
(setq pos (match-beginning 0))
(search-backward "<table" nil t)
(setq beg (match-beginning 0))
(search-forward "</table" nil t)
(set-marker endm (match-end 0))
(< pos (marker-position endm)))
(goto-char beg)
(while (re-search-forward "[?&][io]e=\\([^&]+\\)&" endm t)
(replace-match "UTF-8" nil nil nil 1))
(setq end (marker-position endm)))
(when (string-match "\\`http://www\\.google\\.[^/]+/search\\?" url)
(goto-char (point-max))
(when (and w3m-filter-google-use-ruled-line
(search-backward "<div class=" end t)
(search-forward "</div>" nil t))
(insert w3m-filter-google-separator))
(if w3m-filter-google-use-ruled-line
(while (search-backward "<div class=" end t)
(insert w3m-filter-google-separator))
(while (search-backward "<div class=" end t)
(insert "<p>"))))))
(defun w3m-filter-amazon (url)
"Insert Amazon short URIs."
(when (string-match w3m-filter-amazon-regxp url)
(let* ((base (match-string 1 url))
(asin (match-string 2 url))
(shorturls `(,(concat base "/dp/" asin "/")
,(concat base "/o/ASIN/" asin "/")
,(concat base "/gp/product/" asin "/")))
(case-fold-search t)
shorturl)
(goto-char (point-min))
(setq url (file-name-as-directory url))
(when (or (and (not w3m-filter-amazon-short-url-bottom)
(search-forward "<body" nil t)
(search-forward ">" nil t))
(and w3m-filter-amazon-short-url-bottom
(search-forward "</body>" nil t)
(goto-char (match-beginning 0))))
(insert "\n")
(while (setq shorturl (car shorturls))
(setq shorturls (cdr shorturls))
(unless (string= url shorturl)
(insert (format "Amazon Short URL: <a href=\"%s\">%s</a><br>\n"
shorturl shorturl))))
(insert "\n")))))
(defun w3m-filter-mixi (url)
"Direct jump to the external diary."
(goto-char (point-min))
(let (newurl)
(while (re-search-forward "<a href=\"?view_diary\\.pl\\?url=\\([^>]+\\)>"
nil t)
(setq newurl (match-string 1))
(when newurl
(delete-region (match-beginning 0) (match-end 0))
(when (string-match "&owner_id=[0-9]+\"?\\'" newurl)
(setq newurl (substring newurl 0 (match-beginning 0))))
(insert (format "<a href=\"%s\">"
(w3m-url-readable-string newurl)))))))
(defun w3m-filter-alc (url)
(let ((baseurl "http://eow.alc.co.jp/%s/UTF-8/")
curl cword beg tmp1)
(when (string-match "\\`http://eow\\.alc\\.co\\.jp/\\([^/]+\\)/UTF-8/" url)
(setq curl (match-string 0 url))
(setq cword (match-string 1 url))
(setq cword (car (split-string (w3m-url-decode-string cword 'utf-8)
" ")))
(goto-char (point-min))
(while (search-forward "データの転載は禁じられています" nil t)
(delete-region (line-beginning-position) (line-end-position))
(insert "<br>"))
(goto-char (point-min))
(when (search-forward "<body" nil t)
(forward-line 1)
(insert "<h1>英辞朗 on the WEB<h1>\n")
(setq beg (point))
(when (search-forward "<!-- ▼検索文字列 -->" nil t)
(forward-line 1)
(delete-region beg (point)))
(when (search-forward "<!-- ▼ワードリンク 履歴 -->" nil t)
(forward-line 1)
(setq beg (point))
(when (search-forward "</body>" nil t)
(delete-region beg (match-beginning 0))))
(insert "<br>＊データの転載は禁じられています。")
;; next/previous page
(goto-char (point-min))
(while (re-search-forward
"<a href='javascript:goPage(\"\\([0-9]+\\)\")'>"
nil t)
(setq tmp1 (match-string 1))
(delete-region (match-beginning 0) (match-end 0))
(insert (format "<a href=\"%s?pg=%s\">" curl tmp1)))
;; wordlink
(goto-char (point-min))
(while (re-search-forward
"<span class=\"wordlink\">\\([^<]+\\)</span>"
nil t)
(setq tmp1 (match-string 1))
(delete-region (match-beginning 0) (match-end 0))
(insert (format "<a href=\"%s\">%s</a>" (format baseurl tmp1) tmp1)))
;; goGradable/goFairWord
(goto-char (point-min))
(while (re-search-forward
"<a href='javascript:\\(goGradable\\|goFairWord\\)(\"\\([^\"]+\\)\")'>"
nil t)
(setq tmp1 (match-string 2))
(delete-region (match-beginning 0) (match-end 0))
(insert (format "<a href=\"%s\">" (format baseurl tmp1))))
;; remove spacer
(goto-char (point-min))
(while (search-forward "img/spacer.gif" nil t)
(delete-region (line-beginning-position) (line-end-position)))
(goto-char (point-min))
;; remove ワードリンク
(when (search-forward "alt=\"ワードリンク\"" nil t)
(delete-region (line-beginning-position) (line-end-position)))
;; 全文を表示するは無理
(goto-char (point-min))
(while (re-search-forward
(concat "<br */> *⇒<strong>"
"<a href='javascript:goFullText(\"[^\"]+\", \"[^\"]+\")'>"
"全文を表示する</a>")
nil t)
(delete-region (match-beginning 0) (match-end 0)))
;; Java Document write... ;_;
;; (while (re-search-forward
;; "<a href='javascript:goFullText(\"\\([^\"]+\\)\", \"\\([^\"]+\\)\")'>"
;; nil t)
;; (setq tmp1 (match-string 1))
;; (setq tmp2 (match-string 2))
;; (delete-region (match-beginning 0) (match-end 0))
;; ;; &dk=JE, &dk=EJ
;; (insert (format "<a href=\"%s?ref=ex&exp=%s&dn=%s&dk=%s\">"
;; curl tmp1 tmp2
;; (if (string-match "\\Cj" cword) "JE" "EJ"))))
))))
(defun w3m-filter-imepita (url)
"JavaScript emulation."
(goto-char (point-min))
(let (tmp)
(when (re-search-forward
(concat "<script><!--\ndocument.write('\\([^\n]*\\)');\r\n//--></script>\n"
"<noscript>.*</noscript>")
nil t)
(setq tmp (match-string 1))
(delete-region (match-beginning 0) (match-end 0))
(insert tmp))))
(defun w3m-filter-iframe (url)
(goto-char (point-min))
(while (re-search-forward "<iframe [^>]*src=\"\\([^\"]*\\)\"[^>]*>" nil t)
(insert (concat "[iframe:<a href=\"" (match-string 1) "\">" (match-string 1) "</a>]"))))
(defun w3m-filter-allatanys (url)
"JavaScript emulation."
(goto-char (point-min))
(let (aturl atexpurl)
(if (re-search-forward
(concat "<body[ \t\r\f\n]+onload=\"window\\.top\\.location\\.replace('"
w3m-html-string-regexp
"');\">")
nil t)
(progn
(setq aturl (match-string 1))
(setq atexpurl (w3m-expand-url aturl url))
(delete-region (match-beginning 0) (match-end 0))
(insert "<body>\n"
"<hr>"
"Body has a <b>url=window.top.location.replace()</b><br><br>\n"
(format "Goto: <a href=%s>%s</a>\n" aturl atexpurl)
"<hr>")
(goto-char (point-min))
(insert (format "<meta HTTP-EQUIV=\"Refresh\" CONTENT=\"0;URL=%s\">\n"
aturl)))
(while (re-search-forward (concat "<a[ \t\r\l\n]+href=\"javascript:[^(]+('"
"\\([^']+\\)')\">")
nil t)
(setq aturl (match-string 1))
(delete-region (match-beginning 0) (match-end 0))
(insert (format "<a href=\"%s\">" aturl))))))
(defun w3m-filter-wikipedia (url)
"Make anchor reference to work."
(goto-char (point-min))
(let (matched-text refid)
(while (re-search-forward
"<\\(?:sup\\|cite\\) id=\"\\([^\"]*\\)\"" nil t)
(setq matched-text (match-string 0)
refid (match-string 1))
(delete-region (match-beginning 0) (match-end 0))
(insert (format "<a name=\"%s\"></a>%s" refid matched-text)))))
;;; w3m-filter.el ends here

1896
share/emacs/site-lisp/w3m/w3m-form.el Normal file
View file

File diff suppressed because it is too large Load diff

732
share/emacs/site-lisp/w3m/w3m-hist.el Normal file
View file

@ -0,0 +1,732 @@
;;; w3m-hist.el --- the history management system for emacs-w3m
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2008, 2009, 2010
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Author: 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Emacs-w3m keeps history in the buffer-local variables `w3m-history'
;; and `w3m-history-flat'. Each variable contains a list of all the
;; links you have visited. The behavior tracing history backward or
;; forward is controlled by the `w3m-history-reuse-history-elements'
;; variable. See the documentations for those variables for details.
;;; Code:
(eval-when-compile
(require 'cl))
(defcustom w3m-history-reuse-history-elements nil
"Non-nil means reuse the history element when re-visiting the page.
Otherwise, a new history element will be created even if there are
elements for the same url in the history.
Emacs-w3m used to operate as the case in which it is non-nil, however
it sometimes brought about users' dissatisfaction. For example, if a
user visited the pages A -> B -> C -> B in order, performing BACK on
the second B would let a user visit A. The reason why a user was
taken to A rather than C is that the `w3m-history' variable only had
the list `(A B C)' as a history and B was the current position at that
time.
The default value for this variable is nil which allows the
`w3m-history' variable to have the list `(A B C B)'. Where contents
of two B's are the identical Lisp objects. So, too much wasting the
Lisp resources will be avoided.
See the documentation for the variables `w3m-history' and
`w3m-history-flat' for more information."
:group 'w3m
:type '(boolean :format "%{%t%}: %[%v%]" :on "On" :off "Off"))
(defcustom w3m-history-minimize-in-new-session nil
"Non-nil means minimize copied history so that there's only current page.
This variable is effective when creating of the new session by copying
\(i.e., `w3m-copy-buffer')."
:group 'w3m
:type '(boolean :format "%{%t%}: %[%v%]" :on "On" :off "Off"))
(defvar w3m-history nil
"A tree-structured complex list of all the links which you have visited.
This is a buffer-local variable. For example, it will grow as follows:
\[Branch-1.0.0.0]: +--> U1.0.0.0.0 --> U1.0.0.0.1
|
[Branch-1.0]: +--> U1.0.0 --> U1.0.1 --> U1.0.2
|
[Trunk]: U0 --> U1 --> U2 --> U3 --> U4 --> U5 --> U6
|
[Branch-2.0]: +--> U2.0.0 --> U2.0.1
|
[Branch-2.1]: +--> U2.1.0 --> U2.1.1 --> U2.1.2
|
\[Branch-2.1.1.0]: +--> U2.1.1.0.0
In this case, the U1.0.0.0.0 history element represents the first link
of the first branch which is sprouted from the U1.0.0 history element.
The trunk or each branch is a simple list which will contain some
history elements. History elements in the trunk or each branch will
be arranged in increasing order (the newest history element will be
the last element of the list). Each history element represents a link
which consists of the following records:
(URL PROPERTIES BRANCH BRANCH ...)
Where URL is a string of an address of a link. PROPERTIES is a plist
which is able to contain any kind of data to supplement the URL as
follows:
(KEYWORD VALUE KEYWORD VALUE ...)
A note for programmers: PROPERTIES should always be a non-nil value in
order to make it easy to share the value in every history element in
every emacs-w3m buffer.
The remaining BRANCHes are branches of the history element. Branches
will also be arranged in increasing order (the newest one will be the
rightmost element). Each BRANCH will also be a tree-structured
complex list. Therefore, the history structure will grow up
infinitely.
In order to save the Lisp resources, URL strings and PROPERTIES in the
`w3m-history' variables are shared in every emacs-w3m buffer (it means
each element in two `w3m-history' variables can be compared by `eq'
rather than `equal'). If there is necessity to make buffer-local
properties, in other words, to make properties of which values differ
in every emacs-w3m buffer, use the `w3m-history-flat' variable instead.
There are special rules on the emacs-w3m history management system.
As you perhaps foresaw, the operation BACK on U2.0.0 brings you to U2,
and one more BACK brings you to U1. Well, where do you think we
should go next when the operation FORWARD is performed on U1? The
rule is to go to the newest link you have ever visited. So, that
operation should take you to U1.0.0.
Another rule is that the new U4 link should sprout from U1.0.1 if
`w3m-history-reuse-history-elements' is nil when you visit the U4 link
directly from U1.0.1. In contrast, you should be taken to the
existing U4 link instead of sprouting the new branch from U1.0.1 if
`w3m-history-reuse-history-elements' is non-nil.
In addition, the first element of `w3m-history' is special. It is a
list containing pointers which point to three history elements as
shown below:
(PREV CURRENT NEXT)
PREV points to the previous history element, CURRENT points to the
current one and NEXT points to the next one. Each of them is a list
which contains an odd number of integers. For example, `(0)' does
point to U0 and `(2 1 0)' does point to U2.1.0. Finally, the value of
the `w3m-history' variable will be constructed as follows:
\(((1) (2) (2 1 0))
(\"http://www.U0.org/\" (:title \"U0\" :foo \"bar\"))
(\"http://www.U1.org/\" (:title \"U1\" :foo \"bar\")
((\"http://www.U100.org/\" (:title \"U100\" :foo \"bar\")
((\"http://www.U10000.org/\" (:title \"U10000\" :foo \"bar\"))
(\"http://www.U10001.org/\" (:title \"U10001\" :foo \"bar\"))))
(\"http://www.U101.org/\" (:title \"U101\" :foo \"bar\"))
(\"http://www.U102.org/\" (:title \"U102\" :foo \"bar\"))))
(\"http://www.U2.org/\" (:title \"U2\" :foo \"bar\")
((\"http://www.U200.org/\" (:title \"U200\" :foo \"bar\"))
(\"http://www.U201.org/\" (:title \"U201\" :foo \"bar\")))
((\"http://www.U210.org/\" (:title \"U210\" :foo \"bar\"))
(\"http://www.U211.org/\" (:title \"U211\" :foo \"bar\")
((\"http://www.U21100.org/\" (:title \"U21100\" :foo \"bar\"))))
(\"http://www.U212.org/\" (:title \"U212\" :foo \"bar\"))))
(\"http://www.U3.org/\" (:title \"U3\" :foo \"bar\"))
(\"http://www.U4.org/\" (:title \"U4\" :foo \"bar\"))
(\"http://www.U5.org/\" (:title \"U5\" :foo \"bar\"))
(\"http://www.U6.org/\" (:title \"U6\" :foo \"bar\")))")
(defvar w3m-history-flat nil
"A flattened alist of all the links which you have visited.
All history elements except for buffer-local properties are the same
as ones of `w3m-history'. Each element will contain the following
records:
(URL PROPERTIES POSITION [KEYWORD VALUE [KEYWORD VALUE ...]])
Where URL is a string of an address of a link, PROPERTIES is a plist
which is able to contain any kind of data to supplement the URL. Each
PROPERTIES is the Lisp object identical with that corresponding
element of `w3m-history'. POSITION is a list of integers to designate
the current position in the history.
The remaining [KEYWORD VALUE [KEYWORD VALUE ...]] is a plist similar
to PROPERTIES, but it is buffer-local. You can manipulate
buffer-local properties using the functions `w3m-history-plist-get',
`w3m-history-plist-put', `w3m-history-add-properties' and
`w3m-history-remove-properties'. See the documentation for the
`w3m-history' variable for more information.")
(make-variable-buffer-local 'w3m-history)
(make-variable-buffer-local 'w3m-history-flat)
;; Inline functions.
(defsubst w3m-history-assoc (url)
"Extract a history element associated with URL from `w3m-history-flat'."
(assoc url w3m-history-flat))
;; Functions for internal use.
(defun w3m-history-set-current (position)
"Modify `w3m-history' so that POSITION might be the current position.
What is called the current position is the `cadar' of `w3m-history'.
The previous position and the next position will be computed
automatically."
(setcar w3m-history (w3m-history-regenerate-pointers position)))
(defun w3m-history-element (position &optional flat)
"Return a history element located in the POSITION of the history.
If FLAT is nil, the value will be extracted from `w3m-history' and
represented with the `(URL PROPERTIES BRANCH BRANCH ...)' form.
Otherwise, the value will be extracted from `w3m-history-flat' and
represented with the `(URL PROPERTIES POSITION [KEYWORD VALUE ...])'
form. FYI, to know the current position, the `(cadar w3m-history)'
form for example can be used."
(when position
(if flat
(let ((flat w3m-history-flat)
element)
(while flat
(if (equal (caddr (setq element (pop flat))) position)
(setq flat nil)
(setq element nil)))
element)
(let ((element (nth (pop position) (cdr w3m-history))))
(while position
(setq element (nth (pop position) (cddr element))
element (nth (pop position) element)))
element))))
(defun w3m-history-previous-position (position)
"Return a history position of the previous location of POSITION.
POSITION is a list of integers of the same form as being used in one
of the elements of the `car' of `w3m-history' (which see)."
(let (class number previous)
(when position
(setq class (1- (length position))
number (nth class position))
(if (zerop number)
;; This POSITION is the beginning of the branch.
(unless (zerop class)
;; There's a parent.
(setq previous (copy-sequence position))
(setcdr (nthcdr (- class 2) previous) nil))
;; This POSITION is not the beginning of the branch.
(setq previous (copy-sequence position))
(setcar (nthcdr class previous) (1- number))))
previous))
(defun w3m-history-next-position (position)
"Return a history position of the next location of POSITION.
POSITION is a list of integers of the same form as being used in one
of the elements of the `car' of `w3m-history' (which see)."
(let (next branch element number)
(when position
(setq next position
branch (cdr w3m-history)
element (nth (pop next) branch))
(while next
(setq branch (nth (pop next) (cddr element))
element (nth (pop next) branch)))
(cond ((nth 2 element)
;; There're branches sprouted from the POSITION.
(setq next (copy-sequence position))
(setcdr (nthcdr (1- (length next)) next)
(list (- (length element) 3) 0)))
((> (length branch)
(setq number (1+ (nth (1- (length position)) position))))
;; This POSITION is not the end of the branch.
(setq next (copy-sequence position))
(setcar (nthcdr (1- (length next)) next) number))))
next))
(defun w3m-history-set-plist (plist property value)
"Similar to `plist-put' but PLIST is actually modified even in XEmacs.
If VALUE is nil, the pair of PROPERTY and VALUE is removed from PLIST.
Exceptionally, if PLIST is made empty because of removing, it will be
instead set to `(nil nil)'. Return PLIST itself."
(let ((pair (memq property plist)))
(if pair
(if value
(setcar (cdr pair) value)
(if (eq (car plist) property)
(progn
(setcar plist (nth 2 plist))
(setcar (cdr plist) (nth 3 plist))
(setcdr (cdr plist) (nthcdr 4 plist)))
(setcdr (nthcdr (- (length plist) (length pair) 1) plist)
(nthcdr 2 pair))))
(when value
(setcdr (nthcdr (1- (length plist)) plist) (list property value)))))
plist)
(defun w3m-history-modify-properties (old new &optional replace)
"Merge NEW plist into OLD plist and return a modified plist.
If REPLACE is non-nil, OLD will be replaced with NEW. OLD plist is
modified and also the new value is shared in all the history
elements containing OLD plist. Properties whose values are nil are
removed from OLD plist, but if OLD plist is made empty because of
removing, it will be instead set to `(nil nil)'."
(prog1
old
(if replace
(progn
(setcar old (car new))
(setcdr old (or (cdr new) (list nil))))
(while new
(w3m-history-set-plist old (car new) (cadr new))
(setq new (cddr new))))
(setq new (copy-sequence old))
(while new
(w3m-history-set-plist old (car new) (cadr new))
(setq new (cddr new)))))
(defun w3m-history-seek-element (url &optional newprops replace)
"Return a copy of history element corresponding to URL.
Searching is performed in all emacs-w3m buffers and the first match
found is returned. If REPLACE is nil, NEPROPS will be merged into
properties of an element. Otherwise, properties of an element will be
replaced with NEWPROPS."
(let* ((current (current-buffer))
(buffers (cons current (delq current (buffer-list))))
element)
(while buffers
(set-buffer (pop buffers))
(when (and (eq major-mode 'w3m-mode)
(setq element (w3m-history-assoc url)))
(setq buffers nil)))
(set-buffer current)
(prog1
(copy-sequence element)
(when element
(w3m-history-modify-properties (cadr element) newprops replace)))))
;; Generic functions.
(defun w3m-history-previous-link-available-p ()
"Return non-nil if the previous history element is available."
(caar w3m-history))
(defun w3m-history-next-link-available-p ()
"Return non-nil if the next history element is available."
(caddar w3m-history))
(defun w3m-history-backward (&optional count)
"Move backward COUNT times in the history structure.
Return a cons of a new history element and new position pointers of
the history. The position pointers of `w3m-history' will not change.
If COUNT is omitted, it defaults to the number one. If COUNT is
negative, moving forward is performed. Return nil if there is no
previous element."
(when w3m-history
(let ((oposition (copy-sequence (car w3m-history)))
position last)
(cond ((or (unless count
(setq count 1))
(> count 0))
(while (and (> count 0)
(setq position (caar w3m-history)))
(w3m-history-set-current (setq last position))
(decf count)))
((< count 0)
(while (and (< count 0)
(setq position (caddar w3m-history)))
(w3m-history-set-current (setq last position))
(incf count)))
(t ;; Don't move.
(setq last (cadar w3m-history))))
(prog1
(when last
(cons (w3m-history-element (cadar w3m-history))
(car w3m-history)))
(setcar w3m-history oposition)))))
(defun w3m-history-forward (&optional count)
"Move forward COUNT times in the history structure.
Return a cons of a new history element and new position pointers of
the history. The position pointers of `w3m-history' will not change.
If COUNT is omitted, it defaults to the number one. If COUNT is
negative, moving backward is performed. If there is no room to move
in the history, move as far as possible."
(w3m-history-backward (- (or count 1))))
(defun w3m-history-regenerate-pointers (position)
"Regenerate the position pointers due to only the current POSITION.
The history position pointers are made with the `(PREV CURRENT NEXT)'
form which is mentioned in the documentation for `w3m-history'."
(list (w3m-history-previous-position position)
position
(w3m-history-next-position position)))
(defun w3m-history-flat ()
"Set the value of `w3m-history-flat' due to the value of `w3m-history'.
See also the documentations for those variables."
(setq w3m-history-flat nil)
(when w3m-history
(let ((history (cdr w3m-history))
(position (list 0))
element branches flag children)
(while (setq element (pop history))
(if (stringp (car element))
(progn
(push (list (car element) (cadr element) (reverse position))
w3m-history-flat)
(if (setq element (cddr element))
(progn
(setq history (append element history)
position (append (list 0 0) position))
(push (length element) branches))
(setcar position (1+ (car position)))
(setq flag t)
(while (and flag
children
(zerop (setcar children (1- (car children)))))
(setq children (cdr children))
(if (zerop (setcar branches (1- (car branches))))
(progn
(setq branches (cdr branches)
position (cddr position))
(setcar position (1+ (car position))))
(setcar position 0)
(setcar (cdr position) (1+ (cadr position)))
(setq flag nil)))))
(setq history (append element history))
(push (length element) children))))
(setq w3m-history-flat (nreverse w3m-history-flat))))
(defun w3m-history-tree (&optional newpos)
"Set the value of `w3m-history' due to the value of `w3m-history-flat'.
See also the documentations for those variables. NEWPOS specifies the
current position of the history. It defaults to the beginning
position of the history."
(if w3m-history-flat
(let ((flat w3m-history-flat)
element positions rest position)
(setq w3m-history (list (list nil nil)))
(while (setq element (pop flat))
(setq positions (caddr element)
rest w3m-history)
(while positions
(setq position (pop positions))
(unless (> (length rest) position)
(setcdr (nthcdr (1- (length rest)) rest)
(make-list (- position (length rest) -1)
(list nil nil))))
(setq rest (nth position rest))
(when positions
(setq position (pop positions))
(unless (> (- (length rest) 2) position)
(setcdr (nthcdr (1- (length rest)) rest)
(make-list (- position (length rest) -3)
(list (list nil nil)))))
(setq rest (nth (+ position 2) rest))))
(setcar rest (car element))
(setcar (cdr rest) (cadr element)))
(push 'dummy w3m-history)
(w3m-history-set-current (or newpos (list 0)))
w3m-history)
(setq w3m-history nil)))
(defun w3m-history-push (url &optional newprops replace)
"Push URL into the history structure.
A history which corresponds to URL becomes the current one. NEWPROPS
is a plist which supplements URL. Return a new history position
pointers. How this function behaves to the history structure (i.e.,
`w3m-history' and `w3m-history-flat') is controlled by the value of
`w3m-history-reuse-history-elements'.
The case where `w3m-history-reuse-history-elements' is nil:
A new history element is always created. If there is another
element corresponding to the same URL, its properties are inherited
into the new history element.
The case where `w3m-history-reuse-history-elements' is non-nil:
If there is an element corresponding to URL in the history, it
becomes the current history element. Otherwise, this function
behaves like the case where `w3m-history-reuse-history-elements' is
nil.
If REPLACE is nil, NEWPROPS is merged into properties of the current
history element. Otherwise, properties of the current history element
are replaced with NEWPROPS."
(let ((element (w3m-history-seek-element url newprops replace))
position class number branch)
(if element
(setcdr (cdr element) nil)
(setq element (list url (w3m-history-modify-properties newprops nil))))
(cond
((null w3m-history)
;; The dawn of the history.
(setq position (list nil (list 0) nil)
w3m-history (list position element)
w3m-history-flat (list (append element (list (list 0)))))
position)
((and w3m-history-reuse-history-elements
(setq position (caddr (w3m-history-assoc url))))
;; Reuse the existing history element assigned to the current one.
;; The position pointers will be fixed with correct values after
;; visiting a page when moving back, moving forward or jumping from
;; the about://history/ page.
(w3m-history-set-current position))
(t
;; Sprout a new history element.
(setq position (copy-sequence (cadar w3m-history))
class (1- (length position))
number 0
branch (nthcdr (car position) (cdr w3m-history)))
(while (> class number)
(setq number (1+ number)
branch (nth (nth number position) (cddar branch))
number (1+ number)
branch (nthcdr (nth number position) branch)))
(if (cdr branch)
;; We should sprout a new branch.
(progn
(setq number (1- (length (car branch))))
(setcdr (nthcdr class position) (list (1- number) 0))
(setcdr (nthcdr number (car branch)) (list (list element))))
;; The current position is the last of the branch.
(setcar (nthcdr class position)
(1+ (car (nthcdr class position))))
(setcdr branch (list element)))
(setq w3m-history-flat (nconc w3m-history-flat
(list (append element (list position)))))
(setcar w3m-history (list (cadar w3m-history) position nil))))))
(defun w3m-history-copy (buffer)
"Copy the history structure from BUFFER to the current buffer.
This function keeps corresponding elements identical Lisp objects
between buffers while copying the frameworks of `w3m-history' and
`w3m-history-flat'. Exceptionally, buffer-local properties contained
in `w3m-history-flat' will not be copied. If
`w3m-history-minimize-in-new-session' is non-nil, the copied history
structure will be shrunk so that it may contain only the current
history element."
(let ((current (current-buffer))
position flat element rest)
(set-buffer buffer)
(when w3m-history
(setq position (copy-sequence (cadar w3m-history))
flat w3m-history-flat))
(set-buffer current)
(when position
(if w3m-history-minimize-in-new-session
(progn
(setq w3m-history-flat flat
element (copy-sequence (w3m-history-element position t)))
(setcdr (cdr element) nil)
(setq w3m-history (list (list nil (list 0) nil) element)
w3m-history-flat (list (append element (list (list 0))))))
;; Remove buffer-local properties from the new `w3m-history-flat'.
(while flat
(setq element (copy-sequence (car flat))
flat (cdr flat))
(setcdr (cddr element) nil)
(push element rest))
(setq w3m-history-flat (nreverse rest))
(w3m-history-tree position)))))
(defun w3m-history-plist-get (keyword &optional not-buffer-local)
"Extract a value from the properties of the current history element.
KEYWORD is usually a symbol. This function returns the value
corresponding to KEYWORD, but it returns nil if the properties don't
contain KEYWORD. If NOT-BUFFER-LOCAL is nil, this function searches a
value in buffer-local properties, otherwise looks over the global
properties instead."
(let ((element (w3m-history-element (cadar w3m-history) t)))
(plist-get (if not-buffer-local
(cadr element)
(cdddr element))
keyword)))
(defun w3m-history-add-properties (newprops &optional not-buffer-local)
"Add NEWPROPS to the properties of the current history element.
NEWPROPS should be a plist, which is merged into the properties.
Return new properties. If NOT-BUFFER-LOCAL is nil, NEWPROPS will be
added to the buffer-local properties. Otherwise, NEWPROPS will be
added to the global properties instead."
(if not-buffer-local
(cadr (w3m-history-seek-element
(car (w3m-history-element (cadar w3m-history)))
newprops))
(let ((element (w3m-history-element (cadar w3m-history) t))
properties)
(if element
(progn
(setq properties (cdddr element)
properties
(if properties
(w3m-history-modify-properties properties newprops)
;; Use `w3m-history-modify-properties' to remove
;; keyword-value pairs whose value is nil.
(w3m-history-modify-properties newprops nil)))
(unless (car properties) ;; check whether it is `(nil nil)'.
(setq properties nil))
(setcdr (cddr element) properties))
(message "\
Warning: the history database in this session seems corrupted.")
(sit-for 1)
nil))))
(defun w3m-history-plist-put (keyword value &optional not-buffer-local)
"Put KEYWORD and VALUE into the current history element.
Return new properties. If NOT-BUFFER-LOCAL is nil, KEYWORD and VALUE
will be put into the buffer-local properties. Otherwise, KEYWORD and
VALUE will be put into the global properties instead."
(w3m-history-add-properties (list keyword value) not-buffer-local))
(defun w3m-history-remove-properties (properties &optional not-buffer-local)
"Remove PROPERTIES from the current history element.
PROPERTIES should be one or more keyword-value pairs (i.e., plist) but
values are ignored (treated as nil). Return new properties. If
NOT-BUFFER-LOCAL is nil, the buffer-local properties will be modified.
Otherwise, the global properties will be modified instead."
(let (rest)
(while properties
(setq rest (cons nil (cons (car properties) rest))
properties (cddr properties)))
(w3m-history-add-properties (nreverse rest) not-buffer-local)))
(defun w3m-history-store-position ()
"Store the current cursor position into the current history element.
Data consist of the position where the window starts and the cursor
position. Naturally, those should be treated as buffer-local."
(interactive)
(when (cadar w3m-history)
(w3m-history-add-properties
(list :window-start (window-start)
:position (cons (count-lines (point-min) (point-at-bol))
(current-column))
:window-hscroll (window-hscroll)))
(when (interactive-p)
(message "The current cursor position saved"))))
(defun w3m-history-restore-position ()
"Restore the saved cursor position in the page.
Even if the page has been shrunk (by reloading, for example), somehow
it works although it may not be perfect."
(interactive)
(when (cadar w3m-history)
(let ((start (w3m-history-plist-get :window-start))
position window)
(cond ((and start
(setq position (w3m-history-plist-get :position)))
(when (<= start (point-max))
(setq window (get-buffer-window (current-buffer) 'all-frames))
(when window
(set-window-start window start)
(set-window-hscroll
window (or (w3m-history-plist-get :window-hscroll) 0)))
(goto-char (point-min))
(forward-line (car position))
(move-to-column (cdr position))
(let ((deactivate-mark nil))
(run-hooks 'w3m-after-cursor-move-hook))))
((interactive-p)
(message "No cursor position saved"))))))
(defun w3m-history-minimize ()
"Minimize the history so that there may be the current page only."
(interactive)
(let ((position (cadar w3m-history))
element)
(when position
(setq element (w3m-history-element position t))
(setcar (cddr element) (list 0))
(setq w3m-history-flat (list element)
w3m-history (list (list nil (list 0) nil)
(list (car element) (cadr element)))))))
(defun w3m-history-slimmed-history-flat ()
"Return slimmed history."
(let ((position (cadar w3m-history))
flat-map new-flat)
(dolist (l w3m-history-flat)
(setq flat-map (cons (cons (nth 2 l) l)
flat-map)))
(setq new-flat (cons (cdr (assoc position flat-map)) nil))
(let ((pos (w3m-history-previous-position position)))
(while pos
(setq new-flat (cons (cdr (assoc pos flat-map))
new-flat))
(setq pos (w3m-history-previous-position pos))))
(let ((pos (w3m-history-next-position position)))
(while pos
(setq new-flat (cons (cdr (assoc pos flat-map))
new-flat))
(setq pos (w3m-history-next-position pos))))
new-flat))
(defun w3m-history-slim ()
"Slim the history.
This makes the history slim so that it may have only the pages that
are accessible by PREV and NEXT operations."
(interactive)
(let ((position (cadar w3m-history)))
(setq w3m-history-flat (w3m-history-slimmed-history-flat))
(w3m-history-tree position)))
(eval-when-compile
(defvar w3m-arrived-db)
(autoload 'w3m-goto-url "w3m"))
(defun w3m-history-add-arrived-db ()
"Add the arrived database to the history structure unreasonably.
This function is useless normally, so you may not want to use it.
\(The reason it is here is because it is useful once in a while when
debugging w3m-hist.el.)"
(interactive)
(unless (eq 'w3m-mode major-mode)
(error "`%s' must be invoked from an emacs-w3m buffer" this-command))
(when (and w3m-arrived-db
(prog1
(yes-or-no-p
"Are you sure you really want to destroy the history? ")
(message "")))
(setq w3m-history nil
w3m-history-flat nil)
(let ((w3m-history-reuse-history-elements t)
url-title title)
(mapatoms (lambda (symbol)
(when symbol
(if (setq title (get symbol 'title))
(push (list (symbol-name symbol)
(list :title title))
url-title)
(push (list (symbol-name symbol)) url-title))))
w3m-arrived-db)
(apply 'w3m-history-push (nth (random (length url-title)) url-title))
(while url-title
(w3m-history-push (car (nth (random (length w3m-history-flat))
w3m-history-flat)))
(apply 'w3m-history-push (pop url-title))))
(w3m-goto-url "about://history/" t)))
(provide 'w3m-hist)
;;; w3m-hist.el ends here

266
share/emacs/site-lisp/w3m/w3m-image.el Normal file
View file

@ -0,0 +1,266 @@
;;; w3m-image.el --- Image conversion routines.
;; Copyright (C) 2001, 2002, 2003, 2005, 2007, 2008
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: Yuuichi Teranishi <teranisi@gohome.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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file contains the stuffs to convert images for emacs-w3m.
;; For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;
;; Routines in this file require ImageMagick's convert.
;; For more detail about ImageMagick, see:
;;
;; http://www.imagemagick.org/
;;; Code:
(eval-when-compile
(require 'cl))
(require 'w3m-util)
(require 'w3m-proc)
(eval-when-compile
(if (not (fboundp 'defcustom))
(require 'pcustom)))
;; Functions and variables which should be defined in the other module
;; at run-time.
(eval-when-compile
(defvar w3m-async-exec)
(defvar w3m-current-url)
(defvar w3m-profile-directory)
(defvar w3m-work-buffer-name)
(defvar w3m-work-buffer-list))
(defcustom w3m-imagick-convert-program (if noninteractive
nil
(w3m-which-command "convert"))
"*Program name of ImageMagick's `convert'."
:group 'w3m
:set (lambda (symbol value)
(custom-set-default symbol (if (and (not noninteractive)
value)
(if (file-name-absolute-p value)
(if (file-executable-p value)
value)
(w3m-which-command value)))))
:type 'file)
(defcustom w3m-imagick-identify-program (if noninteractive
nil
(w3m-which-command "identify"))
"*Program name of ImageMagick's `identify'."
:group 'w3m
:set (lambda (symbol value)
(custom-set-default symbol (if (and (not noninteractive)
value)
(if (file-name-absolute-p value)
(if (file-executable-p value)
value)
(w3m-which-command value)))))
:type 'file)
;;; Image handling functions.
(defcustom w3m-resize-images (and w3m-imagick-convert-program t)
"*If non-nil, resize images to the specified width and height."
:group 'w3m
:set (lambda (symbol value)
(custom-set-default symbol (and w3m-imagick-convert-program value)))
:type 'boolean)
(put 'w3m-imagick-convert-program 'available-p 'unknown)
(defun w3m-imagick-convert-program-available-p ()
"Return non-nil if ImageMagick's `convert' program is available.
If not, `w3m-imagick-convert-program' and `w3m-resize-images' are made
nil forcibly."
(cond ((eq (get 'w3m-imagick-convert-program 'available-p) 'yes)
t)
((eq (get 'w3m-imagick-convert-program 'available-p) 'no)
nil)
((and (stringp w3m-imagick-convert-program)
(file-executable-p w3m-imagick-convert-program))
(put 'w3m-imagick-convert-program 'available-p 'yes)
;; Check whether convert supports png32.
(put 'w3m-imagick-convert-program 'png32
(unless (or (featurep 'xemacs)
(< emacs-major-version 22))
(with-temp-buffer
(set-buffer-multibyte nil)
(insert "P1 1 1 1")
(condition-case nil
(call-process-region (point-min) (point-max)
w3m-imagick-convert-program
t t nil "pbm:-" "png32:-")
(error))
(goto-char (point-min))
(looking-at "\211PNG\r\n"))))
t)
(t
(when w3m-imagick-convert-program
(message "ImageMagick's `convert' program is not available")
(sit-for 1))
(setq w3m-imagick-convert-program nil
w3m-resize-images nil)
(put 'w3m-imagick-convert-program 'available-p 'no)
nil)))
;;; Synchronous image conversion.
(defun w3m-imagick-convert-buffer (from-type to-type &rest args)
(when (w3m-imagick-convert-program-available-p)
(let* ((in-file (make-temp-name
(expand-file-name "w3mel" w3m-profile-directory)))
(buffer-file-coding-system 'binary)
(coding-system-for-read 'binary)
(coding-system-for-write 'binary)
(default-process-coding-system (cons 'binary 'binary))
return)
(write-region (point-min) (point-max) in-file nil 'nomsg)
(erase-buffer)
(setq return
(apply 'call-process
w3m-imagick-convert-program
nil t nil
(append args (list
(concat
(if from-type
(concat from-type ":"))
in-file)
(if to-type
(if (and (string-equal to-type "png")
(get 'w3m-imagick-convert-program
'png32))
"png32:-"
(concat to-type ":-"))
"-")))))
(when (file-exists-p in-file) (delete-file in-file))
(if (and (numberp return)
(zerop return))
t
(message "Image conversion failed (code `%s')"
(if (stringp return)
(string-as-multibyte return)
return))
nil))))
(defun w3m-imagick-convert-data (data from-type to-type &rest args)
(with-temp-buffer
(set-buffer-multibyte nil)
(insert data)
(and (apply 'w3m-imagick-convert-buffer from-type to-type args)
(not (zerop (buffer-size)))
(buffer-string))))
;;; Asynchronous image conversion.
(defun w3m-imagick-start-convert-data (handler
data from-type to-type &rest args)
(w3m-process-do-with-temp-buffer
(success (when (w3m-imagick-convert-program-available-p)
(set-buffer-multibyte nil)
(insert data)
(apply 'w3m-imagick-start-convert-buffer
handler from-type to-type args)))
(if (and success
(not (zerop (buffer-size))))
(buffer-string))))
(defun w3m-imagick-start-convert-buffer (handler from-type to-type &rest args)
(lexical-let ((in-file (make-temp-name
(expand-file-name "w3mel" w3m-profile-directory)))
(out-buffer (current-buffer)))
(setq w3m-current-url "non-existent")
(let ((coding-system-for-write 'binary)
(buffer-file-coding-system 'binary)
jka-compr-compression-info-list
format-alist)
(write-region (point-min) (point-max) in-file nil 'nomsg))
(w3m-process-do
(success (with-current-buffer out-buffer
(erase-buffer)
(w3m-process-start
handler
w3m-imagick-convert-program
(append args
(list
(concat
(if from-type
(concat from-type ":"))
in-file)
(if to-type
(if (and (string-equal to-type "png")
(get 'w3m-imagick-convert-program
'png32))
"png32:-"
(concat to-type ":-"))
"-"))))))
(when (file-exists-p in-file)
(delete-file in-file))
success)))
(defun w3m-resize-image (data width height handler)
"Resize image DATA to WIDTH and HEIGHT asynchronously.
HANDLER is called after conversion with resized data as an argument."
(w3m-process-do
(result (w3m-imagick-start-convert-data
handler
data nil nil "-geometry"
(concat (number-to-string width)
"x"
(number-to-string height)
"!")))
result))
(defun w3m-resize-image-by-rate (data rate handler)
"Resize image DATA at RATE asynchronously.
HANDLER is called after conversion with resized data as an argument.
Note that this function requires that the `convert' program allows the
`-resize' option."
(w3m-process-do
(result (w3m-imagick-start-convert-data
handler
data nil nil "-resize"
(concat (number-to-string rate) "%")))
result))
(defun w3m-favicon-usable-p ()
"Check whether ImageMagick's `convert' supports a Windoze ico format in
a large number of bits per pixel."
(let ((xpm (condition-case nil
(w3m-imagick-convert-data
(string 0 0 1 0 1 0 2 1 0 0 1 0 24 0 52 0
0 0 22 0 0 0 40 0 0 0 2 0 0 0 2 0
0 0 1 0 24 0 0 0 0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 255 255 255 0 0 0 0 0 0)
"ico" "xpm")
(error nil))))
(and xpm (string-match "\"2 1 2 1\"" xpm) t)))
(provide 'w3m-image)
;;; w3m-image.el ends here

144
share/emacs/site-lisp/w3m/w3m-lnum.el Normal file
View file

@ -0,0 +1,144 @@
;;; w3m-lnum.el --- Operations using link numbers
;; Copyright (C) 2004, 2005, 2006, 2007, 2009
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file provides a minor mode to enable operations using link
;; numbers.
;;; Usage:
;; Install this file to an appropriate directory, and add these
;; expressions to your ~/.emacs-w3m.
;; (autoload 'w3m-link-numbering-mode "w3m-lnum" nil t)
;; (add-hook 'w3m-mode-hook 'w3m-link-numbering-mode)
;;; Code:
(eval-when-compile
(require 'cl))
(require 'w3m)
(defface w3m-link-numbering
'((((class color) (background light)) (:foreground "gray60"))
(((class color) (background dark)) (:foreground "gray50")))
"Face used to highlight link numbers."
:group 'w3m-face)
;; backward-compatibility alias
(put 'w3m-link-numbering-face 'face-alias 'w3m-link-numbering)
(defcustom w3m-link-numbering-mode-hook nil
"*Hook run after `w3m-link-numbering-mode' initialization."
:group 'w3m
:type 'hook)
(defvar w3m-link-numbering-mode-map
(let ((keymap (make-sparse-keymap)))
(substitute-key-definition 'w3m-view-this-url
'w3m-move-numbered-anchor
keymap w3m-mode-map)
keymap)
"Keymap used when `w3m-link-numbering-mode' is active.")
(defvar w3m-link-numbering-mode nil
"Non-nil if w3m operations using link numbers are enabled.")
(make-variable-buffer-local 'w3m-link-numbering-mode)
(unless (assq 'w3m-link-numbering-mode minor-mode-map-alist)
(push (cons 'w3m-link-numbering-mode w3m-link-numbering-mode-map)
minor-mode-map-alist))
;;;###autoload
(defun w3m-link-numbering-mode (&optional arg)
"Minor mode to enable operations using link numbers."
(interactive "P")
(add-hook 'w3m-display-functions 'w3m-link-numbering)
(if (setq w3m-link-numbering-mode
(if arg
(> (prefix-numeric-value arg) 0)
(not w3m-link-numbering-mode)))
(progn
(w3m-link-numbering)
(run-hooks 'w3m-link-numbering-mode-hook))
(dolist (overlay (overlays-in (point-min) (point-max)))
(when (overlay-get overlay 'w3m-link-numbering-overlay)
(delete-overlay overlay)))))
(defun w3m-link-numbering (&rest args)
"Make overlays that display link numbers."
(when w3m-link-numbering-mode
(save-excursion
(goto-char (point-min))
(let ((i 0)
overlay num)
(catch 'already-numbered
(while (w3m-goto-next-anchor)
(when (w3m-anchor)
(when (get-char-property (point) 'w3m-link-numbering-overlay)
(throw 'already-numbered nil))
(setq overlay (make-overlay (point) (1+ (point)))
num (format "[%d]" (incf i)))
(w3m-static-if (featurep 'xemacs)
(progn
(overlay-put overlay 'before-string num)
(set-glyph-face (extent-begin-glyph overlay)
'w3m-link-numbering))
(w3m-add-face-property 0 (length num) 'w3m-link-numbering num)
(overlay-put overlay 'before-string num)
(overlay-put overlay 'evaporate t))
(overlay-put overlay 'w3m-link-numbering-overlay i))))))))
(defun w3m-move-numbered-anchor (&optional arg)
"Move the point to the specified anchor.
When no prefix argument is specified, call `w3m-view-this-url' instead
of moving cursor."
(interactive "P")
(if (and arg
(> (setq arg (prefix-numeric-value arg)) 0))
(catch 'found
(dolist (overlay (overlays-in (point-min) (point-max)))
(when (eq arg (overlay-get overlay 'w3m-link-numbering-overlay))
(goto-char (overlay-start overlay))
(push (w3m-anchor-sequence) w3m-goto-anchor-hist)
(w3m-horizontal-on-screen)
(throw 'found (w3m-print-this-url))))
(error "Cannot found your specified link: %d" arg))
(w3m-view-this-url)))
(defun w3m-go-to-linknum ()
"Turn on link numbers and ask for one to go to."
(interactive)
(let ((active w3m-link-numbering-mode))
(unless active
(w3m-link-numbering-mode 1))
(unwind-protect
(w3m-move-numbered-anchor (w3m-read-number "Anchor number: "))
(unless active
(w3m-link-numbering-mode 0)))))
(provide 'w3m-lnum)
;;; w3m-lnum.el ends here

447
share/emacs/site-lisp/w3m/w3m-load.el Normal file
View file

@ -0,0 +1,447 @@
;;; w3m-load.el --- automatically extracted autoload
;;
;; This file should be generated by make in emacs-w3m source directory.
;;
;;; Code:
(provide 'w3m-load)
;;;### (autoloads (w3m-buffer w3m-region w3m-find-file w3m-browse-url
;;;;;; w3m w3m-gohome w3m-goto-url-new-session w3m-goto-url w3m-download
;;;;;; w3m-retrieve) "w3m" "w3m.el" (19330 25100))
;;; Generated autoloads from w3m.el
(autoload 'w3m-retrieve "w3m" "\
Retrieve web contents pointed to by URL.
It will put the retrieved contents into the current buffer.
If HANDLER is nil, this function will retrieve web contents, return
the content type of the retrieved data, and then come to an end. This
behavior is what is called a synchronous operation. You have to
specify HANDLER in order to make this function show its real ability,
which is called an asynchronous operation.
If HANDLER is a function, this function will come to an end in no time.
In this case, contents will be retrieved by the asynchronous process
after a while. And after finishing retrieving contents successfully,
HANDLER will be called on the buffer where this function starts. The
content type of the retrieved data will be passed to HANDLER as a
string argument.
NO-UNCOMPRESS specifies whether this function should not uncompress contents.
NO-CACHE specifies whether this function should not use cached contents.
POST-DATA and REFERER will be sent to the web server with a request.
\(fn URL &optional NO-UNCOMPRESS NO-CACHE POST-DATA REFERER HANDLER)" nil nil)
(autoload 'w3m-download "w3m" "\
Download contents of URL to a file named FILENAME.
NO-CHACHE (which the prefix argument gives when called interactively)
specifies not using the cached data.
\(fn URL &optional FILENAME NO-CACHE HANDLER POST-DATA)" t nil)
(autoload 'w3m-goto-url "w3m" "\
Visit World Wide Web pages. This is the primitive function of `w3m'.
If the second argument RELOAD is non-nil, reload a content of URL.
Except that if it is 'redisplay, re-display the page without reloading.
The third argument CHARSET specifies a charset to be used for decoding
a content.
The fourth argument POST-DATA should be a string or a cons cell. If
it is a string, it makes this function request a body as if the
content-type is \"x-www-form-urlencoded\". If it is a cons cell, the
car of a cell is used as the content-type and the cdr of a cell is
used as the body.
If the fifth argument REFERER is specified, it is used for a Referer:
field for this request.
The remaining HANDLER, ELEMENT[1], and NO-POPUP are for the
internal operations of emacs-w3m.
You can also use \"quicksearch\" url schemes such as \"gg:emacs\" which
would search for the term \"emacs\" with the Google search engine. See
the `w3m-search' function and the variable `w3m-uri-replace-alist'.
\[1] A note for the developers: ELEMENT is a history element which has
already been registered in the `w3m-history-flat' variable. It is
corresponding to URL to be retrieved at this time, not for the url of
the current page.
\(fn URL &optional RELOAD CHARSET POST-DATA REFERER HANDLER ELEMENT NO-POPUP)" t nil)
(autoload 'w3m-goto-url-new-session "w3m" "\
Visit World Wide Web pages in a new session.
If you invoke this command in the emacs-w3m buffer, the new session
will be created by copying the current session. Otherwise, the new
session will start afresh.
\(fn URL &optional RELOAD CHARSET POST-DATA REFERER)" t nil)
(autoload 'w3m-gohome "w3m" "\
Go to the Home page.
\(fn)" t nil)
(autoload 'w3m "w3m" "\
Visit World Wide Web pages using the external w3m command.
When you invoke this command interactively for the first time, it will
visit a page which is pointed to by a string like url around the
cursor position or the home page specified by the `w3m-home-page'
variable, but you will be prompted for a URL if `w3m-quick-start' is
nil (default t) or `w3m-home-page' is nil.
The variables `w3m-pop-up-windows' and `w3m-pop-up-frames' control
whether this command should pop to a window or a frame up for the
session.
When emacs-w3m sessions have already been opened, this command will
pop to the existing window or frame up, but if `w3m-quick-start' is
nil, (default t), you will be prompted for a URL (which defaults to
`popup' meaning to pop to an existing emacs-w3m buffer up).
In addition, if the prefix argument is given or you enter the empty
string for the prompt, it will visit the home page specified by the
`w3m-home-page' variable or the \"about:\" page.
You can also run this command in the batch mode as follows:
emacs -f w3m http://emacs-w3m.namazu.org/ &
In that case, or if this command is called non-interactively, the
variables `w3m-pop-up-windows' and `w3m-pop-up-frames' will be ignored
\(treated as nil) and it will run emacs-w3m at the current (or the
initial) window.
If the optional NEW-SESSION is non-nil, this function makes a new
emacs-w3m buffer. Besides that, it also makes a new emacs-w3m buffer
if `w3m-make-new-session' is non-nil and a user specifies a url string.
The optional INTERACTIVE-P is for the internal use; it is mainly used
to check whether Emacs 22 or later calls this function as an
interactive command in the batch mode.
\(fn &optional URL NEW-SESSION INTERACTIVE-P)" t nil)
(autoload 'w3m-browse-url "w3m" "\
Ask emacs-w3m to browse URL.
NEW-SESSION specifies whether to create a new emacs-w3m session. URL
defaults to the string looking like a url around the cursor position.
Pop to a window or a frame up according to `w3m-pop-up-windows' and
`w3m-pop-up-frames'.
\(fn URL &optional NEW-SESSION)" t nil)
(autoload 'w3m-find-file "w3m" "\
Function used to open FILE whose name is expressed in ordinary format.
The file name will be converted into the file: scheme.
\(fn FILE)" t nil)
(autoload 'w3m-region "w3m" "\
Render the region of the current buffer between START and END.
URL specifies the address where the contents come from. It can be
omitted or nil when the address is not identified. CHARSET is used
for decoding the contents. If it is nil, this function attempts to
parse the meta tag to extract the charset.
\(fn START END &optional URL CHARSET)" t nil)
(autoload 'w3m-buffer "w3m" "\
Render the current buffer.
See `w3m-region' for the optional arguments.
\(fn &optional URL CHARSET)" t nil)
;;;***
;;;### (autoloads (w3m-antenna w3m-about-antenna) "w3m-antenna" "w3m-antenna.el"
;;;;;; (19188 5056))
;;; Generated autoloads from w3m-antenna.el
(autoload 'w3m-about-antenna "w3m-antenna" "\
Not documented
\(fn URL &optional NO-DECODE NO-CACHE POST-DATA REFERER HANDLER)" nil nil)
(autoload 'w3m-antenna "w3m-antenna" "\
Report changes of WEB sites, which is specified in `w3m-antenna-sites'.
\(fn &optional NO-CACHE)" t nil)
;;;***
;;;### (autoloads (w3m-setup-bookmark-menu w3m-about-bookmark w3m-bookmark-view-new-session
;;;;;; w3m-bookmark-view w3m-bookmark-add-current-url-group w3m-bookmark-add-all-urls
;;;;;; w3m-bookmark-add-current-url w3m-bookmark-add-this-url) "w3m-bookmark"
;;;;;; "w3m-bookmark.el" (19276 22621))
;;; Generated autoloads from w3m-bookmark.el
(autoload 'w3m-bookmark-add-this-url "w3m-bookmark" "\
Add link under cursor to bookmark.
\(fn)" t nil)
(autoload 'w3m-bookmark-add-current-url "w3m-bookmark" "\
Add a url of the current page to the bookmark.
With prefix, ask for a new url instead of the present one.
\(fn &optional ARG)" t nil)
(autoload 'w3m-bookmark-add-all-urls "w3m-bookmark" "\
Add urls of all pages being visited to the bookmark.
\(fn)" t nil)
(autoload 'w3m-bookmark-add-current-url-group "w3m-bookmark" "\
Add link of the group of current urls to the bookmark.
\(fn)" t nil)
(autoload 'w3m-bookmark-view "w3m-bookmark" "\
Display the bookmark.
\(fn &optional RELOAD)" t nil)
(autoload 'w3m-bookmark-view-new-session "w3m-bookmark" "\
Display the bookmark on a new session.
\(fn &optional RELOAD)" t nil)
(autoload 'w3m-about-bookmark "w3m-bookmark" "\
Not documented
\(fn &rest ARGS)" nil nil)
(autoload 'w3m-setup-bookmark-menu "w3m-bookmark" "\
Setup w3m bookmark items in menubar.
\(fn)" nil nil)
;;;***
;;;### (autoloads (w3m-about-cookie w3m-cookie w3m-cookie-get w3m-cookie-set
;;;;;; w3m-cookie-shutdown) "w3m-cookie" "w3m-cookie.el" (19277
;;;;;; 43559))
;;; Generated autoloads from w3m-cookie.el
(autoload 'w3m-cookie-shutdown "w3m-cookie" "\
Save cookies, and reset cookies' data.
\(fn)" t nil)
(autoload 'w3m-cookie-set "w3m-cookie" "\
Register cookies which correspond to URL.
BEG and END should be an HTTP response header region on current buffer.
\(fn URL BEG END)" nil nil)
(autoload 'w3m-cookie-get "w3m-cookie" "\
Get a cookie field string which corresponds to the URL.
\(fn URL)" nil nil)
(autoload 'w3m-cookie "w3m-cookie" "\
Display cookies and enable you to manage them.
\(fn &optional NO-CACHE)" t nil)
(autoload 'w3m-about-cookie "w3m-cookie" "\
Make the html contents to display and to enable you to manage cookies.
\(fn URL &optional NO-DECODE NO-CACHE POST-DATA &rest ARGS)" nil nil)
;;;***
;;;### (autoloads (w3m-dtree w3m-about-dtree) "w3m-dtree" "w3m-dtree.el"
;;;;;; (18965 10114))
;;; Generated autoloads from w3m-dtree.el
(autoload 'w3m-about-dtree "w3m-dtree" "\
Not documented
\(fn URL &optional NODECODE ALLFILES &rest ARGS)" nil nil)
(autoload 'w3m-dtree "w3m-dtree" "\
Display directory tree on local file system.
If called with 'prefix argument', display all directorys and files.
\(fn ALLFILES PATH)" t nil)
;;;***
;;;### (autoloads (w3m-fb-mode) "w3m-fb" "w3m-fb.el" (17681 2386))
;;; Generated autoloads from w3m-fb.el
(defvar w3m-fb-mode nil "\
Non-nil if W3m-Fb mode is enabled.
See the command `w3m-fb-mode' for a description of this minor mode.
Setting this variable directly does not take effect;
either customize it (see the info node `Easy Customization')
or call the function `w3m-fb-mode'.")
(custom-autoload 'w3m-fb-mode "w3m-fb" nil)
(autoload 'w3m-fb-mode "w3m-fb" "\
Toggle W3M Frame Buffer mode.
This allows frame-local lists of buffers (tabs).
\(fn &optional ARG)" t nil)
;;;***
;;;### (autoloads (w3m-filter) "w3m-filter" "w3m-filter.el" (18560
;;;;;; 26042))
;;; Generated autoloads from w3m-filter.el
(autoload 'w3m-filter "w3m-filter" "\
Apply filtering rule of URL against a content in this buffer.
\(fn URL)" nil nil)
;;;***
;;;### (autoloads (w3m-fontify-forms) "w3m-form" "w3m-form.el" (19276
;;;;;; 22621))
;;; Generated autoloads from w3m-form.el
(autoload 'w3m-fontify-forms "w3m-form" "\
Process half-dumped data and fontify forms in this buffer.
\(fn)" nil nil)
;;;***
;;;### (autoloads (w3m-link-numbering-mode) "w3m-lnum" "w3m-lnum.el"
;;;;;; (18851 53425))
;;; Generated autoloads from w3m-lnum.el
(autoload 'w3m-link-numbering-mode "w3m-lnum" "\
Minor mode to enable operations using link numbers.
\(fn &optional ARG)" t nil)
;;;***
;;;### (autoloads (w3m-namazu w3m-about-namazu) "w3m-namazu" "w3m-namazu.el"
;;;;;; (18965 10114))
;;; Generated autoloads from w3m-namazu.el
(autoload 'w3m-about-namazu "w3m-namazu" "\
Not documented
\(fn URL &optional NO-DECODE NO-CACHE &rest ARGS)" nil nil)
(autoload 'w3m-namazu "w3m-namazu" "\
Search indexed files with Namazu.
\(fn INDEX QUERY &optional RELOAD)" t nil)
;;;***
;;;### (autoloads (w3m-perldoc w3m-about-perldoc) "w3m-perldoc" "w3m-perldoc.el"
;;;;;; (18199 13480))
;;; Generated autoloads from w3m-perldoc.el
(autoload 'w3m-about-perldoc "w3m-perldoc" "\
Not documented
\(fn URL &optional NO-DECODE NO-CACHE &rest ARGS)" nil nil)
(autoload 'w3m-perldoc "w3m-perldoc" "\
View Perl documents.
\(fn DOCNAME)" t nil)
;;;***
;;;### (autoloads (w3m-search-uri-replace w3m-search-new-session
;;;;;; w3m-search) "w3m-search" "w3m-search.el" (19102 18473))
;;; Generated autoloads from w3m-search.el
(autoload 'w3m-search "w3m-search" "\
Search QUERY using SEARCH-ENGINE.
When called interactively with a prefix argument, you can choose one of
the search engines defined in `w3m-search-engine-alist'. Otherwise use
`w3m-search-default-engine'.
If Transient Mark mode, use the region as an initial string of query
and deactivate the mark.
\(fn SEARCH-ENGINE QUERY)" t nil)
(autoload 'w3m-search-new-session "w3m-search" "\
Like `w3m-search', but do the search in a new session.
\(fn SEARCH-ENGINE QUERY)" t nil)
(autoload 'w3m-search-uri-replace "w3m-search" "\
Generate query string for ENGINE from URI matched by last search.
\(fn URI ENGINE)" nil nil)
;;;***
;;;### (autoloads (w3m-session-last-crashed-session w3m-session-last-autosave-session
;;;;;; w3m-setup-session-menu w3m-session-select w3m-session-save)
;;;;;; "w3m-session" "w3m-session.el" (19277 43559))
;;; Generated autoloads from w3m-session.el
(autoload 'w3m-session-save "w3m-session" "\
Save list of displayed session.
\(fn)" t nil)
(autoload 'w3m-session-select "w3m-session" "\
Select session from session list.
\(fn)" t nil)
(autoload 'w3m-setup-session-menu "w3m-session" "\
Setup w3m session items in menubar.
\(fn)" nil nil)
(autoload 'w3m-session-last-autosave-session "w3m-session" "\
Not documented
\(fn)" nil nil)
(autoload 'w3m-session-last-crashed-session "w3m-session" "\
Not documented
\(fn)" nil nil)
;;;***
;;;### (autoloads (w3m-replace-symbol) "w3m-symbol" "w3m-symbol.el"
;;;;;; (18791 12168))
;;; Generated autoloads from w3m-symbol.el
(autoload 'w3m-replace-symbol "w3m-symbol" "\
Not documented
\(fn)" nil nil)
;;;***
;;;### (autoloads (w3m-about-weather w3m-weather) "w3m-weather" "w3m-weather.el"
;;;;;; (18199 13480))
;;; Generated autoloads from w3m-weather.el
(autoload 'w3m-weather "w3m-weather" "\
Display weather report.
\(fn AREA)" t nil)
(autoload 'w3m-about-weather "w3m-weather" "\
Not documented
\(fn URL NO-DECODE NO-CACHE POST-DATA REFERER HANDLER)" nil nil)
;;;***
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
;; coding: utf-8
;; End:
;;; w3m-load.el ends here

396
share/emacs/site-lisp/w3m/w3m-mail.el Normal file
View file

@ -0,0 +1,396 @@
;;; w3m-mail.el --- an interface to mail-user-agent for sending web pages
;; Copyright (C) 2006, 2009 TSUCHIYA Masatoshi
;; Author: 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This module provides the `w3m-mail' command which enables you to
;; send web pages as mails respecting those content types (typically
;; text/html). Currently this program works if and only if you set
;; the `mail-user-agent' variable to one of the following agents:
;; `gnus-user-agent'
;; `message-user-agent'
;; `mew-user-agent'
;; `vm-user-agent'
;; `wl-user-agent'
;; To send the page you are looking at, type `M-x w3m-mail' or click
;; the menu button, fill message headers properly, and type `C-c C-c'.
;;; Code:
(require 'w3m)
(defcustom w3m-mail-subject '("Emailing:" url)
"A list of strings and symbols used to generate the subject header.
Valid symbols include `url' which is replaced with the url of the page
and `title' which is replaced with the page title. You can also use
just a string for this variable."
:group 'w3m
:type '(radio (editable-list :format "\n%v%i\n"
(radio-button-choice
(const :format "%v " url)
(const :format "%v " title)
string))
string
(const :format "no subject" nil)))
(defvar w3m-mail-user-agent-compose-function-alist
(let ((alist '((gnus-user-agent . w3m-mail-compose-with-mml)
(message-user-agent . w3m-mail-compose-with-mml)
(mew-user-agent . w3m-mail-compose-with-mew)
(vm-user-agent . w3m-mail-compose-with-vm)
(wl-user-agent . w3m-mail-compose-with-semi)))
composer)
(delq nil (mapcar (lambda (agent)
(if (setq composer (cdr (assq agent alist)))
(cons agent composer)))
w3m-mail-user-agents)))
"Alist of mail user agents and functions to compose a mail.
The function will be called with the arguments `source', `url',
`charset', `content-type', `to', `subject', and `other-headers'; where
`source' is a string containing the page source, `url' is the url of
the page, `charset' is a charset that the page uses, `content-type' is
the one such as \"text/html\", and the rest are the same as those of
`compose-mail'.")
(eval-when-compile
(autoload 'message-add-action "message")
(autoload 'mml-insert-empty-tag "mml")
(autoload 'vm-mime-attach-buffer "vm-mime")
(condition-case nil
(require 'mime-edit)
(error
(dolist (symbol '(encode-mime-charset-region
detect-mime-charset-region
std11-wrap-as-quoted-string
mime-find-file-type
mime-edit-insert-tag
mime-edit-define-encoding
mime-encode-region))
(defalias symbol 'ignore)))))
(eval-and-compile
(autoload 'mm-find-mime-charset-region "mm-util")
(autoload 'w3m-mail-compose-with-mew "mew-w3m"
"Compose a mail using Mew." t))
(defun w3m-mail-make-subject ()
"Return a string used for the Subject header."
(cond ((consp w3m-mail-subject)
(w3m-replace-in-string
(w3m-replace-in-string
(mapconcat (lambda (elem)
(cond ((eq elem 'url) w3m-current-url)
((eq elem 'title) w3m-current-title)
((stringp elem) elem)
(t (format "%s" elem))))
w3m-mail-subject
" ")
"[\t\n ]+" " ")
"\\(?:\\` \\| \\'\\)" ""))
((stringp w3m-mail-subject) w3m-mail-subject)
(t "(no subject)")))
(defun w3m-mail-compute-base-url ()
"Compute a base url of the page if it is not provided."
(let ((url (substring w3m-current-url 15)))
(unless (string-match "\\`about:" url)
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t)
start end)
(unless (and (setq start (search-forward "<head>" nil t))
(setq end (search-forward "</head>" nil t))
(progn
(goto-char start)
(re-search-forward "<base[\t\n\r ]+" end t))
(w3m-parse-attributes (href) (> (length href) 0)))
(substring (w3m-expand-url "x" url) 0 -1)))))))
(defun w3m-mail-embed-base-url (source base-url)
"Embed BASE-URL in SOURCE."
(with-temp-buffer
(w3m-static-unless (featurep 'xemacs)
(set-buffer-multibyte t))
(setq case-fold-search t)
(insert source)
(goto-char (point-min))
(while (search-forward "\r\n" nil t)
(replace-match "\n"))
(goto-char (point-min))
(let ((nohead t)
(points (list (point-min) (point-min)))
(margin 0))
(when (re-search-forward "\\(<html>\\)[\t\n ]*" nil t)
(setq points (list (match-end 1) (match-end 0))
margin (current-column)))
(when (re-search-forward "\\(<head>\\)[\t\n ]*" nil t)
(setq nohead nil
points (list (match-end 1) (match-end 0))
margin (current-column)))
(setq margin (make-string margin ? ))
(goto-char (car points))
(apply 'delete-region points)
(if nohead
(insert "\n" margin "<head><base href=\"" base-url "\"></head>\n"
margin)
(insert "\n" margin "<base href=\"" base-url "\">\n" margin)))
(buffer-string)))
(defun w3m-mail-goto-body-and-clear-body ()
"Go to the beginning of the body and clear the body."
(goto-char (point-min))
(if (re-search-forward (concat "^\\(?:"
(regexp-quote mail-header-separator)
"\\)?\n")
nil 'move)
(delete-region (point) (point-max))
(insert (if (bolp) "\n" "\n\n"))))
(defun w3m-mail-position-point (bob)
"Go to empty or bogus header, otherwise the beginning of the body BOB."
(goto-char (point-min))
(when (re-search-forward "^\\(Subject: \\)(no subject)\\|\
^\\([0-9A-Za-z-]+: ?\\)[\t ]*\n\\(?:[\t ]+\n\\)*[^\t ]"
bob 'move)
(goto-char (or (match-end 1) (match-end 2)))))
(defun w3m-mail-compose-with-mml (source url charset content-type
to subject other-headers)
"Compose a mail using MML."
(let ((buffer (generate-new-buffer " *w3m-mail*")))
(with-current-buffer buffer
(w3m-static-unless (featurep 'xemacs)
(set-buffer-multibyte (not (string-match "\\`image/" content-type))))
(insert source))
(if (eq mail-user-agent 'gnus-user-agent)
(progn
(require 'gnus)
(let (gnus-newsgroup-name)
(compose-mail to subject other-headers)))
(compose-mail to subject other-headers))
(message-add-action `(kill-buffer ,buffer) 'exit 'kill 'postpone 'send)
(w3m-mail-goto-body-and-clear-body)
(w3m-mail-position-point
(prog1
(point)
(mml-insert-empty-tag
'part
'type content-type
'buffer (buffer-name buffer)
;; Use the base64 encoding if the body contains non-ASCII text
;; or very long lines which might be broken by MTAs.
'encoding "base64"
'charset (when charset (symbol-name charset))
'disposition "inline"
'description url)))))
;; This function is implemented in mew-w3m.el.
;; (defun w3m-mail-compose-with-mew (source url charset content-type
;; to subject other-headers)
;; "Compose a mail using Mew.")
(defun w3m-mail-compose-with-vm (source url charset content-type
to subject other-headers)
"Compose a mail using VM."
(let* ((coding (and charset (w3m-charset-to-coding-system charset)))
(multibytep (and (not coding)
(or charset
(and (not (string-match "\\`image/"
content-type))
(w3m-static-if (featurep 'xemacs)
(string-match "[^\000-\177]" source)
(multibyte-string-p source))))))
(buffer (generate-new-buffer " *w3m-mail*")))
(with-current-buffer buffer
(w3m-static-unless (featurep 'xemacs)
(set-buffer-multibyte (and (not coding) multibytep)))
(cond (coding
(insert (encode-coding-string source coding)))
(multibytep
(insert source)
(when (and (setq charset (car (mm-find-mime-charset-region
(point-min) (point-max))))
(setq coding (w3m-charset-to-coding-system charset)))
(w3m-static-if (featurep 'xemacs)
(encode-coding-region (point-min) (point-max) coding)
(insert (prog1
(encode-coding-string (buffer-string) coding)
(erase-buffer)
(set-buffer-multibyte nil))))))
(t
(insert source))))
(require 'vm-startup)
(compose-mail to subject other-headers)
(add-to-list 'mail-send-actions `(kill-buffer ,buffer))
(w3m-add-local-hook 'kill-buffer-hook `(lambda nil (kill-buffer ,buffer)))
(w3m-mail-goto-body-and-clear-body)
(w3m-mail-position-point
(prog1
(point)
(vm-mime-attach-buffer buffer content-type
(when charset (symbol-name charset))
url)))))
(defun w3m-mail-compose-with-semi (source url charset content-type
to subject other-headers)
"Compose a mail using SEMI."
(require 'mime-edit)
(let* ((content-type (and content-type
(split-string (downcase content-type) "/")))
(basename (file-name-nondirectory (w3m-url-strip-query url)))
(filename (cond
((and (string-match "^[\t ]*$" basename)
(equal content-type '("text" "html")))
"index.html")
((string-match "^[\t ]*$" basename)
"dummy")
(t
basename)))
(type (or (nth 0 content-type) "text"))
(subtype (or (nth 1 content-type) "html"))
parameters
(encoding "base64")
(disposition-type "inline")
disposition-params
(guess (mime-find-file-type filename))
(textp (string= type "text")))
(when (and guess
(string= (nth 0 guess) type)
(string= (nth 1 guess) subtype))
(setq parameters (nth 2 guess)
encoding (or (nth 3 guess) encoding)
disposition-type (or (nth 4 guess) disposition-type)
disposition-params (nth 5 guess)))
(compose-mail to subject other-headers)
(w3m-mail-goto-body-and-clear-body)
(let ((parameters-to-string
(lambda (parameters)
(when parameters
(mapconcat
(lambda (parameter)
(concat "; " (car parameter)
"=" (if (eq (cdr parameter) 'file)
(std11-wrap-as-quoted-string filename)
(cdr parameter))))
parameters
""))))
(body (point))
(edit-buffer (current-buffer))
work-buffer)
(with-temp-buffer
(if textp
(progn
(insert source)
(unless charset
(setq charset (detect-mime-charset-region (point-min)
(point-max))))
(when charset
(setq parameters (cons (cons "charset" (symbol-name charset))
parameters))
(encode-mime-charset-region (point-min) (point-max) charset)))
(set-buffer-multibyte nil)
(insert source))
(mime-encode-region (point-min) (point-max) encoding)
(setq work-buffer (current-buffer))
(set-buffer edit-buffer)
(mime-edit-insert-tag
type subtype
(concat (funcall parameters-to-string parameters)
"\nContent-Disposition: " disposition-type
(funcall parameters-to-string disposition-params)
"\nContent-Description: " url))
(mime-edit-define-encoding encoding)
(save-restriction
(narrow-to-region (point) (point))
(insert-buffer-substring work-buffer)
(unless (bolp)
(insert "\n"))
(when (or (string= disposition-type "attachment")
(not (member encoding '("7bit" "8bit" "binary"))))
(add-text-properties
(point-min) (point-max) '(invisible t mime-edit-invisible t)))))
(w3m-mail-position-point body))))
(defun w3m-mail (&optional headers)
"Send a web page as a mail.
By default the subject is generated according to `w3m-mail-subject'.
The optional HEADERS is a list in which each element is a cons of the
symbol of a header name and a string. Here is an example to use this
function:
\(w3m-mail '((To . \"foo@bar\") (Subject . \"The emacs-w3m home page\")))"
(interactive (unless (eq major-mode 'w3m-mode)
(error "`%s' must be invoked from an emacs-w3m buffer"
this-command)))
(let ((composer (cdr (assq mail-user-agent
w3m-mail-user-agent-compose-function-alist)))
;; Don't move the history position.
(w3m-history-reuse-history-elements t)
source base url charset content-type to subject)
(cond
((not composer)
(error "`%s' is not supported (yet) by `w3m-mail'" mail-user-agent))
((not w3m-current-url)
(error "The source for this page is not available"))
((string-match "\\`about://source/" w3m-current-url)
(setq source (buffer-string)
base (w3m-mail-compute-base-url))
(w3m-view-source)
(setq url w3m-current-url
charset (w3m-coding-system-to-charset w3m-current-coding-system)
content-type (or (w3m-arrived-content-type w3m-current-url)
(w3m-content-type w3m-current-url)))
(w3m-view-source))
((string-match "\\`about://header/" w3m-current-url)
(w3m-view-source)
(setq source (buffer-string)
base (w3m-mail-compute-base-url))
(w3m-view-source)
(setq url w3m-current-url
charset (w3m-coding-system-to-charset w3m-current-coding-system)
content-type (or (w3m-arrived-content-type w3m-current-url)
(w3m-content-type w3m-current-url)))
(w3m-view-header))
(t
(setq url w3m-current-url
charset (w3m-coding-system-to-charset w3m-current-coding-system)
content-type (or (w3m-arrived-content-type w3m-current-url)
(w3m-content-type w3m-current-url)))
(w3m-view-source)
(setq source (buffer-string)
base (w3m-mail-compute-base-url))
(w3m-view-source)))
(when (and base (string= "text/html" content-type))
(setq source (w3m-mail-embed-base-url source base)))
(setq to (or (assq 'To headers) (assq 'to headers))
subject (or (assq 'Subject headers) (assq 'subject headers)))
(when (or to subject)
(setq headers (delq to (delq subject (copy-sequence headers)))
to (cdr to)
subject (cdr subject)))
(unless subject
(setq subject (let ((w3m-current-url url)) (w3m-mail-make-subject))))
(funcall composer source url charset content-type to subject headers)))
;;; w3m-mail.el ends here

278
share/emacs/site-lisp/w3m/w3m-namazu.el Normal file
View file

@ -0,0 +1,278 @@
;;; w3m-namazu.el --- The add-on program to search files with Namazu.
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2009
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Keywords: w3m, WWW, hypermedia, namazu
;; 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; w3m-namazu.el is the add-on program of emacs-w3m to search files
;; with Namazu. For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; History:
;; Original program was posted by
;; Takayuki Arakawa <takayu@pop02.odn.ne.jp> in [emacs-w3m:01340] at
;; Jul 31, 2001.
;; Many codes are imported from namazu.el written by
;; Yukihiro Matsumoto <matz@netlab.co.jp> et al.
;; All stuffs are rewritten by
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org> at Aug 2, 2001.
;;; Code:
(eval-when-compile
(require 'cl))
(require 'w3m)
(eval-and-compile
(autoload 'w3m-search-read-query "w3m-search"))
(defgroup w3m-namazu nil
"w3m-namazu front-end for Emacs."
:group 'w3m
:prefix "w3m-namazu-")
(defcustom w3m-namazu-command "namazu"
"*Name of the executable file of Namazu."
:group 'w3m-namazu
:type '(string :size 0))
(defcustom w3m-namazu-arguments
'("-h" ; print in HTML format.
"-H" ; print further result links.
"-n" w3m-namazu-page-max ; set number of documents shown to NUM.
"-w" whence) ; set first number of documents shown to NUM.
"*Arguments of Namazu."
:group 'w3m-namazu
:type '(repeat
(restricted-sexp :format "Argument: %v\n"
:match-alternatives
(stringp 'w3m-namazu-page-max 'whence)
:size 0)))
(defcustom w3m-namazu-page-max
(if (boundp 'namazu-search-num)
(symbol-value 'namazu-search-num)
30)
"*A maximum number of documents which are retrieved by one-time search."
:group 'w3m-namazu
:type '(integer :size 0))
(defconst w3m-namazu-default-index-customize-spec
'`(choice
(const :tag "No default index" nil)
,@(mapcar (lambda (x) (list 'const (car x)))
w3m-namazu-index-alist)
(directory :format "Index directory: %v\n" :size 0)))
(defcustom w3m-namazu-index-alist
(when (boundp 'namazu-dir-alist)
(mapcar (lambda (pair)
(cons (car pair)
(split-string (cdr pair))))
(symbol-value 'namazu-dir-alist)))
"*Alist of alias and index directories."
:group 'w3m-namazu
:type '(repeat
(group
:indent 0 :inline t
(cons :format "%v"
(string :format "Alias: %v\n" :size 0)
(repeat
:format "%v%i\n" :indent 8
(directory :format "Index directory: %v\n" :size 0)))))
:set (lambda (symbol value)
(custom-set-default symbol value)
(put 'w3m-namazu-default-index 'custom-type
(eval w3m-namazu-default-index-customize-spec))))
(defcustom w3m-namazu-default-index
(unless (and (boundp 'namazu-always-query-index-directory)
(symbol-value 'namazu-always-query-index-directory))
(when (boundp 'namazu-default-dir)
(symbol-value 'namazu-default-dir)))
"*Alias or directory of the default index.
If this variable equals nil, it is required to input an index path
whenever `w3m-namazu' is called interactively without prefix
argument."
:group 'w3m-namazu
:type (eval w3m-namazu-default-index-customize-spec))
(defcustom w3m-namazu-output-coding-system
(if (boundp 'namazu-cs-write)
(symbol-value 'namazu-cs-write)
(if (memq system-type '(OS/2 emx windows-nt))
'shift_jis-dos
'euc-japan-unix))
"*Coding system for namazu process."
:group 'w3m-namazu
:type '(coding-system :size 0))
(defcustom w3m-namazu-input-coding-system
(if (boundp 'namazu-cs-read)
(symbol-value 'namazu-cs-read)
'undecided)
"*Coding system for namazu process."
:group 'w3m-namazu
:type '(coding-system :size 0))
(defun w3m-namazu-call-process (index query whence)
(setq index (if (assoc index w3m-namazu-index-alist)
(mapcar 'expand-file-name
(cdr (assoc index w3m-namazu-index-alist)))
(list (expand-file-name index))))
(let ((file-name-coding-system w3m-file-name-coding-system)
(coding-system-for-read w3m-namazu-input-coding-system)
(coding-system-for-write w3m-namazu-output-coding-system)
(default-process-coding-system
(cons w3m-namazu-input-coding-system
w3m-namazu-output-coding-system)))
(apply 'call-process w3m-namazu-command nil t nil
(let ((w3m-namazu-page-max
(number-to-string w3m-namazu-page-max)))
(nconc (mapcar 'eval w3m-namazu-arguments)
(list query)
index)))))
;;;###autoload
(defun w3m-about-namazu (url &optional no-decode no-cache &rest args)
(let (index query (whence "0"))
(when (string-match "\\`about://namazu/\\?" url)
(dolist (s (split-string (substring url (match-end 0)) "&"))
(when (string-match "\\`\\(?:index\\|\\(query\\)\\|\\(whence\\)\\)=" s)
(set (cond
((match-beginning 1) 'query)
((match-beginning 2) 'whence)
(t 'index))
(substring s (match-end 0)))))
(when (zerop (w3m-namazu-call-process (w3m-url-decode-string index)
(w3m-url-decode-string query)
whence))
(let ((case-fold-search t))
(goto-char (point-min))
(let ((max (if (re-search-forward
"<!-- HIT -->\\([0-9]+\\)<!-- HIT -->" nil t)
(string-to-number (match-string 1))
0))
(cur (string-to-number whence)))
(goto-char (point-min))
(when (search-forward "<head>" nil t)
(when (> cur 0)
(insert
(format "
<link rel=\"prev\" href=\"about://namazu/?index=%s&query=%s&whence=%d\">"
index
query
(max (- cur w3m-namazu-page-max) 0))))
(when (> max (+ cur w3m-namazu-page-max))
(insert
(format "
<link rel=\"next\" href=\"about://namazu/?index=%s&query=%s&whence=%d\">"
index
query
(+ cur w3m-namazu-page-max))))))
(goto-char (point-min))
(while (search-forward "<a href=\"/" nil t)
(forward-char -1)
(insert "file://"))
(goto-char (point-min))
(while (re-search-forward "<a href=\"\\(\\?\\)&\\(?:amp;\\)?whence="
nil t)
(goto-char (match-beginning 1))
(delete-char 1)
(insert (format "about://namazu/?index=%s&query=%s" index query))))
"text/html"))))
(defun w3m-namazu-complete-index (index predicate flag)
"Function to complete index name"
(if (eq flag 'lambda)
(and (or (and (assoc index w3m-namazu-index-alist) t)
(file-directory-p index))
(or (not predicate)
(funcall predicate index)))
(let ((alist
(mapcar
'list
(nconc
(all-completions index w3m-namazu-index-alist)
(let ((partial (file-name-nondirectory index))
(dir (file-name-as-directory
(or (file-name-directory index)
default-directory))))
(delq nil
(mapcar
(lambda (file)
(when (file-directory-p (expand-file-name file dir))
(concat dir file)))
(file-name-all-completions partial dir))))))))
(cond
((not flag) (try-completion index alist predicate))
((eq flag t) (all-completions index alist predicate))))))
(defvar w3m-namazu-index-history nil)
(defvar w3m-namazu-query-history nil)
;;;###autoload
(defun w3m-namazu (index query &optional reload)
"Search indexed files with Namazu."
(interactive
(list
(if (if w3m-namazu-default-index
current-prefix-arg
(not (and current-prefix-arg
w3m-namazu-index-history)))
(let* ((default (or (car w3m-namazu-index-history)
w3m-namazu-default-index))
(s (completing-read
(if default
(format "Namazu index (default %s): " default)
"Namazu index: ")
'w3m-namazu-complete-index nil t nil
'w3m-namazu-index-history)))
(if (string= s "") default s))
(or w3m-namazu-default-index
(car w3m-namazu-index-history)))
(w3m-search-read-query "Namazu query: " "Namazu query (default %s): "
'w3m-namazu-query-history)
current-prefix-arg))
(unless (stringp index)
(error "%s" "Index is required"))
(unless (stringp query)
(error "%s" "Query is required"))
(w3m-goto-url (format "about://namazu/?index=%s&query=%s&whence=0"
(w3m-url-encode-string index)
(w3m-url-encode-string query))
reload))
(provide 'w3m-namazu)
;;; w3m-namazu.el ends here

124
share/emacs/site-lisp/w3m/w3m-perldoc.el Normal file
View file

@ -0,0 +1,124 @@
;;; w3m-perldoc.el --- The add-on program to view Perl documents.
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Keywords: w3m, perldoc
;; 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; w3m-perldoc.el is the add-on program of emacs-w3m to view Perl
;; documents. For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; Code:
(require 'w3m)
(defgroup w3m-perldoc nil
"Perldoc front-end for emacs-w3m."
:group 'w3m
:prefix "w3m-perldoc-")
(defcustom w3m-perldoc-command "perldoc"
"*Name of the executable file of perldoc."
:group 'w3m-perldoc
:type '(string :size 0))
(defcustom w3m-perldoc-pod2html-command "pod2html"
"*Name of the executable file of pod2html."
:group 'w3m-perldoc
:type '(string :size 0))
(defcustom w3m-perldoc-pod2html-arguments
'("--noindex")
"*Arguments of pod2html."
:group 'w3m-perldoc
:type '(repeat (string :format "Argument: %v\n" :size 0))
:get (lambda (symbol)
(delq nil (delete "" (mapcar (lambda (x) (if (stringp x) x))
(default-value symbol)))))
:set (lambda (symbol value)
(custom-set-default
symbol
(delq nil (delete "" (mapcar (lambda (x) (if (stringp x) x))
value))))))
(defcustom w3m-perldoc-input-coding-system
(if (string= "Japanese" w3m-language)
'euc-japan
(if (w3m-find-coding-system 'utf-8)
'utf-8
'iso-latin-1))
"*Coding system used when writing to `w3m-perldoc-command'."
:group 'w3m-perldoc
:type '(coding-system :size 0))
(defcustom w3m-perldoc-output-coding-system
'undecided
"*Coding system used when reading from `w3m-perldoc-command'."
:group 'w3m-perldoc
:type '(coding-system :size 0))
;;;###autoload
(defun w3m-about-perldoc (url &optional no-decode no-cache &rest args)
(when (string-match "\\`about://perldoc/" url)
(let ((docname (if (= (length url) (match-end 0))
"perl"
(w3m-url-decode-string (substring url (match-end 0)))))
(default-directory w3m-profile-directory)
(process-environment (copy-sequence process-environment)))
;; To specify the place in which pod2html generates its cache files.
(setenv "HOME" (expand-file-name w3m-profile-directory))
(and (let ((coding-system-for-read w3m-perldoc-output-coding-system))
(zerop (call-process w3m-perldoc-command
nil t nil "-u" docname)))
(let ((coding-system-for-write w3m-perldoc-input-coding-system)
(coding-system-for-read w3m-perldoc-input-coding-system))
(zerop (apply (function call-process-region)
(point-min) (point-max)
w3m-perldoc-pod2html-command
t '(t nil) nil
(append w3m-perldoc-pod2html-arguments
'("--htmlroot=about://perldoc")))))
(let ((case-fold-search t))
(goto-char (point-min))
(while (re-search-forward
"<a href=\"about://perldoc/\\([^\"]*\\)\\(\\.html\\)\">" nil t)
(delete-region (match-beginning 2) (match-end 2))
(save-restriction
(narrow-to-region (match-beginning 1) (match-end 1))
(while (search-backward "/" nil t)
(delete-char 1)
(insert "::"))
(goto-char (point-max))))
"text/html")))))
;;;###autoload
(defun w3m-perldoc (docname)
"View Perl documents."
(interactive "sDocument: ")
(w3m-goto-url (concat "about://perldoc/" (w3m-url-encode-string docname))))
(provide 'w3m-perldoc)
;;; w3m-perldoc.el ends here.

801
share/emacs/site-lisp/w3m/w3m-proc.el Normal file
View file

@ -0,0 +1,801 @@
;;; w3m-proc.el --- Functions and macros to control sub-processes
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.org>,
;; Shun-ichi GOTO <gotoh@taiyo.co.jp>,
;; Satoru Takabayashi <satoru-t@is.aist-nara.ac.jp>,
;; Hideyuki SHIRAI <shirai@meadowy.org>,
;; Keisuke Nishida <kxn30@po.cwru.edu>,
;; Yuuichi Teranishi <teranisi@gohome.org>,
;; Akihiro Arisawa <ari@mbf.sphere.ne.jp>,
;; 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This module is a part of emacs-w3m which provides functions and
;; macros to control sub-processes. Visit
;; <URL:http://emacs-w3m.namazu.org/> for more details of emacs-w3m.
;;; Code:
(eval-when-compile
(require 'cl))
(require 'w3m-util)
(eval-when-compile
;; Variable(s) which are used in the following inline functions.
;; They should be defined in the other module at run-time.
(defvar w3m-current-url)
(defvar w3m-current-buffer)
(defvar w3m-current-process)
(defvar w3m-profile-directory)
(defvar w3m-terminal-coding-system)
(defvar w3m-command)
(defvar w3m-command-arguments)
(defvar w3m-command-environment)
(defvar w3m-async-exec)
(defvar w3m-process-connection-type)
(defvar w3m-process-modeline-format)
(defvar w3m-work-buffer-list)
(autoload 'w3m-idle-images-show-unqueue "w3m"))
;; Silence the Emacs' byte-compiler that says ``might not be defined''.
(eval-when-compile
(defun w3m-decode-coding-string-with-priority (str coding)
()))
(defvar w3m-process-inhibit-quit t
"`w3m-process-sentinel' binds `inhibit-quit' according to this variable.")
(defvar w3m-process-timeout 300
"Number of seconds idle time waiting for processes to terminate.")
(defvar w3m-process-kill-surely (featurep 'meadow)
"If non-nil, kill the process surely.")
(defconst w3m-process-max 5 "The maximum limit of the working processes.")
(defvar w3m-process-queue nil "Queue of processes.")
(defvar w3m-process-exit-status nil "The last exit status of a process.")
(defvar w3m-process-authinfo-alist nil)
(defvar w3m-process-accept-alist nil)
(defvar w3m-process-user nil)
(defvar w3m-process-passwd nil)
(defvar w3m-process-realm nil)
(defvar w3m-process-object nil)
(make-variable-buffer-local 'w3m-process-user)
(make-variable-buffer-local 'w3m-process-passwd)
(make-variable-buffer-local 'w3m-process-realm)
(make-variable-buffer-local 'w3m-process-object)
(defvar w3m-process-modeline-string nil
"Modeline string to show status of retrieving process.")
(make-variable-buffer-local 'w3m-process-modeline-string)
(defvar w3m-process-proxy-user nil "User name of the proxy server.")
(defvar w3m-process-proxy-passwd nil "Password of the proxy server.")
(defvar w3m-process-ssl-passphrase nil
"Passphrase for the client certificate.")
(defmacro w3m-process-with-coding-system (&rest body)
"Set coding systems for `w3m-command', and evaluate BODY."
`(let ((coding-system-for-read 'binary)
(coding-system-for-write w3m-terminal-coding-system)
(default-process-coding-system
(cons 'binary w3m-terminal-coding-system))
(process-connection-type w3m-process-connection-type))
,@body))
(put 'w3m-process-with-coding-system 'lisp-indent-function 0)
(put 'w3m-process-with-coding-system 'edebug-form-spec '(body))
(defmacro w3m-process-with-environment (alist &rest body)
"Set the environment variables according to ALIST, and evaluate BODY."
`(let ((process-environment (copy-sequence process-environment))
(temporary-file-directory
(if (file-directory-p w3m-profile-directory)
(file-name-as-directory w3m-profile-directory)
,(if (featurep 'xemacs)
;; Though `temporary-file-directory' exists even in XEmacs,
;; that's only an imitation provided by APEL.
'(temp-directory)
'temporary-file-directory)))
(default-directory
(cond ((file-directory-p w3m-profile-directory)
(file-name-as-directory w3m-profile-directory))
((file-directory-p (expand-file-name "~/"))
(expand-file-name "~/"))
(t temporary-file-directory))))
;; XEmacs obtains tmp-dir from the `temp-directory' function of which
;; return value can only be modified by the following env vars.
,@(if (featurep 'xemacs)
'((setenv "TEMP" temporary-file-directory) ;; Windoze
(setenv "TMPDIR" temporary-file-directory))) ;; Un|x
(dolist (pair ,alist)
(setenv (car pair) (cdr pair)))
,@body))
(put 'w3m-process-with-environment 'lisp-indent-function 1)
(put 'w3m-process-with-environment 'edebug-form-spec '(form body))
(defun w3m-process-p (object)
"Return t if OBJECT is a `w3m-process' object."
(and (consp object)
(vectorp (cdr object))
(eq 'w3m-process-object (aref (cdr object) 0))))
(put 'w3m-process-new 'edebug-form-spec '(form form form &optional form form))
(defmacro w3m-process-new (command arguments buffer &optional process handlers)
"Return a new `w3m-process' object."
`(cons (cons ,command ,arguments)
(vector 'w3m-process-object
,buffer
,process
,handlers)))
(defmacro w3m-process-command (object)
`(car (car ,object)))
(defmacro w3m-process-arguments (object)
`(cdr (car ,object)))
(defmacro w3m-process-buffer (object)
`(aref (cdr ,object) 1))
(defmacro w3m-process-process (object)
`(aref (cdr ,object) 2))
(defmacro w3m-process-handlers (object)
`(aref (cdr ,object) 3))
(put 'w3m-process-handler-new 'edebug-form-spec '(form form form))
(defmacro w3m-process-handler-new (buffer parent-buffer functions)
`(vector ,buffer ,parent-buffer ,functions nil))
(defmacro w3m-process-handler-buffer (handler)
`(aref ,handler 0))
(defmacro w3m-process-handler-parent-buffer (handler)
`(aref ,handler 1))
(defmacro w3m-process-handler-functions (handler)
`(aref ,handler 2))
(defmacro w3m-process-handler-result (handler)
`(aref ,handler 3))
(defun w3m-process-push (handler command arguments)
"Generate a new `w3m-process' object which is provided by HANDLER,
ARGUMENTS and this buffer, regist it to `w3m-process-queue', and
return it."
(let ((x (assoc (cons command arguments) w3m-process-queue)))
(unless x
(setq x (w3m-process-new command arguments (current-buffer)))
(push x w3m-process-queue))
(push (w3m-process-handler-new (current-buffer) w3m-current-buffer handler)
(w3m-process-handlers x))
(with-current-buffer (w3m-process-buffer x)
(setq w3m-process-object x))))
(defun w3m-process-kill-process (process)
"Kill process PROCESS safely."
(when (processp process)
(set-process-filter process 'ignore)
(set-process-sentinel process 'ignore)
(when (memq (process-status process) '(run stop))
(kill-process process)
(when w3m-process-kill-surely
(while (memq (process-status process) '(run stop))
(sit-for 0.1))))))
(defun w3m-process-start-process (object &optional no-sentinel)
"Start a process specified by the OBJECT, return always nil.
When NO-SENTINEL is not equal to nil, all status changes of the
generated asynchronous process is ignored. Otherwise,
`w3m-process-sentinel' is given to the process as the sentinel."
(if (w3m-process-process object)
(when no-sentinel
(set-process-sentinel (w3m-process-process object) 'ignore))
(with-current-buffer (w3m-process-buffer object)
(w3m-process-with-coding-system
(w3m-process-with-environment w3m-command-environment
(let* ((command (w3m-process-command object))
(proc (apply 'start-process command
(current-buffer) command
(w3m-process-arguments object)))
(authinfo (when w3m-current-url
(w3m-url-authinfo w3m-current-url)))
(set-process-query-on-exit-flag
(if (fboundp 'set-process-query-on-exit-flag)
'set-process-query-on-exit-flag
'process-kill-without-query)))
(setq w3m-process-user (car authinfo)
w3m-process-passwd (cdr authinfo)
w3m-process-realm nil)
(setf (w3m-process-process object) proc)
(set-process-filter proc 'w3m-process-filter)
(set-process-sentinel proc (if no-sentinel
'ignore
'w3m-process-sentinel))
(funcall set-process-query-on-exit-flag proc nil))))))
nil) ;; The return value of `w3m-process-start-process'.
(defun w3m-process-kill-stray-processes ()
"Kill stray processes."
(dolist (obj w3m-process-queue)
(unless (buffer-name (w3m-process-buffer obj))
(setq w3m-process-queue (delq obj w3m-process-queue))
(when (w3m-process-process obj)
(w3m-process-kill-process (w3m-process-process obj))))))
(defun w3m-process-start-queued-processes ()
"Start a process which is registerd in `w3m-process-queue' if the
number of current working processes is less than `w3m-process-max'."
(w3m-process-kill-stray-processes)
(let ((num 0))
(catch 'last
(dolist (obj (reverse w3m-process-queue))
(when (buffer-name (w3m-process-buffer obj))
(if (> (incf num) w3m-process-max)
(throw 'last nil)
(w3m-process-start-process obj)))))))
(defun w3m-process-stop (buffer)
"Remove handlers related to the buffer BUFFER, and stop processes
which have no handler."
(interactive (list (current-buffer)))
(w3m-cancel-refresh-timer buffer)
(setq w3m-process-queue
(delq nil
(mapcar
(lambda (obj)
(let ((handlers
;; List up handlers related to other buffer
;; than the buffer BUFFER.
(delq nil
(mapcar
(lambda (handler)
(unless (eq buffer
(w3m-process-handler-parent-buffer
handler))
handler))
(w3m-process-handlers obj)))))
(if handlers
(w3m-process-new
(w3m-process-command obj)
(w3m-process-arguments obj)
(w3m-process-buffer obj)
(w3m-process-process obj)
(if (memq (w3m-process-buffer obj)
(mapcar (lambda (x)
(w3m-process-handler-buffer x))
handlers))
handlers
(cons
;; Dummy handler to remove buffer.
(w3m-process-handler-new
(w3m-process-buffer obj)
(w3m-process-handler-parent-buffer (car handlers))
(lambda (x) (w3m-kill-buffer (current-buffer))))
handlers)))
(when (w3m-process-process obj)
(w3m-process-kill-process (w3m-process-process obj)))
(dolist (handler (w3m-process-handlers obj))
(w3m-kill-buffer (w3m-process-handler-buffer handler)))
nil)))
w3m-process-queue)))
(when (buffer-name buffer)
(with-current-buffer buffer
(setq w3m-current-process nil)))
(w3m-process-start-queued-processes)
(w3m-force-window-update-later buffer))
(defun w3m-process-shutdown ()
(let ((list w3m-process-queue))
(setq w3m-process-queue nil
w3m-process-authinfo-alist nil
w3m-process-accept-alist nil)
(dolist (obj list)
(when (buffer-name (w3m-process-buffer obj))
(when (w3m-process-process obj)
(w3m-process-kill-process (w3m-process-process obj))))
(w3m-kill-buffer (w3m-process-buffer obj)))))
(defmacro w3m-process-with-null-handler (&rest body)
"Generate the null handler, and evaluate BODY.
When BODY is evaluated, the local variable `handler' keeps the null
handler."
(let ((var (gensym "--tempvar--")))
`(let ((,var (let (handler) ,@body)))
(when (w3m-process-p ,var)
(w3m-process-start-process ,var))
,var)))
(put 'w3m-process-with-null-handler 'lisp-indent-function 0)
(put 'w3m-process-with-null-handler 'edebug-form-spec '(body))
;; Error symbol:
(put 'w3m-process-timeout 'error-conditions '(error w3m-process-timeout))
(put 'w3m-process-timeout 'error-message "Time out")
(defun w3m-process-error-handler (error-data process)
(setq w3m-process-queue (delq process w3m-process-queue))
(w3m-process-kill-process (w3m-process-process process))
(signal (car error-data) (cdr error-data)))
(defvar w3m-process-waited nil
"Non-nil means that `w3m-process-with-wait-handler' is being evaluated.")
(defun w3m-process-wait-process (process seconds)
"Wait for SECONDS seconds or until PROCESS will exit.
Returns the exit status of the PROCESS when it exit normally,
otherwise returns nil."
(catch 'timeout
(let ((start (current-time)))
(while (or (and (prog2
(discard-input)
(not (save-current-buffer (sit-for 0.1)))
(discard-input))
;; Some input is detected but it may be a key
;; press event which should be ignored when the
;; process is not running.
(memq (process-status process) '(open run)))
(memq (process-status process) '(open run stop)))
(and seconds
(< seconds (w3m-time-lapse-seconds start (current-time)))
(throw 'timeout nil)))
(process-exit-status process))))
(defmacro w3m-process-with-wait-handler (&rest body)
"Generate the waiting handler, and evaluate BODY.
When BODY is evaluated, the local variable `handler' keeps the handler
which will wait for the end of the evaluation."
(let ((result (gensym "--result--"))
(wait-function (gensym "--wait-function--")))
`(let ((w3m-process-waited t)
(,result)
(,wait-function (make-symbol "wait-function")))
(fset ,wait-function 'identity)
(setq ,result (let ((handler (list ,wait-function))) ,@body))
(while (w3m-process-p ,result)
(condition-case error
(let (w3m-process-inhibit-quit inhibit-quit)
;; No sentinel function is registered and the process
;; sentinel function is called from this macro, in
;; order to avoid the dead-locking which occurs when
;; this macro is called in the environment that
;; `w3m-process-sentinel' is evaluated.
(w3m-process-start-process ,result t)
(unless (w3m-process-wait-process (w3m-process-process ,result)
w3m-process-timeout)
(w3m-process-error-handler (cons 'w3m-process-timeout nil)
,result)))
(quit (w3m-process-error-handler error ,result)))
(w3m-process-sentinel (w3m-process-process ,result) "finished\n" t)
(setq ,result
(catch 'result
(dolist (handler (w3m-process-handlers ,result))
(when (memq ,wait-function
(w3m-process-handler-functions handler))
(throw 'result (w3m-process-handler-result handler))))
(w3m-process-error-handler (cons 'error
"Can't find wait handler")
,result))))
,result)))
(put 'w3m-process-with-wait-handler 'lisp-indent-function 0)
(put 'w3m-process-with-wait-handler 'edebug-form-spec '(body))
;;; Explanation of w3m-process-do in Japanese:
;;
;; w3m-process-do $B$O!"HsF14|=hM}$r4JC1$K=q$/$?$a$N%^%/%m$G$"$k!#Nc$($P!"(B
;;
;; (w3m-process-do
;; (var (async-form...))
;; post-body...)
;;
;; $B$H$$$&$h$&$K=q$/$H!"0J2<$N=g=x$G=hM}$,9T$o$l$k!#(B
;;
;; (1) async-form $B$rI>2A(B
;; --> async-form $BFb$GHsF14|%W%m%;%9$,@8@.$5$l$?>l9g$O!"$=$NHsF1(B
;; $B4|%W%m%;%9=*N;8e$K(B post-body $B$,I>2A$5$l$k$h$&$K!"%O%s%I%i(B
;; $B$KDI2C(B
;; --> $BHsF14|%W%m%;%9$,@8@.$5$l$J$+$C$?>l9g$O!"C1$K<!$N%9%F%C%W(B
;; $B$K?J$`(B(= post-body $B$rI>2A$9$k(B)$B!#(B
;; (2) post-body $B$rI>2A(B
;;
;; $B$J$*!"(Basync-form / post-body $B$,I>2A$5$l$k;~!"$=$NFbIt$GHsF14|%W%m%;(B
;; $B%9$,@8@.$5$l$?>l9g$K!"$=$NJV$jCM$r=hM}$9$k$?$a$N%O%s%I%i$,!"JQ?t(B
;; handler $B$K@_Dj$5$l$F$$$k!#HsF14|$J=hM}$r9T$&4X?t$r8F$S=P$9>l9g$K$O!"(B
;; $B$=$N4X?t$N0z?t$H$7$FI,$:(B handler $B$rEO$5$J$1$l$P$J$i$J$$!#(B
;;
;; $B$^$?!"(Bw3m-process-do $B$O!"8=:_$N%O%s%I%i$NFbMF$rD4$Y$k$?$a!"$=$N%^%/(B
;; $B%m$,8F$S=P$5$l$F$$$k4D6-$NJQ?t(B handler $B$r;2>H$9$k!#Nc$($P!"(B
;;
;; (let (handler) (w3m-process-do ...))
;;
;; $B$HJQ?t(B handler $B$r(B nil $B$KB+G{$7$F$*$/$H!"!V8=;~E@$N%O%s%I%i$O6u$G$"(B
;; $B$k(B = $BHsF14|%W%m%;%9<B9T8e$KI,MW$J=hM}$OB8:_$7$J$$!W$H$$$&0UL#$K$J$j!"(B
;; w3m-process-do() $B$O!"HsF14|%W%m%;%9$,@8@.$5$l$?>l9g$K$OC1$K(B nil $B$r(B
;; $BJV$7!"$=$l0J30$N>l9g$O(B post-body $B$NCM$rJV$9!#(B
;;
(defmacro w3m-process-do (spec &rest body)
"(w3m-process-do (VAR FORM) BODY...): Eval the body BODY asynchronously.
If an asynchronous process is generated in the evaluation of the form
FORM, this macro returns its object immdiately, and the body BODY will
be evaluated after the end of the process with the variable VAR which
is set to the result of the form FORM. Otherwise, the body BODY is
evaluated at the same time, and this macro returns the result of the
body BODY."
(let ((var (or (car spec) (gensym "--tempvar--")))
(form (cdr spec))
(post-function (gensym "--post-function--")))
`(let ((,post-function (lambda (,var) ,@body)))
(let ((,var (let ((handler (cons ,post-function handler)))
,@form)))
(if (w3m-process-p ,var)
(if handler
,var
(w3m-process-start-process ,var))
(if (w3m-process-p (setq ,var (funcall ,post-function ,var)))
(if handler
,var
(w3m-process-start-process ,var))
,var))))))
(put 'w3m-process-do 'lisp-indent-function 1)
(put 'w3m-process-do 'edebug-form-spec '((symbolp form) def-body))
(defmacro w3m-process-do-with-temp-buffer (spec &rest body)
"(w3m-process-do-with-temp-buffer (VAR FORM) BODY...):
Like `w3m-process-do', but the form FORM and the body BODY are
evaluated in a temporary buffer."
(let ((var (or (car spec) (gensym "--tempvar--")))
(form (cdr spec))
(post-body (gensym "--post-body--"))
(post-handler (gensym "--post-handler--"))
(temp-buffer (gensym "--temp-buffer--"))
(current-buffer (gensym "--current-buffer--")))
`(lexical-let ((,temp-buffer
(w3m-get-buffer-create
(generate-new-buffer-name w3m-work-buffer-name)))
(,current-buffer (current-buffer)))
(labels ((,post-body (,var)
(when (buffer-name ,temp-buffer)
(set-buffer ,temp-buffer))
,@body)
(,post-handler (,var)
(w3m-kill-buffer ,temp-buffer)
(when (buffer-name ,current-buffer)
(set-buffer ,current-buffer))
,var))
(let ((,var (let ((handler
(cons ',post-body (cons ',post-handler handler))))
(with-current-buffer ,temp-buffer ,@form))))
(if (w3m-process-p ,var)
(if handler
,var
(w3m-process-start-process ,var))
(if (w3m-process-p
(setq ,var (save-current-buffer
(let ((handler (cons ',post-handler handler)))
(,post-body ,var)))))
(if handler
,var
(w3m-process-start-process ,var))
(,post-handler ,var))))))))
(put 'w3m-process-do-with-temp-buffer 'lisp-indent-function 1)
(put 'w3m-process-do-with-temp-buffer 'edebug-form-spec
'((symbolp form) def-body))
(defun w3m-process-start (handler command arguments)
"Run COMMAND with ARGUMENTS, and eval HANDLER asynchronously."
(if w3m-async-exec
(w3m-process-do
(exit-status (w3m-process-push handler command arguments))
(w3m-process-start-after exit-status))
(w3m-process-start-after
(w3m-process-with-coding-system
(w3m-process-with-environment w3m-command-environment
(apply 'call-process command nil t nil arguments))))))
(defun w3m-process-start-after (exit-status)
(when w3m-current-buffer
(with-current-buffer w3m-current-buffer
(setq w3m-process-modeline-string nil)))
(cond
((numberp exit-status)
(zerop (setq w3m-process-exit-status exit-status)))
((not exit-status)
(setq w3m-process-exit-status nil))
(t
(setq w3m-process-exit-status
(string-as-multibyte (format "%s" exit-status)))
nil)))
(defvar w3m-process-background nil
"Non-nil means that an after handler is being evaluated.")
(defun w3m-process-sentinel (process event &optional ignore-queue)
;; Ensure that this function will be never called repeatedly.
(set-process-sentinel process 'ignore)
(let ((inhibit-quit w3m-process-inhibit-quit)
(w3m-process-background t))
(unwind-protect
(if (buffer-name (process-buffer process))
(with-current-buffer (process-buffer process)
(w3m-static-unless (featurep 'xemacs)
(accept-process-output process 1))
(setq w3m-process-queue
(delq w3m-process-object w3m-process-queue))
(let ((exit-status (process-exit-status process))
(buffer (current-buffer))
(realm w3m-process-realm)
(user w3m-process-user)
(passwd w3m-process-passwd)
(obj w3m-process-object))
(setq w3m-process-object nil)
(dolist (x (w3m-process-handlers obj))
(when (and
(buffer-name (w3m-process-handler-buffer x))
(buffer-name (w3m-process-handler-parent-buffer x)))
(set-buffer (w3m-process-handler-buffer x))
(unless (eq buffer (current-buffer))
(insert-buffer-substring buffer))))
(dolist (x (w3m-process-handlers obj))
(when (and
(buffer-name (w3m-process-handler-buffer x))
(buffer-name (w3m-process-handler-parent-buffer x)))
(set-buffer (w3m-process-handler-buffer x))
(let ((w3m-process-exit-status)
(w3m-current-buffer
(w3m-process-handler-parent-buffer x))
(handler
(w3m-process-handler-functions x))
(exit-status exit-status))
(when realm
(w3m-process-set-authinfo w3m-current-url
realm user passwd))
(while (and handler
(not (w3m-process-p
(setq exit-status
(funcall (pop handler)
exit-status))))))
(setf (w3m-process-handler-result x) exit-status))))))
;; Something wrong has been occured.
(catch 'last
(dolist (obj w3m-process-queue)
(when (eq process (w3m-process-process obj))
(setq w3m-process-queue (delq obj w3m-process-queue))
(throw 'last nil)))))
(delete-process process)
(unless ignore-queue
(w3m-process-start-queued-processes)))))
(defun w3m-process-filter (process string)
(when (buffer-name (process-buffer process))
(with-current-buffer (process-buffer process)
(let ((buffer-read-only nil)
(case-fold-search nil))
(goto-char (process-mark process))
(insert string)
(set-marker (process-mark process) (point))
(unless (string= "" string)
(goto-char (point-min))
(cond
((and (looking-at
"\\(?:Accept [^\n]+\n\\)*\\([^\n]+: accept\\? \\)(y/n)")
(= (match-end 0) (point-max)))
;; SSL certificate
(message "")
(let ((yn (w3m-process-y-or-n-p w3m-current-url (match-string 1))))
(ignore-errors
(process-send-string process (if yn "y\n" "n\n"))
(delete-region (point-min) (point-max)))))
((and (looking-at "\n?Accept unsecure SSL session:.*\n")
(= (match-end 0) (point-max)))
(delete-region (point-min) (point-max)))
((and (looking-at "\\(\n?Wrong username or password\n\\)?\
Proxy Username for \\(?:.*\\): Proxy Password: ")
(= (match-end 0) (point-max)))
(when (or (match-beginning 1)
(not (stringp w3m-process-proxy-passwd)))
(setq w3m-process-proxy-passwd
(read-passwd "Proxy Password: ")))
(ignore-errors
(process-send-string process
(concat w3m-process-proxy-passwd "\n"))
(delete-region (point-min) (point-max))))
((and (looking-at "\\(\n?Wrong username or password\n\\)?\
Proxy Username for \\(.*\\): ")
(= (match-end 0) (point-max)))
(when (or (match-beginning 1)
(not (stringp w3m-process-proxy-user)))
(setq w3m-process-proxy-user
(read-from-minibuffer (concat
"Proxy Username for "
(match-string 2) ": "))))
(ignore-errors
(process-send-string process
(concat w3m-process-proxy-user "\n"))))
((and (looking-at "\\(\n?Wrong username or password\n\\)?\
Username for [^\n]*\n?: Password: ")
(= (match-end 0) (point-max)))
(when (or (match-beginning 1)
(not (stringp w3m-process-passwd)))
(setq w3m-process-passwd
(w3m-process-read-passwd w3m-current-url
w3m-process-realm
w3m-process-user
(match-beginning 1))))
(ignore-errors
(process-send-string process
(concat w3m-process-passwd "\n"))
(delete-region (point-min) (point-max))))
((and (looking-at "\\(\n?Wrong username or password\n\\)?\
Username for \\(.*\\)\n?: ")
(= (match-end 0) (point-max)))
(setq w3m-process-realm (w3m-decode-coding-string-with-priority
(match-string 2) nil))
(when (or (match-beginning 1)
(not (stringp w3m-process-user)))
(setq w3m-process-user
(w3m-process-read-user w3m-current-url
w3m-process-realm
(match-beginning 1))))
(ignore-errors
(process-send-string process
(concat w3m-process-user "\n"))))
((and (looking-at "Enter PEM pass phrase:")
(= (match-end 0) (point-max)))
(unless (stringp w3m-process-ssl-passphrase)
(setq w3m-process-ssl-passphrase
(read-passwd "PEM pass phrase: ")))
(ignore-errors
(process-send-string process
(concat w3m-process-ssl-passphrase "\n"))
(delete-region (point-min) (point-max))))
((progn
(or (search-forward "\nW3m-current-url:" nil t)
(goto-char (process-mark process)))
(re-search-backward
"^W3m-\\(?:in-\\)?progress: \\([.0-9]+/[.0-9]+[a-zA-Z]?b\\)$"
nil t))
(let ((str (w3m-process-modeline-format (match-string 1)))
(buf))
(save-current-buffer
(dolist (handler (w3m-process-handlers w3m-process-object))
(when (setq buf (w3m-process-handler-parent-buffer handler))
(if (buffer-name buf)
(progn
(set-buffer buf)
(setq w3m-process-modeline-string str))
(w3m-process-kill-stray-processes)))))))))))))
(defun w3m-process-modeline-format (str)
(ignore-errors
(cond
((stringp w3m-process-modeline-format)
(format w3m-process-modeline-format
(if (string-match "/0\\([a-zA-Z]?b\\)\\'" str)
(replace-match "\\1" t nil str)
str)))
((functionp w3m-process-modeline-format)
(funcall w3m-process-modeline-format str)))))
;; w3m-process-authinfo-alist has an association list as below format.
;; (("root1" ("realm11" ("user11" . "pass11")
;; ("user12" . "pass12"))
;; ("realm12" ("user13" . "pass13")))
;; ("root2" ("realm21" ("user21" . "pass21"))))
(defun w3m-process-set-authinfo (url realm username password)
(let (x y z (root (w3m-get-server-hostname url)))
(if (setq x (assoc root w3m-process-authinfo-alist))
(if (setq y (assoc realm x))
(if (setq z (assoc username y))
;; Change a password only.
(setcdr z password)
;; Add a pair of a username and a password.
(setcdr y (cons (cons username password) (cdr y))))
;; Add a 3-tuple of a realm, a username and a password.
(setcdr x (cons (cons realm (list (cons username password)))
(cdr x))))
;; Add a 4-tuple of a server root, a realm, a username and a password.
(push (cons root (list (cons realm (list (cons username password)))))
w3m-process-authinfo-alist))))
(defun w3m-process-read-user (url &optional realm ignore-history)
"Read a user name for URL and REALM."
(let* ((root (when (stringp url) (w3m-get-server-hostname url)))
(ident (or realm root))
(alist))
(if (and (not ignore-history)
(setq alist
(cdr (assoc realm
(cdr (assoc root
w3m-process-authinfo-alist))))))
(if (= 1 (length alist))
(caar alist)
(completing-read (if ident
(format "Select username for %s: " ident)
"Select username: ")
(mapcar (lambda (x) (cons (car x) (car x))) alist)
nil t))
(read-from-minibuffer (if ident
(format "Username for %s: " ident)
"Username: ")))))
(defun w3m-process-read-passwd (url &optional realm username ignore-history)
"Read a password for URL, REALM, and USERNAME."
(let* ((root (when (stringp url) (w3m-get-server-hostname url)))
(ident (or realm root))
(pass (cdr (assoc username
(cdr (assoc realm
(cdr (assoc root
w3m-process-authinfo-alist))))))))
(if (and pass (not ignore-history))
pass
(read-passwd (format (if ident
(format "Password for %s%%s: " ident)
"Password%s: ")
(if (and (stringp pass)
(> (length pass) 0)
(not (featurep 'xemacs)))
(concat " (default "
(make-string (length pass) ?\*)
")")
""))
nil pass))))
(defun w3m-process-y-or-n-p (url prompt)
"Ask user a \"y or n\" question. Return t if answer is \"y\".
NOTE: This function is designed to avoid annoying questions. So when
the same questions is reasked, its previous answer is reused without
prompt."
(let ((root (w3m-get-server-hostname url))
(map (copy-keymap query-replace-map))
elem answer)
;; ignore [space] to avoid answering y without intention.
(define-key map " " 'ignore)
(let ((query-replace-map map))
(if (setq elem (assoc root w3m-process-accept-alist))
(if (member prompt (cdr elem))
;; When the same question has been asked, the previous
;; answer is reused.
(setq answer t)
;; When any question for the same server has been asked,
;; regist the pair of this question and its answer to
;; `w3m-process-accept-alist'.
(when (setq answer (y-or-n-p prompt))
(setcdr elem (cons prompt (cdr elem)))))
;; When no question for the same server has been asked, regist
;; the 3-tuple of the server, the question and its answer to
;; `w3m-process-accept-alist'.
(when (setq answer (y-or-n-p prompt))
(push (cons root (list prompt)) w3m-process-accept-alist)))
answer)))
;; Silence the byte compiler complaining against `gensym' like:
;; "Warning: the function `gensym' might not be defined at runtime."
(eval-when-compile
(and (boundp 'byte-compile-unresolved-functions)
(fboundp 'gensym)
(symbol-file 'gensym)
(string-match "/cl-macs\\.el[^/]*\\'" (symbol-file 'gensym))
(condition-case nil
(setq byte-compile-unresolved-functions
(delq (assq 'gensym byte-compile-unresolved-functions)
byte-compile-unresolved-functions))
(error))))
(provide 'w3m-proc)
;;; w3m-proc.el ends here

169
share/emacs/site-lisp/w3m/w3m-rss.el Normal file
View file

@ -0,0 +1,169 @@
;;; w3m-rss.el --- RSS functions
;; Copyright (C) 2004, 2005 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; w3m-rss.el provides RSS-related functions for emacs-w3m. For more
;; detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; Acknowledgment:
;; I refered functions in `sb-rss.el' to implement this module.
;; Thanks to Koichiro Ohba and NAKAJIMA Mikio.
;;; Code:
(eval-when-compile (require 'cl))
(autoload 'xml-parse-region "xml")
(eval-and-compile
(autoload 'timezone-parse-date "timezone")
(autoload 'timezone-parse-time "timezone"))
(eval-when-compile
;; Avoid warning for Emacs 19 and XEmacs.
(unless (fboundp 'match-string-no-properties)
(autoload 'match-string-no-properties "poe"))
;; Avoid warning for Emacs 19.
(unless (fboundp 'split-string)
(autoload 'split-string "poe")))
(defun w3m-rss-parse-date-string (date)
"Decode DATE string written in the ISO 8601 format or the RFC822 style.
Return a list of numbers which conforms to the Emacs internal format.
Valid types in the ISO 8601 format include:
Year:
YYYY (eg 1997)
Year and month:
YYYY-MM (eg 1997-07)
Complete date:
YYYY-MM-DD (eg 1997-07-16)
Complete date plus hours and minutes:
YYYY-MM-DDThh:mmTZD (eg 1997-07-16T19:20+01:00)
Complete date plus hours, minutes and seconds:
YYYY-MM-DDThh:mm:ssTZD (eg 1997-07-16T19:20:30+01:00)
Complete date plus hours, minutes, seconds and a decimal fraction
of a second
YYYY-MM-DDThh:mm:ss.sTZD (eg 1997-07-16T19:20:30.45+01:00)
where:
YYYY = four-digit year
MM = two-digit month (01=January, etc.)
DD = two-digit day of month (01 through 31)
hh = two digits of hour (00 through 23) (am/pm NOT allowed)
mm = two digits of minute (00 through 59)
ss = two digits of second (00 through 59)
s = one or more digits representing a decimal fraction of a second
TZD = time zone designator (Z or +hh:mm or -hh:mm)
For more detail about ISO 8601 date format, see
<URL:http://www.w3.org/TR/NOTE-datetime>.
In addition to the above, it also supports the date format in the
RFC822 style which RSS 2.0 allows. Valid types are the same as ones
which are supported by the `timezone-parse-date' function (which see)."
(cond ((not date) nil)
((string-match " [0-9]+ " date)
(let* ((vector (timezone-parse-date date))
(year (string-to-number (aref vector 0)))
time)
(when (>= year 1970)
(setq time (timezone-parse-time (aref vector 3)))
(encode-time
(string-to-number (aref time 2))
(string-to-number (aref time 1))
(string-to-number (aref time 0))
(string-to-number (aref vector 2))
(string-to-number (aref vector 1))
year
(aref vector 4)))))
((string-match "\
\\([0-9][0-9][0-9][0-9]\\)\\(?:-\\([0-9][0-9]\\)\\)?\\(?:-\\([0-9][0-9]\\)\\)?\
T?\\(?:\\([0-9][0-9]\\):\\([0-9][0-9]\\)\\(?::\\([.0-9]+\\)\\)?\\)?\
\\(?:\\([-+]\\)\\([0-9][0-9]\\):?\\([0-9][0-9]\\)\\|Z\\)?"
date)
(labels ((substr (n default)
(if (match-beginning n)
(string-to-number
(match-string-no-properties n date))
default)))
(encode-time
(substr 6 0) ;; seconds
(substr 5 0) ;; minitue
(substr 4 0) ;; hour
(substr 3 1) ;; day
(substr 2 1) ;; month
(substr 1 0) ;; year
(if (match-beginning 7)
(funcall (intern (match-string-no-properties 7 date))
0
(* 3600 (substr 8 0))
(* 60 (substr 9 0)))
0))))))
(defun w3m-rss-find-el (tag data)
"Find the all matching elements in the data. Careful with this on
large documents!"
(let (found)
(when (listp data)
(dolist (bit data)
(when (car-safe bit)
(when (equal tag (car bit))
(setq found (nconc found (list bit))))
(setq found
(nconc found
(w3m-rss-find-el
tag
(if (and (listp (car-safe (caddr bit)))
(not (stringp (caddr bit))))
(caddr bit)
(cddr bit))))))))
found))
(defun w3m-rss-get-namespace-prefix (el uri)
"Given EL (containing a parsed element) and URI (containing a string
that gives the URI for which you want to retrieve the namespace
prefix), return the prefix.
See http://feeds.archive.org/validator/docs/howto/declare_namespaces.html
for more RSS namespaces."
(let* ((prefix (car (rassoc uri (cadar el))))
(nslist (when prefix
(split-string (symbol-name prefix) ":")))
(ns (cond ((eq (length nslist) 1) ; no prefix given
"")
((eq (length nslist) 2) ; extract prefix
(cadr nslist)))))
(if (and ns (not (equal ns "")))
(concat ns ":")
ns)))
(provide 'w3m-rss)
;;; w3m-rss.el ends here

365
share/emacs/site-lisp/w3m/w3m-search.el Normal file
View file

@ -0,0 +1,365 @@
;;; w3m-search.el --- functions convenient to access web search engines
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: Keisuke Nishida <kxn30@po.cwru.edu>,
;; Shun-ichi GOTO <gotoh@taiyo.co.jp>,
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>,
;; Romain FRANCOISE <romain@orebokech.com>
;; 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This module contains the `w3m-search' command and some utilities
;; to improve your cyberlife. For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; Code:
(eval-when-compile
(require 'cl))
(require 'w3m)
(defcustom w3m-search-engine-alist
(let* ((ja (equal "Japanese" w3m-language))
(utf-8 (or (and (boundp 'mule-version)
(not (string< (symbol-value 'mule-version) "6.0")))
(featurep 'un-define)
(fboundp 'utf-translate-cjk-mode)
(and (not ja) (w3m-find-coding-system 'utf-8)))))
`(,@(if ja
'(("yahoo"
"http://search.yahoo.co.jp/bin/search?p=%s"
euc-japan)
("yahoo-en"
"http://search.yahoo.com/bin/search?p=%s"))
'(("yahoo"
"http://search.yahoo.com/bin/search?p=%s")
("yahoo-ja"
"http://search.yahoo.co.jp/bin/search?p=%s"
euc-japan)))
("alc" "http://eow.alc.co.jp/%s/UTF-8/" utf-8)
,@(cond
((and ja utf-8)
'(("blog"
"http://blogsearch.google.com/blogsearch?q=%s&hl=ja&lr=lang_ja&oe=utf-8&ie=utf-8"
utf-8)
("blog-en"
"http://blogsearch.google.com/blogsearch?q=%s&hl=en&oe=utf-8&ie=utf-8"
utf-8)))
(ja
'(("blog"
"http://blogsearch.google.com/blogsearch?q=%s&hl=ja&lr=lang_ja&ie=Shift_JIS&oe=Shift_JIS"
shift_jis)
("blog-en"
"http://blogsearch.google.com/blogsearch?q=%s&hl=en")))
(utf-8
'(("blog"
"http://blogsearch.google.com/blogsearch?q=%s&oe=utf-8&ie=utf-8"
utf-8)
("blog-en"
"http://blogsearch.google.com/blogsearch?q=%s&hl=en&oe=utf-8&ie=utf-8"
utf-8)))
(t
'(("blog"
"http://blogsearch.google.com/blogsearch?q=%s")
("blog-ja"
"http://blogsearch.google.com/blogsearch?q=%s&lr=lang_ja&ie=Shift_JIS&oe=Shift_JIS"
shift_jis))))
,@(cond
((and ja utf-8)
'(("google"
"http://www.google.com/search?q=%s&hl=ja&lr=lang_ja&ie=utf-8&oe=utf-8"
utf-8)
("google-en"
"http://www.google.com/search?q=%s&hl=en&ie=utf-8&oe=utf-8"
utf-8)))
(ja
'(("google"
"http://www.google.com/search?q=%s&hl=ja&lr=lang_ja&ie=Shift_JIS&oe=Shift_JIS"
shift_jis)
("google-en"
"http://www.google.com/search?q=%s&hl=en")))
(utf-8
'(("google"
"http://www.google.com/search?q=%s&ie=utf-8&oe=utf-8"
utf-8)
("google-en"
"http://www.google.com/search?q=%s&hl=en&ie=utf-8&oe=utf-8"
utf-8)))
(t
'(("google"
"http://www.google.com/search?q=%s")
("google-ja"
"http://www.google.com/search?q=%s&hl=ja&lr=lang_ja&ie=Shift_JIS&oe=Shift_JIS"
shift_jis))))
,@(cond
((and ja utf-8)
'(("google news"
"http://news.google.co.jp/news?hl=ja&ie=utf-8&q=%s&oe=utf-8"
utf-8)
("google news-en"
"http://news.google.com/news?hl=en&q=%s")))
(ja
'(("google news"
"http://news.google.co.jp/news?hl=ja&ie=Shift_JIS&q=%s&oe=Shift_JIS"
shift_jis)
("google news-en"
"http://news.google.com/news?hl=en&q=%s")))
(utf-8
'(("google news"
"http://news.google.co.jp/news?hl=ja&ie=utf-8&q=%s&oe=utf-8"
utf-8)
("google news-en"
"http://news.google.com/news?hl=en&q=%s")))
(t
'(("google news"
"http://news.google.com/news?q=%s")
("google news-ja"
"http://news.google.co.jp/news?hl=ja&ie=Shift_JIS&q=%s&oe=Shift_JIS"
shift_jis))))
("google groups"
"http://groups.google.com/groups?q=%s")
,@(if ja
'(("All the Web"
"http://www.alltheweb.com/search?web&_sb_lang=ja&cs=euc-jp\
&q=%s"
euc-japan)
("All the Web-en"
"http://www.alltheweb.com/search?web&_sb_lang=en&q=%s"))
'(("All the Web"
"http://www.alltheweb.com/search?web&_sb_lang=en&q=%s")
("All the Web-ja"
"http://www.alltheweb.com/search?web&_sb_lang=ja&cs=euc-jp&q=%s"
euc-japan)))
,@(if ja
'(("technorati"
"http://www.technorati.jp/search/search.html?query=%s&language=ja"
utf-8)
("technorati-en"
"http://www.technorati.com/search/%s"
utf-8))
'(("technorati"
"http://www.technorati.com/search/%s"
utf-8)
("technorati-ja"
"http://www.technorati.jp/search/search.html?query=%s&language=ja"
utf-8)))
("technorati-tag"
"http://www.technorati.com/tag/%s"
utf-8)
("goo-ja"
"http://search.goo.ne.jp/web.jsp?MT=%s"
euc-japan)
("excite-ja"
"http://www.excite.co.jp/search.gw?target=combined&look=excite_jp\
&lang=jp&tsug=-1&csug=-1&search=%s"
shift_jis)
("altavista"
"http://altavista.com/sites/search/web?q=\"%s\"&kl=ja&search=Search")
("rpmfind"
"http://rpmfind.net/linux/rpm2html/search.php?query=%s"
nil)
("debian-pkg"
"http://packages.debian.org/cgi-bin/search_contents.pl\
?directories=yes&arch=i386&version=unstable&case=insensitive&word=%s")
("debian-bts"
"http://bugs.debian.org/cgi-bin/pkgreport.cgi?archive=yes&pkg=%s")
("freebsd-users-jp"
"http://home.jp.FreeBSD.org/cgi-bin/namazu.cgi?key=\"%s\"&whence=0\
&max=50&format=long&sort=score&dbname=FreeBSD-users-jp"
euc-japan)
("iij-archie"
"http://www.iij.ad.jp/cgi-bin/archieplexform?query=%s\
&type=Case+Insensitive+Substring+Match&order=host&server=archie1.iij.ad.jp\
&hits=95&nice=Nice")
("waei"
"http://dictionary.goo.ne.jp/search.php?MT=%s&kind=je"
euc-japan)
("eiwa"
"http://dictionary.goo.ne.jp/search.php?MT=%s&kind=ej")
("kokugo"
"http://dictionary.goo.ne.jp/search.php?MT=%s&kind=jn"
euc-japan)
("eiei"
"http://www.dictionary.com/cgi-bin/dict.pl?term=%s&r=67")
,@(if ja
'(("amazon"
"http://www.amazon.co.jp/gp/search?\
__mk_ja_JP=%%83J%%83%%5E%%83J%%83i&url=search-alias%%3Daps&field-keywords=%s"
shift_jis)
("amazon-en"
"http://www.amazon.com/exec/obidos/search-handle-form/\
250-7496892-7797857"
iso-8859-1
"url=index=blended&field-keywords=%s"))
'(("amazon"
"http://www.amazon.com/exec/obidos/search-handle-form/\
250-7496892-7797857"
iso-8859-1
"url=index=blended&field-keywords=%s")
("amazon-ja"
"http://www.amazon.co.jp/gp/search?\
__mk_ja_JP=%%83J%%83%%5E%%83J%%83i&url=search-alias%%3Daps&field-keywords=%s"
shift_jis)))
("emacswiki" "http://www.emacswiki.org/cgi-bin/wiki?search=%s")
("en.wikipedia" "http://en.wikipedia.org/wiki/Special:Search?search=%s")
("de.wikipedia" "http://de.wikipedia.org/wiki/Spezial:Search?search=%s"
utf-8)
("ja.wikipedia" "http://ja.wikipedia.org/wiki/Special:Search?search=%s"
utf-8)
("msdn" "http://search.msdn.microsoft.com/search/default.aspx?query=%s")
("freshmeat" "http://freshmeat.net/search/?q=%s&section=projects")))
"*An alist of search engines.
Each element looks like (ENGINE ACTION CODING POST-DATA)
ENGINE is a string, the name of the search engine.
ACTION is a string, the URL that performs a search.
ACTION must contain a \"%s\", which is substituted by a query string.
CODING is optional value which is coding system for query string.
POST-DATA is optional value which is a string for POST method search engine.
If CODING is omitted, it defaults to `w3m-default-coding-system'."
:group 'w3m
:type `(repeat
(group :indent 2
(string :format "Engine: %v\n" :size 0)
(string :format " Action: %v\n" :size 0)
(coding-system :format "%t: %v\n" :size 0)
(checklist :inline t
:entry-format ,(if (w3m-device-on-window-system-p)
"%b %v"
"%b %v")
(string :format "PostData: %v\n" :size 0)))))
(defcustom w3m-search-default-engine "google"
"*Name of the default search engine.
See also `w3m-search-engine-alist'."
:group 'w3m
:type '(string :size 0))
(defcustom w3m-search-word-at-point t
"*Non-nil means that the word at point is used as an initial string.
If Transient Mark mode, this option is ignored and the region is used
as an initial string."
:group 'w3m
:type 'boolean)
(defvar w3m-search-engine-history nil
"History variable used by `w3m-search' for prompting a search engine.")
(defvar w3m-search-thing-at-point-arg 'word
"Argument for `thing-at-point' used in `w3m-search-read-query'")
(defun w3m-search-escape-query-string (str &optional coding)
(mapconcat
(lambda (s)
(w3m-url-encode-string s (or coding w3m-default-coding-system)))
(split-string str)
"+"))
(defun w3m-search-read-query (prompt prompt-with-default &optional history)
"Read a query from the minibuffer, prompting with string PROMPT.
When a default value for the query is discovered, prompt with string
PROMPT-WITH-DEFAULT instead of string PROMPT."
(let ((default
(if (w3m-region-active-p)
(buffer-substring (region-beginning) (region-end))
(unless (and (eq major-mode 'w3m-mode)
(listp (get-text-property (point-at-bol) 'face))
(memq 'w3m-header-line-location-title
(get-text-property (point-at-bol) 'face)))
(thing-at-point w3m-search-thing-at-point-arg))))
initial)
(when default
(set-text-properties 0 (length default) nil default)
(when (or w3m-search-word-at-point (w3m-region-active-p))
(setq initial default
default nil))
(when (w3m-region-active-p)
(w3m-deactivate-region)))
(read-string (if default
(format prompt-with-default default)
prompt)
initial history default)))
(defun w3m-search-read-variables ()
"Ask for a search engine and words to query and return them as a list."
(let* ((search-engine
(if current-prefix-arg
(let ((default (or (car w3m-search-engine-history)
w3m-search-default-engine))
(completion-ignore-case t))
(completing-read (format "Which engine? (default %s): "
default)
w3m-search-engine-alist nil t nil
'w3m-search-engine-history default))
w3m-search-default-engine))
(query
(w3m-search-read-query
(format "%s search: " search-engine)
(format "%s search (default %%s): " search-engine))))
(list search-engine query)))
(defun w3m-search-do-search (w3m-goto-function search-engine query)
"Call W3M-GOTO-FUNCTION with the URL for the search."
(unless (string= query "")
(let ((info (assoc search-engine w3m-search-engine-alist)))
(if info
(let ((query-string (w3m-search-escape-query-string query
(caddr info)))
(post-data (cadddr info)))
(funcall w3m-goto-function
(format (cadr info) query-string)
post-data
nil
(and post-data (format post-data query-string))))
(error "Unknown search engine: %s" search-engine)))))
;;;###autoload
(defun w3m-search (search-engine query)
"Search QUERY using SEARCH-ENGINE.
When called interactively with a prefix argument, you can choose one of
the search engines defined in `w3m-search-engine-alist'. Otherwise use
`w3m-search-default-engine'.
If Transient Mark mode, use the region as an initial string of query
and deactivate the mark."
(interactive (w3m-search-read-variables))
(w3m-search-do-search 'w3m-goto-url search-engine query))
;;;###autoload
(defun w3m-search-new-session (search-engine query)
"Like `w3m-search', but do the search in a new session."
(interactive (w3m-search-read-variables))
(w3m-search-do-search 'w3m-goto-url-new-session search-engine query))
;;;###autoload
(defun w3m-search-uri-replace (uri engine)
"Generate query string for ENGINE from URI matched by last search."
(let ((query (substring uri (match-end 0)))
(info (assoc engine w3m-search-engine-alist)))
(when info
(format (cadr info)
(w3m-search-escape-query-string query (caddr info))))))
(provide 'w3m-search)
;;; w3m-search.el ends here

909
share/emacs/site-lisp/w3m/w3m-session.el Normal file
View file

@ -0,0 +1,909 @@
;;; w3m-session.el --- Functions to operate session of w3m -*- coding: iso-2022-7bit; -*-
;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Author: Hideyuki SHIRAI <shirai@meadowy.org>
;; Keywords: w3m, WWW, hypermedia
;; 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; w3m-session.el is the add-on program of emacs-w3m to save and load
;; sessions. For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; Code:
(eval-when-compile (require 'cl))
(require 'w3m-util)
(eval-when-compile
(defvar w3m-async-exec)
(defvar w3m-async-exec-with-many-urls)
(defvar w3m-current-title)
(defvar w3m-current-url)
(defvar w3m-history)
(defvar w3m-history-flat)
(defvar w3m-language)
(defvar w3m-mode-map)
(defvar w3m-profile-directory)
(autoload 'w3m-goto-url-new-session "w3m")
(autoload 'w3m-history-tree "w3m-hist")
(autoload 'w3m-load-list "w3m")
(autoload 'w3m-save-list "w3m"))
(defcustom w3m-session-file
(expand-file-name ".sessions" w3m-profile-directory)
"*File name to keep sessions."
:group 'w3m
:type '(file :size 0))
(defcustom w3m-session-autosave t
"*Non-nil means save automatically when w3m quit."
:group 'w3m
:type 'boolean)
(defcustom w3m-session-deleted-save t
"*Non-nil means save deleted sessions."
:group 'w3m
:type 'boolean)
(defcustom w3m-session-crash-recovery t
"*Non-nil means emacs-w3m save session set automatically, and recover it when emacs-w3m crash."
:group 'w3m
:type 'boolean)
(defcustom w3m-session-time-format
(if (and (equal "Japanese" w3m-language)
(not (featurep 'xemacs)))
"%Y$BG/(B%m$B7n(B%d$BF|(B(%a) %H:%M"
"%Y-%m-%d (%a) %H:%M")
"*Format of saved time."
:group 'w3m
:type '(string :size 0))
(defcustom w3m-session-automatic-title
(if (equal "Japanese" w3m-language)
"$B<+F0J]B8(B"
"Automatic saved sessions")
"*String of title to save session automatically."
:group 'w3m
:type '(string :size 0))
(defcustom w3m-session-deleted-title
(if (equal "Japanese" w3m-language)
"$B:o=|%;%C%7%g%s(B"
"Removed sessions")
"*String of title to save session when buffer delete."
:group 'w3m
:type '(string :size 0))
(defcustom w3m-session-crash-recovery-title
(if (equal "Japanese" w3m-language)
"$B%/%i%C%7%e2sI|(B"
"Crash recovery sessions")
"*String of title to save session to use for crash recovering."
:group 'w3m
:type '(string :size 0))
(defcustom w3m-session-deleted-keep-number 5
"*Number to keep sessions when buffers delete."
:group 'w3m
:type '(integer :size 0))
(defcustom w3m-session-automatic-keep-number 5
"*Number to keep sessions automatically."
:group 'w3m
:type '(integer :size 0))
(defcustom w3m-session-unknown-title "<Unknown Title>"
"*String of title to use when title is not specified."
:group 'w3m
:type '(string :size 0))
(defcustom w3m-session-load-last-sessions nil
"*Whether to load the last sessions when emacs-w3m starts."
:group 'w3m
:type '(radio (const :format "Load the last sessions automatically." t)
(const :format "Ask whether to load the last sessions." ask)
(const :format "Never load the last sessions automatically." nil)))
(defcustom w3m-session-load-crashed-sessions 'ask
"*Whether to load the crashed sessions when emacs-w3m starts."
:group 'w3m
:type '(radio (const :format "Load the crashed sessions automatically." t)
(const :format "Ask whether to load the crashed sessions." ask)
(const :format "Never load the crashed sessions automatically." nil)))
(defface w3m-session-select
`((((class color) (background light) (type tty))
(:foreground "black"))
(((class color) (background dark) (type tty))
(:foreground "cyan"))
(((class color) (background light))
(:foreground "dark blue"))
(((class color) (background dark))
(:foreground "white"))
(t nil))
"Face of w3m-session."
:group 'w3m)
;; backward-compatibility alias
(put 'w3m-session-select-face 'face-alias 'w3m-session-select)
(defface w3m-session-selected
`((((class color) (background light) (type tty))
(:foreground "blue" :bold t :underline t))
(((class color) (background dark) (type tty))
(:foreground "cyan" :bold t :underline t))
(((class color) (background light))
(:foreground "dark blue" :bold t :underline t))
(((class color) (background dark))
(:foreground "white" :bold t :underline t))
(t (:bold t :underline t)))
"Face of selected w3m-session."
:group 'w3m)
;; backward-compatibility alias
(put 'w3m-session-selected-face 'face-alias 'w3m-session-selected)
(defun w3m-session-history-to-save ()
"Return a copy of `w3m-history-flat' without current page data."
(let ((pos (cadar w3m-history)))
(apply
'append
(mapcar (lambda (x)
(unless (equal (nth 2 x) pos)
(list x)))
(copy-sequence (w3m-history-slimmed-history-flat))))))
;; format of sessin file.
;; '((sessiontitle1 time1 ((url11 pos11 hflat11 urltitle11)
;; (url12 pos12 hflat12 urltitle12) ...) current1)
;; ...
(defmacro w3m-session-ignore-errors (&rest forms)
"Run FORMS. Remove `w3m-session-file' and quit if any error happens."
`(condition-case err
(progn ,@forms)
(error
(if (and (file-exists-p w3m-session-file)
(yes-or-no-p (format
"\
Sorry, an error found in \"%s\"; may we remove it? "
,(if (featurep 'xemacs)
'(abbreviate-file-name w3m-session-file t)
'(abbreviate-file-name w3m-session-file)))))
(progn
(delete-file w3m-session-file)
(run-at-time 0.1 nil #'message
"\"%s\" has been removed; try again"
(abbreviate-file-name w3m-session-file))
(keyboard-quit))
(signal (car err) (cdr err))))))
;;;###autoload
(defun w3m-session-save ()
"Save list of displayed session."
(interactive)
(w3m-session-ignore-errors
(let ((sessions (w3m-load-list w3m-session-file))
(bufs (w3m-list-buffers))
(prompt "New session title: ")
(cnum 0)
(i 0)
title titles urls len buf cbuf)
(mapc (lambda (x)
(setq titles (cons (cons (car x) (car x)) titles)))
sessions)
(setq title (or w3m-current-title
(with-current-buffer (car bufs)
w3m-current-title)))
(setq titles (cons (cons title title) titles))
(catch 'loop
(while t
(setq title (completing-read prompt titles nil nil title))
(if (or (string= title "")
(and (assoc title sessions)
(not (y-or-n-p (format "\"%s\" is exist. Overwrite? "
title)))))
(setq prompt "Again New session title: ")
(throw 'loop t))))
(setq cbuf (current-buffer))
(save-current-buffer
(while (setq buf (car bufs))
(setq bufs (cdr bufs))
(set-buffer buf)
(when w3m-current-url
(when (eq cbuf (current-buffer))
(setq cnum i))
(setq i (1+ i))
(setq urls (cons (list w3m-current-url
(copy-sequence (caar w3m-history))
(w3m-session-history-to-save)
w3m-current-title)
urls)))))
(if (not urls)
(message "%s: no session save...done" title)
(setq len (length urls))
(setq urls (nreverse urls))
(when (assoc title sessions)
(setq sessions (delete (assoc title sessions) sessions)))
(setq sessions (cons (list title (current-time) urls cnum) sessions))
(w3m-save-list w3m-session-file sessions)
(if (= len 1)
(message "%s: 1 session save...done" title)
(message "%s: %d sessions save...done" title len))))))
(defun w3m-session-automatic-save ()
"Save list of displayed session automatically."
(when w3m-session-autosave
(w3m-session-ignore-errors
(let ((sessions (w3m-load-list w3m-session-file))
(bufs (w3m-list-buffers))
(title (concat w3m-session-automatic-title "-1"))
(titleregex (concat "^"
(regexp-quote w3m-session-automatic-title)
"-[0-9]+$"))
(cnum 0)
(i 0)
urls buf cbuf session
tmp tmptitle tmptime tmpurls)
(when bufs
(setq cbuf (current-buffer))
(save-current-buffer
(while (setq buf (car bufs))
(setq bufs (cdr bufs))
(set-buffer buf)
(when w3m-current-url
(when (eq cbuf (current-buffer))
(setq cnum i))
(setq i (1+ i))
(setq urls (cons (list w3m-current-url
(copy-sequence (caar w3m-history))
(w3m-session-history-to-save)
w3m-current-title)
urls)))))
(when urls
(setq i 2)
(while (setq session (car sessions))
(setq sessions (cdr sessions))
(if (string-match titleregex (nth 0 session))
(when (<= i w3m-session-automatic-keep-number)
(setq tmptitle (format (concat w3m-session-automatic-title
"-%d") i))
(setq tmptime (nth 1 session))
(setq tmpurls (nth 2 session))
(setq tmp (cons (list tmptitle tmptime tmpurls nil) tmp))
(setq i (1+ i)))
(setq tmp (cons session tmp))))
(setq sessions (nreverse tmp))
(setq urls (nreverse urls))
(setq sessions (cons (list title (current-time) urls cnum)
sessions))
(w3m-save-list w3m-session-file sessions)))))))
(defun w3m-session-deleted-save (buffers)
"Save list of deleted session."
(when w3m-session-deleted-save
(w3m-session-ignore-errors
(let ((sessions (w3m-load-list w3m-session-file))
(title (concat w3m-session-deleted-title "-1"))
(titleregex (concat "^"
(regexp-quote w3m-session-deleted-title)
"-[0-9]+$"))
(bufs (copy-sequence buffers))
(i 2)
urls buf session
tmp tmptitle tmptime tmpurls)
(when bufs
(setq bufs (sort bufs 'w3m-buffer-name-lessp))
(save-current-buffer
(while (setq buf (car bufs))
(setq bufs (cdr bufs))
(set-buffer buf)
(when w3m-current-url
(setq urls (cons (list w3m-current-url
(copy-sequence (caar w3m-history))
(w3m-session-history-to-save)
w3m-current-title)
urls)))))
(when urls
(while (setq session (car sessions))
(setq sessions (cdr sessions))
(if (string-match titleregex (nth 0 session))
(when (<= i w3m-session-deleted-keep-number)
(setq tmptitle (format (concat w3m-session-deleted-title
"-%d") i))
(setq tmptime (nth 1 session))
(setq tmpurls (nth 2 session))
(setq tmp (cons (list tmptitle tmptime tmpurls nil) tmp))
(setq i (1+ i)))
(setq tmp (cons session tmp))))
(setq sessions (nreverse tmp))
(setq urls (nreverse urls))
(setq sessions (cons (list title (current-time) urls nil) sessions))
(w3m-save-list w3m-session-file sessions)))))))
(defun w3m-session-crash-recovery-save ()
"Save list of displayed session."
(when w3m-session-crash-recovery
(w3m-session-ignore-errors
(let ((sessions (w3m-load-list w3m-session-file))
(bufs (w3m-list-buffers))
(title w3m-session-crash-recovery-title)
urls buf tmp)
(when bufs
(save-current-buffer
(while (setq buf (car bufs))
(setq bufs (cdr bufs))
(set-buffer buf)
(when w3m-current-url
(setq urls (cons (list w3m-current-url
(copy-sequence (caar w3m-history))
(w3m-session-history-to-save)
w3m-current-title)
urls)))))
(when urls
(setq urls (nreverse urls))
(setq tmp (assoc title sessions))
(when tmp (setq sessions (delete tmp sessions)))
(setq sessions (cons (list title (current-time) urls nil) sessions))
(w3m-save-list w3m-session-file sessions)))))))
(defun w3m-session-crash-recovery-remove ()
"Remove crash recovery session set."
(when w3m-session-crash-recovery
(w3m-session-ignore-errors
(let* ((sessions (w3m-load-list w3m-session-file))
(item (assoc w3m-session-crash-recovery-title sessions)))
(when item
(setq sessions (delete item sessions))
(w3m-save-list w3m-session-file sessions))))))
(defvar w3m-session-select-mode-map nil)
(unless w3m-session-select-mode-map
(let ((map (make-keymap)))
(suppress-keymap map)
(define-key map "q" 'w3m-session-select-quit)
(define-key map "Q" 'w3m-session-select-quit)
(define-key map "\C-g" 'w3m-session-select-quit)
(define-key map "\C-m" 'w3m-session-select-select)
(define-key map "\M-s" 'w3m-session-select-open-session-group)
(define-key map "d" 'w3m-session-select-delete)
(define-key map "D" 'w3m-session-select-delete)
(define-key map "s" 'w3m-session-select-save)
(define-key map "S" 'w3m-session-select-save)
(define-key map "r" 'w3m-session-select-rename)
(define-key map "R" 'w3m-session-select-rename)
(define-key map "n" 'w3m-session-select-next)
(define-key map "j" 'w3m-session-select-next)
(define-key map "\C-n" 'w3m-session-select-next)
(define-key map [down] 'w3m-session-select-next)
(define-key map "p" 'w3m-session-select-previous)
(define-key map "k" 'w3m-session-select-previous)
(define-key map "\C-p" 'w3m-session-select-previous)
(define-key map [up] 'w3m-session-select-previous)
(setq w3m-session-select-mode-map map)))
;;; Local variables
(defvar w3m-session-select-wincfg nil)
(defvar w3m-session-select-sessions nil)
(make-variable-buffer-local 'w3m-session-select-wincfg)
(make-variable-buffer-local 'w3m-session-select-sessions)
(defun w3m-session-select-mode (&optional sessions)
"Major mode for selecting emacs-w3m session.
\\<w3m-session-select-mode-map>
\\[w3m-session-select-select] Select the session.
\\[w3m-session-select-open-session-group] Open the session group.
\\[w3m-session-select-delete] Delete the session.
\\[w3m-session-select-rename] Rename the session.
\\[w3m-session-select-save] Save the session.
\\[w3m-session-select-next] Move the point to the next session.
\\[w3m-session-select-previous] Move the point to the previous session.
\\[w3m-session-select-quit] Exit selecting session.
"
(w3m-session-ignore-errors
(let ((sessions (or sessions
(w3m-load-list w3m-session-file))))
(buffer-disable-undo)
(setq mode-name "w3m session"
truncate-lines t
buffer-read-only nil
major-mode 'w3m-session-select-mode
w3m-session-select-sessions sessions
buffer-read-only t)
(use-local-map w3m-session-select-mode-map)
(w3m-session-select-list-all-sessions))))
(defun w3m-session-select-list-all-sessions ()
"List up all saved sessions."
(let* ((sessions w3m-session-select-sessions)
(num 0)
(max 0)
(buffer-read-only nil)
title titles time times url urls wid pos)
(if (not sessions)
(progn
(message "No saved session")
(w3m-session-select-quit))
(mapc (lambda (x)
(setq title (format "%s[%d]" (nth 0 x) (length (nth 2 x))))
(setq wid (string-width title))
(when (> wid max)
(setq max wid))
(setq titles (cons title titles))
(setq times (cons (format-time-string w3m-session-time-format
(nth 1 x))
times))
(setq urls (cons (mapconcat (lambda (url)
(if (stringp url)
url
(car url)))
(nth 2 x) ", ")
urls)))
sessions)
(setq titles (nreverse titles))
(setq times (nreverse times))
(setq urls (nreverse urls))
(setq max (+ max 2))
(erase-buffer)
(insert "Select session:\n\n")
(while (and (setq title (car titles))
(setq time (car times))
(setq url (car urls)))
(setq titles (cdr titles))
(setq times (cdr times))
(setq urls (cdr urls))
(setq pos (point))
(insert title)
(add-text-properties pos (point)
`(face w3m-session-select
w3m-session-number ,num))
(setq num (1+ num))
(insert (make-string (- max (string-width title)) ?\ ))
(insert time " " url "\n"))
(goto-char (point-min))
(goto-char (next-single-property-change
(point) 'w3m-session-number))
(put-text-property (point)
(next-single-property-change
(point) 'w3m-session-number)
'face 'w3m-session-selected)
(set-buffer-modified-p nil)
(setq buffer-read-only t))))
(defun w3m-session-select-list-session-group (arg)
(let ((session (nth 2 (nth arg w3m-session-select-sessions)))
(num 0)
(max 0)
(buffer-read-only nil)
title url wid
titles urls pos)
(when session
(mapc (lambda (x)
(setq title (format "%s" (or (nth 3 x) w3m-session-unknown-title)))
(setq wid (string-width title))
(when (> wid max)
(setq max wid))
(setq titles (cons title titles))
(setq urls (cons (nth 0 x)
urls)))
session)
(setq titles (nreverse titles))
(setq urls (nreverse urls))
(setq max (+ max 2))
(erase-buffer)
(insert "Select session:\n\n")
(setq pos (point))
(insert "Open all sessions")
(add-text-properties pos (point)
`(face w3m-session-selected
w3m-session-number ,arg))
(insert "\n")
(while (and (setq title (car titles))
(setq url (car urls)))
(setq titles (cdr titles))
(setq urls (cdr urls))
(setq pos (point))
(insert title)
(add-text-properties pos (point)
`(face w3m-session-select
w3m-session-number ,(cons arg num)))
(setq num (1+ num))
(insert (make-string (- max (string-width title)) ?\ ))
(insert url "\n"))
(goto-char (point-min))
(goto-char (next-single-property-change
(point) 'w3m-session-number)))
(set-buffer-modified-p nil)
(setq buffer-read-only t)))
(defun w3m-session-select-next (&optional arg)
"Move the point to the next session."
(interactive "p")
(unless arg (setq arg 1))
(let ((positive (< 0 arg))
(buffer-read-only nil))
(beginning-of-line)
(put-text-property (point)
(next-single-property-change
(point) 'w3m-session-number)
'face 'w3m-session-select)
(while (not (zerop arg))
(forward-line (if positive 1 -1))
(unless (get-text-property (point) 'w3m-session-number)
(if positive
(goto-char (next-single-property-change
(point-min) 'w3m-session-number))
(goto-char (previous-single-property-change
(point-max) 'w3m-session-number))))
(setq arg (if positive
(1- arg)
(1+ arg))))
(beginning-of-line)
(put-text-property (point)
(next-single-property-change
(point) 'w3m-session-number)
'face 'w3m-session-selected)
(set-buffer-modified-p nil)))
(defun w3m-session-select-previous (&optional arg)
"the point to the previous session."
(interactive "p")
(w3m-session-select-next (- arg)))
(defun w3m-session-select-quit ()
"Exit from w3m session select mode."
(interactive)
(let ((buffer (current-buffer))
(wincfg w3m-session-select-wincfg))
(or (one-window-p) (delete-window))
(kill-buffer buffer)
(set-window-configuration wincfg)))
(defun w3m-session-select-select ()
"Select the session."
(interactive)
(beginning-of-line)
(let* ((num (get-text-property
(point) 'w3m-session-number))
(item (if (consp num)
(nth (cdr num)
(caddr (nth (car num)
w3m-session-select-sessions)))
(nth num w3m-session-select-sessions)))
(session (if (consp num)
(list (or (cadddr item) w3m-session-unknown-title)
nil
(list item)
nil)
item)))
(w3m-session-select-quit)
(w3m-session-goto-session session)))
(defun w3m-session-select-open-session-group ()
"Open the session group."
(interactive)
(beginning-of-line)
(let ((num (get-text-property
(point) 'w3m-session-number))
wheight)
(if (consp num)
(message "There is no session group.")
(setq wheight
(max (+ (length (caddr (nth num w3m-session-select-sessions))) 6)
window-min-height))
(condition-case nil
(enlarge-window (- wheight (window-height)))
(error nil))
(w3m-session-select-list-session-group num))))
(defun w3m-session-select-save ()
"Save the session."
(interactive)
(when (y-or-n-p "Save this sessions? ")
(w3m-session-select-quit)
(w3m-session-save)
(w3m-session-select)))
(defun w3m-session-select-rename ()
"Rename this session."
(interactive)
(beginning-of-line)
(let ((num (get-text-property
(point) 'w3m-session-number))
(sessions w3m-session-select-sessions))
(w3m-session-select-quit)
(w3m-session-rename sessions num)
(w3m-session-select)))
(defun w3m-session-select-delete ()
"Delete the session."
(interactive)
(when (y-or-n-p "Delete this session? ")
(beginning-of-line)
(let ((num (get-text-property
(point) 'w3m-session-number))
(sessions w3m-session-select-sessions))
(w3m-session-select-quit)
(w3m-session-delete sessions num)
(w3m-session-select))))
;;;###autoload
(defun w3m-session-select ()
"Select session from session list."
(interactive)
(w3m-session-ignore-errors
(let* ((sessions (w3m-load-list w3m-session-file))
(showbuf (w3m-get-buffer-create " *w3m-session select*"))
(wheight (max (+ (length sessions) 5) window-min-height))
(wincfg (current-window-configuration))
window last-window)
(setq last-window (previous-window
(w3m-static-if (fboundp 'frame-highest-window)
(frame-highest-window)
(frame-first-window))))
(while (minibuffer-window-active-p last-window)
(setq last-window (previous-window last-window)))
(while (and
(not (one-window-p))
(or (< (window-width last-window)
(frame-width))
(< (window-height last-window)
(+ wheight window-min-height))))
(setq window last-window)
(setq last-window (previous-window window))
(delete-window window))
(select-window (split-window last-window))
(condition-case nil
(shrink-window (- (window-height) wheight))
(error nil))
(switch-to-buffer showbuf)
(setq w3m-session-select-wincfg wincfg)
(w3m-session-select-mode sessions))))
(defun w3m-session-goto-session (session)
"Goto URLs."
(let ((title (nth 0 session))
(urls (nth 2 session))
(cnum (nth 3 session))
(i 0)
(w3m-async-exec (and w3m-async-exec-with-many-urls w3m-async-exec))
url cbuf buf pos history)
(message "Session goto(%s)..." title)
(while (setq url (car urls))
(setq urls (cdr urls))
(unless (stringp url)
(setq pos (nth 1 url)
history (nth 2 url)
url (nth 0 url)))
(w3m-goto-url-new-session url)
(setq buf (car (nreverse (w3m-list-buffers))))
(when (or (and (numberp cnum) (= cnum i))
(and (not cnum) (= i 0)))
(setq cbuf buf))
(when (and buf pos history)
(set-buffer buf)
(setq w3m-history-flat history)
(w3m-history-tree pos))
(setq i (1+ i)))
(when (and cbuf (eq major-mode 'w3m-mode))
(set-window-buffer (selected-window) cbuf))
(message "Session goto(%s)...done" title)))
(defun w3m-session-rename (sessions num)
(if (consp num)
(message "This command can execute in Main session area")
(let ((prompt "New session title: ")
(overwrite nil)
tmp title otitle)
(setq tmp (nth num sessions))
(setq otitle (car tmp))
(setq title otitle)
(catch 'loop
(while t
(setq title (read-from-minibuffer prompt otitle))
(cond
((string= title "")
nil)
((string= title otitle)
(when (y-or-n-p
(format "\"%s\" is same as original title. Do not rename? "
title))
(throw 'loop t)))
((assoc title sessions)
(when (y-or-n-p (format "\"%s\" is exist. Overwrite? " title))
(setq overwrite t)
(throw 'loop t))))
(setq prompt "Again New session title: ")))
(when overwrite
(setq sessions (delete (assoc title sessions) sessions)))
(unless (string= title otitle)
(setq sessions (delete tmp sessions))
(setcar tmp title)
(setq sessions (cons tmp sessions))
(w3m-save-list w3m-session-file sessions)))))
(defun w3m-session-delete (sessions num)
(let (tmp)
(if (consp num)
(let ((item (nth 2 (nth (car num) sessions))))
(setq tmp (delete (nth (cdr num) item)
item))
(setf (nth 2 (nth (car num) sessions))
tmp))
(setq tmp (nth num sessions))
(setq sessions (delete tmp sessions)))
(if sessions
(w3m-save-list w3m-session-file sessions)
(let ((file (expand-file-name w3m-session-file)))
(when (and (file-exists-p file)
(file-writable-p file))
(delete-file file))))))
(defvar w3m-session-menu-items
`([,(w3m-make-menu-item "$B?7$7$$%;%C%7%g%s$r:n$k(B..."
"Create New Session...")
w3m-goto-new-session-url t]
[,(w3m-make-menu-item "$B$3$N%;%C%7%g%s$rJ#@=$9$k(B" "Copy This Session")
w3m-copy-buffer w3m-current-url]
"----" ;; separator
[,(w3m-make-menu-item "$BA0$N%;%C%7%g%s$K0\F0$9$k(B"
"Move Previous Session")
w3m-previous-buffer
(> (safe-length (w3m-list-buffers)) 1)]
[,(w3m-make-menu-item "$B<!$N%;%C%7%g%s$K0\F0$9$k(B" "Move Next Session")
w3m-next-buffer
(> (safe-length (w3m-list-buffers)) 1)]
"----" ;; separator
[,(w3m-make-menu-item "$B$3$N%;%C%7%g%s$rJD$8$k(B" "Close This Session")
w3m-delete-buffer
(> (safe-length (w3m-list-buffers)) 1)]
[,(w3m-make-menu-item "$BB>$N%;%C%7%g%s$rJD$8$k(B" "Close Other Sessions")
w3m-delete-other-buffers
(> (safe-length (w3m-list-buffers)) 1)]
[,(w3m-make-menu-item "$B8=:_$N%;%C%7%g%s$rJ]B8$9$k(B"
"Save Displayed Sessions")
w3m-session-save t]
[,(w3m-make-menu-item "$B%;%C%7%g%s$rA*Br$9$k(B" "Select Sessions")
w3m-session-select t])
"*List of the session menu items.")
;;;###autoload
(defun w3m-setup-session-menu ()
"Setup w3m session items in menubar."
(w3m-static-if (featurep 'xemacs)
(unless (car (find-menu-item current-menubar '("Session")))
(easy-menu-define w3m-session-menu w3m-mode-map
"" '("Session" ["(empty)" ignore nil]))
(easy-menu-add w3m-session-menu)
(add-hook 'activate-menubar-hook 'w3m-session-menubar-update))
(unless (lookup-key w3m-mode-map [menu-bar Session])
(easy-menu-define w3m-session-menu w3m-mode-map "" '("Session"))
(easy-menu-add w3m-session-menu)
(add-hook 'menu-bar-update-hook 'w3m-session-menubar-update))))
(defvar w3m-session-menu-items-pre nil)
(defvar w3m-session-menu-items-time nil)
(defun w3m-session-menubar-update ()
"Update w3m session menubar."
(when (and (eq major-mode 'w3m-mode)
(w3m-static-if (featurep 'xemacs)
(frame-property (selected-frame) 'menubar-visible-p)
menu-bar-mode))
(let ((items w3m-session-menu-items)
(pages (w3m-session-make-menu-items)))
(easy-menu-define w3m-session-menu w3m-mode-map
"The menu kepmap for the emacs-w3m session."
(cons "Session" (if pages
(append items '("----") pages)
items)))
(w3m-static-when (featurep 'xemacs)
(when (setq items (car (find-menu-item current-menubar '("Session"))))
(setcdr items (cdr w3m-session-menu))
(set-buffer-menubar current-menubar))))))
(defun w3m-session-file-modtime ()
"Return the modification time of the session file `w3m-session-file'.
The value is a list of two time values `(HIGH LOW)' if the session
file exists, otherwise nil."
(nth 5 (file-attributes w3m-session-file)))
(defvar w3m-session-make-item-xmas
(and (equal "Japanese" w3m-language) (featurep 'xemacs)))
(defun w3m-session-make-item (item)
(if w3m-session-make-item-xmas
(concat item "%_ ")
item))
(defun w3m-session-make-menu-items ()
"Create w3m session menu items."
(if (and w3m-session-menu-items-pre
w3m-session-menu-items-time
(equal w3m-session-menu-items-time
(w3m-session-file-modtime)))
w3m-session-menu-items-pre
(w3m-session-ignore-errors
(let ((sessions (w3m-load-list w3m-session-file)))
(setq w3m-session-menu-items-time (w3m-session-file-modtime))
(setq w3m-session-menu-items-pre
(and sessions
(mapcar
(lambda (entry)
(cons (w3m-session-make-item (car entry))
(cons (vector "Open all sessions"
`(w3m-session-goto-session
(quote ,entry)))
(mapcar
(lambda (item)
(let ((title
(w3m-session-make-item
(or (nth 3 item)
w3m-session-unknown-title))))
(vector
title
`(w3m-session-goto-session
(quote
,(list title
nil
(list item)
nil))))))
(nth 2 entry)))))
sessions)))))))
;;;###autoload
(defun w3m-session-last-autosave-session ()
(when w3m-session-load-last-sessions
(w3m-session-ignore-errors
(let ((item
(let ((sessions (w3m-load-list w3m-session-file))
(n 1) x)
(catch 'loop
(while t
(if (< w3m-session-automatic-keep-number n)
(throw 'loop nil)
(setq x (assoc (format "%s-%d"
w3m-session-automatic-title n)
sessions))
(when x (throw 'loop x)))
(setq n (1+ n)))))))
(when (and item
(or (and (eq w3m-session-load-last-sessions 'ask)
(y-or-n-p "Load the last sessions? "))
w3m-session-load-last-sessions))
item)))))
;;;###autoload
(defun w3m-session-last-crashed-session ()
(when (and w3m-session-crash-recovery w3m-session-load-crashed-sessions)
(w3m-session-ignore-errors
(let ((item (assoc w3m-session-crash-recovery-title
(w3m-load-list w3m-session-file))))
(when (and item
(or (and (eq w3m-session-load-crashed-sessions 'ask)
(y-or-n-p "Load the crashed sessions? "))
(eq w3m-session-load-crashed-sessions t)))
item)))))
(provide 'w3m-session)
;;; w3m-session.el ends here

230
share/emacs/site-lisp/w3m/w3m-symbol.el Normal file
View file

@ -0,0 +1,230 @@
;;; w3m-symbol.el --- Stuffs to replace symbols for emacs-w3m -*- coding: iso-2022-7bit; -*-
;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2009
;; ARISAWA Akihiro <ari@mbf.sphere.ne.jp>
;; Author: ARISAWA Akihiro <ari@mbf.sphere.ne.jp>
;; Keywords: w3m, WWW, hypermedia, i18n
;; This file 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 file 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; Code:
(eval-when-compile
(require 'cl))
(eval-when-compile
(defvar w3m-output-coding-system)
(defvar w3m-language)
(defvar w3m-use-symbol)
(autoload 'w3m-mule-unicode-p "w3m"))
(defgroup w3m-symbol nil
"Symbols for w3m"
:group 'w3m)
(defvar w3m-symbol-custom-type
'(list
:convert-widget w3m-widget-type-convert-widget
(let* ((w `(sexp :match (lambda (widget value) (stringp value))
:size 4 :value ""
,@(if (not (widget-get widget :copy))
;; Emacs versions prior to 22.
'(:value-to-internal
(lambda (widget value)
(if (string-match "\\`\".*\"\\'" value)
value
(prin1-to-string value)))))))
(a `(,@w :format "%v "))
(b `(,@w :format "%v\n"))
(c (list a a a a a a a b))
(d (list a a a a a b)))
`(:indent 4 :tag "Customize"
,@c ,@c ,@c ,@c ,@d ,@d ,b ,b))))
(defcustom w3m-default-symbol
'("-+" " |" "--" " +" "-|" " |" "-+" ""
"--" " +" "--" "" "-+" "" "" ""
"-+" " |" "--" " +" "-|" " |" "-+" ""
"--" " +" "--" "" "-+" "" "" ""
" *" " +" " o" " #" " @" " -"
" =" " x" " %" " *" " o" " #"
" #"
"<=UpDn ")
"List of symbol string, used by defaultly."
:group 'w3m-symbol
:type w3m-symbol-custom-type)
(defcustom w3m-Chinese-BIG5-symbol
'("$(0#3(B" "$(0#7(B" "$(0#5(B" "$(0#<(B" "$(0#6(B" "$(0#:(B" "$(0#=(B" ""
"$(0#4(B" "$(0#>(B" "$(0#9(B" "" "$(0#?(B" "" "" ""
"$(0#3(B" "$(0#7(B" "$(0#5(B" "$(0#<(B" "$(0#6(B" "$(0#:(B" "$(0#=(B" ""
"$(0#4(B" "$(0#>(B" "$(0#9(B" "" "$(0#?(B" "" "" ""
"$(0!&(B" "$(0!{(B" "$(0!w(B" "$(0!r(B" "$(0!|(B" "$(0!x(B"
"$(0!v(B" "$(0!s(B" "$(0!t(B" "$(0!s(B" "$(0!r(B" "$(0!{(B"
"$(0!s(B"
"$(0!N"U"V(B")
"List of symbol string, used in Chienese-BIG5 environment."
:group 'w3m-symbol
:type w3m-symbol-custom-type)
(defcustom w3m-Chinese-CNS-symbol
'("$(G#3(B" "$(G#7(B" "$(G#5(B" "$(G#<(B" "$(G#6(B" "$(G#:(B" "$(G#=(B" ""
"$(G#4(B" "$(G#>(B" "$(G#9(B" "" "$(G#?(B" "" "" ""
"$(G#3(B" "$(G#7(B" "$(G#5(B" "$(G#<(B" "$(G#6(B" "$(G#:(B" "$(G#=(B" ""
"$(G#4(B" "$(G#>(B" "$(G#9(B" "" "$(G#?(B" "" "" ""
"$(G!&(B" "$(G!{(B" "$(G!w(B" "$(G!r(B" "$(G!|(B" "$(G!x(B"
"$(G!v(B" "$(G!s(B" "$(G!t(B" "$(G!s(B" "$(G!r(B" "$(G!{(B"
"$(G!s(B"
"$(G!N"U"V(B")
"List of symbol string, used in Chienese-CNS environment."
:group 'w3m-symbol
:type w3m-symbol-custom-type)
(defcustom w3m-Chinese-GB-symbol
'("$A)`(B" "$A)@(B" "$A)P(B" "$A)0(B" "$A)H(B" "$A)&(B" "$A)4(B" ""
"$A)X(B" "$A)8(B" "$A)$(B" "" "$A)<(B" "" "" ""
"$A)`(B" "$A)D(B" "$A)S(B" "$A)3(B" "$A)L(B" "$A)'(B" "$A)7(B" ""
"$A)[(B" "$A);(B" "$A)%(B" "" "$A)?(B" "" "" ""
"$A!$(B" "$A!u(B" "$A!n(B" "$A!p(B" "$A!v(B" "$A!o(B"
"$A!r(B" "$A!q(B" "$A!w(B" "$A!q(B" "$A!p(B" "$A!u(B"
"$A!q(B"
"$A!6!|!}(B")
"List of symbol string, used in Chienese-GB environment."
:group 'w3m-symbol
:type w3m-symbol-custom-type)
(defcustom w3m-Japanese-symbol
'("$B(+(B" "$B('(B" "$B(((B" "$B(#(B" "$B()(B" "$B("(B" "$B($(B" ""
"$B(*(B" "$B(&(B" "$B(!(B" "" "$B(%(B" "" "" ""
"$B(+(B" "$B(7(B" "$B(8(B" "$B(.(B" "$B(9(B" "$B(-(B" "$B(/(B" ""
"$B(:(B" "$B(1(B" "$B(,(B" "" "$B(0(B" "" "" ""
"$B!&(B" "$B""(B" "$B!y(B" "$B!{(B" "$B"#(B" "$B!z(B"
"$B!}(B" "$B!|(B" "$B"$(B" "$B!|(B" "$B!{(B" "$B""(B"
"$B!|(B"
"$B"c","-(B")
"List of symbol string, used in Japanese environment."
:group 'w3m-symbol
:type w3m-symbol-custom-type)
(defcustom w3m-Korean-symbol
'("$(C&+(B" "$(C&'(B" "$(C&((B" "$(C&#(B" "$(C&)(B" "$(C&"(B" "$(C&$(B" ""
"$(C&*(B" "$(C&&(B" "$(C&!(B" "" "$(C&%(B" "" "" ""
"$(C&+(B" "$(C&7(B" "$(C&8(B" "$(C&.(B" "$(C&9(B" "$(C&-(B" "$(C&/(B" ""
"$(C&:(B" "$(C&1(B" "$(C&,(B" "" "$(C&0(B" "" "" ""
"$(C!$(B" "$(C!`(B" "$(C!Y(B" "$(C![(B" "$(C!a(B" "$(C!Z(B"
"$(C!](B" "$(C!\(B" "$(C!b(B" "$(C!\(B" "$(C![(B" "$(C!`(B"
"$(C!\(B"
"$(C!l!h!i(B")
"List of symbol string, used in Korean environment."
:group 'w3m-symbol
:type w3m-symbol-custom-type)
(defcustom w3m-mule-unicode-symbol
(when (w3m-mule-unicode-p)
(append
(mapcar (lambda (p)
(if p
(char-to-string
(make-char (or (nth 2 p) 'mule-unicode-2500-33ff)
(car p) (cadr p)))
""))
'((32 92) (32 60) (32 76) (32 44) (32 68) (32 34) (32 48) nil
(32 84) (32 52) (32 32) nil (32 56) nil nil nil
(32 92) (32 64) (32 79) (32 47) (32 72) (32 35) (32 51) nil
(32 87) (32 55) (32 33) nil (32 59) nil nil nil
(115 34 mule-unicode-0100-24ff) (33 97) (34 102) (34 43) (33 96) (34 101)
(34 46) (34 47) (33 115) (34 47) (34 43) (33 97)
(34 47)))
(list (format "%c %c %c "
(make-char 'mule-unicode-0100-24ff 121 42)
(make-char 'mule-unicode-0100-24ff 118 113)
(make-char 'mule-unicode-0100-24ff 118 115)))))
"List of symbol string, using mule-unicode characters."
:group 'w3m-symbol
:type (if (w3m-mule-unicode-p)
w3m-symbol-custom-type
'(const :format "%{%t%}: %v")))
(defcustom w3m-symbol nil
"List of symbol string."
:group 'w3m-symbol
:type `(radio (const :format "Auto detect " nil)
(const :tag "Default" w3m-default-symbol)
(const :format "Chinese BIG5 " w3m-Chinese-BIG5-symbol)
(const :format "Chinese CNS " w3m-Chinese-CNS-symbol)
(const :tag "Chinese GB" w3m-Chinese-GB-symbol)
(const :format "Japanese " w3m-Japanese-symbol)
(const :format "Korean " w3m-Korean-symbol)
,@(when w3m-mule-unicode-symbol
'((const :tag "Mule-Unicode" w3m-mule-unicode-symbol)))
(variable :format "%t symbol: %v\n" :size 0
:value w3m-default-symbol)
,w3m-symbol-custom-type))
(defun w3m-use-symbol ()
(cond ((functionp w3m-use-symbol)
(funcall w3m-use-symbol))
(t w3m-use-symbol)))
(eval-when-compile (defvar current-language-environment))
(defun w3m-symbol ()
(cond (w3m-symbol
(if (symbolp w3m-symbol)
(symbol-value w3m-symbol)
w3m-symbol))
((and (eq w3m-output-coding-system 'utf-8)
w3m-mule-unicode-symbol))
((let ((lang (or w3m-language
(and (boundp 'current-language-environment)
current-language-environment
;; In XEmacs 21.5 it may be the one like
;; "Japanese (UTF-8)".
(if (string-match "[\t ]+("
current-language-environment)
(substring current-language-environment
0 (match-beginning 0))
current-language-environment)))))
(when (boundp (intern (format "w3m-%s-symbol" lang)))
(symbol-value (intern (format "w3m-%s-symbol" lang))))))
(t w3m-default-symbol)))
;;;###autoload
(defun w3m-replace-symbol ()
(when (w3m-use-symbol)
(let ((symbol-list (w3m-symbol)))
(save-excursion
(goto-char (point-min))
(while (re-search-forward "<_SYMBOL TYPE=\\([0-9]+\\)>" nil t)
(let ((symbol (nth (string-to-number (match-string 1)) symbol-list))
(start (point))
end symbol-cnt)
(search-forward "</_SYMBOL>" nil t)
(setq end (match-beginning 0)
symbol-cnt (/ (string-width (buffer-substring start end))
(string-width symbol)))
(goto-char start)
(delete-region start end)
(insert (apply 'concat (make-list symbol-cnt symbol)))))))))
(provide 'w3m-symbol)
;;; w3m-symbol.el ends here

188
share/emacs/site-lisp/w3m/w3m-tabmenu.el Normal file
View file

@ -0,0 +1,188 @@
;;; w3m-tabmenu.el --- Functions for TAB menu browsing
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2009
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: Hideyuki SHIRAI <shirai@meadowy.org>,
;; TSUCHIYA Masatoshi <tsuchiya@namazu.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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file contains the functions for TAB browsing. For more detail
;; about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; Code:
(eval-when-compile
(require 'cl))
(require 'w3m-util)
(require 'w3m)
(require 'easymenu)
(defun w3m-setup-tab-menu ()
"Setup w3m tab menubar."
(when w3m-use-tab-menubar
(w3m-static-if (featurep 'xemacs)
(unless (car (find-menu-item current-menubar '("Tab")))
(easy-menu-define w3m-tab-menu w3m-mode-map
"" '("Tab" ["dummy" w3m-switch-buffer t]))
(easy-menu-add w3m-tab-menu)
(add-hook 'activate-menubar-hook 'w3m-tab-menubar-update))
(unless (lookup-key w3m-mode-map [menu-bar Tab])
(easy-menu-define w3m-tab-menu w3m-mode-map "" '("Tab"))
(easy-menu-add w3m-tab-menu)
(add-hook 'menu-bar-update-hook 'w3m-tab-menubar-update)))))
(defun w3m-switch-buffer ()
"Switch `w3m-mode' buffer in the current window."
(interactive)
(let ((items (w3m-tab-menubar-make-items 'nomenu))
(minibuffer-setup-hook
(append minibuffer-setup-hook '(beginning-of-line)))
(count 1)
(form "%s [%s]")
(completion-ignore-case t)
comp hist histlen default buf)
(dolist (item items)
(when (nth 2 item) ;; current-buffer
(setq default count))
(setq comp (cons
(cons
(format form (nth 1 item) (nth 0 item)) (nth 0 item))
comp))
(setq hist (cons (format form (nth 1 item) (nth 0 item)) hist))
(setq count (1+ count)))
(setq comp (nreverse comp))
(setq histlen (length hist))
(setq hist (append hist hist hist hist hist)) ;; STARTPOS at 3rd hist
(setq buf
(completing-read
"Switch to w3m buffer: "
comp nil t (car (nth (1- default) comp))
(cons 'hist (+ (* 3 histlen) (- histlen default -1)))
(car (nth (1- default) comp))))
(setq buf (cdr (assoc buf comp)))
(when (get-buffer buf)
(switch-to-buffer buf))))
(defun w3m-tab-menubar-open-item (buf)
"Open w3m buffer from tab menubar."
(interactive)
(when (get-buffer buf)
(switch-to-buffer buf)))
(defun w3m-tab-menubar-update ()
"Update w3m tab menubar."
(when (and (eq major-mode 'w3m-mode)
(w3m-static-if (featurep 'xemacs)
(frame-property (selected-frame) 'menubar-visible-p)
menu-bar-mode))
(easy-menu-define w3m-tab-menu w3m-mode-map
"The menu kepmap for the emacs-w3m tab."
(cons "Tab" (w3m-tab-menubar-make-items)))
(w3m-static-when (featurep 'xemacs)
(let ((items (car (find-menu-item current-menubar '("Tab")))))
(when items
(setcdr items (cdr w3m-tab-menu))
(set-buffer-menubar current-menubar))))))
(defvar w3m-tab-menubar-items-sub-coeff 30) ;; 30?
(defvar w3m-tab-menubar-items-width 50) ;; 50?
(defun w3m-tab-menubar-make-items-1 (buffers &optional nomenu)
(let ((i 0)
(current (current-buffer))
(width w3m-tab-menubar-items-width)
title unseen)
(mapcar
(lambda (buffer)
(if nomenu
(list (buffer-name buffer)
(format "%s%s"
(if (w3m-unseen-buffer-p buffer) "(u)" "")
(w3m-buffer-title buffer))
(eq buffer current))
(setq title (w3m-buffer-title buffer))
(setq unseen (w3m-unseen-buffer-p buffer))
(when (>= (string-width title) width)
(setq title
(concat (w3m-truncate-string title
(- width 3))
"...")))
(vector (format "%d:%s%s"
(incf i)
(cond ((eq buffer current) "* ")
(unseen "u ")
(t " "))
title)
`(w3m-tab-menubar-open-item ,(buffer-name buffer))
buffer)))
buffers)))
(defvar w3m-tab-menubar-make-items-precbuf nil)
(defvar w3m-tab-menubar-make-items-prebuflst nil)
(defvar w3m-tab-menubar-make-items-preurl nil)
(defvar w3m-tab-menubar-make-items-preitems nil)
(defun w3m-tab-menubar-force-update (&rest args)
(setq w3m-tab-menubar-make-items-preitems nil)
(w3m-tab-menubar-update))
(add-hook 'w3m-display-functions 'w3m-tab-menubar-force-update)
(defun w3m-tab-menubar-make-items (&optional nomenu)
"Create w3m tab menu items."
(let (menu buflst total max)
(if nomenu
(w3m-tab-menubar-make-items-1 (w3m-list-buffers) t)
(setq w3m-tab-button-menu-current-buffer (current-buffer))
(setq buflst (w3m-list-buffers))
(if (and w3m-tab-menubar-make-items-preitems
(eq w3m-tab-button-menu-current-buffer
w3m-tab-menubar-make-items-precbuf)
(equal w3m-tab-menubar-make-items-prebuflst buflst)
(equal w3m-tab-menubar-make-items-preurl w3m-current-url))
w3m-tab-menubar-make-items-preitems
(setq w3m-tab-menubar-make-items-precbuf
w3m-tab-button-menu-current-buffer)
(setq w3m-tab-menubar-make-items-prebuflst buflst)
(setq w3m-tab-menubar-make-items-preurl w3m-current-url)
(setq total (length buflst))
(setq max (- (frame-height (selected-frame))
w3m-tab-menubar-items-sub-coeff))
(if (< total max)
(setq menu (w3m-tab-menubar-make-items-1 buflst))
(setq menu (list `(,(w3m-make-menu-item "¥¿¥Ö¤ÎÁªÂò"
"Select TAB")
,@(w3m-tab-menubar-make-items-1 buflst)))))
(setq w3m-tab-menubar-make-items-preitems
(append menu
'("-")
'("-")
(w3m-make-menu-commands
w3m-tab-button-menu-commands)))))))
(provide 'w3m-tabmenu)
;;; w3m-tabmenu.el ends here

109
share/emacs/site-lisp/w3m/w3m-ucs.el Normal file
View file

@ -0,0 +1,109 @@
;;; w3m-ucs.el --- CCL programs to process Unicode.
;; Copyright (C) 2001, 2005, 2007 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.org>,
;; ARISAWA Akihiro <ari@mbf.sphere.ne.jp>
;; 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file contains CCL codes to handle UCS characters in emacs-w3m.
;; For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;; This module requires `Mule-UCS' package. It can be downloaded from:
;;
;; ftp://ftp.m17n.org/pub/mule/Mule-UCS/
;;; Code:
;; Enable XEmacs 21.5-Mule to compile this module anyway.
(eval-when-compile
(if (featurep 'xemacs)
(let ((mucs-ignore-version-incompatibilities t))
(defvar font-ccl-encoder-alist nil)
(require 'un-define))))
(require 'un-define)
(require 'w3m-ccl)
(eval-and-compile
(autoload 'w3m-make-ccl-coding-system "w3m"))
(defun w3m-ucs-to-char (codepoint)
(condition-case nil
(or (ucs-to-char codepoint) ?~)
(error ?~)))
(eval-and-compile
(defconst w3m-ccl-get-ucs-codepoint-with-mule-ucs
'(;; (1) Convert a set of r1 (charset-id) and r0 (codepoint) to a
;; character in Emacs internal representation.
(if (r0 > 255)
((r4 = (r0 & 127))
(r0 = (((r0 >> 7) * 96) + r4))
(r0 |= (r1 << 16)))
((r0 |= (r1 << 16))))
;; (2) Convert a character in Emacs to a UCS codepoint.
(call emacs-char-to-ucs-codepoint-conversion)
(if (r0 <= 0)
(write-repeat ?~))) ; unknown character.
"CCL program to convert multibyte char to ucs with Mule-UCS."))
(define-ccl-program w3m-euc-japan-mule-ucs-encoder
`(4
(loop
,@w3m-ccl-write-euc-japan-character
,@w3m-ccl-get-ucs-codepoint-with-mule-ucs
,@w3m-ccl-generate-ncr)))
(w3m-make-ccl-coding-system
'w3m-euc-japan-mule-ucs ?E
"ISO 2022 based EUC encoding for Japanese with w3m internal characters.
A character that can not be encoded with `euc-japan' is converted to a
UCS codepoint with Mule-UCS, and the codepoint is represented as a
string which represents the character in Numeric Character
References (NCR).
(generated by `w3m')"
'w3m-euc-japan-decoder
'w3m-euc-japan-mule-ucs-encoder)
(define-ccl-program w3m-iso-latin-1-mule-ucs-encoder
`(4
(loop
,@w3m-ccl-write-iso-latin-1-character
,@w3m-ccl-get-ucs-codepoint-with-mule-ucs
,@w3m-ccl-generate-ncr)))
(w3m-make-ccl-coding-system
'w3m-iso-latin-1-mule-ucs ?1
"ISO 2022 based 8-bit encoding for Latin-1 with w3m internal characters.
A character that can not be encoded with `iso-latin-1' is converted to
a UCS codepoint with Mule-UCS, and the codepoint is represented as a
string which represents the character in Numeric Character
References (NCR).
(generated by `w3m')"
'w3m-iso-latin-1-decoder
'w3m-iso-latin-1-mule-ucs-encoder)
(provide 'w3m-ucs)
;;; w3m-ucs.el ends here.

1421
share/emacs/site-lisp/w3m/w3m-util.el Normal file
View file

File diff suppressed because it is too large Load diff

510
share/emacs/site-lisp/w3m/w3m-weather.el Normal file
View file

@ -0,0 +1,510 @@
;;; w3m-weather.el --- Look weather forecast -*- coding: iso-2022-7bit; -*-
;; Copyright (C) 2001, 2002, 2003, 2005
;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; w3m-weather.el is the add-on program of emacs-w3m to look weather
;; foracast. For more detail about emacs-w3m, see:
;;
;; http://emacs-w3m.namazu.org/
;;; How to install:
;; Please put this file to appropriate directory, and if you want
;; byte-compile it. And add following lisp expressions to your
;; ~/.emacs.
;;
;; (autoload 'w3m-weather "w3m-weather" "Display weather report." t)
;;; Code:
(eval-when-compile (require 'cl))
(require 'w3m)
(defconst w3m-weather-completion-table
(eval-when-compile
(let* ((format "http://weather.yahoo.co.jp/weather/jp/%s.html")
(alist
'(;; URL$B$N0lIt(B, $B4A;zI=5-(B, $B%m!<%^;zI=5-(B, $BJLL>(B
;; ($B%m!<%^;zI=5-$G$OD92;$r>JN,$7$J$$$3$H(B)
("1a/1100" "$BF;KL!&=!C+(B" "douhokusouya" "souya")
("1a/1200" "$BF;KL!&>e@n(B" "douhokukamikawa" "kamikawa")
("1a/1300" "$BF;KL!&N1K((B" "douhokurumoi" "rumoi")
("1c/1710" "$BF;El!&LVAv(B" "doutouabashiri" "abashiri")
("1c/1720" "$BF;El!&KL8+(B" "doutoukitami" "kitami")
("1c/1730" "$BF;El!&LfJL(B" "doutoumonbetsu" "monbetsu")
("1c/1800" "$BF;El!&:,<<(B" "doutounemuro" "nemuro")
("1c/1900" "$BF;El!&6|O)(B" "doutoukushiro" "kushiro")
("1c/2000" "$BF;El!&==>!(B" "doutoutokachi" "tokachi")
("1b/1400" "$BF;1{!&@P<m(B" "dououishikari" "ishikari")
("1b/1500" "$BF;1{!&6uCN(B" "douousorachi" "sorachi")
("1b/1600" "$BF;1{!&8e;V(B" "dououshiribeshi" "shiribeshi")
("1d/2400" "$BF;Fn!&I0;3(B" "dounanhiyama" "hiyama")
("1d/2100" "$BF;Fn!&C@?6(B" "dounaniburi" "iburi")
("1d/2200" "$BF;Fn!&F|9b(B" "dounanhidaka" "hidaka")
("1d/2300" "$BF;Fn!&EOEg(B" "dounanoshima" "oshima")
("1d/2400" "$BF;Fn!&[X;3(B" "dounanhiyama" "hiyama")
("2/3110" "$B@D?98)!&DE7Z(B" "aomorikentsugaru" "tsugaru")
("2/3120" "$B@D?98)!&2<KL(B" "aomorikenshimokita" "shimokita")
("2/3130" "$B@D?98)!&;0H,>eKL(B"
"aomorikensanpachikamikita" "sanpachikamikita")
("3/3310" "$B4d<j8)!&FbN&It(B" "iwatekennairikubu")
("3/3320" "$B4d<j8)!&1h4_KLIt(B" "iwatekenenganhokubu")
("3/3330" "$B4d<j8)!&1h4_FnIt(B" "iwatekenengannanbu")
("5/3210" "$B=)ED8)!&1h4_It(B" "akitakenenganbu")
("5/3220" "$B=)ED8)!&FbN&It(B" "akitakennairikubu")
("4/3410" "$B5\>k8)!&ElIt(B" "miyagikentoubu")
("4/3420" "$B5\>k8)!&@>It(B" "miyagikenseibu")
("6/3510" "$B;37A8)!&B<;3(B" "yamagatakenmurayama" "murayama")
("6/3520" "$B;37A8)!&CV;r(B" "yamagatakenokitama" "okitama")
("6/3530" "$B;37A8)!&>1Fb(B" "yamagatakenshonai" "shounai")
("6/3540" "$B;37A8)!&:G>e(B" "yamagatakenmogami" "mogami")
("7/3610" "$BJ!Eg8)!&CfDL$j(B" "hukushimakennakadoori" "nakadoori")
("7/3620" "$BJ!Eg8)!&IMDL$j(B" "hukushimakenhamadoori" "hamadoori")
("7/3630" "$BJ!Eg8)!&2qDE(B" "hukushimakenaidu" "aidu")
("8/4010" "$B0q>k8)!&KLIt(B" "ibaragikenhokubu")
("8/4020" "$B0q>k8)!&FnIt(B" "ibaragikennanbu")
("9/4110" "$BFJLZ8)!&FnIt(B" "tochigikennanbu")
("9/4120" "$BFJLZ8)!&KLIt(B" "tochigikenhokubu")
("10/4210" "$B72GO8)!&FnIt(B" "gunmakennanbu")
("10/4220" "$B72GO8)!&KLIt(B" "gunmakenhokubu")
("11/4310" "$B:k6L8)!&FnIt(B" "saitamakennanbu")
("11/4320" "$B:k6L8)!&KLIt(B" "saitamakenhokubu")
("11/4330" "$B:k6L8)!&CaIc(B" "saitamakenchichibu")
("12/4510" "$B@iMU8)!&KL@>It(B" "chibakenhokuseibu")
("12/4520" "$B@iMU8)!&KLElIt(B" "chibakenhokutoubu")
("12/4530" "$B@iMU8)!&FnIt(B" "chibakennanbu")
("13/4410" "$BEl5~ET!&El5~(B" "toukyoutotoukyou" "toukyou")
("13/4420" "$BEl5~ET!&0KF&=tEgKLIt(B"
"toukyoutoizushotouhokubu" "izushotouhokubu")
("13/100" "$BEl5~ET!&0KF&=tEgFnIt(B"
"toukyoutoizushotounanbu" "izushotounanbu")
("13/9600" "$BEl5~ET!&>.3^86=tEg(B"
"toukyoutoogasawarashotou" "ogasawarashotou")
("14/4610" "$B?@F`@n8)!&ElIt(B" "kanagawakentoubu")
("14/4620" "$B?@F`@n8)!&@>It(B" "kanagawakenseibu")
("15/5410" "$B?73c8)!&2<1[(B" "niigatakenkaetsu" "kaetsu")
("15/5420" "$B?73c8)!&Cf1[(B" "niigatakenchuuetsu" "chuuetsu")
("15/5430" "$B?73c8)!&>e1[(B" "niigatakenjouetsu" "jouetsu")
("15/5440" "$B?73c8)!&:4EO(B" "niigatakensado" "sado")
("16/5510" "$BIY;38)!&ElIt(B" "toyamakentoubu")
("16/5520" "$BIY;38)!&@>It(B" "toyamakenseibu")
("17/5610" "$B@P@n8)!&2C2l(B" "ishikawakenkaga" "kaga")
("17/5620" "$B@P@n8)!&G=EP(B" "ishikawakennoto" "noto")
("18/5710" "$BJ!0f8)!&NfKL(B" "hukuikenreihoku" "reihoku")
("18/5720" "$BJ!0f8)!&NfFn(B" "hukuikenreinan" "reinan")
("19/4910" "$B;3M|8)!&Cf@>It(B" "yamanashikenchuuseibu")
("19/4920" "$B;3M|8)!&IY;N8^8P(B" "yamanashikenhujigoko" "hujigoko")
("20/4810" "$BD9Ln8)!&KLIt(B" "naganokenhokubu")
("20/4820" "$BD9Ln8)!&CfIt(B" "naganokenchuubu")
("20/4830" "$BD9Ln8)!&FnIt(B" "naganokennanbu")
("21/5210" "$B4tIl8)!&H~G;(B" "gihukenmino" "mino")
("21/5220" "$B4tIl8)!&HtBM(B" "gihukenhida" "hida")
("22/5010" "$B@E2,8)!&CfIt(B" "shizuokakenchuubu")
("22/5020" "$B@E2,8)!&0KF&(B" "shizuokakenizu" "izu")
("22/5030" "$B@E2,8)!&ElIt(B" "shizuokakentoubu")
("22/5040" "$B@E2,8)!&@>It(B" "shizuokakenseibu")
("23/5110" "$B0&CN8)!&@>It(B" "aichikenseibu")
("23/5120" "$B0&CN8)!&ElIt(B" "aichikentoubu")
("24/5310" "$B;0=E8)!&KLCfIt(B" "miekenhokuchuubu")
("24/5320" "$B;0=E8)!&FnIt(B" "miekennanbu")
("25/6010" "$B<"2l8)!&FnIt(B" "shigakennanbu")
("25/6020" "$B<"2l8)!&KLIt(B" "shigakenhokubu")
("26/400" "$B5~ETI\!&KLIt(B" "kyoutohuhokubu")
("26/6100" "$B5~ETI\!&FnIt(B" "kyoutohunanbu")
("27/6200" "$BBg:eI\(B" "oosakahu" "oosaka")
("28/500" "$BJ<8K8)!&KLIt(B" "hyougokenhokubu")
("28/6300" "$BJ<8K8)!&FnIt(B" "hyougokennanbu")
("29/6410" "$BF`NI8)!&KLIt(B" "narakenhokubu")
("29/6420" "$BF`NI8)!&FnIt(B" "narakennanbu")
("30/6510" "$BOB2N;38)!&KLIt(B" "wakayamakenhokubu")
("30/6520" "$BOB2N;38)!&FnIt(B" "wakayamakennanbu")
("31/6910" "$BD;<h8)!&ElIt(B" "tottorikentoubu")
("31/6920" "$BD;<h8)!&@>It(B" "tottorikenseibu")
("32/600" "$BEg:,8)!&1#4t(B" "shimanekenoki" "oki")
("32/6810" "$BEg:,8)!&ElIt(B" "shimanekentoubu")
("32/6820" "$BEg:,8)!&@>It(B" "shimanekenseibu")
("33/6610" "$B2,;38)!&FnIt(B" "okayamakennanbu")
("33/6620" "$B2,;38)!&KLIt(B" "okayamakenhokubu")
("34/6710" "$B9-Eg8)!&FnIt(B" "hiroshimakennanbu")
("34/6720" "$B9-Eg8)!&KLIt(B" "hiroshimakenhokubu")
("35/8110" "$B;38}8)!&@>It(B" "yamaguchikenseibu")
("35/8120" "$B;38}8)!&CfIt(B" "yamaguchikenchuubu")
("35/8140" "$B;38}8)!&KLIt(B" "yamaguchikenhokubu")
("35/8130" "$B;38}8)!&ElIt(B" "yamaguchikentoubu")
("36/7110" "$BFAEg8)!&KLIt(B" "tokushimakenhokubu")
("36/7120" "$BFAEg8)!&FnIt(B" "tokushimakennanbu")
("37/7200" "$B9a@n8)(B" "kagawaken" "kagawa")
("38/7320" "$B0&I28)!&ElM=(B" "ehimekentouyo" "touyo")
("38/7330" "$B0&I28)!&FnM=(B" "ehimekennanyo" "nanyo")
("38/7310" "$B0&I28)!&CfM=(B" "ehimekenchuuyo" "chuuyo")
("39/7410" "$B9bCN8)!&CfIt(B" "kouchikenchuubu")
("39/7420" "$B9bCN8)!&ElIt(B" "kouchikentoubu")
("39/7430" "$B9bCN8)!&@>It(B" "kouchikenseibu")
("40/8210" "$BJ!2,8)!&J!2,(B" "hukuokakenhukuoka" "hukuoka")
("40/8220" "$BJ!2,8)!&KL6e=#(B" "hukuokakenkitakyushu" "kitakyuushu")
("40/8230" "$BJ!2,8)!&C^K-(B" "hukuokakenchikuhou" "chikuhou")
("40/8240" "$BJ!2,8)!&C^8e(B" "hukuokakenchikugo" "chikugo")
("41/8510" "$B:42l8)!&FnIt(B" "sagakennanbu")
("41/8520" "$B:42l8)!&KLIt(B" "sagakenhokubu")
("42/700" "$BD9:j8)!&0m4tBPGO(B"
"nagasakikenikitsushima" "iki" "tsushima" "ikitsushima")
("42/800" "$BD9:j8)!&8^Eg(B" "nagasakikengotou" "gotou")
("42/8410" "$BD9:j8)!&FnIt(B" "nagasakikennanbu")
("42/8420" "$BD9:j8)!&KLIt(B" "nagasakikenhokubu")
("43/8610" "$B7'K\8)!&7'K\(B" "kumamotokenkumamoto" "kumamoto")
("43/8620" "$B7'K\8)!&0$AI(B" "kumamotokenaso" "aso")
("43/8630" "$B7'K\8)!&E7Ap02KL(B"
"kumamotokenamakusaashikita" "amakusa" "ashikita" "amakusaashikita")
("43/8640" "$B7'K\8)!&5eKa(B" "kumamotokenkuma" "kuma")
("44/8310" "$BBgJ,8)!&CfIt(B" "ooitakenchuubu")
("44/8320" "$BBgJ,8)!&KLIt(B" "ooitakenhokubu")
("44/8330" "$BBgJ,8)!&@>It(B" "ooitakenseibu")
("44/8340" "$BBgJ,8)!&FnIt(B" "ooitakennanbu")
("45/8710" "$B5\:j8)!&FnItJ?LnIt(B" "miyazakikennanbuheiyabu")
("45/8720" "$B5\:j8)!&KLItJ?LnIt(B" "miyazakikenhokubuheiyabu")
("45/8730" "$B5\:j8)!&FnIt;31h$$(B" "miyazakikennanbuyamazoi")
("45/8740" "$B5\:j8)!&KLIt;31h$$(B" "miyazakikenhokubuyamazoi")
("46/8810" "$B</;yEg8)!&;'K`(B" "kagoshimakensatsuma" "satsuma")
("46/8820" "$B</;yEg8)!&Bg6y(B" "kagoshimakenoosumi" "oosumi")
("46/900" "$B</;yEg8)!&<o;REg!&205WEg(B"
"kagoshimakentanegashimayakushima" "tanegashima" "yakushima" "tanegashimayakushima")
("46/1000" "$B</;yEg8)!&1bH~(B" "kagoshimakenamami" "amami")
("47/9110" "$B2-Fl8)!&K\EgCfFnIt(B"
"okinawakenhontouchuunanbu" "hontouchuunanbu")
("47/9120" "$B2-Fl8)!&K\EgKLIt(B"
"okinawakenhontouhokubu" "hontouhokubu")
("47/9130" "$B2-Fl8)!&5WJFEg(B" "okinawakenkumejima" "kumejima")
("47/9200" "$B2-Fl8)!&BgElEg(B" "okinawakendaitoujima" "daitoujima")
("47/9300" "$B2-Fl8)!&5\8EEg(B" "okinawakenmiyakojima" "miyakojima")
("47/9400" "$B2-Fl8)!&@P3@Eg(B"
"okinawakenishigakijima" "ishigakijima")
("47/9500" "$B2-Fl8)!&M?Fa9qEg(B"
"okinawakenyonagunijima" "yonagunijima")))
(table)
;; $B%X%\%s<0$H71Na<0$NBP1~I=(B
(hepburn-table
(let (table)
(dolist (x '(("si" "shi")
("zi" "ji")
("zu" "du")
("ti" "chi")
("tu" "tsu")
("hu" "fu")))
(push x table)
(push (reverse x)table))
(dolist (x '(("sy" . "sh")
("zy" . "j")
("ty" . "ch")))
(dolist (y '("a" "u" "o"))
(push (list (concat (car x) y) (concat (cdr x) y)) table)
(push (list (concat (cdr x) y) (concat (car x) y)) table)))
table))
;; $BBP1~I=$K>h$C$F$$$kJ8;zNs$rC5$9@55,I=8=(B
(hepburn-regexp
(format "\\(?:\\`\\|[aiueo]\\)\\(n\\([^aiueoy]\\)\\|%s\\)"
(regexp-opt (mapcar (function car) hepburn-table))))
;; $BD92;$NM-L5$K$h$kGI@87A$NI=(B
(prolonged-table
(let (table)
(dolist (x '("k" "ky"
"s" "sy" "sh"
"t" "ty" "ch"
"n" "ny"
"h" "hy"
"m" "my"
"y"
"r" "ry"
"w"
"g" "gy"
"z" "zy" "j"
"d" "dy"
"b" "by"
"p" "py"))
(let ((long-vowels '("ou" "oo" "o-")))
(dolist (y long-vowels)
(push (cons (concat x y)
(append
(mapcar
(lambda (z) (concat x z))
(delete y (copy-sequence long-vowels)))
(list (concat x "o"))))
table)))
(push (list (concat x "uu") (concat x "u"))
table))
table))
;; $BGI@87A$NI=$K>h$C$F$$$kJ8;zNs$rC5$9@55,I=8=(B
(prolonged-regexp (format "\\(?:\\`\\|[aiueo]\\)\\(%s\\)"
(regexp-opt (mapcar (function car)
prolonged-table)))))
(labels ((hepburn-candidates
(str)
"$B%X%\%s<0$H71Na<0$N:9$K$h$C$F@8$8$kGI@87A$rF@$k(B"
(if (string-match hepburn-regexp str)
(let ((prefix (substring str 0 (match-beginning 1)))
(candidates (if (match-beginning 2)
'("n" "nn")
(assoc (match-string 1 str)
hepburn-table)))
(suffixes
(hepburn-candidates
(substring str (or (match-beginning 2)
(match-end 0)))))
(buf))
(dolist (x candidates)
(dolist (y suffixes)
(push (concat prefix x y) buf)))
buf)
(list str)))
(prolonged-candidates
(str)
"$BD92;$NM-L5$K$h$C$F@8$8$kGI@87A$rF@$k(B"
(let (buf)
(if (string-match prolonged-regexp str)
(let ((prefix (substring str 0 (match-beginning 1)))
(candidates (assoc (match-string 1 str)
prolonged-table))
(suffixes (prolonged-candidates
(substring str (match-end 0)))))
(dolist (x candidates)
(dolist (y suffixes)
(push (concat prefix x y) buf))))
(setq buf (list str)))
(dolist (x buf)
(when (string-match "\\(\\`\\|[aiue]\\)oo" x)
(let ((prefix (substring x 0 (match-end 1)))
(suffix (substring x (match-end 0))))
(dolist (y '("o" "oh" "o-"))
(push (concat prefix y suffix) buf)))))
buf))
(romaji-candidates
(str)
"$BA4$F$NGI@87A$rF@$k(B"
(let (buf)
(dolist (x (hepburn-candidates str))
(dolist (y (prolonged-candidates x))
(push y buf)))
buf)))
(dolist (area alist)
(let ((url (format format (car area)))
(kanji (cadr area)))
(push (list kanji (nth 2 area) url) table)
(dolist (romaji (cddr area))
(dolist (x (romaji-candidates romaji))
(push (list x kanji) table)))))
(nreverse table))))
"Completion table of areas and urls.")
(defcustom w3m-weather-default-area
"$B5~ETI\!&FnIt(B"
"Default region to check weather."
:group 'w3m
:type (cons 'radio
(delq nil
(mapcar (lambda (area)
(when (nth 2 area)
(list 'const (car area))))
w3m-weather-completion-table))))
(defcustom w3m-weather-filter-functions
'(w3m-weather-extract-contents
w3m-weather-adjust-contents
w3m-weather-expand-anchors
w3m-weather-insert-title)
"Filter functions to remove useless tags."
:group 'w3m
:type 'hook)
(defvar w3m-weather-input-history nil)
(defun w3m-weather-input-area ()
(let* ((str
(completing-read (format "Input area (default %s): "
w3m-weather-default-area)
'w3m-weather-area-completion nil t nil
'w3m-weather-input-history))
(area
(cond
((string= "" str) w3m-weather-default-area)
((string-match "[^-a-zA-Z]" str) str)
(t (cadr (assoc str w3m-weather-completion-table))))))
(setq w3m-weather-input-history
(cons area
(delete area
(delete str w3m-weather-input-history))))
area))
(defun w3m-weather-area-completion (partial predicate flag)
(if (eq flag 'lambda)
(and (assoc partial w3m-weather-completion-table)
(or (not predicate)
(funcall predicate partial))
t)
(let ((kanji "")
(romaji "")
(romaji-partial partial))
(when (string-match "\\`\\(?:[^-a-zA-Z]+\\)" partial)
(let ((suffix (substring partial (match-end 0))))
(setq kanji (substring partial 0 (match-end 0))
romaji (try-completion
""
(mapcar
(lambda (x)
(list (cadr (assoc x w3m-weather-completion-table))))
(all-completions kanji w3m-weather-completion-table)))
romaji-partial (concat romaji suffix))))
(let ((collection)
(regexp
(and (string-match "$B!&(B\\'" kanji)
(string-match "[aiueo]n\\'" romaji)
(concat "\\`" romaji "n[^aiueoy]"))))
(dolist (x (all-completions romaji-partial w3m-weather-completion-table))
(unless (and regexp (string-match regexp x))
(setq x (assoc x w3m-weather-completion-table))
(unless (assoc (cadr x) collection)
(push (cons (cadr x) (car x)) collection))))
(cond
((not flag)
(let ((s (try-completion kanji collection predicate)))
(if (and (stringp s) (string< s partial))
(when (setq s (try-completion romaji-partial
(mapcar (lambda (x) (list (cdr x)))
collection)
predicate))
(concat kanji (substring s (if romaji (length romaji) 0))))
s)))
((eq flag t)
(all-completions kanji collection predicate)))))))
;;;###autoload
(defun w3m-weather (area)
"Display weather report."
(interactive
(list (if current-prefix-arg
(w3m-weather-input-area)
w3m-weather-default-area)))
(w3m-goto-url (format "about://weather/%s" area)))
;;;###autoload
(defun w3m-about-weather (url no-decode no-cache post-data referer handler)
(if (string-match "\\`about://weather/" url)
(lexical-let* ((url url)
(no-cache no-cache)
(area (substring url (match-end 0)))
(furl (nth 2 (assoc area w3m-weather-completion-table))))
(w3m-process-do
(type (w3m-retrieve furl nil no-cache nil nil handler))
(when type
(w3m-decode-buffer furl)
(w3m-weather-run-filter-functions w3m-weather-filter-functions
area furl no-cache handler))))
(w3m-message "Unknown URL: %s" url)
nil))
(defun w3m-weather-run-filter-functions (functions area url no-cache handler)
(if functions
(lexical-let ((functions functions)
(area area)
(url url)
(no-cache no-cache))
(w3m-process-do
(nil (funcall (pop functions) area url no-cache handler))
(w3m-weather-run-filter-functions functions area url
no-cache handler)))
"text/html"))
(defun w3m-weather-extract-contents (&rest args)
"Remove both header and footer in the weather forecast pages."
(goto-char (point-min))
(when (search-forward "<!---MAIN_CONTENTS_table--->" nil t)
(delete-region (point-min) (match-beginning 0)))
(goto-char (point-max))
(when (search-backward "<!---Local_Link--->" nil t)
(delete-region (match-beginning 0) (point-max))))
(defun w3m-weather-adjust-contents (&rest args)
;; Remove spacers.
(goto-char (point-min))
(while (search-forward "<tr><td>\
<img src=\"http://img.yahoo.co.jp/images/clear.gif\" width=1>\
</td></tr>" nil t)
(delete-region (match-beginning 0) (match-end 0)))
;; Remove execessive tables.
(goto-char (point-min))
(while (re-search-forward "<table[^>]*>[ \t\r\f\n]*</table>" nil t)
(delete-region (match-beginning 0) (match-end 0)))
(goto-char (point-min))
;; Remove too narrow width parameters.
(while (re-search-forward "<td[^>]*\\(width=1%\\)" nil t)
(delete-region (match-beginning 1) (match-end 1)))
;; Display border lines.
(goto-char (point-min))
(while (re-search-forward "\
<table border=\\(0\\) cellpadding=[1-9][0-9]* cellspacing=[1-9][0-9]*" nil t)
(goto-char (match-beginning 1))
(delete-char 1)
(insert "1"))
(goto-char (point-min))
(while (re-search-forward
"<td align=center width=25%>[ \t\r\f\n]*<table border=1" nil t)
(delete-char -1)
(insert "0")))
(defun w3m-weather-insert-title (area url &rest args)
"Insert title."
(goto-char (point-min))
(insert "<head><title>Weather forecast of "
area
"</title></head>\n"
"<body><p align=left><a href=\""
url
"\">[Yahoo!]</a></p>\n")
(goto-char (point-max))
(insert "</body>"))
(defun w3m-weather-expand-anchors (area url &rest args)
;; FIXME: $BE75$M=Js%Z!<%8$K4^$^$l$F$$$kAjBP%j%s%/$r@dBP%j%s%/$K=q$-49(B
;; $B$($k$?$a$N4X?t!%$3$l$i$NAjBP%j%s%/$r0BA4$K<h$j07$&$?$a$K$O!$(Bbase
;; URL $B$rJV$;$k$h$&$K!$(Babout:// $B$N9=B$$r=q$-D>$9I,MW$,$"$k$H9M$($i$l(B
;; $B$k$,!$$H$j$"$($:8e2s$7!%(B
(goto-char (point-min))
(while (re-search-forward
(eval-when-compile
(concat "<a[ \t\r\f\n]+href=" w3m-html-string-regexp))
nil t)
(replace-match (format
"<a href=\"%s\""
(w3m-expand-url (w3m-remove-redundant-spaces
(or (match-string-no-properties 2)
(match-string-no-properties 3)
(match-string-no-properties 1)))
url)))))
(provide 'w3m-weather)
;;; w3m-weather.el ends here.

10648
share/emacs/site-lisp/w3m/w3m.el Normal file
View file

File diff suppressed because it is too large Load diff

7014
share/info/emacs-w3m-ja.info Normal file
View file

File diff suppressed because it is too large Load diff

7004
share/info/emacs-w3m.info Normal file
View file

File diff suppressed because it is too large Load diff