Changeset 11996
- Timestamp:
- May 3, 2009, 11:40:57 AM (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/lib/pathnames.lisp
r11640 r11996 230 230 bits. Portable programs should avoid using the :MODE keyword 231 231 argument." 232 (let* ((pathname (make-directory-pathname :directory (pathname-directory (translate-logical-pathname (merge-pathnames pathspec))))) 233 (created-p nil)) 232 (let ((pathname (let ((pathspec (translate-logical-pathname (merge-pathnames pathspec)))) 233 (make-directory-pathname :device (pathname-device pathspec) 234 :directory (pathname-directory pathspec)))) 235 (created-p nil)) 234 236 (when (wild-pathname-p pathname) 235 237 (error 'file-error … … 300 302 ;Directory Traversing 301 303 302 (defmacro with-open-dir ((dirent dir) &body body) 303 `(let ((,dirent (%open-dir ,dir))) 304 (defun %path-cat (device dir subdir) 305 (if device 306 (%str-cat device ":" dir subdir) 307 (%str-cat dir subdir))) 308 309 (defmacro with-open-dir ((dirent device dir) &body body) 310 `(let ((,dirent (%open-dir (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil))))) 304 311 (when ,dirent 305 312 (unwind-protect … … 360 367 ; for a * or *x*y 361 368 (defun %one-wild (dir wild rest path so-far keys) 362 (let ((result ()) (all (getf keys :all)) name subdir) 363 (with-open-dir (dirent dir) 369 (let ((result ()) 370 (device (pathname-device path)) 371 (all (getf keys :all)) 372 name) 373 (with-open-dir (dirent device dir) 364 374 (while (setq name (%read-dir dirent)) 365 375 (when (and (or all (neq (%schar name 0) #\.)) … … 367 377 (not (string= name "..")) 368 378 (%path-pstr*= wild name) 369 (eq (%unix-file-kind (setq subdir (%str-cat dir name)) t) :directory)) 370 (let ((so-far (cons (%path-std-quotes name nil "/;:*") so-far))) 379 (eq (%unix-file-kind (%path-cat device dir name) t) :directory)) 380 (let ((subdir (%path-cat nil dir name)) 381 (so-far (cons (%path-std-quotes name nil "/;:*") so-far))) 371 382 (declare (dynamic-extent so-far)) 372 383 (setq result … … 375 386 376 387 (defun %files-in-directory (dir path so-far keys) 377 (let ((name (pathname-name path)) 388 (let ((device (pathname-device path)) 389 (name (pathname-name path)) 378 390 (type (pathname-type path)) 379 391 (directories (getf keys :directories)) … … 387 399 sub dir-list ans) 388 400 (if (not (or name type)) 389 (when directories 390 (setq ans (if directory-pathnames 391 (%cons-pathname (reverse so-far) nil nil) 392 (%cons-pathname (reverse (cdr so-far)) (car so-far) nil))) 393 (when (and ans (or (null test) (funcall test ans))) 394 (setq result (list ans)))) 395 (with-open-dir (dirent dir) 401 (let (full-path) 402 (when (and directories 403 (eq (%unix-file-kind (namestring (setq full-path (%cons-pathname (reverse so-far) nil nil nil device))) 404 t) 405 :directory)) 406 (setq ans (if directory-pathnames full-path 407 (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device))) 408 (when (and ans (or (null test) (funcall test ans))) 409 (setq result (list ans))))) 410 (with-open-dir (dirent (pathname-device path) dir) 396 411 (while (setq sub (%read-dir dirent)) 397 412 (when (and (or all (neq (%schar sub 0) #\.)) … … 403 418 (%file*= name type sub)) 404 419 (setq ans 405 (if (eq (%unix-file-kind (% str-catdir sub) t) :directory)420 (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory) 406 421 (when directories 407 422 (let* ((std-sub (%path-std-quotes sub nil "/;:*"))) 408 423 (if directory-pathnames 409 (%cons-pathname (reverse (cons std-sub so-far)) nil nil )410 (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) std-sub nil ))))424 (%cons-pathname (reverse (cons std-sub so-far)) nil nil nil device) 425 (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) std-sub nil nil device)))) 411 426 (when files 412 427 (multiple-value-bind (name type) (%std-name-and-type sub) 413 (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type )))))428 (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device))))) 414 429 (when (and ans (or (null test) (funcall test ans))) 415 430 (push (if follow-links (or (probe-file ans) ans) ans) result)))))) … … 420 435 (do-dirs nil) 421 436 (result nil) 437 (device (pathname-device path)) 422 438 (name (pathname-name path)) 423 439 (type (pathname-type path)) … … 426 442 (directory-pathnames (getf keys :directory-pathnames)) 427 443 (follow-links (getf keys :follow-links)) 428 sub subfiledir-list ans)444 sub dir-list ans) 429 445 ;; First process the case that the ** stands for 0 components 430 446 (multiple-value-bind (next-dir next-wild next-rest) (%split-dir rest) … … 445 461 (t (when (getf keys :directories) 446 462 (setq sub (if directory-pathnames 447 (%cons-pathname (setq dir-list (reverse so-far)) nil nil )448 (%cons-pathname (reverse (cdr so-far)) (car so-far) nil )))463 (%cons-pathname (setq dir-list (reverse so-far)) nil nil nil device) 464 (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device))) 449 465 (when (or (null test) (funcall test sub)) 450 466 (setq result (list (if follow-links (truename sub) sub)))))))) 451 467 ; now descend doing %all-dirs on dirs and collecting files & dirs if do-x is t 452 (with-open-dir (dirent d ir)468 (with-open-dir (dirent device dir) 453 469 (while (setq sub (%read-dir dirent)) 454 470 (when (and (or all (neq (%schar sub 0) #\.)) 455 471 (not (string= sub ".")) 456 472 (not (string= sub ".."))) 457 (if (eq (%unix-file-kind (setq subfile (%str-cat dir sub)) t) :directory) 458 (let* ((std-sub (%path-std-quotes sub nil "/;:*")) 473 (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory) 474 (let* ((subfile (%path-cat nil dir sub)) 475 (std-sub (%path-std-quotes sub nil "/;:*")) 459 476 (so-far (cons std-sub so-far)) 460 477 (subdir (%str-cat subfile "/"))) … … 462 479 (when (and do-dirs (%file*= name type sub)) 463 480 (setq ans (if directory-pathnames 464 (%cons-pathname (reverse so-far) nil nil )481 (%cons-pathname (reverse so-far) nil nil nil device) 465 482 (%cons-pathname (or dir-list (setq dir-list (reverse (cdr so-far)))) 466 std-sub nil )))483 std-sub nil nil device))) 467 484 (when (or (null test) (funcall test ans)) 468 485 (push (if follow-links (truename ans) ans) result)))
Note: See TracChangeset
for help on using the changeset viewer.