;;; -*- mode: Emacs-Lisp; coding: euc-japan -*-
;; Copyright (C) 2000 TSUCHIYA Masatoshi <tsuchiya@pine.kuee.kyoto-u.ac.jp>
;; Authors: TSUCHIYA Masatoshi <tsuchiya@pine.kuee.kyoto-u.ac.jp>,
;; Shun-ichi GOTO <gotoh@taiyo.co.jp>,
;; Satoru Takabayashi <satoru-t@is.aist-nara.ac.jp>
;; Hideyuki SHIRAI <shirai@meadowy.org>
;; Keywords: w3m, WWW, hypermedia
;; w3m.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 of the License, or
;; (at your option) any later version.
;; w3m.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.
;; You should have received a copy of the GNU General Public License
;; along with w3m.el; if not, write to the Free Software Foundation,
;; Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Commentary:
;; w3m.el is the interface program of w3m on Emacs. For more detail
;; about w3m, see:
;;
;; http://ei5nazha.yz.yamagata-u.ac.jp/~aito/w3m/
;;
;;; 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 "w3m" "Interface for w3m on Emacs." t)
;;; Code:
(or (and (boundp 'emacs-major-version)
(>= emacs-major-version 20))
(progn
(require 'poe)
(require 'pcustom)))
(defgroup w3m nil
"w3m - the web browser of choice."
:group 'hypermedia)
(defgroup w3m-face nil
"Faces for w3m."
:group 'w3m
:prefix "w3m-")
(defcustom w3m-command "w3m"
"*Name of the executable file of w3m."
:group 'w3m
:type 'string)
(defcustom w3m-command-arguments '("-e" "-halfdump" "-cols" col url)
"*Arguments of w3m."
:group 'w3m
:type '(repeat (restricted-sexp :match-alternatives (stringp 'col 'url))))
(defcustom w3m-viewer-command "xv"
"*Name of the viewer."
:group 'w3m
:type 'string)
(defcustom w3m-viewer-command-arguments '(file)
"Arguments of viewer."
:group 'w3m
:type '(repeat (restricted-sexp :match-alternatives (stringp 'file))))
(defcustom w3m-browser-command "netscape"
"*Command name or function name of the browser."
:group 'w3m
:type '(choice (string :tag "Name of command")
(function :tag "Name of function")))
(defcustom w3m-browser-command-arguments '(url)
"*Arguments of browser."
:group 'w3m
:type '(repeat (restricted-sexp :match-alternatives (stringp 'url))))
(defcustom w3m-mailto-url-function nil
"*Mailto handling Function."
:group 'w3m
:type 'function)
(defcustom w3m-use-cygdrive t
"*If non-nil, use /cygdrive/ rule when expand-file-name."
:group 'w3m
:type 'boolean)
(defcustom w3m-default-save-dir "~/.w3m"
"*Default directory for save file."
:group 'w3m
:type 'directory)
(defcustom w3m-coding-system (if (boundp 'MULE) '*euc-japan* 'euc-japan)
"*Coding system for w3m."
:group 'w3m
:type 'symbol)
(defcustom w3m-bookmark-file (expand-file-name "~/.w3m/bookmark.html")
"*Bookmark file of w3m."
:group 'w3m
:type 'file)
(defcustom w3m-arrived-list-file (expand-file-name "~/.w3m/.arrived")
"*Arrived URL file of w3m."
:group 'w3m
:type 'file)
(defcustom w3m-arrived-ct-file (expand-file-name "~/.w3m/.ctcheck")
"*Arrived URL's context-type file of w3m."
:group 'w3m
:type 'file)
(defcustom w3m-arrived-file-cs
(if (boundp 'MULE) '*euc-japan*unix 'euc-japan-unix)
"*Coding system for arrived file."
:group 'w3m
:type 'symbol)
(defcustom w3m-arrived-list-keep 500
"*Arrived keep count of w3m."
:group 'w3m
:type 'integer)
(defcustom w3m-keep-backlog 300
"*Back log size of w3m."
:group 'w3m
:type 'integer)
(defcustom w3m-fill-column (- (frame-width) 4)
"*Fill column of w3m."
:group 'w3m
:type 'integer)
(defcustom w3m-always-html-url-regex nil
"*If URL is matched this regex, it handle always Text/Html."
:group 'w3m
:type 'string)
(defface w3m-anchor-face
'((((class color) (background light)) (:foreground "red" :underline t))
(((class color) (background dark)) (:foreground "blue" :underline t))
(t (:underline t)))
"*Face to fontify anchors."
:group 'w3m-face)
(defface w3m-arrived-anchor-face
'((((class color) (background light))
(:foreground "navy" :underline t :bold t))
(((class color) (background dark))
(:foreground "blue" :underline t :bold t))
(t (:underline t)))
"*Face to fontify anchors, if arrived."
:group 'w3m-face)
(defface w3m-image-face
'((((class color) (background light)) (:foreground "ForestGreen"))
(((class color) (background dark)) (:foreground "PaleGreen"))
(t (:underline t)))
"*Face to fontify image alternate strings."
:group 'w3m-face)
(defcustom w3m-hook nil
"*Hook run before w3m called."
:group 'w3m
:type 'hook)
(defcustom w3m-mode-hook nil
"*Hook run before w3m-mode called."
:group 'w3m
:type 'hook)
(defcustom w3m-fontify-before-hook nil
"*Hook run before w3m-fontify called."
:group 'w3m
:type 'hook)
(defcustom w3m-fontify-after-hook nil
"*Hook run after w3m-fontify called."
:group 'w3m
:type 'hook)
(defcustom w3m-process-type 'start-process
"*Function type for w3m execution."
:group 'w3m
:type '(choice (symbol :tag "call-process" call-process)
(symbol :tag "start-process" start-process)))
(defcustom w3m-process-connection-type t
"*Process connection type for w3m execution."
:group 'w3m
:type 'boolean)
(defvar w3m-current-url nil "URL of this buffer.")
(defvar w3m-current-title nil "Title of this buffer.")
(defvar w3m-url-history nil "History of URL.")
(defvar w3m-backlog-buffer nil)
(defvar w3m-backlog-articles nil)
(defvar w3m-backlog-hashtb nil)
(defvar w3m-input-url-history nil)
(defvar w3m-arrived-anchor-list nil)
(defvar w3m-arrived-url-ct nil)
(defvar w3m-arrived-user-list nil)
(defvar w3m-process nil)
(defvar w3m-process-string nil)
(defvar w3m-process-url nil)
(defvar w3m-process-user nil)
(defvar w3m-process-passwd nil)
(defvar w3m-process-user-counter 0)
(make-variable-buffer-local 'w3m-process)
(make-variable-buffer-local 'w3m-process-string)
(make-variable-buffer-local 'w3m-process-url)
(make-variable-buffer-local 'w3m-process-user)
(make-variable-buffer-local 'w3m-process-passwd)
(make-variable-buffer-local 'w3m-process-user-counter)
(defun w3m-arrived-list-load ()
"Load arrived url list from 'w3m-arrived-list-file'
and 'w3m-arrived-ct-file'."
(when (file-readable-p w3m-arrived-ct-file)
(with-temp-buffer
(let ((file-coding-system-for-read w3m-arrived-file-cs)
(coding-system-for-read w3m-arrived-file-cs))
(insert-file-contents w3m-arrived-ct-file)
(setq w3m-arrived-url-ct
(condition-case nil
(read (current-buffer))
(error nil))))))
(when (file-readable-p w3m-arrived-list-file)
(with-temp-buffer
(let ((file-coding-system-for-read w3m-arrived-file-cs)
(coding-system-for-read w3m-arrived-file-cs))
(insert-file-contents w3m-arrived-list-file)
(setq w3m-arrived-anchor-list
(condition-case nil
(read (current-buffer))
(error nil)))))))
(defun w3m-arrived-list-save ()
"Save arrived url list to 'w3m-arrived-list-file'
and 'w3m-arrived-ct-file'."
(when (> (length w3m-arrived-url-ct) w3m-arrived-list-keep)
(setq w3m-arrived-url-ct
(nreverse (nthcdr (- (length w3m-arrived-url-ct)
w3m-arrived-list-keep)
(nreverse w3m-arrived-url-ct)))))
(when (and w3m-arrived-url-ct
(file-writable-p w3m-arrived-ct-file))
(with-temp-buffer
(let ((file-coding-system w3m-arrived-file-cs)
(coding-system-for-write w3m-arrived-file-cs))
(prin1 w3m-arrived-url-ct (current-buffer))
(princ "\n" (current-buffer))
(write-region (point-min) (point-max)
w3m-arrived-ct-file nil 'nomsg))))
(when (> (length w3m-arrived-anchor-list) w3m-arrived-list-keep)
(setq w3m-arrived-anchor-list
(nreverse (nthcdr (- (length w3m-arrived-anchor-list)
w3m-arrived-list-keep)
(nreverse w3m-arrived-anchor-list)))))
(when (and w3m-arrived-anchor-list
(file-writable-p w3m-arrived-list-file))
(with-temp-buffer
(let ((file-coding-system w3m-arrived-file-cs)
(coding-system-for-write w3m-arrived-file-cs))
(prin1 w3m-arrived-anchor-list (current-buffer))
(princ "\n" (current-buffer))
(write-region (point-min) (point-max)
w3m-arrived-list-file nil 'nomsg)
(setq w3m-arrived-anchor-list nil)))))
(defun w3m-arrived-list-add (&optional url)
"Cons url to 'w3m-arrived-anchor-list'. CAR is newest."
(setq url (or url w3m-current-url))
(when (> (length url) 5) ;; ignore short
(set-text-properties 0 (length url) nil url)
(setq w3m-arrived-anchor-list
(cons url (delete url w3m-arrived-anchor-list)))))
(defun w3m-fontify ()
"Fontify this buffer."
(let ((case-fold-search t))
(run-hooks 'w3m-fontify-before-hook)
;; Delete extra title tag.
(let (start)
(and (search-forward "<title>" nil t)
(setq start (match-beginning 0))
(search-forward "</title>" nil t)
(delete-region start (match-end 0))))
;; Fontify bold characters.
(goto-char (point-min))
(while (search-forward "<b>" nil t)
(let ((start (match-beginning 0)))
(delete-region start (match-end 0))
(when (search-forward "</b>" nil t)
(delete-region (match-beginning 0) (match-end 0))
(put-text-property start (match-beginning 0) 'face 'bold))))
;; Delete excessive `hseq' elements of anchor tags.
(goto-char (point-min))
(while (re-search-forward "<a\\( hseq=\"[-0-9]+\"\\)" nil t)
(delete-region (match-beginning 1) (match-end 1)))
;; Re-ordering anchor elements.
(goto-char (point-min))
(let (href)
(while (re-search-forward "<a\\([ \t\n]\\)[^>]+[ \t\n]href=\\(\"[^\"]*\"\\)" nil t)
(setq href (buffer-substring (match-beginning 2) (match-end 2)))
(delete-region (match-beginning 2) (match-end 2))
(goto-char (match-beginning 1))
(insert " href=" href)))
;; Fontify anchor tags.
(goto-char (point-min))
(while (re-search-forward
"<a\\([ \t\n]+href=\"\\([^\"]*\\)\"\\)?\\([ \t\n]+name=\"\\([^\"]*\\)\"\\)?[^>]*>"
nil t)
(let ((url (match-string 2))
(tag (match-string 4))
(start (match-beginning 0))
(end))
(delete-region start (match-end 0))
(cond (url
(when (search-forward "</a>" nil t)
(delete-region (setq end (match-beginning 0)) (match-end 0))
(if (member (w3m-expand-url url w3m-current-url)
w3m-arrived-anchor-list)
(put-text-property start end 'face 'w3m-arrived-anchor-face)
(put-text-property start end 'face 'w3m-anchor-face))
(put-text-property start end 'w3m-href-anchor url))
(when tag
(put-text-property start end 'w3m-name-anchor tag)))
(tag
(when (re-search-forward "<\\|\n" nil t)
(setq end (match-beginning 0))
(put-text-property start end 'w3m-name-anchor tag))))))
;; Fontify image alternate strings.
(goto-char (point-min))
(while (re-search-forward "<img_alt src=\"\\([^\"]*\\)\">" nil t)
(let ((src (match-string 1))
(start (match-beginning 0))
(end))
(delete-region start (match-end 0))
(when (search-forward "</img_alt>" nil t)
(delete-region (setq end (match-beginning 0)) (match-end 0))
(put-text-property start end 'face 'w3m-image-face)
(put-text-property start end 'w3m-image src))))
;; Remove other markups.
(goto-char (point-min))
(while (re-search-forward "</?[A-z][^>]*>" nil t)
(delete-region (match-beginning 0) (match-end 0)))
;; Decode escaped characters.
(goto-char (point-min))
(let (prop)
(while (re-search-forward
"&\\(\\(nbsp\\)\\|\\(gt\\)\\|\\(lt\\)\\|\\(amp\\)\\|\\(quot\\)\\|\\(apos\\)\\);"
nil t)
(setq prop (text-properties-at (match-beginning 0)))
(delete-region (match-beginning 0) (match-end 0))
(insert (if (match-beginning 2) " "
(if (match-beginning 3) ">"
(if (match-beginning 4) "<"
(if (match-beginning 5) "&"
(if (match-beginning 6) "\"" "'"))))))
(if prop (add-text-properties (1- (point)) (point) prop))))
(run-hooks 'w3m-fontify-after-hook)))
(defun w3m-refontify-anchor (&optional buff)
"Change face 'w3m-anchor-face to 'w3m-arrived-anchor-face."
(save-excursion
(and buff (set-buffer buff))
(when (and (eq major-mode 'w3m-mode)
(eq (get-text-property (point) 'face) 'w3m-anchor-face))
(let* (start
(end (next-single-property-change (point) 'face))
(buffer-read-only nil))
(when(and end
(setq start (previous-single-property-change end 'face)))
(put-text-property start end 'face 'w3m-arrived-anchor-face))
(set-buffer-modified-p nil)))))
(defun w3m-input-url (&optional prompt default)
"Read a URL from the minibuffer, prompting with string PROMPT."
(let (url candidates)
(w3m-backlog-setup)
(or w3m-input-url-history
(setq w3m-input-url-history (or w3m-arrived-anchor-list
(w3m-arrived-list-load))))
(mapatoms (lambda (x)
(setq candidates (cons (cons (symbol-name x) x) candidates)))
w3m-backlog-hashtb)
(setq url (completing-read (or prompt "URL: ")
candidates nil nil
default 'w3m-input-url-history default))
;; remove duplication
(setq w3m-input-url-history (cons url (delete url w3m-input-url-history)))
;; return value
url))
(defun w3m-backlog-setup ()
"Initialize backlog variables."
(unless (and (bufferp w3m-backlog-buffer)
(buffer-live-p w3m-backlog-buffer))
(save-excursion
(set-buffer (get-buffer-create " *w3m backlog*"))
(buffer-disable-undo)
(setq buffer-read-only t
w3m-backlog-buffer (current-buffer))))
(unless w3m-backlog-hashtb
(setq w3m-backlog-hashtb (make-vector 1021 0))))
(defun w3m-backlog-shutdown ()
"Clear all backlog variables and buffers."
(when (get-buffer w3m-backlog-buffer)
(kill-buffer w3m-backlog-buffer))
(setq w3m-backlog-hashtb nil
w3m-backlog-articles nil))
(defun w3m-backlog-enter (url buffer)
(w3m-backlog-setup)
(let ((ident (intern url w3m-backlog-hashtb)))
(if (memq ident w3m-backlog-articles)
() ; It's already kept.
;; Remove the oldest article, if necessary.
(and (numberp w3m-keep-backlog)
(>= (length w3m-backlog-articles) w3m-keep-backlog)
(w3m-backlog-remove-oldest))
;; Insert the new article.
(save-excursion
(set-buffer w3m-backlog-buffer)
(let (buffer-read-only)
(goto-char (point-max))
(unless (bolp) (insert "\n"))
(let ((b (point)))
(insert-buffer-substring buffer)
;; Tag the beginning of the article with the ident.
(when (> (point-max) b)
(put-text-property b (1+ b) 'w3m-backlog ident)
(setq w3m-backlog-articles (cons ident w3m-backlog-articles)))
))))))
(defun w3m-backlog-remove-oldest ()
(save-excursion
(set-buffer w3m-backlog-buffer)
(goto-char (point-min))
(if (zerop (buffer-size))
() ; The buffer is empty.
(let ((ident (get-text-property (point) 'w3m-backlog))
buffer-read-only)
;; Remove the ident from the list of articles.
(when ident
(setq w3m-backlog-articles (delq ident w3m-backlog-articles)))
;; Delete the article itself.
(delete-region (point)
(next-single-property-change
(1+ (point)) 'w3m-backlog nil (point-max)))))))
(defun w3m-backlog-remove (url)
"Remove data of URL from the backlog."
(w3m-backlog-setup)
(let ((ident (intern url w3m-backlog-hashtb))
beg end)
(when (memq ident w3m-backlog-articles)
;; It was in the backlog.
(save-excursion
(set-buffer w3m-backlog-buffer)
(let (buffer-read-only)
(when (setq beg (text-property-any
(point-min) (point-max) 'w3m-backlog ident))
;; Find the end (i. e., the beginning of the next article).
(setq end (next-single-property-change
(1+ beg) 'w3m-backlog (current-buffer) (point-max)))
(delete-region beg end)))
(setq w3m-backlog-articles (delq ident w3m-backlog-articles))))))
(defun w3m-backlog-request (url &optional buffer)
(w3m-backlog-setup)
(let ((ident (intern url w3m-backlog-hashtb)))
(when (memq ident w3m-backlog-articles)
;; It was in the backlog.
(let (beg end)
(save-excursion
(set-buffer w3m-backlog-buffer)
(if (not (setq beg (text-property-any
(point-min) (point-max) 'w3m-backlog ident)))
;; It wasn't in the backlog after all.
(setq w3m-backlog-articles (delq ident w3m-backlog-articles))
;; Find the end (i. e., the beginning of the next article).
(setq end
(next-single-property-change
(1+ beg) 'w3m-backlog (current-buffer) (point-max)))))
(and beg
end
(save-excursion
(and buffer (set-buffer buffer))
(let (buffer-read-only)
(insert-buffer-substring w3m-backlog-buffer beg end))
t))))))
(defun w3m-exec (url &optional buffer ct)
"Download URL with w3m to the BUFFER.
If BUFFER is nil, all data is placed to the current buffer.
CT denotes content-type."
(let ((cbuf (current-buffer)))
(when (let ((args (copy-sequence w3m-command-arguments)))
(cond
;; backlog exist.
((w3m-backlog-request url)
(w3m-exec-w3m url args buffer) nil)
;; ange|efs-ftp
((and (string-match "^ftp://" url)
(not (string-match "\\.s?html?$" url)))
(w3m-exec-ftp url) t)
;; text/html
((or (string-match "\\.s?html?$\\|/$" url)
(and w3m-always-html-url-regex
(string-match w3m-always-html-url-regex url))
(eq ct 'text/html))
(w3m-exec-w3m url args buffer) nil)
;; text/*
((or (string-match "\\.\\(txt\\|el\\)$" url) (eq ct 'text))
(setq args (cons "-dump" (delete "-halfdump" args)))
(w3m-exec-w3m url args buffer) nil)
;; image/*
((eq ct 'image)
(require 'w3)
(w3-fetch url) t)
;; application/*, audio/*, etc...
((eq ct 'application)
(require 'w3)
(let ((mm-download-directory
(file-name-as-directory w3m-default-save-dir)))
(w3-download-url (w3m-expand-url url w3m-current-url))) t)
;; get context-type and w3-exec() call recursion .
((not ct)
(w3m-exec url buffer (w3m-exec-w3m-ctcheck url)))
;; error
(t (error "context-type check error."))))
;; if not exec w3m, return (current-buffer)
cbuf)))
(defun w3m-exec-w3m-ctcheck (url)
(or (cdr (assoc url w3m-arrived-url-ct))
(save-excursion
(message "Dump header...")
(set-buffer (get-buffer-create " *w3m ctcheck*"))
(buffer-disable-undo)
(delete-region (point-min) (point-max))
(let ((args (copy-sequence w3m-command-arguments))
(case-fold-search t)
(ct 'error))
(setq args (cons "-dump_head" (delete "-halfdump" args)))
(w3m-exec-process url args)
(message "Dump header... done.")
(goto-char (point-min))
(when (re-search-forward "^content-type: " nil t)
(setq ct (if (looking-at "text/html") 'text/html
(if (looking-at "text") 'text
(if (looking-at "image") 'image
'application))))
(setq w3m-arrived-url-ct (cons (cons url ct) w3m-arrived-url-ct))
ct)))))
(defun w3m-exec-w3m (url args buffer)
(save-excursion
(setq buffer-read-only nil)
(if buffer (set-buffer buffer))
(delete-region (point-min) (point-max))
(unless (w3m-backlog-request url)
(message "Loading page...")
(w3m-exec-process url args)
(message "Loading page... done."))
(w3m-backlog-enter url (current-buffer))
;; Setting buffer local variables.
(set (make-local-variable 'w3m-current-url) url)
(goto-char (point-min))
(let (title)
(mapcar (lambda (regexp)
(goto-char 1)
(when (re-search-forward regexp nil t)
(setq title (match-string 1))
(delete-region (match-beginning 0) (match-end 0))))
'("<title_alt[ \t\n]+title=\"\\([^\"]+\\)\">"
"<title>\\([^<]\\)</title>"))
(if (and (null title)
(< 0 (length (file-name-nondirectory url))))
(setq title (file-name-nondirectory url)))
(set (make-local-variable 'w3m-current-title) (or title "<no-title>")))
(set (make-local-variable 'w3m-url-history)
(cons url w3m-url-history))
(setq-default w3m-url-history
(cons url (default-value 'w3m-url-history)))))
(defun w3m-exec-ftp (url)
(let ((ftp (w3m-convert-ftp-to-emacsen url))
(file (file-name-nondirectory url)))
(if (string-match "\\(\\.gz\\|\\.bz2\\|\\.zip\\|\\.lzh\\)$" file)
(copy-file ftp (w3m-read-file-name nil nil file))
(dired-other-window ftp))))
(defun w3m-convert-ftp-to-emacsen (url)
(or (and (string-match "^ftp://?\\([^/@]+@\\)?\\([^/]+\\)\\(/~/\\)?" url)
(concat "/"
(if (match-beginning 1)
(substring url (match-beginning 1) (match-end 1))
"anonymous@")
(substring url (match-beginning 2) (match-end 2))
":"
(substring url (match-end 2))))
(error "URL is strange.")))
(defun w3m-exec-process (url args)
(save-excursion
(let ((coding-system-for-read w3m-coding-system)
(coding-system-for-write w3m-coding-system)
(default-process-coding-system
(cons w3m-coding-system w3m-coding-system))
(process-connection-type w3m-process-connection-type))
(if (eq w3m-process-type 'start-process)
;; start-process
(unwind-protect nil
(let ()
;; (pop-to-buffer (current-buffer))
(setq w3m-process-url url)
(setq w3m-process-string nil)
(setq w3m-process-user nil)
(setq w3m-process-passwd nil)
(setq w3m-process-user-counter 2)
(setq buffer-read-only t)
(setq w3m-process
(apply 'start-process w3m-command (current-buffer) w3m-command
(mapcar (lambda (arg)
(if (eq arg 'col)
(format "%d" w3m-fill-column)
(eval arg)))
args)))
(set-process-coding-system w3m-process w3m-coding-system)
(set-process-filter w3m-process 'w3m-exec-filter)
(set-process-sentinel w3m-process 'w3m-exec-sentinel)
(process-kill-without-query w3m-process)
(while w3m-process
(sit-for 0.5)
(discard-input)))
(setq w3m-process nil)
(setq w3m-process-url url)
(setq w3m-process-string nil)
(setq w3m-process-user nil)
(setq w3m-process-passwd nil)
(setq w3m-process-user-counter 0)
(setq buffer-read-only nil))
;; call-process
(apply 'call-process w3m-command nil t nil
(mapcar (lambda (arg)
(if (eq arg 'col)
(format "%d" w3m-fill-column)
(eval arg)))
args))))))
(defun w3m-exec-filter (process string)
(if (bufferp (process-buffer process))
(let ((obuf (buffer-name)))
(unwind-protect
(progn
(set-buffer (process-buffer process))
(let ((buffer-read-only nil)
(case-fold-search nil)
file input prompt)
(goto-char (point-max))
(setq w3m-process-string
(concat w3m-process-string string))
(while (string-match "\n" w3m-process-string)
(insert (concat
(substring w3m-process-string 0 (match-beginning 0))
"\n"))
(setq w3m-process-string
(substring w3m-process-string (match-end 0))))
(cond
;; username
((string-match "^Username: " w3m-process-string)
(setq prompt (match-string 0 w3m-process-string))
(setq w3m-process-string "")
(setq w3m-process-user
(or (nth 0 (w3m-exec-get-user w3m-process-url))
(read-from-minibuffer prompt)))
(process-send-string process (concat w3m-process-user "\n")))
;; passwd
((string-match "^Password: " w3m-process-string)
(setq prompt (match-string 0 w3m-process-string))
(setq w3m-process-string "")
(setq w3m-process-passwd
(or (nth 1 (w3m-exec-get-user w3m-process-url))
(w3m-read-passwd prompt)))
(process-send-string process (concat w3m-process-passwd "\n")))
;; save file
((string-match "Save file to:" w3m-process-string)
(setq w3m-process-string "")
(setq input (w3m-read-file-name nil nil w3m-process-url))
(process-send-string process (concat input "\n"))
(insert (format "Save to %s.\n" input)))
;; overwrite
((string-match "File exists. Overwrite? (y or n)" w3m-process-string)
(setq w3m-process-string "")
(condition-case nil
(process-send-string process "y\n")
(error nil)))
;; quit
((string-match " *Hit any key to quit w3m:" w3m-process-string)
(condition-case nil
(quit-process process)
(error nil))))))
(if (get-buffer obuf)
(set-buffer obuf))))))
(defun w3m-exec-get-user (url)
(if (= w3m-process-user-counter 0)
nil
(let ((urllist w3m-arrived-user-list))
(catch 'get
(while urllist
(when (string-match (concat "^"
(regexp-quote (car (car urllist))))
url)
(setq w3m-process-user-counter (1- w3m-process-user-counter))
(throw 'get (cdr (car urllist))))
(setq urllist (cdr urllist)))))))
(defun w3m-exec-sentinel (process event)
(if (bufferp (process-buffer process))
(let ((obuf (buffer-name)))
(unwind-protect
(progn
(set-buffer (process-buffer process))
(if (and w3m-process-url w3m-process-user)
(setq w3m-arrived-user-list
(cons
(cons w3m-process-url
(list w3m-process-user w3m-process-passwd))
(delete (assoc w3m-process-url w3m-arrived-user-list)
w3m-arrived-user-list))))
(setq w3m-process-string nil)
(setq w3m-process nil)
(setq w3m-process-url nil)
(setq w3m-process-user nil)
(setq w3m-process-passwd nil))
(if (get-buffer obuf)
(set-buffer obuf))))))
(defun w3m-read-file-name (&optional prompt dir default existing initial)
(let* ((default (and default (file-name-nondirectory default)))
(prompt (or prompt
(if default (format "Save to (%s): " default) "Save to: ")))
(initial (or initial default))
(dir (file-name-as-directory (or dir w3m-default-save-dir)))
(default-directory dir)
(file (read-file-name prompt dir default existing initial)))
(if (not (file-directory-p file))
(setq w3m-default-save-dir
(or (file-name-directory file) w3m-default-save-dir))
(setq w3m-default-save-dir file)
(if default
(setq file (expand-file-name default file))))
(expand-file-name file)))
(defun w3m-read-passwd (prompt)
(let ((inhibit-input-event-recording t))
(if (fboundp 'read-passwd)
(condition-case nil
(read-passwd prompt)
(error ""))
(let ((pass "")
(c 0)
(echo-keystrokes 0)
(ociea cursor-in-echo-area))
(condition-case nil
(progn
(setq cursor-in-echo-area 1)
(while (and (/= c ?\r) (/= c ?\n) (/= c ?\e) (/= c 7)) ;; ^G
(message "%s%s"
prompt
(make-string (length pass) ?.))
(setq c (read-char-exclusive))
(cond
((char-equal c ?\C-u)
(setq pass ""))
((or (char-equal c ?\b) (char-equal c ?\177)) ;; BS DELL
;; delete one character in the end
(if (not (equal pass ""))
(setq pass (substring pass 0 -1))))
((< c 32) ()) ;; control, just ignore
(t
(setq pass (concat pass (char-to-string c))))))
(setq cursor-in-echo-area -1))
(quit
(setq cursor-in-echo-area ociea)
(signal 'quit nil))
(error
;; Probably not happen. Just align to the code above.
(setq pass "")))
(setq cursor-in-echo-area ociea)
(message "")
(sit-for 0)
pass))))
(defun w3m-search-name-anchor (name &optional quiet)
(interactive "sName: ")
(let ((pos (point-min)))
(catch 'found
(while (setq pos (next-single-property-change pos 'w3m-name-anchor))
(when (equal name (get-text-property pos 'w3m-name-anchor))
(goto-char pos)
(throw 'found t))
(setq pos (next-single-property-change pos 'w3m-name-anchor)))
(unless quiet
(message "Not found such name anchor."))
nil)))
(defun w3m-save-position (url)
(if url
(let ((ident (intern-soft url w3m-backlog-hashtb)))
(when ident
(set ident (cons (window-start) (point)))))))
(defun w3m-restore-position (url)
(let ((ident (intern-soft url w3m-backlog-hashtb)))
(when (and ident (boundp ident))
(set-window-start nil (car (symbol-value ident)))
(goto-char (cdr (symbol-value ident))))))
(defun w3m-view-previous-page (&optional arg)
(interactive "p")
(unless arg (setq arg 1))
(let ((url (nth arg w3m-url-history)))
(when url
(let (w3m-url-history) (w3m-goto-url url))
;; restore last position
(w3m-restore-position url)
(setq w3m-url-history
(nthcdr arg w3m-url-history)))))
(defun w3m-view-previous-point ()
(interactive)
(w3m-restore-position w3m-current-url))
(defun w3m-expand-url (url base)
"Convert URL to absolute, and canonicalize it."
(if (not base) (setq base ""))
(if (string-match "^[^:]+://[^/]*$" base)
(setq base (concat base "/")))
(cond
;; URL is relative on BASE.
((string-match "^#" url)
(concat base url))
;; URL has absolute spec.
((string-match "^[^:]+:" url)
url)
((string-match "^/" url)
(if (string-match "^\\([^:]+://[^/]*\\)/" base)
(concat (match-string 1 base) url)
url))
(t
(let ((server "") path)
(if (string-match "^\\([^:]+://[^/]*\\)/" base)
(setq server (match-string 1 base)
base (substring base (match-end 1))))
(setq path (expand-file-name url (file-name-directory base)))
;; remove drive (for Win32 platform)
(if (string-match "^.:" path)
(setq path (substring path (match-end 0))))
(concat server path)))))
(defun w3m-view-this-url (arg)
"*View the URL of the link under point."
(interactive "P")
(let ((url (get-text-property (point) 'w3m-href-anchor)))
(if url (w3m-goto-url (w3m-expand-url url w3m-current-url) arg))))
(defun w3m-mouse-view-this-url (event)
(interactive "e")
(mouse-set-point event)
(call-interactively (function w3m-view-this-url)))
(defun w3m-view-image ()
"*View the image under point."
(interactive)
(let ((file (get-text-property (point) 'w3m-image)))
(if (not file)
(message "No file at point.")
(require 'w3)
(w3-fetch (w3m-expand-url file w3m-current-url)))))
(defun w3m-save-image ()
"*Save the image under point to a file."
(interactive)
(let ((file (get-text-property (point) 'w3m-image)))
(if (not file)
(message "No file at point.")
(require 'w3)
(let ((mm-download-directory
(file-name-as-directory w3m-default-save-dir)))
(w3-download-url (w3m-expand-url file w3m-current-url))))))
(defun w3m-view-current-url-with-external-browser ()
"*View this URL."
(interactive)
(let ((buffer (get-buffer-create " *w3m-view*"))
(url (get-text-property (point) 'w3m-href-anchor)))
(if url
(setq url (w3m-expand-url url w3m-current-url))
(if (y-or-n-p (format "Browse <%s> ? " w3m-current-url))
(setq url w3m-current-url)))
(when url
(message "Browse <%s>" url)
(if (and (symbolp w3m-browser-command)
(fboundp w3m-browser-command))
(funcall w3m-browser-command url)
(apply 'start-process
"w3m-external-browser"
buffer
w3m-browser-command
(mapcar (function eval)
w3m-browser-command-arguments))))))
(defun w3m-download-this-url ()
"*Download the URL of the link under point to a file."
(interactive)
(let ((url (get-text-property (point) 'w3m-href-anchor)))
(if (not url)
(message "No URL at point.")
(require 'w3)
(let ((mm-download-directory
(file-name-as-directory w3m-default-save-dir)))
(w3-download-url (w3m-expand-url url w3m-current-url)))
(w3m-refontify-anchor (current-buffer)))))
(defun w3m-print-current-url ()
"*Print the URL of current page and push it into kill-ring."
(interactive)
(kill-new w3m-current-url)
(message "%s" w3m-current-url))
(defun w3m-print-this-url ()
"*Print the URL of the link under point."
(interactive)
(let ((url (get-text-property (point) 'w3m-href-anchor)))
(if url
(kill-new (setq url (w3m-expand-url url w3m-current-url))))
(message "%s" (or url "Not found."))))
(defun w3m-next-anchor (&optional arg)
"*Move cursor to the next anchor."
(interactive "p")
(unless arg (setq arg 1))
(if (< arg 0)
;; If ARG is negative.
(w3m-previous-anchor (- arg))
(when (get-text-property (point) 'w3m-href-anchor)
(goto-char (next-single-property-change (point) 'w3m-href-anchor)))
(while (and
(> arg 0)
(setq pos (next-single-property-change (point) 'w3m-href-anchor)))
(goto-char pos)
(unless (zerop (setq arg (1- arg)))
(goto-char (next-single-property-change (point) 'w3m-href-anchor))))))
(defun w3m-previous-anchor (&optional arg)
"Move cursor to the previous anchor."
(interactive "p")
(unless arg (setq arg 1))
(if (< arg 0)
;; If ARG is negative.
(w3m-next-anchor (- arg))
(when (get-text-property (point) 'w3m-href-anchor)
(goto-char (previous-single-property-change (1+ (point)) 'w3m-href-anchor)))
(while (and
(> arg 0)
(setq pos (previous-single-property-change (point) 'w3m-href-anchor)))
(goto-char (previous-single-property-change pos 'w3m-href-anchor))
(setq arg (1- arg)))))
(defun w3m-expand-file-name (file)
(setq file (expand-file-name file))
(if (string-match "^\\(.\\):\\(.*\\)" file)
(if w3m-use-cygdrive
(concat "/cygdrive/" (match-string 1 file) (match-string 2 file))
(concat "file://" (match-string 1 file) (match-string 2 file)))
file))
(defun w3m-view-bookmark ()
(interactive)
(if (file-readable-p w3m-bookmark-file)
(w3m-goto-url (w3m-expand-file-name w3m-bookmark-file))))
(defun w3m-copy-buffer (buf &optional newname and-pop) "\
Create a twin copy of the current buffer.
if NEWNAME is nil, it defaults to the current buffer's name.
if AND-POP is non-nil, the new buffer is shown with `pop-to-buffer'."
(interactive (list (current-buffer)
(if current-prefix-arg (read-string "Name: "))
t))
(setq newname (or newname (buffer-name)))
(if (string-match "<[0-9]+>\\'" newname)
(setq newname (substring newname 0 (match-beginning 0))))
(with-current-buffer buf
(let ((ptmin (point-min))
(ptmax (point-max))
(content (save-restriction (widen) (buffer-string)))
(mode major-mode)
(lvars (buffer-local-variables))
(new (generate-new-buffer (or newname (buffer-name)))))
(with-current-buffer new
;;(erase-buffer)
(insert content)
(narrow-to-region ptmin ptmax)
(funcall mode) ;still needed?? -sm
(mapcar (lambda (v)
(if (not (consp v)) (makunbound v)
(condition-case () ;in case var is read-only
(set (make-local-variable (car v)) (cdr v))
(error nil))))
lvars)
(when and-pop (pop-to-buffer new))
new))))
(defvar w3m-mode-map nil)
(unless w3m-mode-map
(setq w3m-mode-map (make-keymap))
(define-key w3m-mode-map " " 'scroll-up)
(define-key w3m-mode-map "b" 'scroll-down)
(define-key w3m-mode-map [backspace] 'scroll-down)
(define-key w3m-mode-map [delete] 'scroll-down)
(define-key w3m-mode-map "h" 'backward-char)
(define-key w3m-mode-map "j" 'next-line)
(define-key w3m-mode-map "k" 'previous-line)
(define-key w3m-mode-map "l" 'forward-char)
(define-key w3m-mode-map "J" (lambda () (interactive) (scroll-up 1)))
(define-key w3m-mode-map "K" (lambda () (interactive) (scroll-up -1)))
(define-key w3m-mode-map "G" 'goto-line)
(define-key w3m-mode-map "\C-?" 'scroll-down)
(define-key w3m-mode-map "\t" 'w3m-next-anchor)
(define-key w3m-mode-map [down] 'w3m-next-anchor)
(define-key w3m-mode-map "\M-\t" 'w3m-previous-anchor)
(define-key w3m-mode-map [up] 'w3m-previous-anchor)
(define-key w3m-mode-map "\C-m" 'w3m-view-this-url)
(define-key w3m-mode-map [right] 'w3m-view-this-url)
(if (featurep 'xemacs)
(define-key w3m-mode-map [(button2)] 'w3m-mouse-view-this-url)
(define-key w3m-mode-map [mouse-2] 'w3m-mouse-view-this-url))
(define-key w3m-mode-map "\C-c\C-b" 'w3m-view-previous-point)
(define-key w3m-mode-map [left] 'w3m-view-previous-page)
(define-key w3m-mode-map "B" 'w3m-view-previous-page)
(define-key w3m-mode-map "d" 'w3m-download-this-url)
(define-key w3m-mode-map "u" 'w3m-print-this-url)
(define-key w3m-mode-map "I" 'w3m-view-image)
(define-key w3m-mode-map "\M-I" 'w3m-save-image)
(define-key w3m-mode-map "c" 'w3m-print-current-url)
(define-key w3m-mode-map "M" 'w3m-view-current-url-with-external-browser)
(define-key w3m-mode-map "g" 'w3m)
(define-key w3m-mode-map "U" 'w3m)
(define-key w3m-mode-map "V" 'w3m)
(define-key w3m-mode-map "v" 'w3m-view-bookmark)
(define-key w3m-mode-map "q" 'w3m-quit)
(define-key w3m-mode-map "Q" (lambda () (interactive) (w3m-quit t)))
(define-key w3m-mode-map "\M-n" 'w3m-copy-buffer)
(define-key w3m-mode-map "R" 'w3m-reload-this-page)
(define-key w3m-mode-map "?" 'describe-mode)
)
(defun w3m-quit (&optional force)
(interactive "P")
(when (or force
(y-or-n-p "Do you want to exit w3m? "))
(kill-buffer (current-buffer))
(w3m-arrived-list-save)
(or (save-excursion
;; Check existing w3m buffers.
(delq nil (mapcar (lambda (b)
(set-buffer b)
(eq major-mode 'w3m-mode))
(buffer-list))))
;; If no w3m buffer exists, then destruct all cache.
(w3m-backlog-shutdown))))
(defun w3m-mode ()
"\\<w3m-mode-map>
Major mode to browsing w3m buffer.
\\[w3m-view-this-url] View this url.
\\[w3m-mouse-view-this-url] View this url.
\\[w3m-reload-this-page] Reload this page.
\\[w3m-next-anchor] Jump next anchor.
\\[w3m-previous-anchor] Jump previous anchor.
\\[w3m-view-previous-page] Back to previous page.
\\[w3m-download-this-url] Download this url.
\\[w3m-print-this-url] Print this url.
\\[w3m-view-image] View image.
\\[w3m-save-image] Save image.
\\[w3m-print-current-url] Print current url.
\\[w3m-view-current-url-with-external-browser] View current url with external browser.
\\[scroll-up] Scroll up.
\\[scroll-down] Scroll down.
\\[next-line] Next line.
\\[previous-line] Previous line.
\\[forward-char] Forward char.
\\[backward-char] Backward char.
\\[goto-line] Jump to line.
\\[w3m-view-previous-point] w3m-view-previous-point.
\\[w3m] w3m.
\\[w3m-view-bookmark] w3m-view-bookmark.
\\[w3m-copy-buffer] w3m-copy-buffer.
\\[w3m-quit] w3m-quit.
\\[describe-mode] describe-mode.
"
(kill-all-local-variables)
(buffer-disable-undo)
(setq major-mode 'w3m-mode
mode-name "w3m")
(use-local-map w3m-mode-map)
(run-hooks 'w3m-mode-hook))
(defun w3m-mailto-url (url)
(if (and (symbolp w3m-mailto-url-function)
(fboundp w3m-mailto-url-function))
(funcall w3m-mailto-url-function url)
(let (comp)
;; Require `mail-user-agent' setting
(if (not (and (boundp 'mail-user-agent)
mail-user-agent
(setq comp (intern-soft (concat (symbol-name mail-user-agent)
"-compose")))
(fboundp comp)))
(error "You must specify valid `mail-user-agent'."))
;; Use rfc2368.el if exist.
;; rfc2368.el is written by Sen Nagata.
;; You can find it in "contrib" directory of Mew package
;; or in "utils" directory of Wanderlust package.
(if (or (featurep 'rfc2368)
(condition-case nil (require 'rfc2368) (error nil)))
(let ((info (rfc2368-parse-mailto-url url)))
(apply comp (mapcar (lambda (x)
(cdr (assoc x info)))
'("To" "Subject"))))
;; without rfc2368.el.
(funcall comp (match-string 1 url))))))
(defun w3m-goto-url (url &optional reload)
"Retrieve URL and display it in this buffer."
(let (name buff)
(if reload
(w3m-backlog-remove url))
(cond
;; process mailto: protocol
((string-match "^mailto:\\(.*\\)" url)
(w3m-mailto-url url))
(t
(when (string-match "#\\([^#]+\\)$" url)
(setq name (match-string 1 url)
url (substring url 0 (match-beginning 0))))
(w3m-save-position w3m-current-url)
(or w3m-arrived-anchor-list (w3m-arrived-list-load))
(w3m-arrived-list-add url)
(if (setq buff (w3m-exec url))
;; no w3m exec and return *w3m* buffer.
(w3m-refontify-anchor buff)
;; w3m exec.
(w3m-fontify)
(setq buffer-read-only t)
(set-buffer-modified-p nil)
(or (and name (w3m-search-name-anchor name))
(goto-char (point-min))))))))
(defun w3m-reload-this-page ()
"Reload current page without cache."
(interactive)
(setq w3m-url-history (cdr w3m-url-history))
(w3m-goto-url w3m-current-url 'reload))
(defun w3m (url &optional args)
"Interface for w3m on Emacs."
(interactive (list (w3m-input-url)))
(set-buffer (get-buffer-create "*w3m*"))
(or (eq major-mode 'w3m-mode)
(w3m-mode))
(setq mode-line-buffer-identification
(list "%12b" " / " 'w3m-current-title))
(if (string= url "")
(w3m-view-bookmark)
(w3m-goto-url url))
(switch-to-buffer (current-buffer))
(run-hooks 'w3m-hook))
(defun w3m-browse-url (url &optional new-window)
"w3m interface function for browse-url.el."
(interactive
(progn
(require 'browse-url)
(browse-url-interactive-arg "w3m URL: ")))
(if new-window (split-window))
(w3m url))
(defun w3m-find-file (file)
"w3m Interface function for local file."
(interactive "fFilename: ")
(w3m (w3m-expand-file-name file)))
(provide 'w3m)
;;; w3m.el ends here.
