browse-open-all-url.el

;;; browse-open-all-url.el -- browse-open-all-url for Mew.

;; Copyright (C) 2017, 2018 fubuki

;; Author: fubuki@*****.org
;; Keywords: tools

;; 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 3 of the License.

;; 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.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; mew のメッセージバッファの url すべてを規定ブラウザで開く.

;;; Installation:

;; (require 'browse-open-all-url)

;; 以下のようにすると同じ操作(C-c C-e)で
;; HTML なら `mew-summary-execute-external' に渡し,
;; 通常メールなら `browse-open-all-url' を起動するよう振り分けられます.

;; (add-hook 'mew-summary-mode-hook
;; 	  '(lambda ()
;;              (local-set-key [remap mew-summary-execute-external] 'browse-open-branch)))

;; 除外したいものは  `browse-open-ignore-word-list' に正規表現リストで指定できます.
;; URL 行とそのひとつ前の行に指定キーワードが含まれていれば その URL が除外されます.

;; (setq browse-open-ignore-word-list
;;       '("パス" "登録" "変更" "解除" "問い合" "修正" "停止" "マイページ"
;;         "いいね" "シェア" "TERMS" "PRIVACY" "POLICY" "UNSUBSCRIBE"
;;         "facebook" "twitter" "line" "unsub_center" "antispam" "profile_center"
;;         "link.rakuten" "news.html" "/auctions.yahoo.co.jp/"))

;; 通常 HTTP アドレス行とそのひとつ上の行を見るのですが,
;; 変数 `browse-open-scan-direction-default' で変更することができ,
;; 更に 変数 `browse-open-scan-direction-alist' を設定することにより,
;; `From:' メールアドレスごとに個別の設定ができます.

;; 以下の場合 メアドに "rhino" が含まれていれば HTTP 行とその次の行を対象にします.

;; (setq browse-open-scan-direction-alist '(("rhino" . after))

;; 仕様として洗練されていないのですが,
;; HTTPパターン以外に数字列12桁にもマッチするようになっていて,
;; 数値12桁の場合マッチした数値の前に `browse-open-url-search-prefix' を付け足して,
;; ブラウザに渡します。トラッキングサーチ用です.

(defgroup browse-open nil
  "Auto URL open all."
  :prefix  "browse-open-"
  :version "25.3"
  :group 'mew)
  
(defcustom browse-open-ignore-word-list nil
  "If direction matches REGEXP, it excludes that URL."
  :type  '(choice
           (const nil)
           (repeat :tag "Regexp" regexp))
  :group 'browse-open)

(defcustom browse-open-scan-direction-default 'before
  "Default scan mode. 
just   : URL only.
here   : URL line.
before : URL line and before the one line.
after  : URL line and after the one line.
around : Before the one line to after the one line."
  :type '(choice (const just)
                 (const before)
                 (const here)
                 (const after)
                 (const around))
  :group 'browse-open)

(defcustom browse-open-scan-direction-alist '(("rhino" . after))
  "`From:' line determines the scan mode."
  :type '(repeat (cons regexp
                       (choice (const just)
                               (const before)
                               (const here)
                               (const after)
                               (const around))))
  :group 'browse-open)

(defcustom browse-open-url-regexp "\\(https?://.+$\\)\\|\\([0-9]\\{12,12\\}\\)"
  "URL pattern REGEXP or 12 digit number."
  :type   'regexp
  :group  'browse-open)

(defcustom browse-open-url-search-prefix "https://www.google.co.jp/search?q="
  "When a match line is a 12 digit number, a character string added before that."
  :type  'string
  :group 'browse-open)

;;; Code

(defun browse-open-uniq-delete (list)
  "Returns a LIST that excludes adjacent duplicate elements."
  (cond
   ((null list) list)
   ((equal (car list) (cadr list))
    (browse-open-uniq-delete (cdr list)))
   (t
    (cons (car list) (browse-open-uniq-delete (cdr list))))))

(defun browse-open-set-scan-point (mode &optional beg end)
  "Returns cons and start point and end point corresponding to MODE symbol."
  (let ((beg (or beg (point))) (end (or end (point))))
    ;; POINT MOVEMENT FUNCTION DOES NOT NOTIFY ERROR.
    ;; That is, if the target line does not exist, it does not only include it
    (save-excursion
      (cond
       ((eq mode 'just)
        nil)
       ((eq mode 'here)
        (setq beg (progn (beginning-of-line) (point))
              end (progn (end-of-line) (point))))
       ((eq mode 'before)
        (setq beg (progn (forward-line -1) (point))
              end (progn (forward-line) (end-of-line) (point))))
       ((eq mode 'after)
        (setq beg (progn (beginning-of-line) (point))
              end (progn (forward-line) (end-of-line) (point))))
       ((eq mode 'around)
        (setq beg (progn (forward-line -1) (beginning-of-line) (point))
              end (progn (forward-line  2) (end-of-line) (point))))
       (t
        nil)))
    (cons beg end)))

(defun browse-open-ignore-link-p (mode beg end)
  "MODE Returns `T' if the range matches any of
the excluded string list `browse-open-ignore-word-list'.
Otherwise it returns `NIL'."
  (let ((ignore-words browse-open-ignore-word-list)
        scan-point)
    (save-match-data
      (save-excursion
        (setq scan-point (browse-open-set-scan-point mode beg end))
        (dolist (word ignore-words)
          (if (string-match
               word
               (buffer-substring-no-properties (car scan-point) (cdr scan-point)))
              (return t)))))))

(defun browse-open-url-list-get ()
  "Sort the url string in BUFFER and return it as a list without duplicates."
  (browse-open-uniq-delete (sort (browse-open-url-list-set) 'string<)))

(defun browse-open-add-prefix (str)
  "If STR is 12 digits numerical value, `browse-open-url-search-prefix' is concat."
  (let ((prefix browse-open-url-search-prefix))
    (if (string-match "^[0-9]\\{12,12\\}$" str)
        (concat prefix  str)
      str)))

(defun browse-open-mail-address ()
  (save-excursion
    (mew-summary-set-message-buffer
     (mew-summary-folder-name)
     (mew-summary-message-number2))
    (mew-header-parse-address mew-from:)))

(defun browse-open-url-list-set ()
  "Returns a list of url strings in Mew Summary point BUFFER."
  (let ((case-fold-search t)
        (scan-mode (browse-open-scan-mode (browse-open-mail-address)))
        result-url-list)

    (save-excursion

      ;; ;; こっちだとキャッシュがあるとそれを丸ごと持ってるバッファになり HTML なゴミが混じる
      ;; (mew-summary-set-message-buffer
      ;;  (mew-summary-folder-name) (mew-summary-message-number))

      ;; こっちだとサマリでカーソルが合って表示されているバッファになり目的の挙動になる
      (with-current-buffer (mew-buffer-message)

        ;; Skip mail header. If you fail, do not change points.
        (goto-char (point-min))
        (while (re-search-forward "^Subject: \\(.+\n\\)+" nil t) nil)

        ;; Scan loop. Ignore-word `browse-open-ignore-word-list' is lost here.
        (while (re-search-forward browse-open-url-regexp nil t)
          (let ((str (browse-open-add-prefix (match-string-no-properties 0))))
            (and browse-open-ignore-word-list
                 (not (browse-open-ignore-link-p scan-mode
                                                 (match-beginning 0)
                                                 (match-end 0)))
                 (setq result-url-list (cons str result-url-list)))))))
    result-url-list))

(defun browse-open-scan-mode (mail)
  "Choice scan mode."
  (let ((mail (or mail ""))
        (result browse-open-scan-direction-default))
    ;; (message "<m %s>" mail) ;;
    ;; (message "<b %s>" (current-buffer)) ;;
    (dolist (a browse-open-scan-direction-alist)
      (if (string-match (car a) mail) (return (setq result (cdr a)))))
    result))

(defun browse-open-branch (&optional ask)
  "For mew bind remap `mew-summary-execute-external'."
  (interactive "P")
  (unless (mew-summary-execute-external ask)
    (browse-open-all-url)))

(defun browse-open-all-url ()
  "Current loop."
  (dolist (url (browse-open-url-list-get))
    (w32-shell-execute "open" url)))
;;(message "[%s]" url)))

;; (define-key mew-summary-mode-map [remap mew-summary-execute-external] 'browse-open-branch)
  
(provide 'browse-open-all-url)
;; fin.