chicken-hackers
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Chicken-hackers] [PATCH] Rework "glob->regexp" into "glob->sre" and add


From: Evan Hanson
Subject: [Chicken-hackers] [PATCH] Rework "glob->regexp" into "glob->sre" and add to irregex exports
Date: Sun, 2 Jul 2017 12:22:37 +1200

This was previously an internal procedure used variously within core,
but it's useful enough to promote to an official API. So, simplify its
interface (making it always return an SRE) and add it to the irregex
library's exports.
---
 NEWS                  |  1 +
 chicken-status.scm    |  3 +-
 chicken-uninstall.scm |  3 +-
 file.scm              |  2 +-
 irregex.scm           | 84 +++++++++++++++++++++++++--------------------------
 tests/test-glob.scm   | 30 +++++++++---------
 types.db              |  1 +
 7 files changed, 61 insertions(+), 63 deletions(-)

diff --git a/NEWS b/NEWS
index f4b0e041..5db0be65 100644
--- a/NEWS
+++ b/NEWS
@@ -47,6 +47,7 @@
   - Keywords are now always written in "portable" style by WRITE, so
     that the reader's keyword style doesn't need to match the writer's.
   - The environment variable `CHICKEN_PREFIX` has been removed.
+  - Added the `glob->sre` procedure to the irregex library.
 
 - Module system
   - The compiler has been modularised, for improved namespacing.  This
diff --git a/chicken-status.scm b/chicken-status.scm
index 32f6b09c..f1049687 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -69,8 +69,7 @@
                         (mtch
                          (concatenate
                            (map (lambda (pat)
-                                  (grep (irregex (##sys#glob->regexp pat))
-                                        eggs))
+                                  (grep (irregex (glob->sre pat)) eggs))
                              patterns)))
                         (else 
                           (filter 
diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm
index af617d5a..9b40a3bd 100644
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@ -62,8 +62,7 @@
          (pats (if mtch
                    (concatenate 
                      (map (lambda (pat)
-                            (grep (irregex (##sys#glob->regexp pat))
-                                  eggs))
+                            (grep (irregex (glob->sre pat)) eggs))
                        patterns))
                    (filter 
                      (lambda (egg)
diff --git a/file.scm b/file.scm
index cd0f6012..87579d45 100644
--- a/file.scm
+++ b/file.scm
@@ -267,7 +267,7 @@ EOF
          '()
          (let ((path (car paths)))
            (let-values (((dir fil ext) (decompose-pathname path)))
-             (let ((rx (##sys#glob->regexp (make-pathname #f (or fil "*") 
ext))))
+             (let ((rx (irregex (glob->sre (make-pathname #f (or fil "*") 
ext)))))
                (let loop ((fns (directory (or dir ".") #t)))
                  (cond ((null? fns) (conc-loop (cdr paths)))
                        ((irregex-match rx (car fns)) =>
diff --git a/irregex.scm b/irregex.scm
index b215240b..4959092c 100644
--- a/irregex.scm
+++ b/irregex.scm
@@ -56,7 +56,7 @@
      irregex-match-subchunk
 
      ;; Utilities
-     sre->string irregex-opt irregex-quote)
+     glob->sre sre->string irregex-opt irregex-quote)
 
 (import scheme
        chicken
@@ -220,49 +220,47 @@
 (include "irregex-core.scm")
 (include "irregex-utils.scm")
 
-(define ##sys#glob->regexp
+(define glob->sre
   (let ((list->string list->string)
         (string->list string->list))
-    (lambda (s #!optional sre?)
-      (##sys#check-string s 'glob->regexp)
-      (let ((sre
-            (cons 
-             ':
-             (let loop ((cs (string->list s)) (dir #t))
-               (if (null? cs)
-                   '()
-                   (let ((c (car cs))
-                         (rest (cdr cs)) )
-                     (cond ((char=? c #\*) 
-                            (if dir
-                                `((or (: (~ ("./\\"))
-                                         (* (~ ("/\\"))))
-                                      (* (~ ("./\\"))))
-                                  ,@(loop rest #f))
-                                `((* (~ ("/\\"))) ,@(loop rest #f))))
-                           ((char=? c #\?)  (cons 'any (loop rest #f)))
-                           ((char=? c #\[)
-                            (let loop2 ((rest rest) (s '()))
-                              (cond ((not (pair? rest))
-                                     (error 'glob->regexp
-                                            "unexpected end of character 
class" s))
-                                    ((char=? #\] (car rest))
-                                     `(,(if (> (length s) 1)
-                                            `(or ,@s) 
-                                            (car s))
-                                       ,@(loop (cdr rest) #f)))
-                                    ((and (pair? (cdr rest))
-                                          (pair? (cddr rest))
-                                          (char=? #\- (cadr rest)) )
-                                     (loop2 (cdddr rest)
-                                            (cons `(/ ,(car rest) ,(caddr 
rest)) s)))
-                                    ((and (pair? (cdr rest))
-                                          (char=? #\- (car rest)))
-                                     (loop2 (cddr rest)
-                                            (cons `(~ ,(cadr rest)) s)))
-                                    (else
-                                     (loop2 (cdr rest) (cons (car rest) s))))))
-                           (else (cons c (loop rest (memq c '(#\\ 
#\/))))))))))))
-       (if sre? sre (irregex sre))))))
+    (lambda (s)
+      (##sys#check-string s 'glob->sre)
+      (cons
+       ':
+       (let loop ((cs (string->list s)) (dir #t))
+        (if (null? cs)
+            '()
+            (let ((c (car cs))
+                  (rest (cdr cs)) )
+              (cond ((char=? c #\*)
+                     (if dir
+                         `((or (: (~ ("./\\"))
+                                  (* (~ ("/\\"))))
+                               (* (~ ("./\\"))))
+                           ,@(loop rest #f))
+                         `((* (~ ("/\\"))) ,@(loop rest #f))))
+                    ((char=? c #\?)  (cons 'any (loop rest #f)))
+                    ((char=? c #\[)
+                     (let loop2 ((rest rest) (s '()))
+                       (cond ((not (pair? rest))
+                              (error 'glob->sre
+                                     "unexpected end of character class" s))
+                             ((char=? #\] (car rest))
+                              `(,(if (> (length s) 1)
+                                     `(or ,@s)
+                                     (car s))
+                                ,@(loop (cdr rest) #f)))
+                             ((and (pair? (cdr rest))
+                                   (pair? (cddr rest))
+                                   (char=? #\- (cadr rest)) )
+                              (loop2 (cdddr rest)
+                                     (cons `(/ ,(car rest) ,(caddr rest)) s)))
+                             ((and (pair? (cdr rest))
+                                   (char=? #\- (car rest)))
+                              (loop2 (cddr rest)
+                                     (cons `(~ ,(cadr rest)) s)))
+                             (else
+                              (loop2 (cdr rest) (cons (car rest) s))))))
+                    (else (cons c (loop rest (memq c '(#\\ #\/)))))))))))))
 
 )
diff --git a/tests/test-glob.scm b/tests/test-glob.scm
index 91fc3d64..62ccc6fb 100644
--- a/tests/test-glob.scm
+++ b/tests/test-glob.scm
@@ -3,18 +3,18 @@
 
 (use irregex)
 
-(assert (irregex-match (##sys#glob->regexp "foo.bar") "foo.bar"))
-(assert (irregex-match (##sys#glob->regexp "foo*") "foo.bar"))
-(assert (irregex-match (##sys#glob->regexp "foo/*") "foo/bar"))
-(assert (not (irregex-match (##sys#glob->regexp "foo/*") "foo/bar/baz")))
-(assert (irregex-match (##sys#glob->regexp "foo/*/*") "foo/bar/baz"))
-(assert (not (irregex-match (##sys#glob->regexp "foo/*") "foo/.bar")))
-(assert (irregex-match (##sys#glob->regexp "*foo") "xyzfoo"))
-(assert (not (irregex-match (##sys#glob->regexp "*foo") ".foo")))
-(assert (not (irregex-match (##sys#glob->regexp "*foo*") "a.fooxxx/yyy")))
-(assert (irregex-match (##sys#glob->regexp "*foo*") "fooxxx"))
-(assert (irregex-match (##sys#glob->regexp "main.[ch]") "main.c"))
-(assert (irregex-match (##sys#glob->regexp "main.[ch]") "main.h"))
-(assert (not (irregex-match (##sys#glob->regexp "main.[ch]") "main.cpp")))
-(assert (irregex-match (##sys#glob->regexp "main.[-c]") "main.h"))
-(assert (not (irregex-match (##sys#glob->regexp "main.[-h]") "main.h")))
+(assert (irregex-match (glob->sre "foo.bar") "foo.bar"))
+(assert (irregex-match (glob->sre "foo*") "foo.bar"))
+(assert (irregex-match (glob->sre "foo/*") "foo/bar"))
+(assert (not (irregex-match (glob->sre "foo/*") "foo/bar/baz")))
+(assert (irregex-match (glob->sre "foo/*/*") "foo/bar/baz"))
+(assert (not (irregex-match (glob->sre "foo/*") "foo/.bar")))
+(assert (irregex-match (glob->sre "*foo") "xyzfoo"))
+(assert (not (irregex-match (glob->sre "*foo") ".foo")))
+(assert (not (irregex-match (glob->sre "*foo*") "a.fooxxx/yyy")))
+(assert (irregex-match (glob->sre "*foo*") "fooxxx"))
+(assert (irregex-match (glob->sre "main.[ch]") "main.c"))
+(assert (irregex-match (glob->sre "main.[ch]") "main.h"))
+(assert (not (irregex-match (glob->sre "main.[ch]") "main.cpp")))
+(assert (irregex-match (glob->sre "main.[-c]") "main.h"))
+(assert (not (irregex-match (glob->sre "main.[-h]") "main.h")))
diff --git a/types.db b/types.db
index 0b3077e6..5b1eaf14 100644
--- a/types.db
+++ b/types.db
@@ -1730,6 +1730,7 @@
 (chicken.irregex#sre->irregex (#(procedure #:clean) 
chicken.irregex#sre->irregex (#!rest) *))
 (chicken.irregex#string->irregex (#(procedure #:clean #:enforce) 
chicken.irregex#string->irregex (string #!rest) *))
 (chicken.irregex#string->sre (#(procedure #:clean #:enforce) 
chicken.irregex#string->sre (string #!rest) *))
+(chicken.irregex#glob->sre (#(procedure #:clean #:enforce) 
chicken.irregex#glob->sre (string) (pair symbol *)))
 
 
 ;; memory
-- 
2.11.0




reply via email to

[Prev in Thread] Current Thread [Next in Thread]