Changeset 8886 in project


Ignore:
Timestamp:
02/25/08 02:21:40 (12 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/3/osprocess
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • release/3/osprocess/osprocess-eggdoc.scm

    r4262 r8886  
    3131                (description (p "Subprocess Object"))
    3232                (author (url "mailto:klovett@pacbell.net" "Kon Lovett"))
    33                 (history
    34                         (version "1.2" "Added collect?, search? & exact? option keywords. Added automatic input stream draining. Made osprocess result values order like osprocess-run result")
    35                         (version "1.1" "Added fileno redirection")
    36                         (version "1.0" "Initial release"))
    3733                (requires
    3834                  "Chicken 2.6"
     
    372368    )
    373369
     370                (history
     371                  (version "1.3" "Use of misc-extn 3.1 procedures.")
     372                        (version "1.2" "Added collect?, search? & exact? option keywords. Added automatic input stream draining. Made osprocess result values order like osprocess-run result")
     373                        (version "1.1" "Added fileno redirection")
     374                        (version "1.0" "Initial release") )
     375
    374376    (section "License" (pre ,license))
    375377  )
  • release/3/osprocess/osprocess-support.scm

    r5686 r8886  
    1717
    1818(use srfi-1 srfi-18 utils extras posix)
    19 (use miscmacros misc-extn-posix misc-extn-list misc-extn-condition synch job-worker)
     19(use miscmacros misc-extn-posix misc-extn-list misc-extn-condition
     20     misc-extn-directory synch job-worker)
    2021
    2122(eval-when (compile)
     
    2324    (not usual-integrations
    2425      string->list list->string
    25       char-whitespace?)
     26      char-whitespace? )
    2627    (inline)
    2728    (fixnum)
    2829    (import
    29       ; posix unit
    30       ##sys#update-errno
    31       ##sys#shell-command
    32       ##sys#shell-command-arguments
    33       ##sys#custom-input-port
    34       ##sys#custom-output-port
    35       ##sys#process
    36       ##sys#signal-hook
    37       ##sys#posix-error
    3830      ; osprocess.scm
    3931      osprocess-input-buffer-size
     
    5345      osprocess-input-buffer-size
    5446      osprocess-output-buffer-size
    55       osprocess-reaper-period)
     47      osprocess-reaper-period
     48      osp-reaper )
    5649    (always-bound
    5750      *process-list*
    5851      *reaper-queue*
    59       *reaper-associate*)
     52      *reaper-associate* )
    6053    (export
    6154      osprocess:remove-sigchld-handler
    6255      osp$priority
    63       osp$empty-inp osp$empty-errp osp$empty-all
    64       osp$close-inp osp$close-outp osp$close-errp osp$close-all
     56      osp$empty-inp
     57      osp$empty-errp
     58      osp$empty-all
     59      osp$close-inp
     60      osp$close-outp
     61      osp$close-errp
     62      osp$close-all
    6563      osp$wait
    6664      osp$run
     
    7169      osp$stop-reaping
    7270      osp$list
    73       osp$make) ) )
     71      osp$make ) ) )
    7472
    7573;;;
     
    8179(define (close-port port)
    8280  (if (input-port? port)
    83     (close-input-port port)
    84     (close-output-port port)) )
     81      (close-input-port port)
     82      (close-output-port port)) )
    8583
    8684;;; Type Predicates
     
    119117(define-constant OPTION-PROBLEM-CHARS '(#\\ #\# #\"))
    120118
     119(define (problem-char? chr need-escape-chars)
     120  (or (char-whitespace? chr)
     121      (memq chr need-escape-chars)) )
     122
    121123(define (quote-option str #!optional (need-escape-chars OPTION-PROBLEM-CHARS))
    122124  (let ([lststr (string->list str)]
    123125        [need-quotes #f])
    124     (if (any
    125           (lambda (chr)
    126             (or (char-whitespace? chr)
    127                 (memq chr need-escape-chars)) )
    128           lststr)
    129       (let ([escstr
    130               (reverse-list->string
    131                 (fold
    132                   (lambda (chr lst)
    133                     (if (memq chr need-escape-chars)
    134                       (cons* chr #\\ lst)
    135                       (begin
    136                         (when (char-whitespace? chr) (set! need-quotes #t))
    137                         (cons chr lst) ) ) )
    138                   '()
    139                   lststr))])
    140         (if need-quotes
    141           (string-append "\"" escstr "\"")
    142           escstr) )
    143       str) ) )
     126    (if (any (cute problem-char? <> need-escape-chars) lststr)
     127        (let ([escstr
     128                (reverse-list->string
     129                  (fold
     130                    (lambda (chr lst)
     131                      (if (memq chr need-escape-chars)
     132                          (cons* chr #\\ lst)
     133                          (begin
     134                            (when (char-whitespace? chr)
     135                              (set! need-quotes #t) )
     136                            (cons chr lst) ) ) )
     137                    '()
     138                    lststr)) ] )
     139          (if need-quotes
     140              (string-append "\"" escstr "\"")
     141              escstr) )
     142        str) ) )
    144143
    145144(define (quote-args-list args #!optional exactf)
    146145  (if exactf
    147     args
    148     (map quote-option args)) )
     146      args
     147      (map quote-option args)) )
    149148
    150149(define (list-replace lst alst #!optional (test eqv?) (default #f))
     
    188187        (when termp (free-termios termp))
    189188        (if (zero? ret)
    190           (values master slave)
    191           (##sys#posix-error #:file-error loc "cannot open pseudo-tty" name)) ) ) ) )
     189            (values master slave)
     190            (##sys#posix-error #:file-error loc "cannot open pseudo-tty" name)) ) ) ) )
    192191
    193192;;; Port Handling
    194193
    195194(define (port-specification-create-pipe? port)
    196   (and port (boolean? port)) )
     195  (and port
     196       (boolean? port)) )
    197197
    198198(define (make-ospp loc ps bf inf modes stdfd)
    199   (cond
    200     ; Shared port, don't autoclose
    201     [(not ps)
    202       (%make-ospp #f #f #f bf inf modes stdfd #f)]
    203     ; User supplied fileno, don't autoclose
    204     [(fileno? ps)
    205       (%make-ospp ps #t #f bf inf modes stdfd #f)]
    206     ; User supplied pathname, can't autoclose
    207     [(pathname? ps)
    208       (%make-ospp ps #t #f bf inf modes stdfd #f)]
    209     ; User supplied port, don't autoclose
    210     [(port? ps)
    211       (%make-ospp ps #t #f bf inf modes stdfd #f)]
    212     ; System supplied so create, autoclose
    213     [(boolean? ps)
    214       (%make-ospp #t #f #t bf inf modes stdfd #f)]
    215     ;
    216     [else
    217       (error loc "invalid port specification" ps)]) )
     199  (cond [(not ps)                                       ; Shared port, don't autoclose
     200          (%make-ospp #f #f #f bf inf modes stdfd #f)]
     201        [(fileno? ps)                                   ; User supplied fileno, don't autoclose
     202          (%make-ospp ps #t #f bf inf modes stdfd #f)]
     203        [(pathname? ps)                                 ; User supplied pathname, can't autoclose
     204          (%make-ospp ps #t #f bf inf modes stdfd #f)]
     205        [(port? ps)                                     ; User supplied port, don't autoclose
     206          (%make-ospp ps #t #f bf inf modes stdfd #f)]
     207        [(boolean? ps)                                  ; System supplied so create, autoclose
     208          (%make-ospp #t #f #t bf inf modes stdfd #f)]
     209        [else
     210          (error loc "invalid port specification" ps)]) )
    218211
    219212(define (ospp-needed-pipe loc ospp)
    220213  (and (port-specification-create-pipe? (ospp-port ospp))
    221        (receive [i o] (create-pipe) (cons i o))) )
     214       (let-values ([(i o) (create-pipe)])
     215         (cons i o))) )
    222216
    223217(define (ossp-connect-parent loc pipe ospp)
    224218  (let ([port-spec (ospp-port ospp)])
    225     (cond
    226       [(not port-spec)
    227         #f]
    228       [(boolean? port-spec)
    229         (let ([usefd (car pipe)] [clsfd (cdr pipe)])
    230           (file-close clsfd)
    231           usefd)]
    232       [(fileno? port-spec)
    233         #f]
    234       [(pathname? port-spec)
    235         #f]
    236       [(port? port-spec)
    237         #f]) ) )
     219    (cond [(not port-spec)
     220            #f]
     221          [(boolean? port-spec)
     222            (let ([usefd (car pipe)] [clsfd (cdr pipe)])
     223              (file-close clsfd)
     224              usefd)]
     225          [(fileno? port-spec)
     226            #f]
     227          [(pathname? port-spec)
     228            #f]
     229          [(port? port-spec)
     230            #f]) ) )
    238231
    239232(define (ossp-connect-child loc pipe ospp)
    240233  (and-let* ([port-spec (ospp-port ospp)])
    241234    (let ([sfd (ospp-stdfd ospp)])
    242       (cond
    243         [(boolean? port-spec)
    244           (let ([usefd (car pipe)] [clsfd (cdr pipe)])
    245             (file-close clsfd)
    246             (replace-fileno usefd sfd))]
    247         [(fileno? port-spec)
    248           (replace-fileno port-spec sfd)]
    249         [(pathname? port-spec)
    250           (let ([fd (apply file-open port-spec (ospp-modes ospp))])
    251             (replace-fileno fd sfd))]
    252         [(port? port-spec)
    253           (let ([pfd (port->fileno port-spec)])
    254             (replace-fileno pfd sfd))]) ) ) )
     235      (cond [(boolean? port-spec)
     236              (let ([usefd (car pipe)] [clsfd (cdr pipe)])
     237                (file-close clsfd)
     238                (replace-fileno usefd sfd))]
     239            [(fileno? port-spec)
     240              (replace-fileno port-spec sfd)]
     241            [(pathname? port-spec)
     242              (let ([fd (apply file-open port-spec (ospp-modes ospp))])
     243                (replace-fileno fd sfd))]
     244            [(port? port-spec)
     245              (let ([pfd (port->fileno port-spec)])
     246                (replace-fileno pfd sfd))]) ) ) )
    255247
    256248(define (ossp-close ospp)
     
    258250    (and-let* ([port (ospp-port ospp)]
    259251               [(port? port)])
    260       (close-port port))
     252      (close-port port) )
    261253    (ospp-closed-set! ospp #t) ) )
    262254
     
    270262(define (osp-exec loc osp)
    271263  (when (osp-sigmask osp)
    272     (set-signal-mask! (osp-sigmask osp)))
     264    (set-signal-mask! (osp-sigmask osp)) )
    273265  (process-execute (osp-cmd osp) (osp-args osp) (osp-env osp)) )
    274266
     
    283275            [errp (osp-errp osp)])
    284276        (if (osp-fork? osp)
    285           (let ([ip (ospp-needed-pipe loc inp)]
    286                 [op (ospp-needed-pipe loc outp)]
    287                 [ep (ospp-needed-pipe loc errp)])
    288             (values
    289               ip (swapped-ends op) ep
    290               (process-fork
    291                 (lambda ()
    292                   (ossp-connect-child loc op inp)
    293                   (ossp-connect-child loc (swapped-ends ip) outp)
    294                   (ossp-connect-child loc (swapped-ends ep) errp)
    295                   (osp-exec loc osp)))))
    296           (begin
    297             (ossp-connect-child loc #f inp)
    298             (ossp-connect-child loc #f outp)
    299             (ossp-connect-child loc #f errp)
    300             (osp-exec loc osp)))) ) ) )
     277            (let ([ip (ospp-needed-pipe loc inp)]
     278                  [op (ospp-needed-pipe loc outp)]
     279                  [ep (ospp-needed-pipe loc errp)])
     280              (values
     281                ip (swapped-ends op) ep
     282                (process-fork
     283                  (lambda ()
     284                    (ossp-connect-child loc op inp)
     285                    (ossp-connect-child loc (swapped-ends ip) outp)
     286                    (ossp-connect-child loc (swapped-ends ep) errp)
     287                    (osp-exec loc osp)))))
     288            (begin
     289              (ossp-connect-child loc #f inp)
     290              (ossp-connect-child loc #f outp)
     291              (ossp-connect-child loc #f errp)
     292              (osp-exec loc osp)))) ) ) )
    301293
    302294(cond-expand
     
    307299                (lambda ()
    308300                  (ospp-closed-set! ospp #t)
    309                   #; ;FIXME - what to do here?
     301                  #; ; osp-wait closes all ports so this would recurse!
    310302                  (when (and (ospp-closed? (osp-inp osp))
    311303                             (ospp-closed? (osp-outp osp))
     
    317309                [on-close (make-on-close loc osp ospp)])
    318310            (if (ospp-input? ospp)
    319               (##sys#custom-input-port loc nam fd #t bufi on-close more?)
    320               (##sys#custom-output-port loc nam fd #t bufi on-close) ) ) ) ) ) ]
     311                (##sys#custom-input-port loc nam fd #t bufi on-close more?)
     312                (##sys#custom-output-port loc nam fd #t bufi on-close) ) ) ) ) ) ]
    321313  [windows
    322314    (define (osp-custom-port loc osp fd ospp #!optional (more? #f))
     
    374366  (if (and (osp-abexit? osp)
    375367           (not (osp-enorm? osp)))
    376     (##sys#signal-hook #:process-error loc "abnormal process exit"
    377       (osp-cmd osp) (osp-pid osp) (osp-ecode osp))
    378     #t) )
     368      (##sys#signal-hook #:process-error loc "abnormal process exit"
     369        (osp-cmd osp) (osp-pid osp) (osp-ecode osp))
     370      #t ) )
    379371
    380372(define (osp-close-inp loc osp)
     
    396388  (osp-esec-set! osp (current-seconds))
    397389  (osp-status-set! osp 'exited)
    398   #;(osp-empty-all loc osp)
     390  #; ; Unnecessary
     391  (osp-empty-all loc osp)
    399392  (osp-close-all loc osp)
    400393  (osp-check-abexit loc osp) )
     
    410403  ; Possibly not waited?
    411404  (if (boolean? (osp-ecode osp))
    412     ; then try pty
    413     (and (osp-mode-pty? osp) (osp-pty-exited? loc osp))
    414     ; else when somebody else waited - finish up
    415     (osp-exited! loc osp) ) )
     405      ; then try pty
     406      (and (osp-mode-pty? osp) (osp-pty-exited? loc osp))
     407      ; else when somebody else waited - finish up
     408      (osp-exited! loc osp) ) )
    416409
    417410(define (osp-status-exited? osp)
     
    473466            (lambda ()
    474467              (if (osp-inp-collector osp)
    475                 (osp-collect-inp loc osp)
    476                 (osp-drain-inp loc osp))))])
     468                  (osp-collect-inp loc osp)
     469                  (osp-drain-inp loc osp))))])
    477470    (when (condition? res)
    478471      (osp-last-error-set! osp res)) ) )
     
    483476            (lambda ()
    484477              (if (osp-errp-collector osp)
    485                 (osp-collect-errp loc osp)
    486                 (osp-drain-errp loc osp))))])
     478                  (osp-collect-errp loc osp)
     479                  (osp-drain-errp loc osp))))])
    487480    (when (condition? res)
    488481      (osp-last-error-set! osp res)) ) )
     
    501494  ;
    502495  (let ([pid (osp-pid osp)])
    503     (receive [epid enorm ecode] (process-wait pid nohang)
    504       (cond
    505         [(= -1 epid)    #f]
    506         [(= 0 epid)     #f]
    507         [(= epid pid)
    508           (osp-enorm-set! osp enorm)
    509           (osp-ecode-set! osp ecode)
    510           (osp-exited! loc osp)
    511           osp]
    512         [else           #f] ) ) ) )
     496    (let-values ([(epid enorm ecode) (process-wait pid nohang)])
     497      (cond [(= -1 epid)
     498              #f]
     499            [(= 0 epid)
     500              #f]
     501            [(= epid pid)
     502              (osp-enorm-set! osp enorm)
     503              (osp-ecode-set! osp ecode)
     504              (osp-exited! loc osp)
     505              osp]
     506            [else
     507              #f] ) ) ) )
    513508
    514509(define (osp-wait-any loc nohang)
    515   (receive [epid enorm ecode] (process-wait 0 nohang)
    516     (cond
    517       [(= -1 epid)    #f]
    518       [(= 0 epid)     #f]
    519       [else
    520         (and-let* ([osp (osp-lookup epid)])
    521           (osp-enorm-set! osp enorm)
    522           (osp-ecode-set! osp ecode)
    523           (osp-exited! loc osp)
    524           osp)] ) ) )
     510    (let-values ([(epid enorm ecode) (process-wait 0 nohang)])
     511    (cond [(= -1 epid)
     512            #f]
     513          [(= 0 epid)
     514            #f]
     515          [else
     516            (and-let* ([osp (osp-lookup epid)])
     517              (osp-enorm-set! osp enorm)
     518              (osp-ecode-set! osp ecode)
     519              (osp-exited! loc osp)
     520              osp)] ) ) )
    525521
    526522(cond-expand
    527523  [unix
    528524    (define (osp-run-pseudo-tty loc osp)
    529       (receive [master slave]
    530                (apply open-psuedo-tty loc (osp-pty-specification osp))
     525      (let-values ([(master slave)
     526                     (apply open-psuedo-tty loc (osp-pty-specification osp))])
    531527        (let ([pid
    532528                (process-fork
     
    553549              (and-let* ([fd (ossp-connect-parent loc pipe ospp)])
    554550                (osp-custom-port loc osp fd ospp) ) )])
    555         (receive [ipipe opipe epipe pid] (osp-spawn loc osp)
     551        (let-values ([(ipipe opipe epipe pid) (osp-spawn loc osp)])
    556552          (osp-pid-set! osp pid)
    557553          (osp-inp-port-set! osp (get-port ipipe (osp-inp osp)))
     
    570566(define (osp-run loc osp)
    571567  (if (osp-mode-pty? osp)
    572     (osp-run-pseudo-tty loc osp)
    573     (osp-run-process loc osp))
     568      (osp-run-pseudo-tty loc osp)
     569      (osp-run-process loc osp))
    574570  (osp-ssec-set! osp (current-seconds))
    575571  (osp-status-set! osp 'running) )
     
    587583      (remove!
    588584        (lambda (osp)
    589           (cond
    590             [(osp-exited? 'osp-reaper osp)
    591               #t]
    592             [(osp-status-running? osp)
    593               (osp-wait 'osp-reaper osp nohang)]
    594             [else
    595               #f]) )
     585          (cond [(osp-exited? 'osp-reaper osp)
     586                  #t]
     587                [(osp-status-running? osp)
     588                  (osp-wait 'osp-reaper osp nohang)]
     589                [else
     590                  #f]) )
    596591        (queue->list/synch *reaper-queue*)))) )
    597592
     
    601596  (unless *reaper-associate*
    602597    (set! *reaper-associate*
    603       (run-timeout-chore! 'osprocess-reaper osp-reaper
    604         (osprocess-reaper-period))) ) )
     598      (run-timeout-chore! 'osprocess-reaper
     599                          osp-reaper
     600                          (osprocess-reaper-period))) ) )
    605601
    606602(define (stop-reaper)
     
    624620          (set-signal-handler! signal/chld
    625621            (if (null? args)
    626               (lambda (reason)
    627                 ; ** Let the reaper handle it **
    628                 (when old-sigchld-handler (old-sigchld-handler reason)))
    629               old-sigchld-handler)) ) ) )
     622                (lambda (reason)
     623                  ; ** Let the reaper handle it **
     624                  (when old-sigchld-handler (old-sigchld-handler reason)))
     625                old-sigchld-handler)) ) ) )
    630626
    631627    (define (osprocess:remove-sigchld-handler)
     
    662658
    663659(define (ensure-buffer-specification loc obj ps inf)
    664   (if obj
    665     ;then object supplied so verify
    666     (begin
    667       (unless (or (io-buffer? obj)
    668                   (io-buffer-size? obj)
    669         (error loc "invalid buffer specification" obj)) )
    670       obj)
    671     ;else size is defaulted - only bother
    672     ;when port is created, it is ignored for all other
    673     ;port specs.
    674     (if (and ps (boolean? ps))
    675       (if inf
    676         (osprocess-input-buffer-size)
    677         (osprocess-output-buffer-size))
    678       obj)) )
     660  (cond [obj
     661          ; Object supplied so verify
     662          (unless (or (io-buffer? obj)
     663                      (io-buffer-size? obj)
     664            (error loc "invalid buffer specification" obj)) )
     665          obj ]
     666        ; Size is defaulted - only bother when port is created, it is ignored
     667        ; for all other port specs.
     668        [(eq? #t ps)
     669            (if inf
     670                (osprocess-input-buffer-size)
     671                (osprocess-output-buffer-size) ) ]
     672        [else
     673          obj ] ) )
    679674
    680675(define (ensure-modes loc obj ps inf)
     
    692687    (let ([md (if inf open/rdonly open/wronly)])
    693688      (if (null? obj)
    694         (set! obj (list md))
    695         (set-car! obj (fxior md (car obj))))))
     689          (set! obj (list md))
     690          (set-car! obj (fxior md (car obj))))))
    696691  obj )
    697692
     
    706701  (map
    707702    (lambda (x)
    708       (cond
    709         [(string? x)
    710           ;Check proper form?
    711           x]
    712         [(pair? x)
    713           (let ([nam (car x)]
    714                 [val (cdr x)])
    715             (conc nam #\= (if (pair? val) (car val) val)) )]
    716         [else
    717           (error loc "invalid environment list entry" x)]))
     703      (cond [(string? x)
     704              ;Check proper form?
     705              x]
     706            [(pair? x)
     707              (let ([nam (car x)]
     708                    [val (cdr x)])
     709                (conc nam #\= (if (pair? val) (car val) val)) )]
     710            [else
     711              (error loc "invalid environment list entry" x)]))
    718712    obj) )
    719713
     
    723717      (let ([nm (car obj)]
    724718            [wd (if (null? (cdr obj))
    725                   0
    726                   (cadr obj))]
     719                    0
     720                    (cadr obj))]
    727721            [ht (if (and (not-null? (cdr obj))
    728722                         (null? (cddr obj)))
    729                   0
    730                   (caddr obj))])
     723                    0
     724                    (caddr obj))])
    731725        (check-string loc nm)
    732726        (check-window-dimension loc wd)
     
    740734(define (ensure-command-line cmd args exactf)
    741735  (if (null? args)
    742     cmd
    743     (string-intersperse (quote-args-list (cons cmd args) exactf))) )
     736      cmd
     737      (string-intersperse (quote-args-list (cons cmd args) exactf))) )
    744738
    745739;;; Globals
     
    751745    (define (osp$priority loc osp #!optional prio)
    752746      (if prio
    753         (set-scheduling-priority! priority/process (osp-pid osp) prio)
    754         (scheduling-priority priority/process (osp-pid osp)) ) ) ]
     747          (set-scheduling-priority! priority/process (osp-pid osp) prio)
     748          (scheduling-priority priority/process (osp-pid osp)) ) ) ]
    755749  [windows
    756750    (define (osp$priority loc osp #!optional prio)
     
    826820  (osp-run loc osp)
    827821  ;Wait for exit?
    828   (cond
    829     [(osp-wait? osp)
    830       (osp-wait loc osp #f)]
    831     [(osp-reap? osp)
    832       (osp$start-reaping osp)]) )
     822  (cond [(osp-wait? osp)
     823          (osp-wait loc osp #f)]
     824        [(osp-reap? osp)
     825          (osp$start-reaping osp)]) )
    833826
    834827;;
     
    836829(define (osp$wait loc osp nohang)
    837830  (and-let* ([eosp (if osp
    838                       (osp-wait loc osp nohang)
    839                       (osp-wait-any loc nohang))])
     831                       (osp-wait loc osp nohang)
     832                       (osp-wait-any loc nohang))])
    840833    (when (osp-reap? eosp) (osp$stop-reaping eosp))
    841834    eosp ) )
     
    882875      (set! collf
    883876        (if (pair? collf)
    884           (map
    885             (lambda (obj)
    886               (and obj (if (boolean? obj) osp-default-read-procedure obj)) )
    887             (if (= 2 (length collf)) collf `(,(car collf) #f)))
    888           `(,osp-default-read-procedure ,osp-default-read-procedure))) )
     877            (map
     878              (lambda (obj)
     879                (and obj (if (boolean? obj) osp-default-read-procedure obj)) )
     880              (if (= 2 (length collf))
     881                  collf
     882                  `(,(car collf) #f)))
     883            `(,osp-default-read-procedure ,osp-default-read-procedure))) )
    889884    (set! collf '(#f #f)))
    890885
     
    926921    (let ([cmd-path
    927922            (if (boolean? searchf)
    928               (which-command-pathname cmd)
    929               (and-let* ([paths (find-program-pathnames cmd searchf)])
    930                 (first paths)))])
     923                (which-command-pathname cmd)
     924                (and-let* ([paths (find-program-pathnames cmd searchf)])
     925                  (first paths)))])
    931926      (if cmd-path
    932         (set! cmd cmd-path)
    933         (error loc "cannot locate the program file" cmd)) ) )
     927          (set! cmd cmd-path)
     928          (error loc "cannot locate the program file" cmd)) ) )
    934929
    935930  ; Combine all command-line arguments,
     
    939934
    940935  ; Overrides for Pseudo-tty?, Shell?
    941   (cond
    942     [ptyf
    943       ; Mode specific data
    944       (set! data (ensure-pty-specification loc ptyf))
    945       ; Warn about shell usage
    946       (when shellf
    947         (warning "shell use with pseudo-tty unsupported")
    948         (set! shellf #f) )
    949       ; Always forks (just be specific)
    950       (unless forkf
    951         (warning "process replacement with pseudo-tty unsupported")
    952         (set! forkf #t) )
    953       ; Always create ports
    954       (set! inp #t)
    955       (set! outp #t)
    956       (set! errp #t)]
    957     [shellf
    958       ; Place command for shell & any arguments to the shell
    959       ; in their proper position in the argument list
    960       (set! args
    961         (append!
    962           (list-replace
    963             (##sys#shell-command-arguments (void))
    964             `((,(void) . ,(ensure-command-line cmd args exactf)))
    965             eq?)
    966           rest))
    967       (set! cmd (##sys#shell-command))
    968       #+windows ; We already did the quoting!
    969       (set! exactf #t)] )
     936  (cond [ptyf
     937          ; Mode specific data
     938          (set! data (ensure-pty-specification loc ptyf))
     939          ; Warn about shell usage
     940          (when shellf
     941            (warning "shell use with pseudo-tty unsupported")
     942            (set! shellf #f) )
     943          ; Always forks (just be specific)
     944          (unless forkf
     945            (warning "process replacement with pseudo-tty unsupported")
     946            (set! forkf #t) )
     947          ; Always create ports
     948          (set! inp #t)
     949          (set! outp #t)
     950          (set! errp #t)]
     951        [shellf
     952          ; Place command for shell & any arguments to the shell
     953          ; in their proper position in the argument list
     954          (set! args
     955            (append!
     956              (list-replace
     957                (##sys#shell-command-arguments (void))
     958                `((,(void) . ,(ensure-command-line cmd args exactf)))
     959                eq?)
     960              rest))
     961          (set! cmd (##sys#shell-command))
     962          #+windows ; We already did the quoting!
     963          (set! exactf #t)] )
    970964
    971965  ;Return a new osprocess object
    972966  (make-osp loc
    973     (or (and ptyf 'pty) (and shellf 'shell) 'command) data
    974     reapf abexitf forkf waitf exactf
    975     sigmsk
    976     inp outp errp
    977     inbf outbf errbf
    978     inmod outmod errmod
    979     cmd args env
    980     collf) )
     967            (or (and ptyf 'pty) (and shellf 'shell) 'command) data
     968            reapf abexitf forkf waitf exactf
     969            sigmsk
     970            inp outp errp
     971            inbf outbf errbf
     972            inmod outmod errmod
     973            cmd args env
     974            collf) )
    981975
    982976;;; Module Init
  • release/3/osprocess/osprocess.html

    r4262 r8886  
    156156<h3>Author</h3><a href="mailto:klovett@pacbell.net">Kon Lovett</a></div>
    157157<div class="section">
    158 <h3>Version</h3>
    159 <ul>
    160 <li>1.2 Added collect?, search? &amp; exact? option keywords. Added automatic input stream draining. Made osprocess result values order like osprocess-run result</li>
    161 <li>1.1 Added fileno redirection</li>
    162 <li>1.0 Initial release</li></ul></div>
    163 <div class="section">
    164158<h3>Requires</h3>
    165159<ul>
     
    423417<p>Use of a shell will cause the <code>osprocess-command</code> and <code>osprocess-arguments</code> queries to reflect the execution values, not the definition values.</p>
    424418<p>Incomplete Windows support.</p></div>
     419<div class="section">
     420<h3>Version</h3>
     421<ul>
     422<li>1.3 .</li>
     423<li>1.2 Added collect?, search? &amp; exact? option keywords. Added automatic input stream draining. Made osprocess result values order like osprocess-run result</li>
     424<li>1.1 Added fileno redirection</li>
     425<li>1.0 Initial release</li></ul></div>
    425426<div class="section">
    426427<h3>License</h3>
  • release/3/osprocess/osprocess.scm

    r4262 r8886  
    99
    1010(use srfi-1 posix utils)
    11 (use miscmacros misc-extn-list)
     11(use miscmacros misc-extn-dsssl)
    1212(use osprocess-support)
    1313
     
    130130  (lambda (x)
    131131    (if (and (number? x) (positive? x))
    132       x
    133       (osprocess-reaper-period))) )
     132        x
     133        (begin
     134          (warning 'osprocess-reaper-period "invalid positive integer" x)
     135          (osprocess-reaper-period) ) ) ) )
    134136
    135137;;; Buffer
     
    138140  (lambda (x)
    139141    (if (io-buffer-size? x)
    140       x
    141       (osprocess-input-buffer-size))) )
     142        x
     143        (begin
     144          (warning 'osprocess-input-buffer-size "invalid buffer size" x)
     145          (osprocess-input-buffer-size) ) ) ) )
    142146
    143147(define-parameter osprocess-output-buffer-size DEFAULT-OUTPUT-BUFFER-SIZE
    144148  (lambda (x)
    145149    (if (io-buffer-size? x)
    146       x
    147       (osprocess-output-buffer-size))) )
     150        x
     151        (begin
     152          (warning 'osprocess-output-buffer-size "invalid buffer size" x)
     153          (osprocess-output-buffer-size) ) ) ) )
    148154
    149155;;; Argument Checking/Handling
     
    176182
    177183(define (filter-rest rest)
    178   (filter-rest-argument! rest
     184  (fixup-extended-lambda-list-rest
    179185    '(#:shell? #:pseudo-tty?
    180186      #:reap? #:fork? #:wait?
     
    185191      #:output-buffer #:input-buffer #:error-buffer
    186192      #:output-mode #:input-mode #:error-mode
    187       #:arguments #:environment)) )
     193      #:arguments #:environment)
     194     rest) )
    188195
    189196;;;
     
    191198(define (osp$connection osp)
    192199  (values (osp-pid osp)
    193           (osp-inp-port/shared osp) (osp-outp-port/shared osp) (osp-errp-port/shared osp)) )
     200          (osp-inp-port/shared osp)
     201          (osp-outp-port/shared osp)
     202          (osp-errp-port/shared osp)) )
    194203
    195204;;; Globals
     
    236245  (set! args (filter-rest args))
    237246  (when (eq? (void) shell?)
    238     (set! shell? (and (null? args) (or (not arguments) (null? arguments)))) )
     247    (set! shell? (and (null? args)
     248                      (or (not arguments) (null? arguments)))) )
    239249
    240250  ; Create & run
     
    252262    (osp$run 'osprocess osp)
    253263    (values (osp-pid osp)
    254             (osp-inp-port/shared osp) (osp-outp-port/shared osp) (osp-errp-port/shared osp)
     264            (osp-inp-port/shared osp)
     265            (osp-outp-port/shared osp)
     266            (osp-errp-port/shared osp)
    255267            osp) ) )
    256268
     
    305317  (check-osp 'osprocess-pid osp)
    306318  (if (osp-created? osp)
    307     (void)
    308     (osp-pid osp)) )
     319      (void)
     320      (osp-pid osp)) )
    309321
    310322(define (osprocess-start-seconds osp)
    311323  (check-osp 'osprocess-start-seconds osp)
    312324  (if (osp-created? osp)
    313     (void)
    314     (osp-ssec osp)) )
     325      (void)
     326      (osp-ssec osp)) )
    315327
    316328(define (osprocess-exit-seconds osp)
    317329  (check-osp 'osprocess-exit-seconds osp)
    318330  (if (osp$exited? 'osprocess-exit-seconds osp)
    319     (osp-esec osp)
    320     (void)) )
     331      (osp-esec osp)
     332      (void)) )
    321333
    322334(define (osprocess-exit-normal? osp)
    323335  (check-osp 'osprocess-exit-normal? osp)
    324336  (if (osp$exited? 'osprocess-exit-normal? osp)
    325     (osp-enorm? osp)
    326     (void)) )
     337      (osp-enorm? osp)
     338      (void)) )
    327339
    328340(define (osprocess-exit-code osp)
    329341  (check-osp 'osprocess-exit-code osp)
    330342  (if (osp$exited? 'osprocess-exit-code osp)
    331     (osp-ecode osp)
    332     (void)) )
     343      (osp-ecode osp)
     344      (void)) )
    333345
    334346(define (osprocess-exit-status osp)
    335347  (check-osp 'osprocess-exit-status osp)
    336348  (if (osp$exited? 'osprocess-exit-status osp)
    337     (and (osp-enorm? osp)
    338          (osp-ecode osp))
    339     (void)) )
     349      (and (osp-enorm? osp)
     350           (osp-ecode osp))
     351      (void)) )
    340352
    341353(define (osprocess-exit-signal osp)
    342354  (check-osp 'osprocess-exit-signal osp)
    343355  (if (osp$exited? 'osprocess-exit-signal osp)
    344     (and (not (osp-enorm? osp))
    345          (osp-ecode osp))
    346     (void)) )
     356      (and (not (osp-enorm? osp))
     357           (osp-ecode osp))
     358      (void)) )
    347359
    348360(define (osprocess-input-port osp)
    349361  (check-osp 'osprocess-input-port osp)
    350362  (if (osp-created? osp)
    351     (void)
    352     (osp-inp-port/shared osp)) )
     363      (void)
     364      (osp-inp-port/shared osp)) )
    353365
    354366(define (osprocess-output-port osp)
    355367  (check-osp 'osprocess-output-port osp)
    356368  (if (osp-created? osp)
    357     (void)
    358     (osp-outp-port/shared osp)) )
     369      (void)
     370      (osp-outp-port/shared osp)) )
    359371
    360372(define (osprocess-error-port osp)
    361373  (check-osp 'osprocess-error-port osp)
    362374  (if (osp-created? osp)
    363     (void)
    364     (osp-errp-port/shared osp)) )
     375      (void)
     376      (osp-errp-port/shared osp)) )
    365377
    366378(define (osprocess-ports osp)
    367379  (check-osp 'osprocess-ports osp)
    368380  (if (osp-created? osp)
    369     (values (void) (void) (void))
    370     (values (osp-inp-port/shared osp) (osp-outp-port/shared osp) (osp-errp-port/shared osp)) ) )
     381      (values (void) (void) (void))
     382      (values (osp-inp-port/shared osp)
     383              (osp-outp-port/shared osp)
     384              (osp-errp-port/shared osp)) ) )
    371385
    372386(define (osprocess-connection osp)
    373387  (check-osp 'osprocess-connection osp)
    374388  (if (osp-created? osp)
    375     (values (void) (void) (void) (void))
    376     (osp$connection osp) ) )
     389      (values (void) (void) (void) (void))
     390      (osp$connection osp) ) )
    377391
    378392(define (osprocess-command osp)
     
    408422  (unless (null? rest)
    409423    (let ([flag (car rest)])
    410       #;(check-boolean 'osprocess-reap flag)
    411424      (if flag
    412         (unless (osp-reap? osp) (osp$start-reaping osp))
    413         (when (osp-reap? osp) (osp$stop-reaping osp)) ) ) )
     425          (unless (osp-reap? osp) (osp$start-reaping osp))
     426          (when (osp-reap? osp) (osp$stop-reaping osp)) ) ) )
    414427  (osp-reap? osp) )
    415428
     
    419432      (check-started-osp 'osprocess-priority osp)
    420433      (if (osp$running? 'osprocess-priority osp)
    421         (begin
    422           (unless (null? rest)
    423             (let ([prio (car rest)])
    424               (check-priority 'osprocess-priority prio)
    425               (osp$priority 'osprocess-priority osp prio) ) )
    426           (osp$priority 'osprocess-priority osp) ) )
    427         (void) )
    428   ] [windows
     434          (begin
     435            (unless (null? rest)
     436              (let ([prio (car rest)])
     437                (check-priority 'osprocess-priority prio)
     438                (osp$priority 'osprocess-priority osp prio) ) )
     439            (osp$priority 'osprocess-priority osp) ) )
     440          (void) ) ]
     441  [windows
    429442    (define (osprocess-priority osp . rest)
    430       (unimplemented-warning 'osprocess-priority) )
    431   ])
     443      (unimplemented-warning 'osprocess-priority) ) ] )
    432444
    433445(define (osprocess-autoclose-input-port osp . rest)
     
    435447  (unless (null? rest)
    436448    (let ([flag (car rest)])
    437       #;(check-boolean 'osprocess-autoclose-input-port flag)
    438449      (osp-inp-auto-set! osp flag) ) )
    439450  (osp-inp-auto? osp) )
     
    443454  (unless (null? rest)
    444455    (let ([flag (car rest)])
    445       #;(check-boolean 'osprocess-autoclose-output-port flag)
    446456      (osp-outp-auto-set! osp flag) ) )
    447457  (osp-outp-auto? osp) )
     
    451461  (unless (null? rest)
    452462    (let ([flag (car rest)])
    453       #;(check-boolean 'osprocess-autoclose-error-port flag)
    454463      (osp-errp-auto-set! osp flag) ) )
    455464  (osp-errp-auto? osp) )
     
    459468  (unless (null? rest)
    460469    (let ([flag (car rest)])
    461       #;(check-boolean 'osprocess-autoclose-ports flag)
    462470      (osp-inp-auto-set! osp flag)
    463471      (osp-outp-auto-set! osp flag)
     
    526534  (check-osp 'osprocess-run osp)
    527535  (if (osp-created? osp)
    528     (begin
    529       (osp$run 'osprocess-run osp)
    530       (osp$connection osp))
    531     (warning 'osprocess-run "osprocess started" osp) ) )
     536      (begin
     537        (osp$run 'osprocess-run osp)
     538        (osp$connection osp))
     539      (warning 'osprocess-run "osprocess started" osp) ) )
    532540
    533541(define (osprocess-wait osp #!optional nohang)
     
    535543  (if (or (osp$exited? 'osprocess-wait osp)
    536544          (osp$wait 'osprocess-wait osp nohang))
    537     (values (osp-pid osp) (osp-enorm? osp) (osp-ecode osp))
    538     (values 0 (void) (void))) )
     545      (values (osp-pid osp) (osp-enorm? osp) (osp-ecode osp))
     546      (values 0 (void) (void))) )
    539547
    540548(define (osprocess-wait-any #!optional nohang)
     
    545553    (define (osprocess-kill osp #!optional (force? #f))
    546554      (check-started-osp 'osprocess-kill osp)
    547       #;(check-boolean 'osprocess-kill force?)
    548555      (unless (osp$exited? 'osprocess-kill osp)
    549         (process-signal (osp-pid osp) (if force? signal/kill signal/term)) ) )
     556        (process-signal (osp-pid osp)
     557                        (if force? signal/kill signal/term)) ) )
    550558
    551559    (define (osprocess-stop osp)
     
    565573      (check-signal 'osprocess-signal sig)
    566574      (unless (osp$exited? 'osprocess-signal osp)
    567         (process-signal (osp-pid osp) sig) ) )
    568   ] [windows
     575        (process-signal (osp-pid osp) sig) ) ) ]
     576  [windows
    569577    (define (osprocess-kill osp #!optional (force? #t))
    570578      (unimplemented-warning 'osprocess-kill) )
     
    577585
    578586    (define (osprocess-signal osp sig)
    579       (unimplemented-warning 'osprocess-signal) )
    580   ])
     587      (unimplemented-warning 'osprocess-signal) ) ] )
  • release/3/osprocess/osprocess.setup

    r5686 r8886  
    77  'synch                  "1.3"
    88  'job-worker             "0.4"
    9   'misc-extn              "3.0"
     9  'misc-extn              "3.1"
    1010  'miscmacros             "2.4")
    1111
    12 (install-dynld osprocess-support "1.2.1" -O3 -d0)
    13 (install-dynld+docu osprocess "1.2.1")
     12(install-dynld osprocess-support *version* -O3 -d0)
     13(install-dynld+docu osprocess *version*)
    1414
    1515(install-test "osprocess-test.scm")
  • release/3/osprocess/tests/osprocess-test.scm

    r7890 r8886  
    1414(use srfi-13 srfi-18 posix utils miscmacros)
    1515
    16 ;; Configure
     16;;; Configure
    1717
    1818#| TestBase
     
    2424    (extend (char-name 'eot (integer->char 4))) )
    2525|#
    26 
    27 ;; Define Expectations
    28 
    29 (define-expect-unary null?)
    30 (define-expect-unary string?)
    31 (define-expect-unary string-null?)
    32 
    33 (define (not-string-null? str)
    34   (not (string-null? str)) )
    35 (define-expect-unary not-string-null?)
    3626
    3727;;;
     
    4737#+windows
    4838(define-constant *CHICKEN-SETUP-PATHNAME* "C:\\Program Files\\Chicken\\bin\\chicken-setup.exe")
     39
     40(define (not-string-null? str)
     41  (not (string-null? str)) )
     42
     43;;; Define Expectations
     44
     45(define-expect-unary null?)
     46(define-expect-unary string?)
     47(define-expect-unary string-null?)
     48(define-expect-unary not-string-null?)
    4949
    5050;;;
     
    147147
    148148;Tests implicit shell use
    149 (define-test implicit-shell-test "Shell uname implicit w/ reaping"
     149(define-test implicit-shell-test "Shell uname implicit w/ reaping & shell"
    150150  (initial
    151151    (define osp #f)
     
    154154  (expect-set! osp (receive [pid in out err osp]
    155155                            (osprocess "uname -a")
    156                       osp))
     156                     osp))
    157157  (expect-true (osprocess-shell? osp))
    158158  (expect-set! outstr (read-all (osprocess-input-port osp)))
     
    162162
    163163;Tests shell use w/ cmd search
    164 (define-test explicit-shell-test-w-search "Shell uname w/ reaping & searching"
     164(define-test explicit-shell-test-w-search "Shell uname w/ reaping & search"
    165165  (initial
    166166    (define osp #f)
     
    168168
    169169  (expect-set! osp (receive [pid in out err osp]
    170                             (osprocess "uname" #:shell? #t #:arguments '(-a))
    171                       osp))
    172   (expect-true (osprocess-shell? osp))
     170                            (osprocess "uname" #:search? #t #:arguments '(-a))
     171                     osp))
     172  (expect-false (osprocess-shell? osp))
    173173  (expect-set! outstr (read-all (osprocess-input-port osp)))
    174174  (expect-success (osprocess-empty-ports osp))
     
    197197
    198198  (expect-set! osp (receive [pid in out err osp]
    199                             (osprocess "uname" "-a" #:wait? #t #:collect? #t) osp))
     199                            (osprocess "uname" "-a" #:wait? #t #:collect? #t)
     200                     osp))
    200201  (expect-not-string-null (osprocess-input-port-collection osp))
    201202  (expect-string-null (osprocess-error-port-collection osp))
     
    204205;
    205206(define-test process-list-test "List of active processes"
    206   (side-effect (thread-sleep! 5.0)) ; Give the reaper some time
     207  (side-effect (thread-sleep! 15.0)) ; Give the reaper some time
    207208  (expect-null "No more processes" (osprocess-list))
    208209)
     
    215216(test::for-each (cut test::styler-set! <> test::output-style-human))
    216217(run-test "OSProcess Tests")
     218
     219(test::forget!)
Note: See TracChangeset for help on using the changeset viewer.