[plt-scheme] patch to escape R6RS library names [was: SXML for R6RS]

On Thu, 2008-07-03 at 07:47 -0600, Matthew Flatt wrote:
> At Thu, 03 Jul 2008 03:43:02 -0700, Derick Eddington wrote:
> > I've been meaning to bring this up and ask: would it be possible for PLT
> > to support any symbols for library names?  Ikarus currently does it by
> > encoding filename-unfriendly characters like * to %2A.  I'd be willing
> > to make a patch to do this if it's not a dead end.
> 
> That would be great.

OK, here's my patch, below and attached.  Comments:

I made it escape all characters that are not valid for a PLT Scheme
unquoted module path component because that seemed the most
conservative.

I made the %-escape encoding have a terminating delimiter of the ;
character so that library names like (foo \x3BB;) and (foo \x3B;B) do
not resolve to the same filename.

Because the (lib rel-string) require form does not allow the % nor ;
characters in the rel-string, I changed `convert-library-reference' to
use the (file string) require form and changed `parse-library-reference'
to return a platform-specific absolute path string.

In addition to it working for importing my and-let* library, allowing
sxml-tools to now completely work, I tried this:

> (parse-library-reference #'(횉훒 훕홏횁 (1 2 3)) error)
"/home/d/.plt-scheme/4.0.1.3/collects/%D689;%D6D2;/%D6D5;%D64F;%D681;-1-2-3.mzscheme.sls"
> 

$ ls .plt-scheme/4.0.1.3/collects/%D689\;%D6D2\;/
%D6D5;%D64F;%D681;-1-2-3.mzscheme.sls
use-it.ss
$ cat .plt-scheme/4.0.1.3/collects/%D689\;%D6D2\;/%D6D5\;%D64F\;%D681\;-1-2-3.mzscheme.sls 
#!r6rs
(library (횉훒 훕홏횁 (1 2 3))
  (export
    x)
  (import
    (rnrs))

  (define x 'foo)
)
$ cat .plt-scheme/4.0.1.3/collects/%D689\;%D6D2\;/use-it.ss 
#!r6rs
(import
  (rnrs)
  (횉훒 훕홏횁 (1 2 3)))
  
(write x) (newline)
$ mzscheme .plt-scheme/4.0.1.3/collects/%D689\;%D6D2\;/use-it.ss 
foo
$

-- 
: Derick
----------------------------------------------------------------

======================================================================
--- plt-4.0.1.3/collects/r6rs/private/parse-ref.ss	2008-06-22 21:01:18.000000000 -0700
+++ plt-4.0.1.3/collects/r6rs/private/parse-ref.ss	2008-07-04 01:39:44.000000000 -0700
@@ -30,6 +30,24 @@
      (andmap is-sub-version-reference? (syntax->list #'(sv ...)))]
     [_ #f]))
 
+(define (escape-library-id-str str)
+  (let loop ([chars (string->list str)] [accum '()])
+    (if (null? chars)
+      (list->string (reverse accum))
+      (let ([c (car chars)])
+        (if (or (char<=? #\a c #\z)
+                (char<=? #\A c #\Z)
+                (char<=? #\0 c #\9)
+                (memv c '(#\+ #\- #\_)))
+          (loop (cdr chars) (cons c accum))
+          (loop (cdr chars)
+                (append
+                 (cons #\; (reverse 
+                            (cons #\% (string->list
+                                       (string-upcase
+                                        (number->string (char->integer c) 16))))))
+                 accum)))))))
+
 (define (parse-library-reference stx err)
   (syntax-case stx ()
     [(id1 id2 ... (vers ...))
@@ -38,34 +56,34 @@
           (is-version-reference? #'(vers ...)))
      (let-values ([(coll file)
                    (let ([strs (map (lambda (id)
-                                      (symbol->string (syntax-e id)))
+                                      (escape-library-id-str 
+                                       (symbol->string (syntax-e id))))
                                     (syntax->list #'(id1 id2 ...)))])
                      (if (= 1 (length strs))
                          (values (list (car strs)) "main")
                          (values (reverse (cdr (reverse strs)))
                                  (car (reverse strs)))))])
-       (let ([base (build-path (with-handlers ([exn:fail?
-                                                (lambda (exn)
-                                                  (err
-                                                   (format 
-                                                    "cannot find suitable library installed (exception: ~a)"
-                                                    (if (exn? exn)
-                                                        (exn-message exn)
-                                                        exn))))])
-                                 (apply collection-path coll))
-                               file)])
+       (let* ([coll-path (with-handlers ([exn:fail?
+                                          (lambda (exn)
+                                            (err
+                                             (format 
+                                              "cannot find suitable library installed (exception: ~a)"
+                                              (if (exn? exn)
+                                                (exn-message exn)
+                                                exn))))])
+                           (apply collection-path coll))]
+              [base (build-path coll-path file)])
          (let ([vers.ext (find-version (path->bytes base) (syntax->datum #'(vers ...)))])
            (if vers.ext
-               (apply string-append
-                      (car coll)
-                      (append
-                       (map (lambda (s)
-                              (string-append "/" s))
-                            (append (cdr coll) (list file)))
-                       (map (lambda (v)
-                              (format "-~a" v))
-                            (car vers.ext))
-                       (list (cdr vers.ext))))
+               (bytes->string/latin-1
+                (path->bytes
+                 (build-path coll-path (string-append
+                                        file
+                                        (apply string-append
+                                               (map (lambda (v)
+                                                      (format "-~a" v))
+                                                    (car vers.ext))) 
+                                        (cdr vers.ext)))))
                (err "cannot find suitable installed library")))))]
     [(id1 id2 ...)
      (and (identifier? #'id1)
@@ -77,7 +95,7 @@
 (define (convert-library-reference orig stx stx-err)
   (datum->syntax
    orig
-   `(,#'lib
+   `(,#'file
      ,(parse-library-reference stx
                                (lambda (msg)
                                  (stx-err msg orig stx))))
======================================================================

-------------- next part --------------
A non-text attachment was scrubbed...
Name: escape-library-identifier.patch
Type: text/x-patch
Size: 4457 bytes
Desc: not available
URL: <http://lists.racket-lang.org/users/archive/attachments/20080704/1bd24827/attachment.bin>