Changeset 12283


Ignore:
Timestamp:
11/25/09 23:12:39 (11 years ago)
Author:
ehuelsmann
Message:

Fix logical pathname translation issue reported by Thomas Russ.

File:
1 edited

Legend:

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

    r11577 r12283  
    215215         (error "Unsupported wildcard pattern: ~S" to))))
    216216
    217 (defun translate-directory-components (source from to case)
    218   (cond ((null to)
    219          nil
    220          )
    221         ((memq (car to) '(:absolute :relative))
    222          (cons (car to)
    223                (translate-directory-components (cdr source) (cdr from) (cdr to) case))
    224          )
    225         ((eq (car to) :wild)
    226          (if (eq (car from) :wild)
    227              ;; Grab the next chunk from SOURCE.
    228              (append (casify (car source) case)
    229                      (translate-directory-components (cdr source) (cdr from) (cdr to) case))
    230              (error "Unsupported case 1: ~S ~S ~S" source from to))
    231          )
    232         ((eq (car to) :wild-inferiors)
    233          ;; Grab the next chunk from SOURCE.
    234          (append (casify (car source) case)
    235                  (translate-directory-components (cdr source) (cdr from) (cdr to) case))
    236          )
    237         (t
    238          ;; "If the piece in TO-WILDCARD is present and not wild, it is copied
    239          ;; into the result."
    240          (append (casify (car to) case)
    241                  (translate-directory-components source from (cdr to) case))
    242          )
    243         ))
     217
     218(defun translate-directory-components-aux (src from to case)
     219  (cond
     220    ((and (null src) (null from) (null to))
     221     NIL)
     222    ((and to
     223          (not (member (car to) '(:wild :wild-inferiors))))
     224     (cons (casify (car to) case)
     225           (translate-directory-components-aux src from (cdr to) case)))
     226    ((not (and src from))
     227     ;; both are NIL --> TO is a wildcard which can't be matched
     228     ;; either is NIL --> SRC can't be fully matched against FROM, vice versa
     229     (throw 'failed-match))
     230    ((not (member (car from) '(:wild :wild-inferiors)))
     231     (unless (string= (casify (car src) case) (casify (car from) case))
     232       (throw 'failed-match)) ;; FROM doesn't match SRC
     233     (translate-directory-components-aux (cdr src) (cdr from) to case))
     234    ((not (eq (car from) (car to))) ;; TO is NIL while FROM is not, or
     235     (throw 'failed-match))         ;; FROM wildcard doesn't match TO wildcard
     236    ((eq (car to) :wild)  ;; FROM and TO wildcards are :WILD
     237     (cons (casify (car src) case)
     238       (translate-directory-components-aux (cdr src) (cdr from) (cdr to) case)))
     239    ((eq (car to) :wild-inferiors) ;; FROM and TO wildcards are :WILD-INFERIORS
     240     (do ((src (cdr src) (cdr src))
     241          (match (list (casify (car src) case))
     242                 (cons (casify (car src) case) match)))
     243         (NIL) ;; we'll exit the loop in different ways
     244       (catch 'failed-match
     245         (return-from translate-directory-components-aux
     246           (append (reverse match) (translate-directory-components-aux
     247                                        src (cdr from) (cdr to) case))))
     248       (when (null src) ;; SRC is NIL and we're still here: error exit
     249         (throw 'failed-match))))))
     250
     251(defun translate-directory-components (src from to case)
     252  (catch 'failed-match
     253    (return-from translate-directory-components
     254      (translate-directory-components-aux src from to case)))
     255  (error "Unsupported case in TRANSLATE-DIRECTORY-COMPONENTS."))
     256
    244257
    245258(defun translate-directory (source from to case)
     
    253266         (remove :wild-inferiors to))
    254267        (t
    255          (translate-directory-components (split-directory-components source)
    256                                          (split-directory-components from)
    257                                          (split-directory-components to)
    258                                          case))))
     268         (translate-directory-components source from to case))))
    259269
    260270;; "The resulting pathname is TO-WILDCARD with each wildcard or missing field
Note: See TracChangeset for help on using the changeset viewer.