diff options
author | Marius Bakke <mbakke@fastmail.com> | 2018-03-19 03:50:39 +0100 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2018-03-19 03:50:39 +0100 |
commit | 4eade64706d88434fb6096e2b9506e2022e3137b (patch) | |
tree | 6f332077d17c5067a8c752b71b1f33f2c62bfc58 | |
parent | 7ace97395feedc4b3ec23be65f2ed63f29aac9a9 (diff) | |
parent | be95bcf0887dc7d90177fda20cab56c6e248dcfa (diff) | |
download | patches-4eade64706d88434fb6096e2b9506e2022e3137b.tar patches-4eade64706d88434fb6096e2b9506e2022e3137b.tar.gz |
Merge branch 'master' into staging
-rw-r--r-- | gnu/build/linux-modules.scm | 19 | ||||
-rw-r--r-- | gnu/packages/cran.scm | 31 | ||||
-rw-r--r-- | gnu/packages/gnome.scm | 4 | ||||
-rw-r--r-- | gnu/packages/gnuzilla.scm | 5 | ||||
-rw-r--r-- | gnu/packages/maths.scm | 34 | ||||
-rw-r--r-- | gnu/packages/ruby.scm | 260 | ||||
-rw-r--r-- | gnu/packages/video.scm | 4 | ||||
-rw-r--r-- | gnu/system/vm.scm | 1 | ||||
-rw-r--r-- | guix/git-download.scm | 2 | ||||
-rw-r--r-- | guix/glob.scm | 124 | ||||
-rw-r--r-- | guix/import/elpa.scm | 15 | ||||
-rw-r--r-- | tests/elpa.scm | 43 | ||||
-rw-r--r-- | tests/glob.scm | 67 |
13 files changed, 503 insertions, 106 deletions
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index 4fe673cca2..87d2e98edf 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -206,7 +206,9 @@ appears in BLACK-LIST are not loaded." (define (load-dependencies file) (let ((dependencies (module-dependencies file))) - (every (cut load-linux-module* <> #:lookup-module lookup-module) + (every (cut load-linux-module* <> + #:lookup-module lookup-module + #:black-list black-list) (map lookup-module dependencies)))) (and (not (black-listed? (file-name->module-name file))) @@ -327,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) @@ -352,17 +354,20 @@ 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))))))) -(define (current-alias-file) - "Return the absolute file name of the default 'modules.alias' file." +(define (current-kernel-directory) + "Return the directory of the currently running Linux kernel." (string-append (or (getenv "LINUX_MODULE_DIRECTORY") "/run/booted-system/kernel/lib/modules") - "/" (utsname:release (uname)) - "/" "modules.alias")) + "/" (utsname:release (uname)))) + +(define (current-alias-file) + "Return the absolute file name of the default 'modules.alias' file." + (string-append (current-kernel-directory) "/modules.alias")) (define* (known-module-aliases #:optional (alias-file (current-alias-file))) "Return the list of alias/module pairs read from ALIAS-FILE. Each alias is diff --git a/gnu/packages/cran.scm b/gnu/packages/cran.scm index 717fa7fdfa..b54ddc6b55 100644 --- a/gnu/packages/cran.scm +++ b/gnu/packages/cran.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017 Roel Janssen <roel@gnu.org> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017 Raoul Bonnal <ilpuccio.febo@gmail.com> +;;; Copyright © 2018 Vijayalakshmi Vedantham <vijimay12@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -59,6 +60,36 @@ diversification and macroevolution, computing distances from DNA sequences, and several other tools.") (license license:gpl2+))) +(define-public r-abbyyr + (package + (name "r-abbyyr") + (version "0.5.1") + (source + (origin + (method url-fetch) + (uri (cran-uri "abbyyR" version)) + (sha256 + (base32 + "1s8zf18sh0s89vk3dl09fzrq50csmmfvmsanf5vfkv9n5lx6pklg")))) + (properties `((upstream-name . "abbyyR"))) + (build-system r-build-system) + (propagated-inputs + `(("r-curl" ,r-curl) + ("r-httr" ,r-httr) + ("r-plyr" ,r-plyr) + ("r-progress" ,r-progress) + ("r-readr" ,r-readr) + ("r-xml" ,r-xml))) + (home-page "https://github.com/soodoku/abbyyR") + (synopsis "Access to Abbyy Optical Character Recognition (OCR) API") + (description + "This package provides tools to get text from images of text using Abbyy +Cloud Optical Character Recognition (OCR) API. With abbyyyR, one can easily +OCR images, barcodes, forms, documents with machine readable zones, e.g. +passports and get the results in a variety of formats including plain text and +XML. To learn more about the Abbyy OCR API, see @url{http://ocrsdk.com/}.") + (license license:expat))) + (define-public r-colorspace (package (name "r-colorspace") diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 164d705ca5..6623a59bff 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -4424,7 +4424,7 @@ metadata in photo and video files of various formats.") (define-public shotwell (package (name "shotwell") - (version "0.27.4") + (version "0.28.0") (source (origin (method url-fetch) (uri (string-append "mirror://gnome/sources/" name "/" @@ -4432,7 +4432,7 @@ metadata in photo and video files of various formats.") name "-" version ".tar.xz")) (sha256 (base32 - "0g2vphhpxrljpy9sryfsgaayix807i1i9plj9bay72dk0zphqab2")))) + "1d797nmlz9gs6ri0h65b76s40ss6ma6h6405xqx03lhg5xni3kmg")))) (build-system glib-or-gtk-build-system) (propagated-inputs `(("dconf" ,dconf))) diff --git a/gnu/packages/gnuzilla.scm b/gnu/packages/gnuzilla.scm index c8cec6b422..0836b89a80 100644 --- a/gnu/packages/gnuzilla.scm +++ b/gnu/packages/gnuzilla.scm @@ -449,7 +449,10 @@ security standards.") (mozilla-patch "icecat-bug-1442127-pt2.patch" "da5792b70f30" "116k9qja5ir9b3laazasp43f5jx59qq72nknmq5bn5v1ixya9r4l") (mozilla-patch "icecat-CVE-2018-5125-pt8.patch" "62b831df8269" "109pn0hqn7s27580glv4z7qv1pmjzii9szvf3wkn97k5wybrzgkx") (mozilla-patch "icecat-bug-1442504.patch" "8954ce68a364" "0bl65zw82bwqg0mmcri94pxqq6ibff7y5rclkzapb081p6yvf73q") - (mozilla-patch "icecat-CVE-2018-5125-pt9.patch" "8a16f439117c" "108iarql6z7h1r4rlzac6n6lrzs78x7kcdbfa0b5dbr5xc66jmgb"))) + (mozilla-patch "icecat-CVE-2018-5125-pt9.patch" "8a16f439117c" "108iarql6z7h1r4rlzac6n6lrzs78x7kcdbfa0b5dbr5xc66jmgb") + (mozilla-patch "icecat-bug-1426603.patch" "ca0b92ecedee" "0dc3mdl4a3hrq4j384zjavf3splj6blv4masign710hk7svlgbhq") + (mozilla-patch "icecat-CVE-2018-5146.patch" "494e5d5278ba" "1yb4lxjw499ppwhk31vz0vzl0cfqvj9d4jwqag7ayj53ybwsqgjr") + (mozilla-patch "icecat-CVE-2018-5147.patch" "5cd5586a2f48" "10s774pwvj6xfk3kk6ivnhp2acc8x9sqq6na8z47nkhgwl2712i5"))) (modules '((guix build utils))) (snippet '(begin diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 64fe13b9bc..51fe119712 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -53,6 +53,7 @@ #:use-module (guix build-system gnu) #:use-module (guix build-system ocaml) #:use-module (guix build-system r) + #:use-module (guix build-system ruby) #:use-module (gnu packages algebra) #:use-module (gnu packages autotools) #:use-module (gnu packages bison) @@ -97,6 +98,7 @@ #:use-module (gnu packages python-web) #:use-module (gnu packages qt) #:use-module (gnu packages readline) + #:use-module (gnu packages ruby) #:use-module (gnu packages tbb) #:use-module (gnu packages scheme) #:use-module (gnu packages shells) @@ -1940,6 +1942,38 @@ special functions. It uses Matlab function names where appropriate to simplify porting.") (license license:gpl3+))) +(define-public ruby-asciimath + (package + (name "ruby-asciimath") + (version "1.0.4") + (source + (origin + (method url-fetch) + (uri (rubygems-uri "asciimath" version)) + (sha256 + (base32 + "1d80kiph5mc78zps7si1hv48kv4k12mzaq8jk5kb3pqpjdr72qmc")))) + (build-system ruby-build-system) + (arguments + '(#:phases + (modify-phases %standard-phases + ;; Apply this patch + ;; https://github.com/asciidoctor/asciimath/commit/1c06fdc8086077f4785479f78b0823a4a72d7948 + (add-after 'unpack 'patch-remove-spurious-backslashes + (lambda _ + (substitute* "spec/parser_spec.rb" + (("\\\\\"") + "\""))))))) + (native-inputs + `(("bundler" ,bundler) + ("ruby-rspec" ,ruby-rspec))) + (synopsis "AsciiMath parsing and conversion library") + (description + "A pure Ruby AsciiMath parsing and conversion library. AsciiMath is an +easy-to-write markup language for mathematics.") + (home-page "https://github.com/asciidoctor/asciimath") + (license license:expat))) + (define-public superlu (package (name "superlu") diff --git a/gnu/packages/ruby.scm b/gnu/packages/ruby.scm index ee5d20955c..dcf4cda26a 100644 --- a/gnu/packages/ruby.scm +++ b/gnu/packages/ruby.scm @@ -36,6 +36,7 @@ #:use-module (gnu packages autotools) #:use-module (gnu packages java) #:use-module (gnu packages libffi) + #:use-module (gnu packages maths) #:use-module (gnu packages networking) #:use-module (gnu packages python) #:use-module (gnu packages ragel) @@ -665,6 +666,72 @@ line of code.") ;; of the Expat license. (license license:bsd-3))) +(define-public ruby-asciidoctor + (package + (name "ruby-asciidoctor") + (version "1.5.6.1") + (source + (origin + (method url-fetch) + (uri (rubygems-uri "asciidoctor" version)) + (sha256 + (base32 + "1jnf9y8q5asfdzilp8vcqafrc2faj719df4yh1993mh6jd0iqdy4")))) + (build-system ruby-build-system) + (arguments + `(#:test-target "test:all" + #:phases + (modify-phases %standard-phases + (add-before 'check 'remove-circular-tests + (lambda _ + ;; Remove tests that require circular dependencies to load or pass. + (delete-file "test/invoker_test.rb") + (delete-file "test/converter_test.rb") + (delete-file "test/options_test.rb") + #t))))) + (native-inputs + `(("ruby-minitest" ,ruby-minitest) + ("ruby-nokogiri" ,ruby-nokogiri) + ("ruby-asciimath" ,ruby-asciimath) + ("ruby-coderay" ,ruby-coderay))) + (synopsis "Converter from AsciiDoc content to other formats") + (description + "Asciidoctor is a text processor and publishing toolchain for converting +AsciiDoc content to HTML5, DocBook 5 (or 4.5) and other formats.") + (home-page "http://asciidoctor.org") + (license license:expat))) + +(define-public ruby-sporkmonger-rack-mount + ;; Testing the addressable gem requires a newer commit than that released, so + ;; use an up to date version. + (let ((revision "1") + (commit "076aa2c47d9a4c081f1e9bcb56a826a9e72bd5c3")) + (package + (name "ruby-sporkmonger-rack-mount") + (version (git-version "0.8.3" revision commit)) + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/sporkmonger/rack-mount.git") + (commit commit))) + (file-name (git-file-name name version)) + (sha256 + (base32 + "1scx273g3xd93424x9lxc4zyvcp2niknbw5mkz6wkivpf7xsyxdq")))) + (build-system ruby-build-system) + (arguments + ;; Tests currently fail so disable them. + ;; https://github.com/sporkmonger/rack-mount/pull/1 + `(#:tests? #f)) + (propagated-inputs `(("ruby-rack" ,ruby-rack))) + (synopsis "Stackable dynamic tree based Rack router") + (description + "@code{Rack::Mount} supports Rack's @code{X-Cascade} convention to +continue trying routes if the response returns pass. This allows multiple +routes to be nested or stacked on top of each other.") + (home-page "https://github.com/sporkmonger/rack-mount") + (license license:expat)))) + (define-public ruby-ci-reporter (package (name "ruby-ci-reporter") @@ -824,6 +891,29 @@ functions.") (home-page "https://github.com/ahoward/options") (license license:ruby))) +(define-public ruby-erubis + (package + (name "ruby-erubis") + (version "2.7.0") + (source + (origin + (method url-fetch) + (uri (rubygems-uri "erubis" version)) + (sha256 + (base32 + "1fj827xqjs91yqsydf0zmfyw9p4l2jz5yikg3mppz6d7fi8kyrb3")))) + (build-system ruby-build-system) + (arguments + '(#:tests? #f)) ; tests do not run properly with Ruby 2.0 + (synopsis "Implementation of embedded Ruby (eRuby)") + (description + "Erubis is a fast implementation of embedded Ruby (eRuby) with several +features such as multi-language support, auto escaping, auto trimming spaces +around @code{<% %>}, a changeable embedded pattern, and Ruby on Rails +support.") + (home-page "http://www.kuwata-lab.com/erubis/") + (license license:expat))) + (define-public ruby-orderedhash (package (name "ruby-orderedhash") @@ -3293,6 +3383,106 @@ into a single method call.") (home-page "https://rack.github.io/") (license license:expat))) +(define-public ruby-rack-test + (package + (name "ruby-rack-test") + (version "0.8.3") + (source + (origin + (method url-fetch) + (uri (rubygems-uri "rack-test" version)) + (sha256 + (base32 + "14ij39zywvr1i9f6jsixfg4zxi2q1m1n1nydvf47f0b6sfc9mv1g")))) + (build-system ruby-build-system) + (arguments + ;; Disable tests because of circular dependencies: requires sinatra, + ;; which requires rack-protection, which requires rack-test. Instead + ;; simply require the library. + `(#:phases + (modify-phases %standard-phases + (replace 'check + (lambda _ + (invoke "ruby" "-Ilib" "-r" "rack/test")))))) + (propagated-inputs + `(("ruby-rack" ,ruby-rack))) + (synopsis "Testing API for Rack applications") + (description + "Rack::Test is a small, simple testing API for Rack applications. It can +be used on its own or as a reusable starting point for Web frameworks and +testing libraries to build on.") + (home-page "https://github.com/rack-test/rack-test") + (license license:expat))) + +(define-public ruby-rack-protection + (package + (name "ruby-rack-protection") + (version "2.0.1") + (source + (origin + (method url-fetch) + (uri (rubygems-uri "rack-protection" version)) + (sha256 + (base32 + "0ywmgh7x8ljf7jfnq5hmfzki3f803waji3fcvi107w7mlyflbng7")))) + (build-system ruby-build-system) + (arguments + '(;; Tests missing from the gem + #:tests? #f)) + (propagated-inputs + `(("ruby-rack" ,ruby-rack))) + (native-inputs + `(("bundler" ,bundler) + ("ruby-rspec" ,ruby-rspec-2) + ("ruby-rack-test" ,ruby-rack-test))) + (synopsis "Rack middleware that protects against typical web attacks") + (description "Rack middleware that can be used to protect against typical +web attacks. It can protect all Rack apps, including Rails. For instance, it +protects against cross site request forgery, cross site scripting, +clickjacking, directory traversal, session hijacking and IP spoofing.") + (home-page "https://github.com/sinatra/sinatra/tree/master/rack-protection") + (license license:expat))) + +(define-public ruby-contest + (package + (name "ruby-contest") + (version "0.1.3") + (source + (origin + (method url-fetch) + (uri (rubygems-uri "contest" version)) + (sha256 + (base32 + "1p9f2292b7b0fbrcjswvj9v01z7ig5ig52328wyqcabgb553qsdf")))) + (build-system ruby-build-system) + (synopsis "Write declarative tests using nested contexts") + (description + "Contest allows writing declarative @code{Test::Unit} tests using nested +contexts without performance penalties.") + (home-page "https://github.com/citrusbyte/contest") + (license license:expat))) + +(define-public ruby-creole + (package + (name "ruby-creole") + (version "0.5.0") + (source + (origin + (method url-fetch) + (uri (rubygems-uri "creole" version)) + (sha256 + (base32 + "00rcscz16idp6dx0dk5yi5i0fz593i3r6anbn5bg2q07v3i025wm")))) + (build-system ruby-build-system) + (native-inputs + `(("ruby-bacon" ,ruby-bacon))) + (synopsis "Creole markup language converter") + (description + "Creole is a lightweight markup language and this library for converting +creole to @code{HTML}.") + (home-page "https://github.com/minad/creole") + (license license:ruby))) + (define-public ruby-docile (package (name "ruby-docile") @@ -3526,6 +3716,55 @@ used to create both network servers and clients.") (home-page "http://rubyeventmachine.com") (license (list license:ruby license:gpl3)))) ; GPLv3 only AFAICT +(define-public ruby-ruby-engine + (package + (name "ruby-ruby-engine") + (version "1.0.1") + (source + (origin + (method url-fetch) + (uri (rubygems-uri "ruby_engine" version)) + (sha256 + (base32 + "1d0sd4q50zkcqhr395wj1wpn2ql52r0fpwhzjfvi1bljml7k546v")))) + (build-system ruby-build-system) + (arguments + `(#:phases + (modify-phases %standard-phases + (add-before 'check 'clean-up + (lambda _ + (delete-file "Gemfile.lock") + (substitute* "ruby_engine.gemspec" + ;; Remove unnecessary imports that would entail further + ;; dependencies. + ((".*<rdoc.*") "") + ((".*<rubygems-tasks.*") "") + ;; Remove extraneous .gem file + (("\\\"pkg/ruby_engine-1.0.0.gem\\\",") "") + ;; Soften rake dependency + (("%q<rake>.freeze, \\[\\\"~> 10.0\\\"\\]") + "%q<rake>.freeze, [\">= 10.0\"]") + ;; Soften the rspec dependency + (("%q<rspec>.freeze, \\[\\\"~> 2.4\\\"\\]") + "%q<rspec>.freeze, [\">= 2.4\"]")) + (substitute* "Rakefile" + (("require 'rubygems/tasks'") "") + (("Gem::Tasks.new") "")) + ;; Remove extraneous .gem file that otherwise gets installed. + (delete-file "pkg/ruby_engine-1.0.0.gem") + #t))))) + (native-inputs + `(("bundler" ,bundler) + ("ruby-rake" ,ruby-rake) + ("ruby-rspec" ,ruby-rspec))) + (synopsis "Simplifies checking for Ruby implementation") + (description + "@code{ruby_engine} provides an RubyEngine class that can be used to +check which implementation of Ruby is in use. It can provide the interpreter +name and provides query methods such as @{RubyEngine.mri?}.") + (home-page "https://github.com/janlelis/ruby_engine") + (license license:expat))) + (define-public ruby-turn (package (name "ruby-turn") @@ -4721,3 +4960,24 @@ thing this library does today is convert org-mode files to HTML or Textile or Markdown.") (home-page "https://github.com/wallyqs/org-ruby") (license license:expat))) + +(define-public ruby-rake + (package + (name "ruby-rake") + (version "12.3.0") + (source + (origin + (method url-fetch) + (uri (rubygems-uri "rake" version)) + (sha256 + (base32 + "190p7cs8zdn07mjj6xwwsdna3g0r98zs4crz7jh2j2q5b0nbxgjf")))) + (build-system ruby-build-system) + (native-inputs + `(("bundler" ,bundler))) + (synopsis "Rake is a Make-like program implemented in Ruby") + (description + "Rake is a Make-like program where tasks and dependencies are specified +in standard Ruby syntax.") + (home-page "https://github.com/ruby/rake") + (license license:expat))) diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm index f66bfa2435..0dc0ef6551 100644 --- a/gnu/packages/video.scm +++ b/gnu/packages/video.scm @@ -1158,7 +1158,7 @@ access to mpv's powerful playback capabilities.") (define-public youtube-dl (package (name "youtube-dl") - (version "2018.03.10") + (version "2018.03.14") (source (origin (method url-fetch) (uri (string-append "https://yt-dl.org/downloads/" @@ -1166,7 +1166,7 @@ access to mpv's powerful playback capabilities.") version ".tar.gz")) (sha256 (base32 - "1ibmz91anli1vzkgw2i3h4wf1i8arzd74730ylwcwyg3375xryjb")))) + "0j8j797gqc29fd5ra3cjvwkp8dgvigdydsj0zzjs05zccfqrj9lh")))) (build-system python-build-system) (arguments ;; The problem here is that the directory for the man page and completion diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index ae8780d2e1..594ba66ff4 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -144,6 +144,7 @@ made available under the /xchg CIFS share." (initrd (if initrd ; use the default initrd? (return initrd) (base-initrd %linux-vm-file-systems + #:on-error 'backtrace #:linux linux #:linux-modules %base-initrd-modules #:qemu-networking? #t)))) diff --git a/guix/git-download.scm b/guix/git-download.scm index 731e549b38..33f102bc6c 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -109,7 +109,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;; grep, etc. to be in $PATH. (set-path-environment-variable "PATH" '("bin") (match '#+inputs - (((names dirs) ...) + (((names dirs outputs ...) ...) dirs))) (or (git-fetch (getenv "git url") (getenv "git commit") diff --git a/guix/glob.scm b/guix/glob.scm index 4fc5173ac0..a9fc744802 100644 --- a/guix/glob.scm +++ b/guix/glob.scm @@ -18,80 +18,120 @@ (define-module (guix glob) #:use-module (ice-9 match) - #:export (compile-glob-pattern + #:export (string->sglob + compile-sglob + string->compiled-sglob glob-match?)) ;;; Commentary: ;;; ;;; 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 -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) (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 (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 - ((? 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) (index (loop rest (string-drop str (+ index (string-length suffix))))))) - (('? . rest) + (((? char-set? cs) . rest) (and (>= (string-length str) 1) - (loop rest (string-drop str 1)))) + (let ((chr (string-ref str 0))) + (and (char-set-contains? cs 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/guix/import/elpa.scm b/guix/import/elpa.scm index 5d3d04ee7c..43e9eb60c9 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -190,7 +190,7 @@ include VERSION." url))) (_ #f)))) -(define* (elpa-package->sexp pkg) +(define* (elpa-package->sexp pkg #:optional license) "Return the `package' S-expression for the Emacs package PKG, a record of type '<elpa-package>'." @@ -234,12 +234,17 @@ type '<elpa-package>'." (home-page ,(elpa-package-home-page pkg)) (synopsis ,(elpa-package-synopsis pkg)) (description ,(elpa-package-description pkg)) - (license license:gpl3+)))) + (license ,license)))) (define* (elpa->guix-package name #:optional (repo 'gnu)) "Fetch the package NAME from REPO and produce a Guix package S-expression." - (let ((pkg (fetch-elpa-package name repo))) - (and=> pkg elpa-package->sexp))) + (match (fetch-elpa-package name repo) + (#f #f) + (package + ;; ELPA is known to contain only GPLv3+ code. Other repos may contain + ;; code under other license but there's no license metadata. + (let ((license (and (eq? 'gnu repo) 'license:gpl3+))) + (elpa-package->sexp package license))))) ;;; diff --git a/tests/elpa.scm b/tests/elpa.scm index 46c6ac2d75..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 - "http://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")) diff --git a/tests/glob.scm b/tests/glob.scm index 033eeb10fe..3134069789 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-string->sglob + (syntax-rules (=>) + ((_ pattern => result rest ...) + (begin + (test-equal (format #f "string->sglob, ~s" pattern) + result + (string->sglob pattern)) + (test-string->sglob 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 (string->compiled-sglob 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-string->sglob + "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") |