17.  Examples  

This program implements a simple program interface to the UNIX dc desktop calculator command. The procedure calc-open starts the dc command and establishes two pipes to/from the child process; the procedure calc sends its argument (a dc expression as a string) as input to dc; calc-close closes the pipes and waits for the subprocess to terminate.

(require 'unix)
(define calc-from-dc)   ; input port: standard output of dc command
(define calc-to-dc)     ; output port: standard input of dc command
(define calc-dc-pid)    ; process-ID of child process running dc
(define calc-dc-command "/bin/dc")
(define (calc-open)
  (let* ((from (unix-pipe))
         (to (unix-pipe))
         (redirect-fd (lambda (a b)
                        (unix-dup a b) (unix-close a))))
    (set! calc-dc-pid (unix-fork))
    (if (zero? calc-dc-pid)
          (unix-close (car from))
          (unix-close (cdr to))
          (redirect-fd (car to) 0)
          (redirect-fd (cdr from) 1)
          (unix-exec calc-dc-command '("dc")))
          (unix-close (cdr from))
          (unix-close (car to))
          (set! calc-to-dc   (unix-filedescriptor->port (cdr to)   "w"))
          (set! calc-from-dc (unix-filedescriptor->port (car from) "r"))))))
(define (calc expr)
  (format calc-to-dc "~a~%" expr)
  (flush-output-port calc-to-dc)
  (read-string calc-from-dc))
(define (calc-close)
  (close-output-port calc-to-dc)
  (close-input-port calc-from-dc)
  (unix-wait-process calc-dc-pid))

;;; Test -- print sqrt(2):
(display (calc "10k 2v p")) (newline)

The following procedure copies a file; the arguments are the source and target file names. The second argument may name a directory, in this case the file is copied into the directory. The target file must not yet exist. copy-file preserves the access mode of the source file.

(require 'unix)
(define copy-buffer-size 8192)
(define (copy-file from to)
  (let ((from-stat (unix-stat from))
        (to-stat (unix-errval (unix-stat to))))
    (if (eq? (stat-type from-stat) 'directory)       ; complain if "from"
        (error 'copy-file "~s is a directory" from)) ;   is a directory
    (if (and (not (unix-error? to-stat))             ; destination exists
             (eq? (stat-type to-stat) 'directory))   ;   and is a directory?
        (set! to (format #f "~a/~a" to from)))
    (let* ((to-fd (unix-open to '(write create exclusive)
                             (stat-mode from-stat)))
           (from-fd (unix-open from '(read)))
           (buf (make-string copy-buffer-size)))

      (let loop ((num-chars (unix-read-string-fill! from-fd buf)))
           (if (positive? num-chars)
                 (unix-write to-fd buf num-chars)
                 (loop (unix-read-string-fill! from-fd buf)))))
      (unix-close from-fd)
      (unix-close to-fd))))

lock-vi starts the vi editor with the specified file name. It provides exclusive access to the file during the editing session by applying a write lock to the file and removing it when the editor finishes. A message is displayed periodically if the lock is held by somebody else.

(require 'unix)
(define (lock-vi file)
  (let* ((fd (unix-open file '(read write)))
         (lock ((record-constructor lock-record) #t 'set 0 0)))
    (let loop ()
         (if (not (unix-set-lock fd lock #f))
               (format #t "Someone else is editing ~s...~%" file)
               (unix-sleep 10)
    (unix-system (format #f "vi ~a" file))
    (unix-remove-lock fd lock)))

pipe-size attempts to determine the capacity of a pipe. It creates a pipe, places the write end of the pipe into non-blocking I/O mode and writes into the pipe until it is full, counting the characters successfully written.

(require 'unix)
(define (pipe-size)
  (let* ((pipe (unix-pipe))
         (flags (unix-filedescriptor-flags (cdr pipe)))
         (len 32)                    ; assumes capacity is multiple of len
         (noise (make-string len)))
    ;; enable non-blocking I/O for write side of pipe:
    (unix-filedescriptor-flags (cdr pipe) (cons 'ndelay flags))
      (let loop ((size 0))
           (if (unix-error? (unix-errval (unix-write (cdr pipe) noise)))
               (if (memq (unix-errno) '(eagain ewouldblock))
                   (error 'pipe-size "~E"))
               (loop (+ size 32))))
      (unix-close (car pipe))
      (unix-close (cdr pipe)))))

Markup created by unroff 1.0,    September 24, 1996,    net@informatik.uni-bremen.de