;;; SCSH Processes -- Part of Guile Facade (formerly part of SCSH)
;;; See COPYING for full Copyrights
;;; Guile specific changes Copyright (c) 2010 Clinton Ebadi

(define-module (scsh process)
  #:use-module (scsh process-object)
  #:use-module (scsh utilities)
  #:use-module (srfi srfi-39)
  #:use-module (ice-9 optargs)
  #:export (exec
	    exec-path
	    exec/env
	    exec-path/env

	    exec-path-search

	    call-terminally
	    halts? ; likewise... nah, probably not

	    fork
	    %fork

	    fork/pipe
	    %fork/pipe
	    fork/pipe+
	    %fork/pipe+
	    pipe*

	    process-sleep
	    process-sleep-until))

;;; Process
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (%exec prog arg-list env)
  (let ((argv (map stringify arg-list))
	(prog (stringify prog))
	(env (if (eq? env #t) (environ) env)))
    (apply execle prog env argv)))

;;; EXEC support
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Assumes a low-level %exec procedure:
;;; (%exec prog arglist env)
;;;   ENV is either #t, meaning the current environment, or a string->string
;;;       alist.
;;;   %EXEC stringifies PROG and the elements of ARGLIST.

(define (exec-path-search prog path-list)
  (cond
   ((not (file-name-absolute? prog))
    (let loop ((path-list path-list))
      (if (not (null? path-list))
	  (let* ((dir (car path-list))
		 (fname (string-append dir "/" prog)))
	    (if (file-executable? fname)
		fname
		(loop (cdr path-list)))))))
   ((file-executable? prog)
    prog)
   (else #f)))

(define (exec/env prog env . arglist)
  (flush-all-ports)
  (%exec prog (cons prog arglist) env))

;;; Some globals:
(define exec-path-list)

(define (init-exec-path-list quietly?)
  (set! exec-path-list
	(make-parameter
	 (cond ((getenv "PATH") => split-colon-list)
	       (else (if (not quietly?)
			 (warn "Starting up with no path ($PATH)."))
		     '())))))

;;; We keep SPLIT-COLON-LIST defined internally so the top-level
;;; startup code (INIT-SCSH) can use it to split up $PATH without
;;; requiring the field-splitter or regexp code.

(define (split-colon-list clist)
  (let ((len (string-length clist)))
    (if (= 0 len) '()			; Special case "" -> ().

	;; Main loop.
	(let split ((i 0))
	  (cond ((string-index clist #\: i) =>
		 (lambda (colon)
		   (cons (substring clist i colon)
			 (split (+ colon 1)))))
		(else (list (substring clist i len))))))))

;;; This procedure is bummed by tying in directly to %%exec/errno
;;; and pulling some of %exec's code out of the inner loop so that
;;; the inner loop will be fast. Folks don't like waiting...

(define (exec-path/env prog env . arglist)
  (flush-all-ports)
  (let ((prog (stringify prog)))
    (if (string-index prog #\/)
		 
	;; Contains a slash -- no path search.
	(%exec prog (cons prog arglist) env)
		 
	;; Try each directory in PATH-LIST.
	(let ((argv (cons prog (map stringify arglist))))
	  (for-each (lambda (dir)
		      (let ((binary (string-append dir "/" prog)))
			(apply execlv binary env argv)))
		    (exec-path-list))))))
   
(define (exec-path prog . arglist)
  (apply exec-path/env prog #t arglist))

(define (exec prog . arglist)
  (apply exec/env prog #t arglist))


;;; Assumes niladic primitive PRIMITIVE-FORK.

(define (fork . stuff)
  (apply fork-1 #t stuff))

(define (%fork . stuff)
  (apply fork-1 #f stuff))

(define* (fork-1 clear-interactive? #:optional thunk)
  (really-fork clear-interactive?
	       thunk))

(define (really-fork clear-interactive? maybe-thunk)
  (let ((proc #f))
    (if clear-interactive?
	(flush-all-ports))

    ;; fixme: A warning from the scsh source:
    ;;
    ;; There was an atomicity problem/race condition -- if a child
    ;; process died after it was forked, but before the scsh fork
    ;; procedure could register the child's procobj in the
    ;; pid/procobj table, then when the SIGCHLD signal-handler reaped
    ;; the process, there would be no procobj for it.  We now lock
    ;; out interrupts across the PRIMITIVE-FORK and NEW-CHILD-PROC
    ;; operations.
    ;;
    ;; ... I am unsure if guile can deal with this or if it is even a
    ;; problem --clinton
    
    (let ((pid (primitive-fork)))
      (if (zero? pid)				
	  ;; Child
	  (if maybe-thunk
	      (call-and-exit maybe-thunk))
	  ;; Parent
	  (new-child-proc pid)))))


(define (call-terminally thunk)
  (thunk)
  (exit 0))


(define (call-and-exit thunk)
  (call-terminally
   (lambda ()
     (dynamic-wind
      values
      thunk
      (lambda () (exit 0))))))

;;; Like FORK, but the parent and child communicate via a pipe connecting
;;; the parent's stdin to the child's stdout. This function side-effects
;;; the parent by changing his stdin.

(define (fork/pipe . stuff)
  (really-fork/pipe fork stuff))

(define (%fork/pipe . stuff)
  (really-fork/pipe %fork stuff))
  
;;; Common code for FORK/PIPE and %FORK/PIPE.
(define (really-fork/pipe forker rest)
  (let-optional rest ((maybe-thunk #f)
		      (no-new-command-level? #f))
    (receive (r w) (pipe)
      (let ((proc (forker #f no-new-command-level?)))
	(cond (proc		; Parent
	       (close w)
	       (move->fdes r 0)
               (set-current-input-port! r))
	      (else		; Child
	       (close r)
               (move->fdes w 1)
               (if maybe-thunk
                   (parameterize ((current-output-port w))
		     w
                    (call-and-exit maybe-thunk))
                   (set-current-output-port! w))))
	proc))))


;;; FORK/PIPE with a connection list.
;;; (FORK/PIPE . m-t) = (apply fork/pipe+ '((1 0)) m-t)

(define (%fork/pipe+ conns . stuff)
  (really-fork/pipe+ %fork conns stuff))

(define (fork/pipe+ conns . stuff)
  (really-fork/pipe+ fork conns stuff))

;;; Common code.
(define (really-fork/pipe+ forker conns rest)
  (let-optional rest ((maybe-thunk #f)
		      (no-new-command-level? #f))
    (let* ((pipes (map (lambda (conn) (call-with-values pipe cons))
		       conns))
	   (rev-conns (map reverse conns))
	   (froms (map (lambda (conn) (reverse (cdr conn)))
		       rev-conns))
	   (tos (map car rev-conns)))

      (let ((proc (forker #f no-new-command-level?)))
	(cond (proc			; Parent
	       (for-each (lambda (to r/w)
			   (let ((w (cdr r/w))
				 (r (car r/w)))
			     (close w)
			     (move->fdes r to)))
			 tos pipes))

	      (else			; Child
	       (for-each (lambda (from r/w)
			   (let ((r (car r/w))
				 (w (cdr r/w)))
			     (close r)
			     (for-each (lambda (fd) (dup w fd)) from)
			     (close w))) ; Unrevealed ports win.
			 froms pipes)
	       (if maybe-thunk
		   (call-and-exit maybe-thunk))))
	proc))))

(define (tail-pipe a b)
  (fork/pipe a)
  (call-and-exit b))

(define (tail-pipe+ conns a b)
  (fork/pipe+ conns a)
  (call-and-exit b))

;;; Lay a pipeline, one process for each thunk. Last thunk is called
;;; in this process. PIPE* never returns.

(define (pipe* . thunks)
  (letrec ((lay-pipe (lambda (thunks)
		       (let ((thunk (car thunks))
			     (thunks (cdr thunks)))
			 (if (pair? thunks)
			     (begin (fork/pipe thunk)
				    (lay-pipe thunks))
			     (call-and-exit thunk)))))) ; Last one.
    (if (pair? thunks)
	(lay-pipe thunks)
	(error "No thunks passed to PIPE*"))))

;;; The classic T 2.0 primitive.
;;; This definition works for procedures running on top of Unix systems.
(define (halts? proc) #t)

;;; Miscellaneous
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (process-sleep secs) (process-sleep-until (+ secs (current-time))))

(define (process-sleep-until when)
  (let* ((when (floor when))	; Painful to do real->int in Scheme.
	 (when (if (exact? when) when (inexact->exact when))))
    (sleep (- (inexact->exact (floor when)) (current-time)))))