Re: find-versioned-module bugs

[Julian Graham <joolean@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 481 bytes --]

Hey Andy,


> I don't know, all that code is tricky. How about having
> find-versioned-module return a tail instead of a full path, then pass
> that tail to primitive-load-path? It will cause some slight duplication
> of effort but it will find the .go correctly.

Sure!  Find attached an implementation of `find-versioned-module' that
does precisely that -- although it looks like we've gone in a slightly
different direction since this email was written... ;-)


Regards,
Julian

[-- Attachment #2: find-versioned-module.scm --]
[-- Type: text/x-scheme, Size: 3586 bytes --]

(define (find-versioned-module dir-hint name version-ref roots)
  (define (subdir-pair-less pair1 pair2)
    (define (numlist-less lst1 lst2)
      (or (null? lst2) 
          (and (not (null? lst1))
               (cond ((> (car lst1) (car lst2)) #t)
                     ((< (car lst1) (car lst2)) #f)
                     (else (numlist-less (cdr lst1) (cdr lst2)))))))
    (not (numlist-less (car pair2) (car pair1))))
  (define (match-version-and-file pair)
    (and (version-matches? version-ref (car pair))
         (let ((filenames                            
                (filter (lambda (file-pair)
                          (let* ((file (in-vicinity (car file-pair) 
                                                    (cdr file-pair)))
                                 (s (false-if-exception (stat file))))
                            (and s (eq? (stat:type s) 'regular))))
                        (map (lambda (ext)
                               (cons (cadr pair)
                                     (in-vicinity (cddr pair) 
                                                  (string-append name ext))))
                             %load-extensions))))
           (and (not (null? filenames))
                (cons (car pair) (car filenames))))))
    
  (define (match-version-recursive root-pairs leaf-pairs)
    (define (filter-subdirs root-pairs ret)
      (define (filter-subdir root-pair dstrm subdir-pairs)
        (let ((entry (readdir dstrm)))
          (if (eof-object? entry)
              subdir-pairs
              (let* ((subdir (in-vicinity (cddr root-pair) entry))
                     (dir (in-vicinity (cadr root-pair) subdir))
                     (num (string->number entry))
                     (num (and num (exact? num) 
                               (append (car root-pair) (list num)))))
                (if (and num (eq? (stat:type (stat dir)) 'directory))
                    (filter-subdir root-pair dstrm 
                                   (cons (cons num (cons (cadr root-pair) 
                                                         subdir))
                                         subdir-pairs))
                    (filter-subdir root-pair dstrm subdir-pairs))))))
      
      (or (and (null? root-pairs) ret)
          (let* ((rp (car root-pairs))
                 (dir (in-vicinity (cadr rp) (cddr rp)))
                 (dstrm (false-if-exception (opendir dir))))
            (if dstrm
                (let ((subdir-pairs (filter-subdir rp dstrm '())))
                  (closedir dstrm)
                  (filter-subdirs (cdr root-pairs) 
                                  (or (and (null? subdir-pairs) ret)
                                      (append ret subdir-pairs))))
                (filter-subdirs (cdr root-pairs) ret)))))
    
    (or (and (null? root-pairs) leaf-pairs)
        (let ((matching-subdir-pairs (filter-subdirs root-pairs '())))
          (match-version-recursive
           matching-subdir-pairs
           (append leaf-pairs (filter pair? (map match-version-and-file 
                                                 matching-subdir-pairs)))))))

  (define (make-root-pair root) (cons '() (cons root dir-hint)))

  (let* ((root-pairs (map make-root-pair roots))
         (matches (if (null? version-ref) 
                      (filter pair? (map match-version-and-file root-pairs))
                      '()))
         (matches (append matches (match-version-recursive root-pairs '()))))
    (and (null? matches) (error "No matching modules found."))
    (cddar (sort matches subdir-pair-less))))