Changeset 9953


Ignore:
Timestamp:
09/09/05 19:37:26 (16 years ago)
Author:
piso
Message:

Moved PATHNAME-MATCH-P to pathnames.lisp.

Location:
trunk/j/src/org/armedbear/lisp
Files:
4 edited

Legend:

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

    r9950 r9953  
    33 *
    44 * Copyright (C) 2004-2005 Peter Graves
    5  * $Id: LogicalPathname.java,v 1.10 2005-09-08 23:31:28 piso Exp $
     5 * $Id: LogicalPathname.java,v 1.11 2005-09-09 19:36:38 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    204204    }
    205205
    206     // ""Missing components of wildcard default to :WILD."
    207     protected boolean matches(Pathname wildcard) throws ConditionThrowable
    208     {
    209         if (wildcard.host != Keyword.WILD && wildcard.name != NIL) {
    210             if (!host.equalp(wildcard.host))
    211                 return false;
    212         }
    213         if (wildcard.name != Keyword.WILD && wildcard.name != NIL) {
    214             if (!name.equalp(wildcard.name))
    215                 return false;
    216         }
    217         if (wildcard.directory != Keyword.WILD && wildcard.directory != NIL) {
    218             if (!directory.equalp(wildcard.directory))
    219                 return false;
    220         }
    221         if (wildcard.type != Keyword.WILD && wildcard.type != NIL) {
    222             if (!type.equalp(wildcard.type))
    223                 return false;
    224         }
    225         return true;
    226     }
    227 
    228206    // ### %make-logical-pathname namestring => logical-pathname
    229207    private static final Primitive _MAKE_LOGICAL_PATHNAME =
  • trunk/j/src/org/armedbear/lisp/Pathname.java

    r9950 r9953  
    33 *
    44 * Copyright (C) 2003-2005 Peter Graves
    5  * $Id: Pathname.java,v 1.84 2005-09-08 23:31:00 piso Exp $
     5 * $Id: Pathname.java,v 1.85 2005-09-09 19:36:31 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    771771    };
    772772
    773     // ### pathname-match-p pathname wildcard => generalized-boolean
    774     private static final Primitive PATHNAME_MATCH_P =
    775         new Primitive("pathname-match-p", "pathname wildcard")
    776     {
    777         public LispObject execute(LispObject first, LispObject second)
    778             throws ConditionThrowable
    779         {
    780             Pathname pathname = coerceToPathname(first);
    781             Pathname wildcard = coerceToPathname(second);
    782             return pathname.matches(wildcard) ? T : NIL;
    783         }
    784     };
    785 
    786     // ""Missing components of wildcard default to :WILD."
    787     protected boolean matches(Pathname wildcard) throws ConditionThrowable
    788     {
    789         if (Utilities.isPlatformWindows()) {
    790             if (wildcard.device != Keyword.WILD && wildcard.device != NIL) {
    791                 if (!device.equalp(wildcard.device))
    792                     return false;
    793             }
    794             if (wildcard.name != Keyword.WILD && wildcard.name != NIL) {
    795                 if (!name.equalp(wildcard.name))
    796                     return false;
    797             }
    798             if (wildcard.directory != Keyword.WILD && wildcard.directory != NIL) {
    799                 if (!directory.equalp(wildcard.directory))
    800                     return false;
    801             }
    802             if (wildcard.type != Keyword.WILD && wildcard.type != NIL) {
    803                 if (!type.equalp(wildcard.type))
    804                     return false;
    805             }
    806         } else {
    807             // Unix.
    808             if (wildcard.name != Keyword.WILD && wildcard.name != NIL) {
    809                 if (!name.equal(wildcard.name))
    810                     return false;
    811             }
    812             if (wildcard.directory != Keyword.WILD && wildcard.directory != NIL) {
    813                 if (!directory.equal(wildcard.directory))
    814                     return false;
    815             }
    816             if (wildcard.type != Keyword.WILD && wildcard.type != NIL) {
    817                 if (!type.equal(wildcard.type))
    818                     return false;
    819             }
    820         }
    821         return true;
    822     }
    823 
    824773    // ### list-directory
    825774    private static final Primitive LIST_DIRECTORY =
  • trunk/j/src/org/armedbear/lisp/autoloads.lisp

    r9946 r9953  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: autoloads.lisp,v 1.194 2005-09-08 16:09:05 piso Exp $
     4;;; $Id: autoloads.lisp,v 1.195 2005-09-09 19:37:26 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    153153(autoload-macro 'with-open-file)
    154154(autoload '(pathname-host pathname-device pathname-directory pathname-name
    155             pathname-type wild-pathname-p translate-pathname
     155            pathname-type wild-pathname-p pathname-match-p translate-pathname
    156156            logical-pathname-translations translate-logical-pathname
    157157            load-logical-pathname-translations logical-pathname
  • trunk/j/src/org/armedbear/lisp/pathnames.lisp

    r9951 r9953  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: pathnames.lisp,v 1.11 2005-09-09 02:40:08 piso Exp $
     4;;; $Id: pathnames.lisp,v 1.12 2005-09-09 19:36:55 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    3737(defun wild-pathname-p (pathname &optional field-key)
    3838  (%wild-pathname-p pathname field-key))
     39
     40(defun component-match-p (thing wild ignore-case)
     41  (cond ((eq wild :wild)
     42         t)
     43        ((null wild)
     44         t)
     45        (ignore-case
     46         (equalp thing wild))
     47        (t
     48         (equal thing wild))))
     49
     50(defun directory-match-components (thing wild ignore-case)
     51  (loop
     52    (let ((x (car thing))
     53          (y (car wild)))
     54      (unless (component-match-p x y ignore-case)
     55        (return nil))
     56      (setf thing (cdr thing)
     57            wild  (cdr wild))
     58      (cond ((endp thing)
     59             (return (endp wild)))
     60            ((endp wild)
     61             (return nil))))))
     62
     63(defun directory-match-p (thing wild ignore-case)
     64  (cond ((eq wild :wild)
     65         t)
     66        ((null wild)
     67         t)
     68        ((and ignore-case (equalp thing wild))
     69         t)
     70        ((equal thing wild)
     71         t)
     72        ((and (consp thing) (consp wild))
     73         (directory-match-components thing wild ignore-case))
     74        (t
     75         nil)))
     76
     77(defun pathname-match-p (pathname wildcard)
     78  (setf pathname (pathname pathname)
     79        wildcard (pathname wildcard))
     80  (unless (component-match-p (pathname-host pathname) (pathname-host wildcard) nil)
     81    (return-from pathname-match-p nil))
     82  (let* ((windows-p (featurep :windows))
     83         (ignore-case (or windows-p (typep pathname 'logical-pathname))))
     84    (cond ((and windows-p
     85                (not (component-match-p (pathname-device pathname)
     86                                        (pathname-device wildcard)
     87                                        ignore-case)))
     88           nil)
     89          ((not (directory-match-p (pathname-directory pathname)
     90                                   (pathname-directory wildcard)
     91                                   ignore-case))
     92           nil)
     93          ((not (component-match-p (pathname-name pathname)
     94                                   (pathname-name wildcard)
     95                                   ignore-case))
     96           nil)
     97          ((not (component-match-p (pathname-type pathname)
     98                                   (pathname-type wildcard)
     99                                   ignore-case))
     100           nil)
     101          (t
     102           t))))
    39103
    40104(defun wild-p (component)
     
    68132        (from   (pathname from-wildcard))
    69133        (to     (pathname to-wildcard)))
    70     (make-pathname :host     (or (pathname-host to)
    71                                  (pathname-host source))
    72                    :device   (translate-component (pathname-device source)
    73                                                   (pathname-device from)
    74                                                   (pathname-device to))
    75                    ;; FIXME directory
    76                    :name     (translate-component (pathname-name source)
    77                                                   (pathname-name from)
    78                                                   (pathname-name to))
    79                    :type     (translate-component (pathname-type source)
    80                                                   (pathname-type from)
    81                                                   (pathname-type to))
    82                    :version  (if (null (pathname-host from))
    83                                  (if (eq (pathname-version to) :wild)
    84                                      (pathname-version from)
    85                                      (pathname-version to))
    86                                  (translate-component (pathname-version source)
    87                                                       (pathname-version from)
    88                                                       (pathname-version to))))))
     134    (make-pathname :host      (or (pathname-host to)
     135                                  (pathname-host source))
     136                   :device    (translate-component (pathname-device source)
     137                                                   (pathname-device from)
     138                                                   (pathname-device to))
     139                   :directory (translate-component (pathname-device source)
     140                                                   (pathname-device from)
     141                                                   (pathname-device to))
     142                   :name      (translate-component (pathname-name source)
     143                                                   (pathname-name from)
     144                                                   (pathname-name to))
     145                   :type      (translate-component (pathname-type source)
     146                                                   (pathname-type from)
     147                                                   (pathname-type to))
     148                   :version   (if (null (pathname-host from))
     149                                  (if (eq (pathname-version to) :wild)
     150                                      (pathname-version from)
     151                                      (pathname-version to))
     152                                  (translate-component (pathname-version source)
     153                                                       (pathname-version from)
     154                                                       (pathname-version to))))))
    89155
    90156(defun canonicalize-logical-hostname (host)
Note: See TracChangeset for help on using the changeset viewer.