diff --git a/src/mime/fnmatch.scm b/src/mime/fnmatch.scm new file mode 100644 index 0000000..dd38f8e --- /dev/null +++ b/src/mime/fnmatch.scm @@ -0,0 +1,64 @@ +;; fnmatch C library function via FFI +;; +;; Copyright (C) 2014 Mike Gerwitz +;; +;; This file is part of guile-mime. +;; +;; guile-mime is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + + + +(define-module (mime fnmatch) + #:use-module (system foreign) + #:export (fnmatch)) + + + +(define* (fnmatch pattern string + #:key (case-fold #f) + (allow-error #f)) + "Check whether @var{string} matches the shell wildcard pattern +@var{pattern}. This is a wrapper around the C function `fnmatch'; see +fnmatch(3) for more information. + +The key @var{case-fold} is equivalent to the C flag +@var{FNM_CASEFOLD}: it will perform a case-insensitive match. The +default behavior is to perform no case folding. + +POSIX does not define any conditions under which `fnmatch' may fail, +and glibc guarantees that an error condition will not occur. The +default behavior of this procedure is therefore to ignore any error +conditions; if you do not like this, set @var{allow-error}, which +will cause an error to be raised when the underlying `fnmatch` call +fails to return a boolean result." + (define FNM_NOMATCH 1) + (define FNM_CASEFOLD (ash 1 4)) + (define %c-fnmatch (pointer->procedure int + (dynamic-func "fnmatch" + (dynamic-link)) + (list '* '* int))) + (let* ((flags (if case-fold + FNM_CASEFOLD + 0)) + (result (%c-fnmatch (string->pointer pattern) + (string->pointer string) + flags))) + (cond + ((= result 0) + #t) + ((or (= result FNM_NOMATCH) + (eq? #f allow-error)) + #f) + (else + (error "fnmatch errno " result))))) diff --git a/test/mime/fnmatch.scm b/test/mime/fnmatch.scm new file mode 100644 index 0000000..3c1da16 --- /dev/null +++ b/test/mime/fnmatch.scm @@ -0,0 +1,56 @@ +;; Test case for fnmatch module +;; +;; Copyright (C) 2014 Mike Gerwitz +;; +;; This file is part of guile-mime. +;; +;; guile-mime is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . +;; +;; TODO: We should provide stronger assurances, as this does not +;; prevent a bogus implementation. + + + +(define-module (test mime fnmatch) + #:use-module (srfi srfi-64) + #:use-module (mime fnmatch)) + + + +(test-group + "(mime fnmatch)" + + (test-group + "fnmatch procedure" + + (test-eq "returns #t when input matches pattern" + #t + (fnmatch "foo*" "foobar")) + + (test-eq "returns #f when input does not match pattern" + #f + (fnmatch "foo*" "frobnoz")) + + ;; note that we do not test for errors, because POSIX does not + ;; define any such conditions, and glibc will never return an error + + (test-group + "pattern case" + + (test-eq "is not folded by default" + #f + (fnmatch "foo" "Foo")) + (test-eq "is folded with #:case-fold" + #t + (fnmatch "foo" "Foo" #:case-fold #t)))))