summary refs log tree commit diff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gnu/build/linux-modules.scm19
-rw-r--r--gnu/packages/cran.scm31
-rw-r--r--gnu/packages/gnome.scm4
-rw-r--r--gnu/packages/gnuzilla.scm5
-rw-r--r--gnu/packages/maths.scm34
-rw-r--r--gnu/packages/ruby.scm260
-rw-r--r--gnu/packages/video.scm4
-rw-r--r--gnu/system/vm.scm1
-rw-r--r--guix/git-download.scm2
-rw-r--r--guix/glob.scm124
-rw-r--r--guix/import/elpa.scm15
-rw-r--r--tests/elpa.scm43
-rw-r--r--tests/glob.scm67
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")
generated by cgit-pink 1.4.1 (git 2.36.1) at 2024-12-02 04:56:34 +0000