From e5425ed950d06f8e75697b7e8562f71704094453 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 Mar 2018 22:25:54 +0100 Subject: import: elpa: Adjust test for HTTPS URLs. This is a followup to 44dd3d579db3aa467e41d0b431029e46cae8e12d. * tests/elpa.scm (eval-test-with-elpa): Use https. --- tests/elpa.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/elpa.scm b/tests/elpa.scm index 46c6ac2d75..e6d53c892e 100644 --- a/tests/elpa.scm +++ b/tests/elpa.scm @@ -89,7 +89,7 @@ information about package NAME. (Function 'elpa-package-info'.)" ('origin ('method 'url-fetch) ('uri ('string-append - "http://elpa.gnu.org/packages/auctex-" 'version ".tar")) + "https://elpa.gnu.org/packages/auctex-" 'version ".tar")) ('sha256 ('base32 (? string? hash))))) ('build-system 'emacs-build-system) ('home-page "http://www.gnu.org/software/auctex/") -- cgit v1.2.3 From 17cdd3d0fe1987d0272f2c3496123be1ef772d6b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 Mar 2018 22:33:41 +0100 Subject: tests: elpa: Don't actually download files. * tests/elpa.scm (eval-test-with-elpa): Mock 'url-fetch'. --- tests/elpa.scm | 43 +++++++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 18 deletions(-) (limited to 'tests') diff --git a/tests/elpa.scm b/tests/elpa.scm index e6d53c892e..44e3914f2e 100644 --- a/tests/elpa.scm +++ b/tests/elpa.scm @@ -81,24 +81,31 @@ information about package NAME. (Function 'elpa-package-info'.)" auctex-readme-mock url))) (_ #f))))) - (match (elpa->guix-package pkg) - (('package - ('name "emacs-auctex") - ('version "11.88.6") - ('source - ('origin - ('method 'url-fetch) - ('uri ('string-append - "https://elpa.gnu.org/packages/auctex-" 'version ".tar")) - ('sha256 ('base32 (? string? hash))))) - ('build-system 'emacs-build-system) - ('home-page "http://www.gnu.org/software/auctex/") - ('synopsis "Integrated environment for *TeX*") - ('description (? string?)) - ('license 'license:gpl3+)) - #t) - (x - (pk 'fail x #f))))) + (mock + ((guix build download) url-fetch + (lambda (url file . _) + (call-with-output-file file + (lambda (port) + (display "fake tarball" port))))) + + (match (elpa->guix-package pkg) + (('package + ('name "emacs-auctex") + ('version "11.88.6") + ('source + ('origin + ('method 'url-fetch) + ('uri ('string-append + "https://elpa.gnu.org/packages/auctex-" 'version ".tar")) + ('sha256 ('base32 (? string? hash))))) + ('build-system 'emacs-build-system) + ('home-page "http://www.gnu.org/software/auctex/") + ('synopsis "Integrated environment for *TeX*") + ('description (? string?)) + ('license 'license:gpl3+)) + #t) + (x + (pk 'fail x #f)))))) (test-assert "elpa->guix-package test 1" (eval-test-with-elpa "auctex")) -- cgit v1.2.3 From e914b398af11f909e88a8bc85eeebb0768aacd54 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 Mar 2018 23:35:07 +0100 Subject: glob: Support square brackets in patterns. * guix/glob.scm (wildcard-indices): Remove. (parse-bracket): New procedure. (compile-glob-pattern): Rewrite. Support square brackets for sets and ranges. (glob-match?): Support sets and ranges. * tests/glob.scm (test-compile-glob-pattern) (test-glob-match): New macros. Use them to rewrite the existing tests, and add new tests. --- guix/glob.scm | 95 ++++++++++++++++++++++++++++++++++++---------------------- tests/glob.scm | 67 ++++++++++++++++++++++++----------------- 2 files changed, 99 insertions(+), 63 deletions(-) (limited to 'tests') diff --git a/guix/glob.scm b/guix/glob.scm index 4fc5173ac0..29c335ca1d 100644 --- a/guix/glob.scm +++ b/guix/glob.scm @@ -25,20 +25,17 @@ ;;; ;;; This is a minimal implementation of "glob patterns" (info "(libc) ;;; Globbbing"). It is currently limited to simple patterns and does not -;;; support braces and square brackets, for instance. +;;; support braces, for instance. ;;; ;;; Code: -(define (wildcard-indices str) - "Return the list of indices in STR where wildcards can be found." - (let loop ((index 0) - (result '())) - (if (= index (string-length str)) - (reverse result) - (loop (+ 1 index) - (case (string-ref str index) - ((#\? #\*) (cons index result)) - (else result)))))) +(define (parse-bracket chars) + "Parse CHARS, a list of characters that extracted from a '[...]' sequence." + (match chars + ((start #\- end) + `(range ,start ,end)) + (lst + `(set ,@lst)))) (define (compile-glob-pattern str) "Return an sexp that represents the compiled form of STR, a glob pattern @@ -48,29 +45,43 @@ such as \"foo*\" or \"foo??bar\"." (((? string? str)) str) (x x))) - (let loop ((index 0) - (indices (wildcard-indices str)) + (define (cons-string chars lst) + (match chars + (() lst) + (_ (cons (list->string (reverse chars)) lst)))) + + (let loop ((chars (string->list str)) + (pending '()) + (brackets 0) (result '())) - (match indices + (match chars (() - (flatten (cond ((zero? index) - (list str)) - ((= index (string-length str)) - (reverse result)) - (else - (reverse (cons (string-drop str index) - result)))))) - ((wildcard-index . rest) - (let ((wildcard (match (string-ref str wildcard-index) + (flatten (reverse (if (null? pending) + result + (cons-string pending result))))) + (((and chr (or #\? #\*)) . rest) + (let ((wildcard (match chr (#\? '?) (#\* '*)))) - (match (substring str index wildcard-index) - ("" (loop (+ 1 wildcard-index) - rest - (cons wildcard result))) - (str (loop (+ 1 wildcard-index) - rest - (cons* wildcard str result))))))))) + (if (zero? brackets) + (loop rest '() 0 + (cons* wildcard (cons-string pending result))) + (loop rest (cons chr pending) brackets result)))) + ((#\[ . rest) + (if (zero? brackets) + (loop rest '() (+ 1 brackets) + (cons-string pending result)) + (loop rest (cons #\[ pending) (+ 1 brackets) result))) + ((#\] . rest) + (cond ((zero? brackets) + (error "unexpected closing bracket" str)) + ((= 1 brackets) + (loop rest '() 0 + (cons (parse-bracket (reverse pending)) result))) + (else + (loop rest (cons #\] pending) (- brackets 1) result)))) + ((chr . rest) + (loop rest (cons chr pending) brackets result))))) (define (glob-match? pattern str) "Return true if STR matches PATTERN, a compiled glob pattern as returned by @@ -78,11 +89,12 @@ such as \"foo*\" or \"foo??bar\"." (let loop ((pattern pattern) (str str)) (match pattern - ((? string? literal) (string=? literal str)) - (((? string? one)) (string=? one str)) - (('*) #t) - (('?) (= 1 (string-length str))) - (() #t) + ((? string? literal) + (string=? literal str)) + (() + (string-null? str)) + (('*) + #t) (('* suffix . rest) (match (string-contains str suffix) (#f #f) @@ -92,6 +104,19 @@ such as \"foo*\" or \"foo??bar\"." (('? . rest) (and (>= (string-length str) 1) (loop rest (string-drop str 1)))) + ((('range start end) . rest) + (and (>= (string-length str) 1) + (let ((chr (string-ref str 0))) + (and (char-set-contains? (ucs-range->char-set + (char->integer start) + (+ 1 (char->integer end))) + chr) + (loop rest (string-drop str 1)))))) + ((('set . chars) . rest) + (and (>= (string-length str) 1) + (let ((chr (string-ref str 0))) + (and (char-set-contains? (list->char-set chars) chr) + (loop rest (string-drop str 1)))))) ((prefix . rest) (and (string-prefix? prefix str) (loop rest (string-drop str (string-length prefix)))))))) diff --git a/tests/glob.scm b/tests/glob.scm index 033eeb10fe..71e2d3fce0 100644 --- a/tests/glob.scm +++ b/tests/glob.scm @@ -23,36 +23,47 @@ (test-begin "glob") -(test-equal "compile-glob-pattern, no wildcards" - "foo" - (compile-glob-pattern "foo")) +(define-syntax test-compile-glob-pattern + (syntax-rules (=>) + ((_ pattern => result rest ...) + (begin + (test-equal (format #f "compile-glob-pattern, ~s" pattern) + result + (compile-glob-pattern pattern)) + (test-compile-glob-pattern rest ...))) + ((_) + #t))) -(test-equal "compile-glob-pattern, Kleene star" - '("foo" * "bar") - (compile-glob-pattern "foo*bar")) +(define-syntax test-glob-match + (syntax-rules (matches and not) + ((_ (pattern-string matches strings ... (and not others ...)) rest ...) + (begin + (test-assert (format #f "glob-match? ~s" pattern-string) + (let ((pattern (compile-glob-pattern pattern-string))) + (and (glob-match? pattern strings) ... + (not (glob-match? pattern others)) ...))) + (test-glob-match rest ...))) + ((_) + #t))) -(test-equal "compile-glob-pattern, question mark" - '(? "foo" *) - (compile-glob-pattern "?foo*")) +(test-compile-glob-pattern + "foo" => "foo" + "?foo*" => '(? "foo" *) + "foo[1-5]" => '("foo" (range #\1 #\5)) + "foo[abc]bar" => '("foo" (set #\a #\b #\c) "bar") + "foo[a[b]c]bar" => '("foo" (set #\a #\[ #\b #\] #\c) "bar") + "[123]x" => '((set #\1 #\2 #\3) "x") + "[a-z]" => '((range #\a #\z))) -(test-assert "literal match" - (let ((pattern (compile-glob-pattern "foo"))) - (and (glob-match? pattern "foo") - (not (glob-match? pattern "foobar")) - (not (glob-match? pattern "barfoo"))))) - -(test-assert "trailing star" - (let ((pattern (compile-glob-pattern "foo*"))) - (and (glob-match? pattern "foo") - (glob-match? pattern "foobar") - (not (glob-match? pattern "xfoo"))))) - -(test-assert "question marks" - (let ((pattern (compile-glob-pattern "foo??bar"))) - (and (glob-match? pattern "fooxxbar") - (glob-match? pattern "fooZZbar") - (not (glob-match? pattern "foobar")) - (not (glob-match? pattern "fooxxxbar")) - (not (glob-match? pattern "fooxxbarzz"))))) +(test-glob-match + ("foo" matches "foo" (and not "foobar" "barfoo")) + ("foo*" matches "foo" "foobar" (and not "xfoo")) + ("foo??bar" matches "fooxxbar" "fooZZbar" + (and not "foobar" "fooxxxbar" "fooxxbarzz")) + ("foo?" matches "foox" (and not "fooxx")) + ("ab[0-9]c" matches "ab0c" "ab7c" "ab9c" + (and not "ab-c" "ab00c" "ab3")) + ("ab[cdefg]" matches "abc" "abd" "abg" + (and not "abh" "abcd" "ab["))) (test-end "glob") -- cgit v1.2.3 From 71e08fde28fa335bdba2ec2150fd6663390bba5a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 Mar 2018 22:54:34 +0100 Subject: glob: Add an extra glob pattern compilation stage. * guix/glob.scm (compile-glob-pattern): Rename to... (string->sglob): ... this. (compile-sglob, string->compiled-sglob): New procedures. (glob-match?): Replace '?, 'range, and 'set with a single clause. * tests/glob.scm (test-compile-glob-pattern): Rename to... (test-string->sglob): ... this. Adjust accordingly. (test-glob-match): Use 'string->compiled-sglob' instead of 'compile-glob-pattern'. * gnu/build/linux-modules.scm (read-module-aliases): Use 'string->compiled-sglob' instead of 'compile-glob-pattern'. --- gnu/build/linux-modules.scm | 4 ++-- guix/glob.scm | 51 +++++++++++++++++++++++++++++---------------- tests/glob.scm | 12 +++++------ 3 files changed, 41 insertions(+), 26 deletions(-) (limited to 'tests') diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index e97c9c95f1..87d2e98edf 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -329,7 +329,7 @@ The modules corresponding to these aliases can then be found using list of alias/module pairs where each alias is a glob pattern as like the result of: - (compile-glob-pattern \"scsi:t-0x01*\") + (string->compiled-sglob \"scsi:t-0x01*\") and each module is a module name like \"snd_hda_intel\"." (define (comment? str) @@ -354,7 +354,7 @@ and each module is a module name like \"snd_hda_intel\"." (line (match (tokenize line) (("alias" alias module) - (loop (alist-cons (compile-glob-pattern alias) module + (loop (alist-cons (string->compiled-sglob alias) module aliases))) (() ;empty line (loop aliases))))))) diff --git a/guix/glob.scm b/guix/glob.scm index 29c335ca1d..a9fc744802 100644 --- a/guix/glob.scm +++ b/guix/glob.scm @@ -18,7 +18,9 @@ (define-module (guix glob) #:use-module (ice-9 match) - #:export (compile-glob-pattern + #:export (string->sglob + compile-sglob + string->compiled-sglob glob-match?)) ;;; Commentary: @@ -37,9 +39,9 @@ (lst `(set ,@lst)))) -(define (compile-glob-pattern str) - "Return an sexp that represents the compiled form of STR, a glob pattern -such as \"foo*\" or \"foo??bar\"." +(define (string->sglob str) + "Return an sexp, called an \"sglob\", that represents the compiled form of +STR, a glob pattern such as \"foo*\" or \"foo??bar\"." (define flatten (match-lambda (((? string? str)) str) @@ -83,9 +85,33 @@ such as \"foo*\" or \"foo??bar\"." ((chr . rest) (loop rest (cons chr pending) brackets result))))) +(define (compile-sglob sglob) + "Compile SGLOB into a more efficient representation." + (if (string? sglob) + sglob + (let loop ((sglob sglob) + (result '())) + (match sglob + (() + (reverse result)) + (('? . rest) + (loop rest (cons char-set:full result))) + ((('range start end) . rest) + (loop rest (cons (ucs-range->char-set + (char->integer start) + (+ 1 (char->integer end))) + result))) + ((('set . chars) . rest) + (loop rest (cons (list->char-set chars) result))) + ((head . rest) + (loop rest (cons head result))))))) + +(define string->compiled-sglob + (compose compile-sglob string->sglob)) + (define (glob-match? pattern str) "Return true if STR matches PATTERN, a compiled glob pattern as returned by -'compile-glob-pattern'." +'compile-sglob'." (let loop ((pattern pattern) (str str)) (match pattern @@ -101,21 +127,10 @@ such as \"foo*\" or \"foo??bar\"." (index (loop rest (string-drop str (+ index (string-length suffix))))))) - (('? . rest) - (and (>= (string-length str) 1) - (loop rest (string-drop str 1)))) - ((('range start end) . rest) - (and (>= (string-length str) 1) - (let ((chr (string-ref str 0))) - (and (char-set-contains? (ucs-range->char-set - (char->integer start) - (+ 1 (char->integer end))) - chr) - (loop rest (string-drop str 1)))))) - ((('set . chars) . rest) + (((? char-set? cs) . rest) (and (>= (string-length str) 1) (let ((chr (string-ref str 0))) - (and (char-set-contains? (list->char-set chars) chr) + (and (char-set-contains? cs chr) (loop rest (string-drop str 1)))))) ((prefix . rest) (and (string-prefix? prefix str) diff --git a/tests/glob.scm b/tests/glob.scm index 71e2d3fce0..3134069789 100644 --- a/tests/glob.scm +++ b/tests/glob.scm @@ -23,14 +23,14 @@ (test-begin "glob") -(define-syntax test-compile-glob-pattern +(define-syntax test-string->sglob (syntax-rules (=>) ((_ pattern => result rest ...) (begin - (test-equal (format #f "compile-glob-pattern, ~s" pattern) + (test-equal (format #f "string->sglob, ~s" pattern) result - (compile-glob-pattern pattern)) - (test-compile-glob-pattern rest ...))) + (string->sglob pattern)) + (test-string->sglob rest ...))) ((_) #t))) @@ -39,14 +39,14 @@ ((_ (pattern-string matches strings ... (and not others ...)) rest ...) (begin (test-assert (format #f "glob-match? ~s" pattern-string) - (let ((pattern (compile-glob-pattern pattern-string))) + (let ((pattern (string->compiled-sglob pattern-string))) (and (glob-match? pattern strings) ... (not (glob-match? pattern others)) ...))) (test-glob-match rest ...))) ((_) #t))) -(test-compile-glob-pattern +(test-string->sglob "foo" => "foo" "?foo*" => '(? "foo" *) "foo[1-5]" => '("foo" (range #\1 #\5)) -- cgit v1.2.3