mikegerwitz
/
guile-mime
1
0
Fork 0
Code Releases Activity

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.
globs2
Mike Gerwitz 2014-11-24 00:38:00 -05:00
parent 33d702bad4
commit 27a6603985
3 changed files with 276 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
src/mime/xdg.scm 100644
View File

@ -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://www.gnu.org/licenses/>.
;;
;; http://standards.freedesktop.org/shared-mime-info-spec\
;; /shared-mime-info-spec-latest.html
(define-module (mime xdg)
#:use-module (mime xdg globs2))

108
src/mime/xdg/globs2.scm 100644
View File

@ -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 <http://www.gnu.org/licenses/>.
(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?
mime-glob2-class
mime-glob2-type
mime-glob2-pattern
mime-glob2-weight
mime-glob2-flag
;; lower-level procedures
parse-mime-glob2))
(define-record-type <mime-glob2>
(%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)))

141
test/mime/xdg/globs2.scm 100644
View File

@ -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 <http://www.gnu.org/licenses/>.
;;
;; 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"
($ <mime-glob2> '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 "<mime-glob2> 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 "<mime-glob2> 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")))))))