--- /dev/null
+;; -*- 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:
+
+(defvar parallel-service nil)
+(defvar parallel-task-id nil)
+(defvar parallel-client nil)
+(defvar parallel--executed nil)
+
+(defun parallel-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-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)
+ (parallel-send
+ (if (or noninteractive
+ (not debug-on-error))
+ (condition-case err
+ (eval (read output))
+ (error err))
+ (eval (read output))))
+ (setq parallel--executed t)
+ (kill-emacs))
+
+(provide 'parallel-remote)
+
+;;; parallel-remote.el ends here
--- /dev/null
+;; -*- 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 'find-func)
+
+(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
+ username hostname hostport
+ config)
+ (parallel--init-server)
+
+ ;; Initialize parameters
+ (parallel--set-options config
+ post-exec
+ env
+ timeout
+ emacs-args
+ graphical
+ debug
+ on-event
+ 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)
+ (find-library-name "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)
+
+ ;; 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)
+ "-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."
+ (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))
+ do (parallel--process-output connection (first data) (rest data))
+ until (= start end)))
+
+(defun parallel--process-output (connection task result)
+ (cond ((and (not (get task 'initialized))
+ (eq result 'code))
+ (process-send-string connection
+ (parallel--call-with-env (get task 'exec-fun)
+ (get task 'env)))
+ (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)))
+
+(provide 'parallel)
+
+;;; parallel.el ends here
projects / emacs.git / commitdiff