From 27a6603985f0c5ce109a52368d10fbddf61b7bea Mon Sep 17 00:00:00 2001 From: Mike Gerwitz Date: Mon, 24 Nov 2014 00:38:00 -0500 Subject: [PATCH] Initial globs2 parser concept Not yet fully tested, nor is the implementation near complete; this has been sitting idle for a while so I want to make sure I commit it and get it out there. --- src/mime/xdg.scm | 27 ++++++++ src/mime/xdg/globs2.scm | 108 ++++++++++++++++++++++++++++++ test/mime/xdg/globs2.scm | 141 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 276 insertions(+) create mode 100644 src/mime/xdg.scm create mode 100644 src/mime/xdg/globs2.scm create mode 100644 test/mime/xdg/globs2.scm diff --git a/src/mime/xdg.scm b/src/mime/xdg.scm new file mode 100644 index 0000000..3b07a44 --- /dev/null +++ b/src/mime/xdg.scm @@ -0,0 +1,27 @@ +;; Shared MIME-Info Database by the X Desktop Group +;; +;; Copyright (C) 2014 Mike Gerwitz +;; +;; This file is part of guile-mime. +;; +;; guile-mime is free software: you can redistribute it and/or modify +;; 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://standards.freedesktop.org/shared-mime-info-spec\ +;; /shared-mime-info-spec-latest.html + + + +(define-module (mime xdg) + #:use-module (mime xdg globs2)) + diff --git a/src/mime/xdg/globs2.scm b/src/mime/xdg/globs2.scm new file mode 100644 index 0000000..3cf9e64 --- /dev/null +++ b/src/mime/xdg/globs2.scm @@ -0,0 +1,108 @@ +;; globs2 format of the Shared MIME-Info Database +;; +;; Copyright (C) 2014 Mike Gerwitz +;; +;; This file is part of guile-mime. +;; +;; guile-mime is free software: you can redistribute it and/or modify +;; 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 xdg globs2) + #:use-module (mime fnmatch) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-8) + #:select (receive)) + #:use-module ((srfi srfi-9) + #:select (define-record-type)) + #:export (load-mime-globs2 + + + mime-glob2? + mime-glob2-class + mime-glob2-type + mime-glob2-pattern + mime-glob2-weight + mime-glob2-flag + + ;; lower-level procedures + parse-mime-glob2)) + + + +(define-record-type + (%make-mime-glob2 class type pattern weight flag) + mime-glob2? + (class mime-glob2-class) + (type mime-glob2-type) + (pattern mime-glob2-pattern) + (weight mime-glob2-weight) + (flag mime-glob2-flag)) + +(define (%make-mime-glob2-empty class) + (%make-mime-glob2 class #f #f #f #f)) + + + +(define (load-mime-globs2 port) + (let lp ((table (make-hash-table)) + (line (read-line port))) + (cond + ((eof-object? line) + (%make-globs2-proc table)) + ((parse-mime-glob2 line) => + (lambda (glob2) + (display glob2) + (lp table (read-line port)))) + (else (error "TODO: invalid glob2 line"))))) + + +(define (%make-globs2-proc table) + (lambda (fn) + (error "TODO"))) + + + +(define (parse-mime-glob2 line) + (match (glob2-extract-fields line) + (() + (%make-mime-glob2-empty 'comment)) + ((_ type "__NOGLOBS__" . _) + (%make-mime-glob2 'deleteall + type #f 0 #f)) + ((weight type pattern flag . _) + (%make-mime-glob2 'pattern + type + pattern + (string->number weight) + (glob2-parse-flag flag))) + ((weight type pattern . _) + (%make-mime-glob2 'pattern + type + pattern + (string->number weight) + #f)) + (_ #f))) + +(define (glob2-is-comment? line) + (string-prefix? "#" line)) + +(define (glob2-extract-fields line) + (if (glob2-is-comment? line) + '() + (string-split line #\:))) + +(define (glob2-parse-flag flag) + (match flag + ("cs" 'case-fold) + (_ #f))) diff --git a/test/mime/xdg/globs2.scm b/test/mime/xdg/globs2.scm new file mode 100644 index 0000000..9af69fc --- /dev/null +++ b/test/mime/xdg/globs2.scm @@ -0,0 +1,141 @@ +;; Test case for globs2 format of the Shared MIME-Info Database +;; +;; 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 xdg globs2) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match) + #:use-module (mime xdg globs2)) + + + +(define-syntax-rule (%make-test-match pattern test-expr) + (match test-expr + (pattern #t) + (_ #f))) + +(define-syntax test-match + (syntax-rules () + ((test-match test-name pattern test-expr) + (test-eq test-name + #t + (%make-test-match pattern test-expr))) + ((test-match pattern test-expr) + (test-eq #t + (%make-test-match pattern test-expr))))) + + + +(test-group + "(mime xdg globs2)" + + (test-group + "parse-mime-glob2" + + (test-match "comment yields empty record of class 'comment" + ($ 'comment #f #f #f #f) + (parse-mime-glob2 "#comment line")) + + (test-group + "__NOGLOBS__ yields" + + (let* ((type "foo/noglobs") + (r (parse-mime-glob2 + (string-append "10:" type ":__NOGLOBS__:cs" )))) + + (test-assert " record" + (mime-glob2? r)) + + (test-eq "class of 'deleteall" + (mime-glob2-class r) + 'deleteall) + + (test-assert "the given type" + (string=? type + (mime-glob2-type r))) + + (test-equal "weight of zero" + (mime-glob2-weight r) + 0) + + (test-eq "no pattern" + #f + (mime-glob2-pattern r)) + + (test-eq "no flags" + #f + (mime-glob2-flag r))) + + ;; tests both with and without flags + (for-each + (lambda (xs) + (let ((group-desc (car xs)) + (flag (cdr xs))) + + (test-group + group-desc + + ;; flags will be tested below + (let* ((type "foo/flags") + (weight 15) + (pattern "*.foo") + (r (parse-mime-glob2 + (string-append (number->string weight) + ":" type + ":" pattern + flag)))) + + (test-assert " record" + (mime-glob2? r)) + + (test-eq "class of 'pattern" + (mime-glob2-class r) + 'pattern) + + (test-assert "the given type" + (string=? type + (mime-glob2-type r))) + + (test-equal "the given weight" + weight + (mime-glob2-weight r)) + + (test-assert "the given pattern" + (string=? pattern + (mime-glob2-pattern r))))))) + '(("pattern with flag yields" . ":foo") + ("pattern without flag yields" . ""))) + + (test-group + "flag" + + (test-eq "yields #f when unknown" + #f + (mime-glob2-flag (parse-mime-glob2 + "0:foo:*:unknown"))) + + (test-eq "yields 'case-fold when `cs'" + 'case-fold + (mime-glob2-flag (parse-mime-glob2 + "0:foo:*:cs"))))))) +