diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/emacs-parallel/README.org | 147 | ||||
| -rw-r--r-- | lisp/emacs-parallel/parallel-remote.el | 81 | ||||
| -rw-r--r-- | lisp/emacs-parallel/parallel-xwidget.el | 59 | ||||
| -rw-r--r-- | lisp/emacs-parallel/parallel.el | 310 | ||||
| -rw-r--r-- | lisp/net/browse-url.el | 13 | ||||
| -rw-r--r-- | lisp/xwidget.el | 513 |
6 files changed, 1121 insertions, 2 deletions
diff --git a/lisp/emacs-parallel/README.org b/lisp/emacs-parallel/README.org new file mode 100644 index 00000000000..743050518be --- /dev/null +++ b/lisp/emacs-parallel/README.org @@ -0,0 +1,147 @@ +* Emacs Parallel + + Emacs Parallel is yet another library to simulate parallel + computations in Emacs (because it lacks threads support in Elisp). + +* STARTED HowTo + + You can execute a simple function a retrive the result like this: + #+BEGIN_SRC emacs-lisp + (parallel-get-result (parallel-start (lambda () (* 42 42)))) + ⇒ 1764 + #+END_SRC + + Though you won't benefit from the parallelism because + ~parallel-get-result~ is blocking, that is it waits for the function + to be executed. + + So you can use define a callback to be called when the function is + finished: + #+BEGIN_SRC emacs-lisp + (parallel-start (lambda () (sleep-for 4.2) "Hello World") + :post-exec (lambda (results _status) + (message (first results)))) + ⊣ Hello World + #+END_SRC + + Here, why ~(first results)~ and not ~result~? Because you can send + data from the remote instance while it's running with + ~parallel-remote-send~: + #+BEGIN_SRC emacs-lisp + (parallel-start (lambda () + (parallel-remote-send "Hello") + (sleep-for 4.2) + "World") + :post-exec (lambda (results _status) + (message "%s" + (mapconcat #'identity (reverse results) " ")))) + ⊣ Hello World + #+END_SRC + As you may have noticed the results are pushed in a list, so the + first element is the result returned by the function called, the + second is the last piece of data send, and so on... + + And of course you can execute some code when you receive data from + the remote instance: + #+BEGIN_SRC emacs-lisp + (parallel-start (lambda () + (parallel-remote-send 42) + (sleep-for 4.2) ; heavy computation to compute PI + pi) + :on-event (lambda (data) + (message "Received %S" data))) + ⊣ Received 42 + ⊣ Received 3.141592653589793 + #+END_SRC + + Because the function is executed in another Emacs instance (in Batch + Mode by default), the environment isn't the same. However you can + send some data with the ~env~ parameter: + #+BEGIN_SRC emacs-lisp + (let ((a 42) + (b 12)) + (parallel-get-result (parallel-start (lambda (a b) (+ a b)) + :env (list a b)))) + ⇒ 54 + #+END_SRC + + By default, the remote Emacs instance is exited when the function is + executed, but you can keep it running with the + ~:continue-when-executed~ option and send new code to be executed + with ~parellel-send~. + #+BEGIN_SRC emacs-lisp + (let ((task (parallel-start (lambda () 42) + :continue-when-executed t))) + (sleep-for 4.2) + (parallel-send task (lambda () (setq parallel-continue-when-executed nil) 12)) + (parallel-get-results task)) + ⇒ (12 42) + #+END_SRC + + As you can see, to stop the remote instance you have to set the + variable ~parallel-continue-when-executed~ to nil. + +* Modules + +** Parallel XWidget + + [[http://www.emacswiki.org/emacs/EmacsXWidgets][Emacs XWidget]] is an experimental branch which permits to embed GTK+ + widget inside Emacs buffers. For instance, it is possible to use it + to render an HTML page using the webkit engine within an Emacs + buffer. + + With this module, you can configure your "main" Emacs to use + another one to render web pages. + + Let's assume that you've cloned [[https://github.com/jave/xwidget-emacs][the Emacs XWidget repository]] in + ~$HOME/src/emacs-xwidget/~. Once you've compiled it, an Emacs + executable is available ~$HOME/src/emacs-xwidget/src/emacs~. + + Configure ~parallel-xwidget~ to use it: + #+BEGIN_SRC emacs-lisp + (setq parallel-xwidget-config (list :emacs-path + (concat (getenv "HOME") + "/src/emacs-xwidget/src/emacs"))) + #+END_SRC + + Then configure your current Emacs to use it: + #+BEGIN_SRC emacs-lisp + (setq browse-url-browser-function 'parallel-xwidget-browse-url) + #+END_SRC + + You can check it out with M-x browse-url RET google.com RET. + +* Tips & Tricks + + If your windows manager is smart enough (like StumpwWM) you can use + it to move graphical windows (Emacs frames) in another desktop. + + For example, I use this to move Emacs frames (with the title + "emacs-debug") to the group (aka desktop) 9: + #+BEGIN_SRC lisp + (define-frame-preference "9" + (0 nil t :title "emacs-debug")) + #+END_SRC + + And this to specify the title of the frame: + #+BEGIN_SRC emacs-lisp + (parallel-start (lambda () 42) + :no-batch t + :emacs-args '("-T" "emacs-debug")) + #+END_SRC + +* TODO How does it work? + +* Known limitations + + You can only send data to the remote (with the ~env~ parameter) or + from the remote (with ~parallel-send~ and ~parallel-remote-send~) + that have a printed representation (see [[info:elisp#Printed%20Representation][info:elisp#Printed + Representation]]). + + So you can pass around numbers, symbols, strings, lists, vectors, + hash-table but you can't pass buffers, windows, frames... + + + It lacks documentation, tests and probably a clean API, but I'm + working on it! diff --git a/lisp/emacs-parallel/parallel-remote.el b/lisp/emacs-parallel/parallel-remote.el new file mode 100644 index 00000000000..54626afc267 --- /dev/null +++ b/lisp/emacs-parallel/parallel-remote.el @@ -0,0 +1,81 @@ +;; -*- mode: emacs-lisp; lexical-binding: t; -*- +;;; parallel-remote.el --- + +;; Copyright (C) 2013 Grégoire Jadi + +;; Author: Grégoire Jadi <gregoire.jadi@gmail.com> + +;; 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, or (at your option) any later version. + +;; 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 this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'cl) + +(defvar parallel-service nil) +(defvar parallel-task-id nil) +(defvar parallel-client nil) +(defvar parallel--executed nil) +(defvar parallel-continue-when-executed nil) + +(defun parallel-remote-send (data) + (process-send-string parallel-client + (format "%S " (cons parallel-task-id data)))) + +(defun parallel-remote--init () + (setq parallel-client (make-network-process :name "emacs-parallel" + :buffer nil + :server nil + :service parallel-service + :host "localhost" + :family 'ipv4)) + (set-process-filter parallel-client #'parallel-remote--filter) + (parallel-remote-send 'code) + (when noninteractive ; Batch Mode + ;; The evaluation is done in the `parallel--filter' but in Batch + ;; Mode, Emacs doesn't wait for the input, it stops as soon as + ;; `parallel--init' has been executed. + (while (null parallel--executed) + (sleep-for 10)))) ; arbitrary chosen + +(defun parallel-remote--filter (_proc output) + (dolist (code (parallel--read-output output)) + (parallel-remote-send + (if (or noninteractive + (not debug-on-error)) + (condition-case err + (eval code) + (error err)) + (eval code)))) + (unless parallel-continue-when-executed + (setq parallel--executed t) + (kill-emacs))) + +(defun parallel--read-output (output) + "Read lisp forms from output and return them as a list." + (loop with output = (replace-regexp-in-string + "\\`[ \t\n]*" "" + (replace-regexp-in-string "[ \t\n]*\\'" "" output)) ; trim string + with start = 0 + with end = (length output) + for ret = (read-from-string output start end) + for data = (first ret) + do (setq start (rest ret)) + collect data + until (= start end))) + +(provide 'parallel-remote) + +;;; parallel-remote.el ends here diff --git a/lisp/emacs-parallel/parallel-xwidget.el b/lisp/emacs-parallel/parallel-xwidget.el new file mode 100644 index 00000000000..7e23863d6eb --- /dev/null +++ b/lisp/emacs-parallel/parallel-xwidget.el @@ -0,0 +1,59 @@ +;;; parallel-xwidget.el --- + +;; Copyright (C) 2013 Grégoire Jadi + +;; Author: Grégoire Jadi <gregoire.jadi@gmail.com> + +;; 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, or (at your option) any later version. + +;; 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 this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'parallel) +(require 'browse-url) + +(defgroup parallel-xwidget nil + "Browse the web in another emacs instance with XWidget." + :group 'emacs) + +(defvar parallel-xwidget--task nil) + +(defcustom parallel-xwidget-config nil + "Parallel configuration." + :type 'alist + :group 'parallel-xwidget) + +(defun parallel-xwidget--init () + (setq parallel-xwidget--task + (parallel-start (lambda () + (require 'xwidget)) + :graphical t + :continue-when-executed t + :config parallel-xwidget-config))) + +(defun parallel-xwidget-browse-url (url &optional new-session) + "Browse URL in another Emacs instance." + (interactive (browse-url-interactive-arg "xwidget-webkit URL: ")) + (unless (and parallel-xwidget--task + (eq 'run (parallel-status parallel-xwidget--task))) + (parallel-xwidget--init)) + (parallel-send parallel-xwidget--task + (lambda (url new-session) + (xwidget-webkit-browse-url url new-session)) + (url-tidy url) new-session)) + +(provide 'parallel-xwidget) + +;;; parallel-xwidget.el ends here diff --git a/lisp/emacs-parallel/parallel.el b/lisp/emacs-parallel/parallel.el new file mode 100644 index 00000000000..3e5eccfd73c --- /dev/null +++ b/lisp/emacs-parallel/parallel.el @@ -0,0 +1,310 @@ +;; -*- lexical-binding: t; -*- +;;; parallel.el --- + +;; Copyright (C) 2013 Grégoire Jadi + +;; Author: Grégoire Jadi <gregoire.jadi@gmail.com> + +;; 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, or (at your option) any later version. + +;; 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 this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'cl) +(require 'parallel-remote) + +(defgroup parallel nil + "Execute stuff in parallel" + :group 'emacs) + +(defcustom parallel-sleep 0.05 + "How many sec should we wait while polling." + :type 'number + :group 'parallel) + +(defcustom parallel-config nil + "Global config setting to use." + :type 'plist + :group 'parallel) + +(defvar parallel--server nil) +(defvar parallel--tasks nil) +(defvar parallel--tunnels nil) + +;; Declare external function +(declare-function parallel-send "parallel-remote") + +(defun parallel-make-tunnel (username hostname) + (parallel--init-server) + (let ((tunnel (find-if (lambda (tun) + (and (string= username + (process-get tun 'username)) + (string= hostname + (process-get tun 'hostname)))) + parallel--tunnels))) + (unless tunnel + (setq tunnel (start-process "parallel-ssh" nil "ssh" + "-N" "-R" (format "0:localhost:%s" + (process-contact parallel--server :service)) + (format "%s@%s" username hostname))) + (process-put tunnel 'username username) + (process-put tunnel 'hostname hostname) + (set-process-filter tunnel #'parallel--tunnel-filter) + (while (null (process-get tunnel 'service)) + (sleep-for 0.01)) + (push tunnel parallel--tunnels)) + tunnel)) + +(defun parallel-stop-tunnel (tunnel) + (setq parallel--tunnels (delq tunnel parallel--tunnels)) + (delete-process tunnel)) + +(defun parallel--tunnel-filter (proc output) + (if (string-match "\\([0-9]+\\)" output) + (process-put proc 'service (match-string 1 output)))) + +(defmacro parallel--set-option (place config) + `(setf ,place (or ,place + (plist-get ,config ,(intern (format ":%s" (symbol-name place)))) + (plist-get parallel-config ,(intern (format ":%s" (symbol-name place))))))) + +(defmacro parallel--set-options (config &rest options) + `(progn + ,@(loop for option in options + collect `(parallel--set-option ,option ,config)))) + +(defun* parallel-start (exec-fun &key post-exec env timeout + emacs-path library-path emacs-args + graphical debug on-event continue-when-executed + username hostname hostport + config) + (parallel--init-server) + + ;; Initialize parameters + (parallel--set-options config + post-exec + env + timeout + emacs-args + graphical + debug + on-event + continue-when-executed + username + hostname + hostport) + + (setq emacs-path (or emacs-path + (plist-get config :emacs-path) + (plist-get parallel-config :emacs-path) + (expand-file-name invocation-name + invocation-directory)) + library-path (or library-path + (plist-get config :library-path) + (plist-get parallel-config :library-path) + (locate-library "parallel-remote"))) + + (let ((task (parallel--new-task)) + proc tunnel ssh-args) + (push task parallel--tasks) + (put task 'initialized nil) + (put task 'exec-fun exec-fun) + (put task 'env env) + (when (functionp post-exec) + (put task 'post-exec post-exec)) + (when (functionp on-event) + (put task 'on-event on-event)) + (put task 'results nil) + (put task 'status 'run) + (put task 'queue nil) + + ;; We need to get the tunnel if it exists so we can send the right + ;; `service' to the remote. + (when (and username hostname) + (if hostport + (setq ssh-args (list "-R" (format "%s:localhost:%s" hostport + (process-contact parallel--server :service))) + tunnel t) + (setq tunnel (parallel-make-tunnel username hostname) + hostport (process-get tunnel 'service))) + (setq ssh-args (append + ssh-args + (if graphical (list "-X")) + (list (format "%s@%s" username hostname))))) + (setq emacs-args (remq nil + (list* "-Q" "-l" library-path + (if graphical nil "-batch") + "--eval" (format "(setq parallel-service '%S)" + (if tunnel + hostport + (process-contact parallel--server :service))) + "--eval" (format "(setq parallel-task-id '%S)" task) + "--eval" (format "(setq debug-on-error '%S)" debug) + "--eval" (format "(setq parallel-continue-when-executed '%S)" continue-when-executed) + "-f" "parallel-remote--init" + emacs-args))) + + ;; Reformat emacs-args if we use a tunnel (escape string) + (when tunnel + (setq emacs-args (list (mapconcat (lambda (string) + (if (find ?' string) + (prin1-to-string string) + string)) + emacs-args " ")))) + (setq proc (apply #'start-process "parallel" nil + `(,@(when tunnel + (list* "ssh" ssh-args)) + ,emacs-path + ,@emacs-args))) + (put task 'proc proc) + (set-process-sentinel (get task 'proc) #'parallel--sentinel) + (when timeout + (run-at-time timeout nil (lambda () + (when (memq (parallel-status task) + '(run stop)) + (parallel-stop task))))) + task)) + +(defun parallel--new-task () + "Generate a new task by enforcing a unique name." + (let ((symbol-name (make-temp-name "parallel-task-"))) + (while (intern-soft symbol-name) + (setq symbol-name (make-temp-name "parallel-task-"))) + (intern symbol-name))) + +(defun parallel--init-server () + "Initialize `parallel--server'." + (when (or (null parallel--server) + (not (eq (process-status parallel--server) + 'listen))) + (setq parallel--server + (make-network-process :name "parallel-server" + :buffer nil + :server t + :host "localhost" + :service t + :family 'ipv4 + :filter #'parallel--filter + :filter-multibyte t)))) + +(defun parallel--get-task-process (proc) + "Return the task running the given PROC." + (find-if (lambda (task) + (eq (get task 'proc) proc)) + parallel--tasks)) + +(defun parallel--sentinel (proc _event) + "Sentinel to watch over the remote process. + +This function do the necessary cleanup when the remote process is +finished." + (when (memq (process-status proc) '(exit signal)) + (let* ((task (parallel--get-task-process proc)) + (results (get task 'results)) + (status (process-status proc))) + ;; 0 means that the remote process has terminated normally (no + ;; SIGNUM 0). + (if (zerop (process-exit-status proc)) + (setq status 'success) + ;; on failure, push the exit-code or signal number on the + ;; results stack. + (push (process-exit-status proc) results)) + (put task 'results results) + (put task 'status status) + + (when (functionp (get task 'post-exec)) + (funcall (get task 'post-exec) + results status)) + (setq parallel--tasks (delq task parallel--tasks))))) + +(defun parallel--call-with-env (fun env) + "Return a string which can be READ/EVAL by the remote process +to `funcall' FUN with ENV as arguments." + (format "(funcall (read %S) %s)" + (prin1-to-string fun) + (mapconcat (lambda (obj) + ;; We need to quote it because the remote + ;; process will READ/EVAL it. + (format "'%S" obj)) env " "))) + +(defun parallel--filter (connection output) + "Server filter used to retrieve the results send by the remote +process and send the code to be executed by it." + (dolist (data (parallel--read-output output)) + (parallel--process-output connection (first data) (rest data)))) + +(defun parallel--process-output (connection task result) + (put task 'connection connection) + (cond ((and (not (get task 'initialized)) + (eq result 'code)) + (apply #'parallel-send + task + (get task 'exec-fun) + (get task 'env)) + (let ((code nil)) + (while (setq code (pop (get task 'queue))) + (apply #'parallel-send task (car code) (cdr code)))) + (put task 'initialized t)) + (t + (push result (get task 'results)) + (if (functionp (get task 'on-event)) + (funcall (get task 'on-event) result))))) + +(defun parallel-ready-p (task) + "Determine whether TASK is finished and if the results are +available." + (memq (parallel-status task) '(success exit signal))) + +(defun parallel-get-result (task) + "Return the last result send by the remote call, that is the +result returned by exec-fun." + (first (parallel-get-results task))) + +(defun parallel-get-results (task) + "Return all results send during the call of exec-fun." + (parallel-wait task) + (get task 'results)) + +(defun parallel-success-p (task) + "Determine whether TASK has ended successfully." + (parallel-wait task) + (eq (parallel-status task) 'success)) + +(defun parallel-status (task) + "Return TASK status." + (get task 'status)) + +(defun parallel-wait (task) + "Wait for TASK." + (while (not (parallel-ready-p task)) + (sleep-for parallel-sleep)) + t) ; for REPL + +(defun parallel-stop (task) + "Stop TASK." + (delete-process (get task 'proc))) + +(defun parallel-send (task fun &rest env) + "Send FUN to be evaluated by TASK in ENV." + (let ((connection (get task 'connection))) + (if connection + (process-send-string + connection + (parallel--call-with-env fun env)) + (push (cons fun env) (get task 'queue))))) + +(provide 'parallel) + +;;; parallel.el ends here diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 42fb9549255..57c7b61fc28 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -668,7 +668,7 @@ regarding its parameter treatment." ;; functions allows them to be stand-alone commands, making it easier ;; to switch between browsers. -(defun browse-url-interactive-arg (prompt) +(defun browse-url-interactive-arg (prompt &optional default-url) "Read a URL from the minibuffer, prompting with PROMPT. If `transient-mark-mode' is non-nil and the mark is active, it defaults to the current region, else to the URL at or before @@ -685,7 +685,8 @@ for use in `interactive'." "[\t\r\f\n ]+" "" (buffer-substring-no-properties (region-beginning) (region-end)))) - (browse-url-url-at-point))) + (browse-url-url-at-point) + default-url)) (not (eq (null browse-url-new-window-flag) (null current-prefix-arg))))) @@ -795,6 +796,13 @@ narrowed." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Browser-independent commands +(defun url-tidy (url) + "Tidy up URL as much as possible." + (if (equal 0 (string-match ".*://" url)) + url + (concat "http://" url) ;;TODO guess more url forms, like mailto + )) + ;; A generic command to call the current browse-url-browser-function ;;;###autoload @@ -807,6 +815,7 @@ first, if that exists." (interactive (browse-url-interactive-arg "URL: ")) (unless (called-interactively-p 'interactive) (setq args (or args (list browse-url-new-window-flag)))) + (setq url (url-tidy url)) (when (and url-handler-mode (not (file-name-absolute-p url))) (setq url (expand-file-name url))) (let ((process-environment (copy-sequence process-environment)) diff --git a/lisp/xwidget.el b/lisp/xwidget.el new file mode 100644 index 00000000000..1f0932ca7dd --- /dev/null +++ b/lisp/xwidget.el @@ -0,0 +1,513 @@ +;;; 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) + +(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) + (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-to-content) + (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") 'image-scroll-up) + (define-key map (kbd "DEL") 'image-scroll-down) + + (define-key map [remap scroll-up] 'image-scroll-up) + (define-key map [remap scroll-up-command] 'image-scroll-up) + + (define-key map [remap scroll-down] 'image-scroll-down) + (define-key map [remap scroll-down-command] 'image-scroll-down) + + (define-key map [remap forward-char] 'image-forward-hscroll) + (define-key map [remap backward-char] 'image-backward-hscroll) + (define-key map [remap right-char] 'image-forward-hscroll) + (define-key map [remap left-char] 'image-backward-hscroll) + (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'.") + +;;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) + (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) + (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)) + (xwidget-adjust-size-to-content xwidget) + (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) + (switch-to-buffer + (generate-new-buffer "textarea")) + + (set (make-local-variable 'xwbl) xw) + (insert text)) + +(defun xwidget-webkit-end-edit-textarea () + (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 (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 () + (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 also wraps an ugly hack to return a 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 () + (xwidget-webkit-execute-script-rv (xwidget-webkit-current-session) + "window.getSelection().toString();")) + +(defun xwidget-webkit-copy-selection-as-kill () + (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 () + (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 |