cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/contrib/mew-browse.el

   1 ;;; mew-browse.el --- Handling URI with browse-url.el
   2
   3 ;; Author: Hideyuki SHIRAI <shirai@rdmg.mgcs.mei.co.jp>
   4 ;; Modify: Shuichi Kitaguchi <kit@Mew.org>
   5 ;; Created: May 19, 1999
   6 ;; Revised: May 24, 1999
   7
   8 ;;;
   9 ;;; ~/.emacs settings.
  10 ;;;
  11 ;;; ... anything browse-url setting ...
  12 ;; (require 'mew-browse)
  13
  14 ;;; SHIFT + (Middle|Right)-Click = browse-url or mew-user-agent-compose
  15 ;;; for Emacs
  16 ;; (define-key global-map [S-mouse-2] 'browse-url-at-mouse)
  17 ;;; for XEmacs
  18 ;; (define-key global-map [(shift button2)] 'browse-url-at-mouse)
  19 ;;
  20
  21 ;;; Appending URI to specified file.
  22 ;;
  23 ;;   mew-browse-noask                 ... ask or not when browse
  24 ;;   mew-browse-append-file           ... URL collection file name
  25 ;;   mew-browse-append-always-file    ... always, append URL to file (for dial-up)
  26 ;;   mew-browse-append-always-mailto  ... always, URL is mailto: (for emacs19.28)
  27 ;;   mew-browse-append-file-sort      ... always, sort URL file
  28 ;;
  29 ;;; example:
  30 ;;   (setq mew-browse-noask                nil)
  31 ;;   (setq mew-browse-append-file          "~/.browse")
  32 ;;   (setq mew-browse-append-always-file   nil)
  33 ;;   (setq mew-browse-append-always-mailto nil)
  34 ;;   (setq mew-browse-append-file-sort nil)
  35 ;;
  36
  37 ;;; Use mew-url-mailto instead of url-mailto in W3.
  38 ;;
  39 ;; (cond
  40 ;;  ((locate-library "url-mail")
  41 ;;   (eval-after-load "url-mail"
  42 ;;     '(fset 'url-mailto (symbol-function 'mew-url-mailto))))
  43 ;;  ((locate-library "url")
  44 ;;   (eval-after-load "url"
  45 ;;     '(fset 'url-mailto (symbol-function 'mew-url-mailto)))))
  46 ;;
  47
  48 (eval-when-compile (require 'mew))
  49
  50 (if (string-match "XEmacs" emacs-version)
  51     (defvar mew-browse-button [(button2)] "*Mouse button in message mode.")
  52   (defvar mew-browse-button [mouse-2] "*Mouse button in message mode."))
  53
  54 (setq browse-url-browser-function 'mew-browse-url)
  55
  56 (add-hook 'mew-init-hook
  57           (lambda ()
  58             (progn
  59               (define-key mew-message-mode-map mew-browse-button 'browse-url-at-mouse)
  60               )))
  61
  62 (defvar mew-browse-url-mailto-switch-func nil
  63   "*Which do you like, nil, 'switch-to-buffer-other-window or 'switch-to-buffer-other-frame ?")
  64
  65 (setq browse-url-regexp "\\(\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]+\\)\\|\\(\\([^-A-Za-z0-9!_.%]\\|^\\)[-A-Za-z0-9._!%]+@[A-Za-z0-9][-A-Za-z0-9._!]+[A-Za-z0-9]\\)")
  66
  67 (defvar mew-browse-noask                t   "*Ask or not when browse.")
  68 (defvar mew-browse-append-file          nil "*URL collection file.")
  69 (defvar mew-browse-append-always-file   nil "*For dialup user")
  70 (defvar mew-browse-append-always-mailto nil "*For emacs19.28")
  71 (defvar mew-browse-append-file-sort     nil "*Sort URL file.")
  72
  73 (defun mew-browse-url (url &optional args)
  74   "Exec browse URL or mew-user-agent-compose with parsing RFC2368."
  75   (interactive
  76    (list (read-from-minibuffer "Mew URL: ")))
  77   (if (or (not (boundp 'mew-mail-path)) (null mew-mail-path))
  78       (save-excursion (mew)))
  79   (let* ((append-buffer (and mew-browse-append-file
  80                              (string= buffer-file-name
  81                                       (expand-file-name mew-browse-append-file))))
  82          (append-nil (or append-buffer (not mew-browse-append-file)))
  83          (append-all (and (not append-nil) mew-browse-append-always-file))
  84          (append-ask (and (not append-nil) (not mew-browse-append-always-file)))
  85          (browse-all (or append-buffer mew-browse-noask))
  86          (browse-ask (and (not append-buffer) (not mew-browse-noask))))
  87     (string-match "\\([a-zA-Z0-9][-a-zA-Z0-9!_=?#$@~`%&*+|\\/.,:]+\\)" url)
  88     (setq url (substring url (match-beginning 0) (match-end 0)))
  89     (if (not (string-match ":" url))    ;; emacs19.28 only
  90         (if (and (not mew-browse-append-always-mailto)
  91                  (not (y-or-n-p (format "mailto:%s(y) or ftp://%s(n)? " url url))))
  92             (setq url (concat "ftp://" url))
  93           (setq url (concat "mailto:" url))))
  94     (cond
  95      ((and append-all browse-all)
  96       (mew-browse-url-append url)
  97       (mew-browse-url-start url))
  98      ((and append-ask browse-all)
  99       (if (y-or-n-p (format "Append %s? " url))
 100           (mew-browse-url-append url))
 101       (mew-browse-url-start url))
 102      ((and append-nil browse-all)
 103       (mew-browse-url-start url))
 104      ((and append-all browse-ask)
 105       (mew-browse-url-append url)
 106       (if (y-or-n-p (format "Browse %s? " url))
 107           (mew-browse-url-start url)))
 108      ((and append-nil browse-ask)
 109       (if (y-or-n-p (format "Browse %s? " url))
 110           (mew-browse-url-start url)))
 111      (t ;; (and append-ask browse-ask)
 112       (if (y-or-n-p (format "Browse %s(y) or Append(n)? " url))
 113           (mew-browse-url-start url)
 114         (mew-browse-url-append url)))
 115      )))
 116
 117 (defun mew-browse-url-append (url)
 118   (let ((file (expand-file-name mew-browse-append-file))
 119         (beg))
 120     (save-excursion
 121       (find-file file)
 122       (set-buffer (current-buffer))
 123       (goto-char (point-min))
 124       (while (search-forward url nil t)
 125         (progn
 126           (beginning-of-line)
 127           (setq beg (point))
 128           (forward-line)
 129           (delete-region beg (point))))
 130       (goto-char (point-max))
 131       (insert url "\n")
 132       (if mew-browse-append-file-sort
 133           (sort-lines nil (point-min) (point-max)))
 134       (write-file file)
 135       (kill-buffer (current-buffer))
 136       (message "Append %s to %s done." url file)
 137       )))
 138
 139 (defun mew-browse-url-start (url)
 140   (message "Browse %s." url)
 141   (cond
 142    ((string-match "^mailto:" url)
 143     (mew-browse-url-mailto url))
 144    ((and (symbolp mew-ext-prog-url) (fboundp mew-ext-prog-url))
 145     (funcall mew-ext-prog-url url))
 146    ((equal mew-ext-prog-url "w3")
 147     (require 'w3)
 148     (w3-fetch-other-frame url))
 149    (t
 150     (apply (function start-process)
 151            (format "*mew %s*" mew-ext-prog-url)
 152            nil mew-ext-prog-url
 153            (append mew-ext-prog-url-args (list url))))))
 154
 155 (defun mew-url-mailto (url)
 156   "Exec mew-user-agent-compose with parsing RFC2368."
 157   (interactive
 158    (list (read-from-minibuffer "Mew mailto: ")))
 159   (if (or (not (boundp 'mew-mail-path)) (null mew-mail-path))
 160       (save-excursion (mew)))
 161   (mew-browse-url-mailto url))
 162
 163 (defun mew-browse-url-mailto (url)
 164   (let (tmp to subject other)
 165       (and (boundp 'url-working-buffer)
 166            url-working-buffer
 167            (get-buffer url-working-buffer)
 168            (kill-buffer url-working-buffer))
 169       (and (functionp 'url-view-url) (url-view-url t)
 170            (setq other (cons (cons (capitalize "x-url-from") (url-view-url t)) other)))
 171       (while (string-match "[ \t]+" url)
 172         (setq url (concat (substring url 0 (match-beginning 0))
 173                           (substring url (match-end 0)))))
 174       (if (string-match "^mailto:" url)
 175           (setq tmp (mew-browse-url-mailto-decamp (substring url (match-end 0))))
 176         (setq tmp (mew-browse-url-mailto-decamp url)))
 177       (if (string-match "^\\([^?]+\\)" tmp)
 178           (progn
 179             (setq to (mew-browse-url-mailto-hex-to-string
 180                       (substring tmp (match-beginning 1) (match-end 1))))
 181             (setq tmp (substring tmp (match-end 0)))))
 182       (while (string-match "^[?&]\\([^=]+\\)=\\([^&]*\\)" tmp)
 183         (let ((hname (substring tmp (match-beginning 1) (match-end 1)))
 184               (hvalue (mew-browse-url-mailto-hex-to-string
 185                        (substring tmp (match-beginning 2) (match-end 2)))))
 186           (setq tmp (substring tmp (match-end 0)))
 187           (cond
 188            ((string-match "^to$" hname)
 189             (if to
 190                 (setq to (concat to ", " hvalue))
 191               (setq to hvalue)))
 192            ((string-match "^subject$" hname)
 193             (setq subject hvalue))
 194            (t
 195             (setq other (cons (cons (capitalize hname) hvalue) other))))))
 196       (let ((mew-x-mailer mew-x-mailer))
 197         (and (functionp 'url-view-url) (url-view-url t)
 198              (setq mew-x-mailer
 199                    (concat mew-x-mailer " / " url-package-name "-" url-package-version)))
 200         (mew-user-agent-compose to subject other nil mew-browse-url-mailto-switch-func))))
 201
 202 (defun mew-browse-url-mailto-decamp (str)
 203   (save-match-data
 204     (while (string-match "&amp;" str)
 205       (setq str (concat (substring str 0 (match-beginning 0))
 206                         "&"
 207                         (substring str (match-end 0)))))
 208     str))
 209
 210 (defun mew-browse-url-mailto-hex-to-string (str)
 211   (save-match-data
 212     (while (string-match "%\\([0-9a-fA-F][0-9a-fA-F]\\)" str)
 213       (setq str (concat (substring str 0 (match-beginning 0))
 214                         (make-string
 215                          1
 216                          (mew-browse-url-mailto-2hexs-to-int
 217                           (substring str (match-beginning 1) (match-end 1))))
 218                         (substring str (match-end 0)))))
 219     str))
 220
 221 (defun mew-browse-url-mailto-2hexs-to-int (hex)
 222   (+ (* 16 (mew-hexchar-to-int (aref hex 0)))
 223      (mew-hexchar-to-int (aref hex 1))))
 224
 225 (provide 'mew-browse)
 226 ;;; mew-browse.el ends here
 227