~ chicken-core (chicken-5) 09740e031622a6dc7952753569c4acb32c641874
commit 09740e031622a6dc7952753569c4acb32c641874
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sun Jul 2 12:22:37 2017 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Jul 2 19:21:34 2017 +0200
Rework "glob->regexp" into "glob->sre" and add to irregex exports
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.
Signed-off-by: Peter Bex <peter@more-magic.net>
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
Trap