| 1 | |
| 2 | |
| 3 | |
| 4 | |
| 5 | |
| 6 | |
| 7 | |
| 8 | |
| 9 | |
| 10 | |
| 11 | |
| 12 | |
| 13 | |
| 14 | |
| 15 | |
| 16 | |
| 17 | |
| 18 | |
| 19 | |
| 20 | |
| 21 |
|
| 22 | (define-module (test-import-utils)
|
| 23 | #:use-module (guix tests)
|
| 24 | #:use-module ((guix diagnostics) #:select (location))
|
| 25 | #:use-module (guix import utils)
|
| 26 | #:use-module ((guix licenses) #:prefix license:)
|
| 27 | #:use-module (guix packages)
|
| 28 | #:use-module (guix build-system)
|
| 29 | #:use-module (guix tests git)
|
| 30 | #:use-module (gnu packages)
|
| 31 | #:use-module (srfi srfi-64)
|
| 32 | #:use-module (srfi srfi-71)
|
| 33 | #:use-module (ice-9 match))
|
| 34 |
|
| 35 | (test-begin "import-utils")
|
| 36 |
|
| 37 | (test-equal "beautify-description: empty string"
|
| 38 | "This package lacks a description. Run \
|
| 39 | \"info '(guix) Synopses and Descriptions'\" for more information."
|
| 40 | (beautify-description ""))
|
| 41 |
|
| 42 | (test-equal "beautify-description: not a string"
|
| 43 | "This package lacks a description. Run \
|
| 44 | \"info '(guix) Synopses and Descriptions'\" for more information."
|
| 45 | (beautify-description '()))
|
| 46 |
|
| 47 | (test-equal "beautify-description: use double spacing"
|
| 48 | "\
|
| 49 | Trust me Mr. Hendrix, M. Night Shyamalan et al. \
|
| 50 | Differences are hard to spot,
|
| 51 | e.g. in CLOS vs. GOOPS."
|
| 52 | (beautify-description
|
| 53 | "
|
| 54 | Trust me Mr. Hendrix, M. Night Shyamalan et al. \
|
| 55 | Differences are hard to spot, e.g. in CLOS vs. GOOPS."))
|
| 56 |
|
| 57 | (test-equal "beautify-description: transform fragment into sentence"
|
| 58 | "This package provides a function to establish world peace."
|
| 59 | (beautify-description "A function to establish world peace"))
|
| 60 |
|
| 61 | (test-equal "beautify-description: remove single quotes"
|
| 62 | "CRAN likes to quote acronyms and function names."
|
| 63 | (beautify-description "CRAN likes to 'quote' acronyms and 'function' names."))
|
| 64 |
|
| 65 | (test-equal "beautify-description: escape @"
|
| 66 | "This @@ is not Texinfo syntax. Neither is this %@@>%."
|
| 67 | (beautify-description "This @ is not Texinfo syntax. Neither is this %@>%."))
|
| 68 |
|
| 69 | (test-equal "beautify-description: escape @stuff"
|
| 70 | "This is not valid syntax: @code{@@importFrom} oh dear."
|
| 71 | (beautify-description "This is not valid syntax: @importFrom oh dear."))
|
| 72 |
|
| 73 | (test-equal "beautify-description: wrap PascalCase words in @code"
|
| 74 | "The term @code{DelayedMatrix} refers to a class."
|
| 75 | (beautify-description "The term DelayedMatrix refers to a class."))
|
| 76 |
|
| 77 | (test-equal "beautify-description: do not wrap acronyms in @code"
|
| 78 | "The term API is not code, but @code{myAPI} might be."
|
| 79 | (beautify-description "The term API is not code, but myAPI might be."))
|
| 80 |
|
| 81 | (test-equal "beautify-description: do not include punctuation when wrapping in @code"
|
| 82 | "Code (@code{DelayedMatrix}, @code{MaMa}, or @code{MeMe}) should be wrapped."
|
| 83 | (beautify-description "Code (DelayedMatrix, MaMa, or MeMe) should be wrapped."))
|
| 84 |
|
| 85 | (test-equal "beautify-description: wrap function names in @code"
|
| 86 | "The main functions are: @code{haplo.em()} and @code{haplo.power()}; FYI."
|
| 87 | (beautify-description "The main functions are: haplo.em() and haplo.power(); FYI."))
|
| 88 |
|
| 89 | (test-equal "beautify-synopsis: escape @"
|
| 90 | "This is invalid @@syntax"
|
| 91 | (beautify-synopsis "This is invalid @syntax"))
|
| 92 |
|
| 93 | (test-equal "beautify-synopsis: escape @"
|
| 94 | "Just an @@ in the middle"
|
| 95 | (beautify-synopsis "Just an @ in the middle"))
|
| 96 |
|
| 97 | (test-equal "license->symbol"
|
| 98 | 'license:lgpl2.0
|
| 99 | (license->symbol license:lgpl2.0))
|
| 100 |
|
| 101 | (test-equal "recursive-import"
|
| 102 | '((package |
| 103 | (name "bar"))
|
| 104 | (package
|
| 105 | (name "foo")
|
| 106 | (inputs `(("bar" ,bar)))))
|
| 107 | (recursive-import "foo"
|
| 108 | #:repo 'repo
|
| 109 | #:repo->guix-package
|
| 110 | (match-lambda*
|
| 111 | (("foo" #:repo 'repo . rest)
|
| 112 | (values '(package
|
| 113 | (name "foo")
|
| 114 | (inputs `(("bar" ,bar))))
|
| 115 | '("bar")))
|
| 116 | (("bar" #:repo 'repo . rest)
|
| 117 | (values '(package
|
| 118 | (name "bar"))
|
| 119 | '())))
|
| 120 | #:guix-name identity))
|
| 121 |
|
| 122 | (test-equal "recursive-import: skip false packages (toplevel)"
|
| 123 | '()
|
| 124 | (recursive-import "foo"
|
| 125 | #:repo 'repo
|
| 126 | #:repo->guix-package
|
| 127 | (match-lambda*
|
| 128 | (("foo" #:repo 'repo . rest)
|
| 129 | (values #f '())))
|
| 130 | #:guix-name identity))
|
| 131 |
|
| 132 | (test-equal "recursive-import: skip false packages (dependency)"
|
| 133 | '((package
|
| 134 | (name "foo")
|
| 135 | (inputs `(("bar" ,bar)))))
|
| 136 | (recursive-import "foo"
|
| 137 | #:repo 'repo
|
| 138 | #:repo->guix-package
|
| 139 | (match-lambda*
|
| 140 | (("foo" #:repo 'repo . rest)
|
| 141 | (values '(package
|
| 142 | (name "foo")
|
| 143 | (inputs `(("bar" ,bar))))
|
| 144 | '("bar")))
|
| 145 | (("bar" #:repo 'repo . rest)
|
| 146 | (values #f '())))
|
| 147 | #:guix-name identity))
|
| 148 |
|
| 149 | (test-assert "alist->package with simple source"
|
| 150 | (let* ((meta '(("name" . "hello")
|
| 151 | ("version" . "2.10")
|
| 152 | ("source" .
|
| 153 | |
| 154 | ,(string-append "file://"
|
| 155 | (search-path %load-path "guix.scm")))
|
| 156 | ("build-system" . "gnu")
|
| 157 | ("home-page" . "https://gnu.org")
|
| 158 | ("synopsis" . "Say hi")
|
| 159 | ("description" . "This package says hi.")
|
| 160 | ("license" . "GPL-3.0+")))
|
| 161 | (pkg (alist->package meta)))
|
| 162 | (and (package? pkg)
|
| 163 | (license:license? (package-license pkg))
|
| 164 | (build-system? (package-build-system pkg))
|
| 165 | (origin? (package-source pkg)))))
|
| 166 |
|
| 167 | (test-assert "alist->package with explicit source"
|
| 168 | (let* ((meta '(("name" . "hello")
|
| 169 | ("version" . "2.10")
|
| 170 | ("source" . (("method" . "url-fetch")
|
| 171 | ("uri" . "mirror://gnu/hello/hello-2.10.tar.gz")
|
| 172 | ("sha256" .
|
| 173 | (("base32" .
|
| 174 | "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
|
| 175 | ("build-system" . "gnu")
|
| 176 | ("home-page" . "https://gnu.org")
|
| 177 | ("synopsis" . "Say hi")
|
| 178 | ("description" . "This package says hi.")
|
| 179 | ("license" . "GPL-3.0+")))
|
| 180 | (pkg (alist->package meta)))
|
| 181 | (and (package? pkg)
|
| 182 | (license:license? (package-license pkg))
|
| 183 | (build-system? (package-build-system pkg))
|
| 184 | (origin? (package-source pkg))
|
| 185 | (equal? (content-hash-value (origin-hash (package-source pkg)))
|
| 186 | (base32 "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
|
| 187 |
|
| 188 | (test-equal "alist->package with false license" |
| 189 | 'license-is-false
|
| 190 | (let* ((meta '(("name" . "hello")
|
| 191 | ("version" . "2.10")
|
| 192 | ("source" . (("method" . "url-fetch")
|
| 193 | ("uri" . "mirror://gnu/hello/hello-2.10.tar.gz")
|
| 194 | ("sha256" .
|
| 195 | (("base32" .
|
| 196 | "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
|
| 197 | ("build-system" . "gnu")
|
| 198 | ("home-page" . "https://gnu.org")
|
| 199 | ("synopsis" . "Say hi")
|
| 200 | ("description" . "This package says hi.")
|
| 201 | ("license" . #f))))
|
| 202 | |
| 203 | |
| 204 | (or (package-license (alist->package meta))
|
| 205 | 'license-is-false)))
|
| 206 |
|
| 207 | (test-equal "alist->package with SPDX license name 1/2" |
| 208 | license:expat
|
| 209 | (let* ((meta '(("name" . "hello")
|
| 210 | ("version" . "2.10")
|
| 211 | ("source" . (("method" . "url-fetch")
|
| 212 | ("uri" . "mirror://gnu/hello/hello-2.10.tar.gz")
|
| 213 | ("sha256" .
|
| 214 | (("base32" .
|
| 215 | "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
|
| 216 | ("build-system" . "gnu")
|
| 217 | ("home-page" . "https://gnu.org")
|
| 218 | ("synopsis" . "Say hi")
|
| 219 | ("description" . "This package says hi.")
|
| 220 | ("license" . "expat"))))
|
| 221 | (package-license (alist->package meta))))
|
| 222 |
|
| 223 | (test-equal "alist->package with SPDX license name 2/2" |
| 224 | license:expat
|
| 225 | (let* ((meta '(("name" . "hello")
|
| 226 | ("version" . "2.10")
|
| 227 | ("source" . (("method" . "url-fetch")
|
| 228 | ("uri" . "mirror://gnu/hello/hello-2.10.tar.gz")
|
| 229 | ("sha256" .
|
| 230 | (("base32" .
|
| 231 | "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
|
| 232 | ("build-system" . "gnu")
|
| 233 | ("home-page" . "https://gnu.org")
|
| 234 | ("synopsis" . "Say hi")
|
| 235 | ("description" . "This package says hi.")
|
| 236 | ("license" . "MIT"))))
|
| 237 | (package-license (alist->package meta))))
|
| 238 |
|
| 239 | (test-equal "alist->package with dependencies"
|
| 240 | `(("gettext" ,(specification->package "gettext")))
|
| 241 | (let* ((meta '(("name" . "hello")
|
| 242 | ("version" . "2.10")
|
| 243 | ("source" . (("method" . "url-fetch")
|
| 244 | ("uri" . "mirror://gnu/hello/hello-2.10.tar.gz")
|
| 245 | ("sha256" .
|
| 246 | (("base32" .
|
| 247 | "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
|
| 248 | ("build-system" . "gnu")
|
| 249 | ("home-page" . "https://gnu.org")
|
| 250 | ("synopsis" . "Say hi")
|
| 251 | ("description" . "This package says hi.")
|
| 252 | |
| 253 | |
| 254 | |
| 255 | ("native-inputs" . #("gettext"))
|
| 256 |
|
| 257 | ("license" . #f))))
|
| 258 | (package-native-inputs (alist->package meta))))
|
| 259 |
|
| 260 | (test-assert "alist->package with properties"
|
| 261 | (let* ((meta '(("name" . "hello")
|
| 262 | ("version" . "2.10")
|
| 263 | ("source" .
|
| 264 | |
| 265 | ,(string-append "file://"
|
| 266 | (search-path %load-path "guix.scm")))
|
| 267 | ("build-system" . "gnu")
|
| 268 | ("properties" . (("hidden?" . #t)
|
| 269 | ("upstream-name" . "hello-upstream")))
|
| 270 | ("home-page" . "https://gnu.org")
|
| 271 | ("synopsis" . "Say hi")
|
| 272 | ("description" . "This package says hi.")
|
| 273 | ("license" . "GPL-3.0+")))
|
| 274 | (pkg (alist->package meta)))
|
| 275 | (and (package? pkg)
|
| 276 | (equal? (package-upstream-name pkg) "hello-upstream")
|
| 277 | (hidden-package? pkg))))
|
| 278 |
|
| 279 | (test-equal "spdx-string->license"
|
| 280 | '(license:gpl3+ license:agpl3 license:gpl2+)
|
| 281 | (map spdx-string->license
|
| 282 | '("GPL-3.0-oR-LaTeR" "AGPL-3.0" "GPL-2.0+")))
|
| 283 |
|
| 284 |
|
| 285 | |
| 286 | |
| 287 | |
| 288 |
|
| 289 | (test-equal "find-version, empty versions list"
|
| 290 | #f
|
| 291 | (find-version '()))
|
| 292 |
|
| 293 | (test-equal "find-version, latest"
|
| 294 | "6.11.1"
|
| 295 | (find-version '("6.9" "6.8" "6.5" "6.11.1" "6.10.3")))
|
| 296 |
|
| 297 | (test-equal "find-version, partial, exact"
|
| 298 | "6.10.3"
|
| 299 | (find-version '("6.9" "6.8" "6.5" "6.11.1" "6.10.3") "6.10.3" #t))
|
| 300 |
|
| 301 | (test-equal "find-version, partial, under-specified"
|
| 302 | "6.10.3"
|
| 303 | (find-version '("6.9" "6.8" "6.5" "6.11.1" "6.10.3") "6.10" #t))
|
| 304 |
|
| 305 | (test-equal "find-version, partial, over-specified"
|
| 306 | "6.10"
|
| 307 | (find-version '("6.9" "6.8" "6.5" "6.11" "6.10") "6.10.3" #t))
|
| 308 |
|
| 309 | |
| 310 | |
| 311 | |
| 312 |
|
| 313 | (test-assert "default-git-error: returns a procedure without location argument"
|
| 314 | (procedure?
|
| 315 | (default-git-error "https://github.com/user/repo")))
|
| 316 |
|
| 317 | (test-assert "default-git-error: returns a procedure with location argument"
|
| 318 | (procedure?
|
| 319 | (default-git-error "https://github.com/user/repo"
|
| 320 | (location "none.scm" 42 0))))
|
| 321 |
|
| 322 | (test-equal "default-git-error: procedure handles git-error"
|
| 323 | #f
|
| 324 | (let ((home-page "https://github.com/user/repo"))
|
| 325 | ((default-git-error home-page) '(git-error "some error message"))))
|
| 326 |
|
| 327 | (test-equal "default-git-error: returns #f for non-git-error"
|
| 328 | #f
|
| 329 | (let ((home-page "https://github.com/user/repo"))
|
| 330 | ((default-git-error home-page) '(some-other-error "message"))))
|
| 331 |
|
| 332 | |
| 333 | |
| 334 | |
| 335 |
|
| 336 | (define (test-generate-git-source git-version version)
|
| 337 | "Helper to test generate-git-source. Creates a temporary git repository with
|
| 338 | GIT-VERSION tag, attempts to generate source for VERSION, and returns two
|
| 339 | values: the git-source commit S-expression, and a boolean indicating if the
|
| 340 | error procedure has been called."
|
| 341 | (with-temporary-git-repository directory
|
| 342 | `((add "README" "Initial commit")
|
| 343 | (commit "First commit")
|
| 344 | (tag ,git-version ,version))
|
| 345 | (mock ((guix import utils) git-repository-url? (const #t))
|
| 346 | (let* ((error-called? #f)
|
| 347 | (error-proc (lambda args
|
| 348 | (set! error-called? #t)
|
| 349 | #f)))
|
| 350 | (match (generate-git-source directory version error-proc)
|
| 351 | (`(origin
|
| 352 | (method git-fetch)
|
| 353 | (uri (git-reference (url ,url)
|
| 354 | (commit ,commit-sexp)))
|
| 355 | . ,rest)
|
| 356 | (values commit-sexp error-called?))
|
| 357 | (_
|
| 358 | (values #f error-called?)))))))
|
| 359 |
|
| 360 | (test-equal "generate-git-source: version with 'v' prefix tag"
|
| 361 | '(string-append "v" version)
|
| 362 | (test-generate-git-source "v1.0.0" "1.0.0"))
|
| 363 |
|
| 364 | (test-equal "generate-git-source: version without 'v' prefix tag"
|
| 365 | 'version
|
| 366 | (test-generate-git-source "1.0.0" "1.0.0"))
|
| 367 |
|
| 368 | (test-assert "generate-git-source: calls error-procedure when tag not found"
|
| 369 | (let ((sexp error-called? (test-generate-git-source "1.0.0" "2.0.0")))
|
| 370 | error-called?))
|
| 371 |
|
| 372 | (test-equal "tarball-url->git-repository-url, guile"
|
| 373 | '("https://https.git.savannah.gnu.org/git/guile.git"
|
| 374 | "https://gitlab.gnome.org/GNOME/brasero.git"
|
| 375 | "https://github.com/aide/aide")
|
| 376 | (map tarball-url->git-repository-url
|
| 377 | '("mirror://gnu/guile/guile-3.0.11.tar.gz"
|
| 378 | "mirror://gnome/sources/brasero/3.12/brasero-3.12.3.tar.xz"
|
| 379 | "https://github.com/aide/aide/releases/download/v0.19.3/aide-0.19.3.tar.gz")))
|
| 380 |
|
| 381 | (test-end "import-utils")
|