mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-18 18:05:07 +00:00
Code Issues Releases Activity
8a6a92fe12
emacs/lisp/xwidget.el
Joakim Verona 8a6a92fe12 Improved glitch fix
2015-01-25 23:52:34 +01:00

583 lines
23 KiB
EmacsLisp
Raw Blame History

;;; xwidget.el --- api functions for xwidgets
;; see xwidget.c for more api functions
;;; Commentary:
;;
;;TODO this breaks compilation when we dont have xwidgets
;;(require 'xwidget-internal)
;;TODO model after make-text-button instead!
;;; Code:
(eval-when-compile (require 'cl))
(require 'reporter)
(defcustom xwidget-webkit-scroll-behaviour 'native
"Scroll behaviour of the webkit instance.
'native or 'image."
:group 'xwidgets)
(defun xwidget-insert (pos type title width height)
"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."
(goto-char pos)
(let ((id (make-xwidget (point) (point)
type title width height nil)))
(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 isnt well protected yet and
;;xwidgetp aparently doesnt 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)))
;; (defun xwidget-socket-handler ()
;; "Create plug for socket. TODO."
;; (interactive)
;; (message "socket handler xwidget %S" last-input-event)
;; (let*
;; ((xwidget-event-type (nth 2 last-input-event))
;; (xwidget-id (nth 1 last-input-event)))
;; (cond ( (eq xwidget-event-type 'xembed-ready)
;; (let*
;; ((xembed-id (nth 3 last-input-event)))
;; (message "xembed ready event: %S xw-id:%s" xembed-id xwidget-id)
;; ;;TODO fetch process data from the xwidget. create it, store process info
;; ;;will start emacs/uzbl in a xembed socket when its ready
;; ;; (cond
;; ;; ((eq 3 xwidget-id)
;; ;; (start-process "xembed" "*xembed*" (format "%ssrc/emacs" default-directory) "-q" "--parent-id" (number-to-string xembed-id) ) )
;; ;; ((eq 5 xwidget-id)
;; ;; (start-process "xembed2" "*xembed2*" "uzbl-core" "-s" (number-to-string xembed-id) "http://www.fsf.org" ) )
;; )))))
(defun xwidget-display (xwidget)
"Force XWIDGET to be displayed to create a xwidget_view.
Return the window displaying XWIDGET."
(let* ((buffer (xwidget-buffer xwidget))
(window (display-buffer buffer))
(frame (window-frame window)))
(set-frame-visible frame t)
(redisplay t)
window))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; webkit support
(require 'browse-url)
(require 'image-mode);;for some image-mode alike functionality
(require 'cl-macs);;for flet
;;;###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)
(setq url (url-tidy url))
(if new-session
(xwidget-webkit-new-session url)
(xwidget-webkit-goto-url url))))
;;shims for adapting image mode code to the webkit browser window
(defun xwidget-image-display-size (spec &optional pixels frame)
"Image code adaptor. SPEC PIXELS FRAME like the corresponding `image-mode' fn."
(let ((xwi (xwidget-info (xwidget-at 1))))
(cons (aref xwi 2)
(aref xwi 3))))
(defadvice image-display-size (around image-display-size-for-xwidget
(spec &optional pixels frame)
activate)
"Advice for re-using image mode for xwidget."
(if (eq (car spec) 'xwidget)
(setq ad-return-value (xwidget-image-display-size spec pixels frame))
ad-do-it))
;;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")) )
(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 its offscreen
;;TODO this needs to use callbacks and consider different xw ev 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*")))
(save-excursion
(buffer-disable-undo buf)
(set-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."
(save-excursion
(cond ((buffer-live-p (xwidget-buffer xwidget))
(set-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 send xwidget here
(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)))))
(t (xwidget-log "error: callback called for xwidget with dead buffer")))))
(define-derived-mode xwidget-webkit-mode
special-mode "xwidget-webkit" "xwidget webkit view mode"
(setq buffer-read-only t)
;; Keep track of [vh]scroll when switching buffers
(image-mode-setup-winprops))
(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 1))
nil))
(defun xwidget-webkit-current-session ()
"Either the webkit in the current buffer, or the last one used, which might be nil."
(if (xwidget-at 1)
(xwidget-at 1)
(xwidget-webkit-last-session)))
(defun xwidget-adjust-size-to-content (xw)
"Resize XW to content."
;;xwidgets doesnt 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 its ugly. because:
;; - there is aparently no way to find the active frame other than recursion
;; - the js "for each" construct missbehaved 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. sucks.
)
(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)))
(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 '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 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."
(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."
(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."
(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 isnt visible, but then we dont get the glitch,
;;so silence errors
(ignore-errors
(recenter-top-bottom))
)
(defun xwidget-webkit-adjust-size-to-window ()
"Adjust webkit to window."m
(interactive)
(xwidget-resize ( xwidget-webkit-current-session) (window-pixel-width) (window-pixel-height)))
(defun xwidget-webkit-adjust-size (w h)
"Manualy set webkit size.
Argument W width.
Argument H height."
;;TODO shouldnt 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 (- (caddr (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 " ")
(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 execut.
DEFAULT is the defaultreturn value."
;;notice the fugly "title" hack. it is needed because the webkit api
;;doesnt support returning values. this is a wrapper for the title
;;hack so its easy to remove should webkit someday support JS return
;;values or we find some other way to access the DOM
;;reset webkit title. fugly.
(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))
;; use declare here?
;; (declare-function xwidget-resize-internal "xwidget.c" )
;; check-declare-function?
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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."
;;its still pretty easy to trigger bugs with xwidgets.
;;this function tries to implement a workaround
(interactive)
;; kill xviews who should have been deleted but stull linger
(xwidget-delete-zombies)
;; redraw display otherwise ghost of zombies will remain to haunt the screen
(redraw-display))
;;this is a workaround because I cant find the right place to put it in C
;;seems to work well in practice though
;;(add-hook 'window-configuration-change-hook 'xwidget-cleanup)
(add-hook 'window-configuration-change-hook 'xwidget-delete-zombies)
(defun xwidget-kill-buffer-query-function ()
"Ask beforek illing 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 (current-buffer)))))))
(add-hook 'kill-buffer-query-functions 'xwidget-kill-buffer-query-function)
;;killflash is sadly not reliable yet.
(defvar xwidget-webkit-kill-flash-oneshot t)
(defun xwidget-webkit-kill-flash ()
"Disable the flash plugin in webkit.
This is needed because Flash is non-free and doesnt work reliably
on 64 bit systems and offscreen rendering. Sadly not reliable
yet, so deinstall Flash instead for now."
;;you can only call this once or webkit crashes and takes emacs with it. odd.
(unless xwidget-webkit-kill-flash-oneshot
(xwidget-disable-plugin-for-mime "application/x-shockwave-flash")
(setq xwidget-webkit-kill-flash-oneshot t)))
(xwidget-webkit-kill-flash)
(defun report-xwidget-bug ()
"Report a bug in GNU Emacs about the XWidget branch.
Prompts for bug subject. Leaves you in a mail buffer."
(interactive)
(let ((reporter-prompt-for-summary-p t))
(reporter-submit-bug-report "submit@debbugs.gnu.org" nil nil nil nil
(format "Package: emacs-xwidgets
Please describee xactly whata ctions triggered the bug, and the
precise symptoms of the bug. If you can, give a recipe starting
from `emacs -Q'.
If Emacs crashed, and you have the Emacs process in the gdb
deubbger, please include the output from the following gdb
commands:
`bt full' and `xbacktrace'.
For information about debugging Emacs, please read the file
%s" (expand-file-name "DEBUG" data-directory)))))
(provide 'xwidget)
;;; xwidget.el ends here
Reference in New Issue View Git Blame Copy Permalink