| @ -0,0 +1,15 @@ | |||||
| ;;; concurrent-autoloads.el --- automatically extracted autoloads | |||||
| ;; | |||||
| ;;; Code: | |||||
| (add-to-list 'load-path (or (file-name-directory #$) (car load-path))) | |||||
| ;;;### (autoloads nil nil ("concurrent.el") (21571 44956 836134 0)) | |||||
| ;;;*** | |||||
| ;; Local Variables: | |||||
| ;; version-control: never | |||||
| ;; no-byte-compile: t | |||||
| ;; no-update-autoloads: t | |||||
| ;; End: | |||||
| ;;; concurrent-autoloads.el ends here | |||||
| @ -0,0 +1 @@ | |||||
| (define-package "concurrent" "20140609.1940" "Concurrent utility functions for emacs lisp" '((deferred "0.3.1")) :url "https://github.com/kiwanami/emacs-deferred/blob/master/README-concurrent.markdown" :keywords '("deferred" "async" "concurrent")) | |||||
| @ -0,0 +1,509 @@ | |||||
| ;;; concurrent.el --- Concurrent utility functions for emacs lisp | |||||
| ;; Copyright (C) 2010, 2011, 2012 SAKURAI Masashi | |||||
| ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net> | |||||
| ;; Version: 20140609.1940 | |||||
| ;; X-Original-Version: 0.3.1 | |||||
| ;; Keywords: deferred, async, concurrent | |||||
| ;; Package-Requires: ((deferred "0.3.1")) | |||||
| ;; URL: https://github.com/kiwanami/emacs-deferred/blob/master/README-concurrent.markdown | |||||
| ;; 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: | |||||
| ;; 'concurrent.el' is a higher level library for concurrent tasks | |||||
| ;; based on 'deferred.el'. This library has following features: | |||||
| ;; | |||||
| ;; - Generator | |||||
| ;; - Green thread | |||||
| ;; - Semaphore | |||||
| ;; - Dataflow | |||||
| ;; - Signal/Channel | |||||
| (require 'cl) | |||||
| (require 'deferred) | |||||
| (defvar cc:version nil "version number") | |||||
| (setq cc:version "0.3") | |||||
| ;;; Code: | |||||
| (defmacro cc:aif (test-form then-form &rest else-forms) | |||||
| (declare (debug (form form &rest form))) | |||||
| `(let ((it ,test-form)) | |||||
| (if it ,then-form ,@else-forms))) | |||||
| (put 'cc:aif 'lisp-indent-function 2) | |||||
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |||||
| ;; Generator | |||||
| (defun cc:generator-replace-yield (tree) | |||||
| "[internal] Replace `yield' symbols to calling a function in TREE." | |||||
| (let (ret) | |||||
| (loop for i in tree | |||||
| do (cond | |||||
| ((eq i 'yield) | |||||
| (push 'funcall ret) | |||||
| (push i ret)) | |||||
| ((listp i) | |||||
| (push (cc:generator-replace-yield i) ret)) | |||||
| (t | |||||
| (push i ret)))) | |||||
| (nreverse ret))) | |||||
| (defun cc:generator-line (chain line) | |||||
| "[internal] Return a macro expansion to execute the sexp LINE | |||||
| asynchronously." | |||||
| (cond | |||||
| ;; function object | |||||
| ((functionp line) | |||||
| `(setq ,chain (deferred:nextc ,chain ,line))) | |||||
| ;; while loop form | |||||
| ((eq 'while (car line)) | |||||
| (let ((condition (cadr line)) | |||||
| (body (cddr line))) | |||||
| `(setq ,chain | |||||
| (deferred:nextc ,chain | |||||
| (deferred:lambda (x) | |||||
| (if ,condition | |||||
| (deferred:nextc | |||||
| (progn | |||||
| ,@(cc:generator-replace-yield body)) self))))))) | |||||
| ;; statement | |||||
| (t | |||||
| `(setq ,chain | |||||
| (deferred:nextc ,chain | |||||
| (deferred:lambda (x) ,(cc:generator-replace-yield line))))))) | |||||
| (defmacro cc:generator (callback &rest body) | |||||
| "Create a generator object. If BODY has `yield' symbols, it | |||||
| means calling callback function CALLBACK." | |||||
| (let ((chain (gensym)) | |||||
| (cc (gensym)) | |||||
| (waiter (gensym))) | |||||
| `(lexical-let* | |||||
| (,chain | |||||
| (,cc ,callback) | |||||
| (,waiter (deferred:new)) | |||||
| (yield (lambda (x) (funcall ,cc x) ,waiter))) | |||||
| (setq ,chain ,waiter) | |||||
| ,@(loop for i in body | |||||
| collect | |||||
| (cc:generator-line chain i)) | |||||
| (lambda () (deferred:callback ,waiter))))) | |||||
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |||||
| ;; Thread | |||||
| (defun cc:thread-line (wait-time chain line) | |||||
| "[internal] Return a macro expansion to execute the sexp LINE asynchronously. | |||||
| WAIT-TIME is an interval time between tasks. | |||||
| CHAIN is the previous deferred task." | |||||
| (cond | |||||
| ;; function object | |||||
| ((functionp line) | |||||
| `(setq ,chain (deferred:nextc ,chain ,line))) | |||||
| ;; while loop form | |||||
| ((eq 'while (car line)) | |||||
| (let ((condition (cadr line)) | |||||
| (body (cddr line)) | |||||
| (retsym (gensym))) | |||||
| `(setq ,chain | |||||
| (deferred:nextc ,chain | |||||
| (deferred:lambda (x) | |||||
| (if ,condition | |||||
| (deferred:nextc | |||||
| (let ((,retsym (progn ,@body))) | |||||
| (if (deferred-p ,retsym) ,retsym | |||||
| (deferred:wait ,wait-time))) | |||||
| self))))))) | |||||
| ;; statement | |||||
| (t | |||||
| `(setq ,chain | |||||
| (deferred:nextc ,chain | |||||
| (lambda (x) ,line)))))) | |||||
| (defmacro cc:thread (wait-time-msec &rest body) | |||||
| "Return a thread object." | |||||
| (let ((chain (gensym)) | |||||
| (dstart (gensym))) | |||||
| `(lexical-let* | |||||
| (,chain | |||||
| (,dstart (deferred:new))) | |||||
| (setq ,chain ,dstart) | |||||
| ,@(loop for i in body | |||||
| collect | |||||
| (cc:thread-line wait-time-msec chain i)) | |||||
| (deferred:callback ,dstart)))) | |||||
| (put 'cc:thread 'lisp-indent-function 1) | |||||
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |||||
| ;; Semaphore | |||||
| (defstruct cc:semaphore max-permits permits waiting-deferreds) | |||||
| (defun cc:semaphore-create(permits-num) | |||||
| "Return a semaphore object with PERMITS-NUM permissions." | |||||
| (make-cc:semaphore :max-permits permits-num :permits permits-num)) | |||||
| (defun cc:semaphore-acquire(semaphore) | |||||
| "Acquire an execution permission and return deferred object to chain. | |||||
| If this semaphore object has permissions, the subsequent deferred | |||||
| task is executed immediately. If this semaphore object has no | |||||
| permissions, the subsequent deferred task is blocked. After the | |||||
| permission is returned, the task is executed." | |||||
| (cond | |||||
| ((< 0 (cc:semaphore-permits semaphore)) | |||||
| (decf (cc:semaphore-permits semaphore)) | |||||
| (deferred:succeed)) | |||||
| (t | |||||
| (let ((d (deferred:new))) | |||||
| (push d (cc:semaphore-waiting-deferreds semaphore)) | |||||
| d)))) | |||||
| (defun cc:semaphore-release(semaphore) | |||||
| "Release an execution permission. The programmer is responsible to return the permissions." | |||||
| (when (<= (cc:semaphore-max-permits semaphore) | |||||
| (cc:semaphore-permits semaphore)) | |||||
| (error "Too many calling semaphore-release. [max:%s <= permits:%s]" | |||||
| (cc:semaphore-max-permits semaphore) | |||||
| (cc:semaphore-permits semaphore))) | |||||
| (let ((waiting-deferreds | |||||
| (cc:semaphore-waiting-deferreds semaphore))) | |||||
| (cond | |||||
| (waiting-deferreds | |||||
| (let* ((d (car (last waiting-deferreds)))) | |||||
| (setf (cc:semaphore-waiting-deferreds semaphore) | |||||
| (nbutlast waiting-deferreds)) | |||||
| (deferred:callback-post d))) | |||||
| (t | |||||
| (incf (cc:semaphore-permits semaphore))))) | |||||
| semaphore) | |||||
| (defun cc:semaphore-with (semaphore body-func &optional error-func) | |||||
| "Execute the task BODY-FUNC asynchronously with the semaphore block." | |||||
| (lexical-let ((semaphore semaphore)) | |||||
| (deferred:try | |||||
| (deferred:nextc (cc:semaphore-acquire semaphore) body-func) | |||||
| :catch | |||||
| error-func | |||||
| :finally | |||||
| (lambda (x) (cc:semaphore-release semaphore))))) | |||||
| (put 'cc:semaphore-with 'lisp-indent-function 1) | |||||
| (defun cc:semaphore-release-all (semaphore) | |||||
| "Release all permissions for resetting the semaphore object. | |||||
| If the semaphore object has some blocked tasks, this function | |||||
| return a list of the tasks and clear the list of the blocked | |||||
| tasks in the semaphore object." | |||||
| (setf (cc:semaphore-permits semaphore) | |||||
| (cc:semaphore-max-permits semaphore)) | |||||
| (let ((ds (cc:semaphore-waiting-deferreds semaphore))) | |||||
| (when ds | |||||
| (setf (cc:semaphore-waiting-deferreds semaphore) nil)) | |||||
| ds)) | |||||
| (defun cc:semaphore-interrupt-all (semaphore) | |||||
| "Clear the list of the blocked tasks in the semaphore and return a deferred object to chain. | |||||
| This function is used for the interruption cases." | |||||
| (when (cc:semaphore-waiting-deferreds semaphore) | |||||
| (setf (cc:semaphore-waiting-deferreds semaphore) nil) | |||||
| (setf (cc:semaphore-permits semaphore) 0)) | |||||
| (cc:semaphore-acquire semaphore)) | |||||
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |||||
| ;; Signal / Channel | |||||
| (defun cc:signal-channel (&optional name parent-channel) | |||||
| "Create a channel. | |||||
| NAME is a channel name for debug. | |||||
| PARENT-CHANNEL is an upstream channel. The observers of this channel can receive the upstream signals. | |||||
| In the case of using the function `cc:signal-send', the observers of the upstream channel can not receive the signals of this channel. The function `cc:signal-send-global' can send a signal to the upstream channels from the downstream channels." | |||||
| (lexical-let | |||||
| ((ch (cons | |||||
| (or name (format "signal%s" (deferred:uid))) ; name for debug | |||||
| (cons | |||||
| parent-channel ; parent-channel | |||||
| nil)))) ; observers | |||||
| (when parent-channel | |||||
| (cc:signal-connect | |||||
| parent-channel | |||||
| t (lambda (event) | |||||
| (destructuring-bind | |||||
| (event-name event-args) event | |||||
| (apply 'cc:signal-send | |||||
| ch event-name event-args))))) | |||||
| ch)) | |||||
| (defmacro cc:signal-name (ch) | |||||
| "[internal] Return signal name." | |||||
| `(car ,ch)) | |||||
| (defmacro cc:signal-parent-channel (ch) | |||||
| "[internal] Return parent channel object." | |||||
| `(cadr ,ch)) | |||||
| (defmacro cc:signal-observers (ch) | |||||
| "[internal] Return observers." | |||||
| `(cddr ,ch)) | |||||
| (defun cc:signal-connect (channel event-sym &optional callback) | |||||
| "Append an observer for EVENT-SYM of CHANNEL and return a deferred object. | |||||
| If EVENT-SYM is `t', the observer receives all signals of the channel. | |||||
| If CALLBACK function is given, the deferred object executes the | |||||
| CALLBACK function asynchronously. One can connect subsequent | |||||
| tasks to the returned deferred object." | |||||
| (let ((d (if callback | |||||
| (deferred:new callback) | |||||
| (deferred:new)))) | |||||
| (push (cons event-sym d) | |||||
| (cc:signal-observers channel)) | |||||
| d)) | |||||
| (defun cc:signal-send (channel event-sym &rest args) | |||||
| "Send a signal to CHANNEL. If ARGS values are given, observers can get the values by following code: (lambda (event) (destructuring-bind (event-sym (args)) event ... )). " | |||||
| (let ((observers (cc:signal-observers channel)) | |||||
| (event (list event-sym args))) | |||||
| (loop for i in observers | |||||
| for name = (car i) | |||||
| for d = (cdr i) | |||||
| if (or (eq event-sym name) (eq t name)) | |||||
| do (deferred:callback-post d event)))) | |||||
| (defun cc:signal-send-global (channel event-sym &rest args) | |||||
| "Send a signal to the most upstream channel. " | |||||
| (cc:aif (cc:signal-parent-channel channel) | |||||
| (apply 'cc:signal-send-global it event-sym args) | |||||
| (apply 'cc:signal-send channel event-sym args))) | |||||
| (defun cc:signal-disconnect (channel deferred) | |||||
| "Remove the observer object DEFERRED from CHANNEL and return | |||||
| the removed deferred object. " | |||||
| (let ((observers (cc:signal-observers channel)) deleted) | |||||
| (setf | |||||
| (cc:signal-observers channel) ; place | |||||
| (loop for i in observers | |||||
| for d = (cdr i) | |||||
| unless (eq d deferred) | |||||
| collect i | |||||
| else | |||||
| do (push i deleted))) | |||||
| deleted)) | |||||
| (defun cc:signal-disconnect-all (channel) | |||||
| "Remove all observers." | |||||
| (setf | |||||
| (cc:signal-observers channel) ; place | |||||
| nil)) | |||||
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |||||
| ;; Dataflow | |||||
| ;; Dataflow variable entry | |||||
| (defstruct cc:dataflow key (value 'cc:dataflow-undefine) deferred-list) | |||||
| (defun cc:dataflow-undefine-p (obj) | |||||
| "[internal] If the variable entry is not bound, return `t'." | |||||
| (eq 'cc:dataflow-undefine (cc:dataflow-value obj))) | |||||
| (defmacro cc:dataflow-parent-environment (df) | |||||
| "[internal] Return the parent environment." | |||||
| `(car ,df)) | |||||
| (defmacro cc:dataflow-test (df) | |||||
| "[internal] Return the test function." | |||||
| `(cadr ,df)) | |||||
| (defmacro cc:dataflow-channel (df) | |||||
| "[internal] Return the channel object." | |||||
| `(caddr ,df)) | |||||
| (defmacro cc:dataflow-list (df) | |||||
| "[internal] Return the list of deferred object which are waiting for value binding." | |||||
| `(cdddr ,df)) | |||||
| (defun cc:dataflow-environment (&optional parent-env test-func channel) | |||||
| "Create a dataflow environment. | |||||
| PARENT-ENV is the default environment. If this environment doesn't have the entry A and the parent one has the entry A, this environment can return the entry A. One can override the entry, setting another entry A to this environment. | |||||
| TEST-FUNC is a test function that compares the entry keys. The default function is `equal'. | |||||
| CHANNEL is a channel object that sends signals of variable events. Observers can receive following signals: | |||||
| -get-first : the fist referrer is waiting for binding, | |||||
| -get-waiting : another referrer is waiting for binding, | |||||
| -set : a value is bound, | |||||
| -get : returned a bound value, | |||||
| -clear : cleared one entry, | |||||
| -clear-all : cleared all entries. | |||||
| " | |||||
| (let ((this (list parent-env | |||||
| (or test-func 'equal) | |||||
| (or channel | |||||
| (cc:signal-channel | |||||
| 'dataflow | |||||
| (and parent-env | |||||
| (cc:dataflow-channel parent-env))))))) | |||||
| (cc:dataflow-init-connect this) | |||||
| this)) | |||||
| (defun cc:dataflow-init-connect (df) | |||||
| "[internal] Initialize the channel object." | |||||
| (lexical-let ((df df)) | |||||
| (cc:dataflow-connect | |||||
| df 'set | |||||
| (lambda (args) | |||||
| (destructuring-bind (event (key)) args | |||||
| (let* ((obj (cc:dataflow-get-object-for-value df key)) | |||||
| (value (and obj (cc:dataflow-value obj)))) | |||||
| (when obj | |||||
| (loop for i in (cc:aif (cc:dataflow-get-object-for-deferreds df key) | |||||
| (cc:dataflow-deferred-list it) nil) | |||||
| do (deferred:callback-post i value)) | |||||
| (setf (cc:dataflow-deferred-list obj) nil)))))))) | |||||
| (defun cc:dataflow-get-object-for-value (df key) | |||||
| "[internal] Return an entry object that is indicated by KEY. | |||||
| If the environment DF doesn't have the entry and the parent one has the entry, this function returns the entry of the parent environment. This function doesn't affect the waiting list." | |||||
| (or | |||||
| (loop for i in (cc:dataflow-list df) | |||||
| with test = (cc:dataflow-test df) | |||||
| if (and (funcall test key (cc:dataflow-key i)) | |||||
| (not (cc:dataflow-undefine-p i))) | |||||
| return i) | |||||
| (deferred:aand | |||||
| (cc:dataflow-parent-environment df) | |||||
| (cc:dataflow-get-object-for-value it key)))) | |||||
| (defun cc:dataflow-get-object-for-deferreds (df key) | |||||
| "[internal] Return a list of the deferred objects those are waiting for value binding. | |||||
| This function doesn't affect the waiting list and doesn't refer the parent environment." | |||||
| (loop for i in (cc:dataflow-list df) | |||||
| with test = (cc:dataflow-test df) | |||||
| if (funcall test key (cc:dataflow-key i)) | |||||
| return i)) | |||||
| (defun cc:dataflow-connect (df event-sym &optional callback) | |||||
| "Append an observer for EVENT-SYM of the channel of DF and return a deferred object. | |||||
| See the docstring of `cc:dataflow-environment' for details." | |||||
| (cc:signal-connect (cc:dataflow-channel df) event-sym callback)) | |||||
| (defun cc:dataflow-signal (df event &optional arg) | |||||
| "[internal] Send a signal to the channel of DF." | |||||
| (cc:signal-send (cc:dataflow-channel df) event arg)) | |||||
| (defun cc:dataflow-get (df key) | |||||
| "Return a deferred object that can refer the value which is indicated by KEY. | |||||
| If DF has the entry that bound value, the subsequent deferred task is executed immediately. | |||||
| If not, the task is deferred till a value is bound." | |||||
| (let ((obj (cc:dataflow-get-object-for-value df key))) | |||||
| (cond | |||||
| ((and obj (cc:dataflow-value obj)) | |||||
| (cc:dataflow-signal df 'get key) | |||||
| (deferred:succeed (cc:dataflow-value obj))) | |||||
| (t | |||||
| (setq obj (cc:dataflow-get-object-for-deferreds df key)) | |||||
| (unless obj | |||||
| (setq obj (make-cc:dataflow :key key)) | |||||
| (push obj (cc:dataflow-list df)) | |||||
| (cc:dataflow-signal df 'get-first key)) | |||||
| (let ((d (deferred:new))) | |||||
| (push d (cc:dataflow-deferred-list obj)) | |||||
| (cc:dataflow-signal df 'get-waiting key) | |||||
| d))))) | |||||
| (defun cc:dataflow-get-sync (df key) | |||||
| "Return the value which is indicated by KEY synchronously. | |||||
| If the environment DF doesn't have an entry of KEY, this function returns nil." | |||||
| (let ((obj (cc:dataflow-get-object-for-value df key))) | |||||
| (and obj (cc:dataflow-value obj)))) | |||||
| (defun cc:dataflow-set (df key value) | |||||
| "Bind the VALUE to KEY in the environment DF. | |||||
| If DF already has the bound entry of KEY, this function throws an error signal. | |||||
| VALUE can be nil as a value." | |||||
| (let ((obj (cc:dataflow-get-object-for-deferreds df key))) | |||||
| (cond | |||||
| ((and obj (not (cc:dataflow-undefine-p obj))) | |||||
| ;; overwrite! | |||||
| (error "Can not set a dataflow value. The key [%s] has already had a value. NEW:[%s] OLD:[%s]" key value (cc:dataflow-value obj))) | |||||
| (obj | |||||
| (setf (cc:dataflow-value obj) value)) | |||||
| (t | |||||
| ;; just value arrived | |||||
| (push (make-cc:dataflow :key key :value value) | |||||
| (cc:dataflow-list df)))) | |||||
| ;; value arrived and start deferred objects | |||||
| (cc:dataflow-signal df 'set key) | |||||
| value)) | |||||
| (defun cc:dataflow-clear (df key) | |||||
| "Clear the entry which is indicated by KEY. | |||||
| This function does nothing for the waiting deferred objects." | |||||
| (cc:dataflow-signal df 'clear key) | |||||
| (setf (cc:dataflow-list df) | |||||
| (loop for i in (cc:dataflow-list df) | |||||
| with test = (cc:dataflow-test df) | |||||
| unless (funcall test key (cc:dataflow-key i)) | |||||
| collect i))) | |||||
| (defun cc:dataflow-get-avalable-pairs (df) | |||||
| "Return an available key-value alist in the environment DF and the parent ones." | |||||
| (append | |||||
| (loop for i in (cc:dataflow-list df) | |||||
| for key = (cc:dataflow-key i) | |||||
| for val = (cc:dataflow-value i) | |||||
| unless (cc:dataflow-undefine-p i) collect (cons key val)) | |||||
| (deferred:aand | |||||
| (cc:dataflow-parent-environment df) | |||||
| (cc:dataflow-get-avalable-pairs it)))) | |||||
| (defun cc:dataflow-get-waiting-keys (df) | |||||
| "Return a list of keys which have waiting deferred objects in the environment DF and the parent ones." | |||||
| (append | |||||
| (loop for i in (cc:dataflow-list df) | |||||
| for key = (cc:dataflow-key i) | |||||
| for val = (cc:dataflow-value i) | |||||
| if (cc:dataflow-undefine-p i) collect key) | |||||
| (deferred:aand | |||||
| (cc:dataflow-parent-environment df) | |||||
| (cc:dataflow-get-waiting-keys it)))) | |||||
| (defun cc:dataflow-clear-all (df) | |||||
| "Clear all entries in the environment DF. | |||||
| This function does nothing for the waiting deferred objects." | |||||
| (cc:dataflow-signal df 'clear-all) | |||||
| (setf (cc:dataflow-list df) nil)) | |||||
| (provide 'concurrent) | |||||
| ;; Local Variables: | |||||
| ;; byte-compile-warnings: (not cl-functions) | |||||
| ;; End: | |||||
| ;;; concurrent.el ends here | |||||
| @ -0,0 +1,15 @@ | |||||
| ;;; ctable-autoloads.el --- automatically extracted autoloads | |||||
| ;; | |||||
| ;;; Code: | |||||
| (add-to-list 'load-path (or (file-name-directory #$) (car load-path))) | |||||
| ;;;### (autoloads nil nil ("ctable.el") (21571 44956 93448 0)) | |||||
| ;;;*** | |||||
| ;; Local Variables: | |||||
| ;; version-control: never | |||||
| ;; no-byte-compile: t | |||||
| ;; no-update-autoloads: t | |||||
| ;; End: | |||||
| ;;; ctable-autoloads.el ends here | |||||
| @ -0,0 +1 @@ | |||||
| (define-package "ctable" "20140304.1659" "Table component for Emacs Lisp" 'nil :url "https://github.com/kiwanami/emacs-ctable" :keywords '("table")) | |||||
| @ -0,0 +1,15 @@ | |||||
| ;;; deferred-autoloads.el --- automatically extracted autoloads | |||||
| ;; | |||||
| ;;; Code: | |||||
| (add-to-list 'load-path (or (file-name-directory #$) (car load-path))) | |||||
| ;;;### (autoloads nil nil ("deferred.el") (21571 44954 910371 0)) | |||||
| ;;;*** | |||||
| ;; Local Variables: | |||||
| ;; version-control: never | |||||
| ;; no-byte-compile: t | |||||
| ;; no-update-autoloads: t | |||||
| ;; End: | |||||
| ;;; deferred-autoloads.el ends here | |||||
| @ -0,0 +1 @@ | |||||
| (define-package "deferred" "20140816.2205" "Simple asynchronous functions for emacs lisp" 'nil :url "https://github.com/kiwanami/emacs-deferred" :keywords '("deferred" "async")) | |||||
| @ -0,0 +1,963 @@ | |||||
| ;;; deferred.el --- Simple asynchronous functions for emacs lisp | |||||
| ;; Copyright (C) 2010, 2011, 2012 SAKURAI Masashi | |||||
| ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net> | |||||
| ;; Version: 20140816.2205 | |||||
| ;; X-Original-Version: 0.3.2 | |||||
| ;; Keywords: deferred, async | |||||
| ;; URL: https://github.com/kiwanami/emacs-deferred | |||||
| ;; 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: | |||||
| ;; 'deferred.el' is a simple library for asynchronous tasks. | |||||
| ;; [https://github.com/kiwanami/emacs-deferred] | |||||
| ;; The API is almost the same as JSDeferred written by cho45. See the | |||||
| ;; JSDeferred and Mochikit.Async web sites for further documentations. | |||||
| ;; [https://github.com/cho45/jsdeferred] | |||||
| ;; [http://mochikit.com/doc/html/MochiKit/Async.html] | |||||
| ;; A good introduction document (JavaScript) | |||||
| ;; [http://cho45.stfuawsc.com/jsdeferred/doc/intro.en.html] | |||||
| ;;; Samples: | |||||
| ;; ** HTTP Access | |||||
| ;; (require 'url) | |||||
| ;; (deferred:$ | |||||
| ;; (deferred:url-retrieve "http://www.gnu.org") | |||||
| ;; (deferred:nextc it | |||||
| ;; (lambda (buf) | |||||
| ;; (insert (with-current-buffer buf (buffer-string))) | |||||
| ;; (kill-buffer buf)))) | |||||
| ;; ** Invoking command tasks | |||||
| ;; (deferred:$ | |||||
| ;; (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png") | |||||
| ;; (deferred:nextc it | |||||
| ;; (lambda (x) (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg"))) | |||||
| ;; (deferred:nextc it | |||||
| ;; (lambda (x) | |||||
| ;; (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil))))) | |||||
| ;; See the readme for further API documentation. | |||||
| ;; ** Applications | |||||
| ;; *Inertial scrolling for Emacs | |||||
| ;; [https://github.com/kiwanami/emacs-inertial-scroll] | |||||
| ;; This program makes simple multi-thread function, using | |||||
| ;; deferred.el. | |||||
| (require 'cl) | |||||
| (defvar deferred:version nil "deferred.el version") | |||||
| (setq deferred:version "0.3.2") | |||||
| ;;; Code: | |||||
| (defmacro deferred:aand (test &rest rest) | |||||
| "[internal] Anaphoric AND." | |||||
| (declare (debug ("test" form &rest form))) | |||||
| `(let ((it ,test)) | |||||
| (if it ,(if rest `(deferred:aand ,@rest) 'it)))) | |||||
| (defmacro deferred:$ (&rest elements) | |||||
| "Anaphoric function chain macro for deferred chains." | |||||
| (declare (debug (&rest form))) | |||||
| `(let (it) | |||||
| ,@(loop for i in elements | |||||
| with it = nil | |||||
| collect | |||||
| `(setq it ,i)) | |||||
| it)) | |||||
| (defmacro deferred:lambda (args &rest body) | |||||
| "Anaphoric lambda macro for self recursion." | |||||
| (declare (debug ("args" form &rest form))) | |||||
| (let ((argsyms (loop for i in args collect (gensym)))) | |||||
| `(lambda (,@argsyms) | |||||
| (lexical-let (self) | |||||
| (setq self (lambda( ,@args ) ,@body)) | |||||
| (funcall self ,@argsyms))))) | |||||
| (defmacro* deferred:try (d &key catch finally) | |||||
| "Try-catch-finally macro. This macro simulates the | |||||
| try-catch-finally block asynchronously. CATCH and FINALLY can be | |||||
| nil. Because of asynchrony, this macro does not ensure that the | |||||
| task FINALLY should be called." | |||||
| (let ((chain | |||||
| (if catch `((deferred:error it ,catch))))) | |||||
| (when finally | |||||
| (setq chain (append chain `((deferred:watch it ,finally))))) | |||||
| `(deferred:$ ,d ,@chain))) | |||||
| (defun deferred:setTimeout (f msec) | |||||
| "[internal] Timer function that emulates the `setTimeout' function in JS." | |||||
| (run-at-time (/ msec 1000.0) nil f)) | |||||
| (defun deferred:cancelTimeout (id) | |||||
| "[internal] Timer cancellation function that emulates the `cancelTimeout' function in JS." | |||||
| (cancel-timer id)) | |||||
| (defun deferred:run-with-idle-timer (sec f) | |||||
| "[internal] Wrapper function for run-with-idle-timer." | |||||
| (run-with-idle-timer sec nil f)) | |||||
| (defun deferred:call-lambda (f &optional arg) | |||||
| "[internal] Call a function with one or zero argument safely. | |||||
| The lambda function can define with zero and one argument." | |||||
| (condition-case err | |||||
| (funcall f arg) | |||||
| ('wrong-number-of-arguments | |||||
| (display-warning 'deferred "\ | |||||
| Callback that takes no argument may be specified. | |||||
| Passing callback with no argument is deprecated. | |||||
| Callback must take one argument. | |||||
| Or, this error is coming from somewhere inside of the callback: %S" err) | |||||
| (condition-case err2 | |||||
| (funcall f) | |||||
| ('wrong-number-of-arguments | |||||
| (signal 'wrong-number-of-arguments (cdr err))))))) ; return the first error | |||||
| ;; debug | |||||
| (eval-and-compile | |||||
| (defvar deferred:debug nil "Debug output switch.")) | |||||
| (defvar deferred:debug-count 0 "[internal] Debug output counter.") | |||||
| (defmacro deferred:message (&rest args) | |||||
| "[internal] Debug log function." | |||||
| (when deferred:debug | |||||
| `(progn | |||||
| (with-current-buffer (get-buffer-create "*deferred:debug*") | |||||
| (save-excursion | |||||
| (goto-char (point-max)) | |||||
| (insert (format "%5i %s\n" deferred:debug-count (format ,@args))))) | |||||
| (incf deferred:debug-count)))) | |||||
| (defun deferred:message-mark () | |||||
| "[internal] Debug log function." | |||||
| (interactive) | |||||
| (deferred:message "==================== mark ==== %s" | |||||
| (format-time-string "%H:%M:%S" (current-time)))) | |||||
| (defun deferred:pp (d) | |||||
| (require 'pp) | |||||
| (deferred:$ | |||||
| (deferred:nextc d | |||||
| (lambda (x) | |||||
| (pp-display-expression x "*deferred:pp*"))) | |||||
| (deferred:error it | |||||
| (lambda (e) | |||||
| (pp-display-expression e "*deferred:pp*"))) | |||||
| (deferred:nextc it | |||||
| (lambda (x) (pop-to-buffer "*deferred:pp*"))))) | |||||
| (defvar deferred:debug-on-signal nil | |||||
| "If non nil, the value `debug-on-signal' is substituted this | |||||
| value in the `condition-case' form in deferred | |||||
| implementations. Then, Emacs debugger can catch an error occurred | |||||
| in the asynchronous tasks.") | |||||
| (defmacro deferred:condition-case (var protected-form &rest handlers) | |||||
| "[internal] Custom condition-case. See the comment for | |||||
| `deferred:debug-on-signal'." | |||||
| (declare (debug condition-case) | |||||
| (indent 2)) | |||||
| `(let ((debug-on-signal | |||||
| (or debug-on-signal deferred:debug-on-signal))) | |||||
| (condition-case ,var | |||||
| ,protected-form | |||||
| ,@handlers))) | |||||
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |||||
| ;; Back end functions of deferred tasks | |||||
| (defvar deferred:tick-time 0.001 | |||||
| "Waiting time between asynchronous tasks (second). | |||||
| The shorter waiting time increases the load of Emacs. The end | |||||
| user can tune this paramter. However, applications should not | |||||
| modify it because the applications run on various environments.") | |||||
| (defvar deferred:queue nil | |||||
| "[internal] The execution queue of deferred objects. | |||||
| See the functions `deferred:post-task' and `deferred:worker'.") | |||||
| (defmacro deferred:pack (a b c) | |||||
| `(cons ,a (cons ,b ,c))) | |||||
| (defun deferred:schedule-worker () | |||||
| "[internal] Schedule consuming a deferred task in the execution queue." | |||||
| (run-at-time deferred:tick-time nil 'deferred:worker)) | |||||
| (defun deferred:post-task (d which &optional arg) | |||||
| "[internal] Add a deferred object to the execution queue | |||||
| `deferred:queue' and schedule to execute. | |||||
| D is a deferred object. WHICH is a symbol, `ok' or `ng'. ARG is | |||||
| an argument value for execution of the deferred task." | |||||
| (push (deferred:pack d which arg) deferred:queue) | |||||
| (deferred:message "QUEUE-POST [%s]: %s" | |||||
| (length deferred:queue) (deferred:pack d which arg)) | |||||
| (deferred:schedule-worker) | |||||
| d) | |||||
| (defun deferred:clear-queue () | |||||
| "Clear the execution queue. For test and debugging." | |||||
| (interactive) | |||||
| (deferred:message "QUEUE-CLEAR [%s -> 0]" (length deferred:queue)) | |||||
| (setq deferred:queue nil)) | |||||
| (defun deferred:worker () | |||||
| "[internal] Consume a deferred task. | |||||
| Mainly this function is called by timer asynchronously." | |||||
| (when deferred:queue | |||||
| (let* ((pack (car (last deferred:queue))) | |||||
| (d (car pack)) | |||||
| (which (cadr pack)) | |||||
| (arg (cddr pack)) value) | |||||
| (setq deferred:queue (nbutlast deferred:queue)) | |||||
| (condition-case err | |||||
| (setq value (deferred:exec-task d which arg)) | |||||
| (error | |||||
| (deferred:message "ERROR : %s" err) | |||||
| (message "deferred error : %s" err))) | |||||
| value))) | |||||
| (defun deferred:flush-queue! () | |||||
| "Call all deferred tasks synchronously. For test and debugging." | |||||
| (let (value) | |||||
| (while deferred:queue | |||||
| (setq value (deferred:worker))) | |||||
| value)) | |||||
| (defun deferred:sync! (d) | |||||
| "Wait for the given deferred task. For test and debugging. | |||||
| Error is raised if it is not processed within deferred chain D." | |||||
| (progn | |||||
| (lexical-let ((last-value 'deferred:undefined*) | |||||
| uncaught-error) | |||||
| (deferred:try | |||||
| (deferred:nextc d | |||||
| (lambda (x) (setq last-value x))) | |||||
| :catch | |||||
| (lambda (err) (setq uncaught-error err))) | |||||
| (while (and (eq 'deferred:undefined* last-value) | |||||
| (not uncaught-error)) | |||||
| (sit-for 0.05) | |||||
| (sleep-for 0.05)) | |||||
| (when uncaught-error | |||||
| (deferred:resignal uncaught-error)) | |||||
| last-value))) | |||||
| ;; Struct: deferred | |||||
| ;; | |||||
| ;; callback : a callback function (default `deferred:default-callback') | |||||
| ;; errorback : an errorback function (default `deferred:default-errorback') | |||||
| ;; cancel : a canceling function (default `deferred:default-cancel') | |||||
| ;; next : a next chained deferred object (default nil) | |||||
| ;; status : if 'ok or 'ng, this deferred has a result (error) value. (default nil) | |||||
| ;; value : saved value (default nil) | |||||
| ;; | |||||
| (defstruct deferred | |||||
| (callback 'deferred:default-callback) | |||||
| (errorback 'deferred:default-errorback) | |||||
| (cancel 'deferred:default-cancel) | |||||
| next status value) | |||||
| (defun deferred:default-callback (i) | |||||
| "[internal] Default callback function." | |||||
| (identity i)) | |||||
| (defun deferred:default-errorback (err) | |||||
| "[internal] Default errorback function." | |||||
| (deferred:resignal err)) | |||||
| (defun deferred:resignal (err) | |||||
| "[internal] Safely resignal ERR as an Emacs condition. | |||||
| If ERR is a cons (ERROR-SYMBOL . DATA) where ERROR-SYMBOL has an | |||||
| `error-conditions' property, it is re-signaled unchanged. If ERR | |||||
| is a string, it is signaled as a generic error using `error'. | |||||
| Otherwise, ERR is formatted into a string as if by `print' before | |||||
| raising with `error'." | |||||
| (cond ((and (listp err) | |||||
| (symbolp (car err)) | |||||
| (get (car err) 'error-conditions)) | |||||
| (signal (car err) (cdr err))) | |||||
| ((stringp err) | |||||
| (error "%s" err)) | |||||
| (t | |||||
| (error "%S" err)))) | |||||
| (defun deferred:default-cancel (d) | |||||
| "[internal] Default canceling function." | |||||
| (deferred:message "CANCEL : %s" d) | |||||
| (setf (deferred-callback d) 'deferred:default-callback) | |||||
| (setf (deferred-errorback d) 'deferred:default-errorback) | |||||
| (setf (deferred-next d) nil) | |||||
| d) | |||||
| (defun deferred:exec-task (d which &optional arg) | |||||
| "[internal] Executing deferred task. If the deferred object has | |||||
| next deferred task or the return value is a deferred object, this | |||||
| function adds the task to the execution queue. | |||||
| D is a deferred object. WHICH is a symbol, `ok' or `ng'. ARG is | |||||
| an argument value for execution of the deferred task." | |||||
| (deferred:message "EXEC : %s / %s / %s" d which arg) | |||||
| (when (null d) (error "deferred:exec-task was given a nil.")) | |||||
| (let ((callback (if (eq which 'ok) | |||||
| (deferred-callback d) | |||||
| (deferred-errorback d))) | |||||
| (next-deferred (deferred-next d))) | |||||
| (cond | |||||
| (callback | |||||
| (deferred:condition-case err | |||||
| (let ((value (deferred:call-lambda callback arg))) | |||||
| (cond | |||||
| ((deferred-p value) | |||||
| (deferred:message "WAIT NEST : %s" value) | |||||
| (if next-deferred | |||||
| (deferred:set-next value next-deferred) | |||||
| value)) | |||||
| (t | |||||
| (if next-deferred | |||||
| (deferred:post-task next-deferred 'ok value) | |||||
| (setf (deferred-status d) 'ok) | |||||
| (setf (deferred-value d) value) | |||||
| value)))) | |||||
| (error | |||||
| (cond | |||||
| (next-deferred | |||||
| (deferred:post-task next-deferred 'ng err)) | |||||
| (deferred:onerror | |||||
| (deferred:call-lambda deferred:onerror err)) | |||||
| (t | |||||
| (deferred:message "ERROR : %S" err) | |||||
| (message "deferred error : %S" err) | |||||
| (setf (deferred-status d) 'ng) | |||||
| (setf (deferred-value d) err) | |||||
| err))))) | |||||
| (t ; <= (null callback) | |||||
| (cond | |||||
| (next-deferred | |||||
| (deferred:exec-task next-deferred which arg)) | |||||
| ((eq which 'ok) arg) | |||||
| (t ; (eq which 'ng) | |||||
| (deferred:resignal arg))))))) | |||||
| (defun deferred:set-next (prev next) | |||||
| "[internal] Connect deferred objects." | |||||
| (setf (deferred-next prev) next) | |||||
| (cond | |||||
| ((eq 'ok (deferred-status prev)) | |||||
| (setf (deferred-status prev) nil) | |||||
| (let ((ret (deferred:exec-task | |||||
| next 'ok (deferred-value prev)))) | |||||
| (if (deferred-p ret) ret | |||||
| next))) | |||||
| ((eq 'ng (deferred-status prev)) | |||||
| (setf (deferred-status prev) nil) | |||||
| (let ((ret (deferred:exec-task next 'ng (deferred-value prev)))) | |||||
| (if (deferred-p ret) ret | |||||
| next))) | |||||
| (t | |||||
| next))) | |||||
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |||||
| ;; Basic functions for deferred objects | |||||
| (defun deferred:new (&optional callback) | |||||
| "Create a deferred object." | |||||
| (if callback | |||||
| (make-deferred :callback callback) | |||||
| (make-deferred))) | |||||
| (defun deferred:callback (d &optional arg) | |||||
| "Start deferred chain with a callback message." | |||||
| (deferred:exec-task d 'ok arg)) | |||||
| (defun deferred:errorback (d &optional arg) | |||||
| "Start deferred chain with an errorback message." | |||||
| (deferred:exec-task d 'ng arg)) | |||||
| (defun deferred:callback-post (d &optional arg) | |||||
| "Add the deferred object to the execution queue." | |||||
| (deferred:post-task d 'ok arg)) | |||||
| (defun deferred:errorback-post (d &optional arg) | |||||
| "Add the deferred object to the execution queue." | |||||
| (deferred:post-task d 'ng arg)) | |||||
| (defun deferred:cancel (d) | |||||
| "Cancel all callbacks and deferred chain in the deferred object." | |||||
| (deferred:message "CANCEL : %s" d) | |||||
| (funcall (deferred-cancel d) d) | |||||
| d) | |||||
| (defun deferred:status (d) | |||||
| "Return a current status of the deferred object. The returned value means following: | |||||
| `ok': the callback was called and waiting for next deferred. | |||||
| `ng': the errorback was called and waiting for next deferred. | |||||
| nil: The neither callback nor errorback was not called." | |||||
| (deferred-status d)) | |||||
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |||||
| ;; Basic utility functions | |||||
| (defvar deferred:onerror nil | |||||
| "Default error handler. This value is nil or a function that | |||||
| have one argument for the error message.") | |||||
| (defun deferred:succeed (&optional arg) | |||||
| "Create a synchronous deferred object." | |||||
| (let ((d (deferred:new))) | |||||
| (deferred:exec-task d 'ok arg) | |||||
| d)) | |||||
| (defun deferred:fail (&optional arg) | |||||
| "Create a synchronous deferred object." | |||||
| (let ((d (deferred:new))) | |||||
| (deferred:exec-task d 'ng arg) | |||||
| d)) | |||||
| (defun deferred:next (&optional callback arg) | |||||
| "Create a deferred object and schedule executing. This function | |||||
| is a short cut of following code: | |||||
| (deferred:callback-post (deferred:new callback))." | |||||
| (let ((d (if callback | |||||
| (make-deferred :callback callback) | |||||
| (make-deferred)))) | |||||
| (deferred:callback-post d arg) | |||||
| d)) | |||||
| (defun deferred:nextc (d callback) | |||||
| "Create a deferred object with OK callback and connect it to the given deferred object." | |||||
| (let ((nd (make-deferred :callback callback))) | |||||
| (deferred:set-next d nd))) | |||||
| (defun deferred:error (d callback) | |||||
| "Create a deferred object with errorback and connect it to the given deferred object." | |||||
| (let ((nd (make-deferred :errorback callback))) | |||||
| (deferred:set-next d nd))) | |||||
| (defun deferred:watch (d callback) | |||||
| "Create a deferred object with watch task and connect it to the given deferred object. | |||||
| The watch task CALLBACK can not affect deferred chains with | |||||
| return values. This function is used in following purposes, | |||||
| simulation of try-finally block in asynchronous tasks, progress | |||||
| monitoring of tasks." | |||||
| (lexical-let* | |||||
| ((callback callback) | |||||
| (normal (lambda (x) (ignore-errors (deferred:call-lambda callback x)) x)) | |||||
| (err (lambda (e) | |||||
| (ignore-errors (deferred:call-lambda callback e)) | |||||
| (deferred:resignal e)))) | |||||
| (let ((nd (make-deferred :callback normal :errorback err))) | |||||
| (deferred:set-next d nd)))) | |||||
| (defun deferred:wait (msec) | |||||
| "Return a deferred object scheduled at MSEC millisecond later." | |||||
| (lexical-let | |||||
| ((d (deferred:new)) (start-time (float-time)) timer) | |||||
| (deferred:message "WAIT : %s" msec) | |||||
| (setq timer (deferred:setTimeout | |||||
| (lambda () | |||||
| (deferred:exec-task d 'ok | |||||
| (* 1000.0 (- (float-time) start-time))) | |||||
| nil) msec)) | |||||
| (setf (deferred-cancel d) | |||||
| (lambda (x) | |||||
| (deferred:cancelTimeout timer) | |||||
| (deferred:default-cancel x))) | |||||
| d)) | |||||
| (defun deferred:wait-idle (msec) | |||||
| "Return a deferred object which will run when Emacs has been | |||||
| idle for MSEC millisecond." | |||||
| (lexical-let | |||||
| ((d (deferred:new)) (start-time (float-time)) timer) | |||||
| (deferred:message "WAIT-IDLE : %s" msec) | |||||
| (setq timer | |||||
| (deferred:run-with-idle-timer | |||||
| (/ msec 1000.0) | |||||
| (lambda () | |||||
| (deferred:exec-task d 'ok | |||||
| (* 1000.0 (- (float-time) start-time))) | |||||
| nil))) | |||||
| (setf (deferred-cancel d) | |||||
| (lambda (x) | |||||
| (deferred:cancelTimeout timer) | |||||
| (deferred:default-cancel x))) | |||||
| d)) | |||||
| (defun deferred:call (f &rest args) | |||||
| "Call the given function asynchronously." | |||||
| (lexical-let ((f f) (args args)) | |||||
| (deferred:next | |||||
| (lambda (x) | |||||
| (apply f args))))) | |||||
| (defun deferred:apply (f &optional args) | |||||
| "Call the given function asynchronously." | |||||
| (lexical-let ((f f) (args args)) | |||||
| (deferred:next | |||||
| (lambda (x) | |||||
| (apply f args))))) | |||||
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |||||
| ;; Utility functions | |||||
| (defun deferred:empty-p (times-or-list) | |||||
| "[internal] Return non-nil if TIMES-OR-LIST is the number zero or nil." | |||||
| (or (and (numberp times-or-list) (<= times-or-list 0)) | |||||
| (and (listp times-or-list) (null times-or-list)))) | |||||
| (defun deferred:loop (times-or-list func) | |||||
| "Return a iteration deferred object." | |||||
| (deferred:message "LOOP : %s" times-or-list) | |||||
| (if (deferred:empty-p times-or-list) (deferred:next) | |||||
| (lexical-let* | |||||
| (items (rd | |||||
| (cond | |||||
| ((numberp times-or-list) | |||||
| (loop for i from 0 below times-or-list | |||||
| with ld = (deferred:next) | |||||
| do | |||||
| (push ld items) | |||||
| (setq ld | |||||
| (lexical-let ((i i) (func func)) | |||||
| (deferred:nextc ld (lambda (x) (deferred:call-lambda func i))))) | |||||
| finally return ld)) | |||||
| ((listp times-or-list) | |||||
| (loop for i in times-or-list | |||||
| with ld = (deferred:next) | |||||
| do | |||||
| (push ld items) | |||||
| (setq ld | |||||
| (lexical-let ((i i) (func func)) | |||||
| (deferred:nextc ld (lambda (x) (deferred:call-lambda func i))))) | |||||
| finally return ld))))) | |||||
| (setf (deferred-cancel rd) | |||||
| (lambda (x) (deferred:default-cancel x) | |||||
| (loop for i in items | |||||
| do (deferred:cancel i)))) | |||||
| rd))) | |||||
| (defun deferred:trans-multi-args (args self-func list-func main-func) | |||||
| "[internal] Check the argument values and dispatch to methods." | |||||
| (cond | |||||
| ((and (= 1 (length args)) (consp (car args)) (not (functionp (car args)))) | |||||
| (let ((lst (car args))) | |||||
| (cond | |||||
| ((or (null lst) (null (car lst))) | |||||
| (deferred:next)) | |||||
| ((deferred:aand lst (car it) (or (functionp it) (deferred-p it))) | |||||
| ;; a list of deferred objects | |||||
| (funcall list-func lst)) | |||||
| ((deferred:aand lst (consp it)) | |||||
| ;; an alist of deferred objects | |||||
| (funcall main-func lst)) | |||||
| (t (error "Wrong argument type. %s" args))))) | |||||
| (t (funcall self-func args)))) | |||||
| (defun deferred:parallel-array-to-alist (lst) | |||||
| "[internal] Translation array to alist." | |||||
| (loop for d in lst | |||||
| for i from 0 below (length lst) | |||||
| collect (cons i d))) | |||||
| (defun deferred:parallel-alist-to-array (alst) | |||||
| "[internal] Translation alist to array." | |||||
| (loop for pair in | |||||
| (sort alst (lambda (x y) | |||||
| (< (car x) (car y)))) | |||||
| collect (cdr pair))) | |||||
| (defun deferred:parallel-func-to-deferred (alst) | |||||
| "[internal] Normalization for parallel and earlier arguments." | |||||
| (loop for pair in alst | |||||
| for d = (cdr pair) | |||||
| collect | |||||
| (progn | |||||
| (unless (deferred-p d) | |||||
| (setf (cdr pair) (deferred:next d))) | |||||
| pair))) | |||||
| (defun deferred:parallel-main (alst) | |||||
| "[internal] Deferred alist implementation for `deferred:parallel'. " | |||||
| (deferred:message "PARALLEL<KEY . VALUE>" ) | |||||
| (lexical-let ((nd (deferred:new)) | |||||
| (len (length alst)) | |||||
| values) | |||||
| (loop for pair in | |||||
| (deferred:parallel-func-to-deferred alst) | |||||
| with cd ; current child deferred | |||||
| do | |||||
| (lexical-let ((name (car pair))) | |||||
| (setq cd | |||||
| (deferred:nextc (cdr pair) | |||||
| (lambda (x) | |||||
| (push (cons name x) values) | |||||
| (deferred:message "PARALLEL VALUE [%s/%s] %s" | |||||
| (length values) len (cons name x)) | |||||
| (when (= len (length values)) | |||||
| (deferred:message "PARALLEL COLLECTED") | |||||
| (deferred:post-task nd 'ok (nreverse values))) | |||||
| nil))) | |||||
| (deferred:error cd | |||||
| (lambda (e) | |||||
| (push (cons name e) values) | |||||
| (deferred:message "PARALLEL ERROR [%s/%s] %s" | |||||
| (length values) len (cons name e)) | |||||
| (when (= (length values) len) | |||||
| (deferred:message "PARALLEL COLLECTED") | |||||
| (deferred:post-task nd 'ok (nreverse values))) | |||||
| nil)))) | |||||
| nd)) | |||||
| (defun deferred:parallel-list (lst) | |||||
| "[internal] Deferred list implementation for `deferred:parallel'. " | |||||
| (deferred:message "PARALLEL<LIST>" ) | |||||
| (lexical-let* | |||||
| ((pd (deferred:parallel-main (deferred:parallel-array-to-alist lst))) | |||||
| (rd (deferred:nextc pd 'deferred:parallel-alist-to-array))) | |||||
| (setf (deferred-cancel rd) | |||||
| (lambda (x) (deferred:default-cancel x) | |||||
| (deferred:cancel pd))) | |||||
| rd)) | |||||
| (defun deferred:parallel (&rest args) | |||||
| "Return a deferred object that calls given deferred objects or | |||||
| functions in parallel and wait for all callbacks. The following | |||||
| deferred task will be called with an array of the return | |||||
| values. ARGS can be a list or an alist of deferred objects or | |||||
| functions." | |||||
| (deferred:message "PARALLEL : %s" args) | |||||
| (deferred:trans-multi-args args | |||||
| 'deferred:parallel 'deferred:parallel-list 'deferred:parallel-main)) | |||||
| (defun deferred:earlier-main (alst) | |||||
| "[internal] Deferred alist implementation for `deferred:earlier'. " | |||||
| (deferred:message "EARLIER<KEY . VALUE>" ) | |||||
| (lexical-let ((nd (deferred:new)) | |||||
| (len (length alst)) | |||||
| value results) | |||||
| (loop for pair in | |||||
| (deferred:parallel-func-to-deferred alst) | |||||
| with cd ; current child deferred | |||||
| do | |||||
| (lexical-let ((name (car pair))) | |||||
| (setq cd | |||||
| (deferred:nextc (cdr pair) | |||||
| (lambda (x) | |||||
| (push (cons name x) results) | |||||
| (cond | |||||
| ((null value) | |||||
| (setq value (cons name x)) | |||||
| (deferred:message "EARLIER VALUE %s" (cons name value)) | |||||
| (deferred:post-task nd 'ok value)) | |||||
| (t | |||||
| (deferred:message "EARLIER MISS [%s/%s] %s" (length results) len (cons name value)) | |||||
| (when (eql (length results) len) | |||||
| (deferred:message "EARLIER COLLECTED")))) | |||||
| nil))) | |||||
| (deferred:error cd | |||||
| (lambda (e) | |||||
| (push (cons name e) results) | |||||
| (deferred:message "EARLIER ERROR [%s/%s] %s" (length results) len (cons name e)) | |||||
| (when (and (eql (length results) len) (null value)) | |||||
| (deferred:message "EARLIER FAILED") | |||||
| (deferred:post-task nd 'ok nil)) | |||||
| nil)))) | |||||
| nd)) | |||||
| (defun deferred:earlier-list (lst) | |||||
| "[internal] Deferred list implementation for `deferred:earlier'. " | |||||
| (deferred:message "EARLIER<LIST>" ) | |||||
| (lexical-let* | |||||
| ((pd (deferred:earlier-main (deferred:parallel-array-to-alist lst))) | |||||
| (rd (deferred:nextc pd (lambda (x) (cdr x))))) | |||||
| (setf (deferred-cancel rd) | |||||
| (lambda (x) (deferred:default-cancel x) | |||||
| (deferred:cancel pd))) | |||||
| rd)) | |||||
| (defun deferred:earlier (&rest args) | |||||
| "Return a deferred object that calls given deferred objects or | |||||
| functions in parallel and wait for the first callback. The | |||||
| following deferred task will be called with the first return | |||||
| value. ARGS can be a list or an alist of deferred objects or | |||||
| functions." | |||||
| (deferred:message "EARLIER : %s" args) | |||||
| (deferred:trans-multi-args args | |||||
| 'deferred:earlier 'deferred:earlier-list 'deferred:earlier-main)) | |||||
| (defmacro deferred:timeout (timeout-msec timeout-form d) | |||||
| "Time out macro on a deferred task D. If the deferred task D | |||||
| does not complete within TIMEOUT-MSEC, this macro cancels the | |||||
| deferred task and return the TIMEOUT-FORM." | |||||
| `(deferred:earlier | |||||
| (deferred:nextc (deferred:wait ,timeout-msec) | |||||
| (lambda (x) ,timeout-form)) | |||||
| ,d)) | |||||
| ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |||||
| ;; Application functions | |||||
| (defvar deferred:uid 0 "[internal] Sequence number for some utilities. See the function `deferred:uid'.") | |||||
| (defun deferred:uid () | |||||
| "[internal] Generate a sequence number." | |||||
| (incf deferred:uid)) | |||||
| (defun deferred:buffer-string (strformat buf) | |||||
| "[internal] Return a string in the buffer with the given format." | |||||
| (format strformat | |||||
| (with-current-buffer buf (buffer-string)))) | |||||
| (defun deferred:process (command &rest args) | |||||
| "A deferred wrapper of `start-process'. Return a deferred | |||||
| object. The process name and buffer name of the argument of the | |||||
| `start-process' are generated by this function automatically. | |||||
| The next deferred object receives stdout string from the command | |||||
| process." | |||||
| (deferred:process-gen 'start-process command args)) | |||||
| (defun deferred:process-shell (command &rest args) | |||||
| "A deferred wrapper of `start-process-shell-command'. Return a deferred | |||||
| object. The process name and buffer name of the argument of the | |||||
| `start-process-shell-command' are generated by this function automatically. | |||||
| The next deferred object receives stdout string from the command | |||||
| process." | |||||
| (deferred:process-gen 'start-process-shell-command command args)) | |||||
| (defun deferred:process-buffer (command &rest args) | |||||
| "A deferred wrapper of `start-process'. Return a deferred | |||||
| object. The process name and buffer name of the argument of the | |||||
| `start-process' are generated by this function automatically. | |||||
| The next deferred object receives stdout buffer from the command | |||||
| process." | |||||
| (deferred:process-buffer-gen 'start-process command args)) | |||||
| (defun deferred:process-shell-buffer (command &rest args) | |||||
| "A deferred wrapper of `start-process-shell-command'. Return a deferred | |||||
| object. The process name and buffer name of the argument of the | |||||
| `start-process-shell-command' are generated by this function automatically. | |||||
| The next deferred object receives stdout buffer from the command | |||||
| process." | |||||
| (deferred:process-buffer-gen 'start-process-shell-command command args)) | |||||
| (defun deferred:process-gen (f command args) | |||||
| "[internal]" | |||||
| (lexical-let | |||||
| ((pd (deferred:process-buffer-gen f command args)) d) | |||||
| (setq d (deferred:nextc pd | |||||
| (lambda (buf) | |||||
| (prog1 | |||||
| (with-current-buffer buf (buffer-string)) | |||||
| (kill-buffer buf))))) | |||||
| (setf (deferred-cancel d) | |||||
| (lambda (x) | |||||
| (deferred:default-cancel d) | |||||
| (deferred:default-cancel pd))) | |||||
| d)) | |||||
| (defun deferred:process-buffer-gen (f command args) | |||||
| "[internal]" | |||||
| (let ((d (deferred:next)) (uid (deferred:uid))) | |||||
| (lexical-let | |||||
| ((f f) (command command) (args args) | |||||
| (proc-name (format "*deferred:*%s*:%s" command uid)) | |||||
| (buf-name (format " *deferred:*%s*:%s" command uid)) | |||||
| (pwd default-directory) | |||||
| (env process-environment) | |||||
| (con-type process-connection-type) | |||||
| (nd (deferred:new)) proc-buf proc) | |||||
| (deferred:nextc d | |||||
| (lambda (x) | |||||
| (setq proc-buf (get-buffer-create buf-name)) | |||||
| (condition-case err | |||||
| (let ((default-directory pwd) | |||||
| (process-environment env) | |||||
| (process-connection-type con-type)) | |||||
| (setq proc | |||||
| (if (null (car args)) | |||||
| (apply f proc-name buf-name command nil) | |||||
| (apply f proc-name buf-name command args))) | |||||
| (set-process-sentinel | |||||
| proc | |||||
| (lambda (proc event) | |||||
| (cond | |||||
| ((string-match "exited abnormally" event) | |||||
| (let ((msg (if (buffer-live-p proc-buf) | |||||
| (format "Process [%s] exited abnormally : %s" | |||||
| command | |||||
| (with-current-buffer proc-buf (buffer-string))) | |||||
| (concat "Process exited abnormally: " proc-name)))) | |||||
| (kill-buffer proc-buf) | |||||
| (deferred:post-task nd 'ng msg))) | |||||
| ((equal event "finished\n") | |||||
| (deferred:post-task nd 'ok proc-buf))))) | |||||
| (setf (deferred-cancel nd) | |||||
| (lambda (x) (deferred:default-cancel x) | |||||
| (when proc | |||||
| (kill-process proc) | |||||
| (kill-buffer proc-buf))))) | |||||
| (error (deferred:post-task nd 'ng err))) | |||||
| nil)) | |||||
| nd))) | |||||
| (defmacro deferred:processc (d command &rest args) | |||||
| "Process chain of `deferred:process'." | |||||
| `(deferred:nextc ,d | |||||
| (lambda (,(gensym)) (deferred:process ,command ,@args)))) | |||||
| (defmacro deferred:process-bufferc (d command &rest args) | |||||
| "Process chain of `deferred:process-buffer'." | |||||
| `(deferred:nextc ,d | |||||
| (lambda (,(gensym)) (deferred:process-buffer ,command ,@args)))) | |||||
| (defmacro deferred:process-shellc (d command &rest args) | |||||
| "Process chain of `deferred:process'." | |||||
| `(deferred:nextc ,d | |||||
| (lambda (,(gensym)) (deferred:process-shell ,command ,@args)))) | |||||
| (defmacro deferred:process-shell-bufferc (d command &rest args) | |||||
| "Process chain of `deferred:process-buffer'." | |||||
| `(deferred:nextc ,d | |||||
| (lambda (,(gensym)) (deferred:process-shell-buffer ,command ,@args)))) | |||||
| (eval-after-load "url" | |||||
| ;; for url package | |||||
| ;; TODO: proxy, charaset | |||||
| ;; List of gloabl variables to preserve and restore before url-retrieve call | |||||
| '(lexical-let ((url-global-variables '(url-request-data | |||||
| url-request-method | |||||
| url-request-extra-headers))) | |||||
| (defun deferred:url-retrieve (url &optional cbargs silent inhibit-cookies) | |||||
| "A wrapper function for url-retrieve. The next deferred | |||||
| object receives the buffer object that URL will load | |||||
| into. Values of dynamically bound 'url-request-data', 'url-request-method' and | |||||
| 'url-request-extra-headers' are passed to url-retrieve call." | |||||
| (lexical-let ((nd (deferred:new)) (url url) | |||||
| (cbargs cbargs) (silent silent) (inhibit-cookies inhibit-cookies) buf | |||||
| (local-values (mapcar (lambda (symbol) (symbol-value symbol)) url-global-variables))) | |||||
| (deferred:next | |||||
| (lambda (x) | |||||
| (progv url-global-variables local-values | |||||
| (condition-case err | |||||
| (setq buf | |||||
| (url-retrieve | |||||
| url (lambda (xx) (deferred:post-task nd 'ok buf)) | |||||
| cbargs silent inhibit-cookies)) | |||||
| (error (deferred:post-task nd 'ng err))) | |||||
| nil))) | |||||
| (setf (deferred-cancel nd) | |||||
| (lambda (x) | |||||
| (when (buffer-live-p buf) | |||||
| (kill-buffer buf)))) | |||||
| nd)) | |||||
| (defun deferred:url-delete-header (buf) | |||||
| (with-current-buffer buf | |||||
| (let ((pos (url-http-symbol-value-in-buffer | |||||
| 'url-http-end-of-headers buf))) | |||||
| (when pos | |||||
| (delete-region (point-min) (1+ pos))))) | |||||
| buf) | |||||
| (defun deferred:url-delete-buffer (buf) | |||||
| (when (and buf (buffer-live-p buf)) | |||||
| (kill-buffer buf)) | |||||
| nil) | |||||
| (defun deferred:url-get (url &optional params &rest args) | |||||
| "Perform a HTTP GET method with `url-retrieve'. PARAMS is | |||||
| a parameter list of (key . value) or key. ARGS will be appended | |||||
| to deferred:url-retrieve args list. The next deferred | |||||
| object receives the buffer object that URL will load into." | |||||
| (when params | |||||
| (setq url | |||||
| (concat url "?" (deferred:url-param-serialize params)))) | |||||
| (let ((d (deferred:$ | |||||
| (apply 'deferred:url-retrieve url args) | |||||
| (deferred:nextc it 'deferred:url-delete-header)))) | |||||
| (deferred:set-next | |||||
| d (deferred:new 'deferred:url-delete-buffer)) | |||||
| d)) | |||||
| (defun deferred:url-post (url &optional params &rest args) | |||||
| "Perform a HTTP POST method with `url-retrieve'. PARAMS is | |||||
| a parameter list of (key . value) or key. ARGS will be appended | |||||
| to deferred:url-retrieve args list. The next deferred | |||||
| object receives the buffer object that URL will load into." | |||||
| (let ((url-request-method "POST") | |||||
| (url-request-extra-headers | |||||
| (append url-request-extra-headers | |||||
| '(("Content-Type" . "application/x-www-form-urlencoded")))) | |||||
| (url-request-data (deferred:url-param-serialize params))) | |||||
| (let ((d (deferred:$ | |||||
| (apply 'deferred:url-retrieve url args) | |||||
| (deferred:nextc it 'deferred:url-delete-header)))) | |||||
| (deferred:set-next | |||||
| d (deferred:new 'deferred:url-delete-buffer)) | |||||
| d))) | |||||
| (defun deferred:url-escape (val) | |||||
| "[internal] Return a new string that is VAL URI-encoded." | |||||
| (unless (stringp val) | |||||
| (setq val (format "%s" val))) | |||||
| (url-hexify-string | |||||
| (encode-coding-string val 'utf-8))) | |||||
| (defun deferred:url-param-serialize (params) | |||||
| "[internal] Serialize a list of (key . value) cons cells | |||||
| into a query string." | |||||
| (when params | |||||
| (mapconcat | |||||
| 'identity | |||||
| (loop for p in params | |||||
| collect | |||||
| (cond | |||||
| ((consp p) | |||||
| (concat | |||||
| (deferred:url-escape (car p)) "=" | |||||
| (deferred:url-escape (cdr p)))) | |||||
| (t | |||||
| (deferred:url-escape p)))) | |||||
| "&"))) | |||||
| )) | |||||
| (provide 'deferred) | |||||
| ;;; deferred.el ends here | |||||
| @ -0,0 +1,16 @@ | |||||
| ;;; epc-autoloads.el --- automatically extracted autoloads | |||||
| ;; | |||||
| ;;; Code: | |||||
| (add-to-list 'load-path (or (file-name-directory #$) (car load-path))) | |||||
| ;;;### (autoloads nil nil ("epc-pkg.el" "epc.el" "epcs.el") (21571 | |||||
| ;;;;;; 44957 379234 0)) | |||||
| ;;;*** | |||||
| ;; Local Variables: | |||||
| ;; version-control: never | |||||
| ;; no-byte-compile: t | |||||
| ;; no-update-autoloads: t | |||||
| ;; End: | |||||
| ;;; epc-autoloads.el ends here | |||||
| @ -0,0 +1,8 @@ | |||||
| (define-package "epc" "20140609.2234" "A RPC stack for the Emacs Lisp" | |||||
| '((concurrent "0.3.1") | |||||
| (ctable "0.1.2")) | |||||
| :url "https://github.com/kiwanami/emacs-epc" :keywords | |||||
| '("lisp" "rpc")) | |||||
| ;; Local Variables: | |||||
| ;; no-byte-compile: t | |||||
| ;; End: | |||||
| @ -0,0 +1,965 @@ | |||||
| ;;; epc.el --- A RPC stack for the Emacs Lisp | |||||
| ;; Copyright (C) 2011, 2012, 2013 Masashi Sakurai | |||||
| ;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net> | |||||
| ;; Version: 0.1.1 | |||||
| ;; Keywords: lisp, rpc | |||||
| ;; Package-Requires: ((concurrent "0.3.1") (ctable "0.1.2")) | |||||
| ;; URL: https://github.com/kiwanami/emacs-epc | |||||
| ;; 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: | |||||
| ;; This program is an asynchronous RPC stack for Emacs. Using this | |||||
| ;; RPC stack, the Emacs can communicate with the peer process. | |||||
| ;; Because the protocol is S-expression encoding and consists of | |||||
| ;; asynchronous communications, the RPC response is fairly good. | |||||
| ;; | |||||
| ;; Current implementations for the EPC are followings: | |||||
| ;; - epcs.el : Emacs Lisp implementation | |||||
| ;; - RPC::EPC::Service : Perl implementation | |||||
| ;;; Code: | |||||
| (eval-when-compile (require 'cl)) | |||||
| (require 'concurrent) | |||||
| (require 'ctable) | |||||
| ;;================================================== | |||||
| ;; Utility | |||||
| (defvar epc:debug-out nil) | |||||
| (defvar epc:debug-buffer "*epc log*") | |||||
| (defvar epc:mngr) | |||||
| ;;(setq epc:debug-out t) | |||||
| ;;(setq epc:debug-out nil) | |||||
| (defun epc:log-init () | |||||
| (when (get-buffer epc:debug-buffer) | |||||
| (kill-buffer epc:debug-buffer))) | |||||
| (defun epc:log (&rest args) | |||||
| (when epc:debug-out | |||||
| (with-current-buffer | |||||
| (get-buffer-create epc:debug-buffer) | |||||
| (buffer-disable-undo) | |||||
| (goto-char (point-max)) | |||||
| (insert (apply 'format args) "\n")))) | |||||
| (defun epc:make-procbuf (name) | |||||
| "[internal] Make a process buffer." | |||||
| (let ((buf (get-buffer-create name))) | |||||
| (with-current-buffer buf | |||||
| (set (make-local-variable 'kill-buffer-query-functions) nil) | |||||
| (erase-buffer) (buffer-disable-undo)) | |||||
| buf)) | |||||
| (defun epc:document-function (function docstring) | |||||
| "Document FUNCTION with DOCSTRING. Use this for `defstruct' accessor etc." | |||||
| (put function 'function-documentation docstring)) | |||||
| (put 'epc:document-function 'lisp-indent-function 'defun) | |||||
| (put 'epc:document-function 'doc-string-elt 2) | |||||
| ;;================================================== | |||||
| ;; Low Level Interface | |||||
| (defvar epc:uid 1) | |||||
| (defun epc:uid () | |||||
| (incf epc:uid)) | |||||
| (defvar epc:accept-process-timeout 150 "Asynchronous timeout time. (msec)") | |||||
| (defvar epc:accept-process-timeout-count 100 " Startup function waits (`epc:accept-process-timeout' * `epc:accept-process-timeout-count') msec for the external process getting ready.") | |||||
| (put 'epc-error 'error-conditions '(error epc-error)) | |||||
| (put 'epc-error 'error-message "EPC Error") | |||||
| (defstruct epc:connection | |||||
| "Set of information for network connection and event handling. | |||||
| name : Connection name. This name is used for process and buffer names. | |||||
| process : Connection process object. | |||||
| buffer : Working buffer for the incoming data. | |||||
| channel : Event channels for incoming messages." | |||||
| name process buffer channel) | |||||
| (epc:document-function 'epc:connection-name | |||||
| "[internal] Connection name. This name is used for process and buffer names. | |||||
| \(fn EPC:CONNECTION)") | |||||
| (epc:document-function 'epc:connection-process | |||||
| "[internal] Connection process object. | |||||
| \(fn EPC:CONNECTION)") | |||||
| (epc:document-function 'epc:connection-buffer | |||||
| "[internal] Working buffer for the incoming data. | |||||
| \(fn EPC:CONNECTION)") | |||||
| (epc:document-function 'epc:connection-channel | |||||
| "[internal] Event channels for incoming messages. | |||||
| \(fn EPC:CONNECTION)") | |||||
| (defun epc:connect (host port) | |||||
| "[internal] Connect the server, initialize the process and | |||||
| return epc:connection object." | |||||
| (epc:log ">> Connection start: %s:%s" host port) | |||||
| (lexical-let* ((connection-id (epc:uid)) | |||||
| (connection-name (format "epc con %s" connection-id)) | |||||
| (connection-buf (epc:make-procbuf (format "*%s*" connection-name))) | |||||
| (connection-process | |||||
| (open-network-stream connection-name connection-buf host port)) | |||||
| (channel (cc:signal-channel connection-name)) | |||||
| (connection (make-epc:connection | |||||
| :name connection-name | |||||
| :process connection-process | |||||
| :buffer connection-buf | |||||
| :channel channel))) | |||||
| (epc:log ">> Connection establish") | |||||
| (set-process-coding-system connection-process 'binary 'binary) | |||||
| (set-process-filter connection-process | |||||
| (lambda (p m) | |||||
| (epc:process-filter connection p m))) | |||||
| (set-process-sentinel connection-process | |||||
| (lambda (p e) | |||||
| (epc:process-sentinel connection p e))) | |||||
| (set-process-query-on-exit-flag connection-process nil) | |||||
| connection)) | |||||
| (defun epc:connection-reset (connection) | |||||
| "[internal] Reset the connection for restarting the process." | |||||
| (cc:signal-disconnect-all (epc:connection-channel connection)) | |||||
| connection) | |||||
| (defun epc:process-sentinel (connection process msg) | |||||
| (epc:log "!! Process Sentinel [%s] : %S : %S" | |||||
| (epc:connection-name connection) process msg) | |||||
| (epc:disconnect connection)) | |||||
| (defun epc:net-send (connection sexp) | |||||
| (let* ((msg (encode-coding-string | |||||
| (concat (epc:prin1-to-string sexp) "\n") 'utf-8-unix)) | |||||
| (string (concat (epc:net-encode-length (length msg)) msg)) | |||||
| (proc (epc:connection-process connection))) | |||||
| (epc:log ">> SEND : [%S]" string) | |||||
| (process-send-string proc string))) | |||||
| (defun epc:disconnect (connection) | |||||
| (lexical-let | |||||
| ((process (epc:connection-process connection)) | |||||
| (buf (epc:connection-buffer connection)) | |||||
| (name (epc:connection-name connection))) | |||||
| (epc:log "!! Disconnect [%s]" name) | |||||
| (when process | |||||
| (set-process-sentinel process nil) | |||||
| (delete-process process) | |||||
| (when (get-buffer buf) (kill-buffer buf))) | |||||
| (epc:log "!! Disconnected finished [%s]" name))) | |||||
| (defun epc:process-filter (connection process message) | |||||
| (epc:log "INCOMING: [%s] [%S]" (epc:connection-name connection) message) | |||||
| (with-current-buffer (epc:connection-buffer connection) | |||||
| (goto-char (point-max)) | |||||
| (insert message) | |||||
| (epc:process-available-input connection process))) | |||||
| (defun epc:process-available-input (connection process) | |||||
| "Process all complete messages that have arrived from Lisp." | |||||
| (with-current-buffer (process-buffer process) | |||||
| (while (epc:net-have-input-p) | |||||
| (let ((event (epc:net-read-or-lose process)) | |||||
| (ok nil)) | |||||
| (epc:log "<< RECV [%S]" event) | |||||
| (unwind-protect | |||||
| (condition-case err | |||||
| (progn | |||||
| (apply 'cc:signal-send | |||||
| (cons (epc:connection-channel connection) event)) | |||||
| (setq ok t)) | |||||
| ('error (epc:log "MsgError: %S / <= %S" err event))) | |||||
| (unless ok | |||||
| (epc:run-when-idle 'epc:process-available-input connection process))))))) | |||||
| (defun epc:net-have-input-p () | |||||
| "Return true if a complete message is available." | |||||
| (goto-char (point-min)) | |||||
| (and (>= (buffer-size) 6) | |||||
| (>= (- (buffer-size) 6) (epc:net-decode-length)))) | |||||
| (defun epc:run-when-idle (function &rest args) | |||||
| "Call FUNCTION as soon as Emacs is idle." | |||||
| (apply #'run-at-time | |||||
| (if (featurep 'xemacs) itimer-short-interval 0) | |||||
| nil function args)) | |||||
| (defun epc:net-read-or-lose (process) | |||||
| (condition-case error | |||||
| (epc:net-read) | |||||
| (error | |||||
| (debug 'error error) | |||||
| (error "net-read error: %S" error)))) | |||||
| (defun epc:net-read () | |||||
| "Read a message from the network buffer." | |||||
| (goto-char (point-min)) | |||||
| (let* ((length (epc:net-decode-length)) | |||||
| (start (+ 6 (point))) | |||||
| (end (+ start length)) content) | |||||
| (assert (plusp length)) | |||||
| (prog1 (save-restriction | |||||
| (narrow-to-region start end) | |||||
| (read (decode-coding-string | |||||
| (buffer-string) 'utf-8-unix))) | |||||
| (delete-region (point-min) end)))) | |||||
| (defun epc:net-decode-length () | |||||
| "Read a 24-bit hex-encoded integer from buffer." | |||||
| (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) 16)) | |||||
| (defun epc:net-encode-length (n) | |||||
| "Encode an integer into a 24-bit hex string." | |||||
| (format "%06x" n)) | |||||
| (defun epc:prin1-to-string (sexp) | |||||
| "Like `prin1-to-string' but don't octal-escape non-ascii characters. | |||||
| This is more compatible with the CL reader." | |||||
| (with-temp-buffer | |||||
| (let (print-escape-nonascii | |||||
| print-escape-newlines | |||||
| print-length | |||||
| print-level) | |||||
| (prin1 sexp (current-buffer)) | |||||
| (buffer-string)))) | |||||
| ;;================================================== | |||||
| ;; High Level Interface | |||||
| (defstruct epc:manager | |||||
| "Root object that holds all information related to an EPC activity. | |||||
| `epc:start-epc' returns this object. | |||||
| title : instance name for displaying on the `epc:controller' UI | |||||
| server-process : process object for the peer | |||||
| commands : a list of (prog . args) | |||||
| port : port number | |||||
| connection : epc:connection instance | |||||
| methods : alist of method (name . function) | |||||
| sessions : alist of session (id . deferred) | |||||
| exit-hook : functions for after shutdown EPC connection" | |||||
| title server-process commands port connection methods sessions exit-hooks) | |||||
| (epc:document-function 'epc:manager-title | |||||
| "Instance name (string) for displaying on the `epc:controller' UI | |||||
| You can modify this slot using `setf' to change the title column | |||||
| in the `epc:controller' table UI. | |||||
| \(fn EPC:MANAGER)") | |||||
| (epc:document-function 'epc:manager-server-process | |||||
| "Process object for the peer. | |||||
| This is *not* network process but the external program started by | |||||
| `epc:start-epc'. For network process, see `epc:connection-process'. | |||||
| \(fn EPC:MANAGER)") | |||||
| (epc:document-function 'epc:manager-commands | |||||
| "[internal] a list of (prog . args) | |||||
| \(fn EPC:MANAGER)") | |||||
| (epc:document-function 'epc:manager-port | |||||
| "Port number (integer). | |||||
| \(fn EPC:MANAGER)") | |||||
| (epc:document-function 'epc:manager-connection | |||||
| "[internal] epc:connection instance | |||||
| \(fn EPC:MANAGER)") | |||||
| (epc:document-function 'epc:manager-methods | |||||
| "[internal] alist of method (name . function) | |||||
| \(fn EPC:MANAGER)") | |||||
| (epc:document-function 'epc:manager-sessions | |||||
| "[internal] alist of session (id . deferred) | |||||
| \(fn EPC:MANAGER)") | |||||
| (epc:document-function 'epc:manager-exit-hooks | |||||
| "Hooks called after shutdown EPC connection. | |||||
| Use `epc:manager-add-exit-hook' to add hook. | |||||
| \(fn EPC:MANAGER)") | |||||
| (defstruct epc:method | |||||
| "Object to hold serving method information. | |||||
| name : method name (symbol) ex: 'test | |||||
| task : method function (function with one argument) | |||||
| arg-specs : arg-specs (one string) ex: \"(A B C D)\" | |||||
| docstring : docstring (one string) ex: \"A test function. Return sum of A,B,C and D\" | |||||
| " | |||||
| name task docstring arg-specs) | |||||
| (epc:document-function 'epc:method-name | |||||
| "[internal] method name (symbol) ex: 'test | |||||
| \(fn EPC:METHOD)") | |||||
| (epc:document-function 'epc:method-task | |||||
| "[internal] method function (function with one argument) | |||||
| \(fn EPC:METHOD)") | |||||
| (epc:document-function 'epc:method-arg-specs | |||||
| "[internal] arg-specs (one string) ex: \"(A B C D)\" | |||||
| \(fn EPC:METHOD)") | |||||
| (epc:document-function 'epc:method-docstring | |||||
| "[internal] docstring (one string) ex: \"A test function. Return sum of A,B,C and D\" | |||||
| \(fn EPC:METHOD)") | |||||
| (defvar epc:live-connections nil | |||||
| "[internal] A list of `epc:manager' objects those currently connect to the epc peer. | |||||
| This variable is for debug purpose.") | |||||
| (defun epc:live-connections-add (mngr) | |||||
| "[internal] Add the EPC manager object." | |||||
| (push mngr epc:live-connections)) | |||||
| (defun epc:live-connections-delete (mngr) | |||||
| "[internal] Remove the EPC manager object." | |||||
| (setq epc:live-connections (delete mngr epc:live-connections))) | |||||
| (defun epc:start-epc (server-prog server-args) | |||||
| "Start the epc server program and return an epc:manager object. | |||||
| Start server program SERVER-PROG with command line arguments | |||||
| SERVER-ARGS. The server program must print out the port it is | |||||
| using at the first line of its stdout. If the server prints out | |||||
| non-numeric value in the first line or does not print out the | |||||
| port number in three seconds, it is regarded as start-up | |||||
| failure." | |||||
| (let ((mngr (epc:start-server server-prog server-args))) | |||||
| (epc:init-epc-layer mngr) | |||||
| mngr)) | |||||
| (defun epc:start-epc-deferred (server-prog server-args) | |||||
| "Deferred version of `epc:start-epc'" | |||||
| (deferred:nextc (epc:start-server-deferred server-prog server-args) | |||||
| #'epc:init-epc-layer)) | |||||
| (defun epc:server-process-name (uid) | |||||
| (format "epc:server:%s" uid)) | |||||
| (defun epc:server-buffer-name (uid) | |||||
| (format " *%s*" (epc:server-process-name uid))) | |||||
| (defun epc:start-server (server-prog server-args) | |||||
| "[internal] Start a peer server and return an epc:manager instance which is set up partially." | |||||
| (let* ((uid (epc:uid)) | |||||
| (process-name (epc:server-process-name uid)) | |||||
| (process-buffer (get-buffer-create (epc:server-buffer-name uid))) | |||||
| (process (apply 'start-process | |||||
| process-name process-buffer | |||||
| server-prog server-args)) | |||||
| (cont 1) port) | |||||
| (while cont | |||||
| (accept-process-output process 0 epc:accept-process-timeout t) | |||||
| (let ((port-str (with-current-buffer process-buffer | |||||
| (buffer-string)))) | |||||
| (cond | |||||
| ((string-match "^[ \n\r]*[0-9]+[ \n\r]*$" port-str) | |||||
| (setq port (string-to-number port-str) | |||||
| cont nil)) | |||||
| ((< 0 (length port-str)) | |||||
| (error "Server may raise an error. \ | |||||
| Use \"M-x epc:pop-to-last-server-process-buffer RET\" \ | |||||
| to see full traceback:\n%s" port-str)) | |||||
| ((not (eq 'run (process-status process))) | |||||
| (setq cont nil)) | |||||
| (t | |||||
| (incf cont) | |||||
| (when (< epc:accept-process-timeout-count cont) ; timeout 15 seconds | |||||
| (error "Timeout server response.")))))) | |||||
| (set-process-query-on-exit-flag process nil) | |||||
| (make-epc:manager :server-process process | |||||
| :commands (cons server-prog server-args) | |||||
| :title (mapconcat 'identity (cons server-prog server-args) " ") | |||||
| :port port | |||||
| :connection (epc:connect "localhost" port)))) | |||||
| (defun epc:start-server-deferred (server-prog server-args) | |||||
| "[internal] Same as `epc:start-server' but start the server asynchronously." | |||||
| (lexical-let* | |||||
| ((uid (epc:uid)) | |||||
| (process-name (epc:server-process-name uid)) | |||||
| (process-buffer (get-buffer-create (epc:server-buffer-name uid))) | |||||
| (process (apply 'start-process | |||||
| process-name process-buffer | |||||
| server-prog server-args)) | |||||
| (mngr (make-epc:manager | |||||
| :server-process process | |||||
| :commands (cons server-prog server-args) | |||||
| :title (mapconcat 'identity (cons server-prog server-args) " "))) | |||||
| (cont 1) port) | |||||
| (set-process-query-on-exit-flag process nil) | |||||
| (deferred:$ | |||||
| (deferred:next | |||||
| (deferred:lambda (_) | |||||
| (accept-process-output process 0 nil t) | |||||
| (let ((port-str (with-current-buffer process-buffer | |||||
| (buffer-string)))) | |||||
| (cond | |||||
| ((string-match "^[0-9]+$" port-str) | |||||
| (setq port (string-to-number port-str) | |||||
| cont nil)) | |||||
| ((< 0 (length port-str)) | |||||
| (error "Server may raise an error. \ | |||||
| Use \"M-x epc:pop-to-last-server-process-buffer RET\" \ | |||||
| to see full traceback:\n%s" port-str)) | |||||
| ((not (eq 'run (process-status process))) | |||||
| (setq cont nil)) | |||||
| (t | |||||
| (incf cont) | |||||
| (when (< epc:accept-process-timeout-count cont) | |||||
| ;; timeout 15 seconds | |||||
| (error "Timeout server response.")) | |||||
| (deferred:nextc (deferred:wait epc:accept-process-timeout) | |||||
| self)))))) | |||||
| (deferred:nextc it | |||||
| (lambda (_) | |||||
| (setf (epc:manager-port mngr) port) | |||||
| (setf (epc:manager-connection mngr) (epc:connect "localhost" port)) | |||||
| mngr))))) | |||||
| (defun epc:stop-epc (mngr) | |||||
| "Disconnect the connection for the server." | |||||
| (let* ((proc (epc:manager-server-process mngr)) | |||||
| (buf (and proc (process-buffer proc)))) | |||||
| (epc:disconnect (epc:manager-connection mngr)) | |||||
| (when proc | |||||
| (accept-process-output proc 0 epc:accept-process-timeout t)) | |||||
| (when (and proc (equal 'run (process-status proc))) | |||||
| (kill-process proc)) | |||||
| (when buf (kill-buffer buf)) | |||||
| (condition-case err | |||||
| (epc:manager-fire-exit-hook mngr) | |||||
| (error (epc:log "Error on exit-hooks : %S / " err mngr))) | |||||
| (epc:live-connections-delete mngr))) | |||||
| (defun epc:start-epc-debug (port) | |||||
| "[internal] Return an epc:manager instance which is set up partially." | |||||
| (epc:init-epc-layer | |||||
| (make-epc:manager :server-process nil | |||||
| :commands (cons "[DEBUG]" nil) | |||||
| :port port | |||||
| :connection (epc:connect "localhost" port)))) | |||||
| (defun epc:args (args) | |||||
| "[internal] If ARGS is an atom, return it. If list, return the cadr of it." | |||||
| (cond | |||||
| ((atom args) args) | |||||
| (t (cadr args)))) | |||||
| (defun epc:init-epc-layer (mngr) | |||||
| "[internal] Connect to the server program and return an epc:connection instance." | |||||
| (lexical-let* | |||||
| ((mngr mngr) | |||||
| (conn (epc:manager-connection mngr)) | |||||
| (channel (epc:connection-channel conn))) | |||||
| ;; dispatch incoming messages with the lexical scope | |||||
| (loop for (method . body) in | |||||
| `((call | |||||
| . (lambda (args) | |||||
| (epc:log "SIG CALL: %S" args) | |||||
| (apply 'epc:handler-called-method ,mngr (epc:args args)))) | |||||
| (return | |||||
| . (lambda (args) | |||||
| (epc:log "SIG RET: %S" args) | |||||
| (apply 'epc:handler-return ,mngr (epc:args args)))) | |||||
| (return-error | |||||
| . (lambda (args) | |||||
| (epc:log "SIG RET-ERROR: %S" args) | |||||
| (apply 'epc:handler-return-error ,mngr (epc:args args)))) | |||||
| (epc-error | |||||
| . (lambda (args) | |||||
| (epc:log "SIG EPC-ERROR: %S" args) | |||||
| (apply 'epc:handler-epc-error ,mngr (epc:args args)))) | |||||
| (methods | |||||
| . (lambda (args) | |||||
| (epc:log "SIG METHODS: %S" args) | |||||
| (epc:handler-methods ,mngr (caadr args)))) | |||||
| ) do | |||||
| (cc:signal-connect channel method body)) | |||||
| (epc:live-connections-add mngr) | |||||
| mngr)) | |||||
| (defun epc:manager-add-exit-hook (mngr hook-function) | |||||
| "Register the HOOK-FUNCTION which is called after the EPC connection closed by the EPC controller UI. | |||||
| HOOK-FUNCTION is a function with no argument." | |||||
| (let* ((hooks (epc:manager-exit-hooks mngr))) | |||||
| (setf (epc:manager-exit-hooks mngr) (cons hook-function hooks)) | |||||
| mngr)) | |||||
| (defun epc:manager-fire-exit-hook (mngr) | |||||
| "[internal] Call exit-hooks functions of MNGR. After calling hooks, this functions clears the hook slot so as not to call doubly." | |||||
| (let* ((hooks (epc:manager-exit-hooks mngr))) | |||||
| (run-hooks hooks) | |||||
| (setf (epc:manager-exit-hooks mngr) nil) | |||||
| mngr)) | |||||
| (defun epc:manager-status-server-process (mngr) | |||||
| "[internal] Return the status of the process object for the peer process. If the process is nil, return nil." | |||||
| (and mngr | |||||
| (epc:manager-server-process mngr) | |||||
| (process-status (epc:manager-server-process mngr)))) | |||||
| (defun epc:manager-status-connection-process (mngr) | |||||
| "[internal] Return the status of the process object for the connection process." | |||||
| (and (epc:manager-connection mngr) | |||||
| (process-status (epc:connection-process | |||||
| (epc:manager-connection mngr))))) | |||||
| (defun epc:manager-restart-process (mngr) | |||||
| "[internal] Restart the process and reconnect." | |||||
| (cond | |||||
| ((null (epc:manager-server-process mngr)) | |||||
| (error "Cannot restart this EPC process!")) | |||||
| (t | |||||
| (epc:stop-epc mngr) | |||||
| (let* ((cmds (epc:manager-commands mngr)) | |||||
| (new-mngr (epc:start-server (car cmds) (cdr cmds)))) | |||||
| (setf (epc:manager-server-process mngr) | |||||
| (epc:manager-server-process new-mngr)) | |||||
| (setf (epc:manager-port mngr) | |||||
| (epc:manager-port new-mngr)) | |||||
| (setf (epc:manager-connection mngr) | |||||
| (epc:manager-connection new-mngr)) | |||||
| (setf (epc:manager-methods mngr) | |||||
| (epc:manager-methods new-mngr)) | |||||
| (setf (epc:manager-sessions mngr) | |||||
| (epc:manager-sessions new-mngr)) | |||||
| (epc:connection-reset (epc:manager-connection mngr)) | |||||
| (epc:init-epc-layer mngr) | |||||
| (epc:live-connections-delete new-mngr) | |||||
| (epc:live-connections-add mngr) | |||||
| mngr)))) | |||||
| (defun epc:manager-send (mngr method &rest messages) | |||||
| "[internal] low-level message sending." | |||||
| (let* ((conn (epc:manager-connection mngr))) | |||||
| (epc:net-send conn (cons method messages)))) | |||||
| (defun epc:manager-get-method (mngr method-name) | |||||
| "[internal] Return a method object. If not found, return nil." | |||||
| (loop for i in (epc:manager-methods mngr) | |||||
| if (eq method-name (epc:method-name i)) | |||||
| do (return i))) | |||||
| (defun epc:handler-methods (mngr uid) | |||||
| "[internal] Return a list of information for registered methods." | |||||
| (let ((info | |||||
| (loop for i in (epc:manager-methods mngr) | |||||
| collect | |||||
| (list | |||||
| (epc:method-name i) | |||||
| (or (epc:method-arg-specs i) "") | |||||
| (or (epc:method-docstring i) ""))))) | |||||
| (epc:manager-send mngr 'return uid info))) | |||||
| (defun epc:handler-called-method (mngr uid name args) | |||||
| "[internal] low-level message handler for peer's calling." | |||||
| (lexical-let ((mngr mngr) (uid uid)) | |||||
| (let* ((methods (epc:manager-methods mngr)) | |||||
| (method (epc:manager-get-method mngr name))) | |||||
| (cond | |||||
| ((null method) | |||||
| (epc:log "ERR: No such method : %s" name) | |||||
| (epc:manager-send mngr 'epc-error uid (format "EPC-ERROR: No such method : %s" name))) | |||||
| (t | |||||
| (condition-case err | |||||
| (let* ((f (epc:method-task method)) | |||||
| (ret (apply f args))) | |||||
| (cond | |||||
| ((deferred-p ret) | |||||
| (deferred:nextc ret | |||||
| (lambda (xx) (epc:manager-send mngr 'return uid xx)))) | |||||
| (t (epc:manager-send mngr 'return uid ret)))) | |||||
| (error | |||||
| (epc:log "ERROR : %S" err) | |||||
| (epc:manager-send mngr 'return-error uid err)))))))) | |||||
| (defun epc:manager-remove-session (mngr uid) | |||||
| "[internal] Remove a session from the epc manager object." | |||||
| (loop with ret = nil | |||||
| for pair in (epc:manager-sessions mngr) | |||||
| unless (eq uid (car pair)) | |||||
| do (push pair ret) | |||||
| finally | |||||
| do (setf (epc:manager-sessions mngr) ret))) | |||||
| (defun epc:handler-return (mngr uid args) | |||||
| "[internal] low-level message handler for normal returns." | |||||
| (let ((pair (assq uid (epc:manager-sessions mngr)))) | |||||
| (cond | |||||
| (pair | |||||
| (epc:log "RET: id:%s [%S]" uid args) | |||||
| (epc:manager-remove-session mngr uid) | |||||
| (deferred:callback (cdr pair) args)) | |||||
| (t ; error | |||||
| (epc:log "RET: NOT FOUND: id:%s [%S]" uid args))))) | |||||
| (defun epc:handler-return-error (mngr uid args) | |||||
| "[internal] low-level message handler for application errors." | |||||
| (let ((pair (assq uid (epc:manager-sessions mngr)))) | |||||
| (cond | |||||
| (pair | |||||
| (epc:log "RET-ERR: id:%s [%S]" uid args) | |||||
| (epc:manager-remove-session mngr uid) | |||||
| (deferred:errorback (cdr pair) (format "%S" args))) | |||||
| (t ; error | |||||
| (epc:log "RET-ERR: NOT FOUND: id:%s [%S]" uid args))))) | |||||
| (defun epc:handler-epc-error (mngr uid args) | |||||
| "[internal] low-level message handler for epc errors." | |||||
| (let ((pair (assq uid (epc:manager-sessions mngr)))) | |||||
| (cond | |||||
| (pair | |||||
| (epc:log "RET-EPC-ERR: id:%s [%S]" uid args) | |||||
| (epc:manager-remove-session mngr uid) | |||||
| (deferred:errorback (cdr pair) (list 'epc-error args))) | |||||
| (t ; error | |||||
| (epc:log "RET-EPC-ERR: NOT FOUND: id:%s [%S]" uid args))))) | |||||
| (defun epc:call-deferred (mngr method-name args) | |||||
| "Call peer's method with args asynchronously. Return a deferred | |||||
| object which is called with the result." | |||||
| (let ((uid (epc:uid)) | |||||
| (sessions (epc:manager-sessions mngr)) | |||||
| (d (deferred:new))) | |||||
| (push (cons uid d) sessions) | |||||
| (setf (epc:manager-sessions mngr) sessions) | |||||
| (epc:manager-send mngr 'call uid method-name args) | |||||
| d)) | |||||
| (defun epc:define-method (mngr method-name task &optional arg-specs docstring) | |||||
| "Define a method and return a deferred object which is called by the peer." | |||||
| (let* ((method (make-epc:method | |||||
| :name method-name :task task | |||||
| :arg-specs arg-specs :docstring docstring)) | |||||
| (methods (cons method (epc:manager-methods mngr)))) | |||||
| (setf (epc:manager-methods mngr) methods) | |||||
| method)) | |||||
| (defun epc:query-methods-deferred (mngr) | |||||
| "Return a list of information for the peer's methods. | |||||
| The list is consisted of lists of strings: | |||||
| (name arg-specs docstring)." | |||||
| (let ((uid (epc:uid)) | |||||
| (sessions (epc:manager-sessions mngr)) | |||||
| (d (deferred:new))) | |||||
| (push (cons uid d) sessions) | |||||
| (setf (epc:manager-sessions mngr) sessions) | |||||
| (epc:manager-send mngr 'methods uid) | |||||
| d)) | |||||
| (defun epc:sync (mngr d) | |||||
| "Wrap deferred methods with synchronous waiting, and return the result. | |||||
| If an exception is occurred, this function throws the error." | |||||
| (lexical-let ((result 'epc:nothing)) | |||||
| (deferred:$ d | |||||
| (deferred:nextc it | |||||
| (lambda (x) (setq result x))) | |||||
| (deferred:error it | |||||
| (lambda (er) (setq result (cons 'error er))))) | |||||
| (while (eq result 'epc:nothing) | |||||
| (save-current-buffer | |||||
| (accept-process-output | |||||
| (epc:connection-process (epc:manager-connection mngr)) | |||||
| 0 epc:accept-process-timeout t))) | |||||
| (if (and (consp result) (eq 'error (car result))) | |||||
| (error (cdr result)) result))) | |||||
| (defun epc:call-sync (mngr method-name args) | |||||
| "Call peer's method with args synchronously and return the result. | |||||
| If an exception is occurred, this function throws the error." | |||||
| (epc:sync mngr (epc:call-deferred mngr method-name args))) | |||||
| (defun epc:live-p (mngr) | |||||
| "Return non-nil when MNGR is an EPC manager object with a live | |||||
| connection." | |||||
| (let ((proc (ignore-errors | |||||
| (epc:connection-process (epc:manager-connection mngr))))) | |||||
| (and (processp proc) | |||||
| ;; Same as `process-live-p' in Emacs >= 24: | |||||
| (memq (process-status proc) '(run open listen connect stop))))) | |||||
| ;;================================================== | |||||
| ;; Troubleshooting / Debugging support | |||||
| (defun epc:pop-to-last-server-process-buffer () | |||||
| "Open the buffer for most recently started server program process. | |||||
| This is useful when you want to check why the server program | |||||
| failed to start (e.g., to see its traceback / error message)." | |||||
| (interactive) | |||||
| (let ((buffer (get-buffer (epc:server-buffer-name epc:uid)))) | |||||
| (if buffer | |||||
| (pop-to-buffer buffer) | |||||
| (error "No buffer for the last server process. \ | |||||
| Probably the EPC connection exits correctly or you didn't start it yet.")))) | |||||
| ;;================================================== | |||||
| ;; Management Interface | |||||
| (defun epc:controller () | |||||
| "Display the management interface for EPC processes and connections. | |||||
| Process list. | |||||
| Session status, statistics and uptime. | |||||
| Peer's method list. | |||||
| Display process buffer. | |||||
| Kill sessions and connections. | |||||
| Restart process." | |||||
| (interactive) | |||||
| (let* ((buf-name "*EPC Controller*") | |||||
| (buf (get-buffer buf-name))) | |||||
| (unless (buffer-live-p buf) | |||||
| (setq buf (get-buffer-create buf-name))) | |||||
| (epc:controller-update-buffer buf) | |||||
| (pop-to-buffer buf))) | |||||
| (defun epc:controller-update-buffer (buf) | |||||
| "[internal] Update buffer for the current epc processes." | |||||
| (let* | |||||
| ((data (loop | |||||
| for mngr in epc:live-connections collect | |||||
| (list | |||||
| (epc:manager-server-process mngr) | |||||
| (epc:manager-status-server-process mngr) | |||||
| (epc:manager-status-connection-process mngr) | |||||
| (epc:manager-title mngr) | |||||
| (epc:manager-commands mngr) | |||||
| (epc:manager-port mngr) | |||||
| (length (epc:manager-methods mngr)) | |||||
| (length (epc:manager-sessions mngr)) | |||||
| mngr))) | |||||
| (param (copy-ctbl:param ctbl:default-rendering-param)) | |||||
| (cp | |||||
| (ctbl:create-table-component-buffer | |||||
| :buffer buf :width nil | |||||
| :model | |||||
| (make-ctbl:model | |||||
| :column-model | |||||
| (list (make-ctbl:cmodel :title "<Process>" :align 'left) | |||||
| (make-ctbl:cmodel :title "<Proc>" :align 'center) | |||||
| (make-ctbl:cmodel :title "<Conn>" :align 'center) | |||||
| (make-ctbl:cmodel :title " Title " :align 'left :max-width 30) | |||||
| (make-ctbl:cmodel :title " Command " :align 'left :max-width 30) | |||||
| (make-ctbl:cmodel :title " Port " :align 'right) | |||||
| (make-ctbl:cmodel :title " Methods " :align 'right) | |||||
| (make-ctbl:cmodel :title " Live sessions " :align 'right)) | |||||
| :data data) | |||||
| :custom-map epc:controller-keymap | |||||
| :param param))) | |||||
| (pop-to-buffer (ctbl:cp-get-buffer cp)))) | |||||
| (eval-when-compile ; introduce anaphoric variable `cp' and `mngr'. | |||||
| (defmacro epc:controller-with-cp (&rest body) | |||||
| `(let ((cp (ctbl:cp-get-component))) | |||||
| (when cp | |||||
| (let ((mngr (car (last (ctbl:cp-get-selected-data-row cp))))) | |||||
| ,@body))))) | |||||
| (defun epc:controller-update-command () | |||||
| (interactive) | |||||
| (epc:controller-with-cp | |||||
| (epc:controller-update-buffer (current-buffer)))) | |||||
| (defun epc:controller-connection-restart-command () | |||||
| (interactive) | |||||
| (epc:controller-with-cp | |||||
| (let* ((proc (epc:manager-server-process mngr)) | |||||
| (msg (format "Restart the EPC process [%s] ? " proc))) | |||||
| (when (and proc (y-or-n-p msg)) | |||||
| (epc:manager-restart-process mngr) | |||||
| (epc:controller-update-buffer (current-buffer)))))) | |||||
| (defun epc:controller-connection-kill-command () | |||||
| (interactive) | |||||
| (epc:controller-with-cp | |||||
| (let* ((proc (epc:manager-server-process mngr)) | |||||
| (msg (format "Kill the EPC process [%s] ? " proc))) | |||||
| (when (and proc (y-or-n-p msg)) | |||||
| (epc:stop-epc mngr) | |||||
| (epc:controller-update-buffer (current-buffer)))))) | |||||
| (defun epc:controller-connection-buffer-command () | |||||
| (interactive) | |||||
| (epc:controller-with-cp | |||||
| (switch-to-buffer | |||||
| (epc:connection-buffer (epc:manager-connection mngr))))) | |||||
| (defun epc:controller-methods-show-command () | |||||
| (interactive) | |||||
| (epc:controller-with-cp | |||||
| (epc:controller-methods mngr))) | |||||
| (defun epc:controller-methods (mngr) | |||||
| "Display a list of methods for the MNGR process." | |||||
| (let* ((buf-name "*EPC Controller/Methods*") | |||||
| (buf (get-buffer buf-name))) | |||||
| (unless (buffer-live-p buf) | |||||
| (setq buf (get-buffer-create buf-name)) | |||||
| (with-current-buffer buf | |||||
| (setq buffer-read-only t))) | |||||
| (lexical-let ((buf buf) (mngr mngr)) | |||||
| (deferred:$ | |||||
| (epc:query-methods-deferred mngr) | |||||
| (deferred:nextc it | |||||
| (lambda (methods) | |||||
| (epc:controller-methods-update-buffer buf mngr methods) | |||||
| (pop-to-buffer buf))))))) | |||||
| (defface epc:face-title | |||||
| '((((class color) (background light)) | |||||
| :foreground "Slategray4" :background "Gray90" :weight bold) | |||||
| (((class color) (background dark)) | |||||
| :foreground "maroon2" :weight bold)) | |||||
| "Face for titles" :group 'epc) | |||||
| (defun epc:controller-methods-update-buffer (buf mngr methods) | |||||
| "[internal] Update methods list buffer for the epc process." | |||||
| (with-current-buffer buf | |||||
| (let* ((data | |||||
| (loop for m in methods collect | |||||
| (list | |||||
| (car m) | |||||
| (or (nth 1 m) "<Not specified>") | |||||
| (or (nth 2 m) "<Not specified>")))) | |||||
| (param (copy-ctbl:param ctbl:default-rendering-param)) | |||||
| cp buffer-read-only) | |||||
| (erase-buffer) | |||||
| (insert | |||||
| (propertize | |||||
| (format "EPC Process : %s\n" | |||||
| (mapconcat 'identity (epc:manager-commands mngr) " ")) | |||||
| 'face 'epc:face-title) "\n") | |||||
| (setq cp (ctbl:create-table-component-region | |||||
| :model | |||||
| (make-ctbl:model | |||||
| :column-model | |||||
| (list (make-ctbl:cmodel :title "Method Name" :align 'left) | |||||
| (make-ctbl:cmodel :title "Arguments" :align 'left) | |||||
| (make-ctbl:cmodel :title "Document" :align 'left)) | |||||
| :data data) | |||||
| :keymap epc:controller-methods-keymap | |||||
| :param param)) | |||||
| (set (make-local-variable 'epc:mngr) mngr) | |||||
| (ctbl:cp-set-selected-cell cp '(0 . 0)) | |||||
| (ctbl:cp-get-buffer cp)))) | |||||
| (defun epc:controller-methods-eval-command () | |||||
| (interactive) | |||||
| (let ((cp (ctbl:cp-get-component))) | |||||
| (when cp | |||||
| (let* ((method-name (car (ctbl:cp-get-selected-data-row cp))) | |||||
| (args (eval-minibuffer | |||||
| (format "Arguments for calling [%s] : " method-name)))) | |||||
| (deferred:$ | |||||
| (epc:call-deferred epc:mngr method-name args) | |||||
| (deferred:nextc it | |||||
| (lambda (ret) (message "Result : %S" ret))) | |||||
| (deferred:error it | |||||
| (lambda (err) (message "Error : %S" err)))))))) | |||||
| (defun epc:define-keymap (keymap-list &optional prefix) | |||||
| "[internal] Keymap utility." | |||||
| (let ((map (make-sparse-keymap))) | |||||
| (mapc | |||||
| (lambda (i) | |||||
| (define-key map | |||||
| (if (stringp (car i)) | |||||
| (read-kbd-macro | |||||
| (if prefix | |||||
| (replace-regexp-in-string "prefix" prefix (car i)) | |||||
| (car i))) | |||||
| (car i)) | |||||
| (cdr i))) | |||||
| keymap-list) | |||||
| map)) | |||||
| (defun epc:add-keymap (keymap keymap-list &optional prefix) | |||||
| (loop with nkeymap = (copy-keymap keymap) | |||||
| for i in keymap-list | |||||
| do | |||||
| (define-key nkeymap | |||||
| (if (stringp (car i)) | |||||
| (read-kbd-macro | |||||
| (if prefix | |||||
| (replace-regexp-in-string "prefix" prefix (car i)) | |||||
| (car i))) | |||||
| (car i)) | |||||
| (cdr i)) | |||||
| finally return nkeymap)) | |||||
| (defvar epc:controller-keymap | |||||
| (epc:define-keymap | |||||
| '( | |||||
| ("g" . epc:controller-update-command) | |||||
| ("R" . epc:controller-connection-restart-command) | |||||
| ("D" . epc:controller-connection-kill-command) | |||||
| ("K" . epc:controller-connection-kill-command) | |||||
| ("m" . epc:controller-methods-show-command) | |||||
| ("C-m" . epc:controller-methods-show-command) | |||||
| ("B" . epc:controller-connection-buffer-command) | |||||
| )) "Keymap for the controller buffer.") | |||||
| (defvar epc:controller-methods-keymap | |||||
| (epc:add-keymap | |||||
| ctbl:table-mode-map | |||||
| '( | |||||
| ("q" . bury-buffer) | |||||
| ("e" . epc:controller-methods-eval-command) | |||||
| )) "Keymap for the controller methods list buffer.") | |||||
| (provide 'epc) | |||||
| ;;; epc.el ends here | |||||
| @ -0,0 +1,160 @@ | |||||
| ;;; epcs.el --- EPC Server | |||||
| ;; Copyright (C) 2011,2012,2013 Masashi Sakurai | |||||
| ;; Author: Masashi Sakurai <m.sakurai at kiwanami.net> | |||||
| ;; Keywords: lisp | |||||
| ;; 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: | |||||
| (eval-when-compile (require 'cl)) | |||||
| (require 'epc) | |||||
| (defvar epcs:client-processes nil | |||||
| "[internal] A list of ([process object] . [`epc:manager' instance]). | |||||
| When the server process accepts the client connection, the | |||||
| `epc:manager' instance is created and stored in this variable | |||||
| `epcs:client-processes'. This variable is used for the management | |||||
| purpose.") | |||||
| ;; epcs:server | |||||
| ;; name : process name (string) ex: "EPC Server 1" | |||||
| ;; process : server process object | |||||
| ;; port : port number | |||||
| ;; connect-function : initialize function for `epc:manager' instances | |||||
| (defstruct epcs:server name process port connect-function) | |||||
| (defvar epcs:server-processes nil | |||||
| "[internal] A list of ([process object] . [`epcs:server' instance]). | |||||
| This variable is used for the management purpose.") | |||||
| (defun epcs:server-start (connect-function &optional port) | |||||
| "Start TCP Server and return the main process object." | |||||
| (lexical-let* | |||||
| ((connect-function connect-function) | |||||
| (name (format "EPC Server %s" (epc:uid))) | |||||
| (buf (epc:make-procbuf (format "*%s*" name))) | |||||
| (main-process | |||||
| (make-network-process | |||||
| :name name | |||||
| :buffer buf | |||||
| :family 'ipv4 :server t :nowait t | |||||
| :host "127.0.0.1" :service (or port t) | |||||
| :sentinel | |||||
| (lambda (process message) | |||||
| (epcs:sentinel process message connect-function))))) | |||||
| (unless port | |||||
| ;; notify port number to the parent process via STDOUT. | |||||
| (message "%s\n" (process-contact main-process :service))) | |||||
| (push (cons main-process | |||||
| (make-epcs:server | |||||
| :name name :process main-process | |||||
| :port (process-contact main-process :service) | |||||
| :connect-function connect-function)) | |||||
| epcs:server-processes) | |||||
| main-process)) | |||||
| (defun epcs:server-stop (process) | |||||
| "Stop the TCP server process." | |||||
| (cond | |||||
| ((and process | |||||
| (assq process epcs:server-processes)) | |||||
| (epc:log "EPCS: Shutdown Server: %S" process) | |||||
| (let ((buf (process-buffer process))) | |||||
| (delete-process process) | |||||
| (kill-buffer buf)) | |||||
| (setq epcs:server-processes | |||||
| (assq-delete-all process epcs:server-processes))) | |||||
| (t (error "Not found in the server process list. [%S]" process)))) | |||||
| (defun epcs:get-manager-by-process (proc) | |||||
| "[internal] Return the epc:manager instance for the PROC." | |||||
| (loop for (pp . mngr) in epcs:client-processes | |||||
| if (eql pp proc) | |||||
| do (return mngr) | |||||
| finally return nil)) | |||||
| (defun epcs:kill-all-processes () | |||||
| "Kill all child processes for debug purpose." | |||||
| (interactive) | |||||
| (loop for (proc . mngr) in epcs:client-processes | |||||
| do (ignore-errors | |||||
| (delete-process proc) | |||||
| (kill-buffer (process-buffer proc))))) | |||||
| (defun epcs:accept (process) | |||||
| "[internal] Initialize the process and return epc:manager object." | |||||
| (epc:log "EPCS: >> Connection accept: %S" process) | |||||
| (lexical-let* ((connection-id (epc:uid)) | |||||
| (connection-name (format "epc con %s" connection-id)) | |||||
| (channel (cc:signal-channel connection-name)) | |||||
| (connection (make-epc:connection | |||||
| :name connection-name | |||||
| :process process | |||||
| :buffer (process-buffer process) | |||||
| :channel channel))) | |||||
| (epc:log "EPCS: >> Connection establish") | |||||
| (set-process-coding-system process 'binary 'binary) | |||||
| (set-process-filter process | |||||
| (lambda (p m) | |||||
| (epc:process-filter connection p m))) | |||||
| (set-process-sentinel process | |||||
| (lambda (p e) | |||||
| (epc:process-sentinel connection p e))) | |||||
| (make-epc:manager :server-process process :port t | |||||
| :connection connection))) | |||||
| (defun epcs:sentinel (process message connect-function) | |||||
| "[internal] Process sentinel handler for the server process." | |||||
| (epc:log "EPCS: SENTINEL: %S %S" process message) | |||||
| (let ((mngr (epcs:get-manager-by-process process))) | |||||
| (cond | |||||
| ;; new connection | |||||
| ((and (string-match "open" message) (null mngr)) | |||||
| (condition-case err | |||||
| (let ((mngr (epcs:accept process))) | |||||
| (push (cons process mngr) epcs:client-processes) | |||||
| (epc:init-epc-layer mngr) | |||||
| (when connect-function (funcall connect-function mngr)) | |||||
| mngr) | |||||
| ('error | |||||
| (epc:log "EPCS: Protocol error: %S" err) | |||||
| (epc:log "EPCS: ABORT %S" process) | |||||
| (delete-process process)))) | |||||
| ;; ignore | |||||
| ((null mngr) nil ) | |||||
| ;; disconnect | |||||
| (t | |||||
| (let ((pair (assq process epcs:client-processes)) d) | |||||
| (when pair | |||||
| (epc:log "EPCS: DISCONNECT %S" process) | |||||
| (epc:stop-epc (cdr pair)) | |||||
| (setq epcs:client-processes | |||||
| (assq-delete-all process epcs:client-processes)) | |||||
| )) | |||||
| nil)))) | |||||
| ;; Management GUI | |||||
| ;; todo... | |||||
| (provide 'epcs) | |||||
| ;;; epcs.el ends here | |||||
| @ -0,0 +1,201 @@ | |||||
| ENV = env | |||||
| VIRTUALENV_SYSTEM_SITE_PACKAGES ?= true | |||||
| VIRTUALENV = \ | |||||
| VIRTUALENV_SYSTEM_SITE_PACKAGES=$(VIRTUALENV_SYSTEM_SITE_PACKAGES) \ | |||||
| virtualenv --python=$(PYTHON) | |||||
| PIP_INSTALL = $(ENV)/$(BINDIR)/pip install | |||||
| JEDI_DEV_URL = https://github.com/davidhalter/jedi/archive/dev.zip | |||||
| PYTHON ?= python | |||||
| CASK ?= cask | |||||
| export EMACS ?= emacs | |||||
| BINDIR ?= bin | |||||
| ELPA_DIR = \ | |||||
| .cask/$(shell ${EMACS} -Q --batch --eval '(princ emacs-version)')/elpa | |||||
| # See: cask-elpa-dir | |||||
| VIRTUAL_EMACS = ${CASK} exec ${EMACS} -Q \ | |||||
| --eval "(setq python-environment--verbose t)" \ | |||||
| --eval "(setq jedi:environment-root \"$(PWD)/$(ENV)\")" | |||||
| .PHONY : test test-1 tryout clean-elpa requirements env clean-env clean \ | |||||
| print-deps travis-ci doc | |||||
| TEST_DEPS = elpa env | |||||
| test: ${TEST_DEPS} | |||||
| ${MAKE} test-1 | |||||
| test-1: | |||||
| ${VIRTUAL_EMACS} -batch \ | |||||
| -L . -l test-jedi.el -f ert-run-tests-batch-and-exit | |||||
| tox | |||||
| compile: elpa clean-elc | |||||
| ${VIRTUAL_EMACS} -batch \ | |||||
| -L . -f batch-byte-compile *.el | |||||
| clean-elc: | |||||
| rm -rf *.elc | |||||
| tryout: compile env | |||||
| ${VIRTUAL_EMACS} -L . -l tryout-jedi.el | |||||
| doc: elpa | |||||
| make -C doc html | |||||
| ensure-git: | |||||
| test -d .git # Running task that can be run only in git repository | |||||
| elpa: ${ELPA_DIR} | |||||
| ${ELPA_DIR}: Cask | |||||
| ${CASK} install | |||||
| test -d $@ | |||||
| touch $@ | |||||
| clean-elpa: | |||||
| rm -rf ${ELPA_DIR} | |||||
| requirements: | |||||
| @echo "**************************************************************" | |||||
| @echo " ERROR: \"make requirements\" is obsolete!" | |||||
| @echo " Please run \"M-x jedi:install-server\" inside of your Emacs." | |||||
| @echo " * If you are using el-get, please update it first." | |||||
| @echo " See also: https://github.com/dimitri/el-get/pull/1603" | |||||
| @echo "**************************************************************" | |||||
| @exit 1 | |||||
| install-jedi-dev: | |||||
| ${PIP_INSTALL} --upgrade ${JEDI_DEV_URL} | |||||
| env: $(ENV)/$(BINDIR)/jediepcserver | |||||
| $(ENV)/$(BINDIR)/jediepcserver: ${ELPA_DIR} jediepcserver.py setup.py | |||||
| ${VIRTUAL_EMACS} -batch -l jedi.el -f "jedi:install-server-block" | |||||
| test -f $@ | |||||
| clean-env: | |||||
| rm -rf $(ENV) | |||||
| clean-el: clean-elpa clean-elc | |||||
| clean: clean-env clean-el | |||||
| rm -rf .cask | |||||
| print-deps: elpa env | |||||
| @echo "----------------------- Dependencies -----------------------" | |||||
| $(EMACS) --version | |||||
| ${VIRTUAL_EMACS} -batch -l jedi.el -f jedi:print-jedi-version | |||||
| ls -d $(ENV)/*/python*/site-packages/*egg-info | |||||
| @echo "------------------------------------------------------------" | |||||
| before-test: ${TEST_DEPS} | |||||
| tox --notest | |||||
| travis-ci: print-deps test | |||||
| test ! -d ~/.emacs.d/.python-environments | |||||
| # Run test against Emacs listed in ${EMACS_LIST}. | |||||
| # This is for running tests for multiple Emacs versions. | |||||
| # This is not used in Travis CI. Usage:: | |||||
| # | |||||
| # make EMACS_LIST="emacs emacs-snapshot emacs23" test-all | |||||
| # | |||||
| # See: http://stackoverflow.com/a/12110773/727827 | |||||
| # | |||||
| # Use ${MET_MAKEFLAGS} to do the tests in parallel. | |||||
| # | |||||
| # MET_MAKEFLAGS=-j4 | |||||
| JOBS := $(addprefix job-,${EMACS_LIST}) | |||||
| .PHONY: ${JOBS} | |||||
| ${JOBS}: job-%: | |||||
| ${MAKE} EMACS=$* clean-elc elpa | |||||
| ${MAKE} EMACS=$* ${MET_MAKEFLAGS} test-1 | |||||
| test-all: env ${JOBS} | |||||
| ### Packaging | |||||
| # | |||||
| # Create dist/${PACKAGE}-${VERSION}.tar.gz ready for distribution. | |||||
| # | |||||
| # See: (info "(elisp) Multi-file Packages") | |||||
| PACKAGE = jedi | |||||
| VERSION = $(shell grep ';; Version:' jedi.el | sed 's/^.* \([0-9].*\)$$/\1/') | |||||
| DIST_FILES = jedi-pkg.el jedi.el jediepcserver.py \ | |||||
| Makefile tryout-jedi.el | |||||
| .PHONY: dist ${PACKAGE}-${VERSION}.tar.gz ${PACKAGE}-${VERSION} \ | |||||
| clean-dist clean-dist-all | |||||
| dist: clean-dist | |||||
| ${MAKE} dist-1 | |||||
| dist-1: dist/${PACKAGE}-${VERSION}.tar dist/${PACKAGE}-${VERSION}.tar.gz | |||||
| dist/${PACKAGE}-${VERSION}.tar: ${PACKAGE}-${VERSION}.tar | |||||
| ${PACKAGE}-${VERSION}.tar: ${PACKAGE}-${VERSION} | |||||
| tar --directory dist -cvf dist/$@ $< | |||||
| dist/${PACKAGE}-${VERSION}.tar.gz: ${PACKAGE}-${VERSION}.tar.gz | |||||
| ${PACKAGE}-${VERSION}.tar.gz: ${PACKAGE}-${VERSION} | |||||
| tar --directory dist -cvzf dist/$@ $< | |||||
| ${PACKAGE}-${VERSION}: dist/${PACKAGE}-${VERSION} | |||||
| dist/${PACKAGE}-${VERSION}: | |||||
| mkdir -p $@ | |||||
| cp -v ${DIST_FILES} $@ | |||||
| clean-dist: | |||||
| rm -rf dist/${PACKAGE}-${VERSION}* | |||||
| clean-dist-all: | |||||
| rm -rf dist | |||||
| ### Package installation | |||||
| PACKAGE_USER_DIR = | |||||
| TEST_PACKAGE_DIR = dist/test | |||||
| install-dist: | |||||
| test -d '${PACKAGE_USER_DIR}' | |||||
| ${EMACS} --batch -Q \ | |||||
| -l package \ | |||||
| --eval " \ | |||||
| (add-to-list 'package-archives \ | |||||
| '(\"marmalade\" . \"http://marmalade-repo.org/packages/\") t)" \ | |||||
| --eval '(setq package-user-dir "${PWD}/${PACKAGE_USER_DIR}")' \ | |||||
| --eval '(package-list-packages)' \ | |||||
| --eval '(package-install-file "${PWD}/dist/${PACKAGE}-${VERSION}.tar")' | |||||
| test-install: dist/${PACKAGE}-${VERSION}.tar | |||||
| rm -rf ${TEST_PACKAGE_DIR} | |||||
| mkdir -p ${TEST_PACKAGE_DIR} | |||||
| ${MAKE} install-dist PACKAGE_USER_DIR=${TEST_PACKAGE_DIR} | |||||
| test-install-requirement: test-install | |||||
| ${MAKE} --directory ${TEST_PACKAGE_DIR}/${PACKAGE}-${VERSION} \ | |||||
| requirements | |||||
| ### GH pages | |||||
| MAKE_GH_PAGES = $(MAKE) --directory doc --file gh-pages.mk | |||||
| gh-pages-latest: | |||||
| $(MAKE_GH_PAGES) | |||||
| # Publish released documentation. This task can be run only when the | |||||
| # current revision has tag (i.e., released). | |||||
| gh-pages-released: | |||||
| # Make sure it's on tag | |||||
| git describe --tags --dirty | grep -v - | |||||
| # Run doc/gh-pages.mk | |||||
| $(MAKE_GH_PAGES) DOC_VER=released | |||||
| @ -0,0 +1,125 @@ | |||||
| ;;; jedi-autoloads.el --- automatically extracted autoloads | |||||
| ;; | |||||
| ;;; Code: | |||||
| (add-to-list 'load-path (or (file-name-directory #$) (car load-path))) | |||||
| ;;;### (autoloads nil "jedi" "jedi.el" (21571 44958 0 0)) | |||||
| ;;; Generated autoloads from jedi.el | |||||
| (autoload 'jedi:start-dedicated-server "jedi" "\ | |||||
| Start Jedi server dedicated to this buffer. | |||||
| This is useful, for example, when you want to use different | |||||
| `sys.path' for some buffer. When invoked as an interactive | |||||
| command, it asks you how to start the Jedi server. You can edit | |||||
| the command in minibuffer to specify the way Jedi server run. | |||||
| If you want to setup how Jedi server is started programmatically | |||||
| per-buffer/per-project basis, make `jedi:server-command' and | |||||
| `jedi:server-args' buffer local and set it in `python-mode-hook'. | |||||
| See also: `jedi:server-args'. | |||||
| \(fn COMMAND)" t nil) | |||||
| (autoload 'jedi:complete "jedi" "\ | |||||
| Complete code at point. | |||||
| \(fn &key (expand ac-expand-on-auto-complete))" t nil) | |||||
| (autoload 'jedi:ac-setup "jedi" "\ | |||||
| Add Jedi AC sources to `ac-sources'. | |||||
| If auto-completion is all you need, you can call this function instead | |||||
| of `jedi:setup', like this:: | |||||
| (add-hook 'python-mode-hook 'jedi:ac-setup) | |||||
| Note that this function calls `auto-complete-mode' if it is not | |||||
| already enabled, for people who don't call `global-auto-complete-mode' | |||||
| in their Emacs configuration. | |||||
| \(fn)" t nil) | |||||
| (autoload 'helm-jedi-related-names "jedi" "\ | |||||
| Find related names of the object at point using `helm' interface. | |||||
| \(fn)" t nil) | |||||
| (autoload 'anything-jedi-related-names "jedi" "\ | |||||
| Find related names of the object at point using `anything' interface. | |||||
| \(fn)" t nil) | |||||
| (autoload 'jedi:setup "jedi" "\ | |||||
| Fully setup jedi.el for current buffer. | |||||
| It setups `ac-sources' (calls `jedi:ac-setup') and turns | |||||
| `jedi-mode' on. | |||||
| This function is intended to be called from `python-mode-hook', | |||||
| like this:: | |||||
| (add-hook 'python-mode-hook 'jedi:setup) | |||||
| You can also call this function as a command, to quickly test | |||||
| what jedi can do. | |||||
| \(fn)" t nil) | |||||
| (autoload 'jedi:install-server "jedi" "\ | |||||
| This command installs Jedi server script jediepcserver.py in a | |||||
| Python environment dedicated to Emacs. By default, the | |||||
| environment is at ``~/.emacs.d/.python-environments/default/``. | |||||
| This environment is automatically created by ``virtualenv`` if it | |||||
| does not exist. | |||||
| Run this command (i.e., type ``M-x jedi:install-server RET``) | |||||
| whenever Jedi.el shows a message to do so. It is a good idea to | |||||
| run this every time after you update Jedi.el to sync version of | |||||
| Python modules used by Jedi.el and Jedi.el itself. | |||||
| You can modify the location of the environment by changing | |||||
| `jedi:environment-root' and/or `python-environment-directory'. More | |||||
| specifically, Jedi.el will install Python modules under the directory | |||||
| ``PYTHON-ENVIRONMENT-DIRECTORY/JEDI:ENVIRONMENT-ROOT``. Note that you | |||||
| need command line program ``virtualenv``. If you have the command in | |||||
| an unusual location, use `python-environment-virtualenv' to specify the | |||||
| location. | |||||
| .. NOTE:: jediepcserver.py is installed in a virtual environment but it | |||||
| does not mean Jedi.el cannot recognize the modules in virtual | |||||
| environment you are using for your Python development. Jedi | |||||
| EPC server recognize the virtualenv it is in (i.e., the | |||||
| environment variable ``VIRTUAL_ENV`` in your Emacs) and then | |||||
| add modules in that environment to its ``sys.path``. You can | |||||
| also add ``--virtual-env PATH/TO/ENV`` to `jedi:server-args' | |||||
| to include modules of virtual environment even you launch | |||||
| Emacs outside of the virtual environment. | |||||
| .. NOTE:: It is highly recommended to use this command to install | |||||
| Python modules for Jedi.el. You still can install Python | |||||
| modules used by Jedi.el manually. However, you are then | |||||
| responsible for keeping Jedi.el and Python modules compatible. | |||||
| See also: | |||||
| - https://github.com/tkf/emacs-jedi/pull/72 | |||||
| - https://github.com/tkf/emacs-jedi/issues/140#issuecomment-37358527 | |||||
| \(fn)" t nil) | |||||
| (autoload 'jedi:install-server-block "jedi" "\ | |||||
| Blocking version `jedi:install-server'. | |||||
| \(fn)" nil nil) | |||||
| ;;;*** | |||||
| ;;;### (autoloads nil nil ("jedi-pkg.el") (21571 44958 323059 0)) | |||||
| ;;;*** | |||||
| ;; Local Variables: | |||||
| ;; version-control: never | |||||
| ;; no-byte-compile: t | |||||
| ;; no-update-autoloads: t | |||||
| ;; End: | |||||
| ;;; jedi-autoloads.el ends here | |||||
| @ -0,0 +1,7 @@ | |||||
| (define-package "jedi" "20140321.1323" "Python auto-completion for Emacs" | |||||
| '((epc "0.1.0") | |||||
| (auto-complete "1.4") | |||||
| (python-environment "0.0.2"))) | |||||
| ;; Local Variables: | |||||
| ;; no-byte-compile: t | |||||
| ;; End: | |||||
| @ -0,0 +1,314 @@ | |||||
| #!/usr/bin/env python | |||||
| """ | |||||
| Jedi EPC server. | |||||
| Copyright (C) 2012 Takafumi Arakaki | |||||
| Author: Takafumi Arakaki <aka.tkf at gmail.com> | |||||
| This file is NOT part of GNU Emacs. | |||||
| Jedi EPC server 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. | |||||
| Jedi EPC server 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 Jedi EPC server. | |||||
| If not, see <http://www.gnu.org/licenses/>. | |||||
| """ | |||||
| import os | |||||
| import sys | |||||
| import re | |||||
| import itertools | |||||
| import logging | |||||
| import site | |||||
| jedi = None # I will load it later | |||||
| PY3 = (sys.version_info[0] >= 3) | |||||
| NEED_ENCODE = not PY3 | |||||
| def jedi_script(source, line, column, source_path): | |||||
| if NEED_ENCODE: | |||||
| source = source.encode('utf-8') | |||||
| source_path = source_path and source_path.encode('utf-8') | |||||
| return jedi.Script(source, line, column, source_path or '') | |||||
| def candidate_symbol(comp): | |||||
| """ | |||||
| Return a character representing completion type. | |||||
| :type comp: jedi.api.Completion | |||||
| :arg comp: A completion object returned by `jedi.Script.complete`. | |||||
| """ | |||||
| try: | |||||
| return comp.type[0].lower() | |||||
| except (AttributeError, TypeError): | |||||
| return '?' | |||||
| def candidates_description(comp): | |||||
| """ | |||||
| Return `comp.description` in an appropriate format. | |||||
| * Avoid return a string 'None'. | |||||
| * Strip off all newlines. This is required for using | |||||
| `comp.description` as candidate summary. | |||||
| """ | |||||
| desc = comp.description | |||||
| return _WHITESPACES_RE.sub(' ', desc) if desc and desc != 'None' else '' | |||||
| _WHITESPACES_RE = re.compile(r'\s+') | |||||
| def complete(*args): | |||||
| reply = [] | |||||
| for comp in jedi_script(*args).complete(): | |||||
| reply.append(dict( | |||||
| word=comp.word, | |||||
| doc=comp.doc, | |||||
| description=candidates_description(comp), | |||||
| symbol=candidate_symbol(comp), | |||||
| )) | |||||
| return reply | |||||
| def get_in_function_call(*args): | |||||
| call_def = jedi_script(*args).get_in_function_call() | |||||
| if call_def: | |||||
| return dict( | |||||
| # p.get_code(False) should do the job. But jedi-vim use replace. | |||||
| # So follow what jedi-vim does... | |||||
| params=[p.get_code().replace('\n', '') for p in call_def.params], | |||||
| index=call_def.index, | |||||
| call_name=call_def.call_name, | |||||
| ) | |||||
| else: | |||||
| return [] # nil | |||||
| def _goto(method, *args): | |||||
| """ | |||||
| Helper function for `goto` and `related_names`. | |||||
| :arg method: `jedi.Script.goto` or `jedi.Script.related_names` | |||||
| :arg args: Arguments to `jedi_script` | |||||
| """ | |||||
| # `definitions` is a list. Each element is an instances of | |||||
| # `jedi.api_classes.BaseOutput` subclass, i.e., | |||||
| # `jedi.api_classes.RelatedName` or `jedi.api_classes.Definition`. | |||||
| definitions = method(jedi_script(*args)) | |||||
| return [dict( | |||||
| column=d.column, | |||||
| line_nr=d.line_nr, | |||||
| module_path=d.module_path if d.module_path != '__builtin__' else [], | |||||
| module_name=d.module_name, | |||||
| description=d.description, | |||||
| ) for d in definitions] | |||||
| def goto(*args): | |||||
| return _goto(jedi.Script.goto, *args) | |||||
| def related_names(*args): | |||||
| return _goto(jedi.Script.related_names, *args) | |||||
| def definition_to_dict(d): | |||||
| return dict( | |||||
| doc=d.doc, | |||||
| description=d.description, | |||||
| desc_with_module=d.desc_with_module, | |||||
| line_nr=d.line_nr, | |||||
| column=d.column, | |||||
| module_path=d.module_path, | |||||
| name=getattr(d, 'name', []), | |||||
| full_name=getattr(d, 'full_name', []), | |||||
| type=getattr(d, 'type', []), | |||||
| ) | |||||
| def get_definition(*args): | |||||
| definitions = jedi_script(*args).get_definition() | |||||
| return list(map(definition_to_dict, definitions)) | |||||
| def get_names_recursively(definition, parent=None): | |||||
| """ | |||||
| Fetch interesting defined names in sub-scopes under `definition`. | |||||
| :type names: jedi.api_classes.Definition | |||||
| """ | |||||
| d = definition_to_dict(definition) | |||||
| try: | |||||
| d['local_name'] = parent['local_name'] + '.' + d['name'] | |||||
| except (AttributeError, TypeError): | |||||
| d['local_name'] = d['name'] | |||||
| if definition.type == 'class': | |||||
| ds = definition.defined_names() | |||||
| return [d] + [get_names_recursively(c, d) for c in ds] | |||||
| else: | |||||
| return [d] | |||||
| def defined_names(*args): | |||||
| return list(map(get_names_recursively, jedi.api.defined_names(*args))) | |||||
| def get_module_version(module): | |||||
| try: | |||||
| from pkg_resources import get_distribution, DistributionNotFound | |||||
| try: | |||||
| return get_distribution(module.__name__).version | |||||
| except DistributionNotFound: | |||||
| pass | |||||
| except ImportError: | |||||
| pass | |||||
| notfound = object() | |||||
| for key in ['__version__', 'version']: | |||||
| version = getattr(module, key, notfound) | |||||
| if version is not notfound: | |||||
| return version | |||||
| def get_jedi_version(): | |||||
| import epc | |||||
| import sexpdata | |||||
| return [dict( | |||||
| name=module.__name__, | |||||
| file=getattr(module, '__file__', []), | |||||
| version=get_module_version(module) or [], | |||||
| ) for module in [sys, jedi, epc, sexpdata]] | |||||
| def jedi_epc_server(address='localhost', port=0, port_file=sys.stdout, | |||||
| sys_path=[], virtual_env=[], | |||||
| debugger=None, log=None, log_level=None, | |||||
| log_traceback=None): | |||||
| add_virtualenv_path() | |||||
| for p in virtual_env: | |||||
| add_virtualenv_path(p) | |||||
| sys_path = map(os.path.expandvars, map(os.path.expanduser, sys_path)) | |||||
| sys.path = [''] + list(filter(None, itertools.chain(sys_path, sys.path))) | |||||
| # Workaround Jedi's module cache. Use this workaround until Jedi | |||||
| # got an API to set module paths. | |||||
| # See also: https://github.com/davidhalter/jedi/issues/36 | |||||
| import_jedi() | |||||
| import epc.server | |||||
| server = epc.server.EPCServer((address, port)) | |||||
| server.register_function(complete) | |||||
| server.register_function(get_in_function_call) | |||||
| server.register_function(goto) | |||||
| server.register_function(related_names) | |||||
| server.register_function(get_definition) | |||||
| server.register_function(defined_names) | |||||
| server.register_function(get_jedi_version) | |||||
| @server.register_function | |||||
| def toggle_log_traceback(): | |||||
| server.log_traceback = not server.log_traceback | |||||
| return server.log_traceback | |||||
| port_file.write(str(server.server_address[1])) # needed for Emacs client | |||||
| port_file.write("\n") | |||||
| port_file.flush() | |||||
| if port_file is not sys.stdout: | |||||
| port_file.close() | |||||
| # This is not supported Python-EPC API, but I am using this for | |||||
| # backward compatibility for Python-EPC < 0.0.4. In the future, | |||||
| # it should be passed to the constructor. | |||||
| server.log_traceback = bool(log_traceback) | |||||
| if log: | |||||
| handler = logging.FileHandler(filename=log, mode='w') | |||||
| if log_level: | |||||
| log_level = getattr(logging, log_level.upper()) | |||||
| handler.setLevel(log_level) | |||||
| server.logger.setLevel(log_level) | |||||
| server.logger.addHandler(handler) | |||||
| if debugger: | |||||
| server.set_debugger(debugger) | |||||
| handler = logging.StreamHandler() | |||||
| handler.setLevel(logging.DEBUG) | |||||
| server.logger.addHandler(handler) | |||||
| server.logger.setLevel(logging.DEBUG) | |||||
| server.serve_forever() | |||||
| server.logger.info('exit') | |||||
| return server | |||||
| def import_jedi(): | |||||
| global jedi | |||||
| import jedi | |||||
| import jedi.api | |||||
| def add_virtualenv_path(venv=os.getenv('VIRTUAL_ENV')): | |||||
| """Add virtualenv's site-packages to `sys.path`.""" | |||||
| if not venv: | |||||
| return | |||||
| venv = os.path.abspath(venv) | |||||
| path = os.path.join( | |||||
| venv, 'lib', 'python%d.%d' % sys.version_info[:2], 'site-packages') | |||||
| sys.path.insert(0, path) | |||||
| site.addsitedir(path) | |||||
| def main(args=None): | |||||
| import argparse | |||||
| parser = argparse.ArgumentParser( | |||||
| formatter_class=argparse.RawTextHelpFormatter, | |||||
| description=__doc__) | |||||
| parser.add_argument( | |||||
| '--address', default='localhost') | |||||
| parser.add_argument( | |||||
| '--port', default=0, type=int) | |||||
| parser.add_argument( | |||||
| '--port-file', '-f', default='-', type=argparse.FileType('wt'), | |||||
| help='file to write port on. default is stdout.') | |||||
| parser.add_argument( | |||||
| '--sys-path', '-p', default=[], action='append', | |||||
| help='paths to be inserted at the top of `sys.path`.') | |||||
| parser.add_argument( | |||||
| '--virtual-env', '-v', default=[], action='append', | |||||
| help='paths to be used as if VIRTUAL_ENV is set to it.') | |||||
| parser.add_argument( | |||||
| '--log', help='save server log to this file.') | |||||
| parser.add_argument( | |||||
| '--log-level', | |||||
| choices=['CRITICAL', 'ERROR', 'WARN', 'INFO', 'DEBUG'], | |||||
| help='logging level for log file.') | |||||
| parser.add_argument( | |||||
| '--log-traceback', action='store_true', default=False, | |||||
| help='Include traceback in logging output.') | |||||
| parser.add_argument( | |||||
| '--pdb', dest='debugger', const='pdb', action='store_const', | |||||
| help='start pdb when error occurs.') | |||||
| parser.add_argument( | |||||
| '--ipdb', dest='debugger', const='ipdb', action='store_const', | |||||
| help='start ipdb when error occurs.') | |||||
| ns = parser.parse_args(args) | |||||
| jedi_epc_server(**vars(ns)) | |||||
| if __name__ == '__main__': | |||||
| main() | |||||
| @ -0,0 +1,25 @@ | |||||
| try: | |||||
| from setuptools import setup | |||||
| args = {} | |||||
| except ImportError: | |||||
| from distutils.core import setup | |||||
| args = dict(scripts=['jediepcserver.py']) | |||||
| print("""\ | |||||
| *** WARNING: setuptools is not found. Using distutils... | |||||
| It is highly recommended to install Jedi.el via M-x jedi:install-server. | |||||
| Note: If you are using Windows, then Jedi.el will not work with distutils. | |||||
| """) | |||||
| setup( | |||||
| name='jediepcserver', | |||||
| py_modules=['jediepcserver'], | |||||
| install_requires=[ | |||||
| "jedi>=0.7.0", | |||||
| "epc>=0.0.4", | |||||
| "argparse", | |||||
| ], | |||||
| entry_points={ | |||||
| 'console_scripts': ['jediepcserver = jediepcserver:main'], | |||||
| }, | |||||
| **args | |||||
| ) | |||||
| @ -0,0 +1,16 @@ | |||||
| ;;; python-environment-autoloads.el --- automatically extracted autoloads | |||||
| ;; | |||||
| ;;; Code: | |||||
| (add-to-list 'load-path (or (file-name-directory #$) (car load-path))) | |||||
| ;;;### (autoloads nil nil ("python-environment-pkg.el" "python-environment.el" | |||||
| ;;;;;; "test-python-environment.el") (21571 44955 482681 0)) | |||||
| ;;;*** | |||||
| ;; Local Variables: | |||||
| ;; version-control: never | |||||
| ;; no-byte-compile: t | |||||
| ;; no-update-autoloads: t | |||||
| ;; End: | |||||
| ;;; python-environment-autoloads.el ends here | |||||
| @ -0,0 +1,7 @@ | |||||
| (define-package "python-environment" "20140321.1116" "virtualenv API for Emacs Lisp" | |||||
| '((deferred "0.3.1")) | |||||
| :keywords | |||||
| '("applications" "tools")) | |||||
| ;; Local Variables: | |||||
| ;; no-byte-compile: t | |||||
| ;; End: | |||||
| @ -0,0 +1,246 @@ | |||||
| ;;; python-environment.el --- virtualenv API for Emacs Lisp | |||||
| ;; Copyright (C) 2013 Takafumi Arakaki | |||||
| ;; Author: Takafumi Arakaki <aka.tkf at gmail.com> | |||||
| ;; Keywords: applications, tools | |||||
| ;; Version: 0.0.2alpha0 | |||||
| ;; Package-Requires: ((deferred "0.3.1")) | |||||
| ;; This file is NOT part of GNU Emacs. | |||||
| ;; python-environment.el 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. | |||||
| ;; python-environment.el 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 python-environment.el. | |||||
| ;; If not, see <http://www.gnu.org/licenses/>. | |||||
| ;;; Commentary: | |||||
| ;; | |||||
| ;;; Code: | |||||
| (eval-when-compile (require 'cl)) | |||||
| (require 'deferred) | |||||
| (defconst python-environment-version "0.0.2alpha0") | |||||
| (defcustom python-environment-directory | |||||
| (locate-user-emacs-file ".python-environments") | |||||
| "Path to directory to store all Python virtual environments. A string. | |||||
| If you want to change the location to, say ``~/.python-environments``, | |||||
| then set it like this in your Emacs setup file:: | |||||
| (setq python-environment-directory \"~/.python-environments\")" | |||||
| :group 'python-environment) | |||||
| (defcustom python-environment-default-root-name "default" | |||||
| "Default Python virtual environment name. A string. | |||||
| This is a name of directory relative to `python-environment-directory' | |||||
| where default virtual environment locates. | |||||
| Thus, typically the default virtual environment path is | |||||
| ``~/.emacs.d/.python-environments/default``." | |||||
| :group 'python-environment) | |||||
| (defcustom python-environment-virtualenv | |||||
| (list "virtualenv" "--system-site-packages" "--quiet") | |||||
| ;; --quiet is required for Windows. Without it, virtualenv raises | |||||
| ;; UnicodeEncodeError | |||||
| ;; See: https://github.com/tkf/emacs-jedi/issues/148#issuecomment-38290546 | |||||
| "``virtualenv`` command to use, including command options. List of strings. | |||||
| For example, if you want to use specific Python executable (to | |||||
| specify Python version), append ``--python`` option like this:: | |||||
| (setq python-environment-virtualenv | |||||
| (append python-environment-virtualenv | |||||
| '(\"--python\" \"PATH/TO/bin/python\"))) | |||||
| I added ``--system-site-packages`` as default, but this is not | |||||
| mandatory. If you don't like it, removing does not break | |||||
| anything (well, theoretically). For reason why it is default, | |||||
| see discussion here: | |||||
| https://github.com/tkf/emacs-python-environment/issues/3" | |||||
| :group 'python-environment) | |||||
| (defvar python-environment--verbose nil) | |||||
| (defun python-environment--deferred-process (msg command) | |||||
| (message "%s..." msg) | |||||
| (deferred:$ | |||||
| (apply #'deferred:process command) | |||||
| (deferred:watch it | |||||
| (apply-partially | |||||
| (lambda (msg output) | |||||
| (message "%s...Done" msg) | |||||
| (when python-environment--verbose | |||||
| (message output))) | |||||
| msg)))) | |||||
| (defun python-environment--blocking-process (msg command) | |||||
| (message "%s (SYNC)..." msg) | |||||
| (let (exit-code output) | |||||
| (with-temp-buffer | |||||
| (setq exit-code | |||||
| (apply #'call-process (car command) | |||||
| nil ; INFILE (no input) | |||||
| t ; BUFFER (output to this buffer) | |||||
| nil ; DISPLAY (no refresh is needed) | |||||
| (cdr command))) | |||||
| (setq output (buffer-string))) | |||||
| (when (or python-environment--verbose | |||||
| (not (= exit-code 0))) | |||||
| (message output)) | |||||
| (message "%s (SYNC)...Done" msg) | |||||
| (unless (= exit-code 0) | |||||
| (error "Command %S exits with error code %S." command exit-code)))) | |||||
| (defun python-environment-root-path (&optional root) | |||||
| (expand-file-name (or root python-environment-default-root-name) | |||||
| python-environment-directory)) | |||||
| (defun python-environment--make-with-runner (proc-runner root virtualenv) | |||||
| (let ((path (convert-standard-filename | |||||
| (python-environment-root-path root))) | |||||
| (virtualenv (append (or virtualenv python-environment-virtualenv) | |||||
| (when python-environment--verbose | |||||
| (list "--verbose"))))) | |||||
| (unless (executable-find (car virtualenv)) | |||||
| (error "Program named %S does not exist." (car virtualenv))) | |||||
| (funcall proc-runner | |||||
| (format "Making virtualenv at %s" path) | |||||
| (append virtualenv (list path))))) | |||||
| (defun python-environment-make (&optional root virtualenv) | |||||
| "Make virtual environment at ROOT asynchronously. | |||||
| This function does not wait until ``virtualenv`` finishes. | |||||
| Instead, it returns a deferred object [#]_. So, if you want to | |||||
| do some operation after the ``virtualenv`` command finishes, do | |||||
| something like this:: | |||||
| (deferred:$ | |||||
| (python-environment-make) | |||||
| (deferred:nextc it (lambda (output) DO-SOMETHING-HERE))) | |||||
| If ROOT is specified, it is used instead of | |||||
| `python-environment-default-root-name'. ROOT can be a relative | |||||
| path from `python-environment-virtualenv' or an absolute path. | |||||
| If VIRTUALENV (list of string) is specified, it is used instead of | |||||
| `python-environment-virtualenv'. | |||||
| .. [#] https://github.com/kiwanami/emacs-deferred" | |||||
| (python-environment--make-with-runner | |||||
| #'python-environment--deferred-process | |||||
| root virtualenv)) | |||||
| (defun python-environment-make-block (&optional root virtualenv) | |||||
| "Blocking version of `python-environment-make'. | |||||
| I recommend NOT to use this function in interactive commands. | |||||
| For reason, see `python-environment-run-block'" | |||||
| (python-environment--make-with-runner | |||||
| #'python-environment--blocking-process | |||||
| root virtualenv)) | |||||
| (defun python-environment-exists-p (&optional root) | |||||
| "Return non-`nil' if virtualenv at ROOT exists. | |||||
| See `python-environment-make' for how ROOT is interpreted." | |||||
| (let ((bin (python-environment-bin "python" root))) | |||||
| (and bin (file-exists-p bin)))) | |||||
| (defun python-environment--existing (root &rest paths) | |||||
| (when paths | |||||
| (let ((full-path (expand-file-name (car paths) | |||||
| (python-environment-root-path root)))) | |||||
| (if (file-exists-p full-path) | |||||
| full-path | |||||
| (apply #'python-environment--existing root (cdr paths)))))) | |||||
| (defun python-environment-bin (path &optional root) | |||||
| "Return full path to \"ROOT/bin/PATH\" or \"ROOT/Scripts/PATH\" if exists. | |||||
| ``Scripts`` is used instead of ``bin`` in typical Windows case. | |||||
| In Windows, path with extension \".ext\" may be returned. | |||||
| See `python-environment-make' for how ROOT is interpreted." | |||||
| (python-environment--existing root | |||||
| (concat "bin/" path) | |||||
| (concat "Scripts/" path) | |||||
| (concat "Scripts/" path ".exe"))) | |||||
| (defun python-environment-lib (path &optional root) | |||||
| "Return full path to \"ROOT/lib/PATH\" or \"ROOT/Lib/PATH\" if exists. | |||||
| ``Lib`` is used instead of ``lib`` in typical Windows case. | |||||
| See `python-environment-make' for how ROOT is interpreted." | |||||
| (python-environment--existing root | |||||
| (concat "lib/" path) | |||||
| (concat "Lib/" path))) | |||||
| (defun python-environment--run-with-runner (proc-runner command root) | |||||
| (funcall proc-runner | |||||
| (format "Running: %s" (mapconcat 'identity command " ")) | |||||
| (cons (python-environment-bin (car command) root) | |||||
| (cdr command)))) | |||||
| (defun python-environment--run-1 (&optional command root) | |||||
| (python-environment--run-with-runner | |||||
| #'python-environment--deferred-process | |||||
| command root)) | |||||
| (defun python-environment--run-block-1 (command root) | |||||
| (python-environment--run-with-runner | |||||
| #'python-environment--blocking-process | |||||
| command root)) | |||||
| (defun python-environment-run (command &optional root virtualenv) | |||||
| "Run COMMAND installed in Python virtualenv located at ROOT | |||||
| asynchronously. | |||||
| Instead of waiting for COMMAND to finish, a deferred object [#]_ | |||||
| is returned so that you can chain operations. | |||||
| See `python-environment-make' for how ROOT and VIRTUALENV are | |||||
| interpreted and how to work with deferred object. | |||||
| Use `python-environment-run-block' if you want to wait until | |||||
| the command exit (NOT recommended in interactive command). | |||||
| .. [#] https://github.com/kiwanami/emacs-deferred" | |||||
| (if (python-environment-exists-p root) | |||||
| (python-environment--run-1 command root) | |||||
| (deferred:$ | |||||
| (python-environment-make root virtualenv) | |||||
| (deferred:nextc it | |||||
| (apply-partially | |||||
| (lambda (command root _) | |||||
| (python-environment--run-1 command root)) | |||||
| command root))))) | |||||
| (defun python-environment-run-block (command &optional root virtualenv) | |||||
| "Blocking version of `python-environment-run'. | |||||
| I recommend NOT to use this function in interactive commands. | |||||
| Emacs users have more important things to than waiting for some | |||||
| command to finish." | |||||
| (unless (python-environment-exists-p root) | |||||
| (python-environment-make-block root virtualenv)) | |||||
| (python-environment--run-block-1 command root)) | |||||
| (provide 'python-environment) | |||||
| ;; Local Variables: | |||||
| ;; coding: utf-8 | |||||
| ;; indent-tabs-mode: nil | |||||
| ;; End: | |||||
| ;;; python-environment.el ends here | |||||
| @ -0,0 +1,209 @@ | |||||
| ;;; test-python-environment.el --- Tests for python-environment.el | |||||
| ;; Copyright (C) 2013 Takafumi Arakaki | |||||
| ;; Author: Takafumi Arakaki <aka.tkf at gmail.com> | |||||
| ;; This file is NOT part of GNU Emacs. | |||||
| ;; test-python-environment.el 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. | |||||
| ;; test-python-environment.el 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 test-python-environment.el. | |||||
| ;; If not, see <http://www.gnu.org/licenses/>. | |||||
| ;;; Commentary: | |||||
| ;; | |||||
| ;;; Code: | |||||
| (require 'ert) | |||||
| (require 'python-environment) | |||||
| (defmacro pye-test-with-temp-env (&rest body) | |||||
| (declare (debug (&rest form)) | |||||
| (indent 0)) | |||||
| (let ((path (make-symbol "path"))) | |||||
| `(let* ((,path (make-temp-file "pye-test-" t)) | |||||
| (python-environment-directory ,path)) | |||||
| (unwind-protect | |||||
| (progn ,@body) | |||||
| (delete-directory ,path t))))) | |||||
| (defmacro pye-deftest (name args &rest body) | |||||
| "Customized `ert-deftest'. Bind `python-environment-directory' to a | |||||
| temporary directory while executing BODY." | |||||
| (declare (debug (&define :name test | |||||
| name sexp [&optional stringp] | |||||
| [&rest keywordp sexp] def-body)) | |||||
| (doc-string 3) | |||||
| (indent 2)) | |||||
| `(ert-deftest ,name ,args | |||||
| (pye-test-with-temp-env | |||||
| ,@body))) | |||||
| (defmacro pye-with-mixed-environment (environment &rest body) | |||||
| "Mix-in ENVIRONMENT to `process-environment' while executing `BODY'. | |||||
| ENVIRONMENT is a list whose element is arguments (i.e., list) to `setenv'." | |||||
| (declare (debug (sexp &rest form)) | |||||
| (indent 1)) | |||||
| `(let ((process-environment (mapcar #'identity process-environment))) | |||||
| (mapc (lambda (env) (apply #'setenv env)) ,environment) | |||||
| ,@body)) | |||||
| (defun pye-eval-in-subprocess (sexp &optional environment) | |||||
| "Evaluate SEXP in Emacs launched as subprocess. Additional environment | |||||
| variable can be given as ENVIRONMENT (see `pye-with-mixed-environment')." | |||||
| (let ((default-directory (expand-file-name default-directory))) | |||||
| ;; Resolution of "~/" will be affected by `environment' if it | |||||
| ;; includes "$HOME". So expand it before | |||||
| ;; `pye-with-mixed-environment' to avoid the confusion. | |||||
| (pye-with-mixed-environment environment | |||||
| (let ((print-length nil) | |||||
| (print-level nil)) | |||||
| (with-temp-buffer | |||||
| (let ((code (call-process | |||||
| (concat invocation-directory invocation-name) | |||||
| nil t nil | |||||
| "-Q" "--batch" | |||||
| "--eval" (format "(setq load-path (cons %S '%S))" | |||||
| default-directory load-path) | |||||
| "--load" (locate-library "test-python-environment") | |||||
| "--eval" (format "%S" sexp)))) | |||||
| (unless (eq code 0) | |||||
| (error "Subprocess terminated with code %S.\nOutput:\n%s" | |||||
| code (buffer-string))))))))) | |||||
| (defmacro pye-test-with-capture-message (&rest form) | |||||
| (declare (debug (&rest form)) | |||||
| (indent 0)) | |||||
| `(let ((start (make-marker)) | |||||
| (message-buffer (get-buffer "*Messages*"))) | |||||
| (with-current-buffer message-buffer | |||||
| (set-marker start (point-max))) | |||||
| (progn ,@form) | |||||
| (with-current-buffer message-buffer | |||||
| (buffer-substring start (point-max))))) | |||||
| (ert-deftest pye-test-test-with-capture-message () | |||||
| (should (equal (pye-test-with-capture-message | |||||
| (message "test-1") | |||||
| (message "test-2")) | |||||
| "test-1\ntest-2\n"))) | |||||
| (defun pye-test-proc-runner-output-message (proc-runner desired-output) | |||||
| (let* ((command '("echo" "DUMMY-ECHO-MESSAGE")) | |||||
| (python-environment--verbose t) | |||||
| (message-output | |||||
| (pye-test-with-capture-message | |||||
| (funcall proc-runner "DUMMY-MESSAGE" command)))) | |||||
| (should (equal message-output desired-output)))) | |||||
| (ert-deftest pye-test-deferred-process-output-message () | |||||
| (pye-test-proc-runner-output-message | |||||
| (lambda (msg command) | |||||
| (deferred:sync! (python-environment--deferred-process msg command))) "\ | |||||
| DUMMY-MESSAGE...Done | |||||
| DUMMY-ECHO-MESSAGE | |||||
| ")) | |||||
| (ert-deftest pye-test-blocking-process-output-message () | |||||
| (pye-test-proc-runner-output-message | |||||
| #'python-environment--blocking-process "\ | |||||
| DUMMY-MESSAGE (SYNC)... | |||||
| DUMMY-ECHO-MESSAGE | |||||
| DUMMY-MESSAGE (SYNC)...Done | |||||
| ")) | |||||
| (defun pye-test-deferred-process-should-error () | |||||
| (let (err) | |||||
| (deferred:sync! | |||||
| (deferred:error | |||||
| (python-environment--deferred-process | |||||
| "DUMMY-MESSAGE" | |||||
| '("false")) | |||||
| (lambda (got) (setq err got)))) | |||||
| (should err))) | |||||
| (ert-deftest pye-test-deferred-process-error-without-verbose () | |||||
| (let ((python-environment--verbose nil)) | |||||
| (pye-test-deferred-process-should-error))) | |||||
| (ert-deftest pye-test-deferred-process-noerror-without-verbose () | |||||
| (let ((python-environment--verbose nil)) | |||||
| (deferred:sync! | |||||
| (python-environment--deferred-process "DUMMY-MESSAGE" '("true"))))) | |||||
| (ert-deftest pye-test-blocking-process-error-without-verbose () | |||||
| (let ((python-environment--verbose nil)) | |||||
| (should-error | |||||
| (python-environment--blocking-process "DUMMY-MESSAGE" '("false"))))) | |||||
| (ert-deftest pye-test-blocking-process-noerror-without-verbose () | |||||
| (let ((python-environment--verbose nil)) | |||||
| (python-environment--blocking-process "DUMMY-MESSAGE" '("true")))) | |||||
| (ert-deftest pye-test-deferred-process-error-with-verbose () | |||||
| (let ((python-environment--verbose t)) | |||||
| (pye-test-deferred-process-should-error))) | |||||
| (ert-deftest pye-test-deferred-process-noerror-with-verbose () | |||||
| (let ((python-environment--verbose t)) | |||||
| (deferred:sync! | |||||
| (python-environment--deferred-process "DUMMY-MESSAGE" '("true"))))) | |||||
| (ert-deftest pye-test-blocking-process-error-with-verbose () | |||||
| (let ((python-environment--verbose t)) | |||||
| (should-error | |||||
| (python-environment--blocking-process "DUMMY-MESSAGE" '("false"))))) | |||||
| (ert-deftest pye-test-blocking-process-noerror-with-verbose () | |||||
| (let ((python-environment--verbose t)) | |||||
| (python-environment--blocking-process "DUMMY-MESSAGE" '("true")))) | |||||
| (pye-deftest pye-test-make-environment-with-non-existing-command () | |||||
| (should-error (python-environment-make nil '("non-existing-command")))) | |||||
| (pye-deftest pye-test-make-environment () | |||||
| (deferred:sync! (python-environment-make))) | |||||
| (pye-deftest pye-test-run () | |||||
| (deferred:sync! (python-environment-run '("python" "--version")))) | |||||
| (pye-deftest pye-test-run-block () | |||||
| (python-environment-run-block '("python" "--version"))) | |||||
| (pye-deftest pye-test-block-error () | |||||
| (should-error (python-environment-run-block '("python" "-c" "1/0")))) | |||||
| (ert-deftest pye-test-eval-in-subprocess () | |||||
| (pye-eval-in-subprocess '(+ 1 2)) | |||||
| (should-error (pye-eval-in-subprocess '(error "some error")))) | |||||
| (pye-deftest pye-test-bare-make-environment () | |||||
| (let ((tmp-home python-environment-directory)) | |||||
| (pye-eval-in-subprocess '(deferred:sync! (python-environment-make)) | |||||
| `(("HOME" ,tmp-home))) | |||||
| (should (file-directory-p (expand-file-name | |||||
| ".emacs.d/.python-environments/default" | |||||
| tmp-home))))) | |||||
| (provide 'test-python-environment) | |||||
| ;; Local Variables: | |||||
| ;; coding: utf-8 | |||||
| ;; indent-tabs-mode: nil | |||||
| ;; End: | |||||
| ;;; test-python-environment.el ends here | |||||