/[meta-cvs]/meta-cvs/F-6BD7679FED76D6E5A7D36DC36C205FC1.lisp
ViewVC logotype

Diff of /meta-cvs/F-6BD7679FED76D6E5A7D36DC36C205FC1.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9.2.10 by kaz, Sun Feb 1 05:10:15 2004 UTC revision 1.26 by kaz, Sat Mar 8 07:22:00 2008 UTC
# Line 2  Line 2 
2  ;;; which is distributed under the GNU license.  ;;; which is distributed under the GNU license.
3  ;;; Copyright 2002 Kaz Kylheku  ;;; Copyright 2002 Kaz Kylheku
4    
5  (require "chatter")  (in-package :meta-cvs)
 (provide "clisp-unix")  
   
 ;;; Null pointer handling  
   
 #.(when (< (first (system::version)) 20020129)  
     (push :clisp-old *features*)  
     (values))  
   
 #+clisp-old  
   (defmacro pointer-null (p) `(unix-funcs:null-pointer-p ,p))  
   
 #-clisp-old  
   (defmacro pointer-null (p) `(ffi:foreign-address-null ,p))  
   
 (defmacro null-to-nil (p)  
   (let ((pointer (gensym)))  
     `(let ((,pointer ,p)) (if (pointer-null ,pointer) nil ,pointer))))  
   
 (defmacro when-not-null (p &body forms)  
   `(if (not (pointer-null ,p)) ,@forms))  
6    
7  ;;; Base condition  ;;; Base condition
8    
# Line 64  Line 44 
44    
45    
46  (defun opendir (dir)  (defun opendir (dir)
47    (cond    (or (unix-funcs:opendir dir)
48      ((null-to-nil (unix-funcs:opendir dir)))        (error (make-condition 'open-dir-error :dir dir))))
     (t (error (make-condition 'open-dir-error :dir dir)))))  
49    
50  (declaim (inline closedir))  (declaim (inline closedir))
51  (defun closedir (dir-stream)  (defun closedir (dir-stream)
52    (when-not-null dir-stream (unix-funcs:closedir dir-stream)))    (when dir-stream (unix-funcs:closedir dir-stream)))
53    
54    
55  (defun readdir (dir-stream)  (defun readdir (dir-stream)
# Line 223  Line 202 
202    
203  (defmethod executable-p ((file file-info))  (defmethod executable-p ((file file-info))
204    (with-slots ((mode mode-flags)) file    (with-slots ((mode mode-flags)) file
205      (and (not (zerop (logand mode unix-funcs:s-ixusr)))      (not (and (zerop (logand mode unix-funcs:s-ixusr))
206           (not (zerop (logand mode unix-funcs:s-ixgrp))))))                (zerop (logand mode unix-funcs:s-ixgrp))
207                  (zerop (logand mode unix-funcs:s-ixoth))))))
208    
209  (defmethod executable-p ((filename string))  (defmethod executable-p ((filename string))
210    (executable-p (stat filename)))    (executable-p (stat filename)))
# Line 341  Line 321 
321      (values)      (values)
322      (error (make-condition 'rm-error :path file))))      (error (make-condition 'rm-error :path file))))
323    
324    ;;; pipes
325    
326    ;;; A process pipe consists of a CLISP stream (input or output), and a child
327    ;;; process ID.  Additionally, the direction records the stream's direction,
328    ;;; the fd records its file descriptor.
329    
330    (defstruct process-pipe
331      (stream)
332      (child-pid)
333      (direction)
334      (fd))
335    
336    (defun create-process-pipe (func direction)
337      (multiple-value-bind (result fd) (unix-funcs:pipe)
338        (when (< 0 result)
339          (error "failed to create pipe: ~A"
340                 (unix-funcs:strerror unix-funcs:errno)))
341        (let ((child (unix-funcs:fork)))
342          (cond
343            ((< child 0)
344             (map nil #'unix-funcs:close fd)
345             (error "fork failed: ~A."
346                    (unix-funcs:strerror unix-funcs:errno)))
347            ((zerop child)
348              (case direction
349                (:output
350                  (ext:duplicate-handle (aref fd 0) 0)
351                  (setf *standard-input* (ext:make-stream
352                                           (aref fd 0)
353                                           :direction :input
354                                           :element-type 'character)))
355                (:input
356                  (ext:duplicate-handle (aref fd 1) 1)
357                  (setf *standard-output* (ext:make-stream
358                                            (aref fd 1)
359                                            :direction :output
360                                            :element-type 'character))))
361              (map nil #'unix-funcs:close fd)
362              (funcall func)
363              (force-output *standard-output*)
364              (unix-funcs:_exit 1))
365            (t
366              (unwind-protect
367                (case direction
368                  (:output
369                    (make-process-pipe
370                      :stream (ext:make-stream (aref fd 1)
371                                               :direction direction
372                                               :element-type 'character)
373                      :direction direction
374                      :fd (ext:duplicate-handle (aref fd 1))
375                      :child-pid child))
376                  (:input
377                    (make-process-pipe
378                      :stream (ext:make-stream (aref fd 0)
379                                               :direction direction
380                                               :element-type 'character)
381                      :direction direction
382                      :fd (ext:duplicate-handle (aref fd 0))
383                      :child-pid child)))
384                (map nil #'unix-funcs:close fd)))))))
385    
386    (defun close-process-pipe (pipe)
387      (unix-funcs:default-sigchld)
388      (close (slot-value pipe 'stream))
389      (unix-funcs:close (slot-value pipe 'fd))
390      (setf (slot-value pipe 'stream) nil)
391      (setf (slot-value pipe 'fd) nil)
392      (loop for result = (unix-funcs:waitpid (slot-value pipe 'child-pid) 0)
393            do (when (and (< result 0) (/= unix-funcs:errno unix-funcs:eintr))
394                 (error "waitpid failed: ~A"
395                        (unix-funcs:strerror unix-funcs:errno)))
396            until (>= result 0))
397      (setf (slot-value pipe 'child-pid) nil)
398      (values))
399    
400  ;;; Coprocesses  ;;; Coprocesses
401    
402  (defun shell-interpreter (command)  (defun shell-interpreter (command)
403    (case (shell command)    (case (ext:shell command)
404      ((0) T)      ((0) T)
405      (otherwise nil)))      (otherwise nil)))
406    
407    (defvar *default-execute-filter* nil)
408    
409  (defun execute-program (arglist)  (defun execute-program (arglist)
410    (chatter-debug "invoking ~s in directory ~s~%" arglist (getcwd))    (chatter-debug "invoking ~s in directory ~s~%" arglist (getcwd))
411    (case (unix-funcs:run-program (first arglist) :arguments (rest arglist))    (let ((result nil))
412      ((0) (chatter-debug "successful termination~%") T)      (let ((pipe nil)
413      (otherwise (chatter-debug "unsuccessful or abnormal termination~%") nil)))            (saved-handle)
414              (saved-handle-which)
415              (*standard-output* *standard-output*)
416              (*standard-input* *standard-input*))
417          (unwind-protect
418            (progn
419              (when *default-execute-filter*
420                (setf pipe (funcall *default-execute-filter*))
421                (case (slot-value pipe 'direction)
422                  (:output
423                    (setf *standard-output* (slot-value pipe 'stream))
424                    (setf saved-handle (ext:duplicate-handle 1))
425                    (setf saved-handle-which 1)
426                    (ext:duplicate-handle (slot-value pipe 'fd) 1))
427                  (:input
428                    (setf *standard-input* (slot-value pipe 'stream))
429                    (setf saved-handle (ext:duplicate-handle 0))
430                    (setf saved-handle-which 0)
431                    (ext:duplicate-handle (slot-value pipe 'fd) 0))))
432              (setf result (unix-funcs:run-program (first arglist)
433                                                   :arguments (rest arglist))))
434            (when saved-handle
435              (ext:duplicate-handle saved-handle saved-handle-which))
436            (when pipe
437              (close-process-pipe pipe))))
438        (case result
439          ((0)
440            (chatter-debug "successful termination~%") T)
441          (otherwise
442            (chatter-debug "unsuccessful or abnormal termination~%") nil))))
443    
444    (defmacro with-filtered-execute-program ((enabled-expr func-expr direction)
445                                             &body body)
446      `(let* ((*default-execute-filter*
447                (if ,enabled-expr
448                  (lambda () (create-process-pipe ,func-expr ,direction))
449                  *default-execute-filter*)))
450         ,@body))
451    
452  (defmacro with-input-from-program ((stream-var arg-list) &body forms)  (defmacro with-input-from-program ((stream-var arg-list) &body forms)
453    (let ((arg-list-sym (gensym "ARG-LIST-")))    (let ((arg-list-sym (gensym "ARG-LIST-")))
454      `(let ((,arg-list-sym ,arg-list))      `(let ((,arg-list-sym ,arg-list))
455         (chatter-debug "piping from ~s in directory ~s~%" ,arg-list-sym (getcwd))         (chatter-debug "piping from ~s in directory ~s~%" ,arg-list-sym (getcwd))
456         (unix-funcs:default-sigchld)         (unix-funcs:default-sigchld)
457         (let* ((,stream-var (make-pipe-input-stream         (let* ((,stream-var (ext:make-pipe-input-stream
458                               (arglist-to-command-string ,arg-list-sym))))                               (arglist-to-command-string ,arg-list-sym))))
459           (declare (dynamic-extent ,stream-var))           (declare (dynamic-extent ,stream-var))
460           (when ,stream-var           (when ,stream-var
# Line 368  Line 463 
463  (defmacro with-output-to-program ((stream-var arg-list) &body forms)  (defmacro with-output-to-program ((stream-var arg-list) &body forms)
464   `(progn   `(progn
465      (unix-funcs:default-sigchld)      (unix-funcs:default-sigchld)
466      (let* ((,stream-var (make-pipe-output-stream      (let* ((,stream-var (ext:make-pipe-output-stream
467                          (arglist-to-command-string ,arg-list))))                          (arglist-to-command-string ,arg-list))))
468        (declare (dynamic-extent ,stream-var))        (declare (dynamic-extent ,stream-var))
469        (when ,stream-var        (when ,stream-var
# Line 395  Line 490 
490    
491  ;;; Environment strings  ;;; Environment strings
492  (defun env-lookup (name &optional substitute-if-not-found)  (defun env-lookup (name &optional substitute-if-not-found)
493    (let ((value (getenv name)))    (let ((value (ext:getenv name)))
494      (if value value substitute-if-not-found)))      (if value value substitute-if-not-found)))

Legend:
Removed from v.1.9.2.10  
changed lines
  Added in v.1.26

  ViewVC Help
Powered by ViewVC 1.1.5