Download
(require 'sunrise-commander)
(defcustom sr-loop-debug nil
"Activate debug mode in the Sunrise Loop extension.
When set, the background elisp interpreter is launched in such a
way that all background input and output are sent to a buffer
named *SUNRISE LOOP* and automatic lifecycle management is
disabled (i.e. you have to kill the interpreter manually using
sr-loop-stop to get rid of it)."
:group 'sunrise
:type 'boolean)
(defcustom sr-loop-timeout 30
"Number of seconds to wait while idle before shutting down the interpreter.
After executing one or more operations in the background, the
Sunrise Loop Elisp interpreter will be killed automatically after
this amount of time."
:group 'sunrise)
(defcustom sr-loop-use-popups t
"When non-nil, display pop‐up notification when execution queue is emptied."
:group 'sunrise
:type 'boolean)
(defvar sr-loop-process nil)
(defvar sr-loop-timer nil)
(defvar sr-loop-scope nil)
(defvar sr-loop-queue nil)
(defun sr-loop-start ()
"Launch and initiate a new background Elisp interpreter.
The new interpreter runs in batch mode and inherits all functions
from the Sunrise Commander (sunrise-commander.el) and from this
file."
(let ((process-connection-type nil)
(sr-main (symbol-file 'sr-mode))
(sr-loop (symbol-file 'sr-loop-cmd-loop))
(emacs (concat invocation-directory invocation-name)))
(setq sr-loop-process (start-process
"Sunrise-Loop"
(if sr-loop-debug "*SUNRISE-LOOP*" nil)
emacs
"-batch" "-q" "-no-site-file"
"-l" sr-main "-l" sr-loop
"-eval" "(sr-loop-cmd-loop)"))
(sr-loop-enqueue `(setq load-path (quote ,load-path)))
(sr-loop-enqueue '(require 'sunrise-commander))
(if sr-loop-debug
(sr-loop-enqueue '(setq sr-loop-debug t))
(set-process-filter sr-loop-process 'sr-loop-filter))
(setq sr-loop-queue nil)))
(defun sr-loop-disable-timer ()
"Disable the automatic shutdown timer.
This is done every time we send a new task to the background
interpreter, lest it gets nuked before completing its queue."
(if sr-loop-timer
(progn
(cancel-timer sr-loop-timer)
(setq sr-loop-timer nil))))
(defun sr-loop-enable-timer ()
"Enable the automatic shutdown timer.
This is done every time we receive confirmation from the
background interpreter that all the tasks delegated to it have
been completed. Once this function is executed, if no new tasks
are enqueued before `sr-loop-timeout' seconds, the interpreter is
killed."
(sr-loop-disable-timer)
(setq sr-loop-timer (run-with-timer sr-loop-timeout nil 'sr-loop-stop)))
(defun sr-loop-stop (&optional interrupt)
"Shut down the background Elisp interpreter and clean up after it."
(interactive "p")
(sr-loop-disable-timer)
(if sr-loop-queue
(if interrupt
(progn
(sr-loop-notify "Aborted. Some operations may remain unfinished.")
(setq sr-loop-queue nil))
(sr-loop-enable-timer)))
(unless sr-loop-queue
(delete-process sr-loop-process)
(setq sr-loop-process nil)))
(defun sr-loop-notify (msg)
"Notify the user about an event."
(if (and window-system sr-loop-use-popups)
(x-popup-dialog t (list msg '("OK")) t)
(message (concat "[[" msg "]]"))))
(defun sr-loop-filter (_process output)
"Process filter for the background interpreter."
(mapc (lambda (line)
(cond ((string-match "^\\[\\[\\*\\([^\]\*]+\\)\\*\\]\\]$" line)
(sr-loop-notify (match-string 1 line)))
((and (or (string-match "^\\[\\[" line)
(string-match "^Sunrise Loop: " line))
(< 0 (length line)))
(message "%s" line))
((eq ?^ (string-to-char line))
(let ((command (substring line 1)))
(when (string= command (car sr-loop-queue))
(pop sr-loop-queue)
(sr-loop-enable-timer)
(unless sr-loop-queue
(sr-loop-notify "Background job finished!")))))
(t nil)))
(split-string output "\n")))
(defun sr-loop-enqueue (form)
"Delegate evaluation of FORM to the background interpreter.
If no such interpreter is currently running, launches a new one."
(sr-loop-disable-timer)
(unless sr-loop-process
(sr-loop-start))
(let ((command (prin1-to-string form)))
(setq sr-loop-queue (append sr-loop-queue (list (md5 command))))
(process-send-string sr-loop-process command)
(process-send-string sr-loop-process "\n")))
(defun sr-loop-cmd-loop ()
"Main execution loop for the background Elisp interpreter."
(sr-ad-disable "^sr-loop-")
(defun read-char nil ?y)
(let ((command) (signature))
(while t
(setq command (read))
(setq signature (md5 (prin1-to-string command)))
(condition-case description
(progn
(if sr-loop-debug
(message "%s" (concat "[[Executing in background: "
(prin1-to-string command) "]]")))
(eval command)
(message "[[Command successfully invoked in background]]"))
(error (message "%s" (concat "[[*ERROR IN BACKGROUND JOB: "
(prin1-to-string description) "*]]"))))
(message "^%s" signature))))
(defun sr-loop-applicable-p ()
"Return non-nil if an operation is suitable for the background interpreter."
(and (null (string-match "^/ftp:" dired-directory))
(null (string-match "^/ftp:" sr-other-directory))))
(defun sr-loop-do-copy (&optional arg)
"Drop-in prefixable replacement for the `sr-do-copy' command.
When invoked with a prefix argument, sets a flag that is used
later by advice to decide whether to delegate further copy
operations to the background interpreter."
(interactive "P")
(if (and arg (sr-loop-applicable-p))
(let ((sr-loop-scope t))
(sr-do-copy))
(sr-do-copy)))
(defun sr-loop-do-clone (&optional arg)
"Drop-in prefixable replacement for the `sr-do-clone' command.
When invoked with a prefix argument, sets a flag that is used
later by advice to decide whether to delegate further copy
operations to the background interpreter."
(interactive "P")
(if (and arg (sr-loop-applicable-p))
(let ((sr-loop-scope t))
(call-interactively 'sr-do-clone))
(call-interactively 'sr-do-clone)))
(defun sr-loop-do-rename (&optional arg)
"Drop-in prefixable replacement for the `sr-do-rename' command.
When invoked with a prefix argument, sets a flag that is used
later by advice to decide whether to delegate further rename
operations to the background interpreter."
(interactive "P")
(if (and arg (sr-loop-applicable-p))
(let ((sr-loop-scope t))
(sr-do-rename))
(sr-do-rename)))
(defadvice sr-progress-prompt (around sr-loop-advice-sr-progress-prompt
activate)
"Display \"Sunrise Loop\" instead of \"Sunrise\" in the prompt."
(setq ad-return-value
(concat (if sr-loop-scope "Sunrise Loop: " "Sunrise: ")
(ad-get-arg 0)
"...")))
(defadvice y-or-n-p (before sr-loop-advice-y-or-n-p activate)
"Modify all confirmation request messages inside a loop scope."
(when sr-loop-scope
(setq (ad-get-arg 0)
(replace-regexp-in-string
"\?" " in the background? (overwrites ALWAYS!)" (ad-get-arg 0)))))
(defadvice dired-mark-read-file-name
(before sr-loop-advice-dired-mark-read-file-name
(prompt dir op-symbol arg files &optional default)
activate)
"Modify all queries from Dired inside a loop scope."
(if sr-loop-scope
(setq prompt (replace-regexp-in-string
"^\\([^ ]+\\) ?\\(.*\\)"
"\\1 (in background - overwrites ALWAYS!) \\2" prompt))))
(defadvice dired-create-files
(around sr-loop-advice-dired-create-files
(file-creator operation fn-list name-constructor
&optional marker-char)
activate)
"Delegate to the background interpreter all copy and rename operations
triggered by `dired-do-copy' inside a loop scope."
(if sr-loop-scope
(with-no-warnings
(sr-loop-enqueue
`(let ((target ,target))
(dired-create-files (function ,file-creator)
,operation
(quote ,fn-list)
,name-constructor nil))))
ad-do-it))
(defadvice sr-clone-files
(around sr-loop-advice-sr-clone-files
(file-path-list target-dir clone-op progress &optional do-overwrite)
activate)
"Delegate to the background interpreter all copy operations
triggered by `sr-do-copy' inside a loop scope."
(if sr-loop-scope
(sr-loop-enqueue
`(sr-clone-files
(quote ,file-path-list) ,target-dir #',clone-op ',progress 'ALWAYS))
ad-do-it))
(defadvice sr-move-files
(around sr-loop-advice-sr-move-files
(file-path-list target-dir progress &optional do-overwrite)
activate)
"Delegate to the background interpreter all rename operations
triggered by `sr-do-rename' inside a loop scope."
(if sr-loop-scope
(sr-loop-enqueue
`(sr-move-files (quote ,file-path-list) ,target-dir ',progress 'ALWAYS))
ad-do-it))
(define-key sr-mode-map "C" 'sr-loop-do-copy)
(define-key sr-mode-map "K" 'sr-loop-do-clone)
(define-key sr-mode-map "R" 'sr-loop-do-rename)
(defun sunrise-x-loop-unload-function ()
(sr-ad-disable "^sr-loop-")
(define-key sr-mode-map "C" 'sr-do-copy)
(define-key sr-mode-map "K" 'sr-do-clone)
(define-key sr-mode-map "R" 'sr-do-rename))
(provide 'sunrise-x-loop)