/[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.68 by toy, Wed Oct 2 13:36:48 2002 UTC revision 1.68.2.1 by pmai, Fri Oct 4 23:13:24 2002 UTC
# Line 72  Line 72 
72  (defun remove-backslashes (namestr start end)  (defun remove-backslashes (namestr start end)
73    "Remove and occurences of \\ from the string because we've already    "Remove and occurences of \\ from the string because we've already
74     checked for whatever they may have been backslashed."     checked for whatever they may have been backslashed."
75    (declare (type simple-base-string namestr)    (declare (type namestring namestr)
76             (type index start end))             (type index start end))
77    (let* ((result (make-string (- end start)))    (let* ((result (make-string (- end start) :element-type 'base-char))
78           (dst 0)           (dst 0)
79           (quoted nil))           (quoted nil))
80      (do ((src start (1+ src)))      (do ((src start (1+ src)))
# Line 100  Line 100 
100  (defvar *ignore-wildcards* nil)  (defvar *ignore-wildcards* nil)
101    
102  (defun maybe-make-pattern (namestr start end)  (defun maybe-make-pattern (namestr start end)
103    (declare (type simple-base-string namestr)    (declare (type namestring namestr)
104             (type index start end))             (type index start end))
105    (if *ignore-wildcards*    (if *ignore-wildcards*
106        (subseq namestr start end)        (subseq namestr start end)
# Line 173  Line 173 
173  ;;; extract-name-type-and-version  --  Internal.  ;;; extract-name-type-and-version  --  Internal.
174  ;;;  ;;;
175  (defun extract-name-type-and-version (namestr start end)  (defun extract-name-type-and-version (namestr start end)
176    (declare (type simple-base-string namestr)    (declare (type namestring namestr)
177             (type index start end))             (type index start end))
178    (labels    (labels
179        ((explicit-version (namestr start end)        ((explicit-version (namestr start end)
# Line 236  Line 236 
236  ;;; separated subseq. The first value t if absolute directories location.  ;;; separated subseq. The first value t if absolute directories location.
237  ;;;  ;;;
238  (defun split-at-slashes (namestr start end)  (defun split-at-slashes (namestr start end)
239    (declare (type simple-base-string namestr)    (declare (type namestring namestr)
240             (type index start end))             (type index start end))
241    (let ((absolute (and (/= start end)    (let ((absolute (and (/= start end)
242                         (char= (schar namestr start) #\/))))                         (char= (schar namestr start) #\/))))
# Line 253  Line 253 
253        (values absolute (pieces)))))        (values absolute (pieces)))))
254    
255  (defun maybe-extract-search-list (namestr start end)  (defun maybe-extract-search-list (namestr start end)
256    (declare (type simple-base-string namestr)    (declare (type namestring namestr)
257             (type index start end))             (type index start end))
258    (let ((quoted nil))    (let ((quoted nil))
259      (do ((index start (1+ index)))      (do ((index start (1+ index)))
# Line 269  Line 269 
269                               (1+ index)))))))))                               (1+ index)))))))))
270    
271  (defun parse-unix-namestring (namestr start end)  (defun parse-unix-namestring (namestr start end)
272    (declare (type simple-base-string namestr)    (declare (type namestring namestr)
273             (type index start end))             (type index start end))
274    (multiple-value-bind    (multiple-value-bind (absolute pieces)
       (absolute pieces)  
275        (split-at-slashes namestr start end)        (split-at-slashes namestr start end)
276      (let ((search-list      (let ((search-list
277             (if absolute             (if absolute
278                 nil                 nil
279                 (let ((first (car pieces)))                 (let ((first (car pieces)))
280                   (multiple-value-bind                   (multiple-value-bind (search-list new-start)
281                       (search-list new-start)                       (maybe-extract-search-list namestr (car first) (cdr first))
                      (maybe-extract-search-list namestr  
                                                 (car first) (cdr first))  
282                     (when search-list                     (when search-list
283                       (setf absolute t)                       (setf absolute t)
284                       (setf (car first) new-start))                       (setf (car first) new-start))
# Line 346  Line 343 
343           (case (schar thing i)           (case (schar thing i)
344             ((#\* #\? #\[)             ((#\* #\? #\[)
345              (incf dstlen))))              (incf dstlen))))
346         (let ((result (make-string dstlen))         (let ((result (make-string dstlen :element-type 'base-char))
347               (dst 0))               (dst 0))
348           (dotimes (src srclen)           (dotimes (src srclen)
349             (let ((char (schar thing src)))             (let ((char (schar thing src)))
# Line 378  Line 375 
375                (t                (t
376                 (error "Invalid pattern piece: ~S" piece))))))                 (error "Invalid pattern piece: ~S" piece))))))
377         (apply #'concatenate         (apply #'concatenate
378                'simple-string                'simple-base-string
379                (strings))))))                (strings))))))
380    
381  (defun unparse-unix-directory-list (directory)  (defun unparse-unix-directory-list (directory)
# Line 408  Line 405 
405             (pieces "/"))             (pieces "/"))
406            (t            (t
407             (error "Invalid directory component: ~S" dir)))))             (error "Invalid directory component: ~S" dir)))))
408      (apply #'concatenate 'simple-string (pieces))))      (apply #'concatenate 'simple-base-string (pieces))))
409    
410  (defun unparse-unix-directory (pathname)  (defun unparse-unix-directory (pathname)
411    (declare (type pathname pathname))    (declare (type pathname pathname))
# Line 435  Line 432 
432                       (if logical-p ".*" ".~*~")                       (if logical-p ".*" ".~*~")
433                       (format nil (if logical-p ".~D" ".~~~D~~")                       (format nil (if logical-p ".~D" ".~~~D~~")
434                               version)))))                               version)))))
435      (and (strings) (apply #'concatenate 'simple-string (strings)))))      (and (strings) (apply #'concatenate 'simple-base-string (strings)))))
436    
437  (defun unparse-unix-namestring (pathname)  (defun unparse-unix-namestring (pathname)
438    (declare (type pathname pathname))    (declare (type pathname pathname))
439    (concatenate 'simple-string    (concatenate 'simple-base-string
440                 (unparse-unix-directory pathname)                 (unparse-unix-directory pathname)
441                 (unparse-unix-file pathname)))                 (unparse-unix-file pathname)))
442    
# Line 497  Line 494 
494               (strings (format nil ".~~~D~~" pathname-version)))               (strings (format nil ".~~~D~~" pathname-version)))
495              (t              (t
496               (lose)))))               (lose)))))
497        (apply #'concatenate 'simple-string (strings)))))        (apply #'concatenate 'simple-base-string (strings)))))
498    
499    
500  (defstruct (unix-host  (defstruct (unix-host
# Line 585  Line 582 
582          (let ((piece (car tail)))          (let ((piece (car tail)))
583            (etypecase piece            (etypecase piece
584              (simple-string              (simple-string
585               (let ((head (concatenate 'string head piece)))               (let ((head (concatenate 'simple-base-string head piece)))
586                 (with-directory-node-noted (head)                 (with-directory-node-noted (head)
587                   (%enumerate-directories (concatenate 'string head "/")                   (%enumerate-directories (concatenate 'simple-base-string head "/")
588                                           (cdr tail) pathname                                           (cdr tail) pathname
589                                           verify-existance follow-links                                           verify-existance follow-links
590                                           nodes function))))                                           nodes function))))
# Line 596  Line 593 
593                                       verify-existance follow-links                                       verify-existance follow-links
594                                       nodes function)                                       nodes function)
595               (do-directory-entries (name head)               (do-directory-entries (name head)
596                 (let ((subdir (concatenate 'string head name)))                 (let ((subdir (concatenate 'simple-base-string head name)))
597                   (multiple-value-bind (res dev ino mode)                   (multiple-value-bind (res dev ino mode)
598                       (unix-xstat subdir)                       (unix-xstat subdir)
599                     (declare (type (or fixnum null) mode))                     (declare (type (or fixnum null) mode))
# Line 606  Line 603 
603                                            (eql (cdr dir) ino))                                            (eql (cdr dir) ino))
604                                   (return t)))                                   (return t)))
605                         (let ((nodes (cons (cons dev ino) nodes))                         (let ((nodes (cons (cons dev ino) nodes))
606                               (subdir (concatenate 'string subdir "/")))                               (subdir (concatenate 'simple-base-string subdir "/")))
607                           (%enumerate-directories subdir tail pathname                           (%enumerate-directories subdir tail pathname
608                                                   verify-existance follow-links                                                   verify-existance follow-links
609                                                   nodes function))))))))                                                   nodes function))))))))
610              ((or pattern (member :wild))              ((or pattern (member :wild))
611               (do-directory-entries (name head)               (do-directory-entries (name head)
612                 (when (or (eq piece :wild) (pattern-matches piece name))                 (when (or (eq piece :wild) (pattern-matches piece name))
613                   (let ((subdir (concatenate 'string head name)))                   (let ((subdir (concatenate 'simple-base-string head name)))
614                     (multiple-value-bind (res dev ino mode)                     (multiple-value-bind (res dev ino mode)
615                         (unix-xstat subdir)                         (unix-xstat subdir)
616                       (declare (type (or fixnum null) mode))                       (declare (type (or fixnum null) mode))
617                       (when (and res                       (when (and res
618                                  (eql (logand mode unix:s-ifmt) unix:s-ifdir))                                  (eql (logand mode unix:s-ifmt) unix:s-ifdir))
619                         (let ((nodes (cons (cons dev ino) nodes))                         (let ((nodes (cons (cons dev ino) nodes))
620                               (subdir (concatenate 'string subdir "/")))                               (subdir (concatenate 'simple-base-string subdir "/")))
621                           (%enumerate-directories subdir (rest tail) pathname                           (%enumerate-directories subdir (rest tail) pathname
622                                                   verify-existance follow-links                                                   verify-existance follow-links
623                                                   nodes function))))))))                                                   nodes function))))))))
624              ((member :up)              ((member :up)
625               (let ((head (concatenate 'string head "..")))               (let ((head (concatenate 'simple-base-string head "..")))
626                 (with-directory-node-noted (head)                 (with-directory-node-noted (head)
627                   (%enumerate-directories (concatenate 'string head "/")                   (%enumerate-directories (concatenate 'simple-base-string head "/")
628                                           (rest tail) pathname                                           (rest tail) pathname
629                                           verify-existance follow-links                                           verify-existance follow-links
630                                           nodes function))))))                                           nodes function))))))
631          (%enumerate-files head pathname verify-existance function))))          (%enumerate-files head pathname verify-existance function))))
632    
633  (defun %enumerate-files (directory pathname verify-existance function)  (defun %enumerate-files (directory pathname verify-existance function)
634    (declare (simple-string directory))    (declare (simple-base-string directory))
635    (let ((name (%pathname-name pathname))    (let ((name (%pathname-name pathname))
636          (type (%pathname-type pathname))          (type (%pathname-type pathname))
637          (version (%pathname-version pathname)))          (version (%pathname-version pathname)))
# Line 664  Line 661 
661                                            (components-match file-version                                            (components-match file-version
662                                                              version))                                                              version))
663                                   (funcall function                                   (funcall function
664                                            (concatenate 'string                                            (concatenate 'simple-base-string
665                                                         directory                                                         directory
666                                                         file)))))                                                         file)))))
667                             (return))))                             (return))))
668                   (unix:close-dir dir)))))                   (unix:close-dir dir)))))
669            (t            (t
670             (let ((file (concatenate 'string directory name)))             (let ((file (concatenate 'simple-base-string directory name)))
671               (unless (or (null type) (eq type :unspecific))               (unless (or (null type) (eq type :unspecific))
672                 (setf file (concatenate 'string file "." type)))                 (setf file (concatenate 'simple-base-string file "." type)))
673               (unless (member version '(nil :newest :wild :unspecific))               (unless (member version '(nil :newest :wild :unspecific))
674                 (setf file (concatenate 'string file ".~"                 (setf file (concatenate 'simple-base-string file ".~"
675                                         (quick-integer-to-string version)                                         (quick-integer-to-string version)
676                                         "~")))                                         "~")))
677               (when (or (not verify-existance)               (when (or (not verify-existance)
# Line 688  Line 685 
685          ((zerop n) "0")          ((zerop n) "0")
686          ((eql n 1) "1")          ((eql n 1) "1")
687          ((minusp n)          ((minusp n)
688           (concatenate 'simple-string "-"           (concatenate 'simple-base-string "-"
689                        (the simple-string (quick-integer-to-string (- n)))))                        (the simple-base-string (quick-integer-to-string (- n)))))
690          (t          (t
691           (do* ((len (1+ (truncate (integer-length n) 3)))           (do* ((len (1+ (truncate (integer-length n) 3)))
692                 (res (make-string len))                 (res (make-string len :element-type 'base-char))
693                 (i (1- len) (1- i))                 (i (1- len) (1- i))
694                 (q n)                 (q n)
695                 (r 0))                 (r 0))
# Line 700  Line 697 
697                 (incf i)                 (incf i)
698                 (replace res res :start2 i :end2 len)                 (replace res res :start2 i :end2 len)
699                 (shrink-vector res (- len i)))                 (shrink-vector res (- len i)))
700             (declare (simple-string res)             (declare (simple-base-string res)
701                      (fixnum len i r q))                      (fixnum len i r q))
702             (multiple-value-setq (q r) (truncate q 10))             (multiple-value-setq (q r) (truncate q 10))
703             (setf (schar res i) (schar "0123456789" r))))))             (setf (schar res i) (schar "0123456789" r))))))
# Line 1266  Line 1263 
1263                         (unix:unix-current-directory)                         (unix:unix-current-directory)
1264      (if gr      (if gr
1265          (let ((*ignore-wildcards* t))          (let ((*ignore-wildcards* t))
1266            (pathname (concatenate 'simple-string dir-or-error "/")))            (pathname (concatenate 'simple-base-string dir-or-error "/")))
1267          (error dir-or-error))))          (error dir-or-error))))
1268    
1269  ;;; %Set-Default-Directory  --  Internal  ;;; %Set-Default-Directory  --  Internal

Legend:
Removed from v.1.68  
changed lines
  Added in v.1.68.2.1

  ViewVC Help
Powered by ViewVC 1.1.5