ol-w3m.el (9363B)
1 ;;; ol-w3m.el --- Copy and Paste From W3M -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2008-2023 Free Software Foundation, Inc. 4 5 ;; Author: Andy Stewart <lazycat dot manatee at gmail dot com> 6 ;; Keywords: outlines, hypermedia, calendar, wp 7 ;; URL: https://orgmode.org 8 ;; 9 ;; This file is part of GNU Emacs. 10 11 ;; GNU Emacs is free software: you can redistribute it and/or modify 12 ;; it under the terms of the GNU General Public License as published by 13 ;; the Free Software Foundation, either version 3 of the License, or 14 ;; (at your option) any later version. 15 16 ;; GNU Emacs is distributed in the hope that it will be useful, 17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 ;; GNU General Public License for more details. 20 21 ;; You should have received a copy of the GNU General Public License 22 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 ;; 25 ;;; Commentary: 26 27 ;; This file implements copying HTML content from a w3m buffer and 28 ;; transforming the text on the fly so that it can be pasted into an 29 ;; Org buffer with hot links. It will also work for regions in gnus 30 ;; buffers that have been washed with w3m. 31 32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 ;; 34 ;;; Acknowledgments: 35 36 ;; Richard Riley <rileyrgdev at googlemail dot com> 37 ;; 38 ;; The idea of transforming the HTML content with Org syntax is 39 ;; proposed by Richard, I'm just coding it. 40 ;; 41 42 ;;; Code: 43 44 (require 'org-macs) 45 (org-assert-version) 46 47 (require 'ol) 48 49 (defvar w3m-current-url) 50 (defvar w3m-current-title) 51 52 (org-link-set-parameters "w3m" :store #'org-w3m-store-link) 53 (defun org-w3m-store-link () 54 "Store a link to a w3m buffer." 55 (when (eq major-mode 'w3m-mode) 56 (org-link-store-props 57 :type "w3m" 58 :link w3m-current-url 59 :url (url-view-url t) 60 :description (or w3m-current-title w3m-current-url)))) 61 62 (defun org-w3m-copy-for-org-mode () 63 "Copy current buffer content or active region with Org style links. 64 This will encode `link-title' and `link-location' with 65 `org-link-make-string', and insert the transformed test into the kill ring, 66 so that it can be yanked into an Org buffer with links working correctly." 67 (interactive) 68 (let* ((regionp (org-region-active-p)) 69 (transform-start (point-min)) 70 (transform-end (point-max)) 71 return-content 72 link-location link-title 73 temp-position out-bound) 74 (when regionp 75 (setq transform-start (region-beginning)) 76 (setq transform-end (region-end)) 77 ;; Deactivate mark if current mark is activate. 78 (deactivate-mark)) 79 (message "Transforming links...") 80 (save-excursion 81 (goto-char transform-start) 82 (while (and (not out-bound) ; still inside region to copy 83 (not (org-w3m-no-next-link-p))) ; no next link current buffer 84 ;; store current point before jump next anchor 85 (setq temp-position (point)) 86 ;; move to next anchor when current point is not at anchor 87 (or (get-text-property (point) 'w3m-href-anchor) (org-w3m-get-next-link-start)) 88 (cond 89 ((<= (point) transform-end) ; point is inside transform bound 90 ;; get content between two links. 91 (when (> (point) temp-position) 92 (setq return-content (concat return-content 93 (buffer-substring 94 temp-position (point))))) 95 (cond 96 ((setq link-location (get-text-property (point) 'w3m-href-anchor)) 97 ;; current point is a link 98 ;; (we thus also got link location at current point) 99 ;; get link title at current point. 100 (setq link-title (buffer-substring (point) 101 (org-w3m-get-anchor-end))) 102 ;; concat Org style url to `return-content'. 103 (setq return-content 104 (concat return-content 105 (if (org-string-nw-p link-location) 106 (org-link-make-string link-location link-title) 107 link-title)))) 108 ((setq link-location (get-text-property (point) 'w3m-image)) 109 ;; current point is an image 110 ;; (we thus also got image link location at current point) 111 ;; get link title at current point. 112 (setq link-title (buffer-substring (point) (org-w3m-get-image-end))) 113 ;; concat Org style url to `return-content'. 114 (setq return-content 115 (concat return-content 116 (if (org-string-nw-p link-location) 117 (org-link-make-string link-location link-title) 118 link-title)))) 119 (t nil))); current point is neither a link nor an image 120 (t ; point is NOT inside transform bound 121 (goto-char temp-position) ; reset point before jump next anchor 122 (setq out-bound t)))) ; for break out `while' loop 123 ;; add the rest until end of the region to be copied 124 (when (< (point) transform-end) 125 (setq return-content 126 (concat return-content 127 (buffer-substring (point) transform-end)))) 128 (org-kill-new return-content) 129 (message "Transforming links...done, use C-y to insert text into Org file") 130 (message "Copy with link transformation complete.")))) 131 132 (defun org-w3m-get-anchor-start () 133 "Move cursor to the start of current anchor. Return point." 134 ;; get start position of anchor or current point 135 ;; NOTE: This function seems never to be used. Should it be removed? 136 (goto-char (or (previous-single-property-change (point) 'w3m-anchor-sequence) 137 (point)))) 138 139 (defun org-w3m-get-anchor-end () 140 "Move cursor to the end of current anchor. Return point." 141 ;; get end position of anchor or point 142 (goto-char (or (next-single-property-change (point) 'w3m-anchor-sequence) 143 (point)))) 144 145 (defun org-w3m-get-image-end () 146 "Move cursor to the end of current image. Return point." 147 ;; get end position of image or point 148 ;; NOTE: Function `org-w3m-get-image-start' was not created because 149 ;; function `org-w3m-get-anchor-start' is never used. 150 (goto-char (or (next-single-property-change (point) 'w3m-image) 151 (point)))) 152 153 (defun org-w3m-get-next-link-start () 154 "Move cursor to the start of next link or image. Return point." 155 (let (pos start-pos anchor-pos image-pos) 156 (setq pos (setq start-pos (point))) 157 (setq anchor-pos 158 (catch 'reach 159 (while (setq pos (next-single-property-change pos 'w3m-anchor-sequence)) 160 (when (get-text-property pos 'w3m-href-anchor) 161 (throw 'reach pos))))) 162 (setq pos start-pos) 163 (setq image-pos 164 (catch 'reach 165 (while (setq pos (next-single-property-change pos 'w3m-image)) 166 (when (get-text-property pos 'w3m-image) 167 (throw 'reach pos))))) 168 (goto-char (min (or anchor-pos (point-max)) (or image-pos (point-max)))))) 169 170 (defun org-w3m-get-prev-link-start () 171 "Move cursor to the start of previous link. Return point." 172 ;; NOTE: This function is only called by `org-w3m-no-prev-link-p', 173 ;; which itself seems never to be used. Should it be removed? 174 ;; 175 ;; WARNING: This function has not been updated to account for 176 ;; `w3m-image'. See `org-w3m-get-next-link-start'. 177 (catch 'reach 178 (let ((pos (point))) 179 (while (setq pos (previous-single-property-change pos 'w3m-anchor-sequence)) 180 (when (get-text-property pos 'w3m-href-anchor) 181 ;; jump to previous anchor 182 (goto-char pos) 183 ;; return point when current is valid link 184 (throw 'reach nil))))) 185 (point)) 186 187 (defun org-w3m-no-next-link-p () 188 "Whether there is no next link after the cursor. 189 Return t if there is no next link; otherwise, return nil." 190 (save-excursion 191 (equal (point) (org-w3m-get-next-link-start)))) 192 193 (defun org-w3m-no-prev-link-p () 194 "Whether there is no previous link after the cursor. 195 Return t if there is no previous link; otherwise, return nil." 196 ;; NOTE: This function seems never to be used. Should it be removed? 197 (save-excursion 198 (equal (point) (org-w3m-get-prev-link-start)))) 199 200 ;; Install keys into the w3m keymap 201 (defvar w3m-mode-map) 202 (defvar w3m-minor-mode-map) 203 (when (and (boundp 'w3m-mode-map) 204 (keymapp w3m-mode-map)) 205 (define-key w3m-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode) 206 (define-key w3m-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode)) 207 (when (and (boundp 'w3m-minor-mode-map) 208 (keymapp w3m-minor-mode-map)) 209 (define-key w3m-minor-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode) 210 (define-key w3m-minor-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode)) 211 (add-hook 212 'w3m-mode-hook 213 (lambda () 214 (define-key w3m-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode) 215 (define-key w3m-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode))) 216 (add-hook 217 'w3m-minor-mode-hook 218 (lambda () 219 (define-key w3m-minor-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode) 220 (define-key w3m-minor-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode))) 221 222 (provide 'ol-w3m) 223 224 ;;; ol-w3m.el ends here