/[cmucl]/src/code/filesys.lisp
ViewVC logotype

Diff of /src/code/filesys.lisp

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

revision 1.112 by rtoy, Mon Jun 7 22:52:17 2010 UTC revision 1.113 by rtoy, Mon Nov 8 22:28:59 2010 UTC
# Line 660  Line 660 
660  ;;;; Wildcard matching stuff.  ;;;; Wildcard matching stuff.
661    
662  (defmacro enumerate-matches ((var pathname &optional result  (defmacro enumerate-matches ((var pathname &optional result
663                                    &key (verify-existance t) (follow-links t))                                    &key (verify-existence t) (follow-links t))
664                               &body body)                               &body body)
665    (let ((body-name (gensym)))    (let ((body-name (gensym)))
666      `(block nil      `(block nil
667         (flet ((,body-name (,var)         (flet ((,body-name (,var)
668                  ,@body))                  ,@body))
669           (%enumerate-matches (pathname ,pathname)           (%enumerate-matches (pathname ,pathname)
670                               ,verify-existance ,follow-links                               ,verify-existence ,follow-links
671                               #',body-name)                               #',body-name)
672           ,result))))           ,result))))
673    
674  (defun %enumerate-matches (pathname verify-existance follow-links function)  (defun %enumerate-matches (pathname verify-existence follow-links function)
675    (when (pathname-type pathname)    (when (pathname-type pathname)
676      (unless (pathname-name pathname)      (unless (pathname-name pathname)
677        (error (intl:gettext "Cannot supply a type without a name:~%  ~S") pathname)))        (error (intl:gettext "Cannot supply a type without a name:~%  ~S") pathname)))
# Line 680  Line 680 
680          (ecase (car directory)          (ecase (car directory)
681            (:absolute            (:absolute
682             (%enumerate-directories "/" (cdr directory) pathname             (%enumerate-directories "/" (cdr directory) pathname
683                                     verify-existance follow-links                                     verify-existence follow-links
684                                     nil function))                                     nil function))
685            (:relative            (:relative
686             (%enumerate-directories "" (cdr directory) pathname             (%enumerate-directories "" (cdr directory) pathname
687                                     verify-existance follow-links                                     verify-existence follow-links
688                                     nil function)))                                     nil function)))
689          (%enumerate-files "" pathname verify-existance function))))          (%enumerate-files "" pathname verify-existence function))))
690    
691  ;;; %enumerate-directories  --   Internal  ;;; %enumerate-directories  --   Internal
692  ;;;  ;;;
693  ;;; The directory node and device numbers are maintained for the current path  ;;; The directory node and device numbers are maintained for the current path
694  ;;; during the search for the detection of path loops upon :wild-inferiors.  ;;; during the search for the detection of path loops upon :wild-inferiors.
695  ;;;  ;;;
696  (defun %enumerate-directories (head tail pathname verify-existance  (defun %enumerate-directories (head tail pathname verify-existence
697                                 follow-links nodes function)                                 follow-links nodes function)
698    (declare (simple-string head))    (declare (simple-string head))
699    (macrolet ((unix-xstat (name)    (macrolet ((unix-xstat (name)
# Line 727  Line 727 
727                 (with-directory-node-noted (head)                 (with-directory-node-noted (head)
728                   (%enumerate-directories (concatenate 'string head "/")                   (%enumerate-directories (concatenate 'string head "/")
729                                           (cdr tail) pathname                                           (cdr tail) pathname
730                                           verify-existance follow-links                                           verify-existence follow-links
731                                           nodes function))))                                           nodes function))))
732              ((member :wild-inferiors)              ((member :wild-inferiors)
733               (%enumerate-directories head (rest tail) pathname               (%enumerate-directories head (rest tail) pathname
734                                       verify-existance follow-links                                       verify-existence follow-links
735                                       nodes function)                                       nodes function)
736               (do-directory-entries (name head)               (do-directory-entries (name head)
737                 (let ((subdir (concatenate 'string head name)))                 (let ((subdir (concatenate 'string head name)))
# Line 746  Line 746 
746                         (let ((nodes (cons (cons dev ino) nodes))                         (let ((nodes (cons (cons dev ino) nodes))
747                               (subdir (concatenate 'string subdir "/")))                               (subdir (concatenate 'string subdir "/")))
748                           (%enumerate-directories subdir tail pathname                           (%enumerate-directories subdir tail pathname
749                                                   verify-existance follow-links                                                   verify-existence follow-links
750                                                   nodes function))))))))                                                   nodes function))))))))
751              ((or pattern (member :wild))              ((or pattern (member :wild))
752               (do-directory-entries (name head)               (do-directory-entries (name head)
# Line 760  Line 760 
760                         (let ((nodes (cons (cons dev ino) nodes))                         (let ((nodes (cons (cons dev ino) nodes))
761                               (subdir (concatenate 'string subdir "/")))                               (subdir (concatenate 'string subdir "/")))
762                           (%enumerate-directories subdir (rest tail) pathname                           (%enumerate-directories subdir (rest tail) pathname
763                                                   verify-existance follow-links                                                   verify-existence follow-links
764                                                   nodes function))))))))                                                   nodes function))))))))
765              ((member :up)              ((member :up)
766               (let ((head (concatenate 'string head "..")))               (let ((head (concatenate 'string head "..")))
767                 (with-directory-node-noted (head)                 (with-directory-node-noted (head)
768                   (%enumerate-directories (concatenate 'string head "/")                   (%enumerate-directories (concatenate 'string head "/")
769                                           (rest tail) pathname                                           (rest tail) pathname
770                                           verify-existance follow-links                                           verify-existence follow-links
771                                           nodes function))))))                                           nodes function))))))
772          (%enumerate-files head pathname verify-existance function))))          (%enumerate-files head pathname verify-existence function))))
773    
774  (defun %enumerate-files (directory pathname verify-existance function)  (defun %enumerate-files (directory pathname verify-existence function)
775    (declare (simple-string directory))    (declare (simple-string directory))
776    (let ((name (%pathname-name pathname))    (let ((name (%pathname-name pathname))
777          (type (%pathname-type pathname))          (type (%pathname-type pathname))
778          (version (%pathname-version pathname)))          (version (%pathname-version pathname)))
779      (cond ((member name '(nil :unspecific))      (cond ((member name '(nil :unspecific))
780             (when (or (not verify-existance)             (when (or (not verify-existence)
781                       (unix:unix-file-kind directory))                       (unix:unix-file-kind directory))
782               (funcall function directory)))               (funcall function directory)))
783            ((or (pattern-p name)            ((or (pattern-p name)
# Line 822  Line 822 
822                 (setf file (concatenate 'string file ".~"                 (setf file (concatenate 'string file ".~"
823                                         (quick-integer-to-string version)                                         (quick-integer-to-string version)
824                                         "~")))                                         "~")))
825               (when (or (not verify-existance)               (when (or (not verify-existence)
826                         (unix:unix-file-kind file t))                         (unix:unix-file-kind file t))
827                 (funcall function file)))))))                 (funcall function file)))))))
828    
# Line 868  Line 868 
868    (enumerate-search-list    (enumerate-search-list
869        (pathname path)        (pathname path)
870      (collect ((names))      (collect ((names))
871        (enumerate-matches (name pathname nil :verify-existance for-input        (enumerate-matches (name pathname nil :verify-existence for-input
872                                 :follow-links t)                                 :follow-links t)
873          (when (or (not executable-only)          (when (or (not executable-only)
874                    (and (eq (unix:unix-file-kind name) :file)                    (and (eq (unix:unix-file-kind name) :file)

Legend:
Removed from v.1.112  
changed lines
  Added in v.1.113

  ViewVC Help
Powered by ViewVC 1.1.5