home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / dosdir.scm < prev    next >
Text File  |  2001-05-12  |  10KB  |  313 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: dosdir.scm,v 1.10 2001/05/12 20:03:01 cph Exp $
  4.  
  5. Copyright (c) 1992, 1999-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
  20. USA.
  21. |#
  22.  
  23. ;;;; DOS Directory Reader
  24. ;;; package: (runtime directory)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define directory-read/adjust-patterns? true)
  29. (define *expand-directory-prefixes?* true)
  30.  
  31. (define (directory-read pattern #!optional sort?)
  32.   (if (if (default-object? sort?) true sort?)
  33.       (sort (directory-read-nosort pattern) pathname<?)
  34.       (directory-read-nosort pattern)))
  35.  
  36. (define (directory-read-nosort pattern)
  37.   (let ((pattern
  38.      (let ((pattern (adjust-directory-pattern (merge-pathnames pattern))))
  39.        (if (directory-pathname? pattern)
  40.            (make-pathname (pathname-host pattern)
  41.                   (pathname-device pattern)
  42.                   (pathname-directory pattern)
  43.                   'WILD
  44.                   'WILD
  45.                   (pathname-version pattern))
  46.            pattern))))
  47.     (let ((directory-path (directory-pathname pattern)))
  48.       (map (lambda (pathname)
  49.          (merge-pathnames pathname directory-path))
  50.        (let ((pathnames
  51.           (let ((fnames (generate-directory-pathnames directory-path)))
  52.             (fluid-let ((*expand-directory-prefixes?* false))
  53.               (map ->pathname fnames)))))
  54.          (if (and (eq? (pathname-name pattern) 'WILD)
  55.               (eq? (pathname-type pattern) 'WILD))
  56.          pathnames
  57.          (list-transform-positive pathnames
  58.            (let ((match-name
  59.               (component-matcher (pathname-name pattern)))
  60.              (match-type
  61.               (component-matcher (pathname-type pattern))))
  62.              (lambda (instance)
  63.                (and (match-name (pathname-name instance))
  64.                 (match-type (pathname-type instance))))))))))))
  65.  
  66. (define (adjust-directory-pattern pathname)
  67.   (if (and directory-read/adjust-patterns?
  68.        (not (pathname-type pathname))
  69.        (let ((name (pathname-name pathname)))
  70.          (and (string? name)
  71.           (let ((len (string-length name)))
  72.             (and (> len 0)
  73.              (char=? (string-ref name (-1+ len)) #\*))))))
  74.       (pathname-new-type pathname 'WILD)
  75.       pathname))
  76.  
  77. (define (generate-directory-pathnames pathname)
  78.   (let ((channel (directory-channel-open (->namestring pathname))))
  79.     (let loop ((result '()))
  80.       (let ((name (directory-channel-read channel)))
  81.     (if name
  82.         (loop (cons name result))
  83.         (begin
  84.           (directory-channel-close channel)
  85.           result))))))
  86.  
  87. (define (pathname<? x y)
  88.   (or (component<? (pathname-name x) (pathname-name y))
  89.       (and (equal? (pathname-name x) (pathname-name y))
  90.        (component<? (pathname-type x) (pathname-type y)))))
  91.  
  92. (define (component<? x y)
  93.   (and y
  94.        (or (not x)
  95.        (and (string? y)
  96.         (or (not (string? x))
  97.             (string<? x y))))))
  98.  
  99. ;;; This matcher does not currently understand question marks
  100. ;;; but understands multiple asterisks.
  101. ;;; Question marks are hard because in the presence of asterisks,
  102. ;;; simple-minded left-to-right processing no longer works.  e.g.
  103. ;;; "*foo?bar*" matching "foogbazfoogbar".
  104.  
  105. (define (component-matcher pattern)
  106.   (cond ((eq? pattern 'WILD)
  107.      (lambda (instance)
  108.        instance            ; ignored
  109.        true))
  110.     ((and (string? pattern) (string-find-next-char pattern #\*))
  111.      =>
  112.      (lambda (posn)
  113.        (let* ((len (string-length pattern))
  114.           (posn*
  115.            (substring-find-next-char pattern (1+ posn) len #\*)))
  116.          (if (not posn*)
  117.          (simple-wildcard-matcher pattern posn)
  118.          (let ((prefix (substring pattern 0 posn)))
  119.            (let loop ((segments (list (substring pattern
  120.                              (1+ posn)
  121.                              posn*)))
  122.                   (posn posn*))
  123.              (let* ((start (1+ posn))
  124.                 (posn*
  125.                  (substring-find-next-char pattern start len #\*)))
  126.                (if (not posn*)
  127.                (full-wildcard-matcher
  128.                 prefix
  129.                 (list-transform-negative (reverse! segments)
  130.                   string-null?)
  131.                 (substring pattern start len))
  132.                (loop (cons (substring pattern start posn*)
  133.                        segments)
  134.                  posn*)))))))))
  135.     (else
  136.      (lambda (instance)
  137.        (equal? pattern instance)))))
  138.  
  139. (define (simple-wildcard-matcher pattern posn)
  140.   (let* ((len (string-length pattern))
  141.      (min-len (-1+ len)))
  142.     (cond ((zero? min-len)
  143.        ;; e.g. "*"
  144.        (lambda (instance)
  145.          instance            ; ignored
  146.          true))
  147.       ((zero? posn)
  148.        ;; e.g. "*foo"
  149.        (lambda (instance)
  150.          (and (string? instance)
  151.           (let ((len* (string-length instance)))
  152.             (and (>= len* min-len)
  153.              (substring=? pattern 1 len
  154.                       instance (- len* min-len) len*))))))
  155.       ((= posn (-1+ len))
  156.        ;; e.g. "bar*"
  157.        (lambda (instance)
  158.          (and (string? instance)
  159.           (let ((len* (string-length instance)))
  160.             (and (>= len* min-len)
  161.              (substring=? pattern 0 min-len
  162.                       instance 0 min-len))))))
  163.       (else
  164.        ;; e.g. "foo*bar"
  165.        (let* ((suffix-start (1+ posn))
  166.           (suffix-len (- len suffix-start)))
  167.          (lambda (instance)
  168.            (and (string? instance)
  169.             (let ((len* (string-length instance)))
  170.               (and (>= len* min-len)
  171.                (substring=? pattern 0 posn
  172.                     instance 0 posn)
  173.                (substring=? pattern suffix-start len
  174.                     instance (- len* suffix-len)
  175.                     len*))))))))))
  176.  
  177. (define (full-wildcard-matcher prefix segments suffix)
  178.   (cond ((null? segments)
  179.      ;; Degenerate case, e.g. "prefix**suffix"
  180.      (simple-wildcard-matcher (string-append prefix "*" suffix)
  181.                   (string-length prefix)))
  182.     #|
  183.     ((null? (cdr segments))
  184.      ;; Special case the single middle segment.
  185.      ;; Disabled because it is hardly worth it.
  186.      (let ((prelen (string-length prefix))
  187.            (suflen (string-length suffix)))
  188.        (let* ((middle (car segments))
  189.           (midlen (string-length middle))
  190.           (totlen (+ prelen midlen suflen)))
  191.          (cond ((string-null? prefix)
  192.             (if (string-null? suffix)
  193.             ;; e.g. "*middle*"
  194.             (lambda (instance)
  195.               (and (string? instance)
  196.                    (let ((len (string-length instance)))
  197.                  (and (>= len totlen)
  198.                       (substring? middle instance)))))
  199.             ;; e.g. "*middle*suffix"
  200.             (lambda (instance)
  201.               (and (string? instance)
  202.                    (let ((len (string-length instance)))
  203.                  (and (>= len totlen)
  204.                       (let ((end (- len suflen)))
  205.                     (and (substring=? suffix 0 suflen
  206.                               instance end len)
  207.                          (substring?
  208.                           middle
  209.                           (substring instance 0
  210.                              end))))))))))
  211.            ((string-null? suffix)
  212.             ;; e.g. "prefix*middle*"
  213.             (lambda (instance)
  214.               (and (string? instance)
  215.                (let ((len (string-length instance)))
  216.                  (and (>= len totlen)
  217.                   (substring=? prefix 0 prelen
  218.                            instance 0 prelen)
  219.                   (substring? middle
  220.                           (substring instance prelen
  221.                              len)))))))
  222.            (else
  223.             ;; e.g. "prefix*middle*suffix"
  224.             (lambda (instance)
  225.               (and (string? instance)
  226.                (let ((len (string-length instance)))
  227.                  (and (>= len totlen)
  228.                   (let ((end (- len suflen)))
  229.                     (substring=? prefix 0 prelen
  230.                          instance 0 prelen)
  231.                     (substring=? suffix 0 suflen
  232.                          instance end len)
  233.                     (substring? middle
  234.                         (substring instance prelen
  235.                                end))))))))))))
  236.     |#
  237.  
  238.     ((and (null? (cdr segments))
  239.           (string-null? prefix)
  240.           (string-null? suffix))
  241.      ;; Special case "*foo*"
  242.      (let* ((middle (car segments))
  243.         (totlen (string-length middle)))
  244.        (lambda (instance)
  245.          (and (string? instance)
  246.           (>= (string-length instance) totlen)
  247.           (substring? middle instance)))))       
  248.  
  249.     (else
  250.      (let* ((prelen (string-length prefix))
  251.         (suflen (string-length suffix))
  252.         (totlen (+ prelen
  253.                (reduce + 0 (map string-length segments))
  254.                suflen)))
  255.  
  256.        (define (segment-matcher segments)
  257.          ;; This handles the "*foo*bar*baz*" part
  258.          (let ((segment (car segments))
  259.            (rest (cdr segments)))
  260.            (if (null? rest)
  261.            (lambda (instance)
  262.              (substring? segment instance))
  263.            (let ((next (segment-matcher rest))
  264.              (len (string-length segment)))
  265.              (lambda (instance)
  266.                (let ((posn (string-search-forward segment instance)))
  267.              (and posn
  268.                   (next
  269.                    (substring instance (+ posn len)
  270.                       (string-length instance))))))))))
  271.  
  272.        (let ((tester (segment-matcher segments)))
  273.          (cond ((string-null? prefix)
  274.             (if (string-null? suffix)
  275.             ;; e.g. "*foo*bar*"
  276.             (lambda (instance)
  277.               (and (string? instance)
  278.                    (>= (string-length instance) totlen)
  279.                    (tester instance)))
  280.             ;; e.g. "*foo*bar*suffix"
  281.             (lambda (instance)
  282.               (and (string? instance)
  283.                    (let ((len (string-length instance)))
  284.                  (and (>= len totlen)
  285.                       (let ((end (- len suflen)))
  286.                     (and (substring=? suffix 0 suflen
  287.                               instance end len)
  288.                          (tester (substring instance 0
  289.                                 end))))))))))
  290.  
  291.          ((string-null? suffix)
  292.           ;; e.g. "prefix*foo*bar*"
  293.           (lambda (instance)
  294.             (and (string? instance)
  295.              (let ((len (string-length instance)))
  296.                (and (>= len totlen)
  297.                 (substring=? prefix 0 prelen
  298.                          instance 0 prelen)
  299.                 (tester (substring instance prelen len)))))))
  300.  
  301.          (else
  302.           ;; e.g. "prefix*foo*bar*suffix"
  303.           (lambda (instance)
  304.             (and (string? instance)
  305.              (let ((len (string-length instance)))
  306.                (and (>= len totlen)
  307.                 (let ((end (- len suflen)))
  308.                   (and (substring=? prefix 0 prelen
  309.                             instance 0 prelen)
  310.                        (substring=? suffix 0 suflen
  311.                             instance end len)
  312.                        (tester (substring instance prelen
  313.                               end)))))))))))))))