Merge branch 'master' into core-updates

5 files changed, 127 insertions, 67 deletions

diff --git a/guix/download.scm b/guix/download.scm
index 50aa78fe0d..a91d924af8 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -66,7 +66,6 @@
        "ftp://gcc.gnu.org/pub/gcc/"
        ,@(map (cut string-append <> "/gcc") gnu-mirrors))
       (gnupg
-       "http://gd.tuwien.ac.at/privacy/gnupg/"
        "http://artfiles.org/gnupg.org"
        "http://www.crysys.hu/"
        "https://gnupg.org/ftp/gcrypt/"
@@ -143,7 +142,6 @@
        "http://apache.belnet.be/"
        "http://mirrors.ircam.fr/pub/apache/"
        "http://apache-mirror.rbc.ru/pub/apache/"
-       "ftp://gd.tuwien.ac.at/pub/infosys/servers/http/apache/dist/"
 
        ;; As a last resort, try the archive.
        "http://archive.apache.org/dist/")
@@ -163,7 +161,6 @@
        "ftp://ftp.piotrkosoft.net/pub/mirrors/ftp.x.org/"
        "ftp://ftp.portal-to-web.de/pub/mirrors/x.org/"
        "ftp://ftp.solnet.ch/mirror/x.org/"
-       "ftp://gd.tuwien.ac.at/X11/"
        "ftp://mi.mirror.garr.it/mirrors/x.org/"
        "ftp://mirror.cict.fr/x.org/"
        "ftp://mirror.switch.ch/mirror/X11/"
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/git.scm b/guix/git.scm
index fc41e2ace3..d31c35f64f 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,6 +28,8 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:export (%repository-cache-directory
             latest-repository-commit))
 
@@ -94,17 +97,32 @@ create the store directory name."
 
 (define (switch-to-ref repository ref)
   "Switch to REPOSITORY's branch, commit or tag specified by REF."
-  (let* ((oid (match ref
-                (('branch . branch)
-                 (reference-target
-                  (branch-lookup repository branch BRANCH-REMOTE)))
-                (('commit . commit)
-                 (string->oid commit))
-                (('tag    . tag)
-                 (reference-name->oid repository
-                                      (string-append "refs/tags/" tag)))))
-         (obj (object-lookup repository oid)))
-    (reset repository obj RESET_HARD)))
+  (define obj
+    (match ref
+      (('branch . branch)
+       (let ((oid (reference-target
+                   (branch-lookup repository branch BRANCH-REMOTE))))
+         (object-lookup repository oid)))
+      (('commit . commit)
+       (let ((len (string-length commit)))
+         ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
+         ;; can't be sure it's available.  Furthermore, 'string->oid' used to
+         ;; read out-of-bounds when passed a string shorter than 40 chars,
+         ;; which is why we delay calls to it below.
+         (if (< len 40)
+             (if (module-defined? (resolve-interface '(git object))
+                                  'object-lookup-prefix)
+                 (object-lookup-prefix repository (string->oid commit) len)
+                 (raise (condition
+                         (&message
+                          (message "long Git object ID is required")))))
+             (object-lookup repository (string->oid commit)))))
+      (('tag    . tag)
+       (let ((oid (reference-name->oid repository
+                                       (string-append "refs/tags/" tag))))
+         (object-lookup repository oid)))))
+
+  (reset repository obj RESET_HARD))
 
 (define* (latest-repository-commit store url
                                    #:key
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 45a419217c..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.
 ;;;
@@ -67,15 +67,15 @@ NAMES (strings)."
         (string-append package-name-prefix (string-downcase name)))))
 
 (define* (elpa-url #:optional (repo 'gnu))
-  "Retrun the URL of REPO."
+  "Retrieve the URL of REPO."
   (let ((elpa-archives
-         '((gnu . "http://elpa.gnu.org/packages")
-           (melpa-stable . "http://stable.melpa.org/packages")
-           (melpa . "http://melpa.org/packages"))))
+         '((gnu . "https://elpa.gnu.org/packages")
+           (melpa-stable . "https://stable.melpa.org/packages")
+           (melpa . "https://melpa.org/packages"))))
     (assq-ref elpa-archives repo)))
 
 (define* (elpa-fetch-archive #:optional (repo 'gnu))
-  "Retrive the archive with the list of packages available from REPO."
+  "Retrieve the archive with the list of packages available from REPO."
   (let ((url (and=> (elpa-url repo)
                     (cut string-append <> "/archive-contents"))))
     (if url
@@ -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)))))
 
 
 ;;;