fnmatch C function wrapper via FFI added

The XDG Shared MIME-info Database spec states that "the format of the glob
pattern is as for fnmatch(3)".[0]  So, here it is.

[0]: http://standards.freedesktop.org/shared-mime-info-spec\
       /shared-mime-info-spec-latest.html (retrieved 17 Nov 2014).

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 <http://www.gnu.org/licenses/>.
+
+
+
+(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)))))

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 <http://www.gnu.org/licenses/>.
+;;
+;; 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)))))