Changeset 9969


Ignore:
Timestamp:
09/13/05 21:36:23 (16 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/pathnames.lisp

    r9968 r9969  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: pathnames.lisp,v 1.17 2005-09-13 17:21:23 piso Exp $
     4;;; $Id: pathnames.lisp,v 1.18 2005-09-13 21:36:23 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    113113           (position #\* component))))
    114114
    115 (defun translate-component (source from to)
     115(defun casify (thing case)
     116  (if (stringp thing)
     117      (case case
     118        (:upcase (string-upcase thing))
     119        (:downcase (string-downcase thing))
     120        (t thing))
     121      thing))
     122
     123(defun translate-component (source from to &optional case)
    116124  (cond ((or (eq to :wild) (null to))
    117125         ;; "If the piece in TO-WILDCARD is :WILD or NIL, the piece in source
    118126         ;; is copied into the result."
    119          source)
     127         (casify source case))
    120128        ((and to (not (wild-p to)))
    121129        ;; "If the piece in TO-WILDCARD is present and not wild, it is copied
     
    132140         (error "Unsupported TO-WILDCARD pattern: ~S" to))))
    133141
    134 (defun translate-directory (source from to)
     142(defun translate-directory (source from to case)
    135143  ;; FIXME The IGNORE-CASE argument to DIRECTORY-MATCH-P should not be nil on
    136144  ;; Windows or if the source pathname is a logical pathname.
     
    139147  (cond ((null source)
    140148         to)
    141         (t
    142          (mapcar 'translate-component source from to))))
     149        ((equal source '(:absolute))
     150         (remove :wild-inferiors to))
     151        (t
     152         (mapcar #'(lambda (source from to)
     153                    (translate-component source from to case))
     154                 source from to))))
    143155
    144156;; "The resulting pathname is TO-WILDCARD with each wildcard or missing field
     
    149161  (let ((source (pathname source))
    150162        (from   (pathname from-wildcard))
    151         (to     (pathname to-wildcard)))
    152     (make-pathname :host      (or (pathname-host to)
    153                                   (pathname-host source))
     163        (to     (pathname to-wildcard))
     164        (case   (and (typep source 'logical-pathname)
     165                     (featurep :unix)
     166                     :downcase)))
     167    (make-pathname :host      (pathname-host to)
    154168                   :device    (translate-component (pathname-device source)
    155169                                                   (pathname-device from)
     
    157171                   :directory (translate-directory (pathname-directory source)
    158172                                                   (pathname-directory from)
    159                                                    (pathname-directory to))
     173                                                   (pathname-directory to)
     174                                                   case)
    160175                   :name      (translate-component (pathname-name source)
    161176                                                   (pathname-name from)
    162                                                    (pathname-name to))
     177                                                   (pathname-name to)
     178                                                   case)
    163179                   :type      (translate-component (pathname-type source)
    164180                                                   (pathname-type from)
    165                                                    (pathname-type to))
     181                                                   (pathname-type to)
     182                                                   case)
    166183                   :version   (if (null (pathname-host from))
    167184                                  (if (eq (pathname-version to) :wild)
Note: See TracChangeset for help on using the changeset viewer.