diff options
author | Paul Eggert <eggert@cs.ucla.edu> | 2016-01-30 11:27:34 -0800 |
---|---|---|
committer | Paul Eggert <eggert@cs.ucla.edu> | 2016-01-30 11:27:34 -0800 |
commit | 82b089783e71b2aeef950eaecfe4cbc0735e64a2 (patch) | |
tree | a826c20768071bda95a69b2632718c1641c6d0cc /lisp | |
parent | d27c8078ef766dae3587bc82b70128a70efaa223 (diff) | |
parent | f7dc6d8b5bb318e02a4016d93f8b34de0716f4dc (diff) | |
download | emacs-82b089783e71b2aeef950eaecfe4cbc0735e64a2.tar.gz emacs-82b089783e71b2aeef950eaecfe4cbc0735e64a2.tar.bz2 emacs-82b089783e71b2aeef950eaecfe4cbc0735e64a2.zip |
-
Diffstat (limited to 'lisp')
-rw-r--r-- | lisp/calendar/todo-mode.el | 10 | ||||
-rw-r--r-- | lisp/doc-view.el | 7 | ||||
-rw-r--r-- | lisp/emacs-lisp/pcase.el | 47 | ||||
-rw-r--r-- | lisp/gnus/nnir.el | 6 | ||||
-rw-r--r-- | lisp/htmlfontify.el | 14 | ||||
-rw-r--r-- | lisp/image-mode.el | 43 | ||||
-rw-r--r-- | lisp/international/mule-cmds.el | 2 | ||||
-rw-r--r-- | lisp/international/quail.el | 2 | ||||
-rw-r--r-- | lisp/isearch.el | 13 | ||||
-rw-r--r-- | lisp/net/shr.el | 2 | ||||
-rw-r--r-- | lisp/progmodes/ruby-mode.el | 2 | ||||
-rw-r--r-- | lisp/progmodes/xref.el | 8 | ||||
-rw-r--r-- | lisp/xwidget.el | 580 |
13 files changed, 682 insertions, 54 deletions
diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index 353ca69a1ba..29d8dfcfb7f 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -4654,13 +4654,15 @@ name in `todo-directory'. See also the documentation string of (goto-char (match-beginning 0)) (goto-char (point-max))) (backward-char) - (when (looking-back "\\[\\([^][]+\\)\\]") + (when (looking-back "\\[\\([^][]+\\)\\]" + (line-beginning-position)) (setq cat (match-string 1)) (goto-char (match-beginning 0)) (replace-match "")) ;; If the item ends with a non-comment parenthesis not ;; followed by a period, we lose (but we inherit that ;; problem from the legacy code). + ;; FIXME: fails on multiline comment (when (looking-back "(\\(.*\\)) " (line-beginning-position)) (setq comment (match-string 1)) (replace-match "") @@ -5230,7 +5232,8 @@ Also preserve category display, if applicable." (with-current-buffer buffer (widen) (let ((todo-category-number (cdr (assq 'catnum misc)))) - (todo-category-select)))) + (todo-category-select) + (current-buffer)))) (add-to-list 'desktop-buffer-mode-handlers '(todo-mode . todo-restore-desktop-buffer)) @@ -6579,8 +6582,7 @@ Added to `window-configuration-change-hook' in Todo mode." "Make some settings that apply to multiple Todo modes." (add-to-invisibility-spec 'todo) (setq buffer-read-only t) - (when (and (boundp 'desktop-save-mode) desktop-save-mode) - (setq-local desktop-save-buffer 'todo-desktop-save-buffer)) + (setq-local desktop-save-buffer 'todo-desktop-save-buffer) (when (boundp 'hl-line-range-function) (setq-local hl-line-range-function (lambda() (save-excursion diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 286811358fb..06cf8dcef3a 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -1714,7 +1714,8 @@ If BACKWARD is non-nil, jump to the previous match." ;; window-parameters in the window-state(s) and then restoring this ;; window-state should call us back (to interpret/use those parameters). (doc-view-goto-page page) - (when slice (apply 'doc-view-set-slice slice))))) + (when slice (apply 'doc-view-set-slice slice)) + (current-buffer)))) (add-to-list 'desktop-buffer-mode-handlers '(doc-view-mode . doc-view-restore-desktop-buffer)) @@ -1788,9 +1789,7 @@ toggle between displaying the document or editing it as text. nil t) (add-hook 'clone-indirect-buffer-hook 'doc-view-clone-buffer-hook nil t) (add-hook 'kill-buffer-hook 'doc-view-kill-proc nil t) - (when (and (boundp 'desktop-save-mode) - desktop-save-mode) - (setq-local desktop-save-buffer 'doc-view-desktop-save-buffer)) + (setq-local desktop-save-buffer 'doc-view-desktop-save-buffer) (remove-overlays (point-min) (point-max) 'doc-view t) ;Just in case. ;; Keep track of display info ([vh]scroll, page number, overlay, diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 3b224814e9e..549ee96dd5f 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -107,12 +107,36 @@ ;;;###autoload (defmacro pcase (exp &rest cases) - "Eval EXP and perform ML-style pattern matching on that value. + "Evaluate EXP and attempt to match it against structural patterns. CASES is a list of elements of the form (PATTERN CODE...). -Patterns can take the following forms: +A structural PATTERN describes a template that identifies a class +of values. For example, the pattern `(,foo ,bar) matches any +two element list, binding its elements to symbols named `foo' and +`bar' -- in much the same way that `cl-destructuring-bind' would. + +A significant difference from `cl-destructuring-bind' is that, if +a pattern match fails, the next case is tried until either a +succesful match is found or there are no more cases. + +Another difference is that pattern elements may be backquoted, +meaning they must match exactly: The pattern \\='(foo bar) +matches only against two element lists containing the symbols +`foo' and `bar' in that order. (As a short-hand, atoms always +match themselves, such as numbers or strings, and need not be +quoted). + +Lastly, a pattern can be logical, such as (pred numberp), that +matches any number-like element; or the symbol `_', that matches +anything. Also, when patterns are backquoted, a comma may be +used to introduce logical patterns inside backquoted patterns. + +The complete list of standard patterns is as follows: + _ matches anything. SYMBOL matches anything and binds it to SYMBOL. + If a SYMBOL is used twice in the same pattern + the second occurrence becomes an `eq'uality test. (or PAT...) matches if any of the patterns matches. (and PAT...) matches if all the patterns match. \\='VAL matches if the object is `equal' to VAL. @@ -122,23 +146,18 @@ Patterns can take the following forms: (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (let PAT EXP) matches if EXP matches PAT. (app FUN PAT) matches if FUN applied to the object matches PAT. -If a SYMBOL is used twice in the same pattern (i.e. the pattern is -\"non-linear\"), then the second occurrence is turned into an `eq'uality test. -FUN can take the form +Additional patterns can be defined using `pcase-defmacro'. + +The FUN argument in the `app' pattern may have the following forms: SYMBOL or (lambda ARGS BODY) in which case it's called with one argument. (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument which is the value being matched. -So a FUN of the form SYMBOL is equivalent to one of the form (FUN). +So a FUN of the form SYMBOL is equivalent to (FUN). FUN can refer to variables bound earlier in the pattern. -E.g. you can match pairs where the cdr is larger than the car with a pattern -like \\=`(,a . ,(pred (< a))) or, with more checks: -\\=`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a)))) -FUN is assumed to be pure, i.e. it can be dropped if its result is not used, -and two identical calls can be merged into one. - -Additional patterns can be defined via `pcase-defmacro'. -Currently, the following patterns are provided this way:" + +See Info node `(elisp) Pattern matching case statement' in the +Emacs Lisp manual for more information and examples." (declare (indent 1) (debug (form &rest (pcase-PAT body)))) ;; We want to use a weak hash table as a cache, but the key will unavoidably ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 183e1443dac..560ba8ad2e5 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -822,8 +822,10 @@ skips all prompting." (deffoo nnir-request-update-mark (group article mark) (let ((artgroup (nnir-article-group article)) (artnumber (nnir-article-number article))) - (when (and artgroup artnumber) - (gnus-request-update-mark artgroup artnumber mark)))) + (or (and artgroup + artnumber + (gnus-request-update-mark artgroup artnumber mark)) + mark))) (deffoo nnir-request-set-mark (group actions &optional server) (nnir-possibly-change-group group server) diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 964d7440332..431300c81c2 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -1001,7 +1001,7 @@ merged by the user - `hfy-flatten-style' should do this." (append parent (hfy-face-to-style-i - (hfy-face-attr-for-class v hfy-display-class)) )))) + (hfy-face-attr-for-class v hfy-display-class)))))) (setq this (if val (case key (:family (hfy-family val)) @@ -1020,7 +1020,7 @@ merged by the user - `hfy-flatten-style' should do this." (:italic (hfy-slant 'italic)))))) (setq that (hfy-face-to-style-i next)) ;;(lwarn t :warning "%S => %S" fn (nconc this that parent)) - (nconc this that parent))) ) + (nconc this parent that))) ) (defun hfy-size-to-int (spec) "Convert SPEC, a CSS font-size specifier, to an Emacs :height attribute value. @@ -1058,13 +1058,19 @@ haven't encountered them yet. Returns a `hfy-style-assoc'." (nconc r (hfy-size (if x (round n) (* n 1.0)))) )) (defun hfy-face-resolve-face (fn) + "For FN return a face specification. +FN may be either a face or a face specification. If the latter, +then the specification is returned unchanged." (cond ((facep fn) (hfy-face-attr-for-class fn hfy-display-class)) + ;; FIXME: is this necessary? Faces can be symbols, but + ;; not symbols refering to other symbols? ((and (symbolp fn) (facep (symbol-value fn))) - (hfy-face-attr-for-class (symbol-value fn) hfy-display-class)) - (t nil))) + (hfy-face-attr-for-class + (symbol-value fn) hfy-display-class)) + (t fn))) (defun hfy-face-to-style (fn) diff --git a/lisp/image-mode.el b/lisp/image-mode.el index e677dd0d0e7..e549b49001e 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -153,6 +153,8 @@ otherwise it defaults to t, used for times when the buffer is not displayed." (selected-window)))) (declare-function image-size "image.c" (spec &optional pixels frame)) +(declare-function xwidget-info "xwidget.c" (xwidget)) +(declare-function xwidget-at "xwidget.el" (pos)) (defun image-display-size (spec &optional pixels frame) "Wrapper around `image-size', handling slice display properties. @@ -160,24 +162,29 @@ Like `image-size', the return value is (WIDTH . HEIGHT). WIDTH and HEIGHT are in canonical character units if PIXELS is nil, and in pixel units if PIXELS is non-nil. -If SPEC is an image display property, this function is equivalent -to `image-size'. If SPEC is a list of properties containing -`image' and `slice' properties, return the display size taking -the slice property into account. If the list contains `image' -but not `slice', return the `image-size' of the specified image." - (if (eq (car spec) 'image) - (image-size spec pixels frame) - (let ((image (assoc 'image spec)) - (slice (assoc 'slice spec))) - (cond ((and image slice) - (if pixels - (cons (nth 3 slice) (nth 4 slice)) - (cons (/ (float (nth 3 slice)) (frame-char-width frame)) - (/ (float (nth 4 slice)) (frame-char-height frame))))) - (image - (image-size image pixels frame)) - (t - (error "Invalid image specification: %s" spec)))))) +If SPEC is an image display property, this function is equivalent to +`image-size'. If SPEC represents an xwidget object, defer to `xwidget-info'. +If SPEC is a list of properties containing `image' and `slice' properties, +return the display size taking the slice property into account. If the list +contains `image' but not `slice', return the `image-size' of the specified +image." + (cond ((eq (car spec) 'xwidget) + (let ((xwi (xwidget-info (xwidget-at (point-min))))) + (cons (aref xwi 2) (aref xwi 3)))) + ((eq (car spec) 'image) + (image-size spec pixels frame)) + (t (let ((image (assoc 'image spec)) + (slice (assoc 'slice spec))) + (cond ((and image slice) + (if pixels + (cons (nth 3 slice) (nth 4 slice)) + (cons (/ (float (nth 3 slice)) (frame-char-width frame)) + (/ (float (nth 4 slice)) + (frame-char-height frame))))) + (image + (image-size image pixels frame)) + (t + (error "Invalid image specification: %s" spec))))))) (defun image-forward-hscroll (&optional n) "Scroll image in current window to the left by N character widths. diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 79e9c7b4adc..2df847acc25 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -2119,7 +2119,7 @@ See `set-language-info-alist' for use in programs." (with-current-buffer standard-output (insert language-name " language environment\n\n") (if (stringp doc) - (insert doc "\n\n")) + (insert (substitute-command-keys doc) "\n\n")) (condition-case nil (let ((str (eval (get-language-info language-name 'sample-text)))) (if (stringp str) diff --git a/lisp/international/quail.el b/lisp/international/quail.el index 75cb7f787df..f5e390278ca 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -2516,7 +2516,7 @@ package to describe." ")\n\n") (save-restriction (narrow-to-region (point) (point)) - (insert (quail-docstring)) + (insert (substitute-command-keys (quail-docstring))) (goto-char (point-min)) (with-syntax-table emacs-lisp-mode-syntax-table (while (re-search-forward "\\\\<\\sw\\(\\sw\\|\\s_\\)+>" nil t) diff --git a/lisp/isearch.el b/lisp/isearch.el index e636ccc0d22..c36f4631549 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -2647,10 +2647,11 @@ the word mode." "Non-default value overrides the behavior of `isearch-search-fun-default'. This variable's value should be a function, which will be called with no arguments, and should return a function that takes three -arguments: STRING, BOUND, and NOERROR. +arguments: STRING, BOUND, and NOERROR. See `re-search-forward' +for the meaning of BOUND and NOERROR arguments. This returned function will be used by `isearch-search-string' to -search for the first occurrence of STRING or its translation.") +search for the first occurrence of STRING.") (defun isearch-search-fun () "Return the function to use for the search. @@ -2695,8 +2696,14 @@ Can be changed via `isearch-search-fun-function' for special needs." (defun isearch-search-string (string bound noerror) "Search for the first occurrence of STRING or its translation. +STRING's characters are translated using `translation-table-for-input' +if that is non-nil. If found, move point to the end of the occurrence, -update the match data, and return point." +update the match data, and return point. +An optional second argument bounds the search; it is a buffer position. +The match found must not extend after that position. +Optional third argument, if t, means if fail just return nil (no error). + If not nil and not t, move to limit of search and return nil." (let* ((func (isearch-search-fun)) (pos1 (save-excursion (funcall func string bound noerror))) pos2) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 290a6422bd7..ab416146595 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1619,7 +1619,7 @@ The preference is a float determined from `shr-prefer-media-type'." (defun shr-table-body (dom) (let ((tbodies (seq-filter (lambda (child) (eq (dom-tag child) 'tbody)) - (dom-children dom)))) + (dom-non-text-children dom)))) (cond ((null tbodies) dom) diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index 53f8a6bb4c0..e3fe315f3bd 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -102,7 +102,7 @@ (eval-and-compile (defconst ruby-here-doc-beg-re - "\\(<\\)<\\(-\\)?\\(\\([a-zA-Z0-9_]+\\)\\|[\"]\\([^\"]+\\)[\"]\\|[']\\([^']+\\)[']\\)" + "\\(<\\)<\\([~-]\\)?\\(\\([a-zA-Z0-9_]+\\)\\|[\"]\\([^\"]+\\)[\"]\\|[']\\([^']+\\)[']\\)" "Regexp to match the beginning of a heredoc.") (defconst ruby-expression-expansion-re diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 2bccd857576..d32da371771 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -861,7 +861,13 @@ tools are used, and when." (cl-assert (directory-name-p dir)) (require 'semantic/symref) (defvar semantic-symref-tool) - (let* ((default-directory dir) + + ;; Some symref backends use `ede-project-root-directory' as the root + ;; directory for the search, rather than `default-directory'. Since + ;; the caller has specified `dir', we bind `ede-minor-mode' to nil + ;; to force the backend to use `default-directory'. + (let* ((ede-minor-mode nil) + (default-directory dir) (semantic-symref-tool 'detect) (res (semantic-symref-find-references-by-name symbol 'subdirs)) (hits (and res (oref res hit-lines))) diff --git a/lisp/xwidget.el b/lisp/xwidget.el new file mode 100644 index 00000000000..f184eb31dbb --- /dev/null +++ b/lisp/xwidget.el @@ -0,0 +1,580 @@ +;;; xwidget.el --- api functions for xwidgets -*- lexical-binding: t -*- +;; +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. +;; +;; Author: Joakim Verona (joakim@verona.se) +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs 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, or +;; (at your option) any later version. + +;; GNU Emacs 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: +;; +;; See xwidget.c for more api functions. + +;; TODO this breaks compilation when we don't have xwidgets. +;;(require 'xwidget-internal) + +;;; Code: + +(require 'cl-lib) +(require 'bookmark) + +(defcustom xwidget-webkit-scroll-behaviour 'native + "Scroll behaviour of the webkit instance. +'native or 'image." + :version "25.1" + :group 'frames ; TODO add xwidgets group if more options are added + :type '(choice (const native) (const image))) + +(declare-function make-xwidget "xwidget.c" + (beg end type title width height arguments &optional buffer)) +(declare-function xwidget-set-adjustment "xwidget.c" + (xwidget axis relative value)) +(declare-function xwidget-buffer "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-get-title "xwidget.c" (xwidget)) +(declare-function xwidget-size-request "xwidget.c" (xwidget)) +(declare-function xwidget-resize "xwidget.c" (xwidget new-width new-height)) +(declare-function xwidget-webkit-execute-script "xwidget.c" (xwidget script)) +(declare-function xwidget-webkit-goto-uri "xwidget.c" (xwidget uri)) +(declare-function xwidget-plist "xwidget.c" (xwidget)) +(declare-function set-xwidget-plist "xwidget.c" (xwidget plist)) +(declare-function xwidget-view-window "xwidget.c" (xwidget-view)) +(declare-function xwidget-view-model "xwidget.c" (xwidget-view)) +(declare-function delete-xwidget-view "xwidget.c" (xwidget-view)) +(declare-function get-buffer-xwidgets "xwidget.c" (buffer)) + +(defun xwidget-insert (pos type title width height &optional args) + "Insert an xwidget at POS. +given ID, TYPE, TITLE WIDTH and +HEIGHT in the current buffer. + +Return ID + +see `make-xwidget' for types suitable for TYPE. +Optional argument ARGS usage depends on the xwidget." + (goto-char pos) + (let ((id (make-xwidget (point) (point) + type title width height args))) + (put-text-property (point) (+ 1 (point)) + 'display (list 'xwidget ':xwidget id)) + id)) + +(defun xwidget-at (pos) + "Return xwidget at POS." + ;; TODO this function is a bit tedious because the C layer isn't well + ;; protected yet and xwidgetp apparently doesn't work yet. + (let* ((disp (get-text-property pos 'display)) + (xw (car (cdr (cdr disp))))) + ;;(if (xwidgetp xw) xw nil) + (if (equal 'xwidget (car disp)) xw))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; webkit support +(require 'browse-url) +(require 'image-mode);;for some image-mode alike functionality + +;;;###autoload +(defun xwidget-webkit-browse-url (url &optional new-session) + "Ask xwidget-webkit to browse URL. +NEW-SESSION specifies whether to create a new xwidget-webkit session. URL +defaults to the string looking like a url around the cursor position." + (interactive (progn + (require 'browse-url) + (browse-url-interactive-arg "xwidget-webkit URL: " + ;;(xwidget-webkit-current-url) + ))) + (when (stringp url) + (if new-session + (xwidget-webkit-new-session url) + (xwidget-webkit-goto-url url)))) + +;;todo. +;; - check that the webkit support is compiled in +(defvar xwidget-webkit-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "g" 'xwidget-webkit-browse-url) + (define-key map "a" 'xwidget-webkit-adjust-size-dispatch) + (define-key map "b" 'xwidget-webkit-back) + (define-key map "r" 'xwidget-webkit-reload) + (define-key map "t" (lambda () (interactive) (message "o"))) ;FIXME: ?!? + (define-key map "\C-m" 'xwidget-webkit-insert-string) + (define-key map "w" 'xwidget-webkit-current-url) + + ;;similar to image mode bindings + (define-key map (kbd "SPC") 'xwidget-webkit-scroll-up) + (define-key map (kbd "DEL") 'xwidget-webkit-scroll-down) + + (define-key map [remap scroll-up] 'xwidget-webkit-scroll-up) + (define-key map [remap scroll-up-command] 'xwidget-webkit-scroll-up) + + (define-key map [remap scroll-down] 'xwidget-webkit-scroll-down) + (define-key map [remap scroll-down-command] 'xwidget-webkit-scroll-down) + + (define-key map [remap forward-char] 'xwidget-webkit-scroll-forward) + (define-key map [remap backward-char] 'xwidget-webkit-scroll-backward) + (define-key map [remap right-char] 'xwidget-webkit-scroll-forward) + (define-key map [remap left-char] 'xwidget-webkit-scroll-backward) + ;; (define-key map [remap previous-line] 'image-previous-line) + ;; (define-key map [remap next-line] 'image-next-line) + + ;; (define-key map [remap move-beginning-of-line] 'image-bol) + ;; (define-key map [remap move-end-of-line] 'image-eol) + ;; (define-key map [remap beginning-of-buffer] 'image-bob) + ;; (define-key map [remap end-of-buffer] 'image-eob) + map) + "Keymap for `xwidget-webkit-mode'.") + +(defun xwidget-webkit-scroll-up () + "Scroll webkit up,either native or like image mode." + (interactive) + (if (eq xwidget-webkit-scroll-behaviour 'native) + (xwidget-set-adjustment (xwidget-webkit-last-session) 'vertical t 50) + (image-scroll-up))) + +(defun xwidget-webkit-scroll-down () + "Scroll webkit down,either native or like image mode." + (interactive) + (if (eq xwidget-webkit-scroll-behaviour 'native) + (xwidget-set-adjustment (xwidget-webkit-last-session) 'vertical t -50) + (image-scroll-down))) + +(defun xwidget-webkit-scroll-forward () + "Scroll webkit forward,either native or like image mode." + (interactive) + (if (eq xwidget-webkit-scroll-behaviour 'native) + (xwidget-set-adjustment (xwidget-webkit-last-session) 'horizontal t 50) + (xwidget-webkit-scroll-forward))) + +(defun xwidget-webkit-scroll-backward () + "Scroll webkit backward,either native or like image mode." + (interactive) + (if (eq xwidget-webkit-scroll-behaviour 'native) + (xwidget-set-adjustment (xwidget-webkit-last-session) 'horizontal t -50) + (xwidget-webkit-scroll-backward))) + + +;; The xwidget event needs to go into a higher level handler +;; since the xwidget can generate an event even if it's offscreen. +;; TODO this needs to use callbacks and consider different xwidget event types. +(define-key (current-global-map) [xwidget-event] #'xwidget-event-handler) +(defun xwidget-log (&rest msg) + "Log MSG to a buffer." + (let ((buf (get-buffer-create " *xwidget-log*"))) + (with-current-buffer buf + (insert (apply #'format msg)) + (insert "\n")))) + +(defun xwidget-event-handler () + "Receive xwidget event." + (interactive) + (xwidget-log "stuff happened to xwidget %S" last-input-event) + (let* + ((xwidget-event-type (nth 1 last-input-event)) + (xwidget (nth 2 last-input-event)) + ;;(xwidget-callback (xwidget-get xwidget 'callback)) + ;;TODO stopped working for some reason + ) + ;;(funcall xwidget-callback xwidget xwidget-event-type) + (message "xw callback %s" xwidget) + (funcall 'xwidget-webkit-callback xwidget xwidget-event-type))) + +(defun xwidget-webkit-callback (xwidget xwidget-event-type) + "Callback for xwidgets. +XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." + (if (not (buffer-live-p (xwidget-buffer xwidget))) + (xwidget-log + "error: callback called for xwidget with dead buffer") + (with-current-buffer (xwidget-buffer xwidget) + (let* ((strarg (nth 3 last-input-event))) + (cond ((eq xwidget-event-type 'document-load-finished) + (xwidget-log "webkit finished loading: '%s'" + (xwidget-webkit-get-title xwidget)) + ;;TODO - check the native/internal scroll + ;;(xwidget-adjust-size-to-content xwidget) + (xwidget-webkit-adjust-size-dispatch) ;;TODO xwidget arg + (rename-buffer (format "*xwidget webkit: %s *" + (xwidget-webkit-get-title xwidget))) + (pop-to-buffer (current-buffer))) + ((eq xwidget-event-type + 'navigation-policy-decision-requested) + (if (string-match ".*#\\(.*\\)" strarg) + (xwidget-webkit-show-id-or-named-element + xwidget + (match-string 1 strarg)))) + (t (xwidget-log "unhandled event:%s" xwidget-event-type))))))) + +(defvar bookmark-make-record-function) +(define-derived-mode xwidget-webkit-mode + special-mode "xwidget-webkit" "Xwidget webkit view mode." + (setq buffer-read-only t) + (setq-local bookmark-make-record-function + #'xwidget-webkit-bookmark-make-record) + ;; Keep track of [vh]scroll when switching buffers + (image-mode-setup-winprops)) + +(defun xwidget-webkit-bookmark-make-record () + "Integrate Emacs bookmarks with the webkit xwidget." + (nconc (bookmark-make-record-default t t) + `((page . ,(xwidget-webkit-current-url)) + (handler . (lambda (bmk) (browse-url + (bookmark-prop-get bmk 'page))))))) + + +(defvar xwidget-webkit-last-session-buffer nil) + +(defun xwidget-webkit-last-session () + "Last active webkit, or nil." + (if (buffer-live-p xwidget-webkit-last-session-buffer) + (with-current-buffer xwidget-webkit-last-session-buffer + (xwidget-at (point-min))) + nil)) + +(defun xwidget-webkit-current-session () + "Either the webkit in the current buffer, or the last one used. +The latter might be nil." + (or (xwidget-at (point-min)) (xwidget-webkit-last-session))) + +(defun xwidget-adjust-size-to-content (xw) + "Resize XW to content." + ;; xwidgets doesn't support widgets that have their own opinions about + ;; size well, yet this reads the desired size and resizes the Emacs + ;; allocated area accordingly. + (let ((size (xwidget-size-request xw))) + (xwidget-resize xw (car size) (cadr size)))) + + +(defvar xwidget-webkit-activeelement-js" +function findactiveelement(doc){ +//alert(doc.activeElement.value); + if(doc.activeElement.value != undefined){ + return doc.activeElement; + }else{ + // recurse over the child documents: + var frames = doc.getElementsByTagName('frame'); + for (var i = 0; i < frames.length; i++) + { + var d = frames[i].contentDocument; + var rv = findactiveelement(d); + if(rv != undefined){ + return rv; + } + } + } + return undefined; +}; + + +" + + "javascript that finds the active element." + ;; Yes it's ugly, because: + ;; - there is apparently no way to find the active frame other than recursion + ;; - the js "for each" construct misbehaved on the "frames" collection + ;; - a window with no frameset still has frames.length == 1, but + ;; frames[0].document.activeElement != document.activeElement + ;;TODO the activeelement type needs to be examined, for iframe, etc. + ) + +(defun xwidget-webkit-insert-string (xw str) + "Insert string in the active field in the webkit. +Argument XW webkit. +Argument STR string." + ;; Read out the string in the field first and provide for edit. + (interactive + (let* ((xww (xwidget-webkit-current-session)) + + (field-value + (progn + (xwidget-webkit-execute-script xww xwidget-webkit-activeelement-js) + (xwidget-webkit-execute-script-rv + xww + "findactiveelement(document).value;"))) + (field-type (xwidget-webkit-execute-script-rv + xww + "findactiveelement(document).type;"))) + (list xww + (cond ((equal "text" field-type) + (read-string "text:" field-value)) + ((equal "password" field-type) + (read-passwd "password:" nil field-value)) + ((equal "textarea" field-type) + (xwidget-webkit-begin-edit-textarea xww field-value)))))) + (xwidget-webkit-execute-script + xw + (format "findactiveelement(document).value='%s'" str))) + +(defvar xwidget-xwbl) +(defun xwidget-webkit-begin-edit-textarea (xw text) + "Start editing of a webkit text area. +XW is the xwidget identifier, TEXT is retrieved from the webkit." + (switch-to-buffer + (generate-new-buffer "textarea")) + + (set (make-local-variable 'xwidget-xwbl) xw) + (insert text)) + +(defun xwidget-webkit-end-edit-textarea () + "End editing of a webkit text area." + (interactive) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (replace-match "\\n" nil t)) + (xwidget-webkit-execute-script + xwidget-xwbl + (format "findactiveelement(document).value='%s'" + (buffer-substring (point-min) (point-max)))) + ;;TODO convert linefeed to \n + ) + +(defun xwidget-webkit-show-named-element (xw element-name) + "Make named-element show. for instance an anchor. +Argument XW is the xwidget. +Argument ELEMENT-NAME is the element name to display in the webkit xwidget." + (interactive (list (xwidget-webkit-current-session) + (read-string "element name:"))) + ;;TODO since an xwidget is an Emacs object, it is not trivial to do + ;; some things that are taken for granted in a normal browser. + ;; scrolling an anchor/named-element into view is one such thing. + ;; This function implements a proof-of-concept for this. Problems + ;; remaining: - The selected window is scrolled but this is not + ;; always correct - This needs to be interfaced into browse-url + ;; somehow. The tricky part is that we need to do this in two steps: + ;; A: load the base url, wait for load signal to arrive B: navigate + ;; to the anchor when the base url is finished rendering + + ;; This part figures out the Y coordinate of the element + (let ((y (string-to-number + (xwidget-webkit-execute-script-rv + xw + (format + "document.getElementsByName('%s')[0].getBoundingClientRect().top" + element-name) + 0)))) + ;; Now we need to tell Emacs to scroll the element into view. + (xwidget-log "scroll: %d" y) + (set-window-vscroll (selected-window) y t))) + +(defun xwidget-webkit-show-id-element (xw element-id) + "Make id-element show. for instance an anchor. +Argument XW is the webkit xwidget. +Argument ELEMENT-ID is the id of the element to show." + (interactive (list (xwidget-webkit-current-session) + (read-string "element id:"))) + (let ((y (string-to-number + (xwidget-webkit-execute-script-rv + xw + (format "document.getElementById('%s').getBoundingClientRect().top" + element-id) + 0)))) + ;; Now we need to tell Emacs to scroll the element into view. + (xwidget-log "scroll: %d" y) + (set-window-vscroll (selected-window) y t))) + +(defun xwidget-webkit-show-id-or-named-element (xw element-id) + "Make id-element show. for instance an anchor. +Argument XW is the webkit xwidget. +Argument ELEMENT-ID is either a name or an element id." + (interactive (list (xwidget-webkit-current-session) + (read-string "element id:"))) + (let* ((y1 (string-to-number + (xwidget-webkit-execute-script-rv + xw + (format "document.getElementsByName('%s')[0].getBoundingClientRect().top" element-id) + "0"))) + (y2 (string-to-number + (xwidget-webkit-execute-script-rv + xw + (format "document.getElementById('%s').getBoundingClientRect().top" element-id) + "0"))) + (y3 (max y1 y2))) + ;; Now we need to tell Emacs to scroll the element into view. + (xwidget-log "scroll: %d" y3) + (set-window-vscroll (selected-window) y3 t))) + +(defun xwidget-webkit-adjust-size-to-content () + "Adjust webkit to content size." + (interactive) + (xwidget-adjust-size-to-content (xwidget-webkit-current-session))) + +(defun xwidget-webkit-adjust-size-dispatch () + "Adjust size according to mode." + (interactive) + (if (eq xwidget-webkit-scroll-behaviour 'native) + (xwidget-webkit-adjust-size-to-window) + (xwidget-webkit-adjust-size-to-content)) + ;; The recenter is intended to correct a visual glitch. + ;; It errors out if the buffer isn't visible, but then we don't get + ;; the glitch, so silence errors. + (ignore-errors + (recenter-top-bottom)) + ) + +(defun xwidget-webkit-adjust-size-to-window () + "Adjust webkit to window." + (interactive) + (xwidget-resize (xwidget-webkit-current-session) (window-pixel-width) + (window-pixel-height))) + +(defun xwidget-webkit-adjust-size (w h) + "Manually set webkit size. +Argument W width. +Argument H height." + ;; TODO shouldn't be tied to the webkit xwidget + (interactive "nWidth:\nnHeight:\n") + (xwidget-resize (xwidget-webkit-current-session) w h)) + +(defun xwidget-webkit-fit-width () + "Adjust width of webkit to window width." + (interactive) + (xwidget-webkit-adjust-size (- (nth 2 (window-inside-pixel-edges)) + (car (window-inside-pixel-edges))) + 1000)) + +(defun xwidget-webkit-new-session (url) + "Create a new webkit session buffer with URL." + (let* + ((bufname (generate-new-buffer-name "*xwidget-webkit*")) + xw) + (setq xwidget-webkit-last-session-buffer (switch-to-buffer + (get-buffer-create bufname))) + (insert " 'a' adjusts the xwidget size.") + (setq xw (xwidget-insert 1 'webkit-osr bufname 1000 1000)) + (xwidget-put xw 'callback 'xwidget-webkit-callback) + (xwidget-webkit-mode) + (xwidget-webkit-goto-uri (xwidget-webkit-last-session) url))) + + +(defun xwidget-webkit-goto-url (url) + "Goto URL." + (if (xwidget-webkit-current-session) + (progn + (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url)) + (xwidget-webkit-new-session url))) + +(defun xwidget-webkit-back () + "Back in history." + (interactive) + (xwidget-webkit-execute-script (xwidget-webkit-current-session) + "history.go(-1);")) + +(defun xwidget-webkit-reload () + "Reload current url." + (interactive) + (xwidget-webkit-execute-script (xwidget-webkit-current-session) + "history.go(0);")) + +(defun xwidget-webkit-current-url () + "Get the webkit url. place it on kill ring." + (interactive) + (let* ((rv (xwidget-webkit-execute-script-rv (xwidget-webkit-current-session) + "document.URL")) + (url (kill-new (or rv "")))) + (message "url: %s" url) + url)) + +(defun xwidget-webkit-execute-script-rv (xw script &optional default) + "Same as 'xwidget-webkit-execute-script' but but with return value. +XW is the webkit instance. SCRIPT is the script to execute. +DEFAULT is the defaultreturn value." + ;; Notice the ugly "title" hack. It is needed because the Webkit + ;; API at the time of writing didn't support returning values. This + ;; is a wrapper for the title hack so it's easy to remove should + ;; Webkit someday support JS return values or we find some other way + ;; to access the DOM. + + ;; Reset webkit title. Not very nice. + (let* ((emptytag "titlecantbewhitespaceohthehorror") + title) + (xwidget-webkit-execute-script xw (format "document.title=\"%s\";" + (or default emptytag))) + (xwidget-webkit-execute-script xw (format "document.title=%s;" script)) + (setq title (xwidget-webkit-get-title xw)) + (if (equal emptytag title) + (setq title "")) + (unless title + (setq title default)) + title)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun xwidget-webkit-get-selection () + "Get the webkit selection." + (xwidget-webkit-execute-script-rv (xwidget-webkit-current-session) + "window.getSelection().toString();")) + +(defun xwidget-webkit-copy-selection-as-kill () + "Get the webkit selection and put it on the kill ring." + (interactive) + (kill-new (xwidget-webkit-get-selection))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Xwidget plist management (similar to the process plist functions) + +(defun xwidget-get (xwidget propname) + "Return the value of XWIDGET' PROPNAME property. +This is the last value stored with `(xwidget-put XWIDGET PROPNAME VALUE)'." + (plist-get (xwidget-plist xwidget) propname)) + +(defun xwidget-put (xwidget propname value) + "Change XWIDGET' PROPNAME property to VALUE. +It can be retrieved with `(xwidget-get XWIDGET PROPNAME)'." + (set-xwidget-plist xwidget + (plist-put (xwidget-plist xwidget) propname value))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar xwidget-view-list) ; xwidget.c +(defvar xwidget-list) ; xwidget.c + +(defun xwidget-delete-zombies () + "Helper for `xwidget-cleanup'." + (dolist (xwidget-view xwidget-view-list) + (when (or (not (window-live-p (xwidget-view-window xwidget-view))) + (not (memq (xwidget-view-model xwidget-view) + xwidget-list))) + (delete-xwidget-view xwidget-view)))) + +(defun xwidget-cleanup () + "Delete zombie xwidgets." + ;; During development it was sometimes easy to wind up with zombie + ;; xwidget instances. + ;; This function tries to implement a workaround should it occur again. + (interactive) + ;; Kill xviews that should have been deleted but still linger. + (xwidget-delete-zombies) + ;; Redraw display otherwise ghost of zombies will remain to haunt the screen + (redraw-display)) + +(defun xwidget-kill-buffer-query-function () + "Ask before killing a buffer that has xwidgets." + (let ((xwidgets (get-buffer-xwidgets (current-buffer)))) + (or (not xwidgets) + (not (memq t (mapcar #'xwidget-query-on-exit-flag xwidgets))) + (yes-or-no-p + (format "Buffer %S has xwidgets; kill it? " (buffer-name)))))) + +(when (featurep 'xwidget-internal) + (add-hook 'kill-buffer-query-functions #'xwidget-kill-buffer-query-function) + ;; This would have felt better in C, but this seems to work well in + ;; practice though. + (add-hook 'window-configuration-change-hook #'xwidget-delete-zombies)) + +(provide 'xwidget) +;;; xwidget.el ends here |