diff --git a/configure.ac b/configure.ac index d989a34..ec74888 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ define(EBUILD_AUTOGEN_CONFIGURE_COPYRIGHT, [[ -Copyright (C) 2025 Cor Legemaat +Copyright (C) 2025, 2026 Cor Legemaat This file is part of ebuild-autogen: you can redistribute it and/or modify it under the terms of the GNU Affero General Public License as published by the @@ -15,7 +15,7 @@ ebuild-autogen. If not, see . m4_define([version_major], [0]) m4_define([version_minor], [0]) -m4_define([version_revision], [3]) +m4_define([version_revision], [4]) AC_PACKAGE_URL([http://www.cor.za.net/code/ebuild-autogen]) AC_INIT(ebuild-autogen, @@ -94,6 +94,7 @@ AC_CONFIG_FILES([Makefile po/Makefile.in ebuild/Makefile ebuild/fetchers/Makefile +ebuild/gen/Makefile doc/Makefile]) AC_CONFIG_COMMANDS([timestamp], [date >timestamp]) diff --git a/ebuild/Makefile.am b/ebuild/Makefile.am index 1236561..7ad7f2a 100644 --- a/ebuild/Makefile.am +++ b/ebuild/Makefile.am @@ -1,6 +1,6 @@ ################################################################################ # Makefile.am -# Copyright (C) 2025 Cor Legemaat +# Copyright (C) 2025, 2026 Cor Legemaat # # This file is part of ebuild-autogen: you can redistribute it and/or modify it # under the terms of the GNU Affero General Public License as published by the @@ -13,7 +13,7 @@ # You should have received a copy of the GNU General Public License along with # ebuild-autogen. If not, see . ################################################################################ -SUBDIRS = fetchers +SUBDIRS = fetchers gen moddir=$(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION)/ebuild objdir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache/ebuild @@ -25,7 +25,10 @@ SOURCES = \ cli.scm \ defs.scm \ gen.scm \ + pkt-map.scm \ repo.scm \ + state.scm \ + semver.scm \ utils.scm \ version.scm diff --git a/ebuild/cli.scm b/ebuild/cli.scm index cc9027a..3d90906 100644 --- a/ebuild/cli.scm +++ b/ebuild/cli.scm @@ -1,6 +1,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; cli.scm -;; Copyright (C) 2025 Cor Legemaat +;; Copyright (C) 2025, 2026 Cor Legemaat ;; ;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; under the terms of the GNU Affero General Public License as published by the @@ -20,10 +20,12 @@ #:use-module (ice-9 pretty-print) #:use-module (ice-9 receive) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (dql dql) #:use-module (ebuild defs) #:use-module (ebuild repo) #:use-module (ebuild gen) + #:use-module (ebuild utils) #:use-module (ebuild version) #:use-module (config) #:use-module (config api) @@ -62,6 +64,10 @@ (name 'init-from) (default "") (test string?) (example "https://www.cor.za.net/code/portage-overlay") (synopsis "An url to initialize the repo from scratch")) + (switch + (name 'min-interval) (default "7d") (test string?) + (example "7D") + (synopsis "Minimum interval in witch to update packages in Seconds Minutes Hours or Days")) ;;TODO figure out how to use non parameter options from the command ;; line instead of this. (switch @@ -90,7 +96,12 @@ authentication when pulling package updates from github.")) (example "/tmp/ebuild-autogen/") (handler identity) (test string?) (synopsis "Temporary files path.") - (description "Full path to the folder for the temporary files.")))) + (description "Full path to the folder for the temporary files.")) + (setting + (name 'curl-retries) (default 3) (character #f) + (example "3") (handler string->number) (test integer?) + (synopsis "curl retry count.") + (description "The amount of retries for curl.")))) (synopsis "Auto generate Gentoo ebuild's") (description "ebuild-autogen is a Guile scheme application to auto generate gentoo ebuild package definitions from the \"autogen.scm\" specification for @@ -126,7 +137,18 @@ git repository.") (cons 'verbosity (option-ref options 'verbosity)) (cons 'cache-path (option-ref options 'filecache-path)) - (cons 'tmp-path (option-ref options 'tmp-path))))) + (cons 'tmp-path (option-ref options 'tmp-path)) + (cons 'age-limit + (if (or (option-ref options 'pkg-clean) + (option-ref options 'ebuild-clean) + (option-ref options 'cache-clean)) + (begin (display "Warning, ignoring min-interval to clean files!") + (current-time)) + (subtract-duration + (current-time) + (string->duration + (option-ref options + 'min-interval)))))))) ;; Update the source repository if requested. (if (option-ref options 'submodule-update) (repo-update-src folder)) @@ -140,6 +162,12 @@ git repository.") (assoc-set! parms 'github-token (option-ref options 'github-token)))) + + ;; The curl retries setting. + (set! parms + (assoc-set! parms + 'curl-retries + (option-ref options 'curl-retries))) (with-exception-handler (lambda (exception) @@ -197,126 +225,178 @@ git repository.") ".gitignore-repo" (option-ref options 'verbosity) #:file-dst ".gitignore") + (cp-repo-file repo + "" + "autogen/" + "eclass" + (option-ref options 'verbosity) + #:required #f) + (cp-repo-file repo + "" + "autogen/" + "license" + (option-ref options 'verbosity) + #:required #f) ;; Preform ebuild generation. - (let ((pkg-list (build-pkg-list repo folder #t))) + (let ((pkg-list (build-pkg-list repo folder #t)) + (same-pkg? (lambda (a b) + (and (string=? (assoc-ref a 'category) + (assoc-ref b 'category)) + (string=? (assoc-ref a 'name) + (assoc-ref b 'name)))))) (if (>= (option-ref options 'verbosity) verbosity-warn) (begin (display "package-list:") (newline) (pretty-print pkg-list))) - (let ((cache-files-used - (append-map (lambda (pkg) - (let ((name (string->symbol (assoc-ref pkg 'name))) - (cat (string->symbol (assoc-ref pkg 'category)))) - (if (>= (option-ref options 'verbosity) - verbosity-notice) - (begin (display "pkg:") (newline) - (pretty-print (append parms pkg)))) - (with-exception-handler - (lambda (exception) - (if (>= (option-ref options 'verbosity) - verbosity-error) - (begin - (display "Failed to update the package ") - (display (assoc-ref pkg 'category)) - (display "/") - (display (assoc-ref pkg 'name)) - (display " with") - (if (exception-with-message? exception) - (display - (simple-format - #f " exception-message: \"~a\"" - (exception-message exception)))) - (if (and (exception-with-message? exception) - (exception-with-irritants? exception)) - (display " and")) - (if (exception-with-irritants? exception) - (display - (simple-format - #f " exception-irritants: \"~a\"" - (exception-irritants exception)))) - (newline))) - '()) - (lambda () - (let* ((pkg-mod (resolve-module `(,cat ,name autogen))) - (pkg-parms (append parms pkg)) - (distfiles-used '()) - (pkgfiles-used - (if pkg-mod - (let ((releases - (if (module-variable pkg-mod 'get-releases) - ((module-ref pkg-mod 'get-releases) - (append parms pkg)) - '()))) - (append - ;; Setup the folder and links for the package. - (if (module-variable pkg-mod 'setup-package) - ((module-ref pkg-mod 'setup-package) - pkg-parms) - (setup-pkg pkg-parms)) - ;; Generate the ebuilds. - (receive (pkg-files dist-files) - (if (module-variable pkg-mod 'generate-ebuilds) - ((module-ref pkg-mod 'generate-ebuilds) - pkg-parms - releases) - (ebuild-gen pkg-parms - releases)) - (set! distfiles-used - (append distfiles-used dist-files)) - pkg-files))) - (setup-pkg pkg-parms)))) - (if (option-ref options 'ebuild-clean) - (clean-files pkgfiles-used - (string-join (list repo - (assoc-ref pkg 'category) - (assoc-ref pkg 'name)) - file-name-separator-string) - (option-ref options 'verbosity))) - (display "Done with package: ") - (display (assoc-ref pkg 'category)) - (display "/") - (display (assoc-ref pkg 'name)) - (newline) - distfiles-used)) - #:unwind? (< 1 (length pkg-list))))) - pkg-list))) + (let* ((cache-files-used + (append-map (lambda (pkg) + (let ((name (string->symbol (assoc-ref pkg 'name))) + (cat (string->symbol (assoc-ref pkg 'category)))) + (if (>= (option-ref options 'verbosity) + verbosity-notice) + (begin (display "pkg:") (newline) + (pretty-print (append parms pkg)))) + (with-exception-handler + (lambda (exception) + (if (>= (option-ref options 'verbosity) + verbosity-error) + (begin + (display "Failed to update the package ") + (display (assoc-ref pkg 'category)) + (display "/") + (display (assoc-ref pkg 'name)) + (display " with") + (if (exception-with-message? exception) + (display + (simple-format + #f " exception-message: \"~a\"" + (exception-message exception)))) + (if (and (exception-with-message? exception) + (exception-with-irritants? exception)) + (display " and")) + (if (exception-with-irritants? exception) + (display + (simple-format + #f " exception-irritants: \"~a\"" + (exception-irritants exception)))) + (newline))) + '()) + (lambda () + (let* ((pkg-mod (resolve-module `(,cat ,name autogen))) + (pkg-parms (append parms pkg)) + (pkgfiles-used + (if pkg-mod + ;; Setup the folder and links for the package. + (let* ((setup-files ((if (module-variable pkg-mod 'setup-package) + (module-ref pkg-mod 'setup-package) + setup-pkg) + pkg-parms)) + ;; Fetch the releases. + (releases + (if (module-variable pkg-mod 'get-releases) + ((module-ref pkg-mod 'get-releases) + pkg-parms) + '())) + ;; Generate the ebuilds. + (pkg-gen ((if (module-variable pkg-mod 'generate-ebuilds) + (module-ref pkg-mod 'generate-ebuilds) + ebuild-gen) + (assoc-set! pkg-parms + 'pkgfiles + setup-files) + releases))) + ;; Populate package if no ebuilds generated. + (if (null? pkg-gen) + (list (list (cons 'category (assoc-ref pkg-parms 'category)) + (cons 'name (assoc-ref pkg-parms 'name)) + (cons 'pkgfiles setup-files))) + pkg-gen)) + (setup-pkg pkg-parms)))) + (display "Done with package: ") + (display (assoc-ref pkg 'category)) + (display "/") + (display (assoc-ref pkg 'name)) + (newline) + (if (>= (option-ref options 'verbosity) + verbosity-notice) + (begin (display "package results:") (newline) + (pretty-print pkgfiles-used))) + pkgfiles-used)) + #:unwind? (< 1 (length pkg-list))))) + pkg-list)) + (unique-pkgfiles + (map (lambda (pkg) + (set! pkg + (assoc-set! pkg + 'pkgfiles + (delete-duplicates + (append-map (lambda (p) + (if (same-pkg? pkg p) + (if (assoc-ref p 'pkgfiles) + (assoc-ref p 'pkgfiles) + '()) + '())) + cache-files-used) + string=?))) + (set! pkg (assoc-set! pkg + 'distfiles + (delete-duplicates + (append-map (lambda (p) + (if (same-pkg? pkg p) + (if (assoc-ref p 'distfiles) + (assoc-ref p 'distfiles) + '()) + '())) + cache-files-used) + string=?))) + pkg) + (delete-duplicates cache-files-used + same-pkg?)))) + ;; Clean deprecated pkgfiles. + (if (option-ref options 'ebuild-clean) + (clean-ebuilds unique-pkgfiles + repo + (option-ref options 'verbosity))) ;; Clean deprecated cache files if requested. (if (>= (option-ref options 'verbosity) verbosity-notice) - (begin (display "distfiles-used:") (newline) - (pretty-print cache-files-used) - (display "\"") (newline))) + (begin ;; (display "generated results:") (newline) + ;; (pretty-print cache-files-used) + (display "generated pkgs:") (newline) + (pretty-print unique-pkgfiles))) (if (and (or (string=? folder repo) (string=? folder (string-join (list repo "autogen") file-name-separator-string))) (option-ref options 'cache-clean)) - (clean-files cache-files-used - (option-ref options 'filecache-path) - (option-ref options 'verbosity)))) - - ;; The extra folders in repo not in src. - (let ((repo-pkgs (build-pkg-list repo folder #f))) - (map (lambda (pkg) - (if (null? ((dql (filter (where (lambda (val) - (string=? val - (assoc-ref pkg 'category))) - 'category) - (where (lambda (val) - (string=? val - (assoc-ref pkg 'name))) - 'name))) - pkg-list)) - (if (>= (option-ref options 'verbosity) - verbosity-warn) - (begin (display "Absolute pkg ") - (display (assoc-ref pkg 'category)) - (display "/") - (display (assoc-ref pkg 'name)) - (display " found.") - (newline))))) - repo-pkgs))) + (clean-cache cache-files-used + (option-ref options 'filecache-path) + (option-ref options 'verbosity))) + ;; The extra folders in repo not in src. + (if (and (or (string=? folder repo) + (string=? folder + (string-join (list repo "autogen") + file-name-separator-string))) + (option-ref options 'pkg-clean)) + (let ((repo-pkgs (build-pkg-list repo folder #f))) + (map (lambda (pkg) + (if (not (any (lambda (list-pkg) + (same-pkg? list-pkg pkg)) + cache-files-used)) + (begin (if (>= (option-ref options 'verbosity) + verbosity-warn) + (begin (display "Absolute pkg ") + (display (assoc-ref pkg 'category)) + (display "/") + (display (assoc-ref pkg 'name)) + (display " deleted.") + (newline))) + (delete-file (string-join (list repo + (assoc-ref pkg 'category) + (assoc-ref pkg 'name)) + file-name-separator-string))))) + repo-pkgs))))) ;; Commit and push the updates to master if requested. (if (option-ref options 'remote-push) diff --git a/ebuild/fetchers/Makefile.am b/ebuild/fetchers/Makefile.am index bea8e50..1c794a3 100644 --- a/ebuild/fetchers/Makefile.am +++ b/ebuild/fetchers/Makefile.am @@ -1,6 +1,6 @@ ################################################################################ # Makefile.am -# Copyright (C) 2025 Cor Legemaat +# Copyright (C) 2025, 2026 Cor Legemaat # # This file is part of ebuild-autogen: you can redistribute it and/or modify it # under the terms of the GNU Affero General Public License as published by the @@ -22,6 +22,7 @@ SOURCES = \ forgejo.scm \ github.scm \ pypi.scm \ + npmjs.scm \ raw.scm # Manual dependencys. @@ -29,6 +30,7 @@ ebuild.go: ../version.scm forgejo.go: ../version.scm github.go: ../version.scm pypi.go: ../version.scm +npmjs.go: ../version.scm raw.scm: ../version.scm GOBJECTS = $(SOURCES:%.scm=%.go) diff --git a/ebuild/fetchers/forgejo.scm b/ebuild/fetchers/forgejo.scm index ecb4e43..8226d96 100644 --- a/ebuild/fetchers/forgejo.scm +++ b/ebuild/fetchers/forgejo.scm @@ -1,6 +1,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; forgejo.scm -;; Copyright (C) 2025 Cor Legemaat +;; Copyright (C) 2025, 2026 Cor Legemaat ;; ;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; under the terms of the GNU Affero General Public License as published by the @@ -17,6 +17,7 @@ (define-module (ebuild fetchers forgejo) #:use-module (ebuild defs) #:use-module (ebuild fetchers raw) + #:use-module (ebuild semver) #:use-module (ebuild utils) #:use-module (curl) #:use-module (json) @@ -58,11 +59,12 @@ (if responce (begin (check-forgejo-errors responce) (let ((scm-responce (json-string->scm responce))) - (if (< 100 (vector-length scm-responce)) - (vector-append (fetch-forgejo-pages url + (if (= 100 (vector-length scm-responce)) + (vector-append scm-responce + (fetch-forgejo-pages url auth-token verbosity - (+1 page))) + (1+ page))) (begin (if (>= verbosity verbosity-info) (pretty-print scm-responce)) scm-responce)))) @@ -143,6 +145,8 @@ (set! scm (json-string->scm json)) (assoc-set! release "version" version-final) (append release + (list (cons "version-values" + (semver->comps version-final))) (list (cons "repo-user" user)) (list (cons "repo-repo" repo)) ;;TODO append this with list of custom assets. @@ -178,6 +182,8 @@ (base-asset-url (string-append host "/" user "/" repo))) (assoc-set! tag "version" version-final) (append tag + (list (cons "version-values" + (semver->comps version-final))) (list (cons "repo-user" user)) (list (cons "repo-name" repo)) (list diff --git a/ebuild/fetchers/github.scm b/ebuild/fetchers/github.scm index c5474b9..1ec1e1f 100644 --- a/ebuild/fetchers/github.scm +++ b/ebuild/fetchers/github.scm @@ -1,6 +1,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; github.scm -;; Copyright (C) 2025 Cor Legemaat +;; Copyright (C) 2025, 2026 Cor Legemaat ;; ;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; under the terms of the GNU Affero General Public License as published by the @@ -18,6 +18,7 @@ #:use-module (ebuild defs) #:use-module (ebuild fetchers raw) #:use-module (ebuild utils) + #:use-module (ebuild semver) #:use-module (curl) #:use-module (json) #:use-module (ice-9 pretty-print) @@ -63,10 +64,12 @@ (if responce (begin (check-github-errors responce) (let ((scm-responce (json-string->scm responce))) - (if (< 100 (vector-length scm-responce)) - (vector-append (fetch-github-pages url + (if (= 100 (vector-length scm-responce)) + (vector-append scm-responce + (fetch-github-pages url + token verbosity - (+1 page))) + (1+ page))) (begin (if (>= verbosity verbosity-info) (pretty-print scm-responce)) scm-responce)))) @@ -156,6 +159,8 @@ (set! sha7 (string-take sha 7)) (assoc-set! release "version" version-final) (append release + (list (cons "version-values" + (semver->comps version-final))) (list (cons "sha" sha)) (list (cons "github-user" user)) (list (cons "github-repo" repo)) @@ -200,6 +205,8 @@ repo))) (assoc-set! tag "version" version-final) (append tag + (list (cons "version-values" + (semver->comps version-final))) (list (cons "github-user" user)) (list (cons "github-repo" repo)) (list (cons "sha7" sha7)) diff --git a/ebuild/fetchers/npmjs.scm b/ebuild/fetchers/npmjs.scm new file mode 100644 index 0000000..35ba8cd --- /dev/null +++ b/ebuild/fetchers/npmjs.scm @@ -0,0 +1,247 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; npmjs.scm +;; Copyright (C) 2025, 2026 Cor Legemaat +;; +;; This file is part of ebuild-autogen: you can redistribute it and/or modify it +;; under the terms of the GNU Affero General Public License as published by the +;; Free Software Foundation, version 3 of the License. +;; +;; ebuild-autogen 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 +;; ebuild-autogen. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-module (ebuild fetchers npmjs) + #:use-module (ebuild defs) + #:use-module (ebuild fetchers raw) + #:use-module (ebuild utils) + #:use-module (ebuild pkt-map) + #:use-module (ebuild semver) + #:use-module (curl) + #:use-module (json) + #:use-module (ice-9 pretty-print) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) + #:use-module (rx irregex) + #:use-module (dql dql)) + +(define fetch-npmjs-pkg + (lambda (pkg retries display-data) + "" + (let loop ((try 1)) + (let ((curl-handle (curl-easy-init))) + ;; Set the url to fetch. + (curl-easy-setopt curl-handle + 'url + (string-append "https://registry.npmjs.org/" + pkg + "/")) + ;; Set my user agent. + (curl-easy-setopt curl-handle 'useragent curl-useragent) + + ;; Set Connection Timeout in seconds + (curl-easy-setopt curl-handle 'connecttimeout 5) + + ;; Kill on a stalled connection. + (curl-easy-setopt curl-handle 'low-speed-limit 120) + (curl-easy-setopt curl-handle 'low-speed-time 12) + + (let* ((responce (curl-easy-perform curl-handle))) + (curl-easy-cleanup curl-handle) + + (cond ((string? responce) + (let ((scm-responce (json-string->scm responce))) + (begin (if display-data + (pretty-print scm-responce)) + scm-responce))) + ((<= try retries) + (sleep 10) + (loop (1+ try))) + (else (error (string-append "npmjs fetch failed with error " + (curl-error-string) + "\n"))))))))) + +(define extract-deps + (lambda (deps) + (append-map + (lambda (dep) + (let* ((alias (car dep)) + (pkg-match + (irregex-search '(seq (look-behind (seq "npm:")) + (? "@") + (look-ahead (seq "@" + (? (or "^" "~" "<" ">" + "<=" ">=" "*" + "=" "==")) + (? space) + (+ num)))) + (cdr dep))) + (alt-slot-match + (irregex-search '(seq (look-behind (or bos "@" space) + (? (or "^" ">=" "<=" ">" "<"))) + (* num) + (? "." (+ num)) ;; bugged spec... + (look-ahead (seq "." (or "*" "x")))) + (cdr dep))) + (alt-sub-slot-match + (irregex-search '(seq (look-behind (or bos "@" space) + (? (or "~" ">=" "<=" ">" "<"))) + (* num) "." (+ num) + (look-ahead (seq "." (or "*" "x")))) + (cdr dep))) + (vers-match + (cond (alt-slot-match + (list (string-append "^" + (irregex-match-substring + alt-slot-match)))) + (alt-sub-slot-match + (list (string-append "~" + (irregex-match-substring + alt-sub-slot-match)))) + (else (irregex-extract + '(seq (look-behind (or bos "@" space)) + (? (or "^" "~" "<" ">" "<=" ">=" "*" "=" "==")) + (? space) + (* num) + (* (or (seq "." (+ num)) + (seq "-" (+ alphanum)))) + (look-ahead (or (seq "+" + (+ (or alphanum "-")) + eos) + (seq (+ space) eos) + eos))) + (cdr dep)))))) + (if (or (null? vers-match) + (every (lambda (answ) + (string=? answ "")) + vers-match)) + (set! vers-match (list "*"))) + (map (lambda (vers) + (if (string=? vers "") + '() + (list (cons "alias" alias) + (cons "pkg" (if pkg-match + (irregex-match-substring pkg-match) + alias)) + (cons "version" vers)))) + vers-match))) + deps))) + +(define-public fetch-npmjs + (lambda* (parms #:key + (npm-name (if (assoc-ref parms 'npm-name) + (assoc-ref parms 'npm-name) + (assoc-ref parms 'name))) + (file-types (list ".tgz")) + (version-filter (lambda (version) + (semver->irregex-match version))) + (version-alter (lambda (version) version)) + (version-values (lambda (version) + (semver->comps version))) + (dep-alter (lambda (dep) dep)) + (display-data #f)) + "" + (let* ((data (fetch-npmjs-pkg npm-name + (assoc-ref parms 'curl-retries) + display-data)) + (versions (assoc-ref data "versions")) + (pkt-map-db (pkt-map-load (assoc-ref parms 'repo) "nodejs"))) + ;;(display "pkt-map-db-pre:") (newline) + ;;(pretty-print pkt-map-db) + (set! pkt-map-db + (pkt-map-set pkt-map-db + npm-name + (assoc-ref parms 'category) + (assoc-ref parms 'name))) + ;;(display "pkt-map-db-post:") (newline) + ;;(pretty-print pkt-map-db) + (pkt-map-write pkt-map-db + (assoc-ref parms 'repo) + "nodejs") + (filter-map + (lambda (version) + (let* ((my-data (car ((dql (select (parm "version") + (parm-as "sha256" "dist" "shasum") + (parm-as "uri" "dist" "tarball") + (parm-as "node" "_nodeVersion") + (parm-as "npm" "_npmVersion") + (parm "dependencies") + (parm "license") + (parm "homepage") + (parm "description")) + ;;#:print-query npmjs-data + ) + (cdr version)))) + (version-match (version-filter (assoc-ref my-data + "version")))) + ;; (display "my-data:") (newline) + ;; (pretty-print my-data) + (if (version-filter (assoc-ref my-data "version")) + (append + (list (cons "version" + (version-alter (assoc-ref my-data + "version")))) + (list (cons "version-values" + (semver->comps (assoc-ref my-data + "version") + #:vers-match version-match))) + (if (assoc-ref my-data "node") + (list (assoc "node" my-data)) + '()) + (if (assoc-ref my-data "npm") + (list (assoc "npm" my-data)) + '()) + (list (cons "npm-name" npm-name)) + (let ((license (if (list? (assoc-ref my-data "license")) + (assoc-ref (assoc-ref my-data "license") + "type") + (assoc-ref my-data "license")))) + (cond + ((not license) '()) + ((string=? license "UNLICENSED") + (list (cons "license" "Unlicense"))) + ((string=? license "BSD-3-Clause") + (list (cons "license" "BSD"))) + ((string=? license "BSD-2-Clause") + (list (cons "license" "BSD-2"))) + ((string=? license "Python-2.0") + (list (cons "license" "PYTHON"))) + (else (list (cons "license" license))))) + (if (assoc-ref my-data "homepage") + (list (assoc "homepage" my-data)) + '()) + (if (assoc-ref my-data "description") + (list (cons "description" + (irregex-replace/all + `(or #\` #\") + (assoc-ref my-data "description") + "'"))) + '()) + (if (and (assoc-ref my-data "dependencies") + (not (null? (assoc-ref my-data "dependencies")))) + (list (cons "dependencies" + (extract-deps (filter-map + (lambda (dep) + (dep-alter dep)) + (assoc-ref my-data + "dependencies"))))) + (list)) + (list + (cons "assets" + (list + (append (list (assoc "sha256" my-data)) + (list (assoc "uri" my-data)) + (list (cons "type" ".tgz")) + (list (cons "name" + (string-append + "npm-" + (assoc-ref parms 'name) + "-" + (assoc-ref my-data "version") + ".tgz")))))))) + #f))) + versions)))) diff --git a/ebuild/fetchers/pypi.scm b/ebuild/fetchers/pypi.scm index c75d338..06863ae 100644 --- a/ebuild/fetchers/pypi.scm +++ b/ebuild/fetchers/pypi.scm @@ -1,6 +1,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; pypi.scm -;; Copyright (C) 2025 Cor Legemaat +;; Copyright (C) 2025, 2026 Cor Legemaat ;; ;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; under the terms of the GNU Affero General Public License as published by the @@ -17,6 +17,7 @@ (define-module (ebuild fetchers pypi) #:use-module (ebuild defs) #:use-module (ebuild fetchers raw) + #:use-module (ebuild semver) #:use-module (ebuild utils) #:use-module (curl) #:use-module (json) @@ -61,28 +62,32 @@ (let* ((data (fetch-pypi-pkg pypi-name display-data)) (versions (vector->list (assoc-ref data "versions"))) (files (assoc-ref data "files"))) - (map (lambda (version) - (let ((upload-date (car ((dql (select (filter (where (lambda (file-name) - (if (string? file-name) - (string-contains file-name - (string-append "-" - version - (car file-types))) - #f)) - "filename")) - (parm-as "date" "upload-time"))) - files)))) + (filter-map + (lambda (version) + (if (semver->irregex-match version) + (let ((upload-date ((dql (select (filter (where (lambda (file-name) + (if (string? file-name) + (string-contains file-name + (string-append "-" + version + (car file-types))) + #f)) + "filename")) + (parm-as "date" "upload-time"))) + files))) (if (nil? upload-date) - (if (>= (assoc-ref parms 'verbosity) - verbosity-error) - (begin (display "Upload file \"") - (display (string-append "-" - version - (car file-types))) - (display "\" not found, skipping release!") - (newline))) + (begin (if (>= (assoc-ref parms 'verbosity) + verbosity-error) + (begin (display "Upload file for version \"") + (display version) + (display "\" and type \"") + (display (car file-types)) + (display "\" not found, skipping release!") + (newline))) + #f) (list (cons "version" version) - (car upload-date) + (cons "version-values" (semver->comps version)) + (car (car upload-date)) (cons "assets" (map (lambda (type) (append (car ((dql (select (filter (where (lambda (file-name) @@ -98,5 +103,6 @@ (parm "hashes" "sha256"))) files)) (list (cons "type" type)))) - file-types)))))) + file-types))))) + #f)) versions)))) diff --git a/ebuild/fetchers/raw.scm b/ebuild/fetchers/raw.scm index ad05c46..406b358 100644 --- a/ebuild/fetchers/raw.scm +++ b/ebuild/fetchers/raw.scm @@ -1,6 +1,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; raw.scm -;; Copyright (C) 2025 Cor Legemaat +;; Copyright (C) 2025, 2026 Cor Legemaat ;; ;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; under the terms of the GNU Affero General Public License as published by the @@ -17,6 +17,7 @@ (define-module (ebuild fetchers raw) #:use-module (ebuild defs) #:use-module (ebuild utils) + #:use-module (ebuild semver) #:use-module (curl) #:use-module (rx irregex) #:use-module (ice-9 pretty-print) @@ -41,6 +42,7 @@ (let ((version (version-alter (extract-version release)))) (if (version-filter version) (list (cons "version" version) + (cons "version-values" (semver->comps version)) (cons "assets" (map (lambda (type) @@ -104,13 +106,12 @@ (lambda (release type) "" (let* ((my-file-data - (car ((dql (select (filter (select (parm-val "assets")) - (where (lambda (x) - (string=? x type)) - "type")) - (parm "uri") - (parm "name"))) - release))) + (car ((dql (select (filter (where (lambda (x) + (string=? x type)) + "type")) + (parm "uri") + (parm "name"))) + (assoc-ref release "assets")))) (uri (assoc-ref my-file-data "uri")) (name (assoc-ref my-file-data "name")) (file-path (string-append (assoc-ref release 'cache-path) diff --git a/ebuild/gen.scm b/ebuild/gen.scm index 86617c8..b7bb3fb 100644 --- a/ebuild/gen.scm +++ b/ebuild/gen.scm @@ -1,6 +1,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; gen.scm -;; Copyright (C) 2025 Cor Legemaat +;; Copyright (C) 2025, 2026 Cor Legemaat ;; ;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; under the terms of the GNU Affero General Public License as published by the @@ -17,29 +17,50 @@ (define-module (ebuild gen) #:use-module (ebuild utils) #:use-module (ebuild defs) + #:use-module (ebuild semver) + #:use-module (ebuild state) #:use-module (dql dql) #:use-module (rx irregex) #:use-module (ice-9 pretty-print) + #:use-module (ice-9 receive) #:use-module (ice-9 string-fun) #:use-module (ice-9 textual-ports) - #:use-module (srfi srfi-1)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19)) ;;Function to generate template from ebuild with variable substitution. (define-public ebuild-from-tmpl (lambda* (vars verbosity #:key - (tmpl (string-append (assoc-ref vars 'name) ".tmpl")) + (tmpl #f) ignore-diff) "" (letrec* - ((input-port (open-input-file (string-join (list (assoc-ref vars 'repo) - "autogen" - (assoc-ref vars 'category) - (assoc-ref vars 'name) - tmpl) - file-name-separator-string))) - (data (append (list "# Auto generated from autogen.scm") + ((pkg-tmpl (string-join (list (assoc-ref vars 'repo) + "autogen" + (assoc-ref vars 'category) + (assoc-ref vars 'name) + (string-append (assoc-ref vars 'name) + ".tmpl")) + file-name-separator-string)) + (cat-tmpl (string-join (list (assoc-ref vars 'repo) + "autogen" + (assoc-ref vars 'category) + (string-append (assoc-ref vars 'category) + ".tmpl")) + file-name-separator-string)) + (input-port (open-input-file + (cond (tmpl tmpl) + ((file-exists? pkg-tmpl) pkg-tmpl) + ((file-exists? cat-tmpl) cat-tmpl) + (else + (error "No pkg or category template found!"))))) + (data (append (list (string-append + "# Copyright (C) " + (number->string (date-year (current-date))) + " auto generated from autogen.scm")) ;; Remove mode-line of tmpl file. - (let ((raw (string-split (get-string-all input-port) #\lf))) + (let ((raw (string-split (get-string-all input-port) + #\lf))) (if (irregex-search '(seq (+ "#") (+ space) "-*-" @@ -55,35 +76,54 @@ "[" (number->string no) "]") - (car data)) + (if (null? data) '() (car data))) (if (not (null? (cdr data))) (traverse-list pre (1+ no) (cdr data))))) (traverse-alist (lambda (pre data) - (for-each (lambda (var) - (if (and (string? (car var)) - (string? (cdr var))) - (replace (if (eq? (string-length pre) 0) - (car var) - (string-append pre - "." - (car var))) - (cdr var)) - (traverse (if (eq? (string-length pre) 0) - (car var) - (string-append pre - "." - (car var))) - (cdr var)))) - data))) + (if (not (eq? pre 'dep-graph)) + (for-each + (lambda (var) + (if (and (or (string? (car var)) + (symbol? (car var))) + (or (string? (cdr var)) + (symbol? (cdr var)))) + (replace (if (eq? (string-length pre) 0) + (if (symbol? (car var)) + (symbol->string (car var)) + (car var)) + (string-append pre + "." + (if (symbol? (car var)) + (symbol->string (car var)) + (car var)))) + (if (symbol? (cdr var)) + (symbol->string (cdr var)) + (cdr var))) + (traverse (if (eq? (string-length pre) 0) + (if (symbol? (car var)) + (symbol->string (car var)) + (car var)) + (string-append pre + "." + (if (symbol? (car var)) + (symbol->string (car var)) + (car var)))) + (cdr var)))) + data)))) (traverse (lambda (pre data) - (cond ((alist? data) - (traverse-alist pre data)) + (cond ((null? data) '()) + ((alist? data) + (traverse-alist pre data)) ((list? data) (traverse-list pre 0 data)) ((number? data) (replace pre (number->string data))) ((string? data) (replace pre data)) + ((eqv? #f data) (replace pre "false")) + ((eqv? #t data) (replace pre "true")) + ((time? data) + (replace pre (number->string (time-second data)))) (else (error (string-append "Error! Don't know how " "to process \"" (object->string data) @@ -103,7 +143,30 @@ (string-replace-substring line var-str val)) - data)))))) + data))))) + (final-ebuild + (lambda (ebuild) + (state-write (state-set + (state-load (assoc-ref vars 'repo) + (assoc-ref vars 'category) + (assoc-ref vars 'name)) + (assoc-ref vars 'constraint) + ebuild + (comps->genver (assoc-ref vars "version-values")) + '()) + (assoc-ref vars 'repo) + (assoc-ref vars 'category) + (assoc-ref vars 'name)) + (list (list (cons 'category (assoc-ref vars 'category)) + (cons 'name (assoc-ref vars 'name)) + (cons 'pkgfiles + (append (if (assoc-ref vars 'pkgfiles) + (assoc-ref vars 'pkgfiles) + '()) + (list ebuild))) + (cons 'distfiles (if (assoc-ref vars 'distfiles) + (assoc-ref vars 'distfiles) + '()))))))) (traverse "" vars) (let* ((folder-out (string-join (list (assoc-ref vars 'repo) (assoc-ref vars 'category) @@ -111,154 +174,102 @@ file-name-separator-string)) (rel (last-ebuild-rel folder-out (assoc-ref vars 'name) - (assoc-ref vars "version"))) + (comps->genver (assoc-ref vars + "version-values")))) (ebuild-name (lambda (rel) - (string-append (assoc-ref vars 'name) - "-" - (assoc-ref vars "version") - (if (< 0 rel) - (string-append "-r" - (number->string rel)) - "") - ".ebuild")))) + (string-append + (assoc-ref vars 'name) + "-" + (comps->genver (assoc-ref vars "version-values")) + (if (< 0 rel) + (string-append "-r" + (number->string rel)) + "") + ".ebuild")))) (if (file-exists? (string-join (list folder-out (ebuild-name rel)) file-name-separator-string)) (if (and (not ignore-diff) (diff? data - (let* ((port-ebuild (open-input-file - (string-join (list folder-out - (ebuild-name rel)) - file-name-separator-string))) - (data-ebuild (get-string-all port-ebuild))) - (close port-ebuild) - (string-split data-ebuild #\newline)) - #:allow (lambda (a b) - (let* ((rx '(seq bos "#")) - (match-a (irregex-search rx a)) - (match-b (irregex-search rx b))) - (if (and match-a match-b) - #false #true))))) + (let* ((port-ebuild + (open-input-file + (string-join (list folder-out + (ebuild-name rel)) + file-name-separator-string))) + (data-ebuild (get-string-all port-ebuild))) + (close port-ebuild) + (string-split data-ebuild #\newline)) + #:allow (lambda (a b) + (let* ((rx '(seq bos "#")) + (match-a (irregex-search rx a)) + (match-b (irregex-search rx b))) + (if (and match-a match-b) + #false #true))) + #:print-delta (>= verbosity verbosity-info))) + ;; Data the same. (let ((output-port (open-output-file (string-join (list folder-out (ebuild-name (1+ rel))) file-name-separator-string)))) (display (string-join data "\n") output-port) (close output-port) - ;;(display "data-diff!!!") (newline) - (ebuild-name (1+ rel))) - (ebuild-name rel)) + (final-ebuild (ebuild-name (1+ rel)))) + ;; Data differs. + (final-ebuild (ebuild-name rel))) (let ((output-port (open-output-file (string-join (list folder-out (ebuild-name rel)) file-name-separator-string)))) (display (string-join data "\n") output-port) (close output-port) - (ebuild-name rel))))))) - -;; filter keep components -(define-public ebuild-fkc - (lambda (vlist-in comps-in) - "" - (letrec* - ((base (lambda (vlist comps) - (if (null? comps) - (cdr (car vlist)) - (let ((clist (sort (delete-duplicates - (map (lambda (vers) - (if (null? (car vers)) - -1 - (car (car vers)))) - vlist)) - <))) - (map (lambda (vcomp) - (append-map - (lambda (sts) - (cond ((string? sts) - (list (list vcomp) sts)) - ((null? (car sts)) - (append (list vcomp) (cdr sts))) - ((not (list? (car (car sts)))) - (list (list (append (list vcomp) - (car sts)) - (second sts)))) - (else - (map (lambda (tst) - (list (append (list vcomp) - (car tst)) - (second tst))) - sts)))) - (base (map (lambda (ver) - (list (if (null? (car ver)) - '() - (cdr (car ver))) - (car (cdr ver)))) - (filter (lambda (vers) - (= vcomp - (if (null? (car vers)) - -1 - (car (car vers))))) - vlist)) - (cdr comps)))) - (take-right clist - (min (length clist) - ;; 0=all. - (if (zero? (car comps)) - (length clist) - (car comps)))))))))) - ;;Works, but probably only for 3 components so shit solution. - (append-map (lambda (vmaj) - vmaj) - (base vlist-in comps-in))))) - -(define default-version-components - (lambda (version) - "" - (map (lambda (component) - (string->number component)) - (irregex-split #\. - (irregex-match-substring - (irregex-search '(seq (+ num) (+ (seq "." (+ num)))) - version)))))) + (final-ebuild (ebuild-name rel)))))))) (define-public ebuild-version-filter (lambda* (releases #:key (keep-components (if (assoc-ref releases 'keep-vers-comps) (assoc-ref releases 'keep-vers-comps) (list 1 1 1))) - (version-components default-version-components) (keep (lambda (version) #f)) (drop (lambda (version) #f))) "" (let* ((vlist (map (lambda (release) - (list (version-components (assoc-ref release - "version")) - (assoc-ref release "version"))) + (assoc-ref release "version-values")) releases)) (vlist-filtered (append (filter (lambda (vers) - (if (keep (second vers)) vers #f)) + (if (keep vers) vers #f)) vlist) - (filter (lambda (vers) - (if (drop (second vers)) #f vers)) - (ebuild-fkc vlist keep-components))))) + (semver-keep (filter (lambda (vers) + (if (drop vers) #f vers)) + vlist) + keep-components)))) (filter-map (lambda (rel) (if (any (lambda (vers) - (string= (assoc-ref rel "version") - (second vers))) + (semver-eq? (assoc-ref rel "version-values") + vers)) vlist-filtered) - (append (list (cons "version-components" - (version-components - (assoc-ref rel - "version")))) - rel) + rel #f)) releases)))) +(define allow-keyword-comment-diff + (lambda (a b) + (let* ((rx '(or (seq bos "#") + (seq bos + "KEYWORDS=\"" + (+ (or alphanumeric whitespace #\- #\~)) + "\"" + eos))) + (match-a (irregex-search rx a)) + (match-b (irregex-search rx b))) + (if (and match-a match-b) + #false #true)))) + (define-public ebuild-cp-man (lambda (parms) "" - (let* ((folder-in (string-join (list (assoc-ref parms 'repo) + (let* ((genver (comps->genver (assoc-ref parms "version-values"))) + (folder-in (string-join (list (assoc-ref parms 'repo) "autogen" (assoc-ref parms 'category) (assoc-ref parms 'name)) @@ -269,19 +280,30 @@ file-name-separator-string)) (rel-in (last-ebuild-rel folder-in (assoc-ref parms 'name) - (assoc-ref parms "version"))) + genver)) (rel-out (last-ebuild-rel folder-out (assoc-ref parms 'name) - (assoc-ref parms "version"))) + genver)) (ebuild-name (lambda (rel) (string-append (assoc-ref parms 'name) "-" - (assoc-ref parms "version") + genver (if (< 0 rel) (string-append "-r" (number->string rel)) "") - ".ebuild")))) + ".ebuild"))) + (return (lambda (rel) + (list (list (cons 'category (assoc-ref parms 'category)) + (cons 'name (assoc-ref parms 'name)) + (cons 'pkgfiles + (append (if (assoc-ref parms 'pkgfiles) + (assoc-ref parms 'pkgfiles) + '()) + (list (ebuild-name rel)))) + (cons 'distfiles (if (assoc-ref parms 'distfiles) + (assoc-ref parms 'distfiles) + '()))))))) (if rel-in (let ((path-in (string-join (list folder-in (ebuild-name rel-in)) @@ -302,70 +324,67 @@ (close port-in) (close port-out) (if (diff? data-in data-out - #:allow (lambda (a b) - (let* ((rx '(or (seq bos "#") - (seq bos - "KEYWORDS=\"" - (+ (or alphanumeric whitespace #\- #\~)) - "\"" - eos))) - (match-a (irregex-search rx a)) - (match-b (irregex-search rx b))) - (if (and match-a match-b) - #false #true)))) - (let ((output-port (open-output-file - (string-join (list folder-out - (ebuild-name (1+ rel-out))) - file-name-separator-string)))) + #:allow allow-keyword-comment-diff + #:print-delta (>= (assoc-ref parms "verbosity") + verbosity-info)) + (let ((output-port + (open-output-file + (string-join (list folder-out + (ebuild-name (1+ rel-out))) + file-name-separator-string)))) (display data-in output-port) (close output-port) - (string-join (list folder-out - (ebuild-name (1+ rel-out))) - file-name-separator-string)) + (return (1+ rel-out))) (if (diff? data-in data-out - #:allow (lambda (a b) - (let* ((rx '(seq bos - "KEYWORDS=\"" - (+ (or alphanumeric whitespace #\- #\~)) - "\"" - eos)) - (match-a (irregex-search rx a)) - (match-b (irregex-search rx b))) - (if (and match-a match-b) - #false #true)))) + #:allow allow-keyword-comment-diff + #:print-delta (>= (assoc-ref parms "verbosity") + verbosity-info)) (let ((output-port (open-output-file - (string-join (list folder-out - (ebuild-name rel-out)) - file-name-separator-string)))) + (return rel-out)))) (display data-in output-port) (close output-port) - (string-join (list folder-out - (ebuild-name rel-out)) - file-name-separator-string)) - #false))) - #false)) - #false)))) + (return rel-out)) + '()))) + '())) + '())))) + +(define-public ebuild-default-post + (lambda (ebuilds parms) + ;; (display "parms:") (newline) + ;; (pretty-print parms) + ;; (display "ebuild-created:") (newline) + ;; (pretty-print ebuilds) + (let* ((out-file (lambda (ebuild) + (string-join (list (assoc-ref parms 'repo) + (assoc-ref parms 'category) + (assoc-ref parms 'name) + ebuild) + file-name-separator-string))) + (run-post (lambda (ebuild) + (if (not (file-exists? (out-file ebuild))) + (error (string-append "Ebuild \"" + (out-file ebuild) + "\" does not exists!!!"))) + (if (string-suffix? ".ebuild" (out-file ebuild)) + (system* "ebuild" (out-file ebuild) "manifest"))))) + (cond ((null? ebuilds) '()) + ((assoc-ref ebuilds 'pkg-files) + (map run-post (assoc-ref ebuilds 'pkgfiles))) + ((assoc-ref (car ebuilds) 'pkgfiles) + (map run-post (assoc-ref (car ebuilds) 'pkgfiles)))) + ebuilds))) ;;Procedure to generate the required ebuild from the given releases. (define-public ebuild-gen (lambda* (parms releases #:key - (version-components (lambda (version) - (map (lambda (component) - (string->number component)) - (string-split version #\.)))) - (keep-components (list 1 1 2)) + (keep-components (if (assoc-ref parms 'keep-vers-comps) + (assoc-ref parms 'keep-vers-comps) + (list 1 1 1))) (keep (lambda (version) #f)) (drop (lambda (version) #f)) - (template (string-append (assoc-ref parms 'name) ".tmpl")) - (post-hook (lambda (ebuild vars) - (system* "ebuild" - (string-join (list (assoc-ref parms 'repo) - (assoc-ref parms 'category) - (assoc-ref parms 'name) - ebuild) - file-name-separator-string) - "manifest") - '())) + (template #f) + (gen-ebuild-hook ebuild-from-tmpl) + (post-hook ebuild-default-post) ignore-autogen-diff) "" (if (>= (assoc-ref parms 'verbosity) verbosity-notice) @@ -373,36 +392,32 @@ (pretty-print releases))) (letrec* ((version-list (map (lambda (release) - (list (version-components (assoc-ref release "version")) - (assoc-ref release "version"))) + (assoc-ref release "version-values")) releases)) - (selected-versions (ebuild-fkc version-list keep-components)) - (distfiles '()) - (ebuilds (filter-map - (lambda (vers) - (let* ((vars (append (car (filter (lambda (rel) - (string= (assoc-ref rel "version") - (second vers))) - releases)) - parms)) - (ebuild-man (ebuild-cp-man vars)) - (ebuild-created (if (and (not ebuild-man) - (not (drop (second vers))) - (or (find (lambda (test-vers) - (string= (second test-vers) - (second vers))) - selected-versions) - (keep (second vers)))) - (ebuild-from-tmpl - vars - (assoc-ref parms 'verbosity) - #:tmpl template - #:ignore-diff ignore-autogen-diff) - ebuild-man))) - (if ebuild-created - (set! distfiles - (append distfiles - (post-hook ebuild-created vars)))) - ebuild-created)) - version-list))) - (values ebuilds distfiles)))) + (selected-versions (semver-keep version-list keep-components)) + (ebuilds (append-map (lambda (vers) + (let* ((vars (append + (car (filter + (lambda (rel) + (equal? (assoc-ref rel + "version-values") + vers)) + releases)) + parms)) + (ebuild-man (ebuild-cp-man vars)) + (ebuild-created + (if (and (null? ebuild-man) + (not (drop vers)) + (or (find + (lambda (test-vers) + (semver-eq? test-vers vers)) + selected-versions) + (keep vers))) + (gen-ebuild-hook vars + (assoc-ref parms 'verbosity) + #:tmpl template + #:ignore-diff ignore-autogen-diff) + ebuild-man))) + (post-hook ebuild-created vars))) + version-list))) + ebuilds))) diff --git a/ebuild/gen/Makefile.am b/ebuild/gen/Makefile.am new file mode 100644 index 0000000..9f8b1e2 --- /dev/null +++ b/ebuild/gen/Makefile.am @@ -0,0 +1,51 @@ +################################################################################ +# Makefile.am +# Copyright (C) 2025, 2026 Cor Legemaat +# +# This file is part of ebuild-autogen: you can redistribute it and/or modify it +# under the terms of the GNU Affero General Public License as published by the +# Free Software Foundation, version 3 of the License. + +# ebuild-autogen 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 +# ebuild-autogen. If not, see . +################################################################################ + +moddir=$(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION)/ebuild/gen +objdir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache/ebuild/gen + +SOURCES = \ + nodejs.scm + +# Manual dependencys. +nodejs.go: ../version.scm + +GOBJECTS = $(SOURCES:%.scm=%.go) + +nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) +nobase_obj_DATA = $(GOBJECTS) + +# Make sure source files are installed first, so that the mtime of +# installed compiled files is greater than that of installed source +# files. See +# +# for details. +guile_install_obj_files = install-nobase_obj_DATA +$(guile_install_obj_files): install-nobase_mod_DATA + +EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) + +CLEANFILES = $(GOBJECTS) + +GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat +GUILE_OPTS = -L $(abs_top_builddir) +SUFFIXES = .scm .go +.scm.go: + $(GUILD) compile $(GUILE_TARGET) $(GUILE_OPTS) $(GUILE_WARNINGS) -o "$@" "$<" + +# Build dep in parent folder. +../version.scm: + $(am__cd) ../ && $(MAKE) $(AM_MAKEFLAGS) version.scm diff --git a/ebuild/gen/nodejs.scm b/ebuild/gen/nodejs.scm new file mode 100644 index 0000000..2322ca3 --- /dev/null +++ b/ebuild/gen/nodejs.scm @@ -0,0 +1,371 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; nodejs.scm +;; Copyright (C) 2025, 2026 Cor Legemaat +;; +;; This file is part of ebuild-autogen: you can redistribute it and/or modify it +;; under the terms of the GNU Affero General Public License as published by the +;; Free Software Foundation, version 3 of the License. +;; +;; ebuild-autogen 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 +;; ebuild-autogen. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-module (ebuild gen nodejs) + #:use-module (ebuild utils) + #:use-module (ebuild defs) + #:use-module (ebuild gen) + #:use-module (ebuild pkt-map) + #:use-module (ebuild state) + #:use-module (ebuild repo) + #:use-module (ebuild semver) + #:use-module (ebuild fetchers npmjs) + #:use-module (dql dql) + #:use-module (rx irregex) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 receive) + #:use-module (ice-9 string-fun) + #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19)) + +(define get-constraints + (lambda (spec) + "" + (let ((raw (irregex-extract '(seq (or bos (look-behind space)) + (? (or "^" "~" "*" "<" ">" "=" + ">=" "<=" "==")) + (* space) + (+ num) + (* (seq "." (+ num))) + (? (seq "-" (+ alphanum) (* "." (+ num))))) + spec))) + ;; Return method, slot depth, comps + (map (lambda (const) + (cond ((string-prefix? "^" const) + ;; Major match minor and patch higher than. + (list (cons 'type '=) + (cons 'slot-level 1) + (cons 'components + (take (semver->comps (string-drop const 1)) 1)))) + ((string-prefix? "~" const) + ;; Major and minor match, patch higher than. + (list (cons 'type '=) + (cons 'slot-level 2) + (cons 'components + (take (semver->comps (string-drop const 1)) 2)))) + ((string-prefix? "*" const) + ;; Any version. + (list (cons 'type '()) + (cons 'slot-level 0) + (cons 'components '()))) + ((string-prefix? ">=" const) + ;; Newer then. + (list (cons 'type '>=) + (cons 'slot-level 0) + (cons 'components + (semver->comps (string-drop const 2))))) + ((string-prefix? "<=" const) + ;; Newer then. + (list (cons 'type '<=) + (cons 'slot-level 0) + (cons 'components + (semver->comps (string-drop const 2))))) + ((string-prefix? "<" const) + ;; Newer then. + (list (cons 'type '<) + (cons 'slot-level 0) + (cons 'components + (semver->comps (string-drop const 1))))) + ((string-prefix? ">" const) + ;; Newer then. + (list (cons 'type '>) + (cons 'slot-level 0) + (cons 'components + (semver->comps (string-drop const 1))))) + ((string-prefix? "=" const) + ;; Newer then. + (list (cons 'type '=) + (cons 'slot-level + (length (semver->comps (string-drop const 1)))) + (cons 'components + (semver->comps (string-drop const 1))))) + (else + ;; Exact version. + (list (cons 'type '=) + (cons 'slot-level + (length (semver->comps const))) + (cons 'components (semver->comps const)))))) + raw)))) + +(define replace-npm-folder + (lambda (npm-name) + "" + (let ((folder-match (irregex-search `(seq (look-behind (seq bos "@")) + (+ (or alphanum #\- #\_ #\.)) + (look-ahead "/")) + npm-name))) + (if folder-match + (irregex-replace `(seq bos "@" (+ (or alphanum #\- #\_ #\.)) "/") + npm-name + (string-append (irregex-match-substring folder-match) + "+")) + npm-name)))) + +(define setup-nodejs-dep + (lambda (dep parms pkt-map-db) + "" + (if (>= (assoc-ref parms 'verbosity) verbosity-warn) + (begin (display "dep:") (newline) + (pretty-print dep))) + (let* ((nodejs-ebuilds '()) + (last-release-comps '()) + (dep-vers (assoc-ref dep "version")) + (constraints (get-constraints dep-vers)) + (dep-name (irregex-replace/all + '(seq #\- (look-ahead num)) + (irregex-replace/all #\. + (replace-npm-folder + (assoc-ref dep "pkg")) + "-dot-") + "-num")) + (pkt-map (let ((answ (pkt-map-get pkt-map-db + (assoc-ref dep "pkg")))) + (if (null? answ) + #f + (car answ)))) + (dep-mod (if pkt-map + (begin (setup-pkg + (list (assoc 'repo parms) + (assoc 'verbosity parms) + (assoc 'category pkt-map) + (cons 'name (assoc-ref pkt-map 'pkg)))) + (resolve-module + `(,(string->symbol (assoc-ref pkt-map 'category)) + ,(string->symbol (assoc-ref pkt-map 'pkg)) + autogen))) + (begin (setup-pkg + (list (assoc 'repo parms) + (assoc 'verbosity parms) + (cons 'category "dev-nodejs") + (cons 'name dep-name))) + (resolve-module + `(,(string->symbol "dev-nodejs") + ,(string->symbol dep-name) + autogen))))) + (dep-parms (let ((answ (alist-copy parms)) + (dep-graph (assoc-ref parms 'dep-graph))) + (set! answ (assoc-set! answ + 'category + (if pkt-map + (assoc-ref pkt-map 'category) + "dev-nodejs"))) + (set! answ (assoc-set! answ + 'name + (if pkt-map + (assoc-ref pkt-map 'pkg) + dep-name))) + (set! answ (assoc-set! answ + 'constraint + constraints)) + (set! answ + (assoc-set! answ + 'dep-graph + (if dep-graph + (append dep-graph + (list (cons (assoc-ref answ + 'name) + constraints))) + (list (cons (assoc-ref parms 'name) + '()) + (cons (assoc-ref answ 'name) + constraints))))) + (set! answ (assoc-set! answ + 'npm-name + (assoc-ref dep "pkg"))) + (set! answ (assoc-remove! answ "dependencies")) + (set! answ (assoc-remove! answ "version")) + (set! answ (assoc-remove! answ "version-values")) + (set! answ (assoc-remove! answ 'pkgfiles)) + (set! answ (assoc-remove! answ "assets")) + (set! answ (assoc-remove! answ "npm-name")) + (set! answ (assoc-remove! answ "homepage")) + (set! answ (assoc-remove! answ "description")) + (set! answ (assoc-remove! answ "license")) + (set! answ (assoc-remove! answ "node")) + (set! answ (assoc-remove! answ "npm")) + (if (>= (assoc-ref parms 'verbosity) verbosity-warn) + (begin (display "dep-vars:") (newline) + (pretty-print answ))) + answ)) + (state-db (state-load (assoc-ref dep-parms 'repo) + (assoc-ref dep-parms 'category) + (assoc-ref dep-parms 'name))) + (dep-state (state-get state-db constraints))) + (if (>= (assoc-ref parms 'verbosity) verbosity-warn) + (begin (display "dep-state:") (newline) + (pretty-print dep-state))) + (if (and (or (nil? dep-state) + (timetime-utc (assoc-ref dep-state 'date)) + (assoc-ref parms 'age-limit))) + (not (member (cons (assoc-ref dep-parms 'name) ;; recursive dep. + constraints) + (if (assoc-ref parms 'dep-graph) + (assoc-ref parms 'dep-graph) + '())))) + (let ((dep-releases + (semver-constrain + (if (and dep-mod + (module-variable dep-mod 'get-releases)) + ((module-ref dep-mod 'get-releases) + dep-parms) + (fetch-npmjs dep-parms)) + constraints))) + (set! last-release-comps (if (not (null? dep-releases)) + (assoc-ref (car dep-releases) + "version-values") + '())) + (set! nodejs-ebuilds + (append nodejs-ebuilds + (if (and dep-mod + (module-variable dep-mod 'generate-ebuilds)) + ((module-ref dep-mod 'generate-ebuilds) + dep-parms + dep-releases) + (ebuild-gen dep-parms + dep-releases))))) + (set! nodejs-ebuilds + (append nodejs-ebuilds + (list + (list + (cons 'category (assoc-ref dep-parms 'category)) + (cons 'name (assoc-ref dep-parms 'name)) + (cons 'pkgfiles + (append (if (assoc-ref dep-parms 'pkgfiles) + (assoc-ref dep-parms 'pkgfiles) + '()) + (list (assoc-ref dep-state 'ebuild)))) + (cons 'distfiles (if (assoc-ref dep-parms 'distfiles) + (assoc-ref dep-parms 'distfiles) + '()))))))) + (if (>= (assoc-ref parms 'verbosity) verbosity-warn) + (begin (display "dep-version:") (display dep-vers) (newline))) + (values + ;; Dependencys. + (let ((pkg-name (string-append (if pkt-map + (assoc-ref pkt-map 'category) + "dev-nodejs") + "/" + (if pkt-map + (assoc-ref pkt-map 'pkg) + dep-name)))) + (map (lambda (const) + (string-append + (if (null? (assoc-ref const 'type)) + "" + (symbol->string (assoc-ref const 'type))) + pkg-name + "-" + (comps->genver (if (positive? (assoc-ref const 'slot-level)) + (if (> (length (assoc-ref const 'components)) + (assoc-ref const 'slot-level)) + (take (assoc-ref const 'components) + (assoc-ref const 'slot-level)) + (assoc-ref const 'components)) + (assoc-ref const 'components))) + (if (eq? (assoc-ref const 'type) '=) "*" ""))) + constraints)) + ;; Symlinks. + (if (null? constraints) + "" + (let ((const (car constraints))) + (string-append + "\"" + (assoc-ref dep "alias") + " -> " + (assoc-ref dep "pkg") + (cond ((eq? (assoc-ref const 'type) '=) + (string-append + "-" + (comps->genver + (if (> (length (assoc-ref const 'components)) + (assoc-ref const 'slot-level)) + (take (assoc-ref const 'components) + (min (assoc-ref const 'slot-level) + 3)) + (take (assoc-ref const 'components) + (min (length (assoc-ref const 'components)) + 3)))))) + ((null? last-release-comps) "") ;; Not found select any. + ;; Highest usable version is car of releases. + ((or (eq? (assoc-ref const 'type) '<) + (eq? (assoc-ref const 'type) '<=) + (> (length constraints) 1)) + (string-append "-" + (comps->genver last-release-comps))) + (else (string-append "-" (assoc-ref dep "version")))) + "\""))) + ;; Ebuilds. + nodejs-ebuilds)))) + +(define gen-nodejs-ebuild + (lambda* (vars verbosity #:key + (tmpl #f) + ignore-diff) + "" + (let* ((pkt-map-db (pkt-map-load (assoc-ref vars 'repo) "nodejs")) + (vers (assoc-ref vars "version-values")) + (nodejs-symlinks '()) + (nodejs-ebuilds '()) + (nodejs-deps (append-map (lambda (dep) + (receive (deps links dep-ebuilds) + (setup-nodejs-dep dep + vars + pkt-map-db) + (set! nodejs-ebuilds + (append nodejs-ebuilds + dep-ebuilds)) + (set! nodejs-symlinks + (append nodejs-symlinks + (list links))) + deps)) + (if (assoc-ref vars "dependencies") + (assoc-ref vars "dependencies") + '())))) + (append (ebuild-from-tmpl + (append vars + (list (cons "slot" + (comps->genver (if (> (length vers) 3) + (take vers 3) + vers))) + (cons "nodejs-deps" + (string-join nodejs-deps "\n\t")) + (cons "nodejs-symlinks" + (string-join nodejs-symlinks "\n\t")))) + (assoc-ref vars 'verbosity) + #:tmpl tmpl + #:ignore-diff ignore-diff) + nodejs-ebuilds)))) + +(define-public ebuild-gen + (lambda* (parms releases #:key + (keep-components (list 1 1 2)) + (keep (lambda (version) #f)) + (drop (lambda (version) #f)) + (template #f) + (gen-ebuild-hook gen-nodejs-ebuild) + (post-hook ebuild-default-post) + ignore-autogen-diff) + "" + ((@ (ebuild gen) ebuild-gen) + parms releases + #:keep-components keep-components + #:keep keep + #:drop drop + #:template template + #:gen-ebuild-hook gen-ebuild-hook + #:post-hook post-hook + #:ignore-autogen-diff ignore-autogen-diff))) diff --git a/ebuild/pkt-map.scm b/ebuild/pkt-map.scm new file mode 100644 index 0000000..1b5263e --- /dev/null +++ b/ebuild/pkt-map.scm @@ -0,0 +1,79 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; pkt-map.scm +;; Copyright (C) 2025, 2026 Cor Legemaat +;; +;; This file is part of ebuild-autogen: you can redistribute it and/or modify it +;; under the terms of the GNU Affero General Public License as published by the +;; Free Software Foundation, version 3 of the License. +;; +;; ebuild-autogen 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 +;; ebuild-autogen. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-module (ebuild pkt-map) + #:use-module (ebuild defs) + #:use-module (ebuild utils) + #:use-module (ice-9 pretty-print) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) + #:use-module (rx irregex) + #:use-module (dql dql)) + +(define-public pkt-map-load + (lambda (repo type) + "" + (let ((path (string-join (list repo + "repo-local" + (string-append "pkg-map-" + type + ".aldb")) + file-name-separator-string))) + (if (file-exists? path) + (dql-read path) + '())))) + +(define-public pkt-map-set + (lambda (db name category pkg) + "" + (if (not (null? (pkt-map-get db name))) + ((dql (alter (where (lambda (pkg-name) + (and (string? pkg-name) + (string= pkg-name name))) + 'name) + (update 'name name) + (update 'category category) + (update 'pkg pkg))) + db) + (append db (list (list (cons 'name name) + (cons 'category category) + (cons 'pkg pkg))))))) + +(define-public pkt-map-get + (lambda (db name) + "" + (let ((answ ((dql (select (filter (where (lambda (pkg-name) + (and (string? pkg-name) + (string= pkg-name name))) + 'name)) + (parm 'category) + (parm 'pkg))) + db))) + ;; (display "answ:") (newline) + ;; (pretty-print answ) + answ))) + +(define-public pkt-map-write + (lambda (db repo type) + "" + (dql-write db + (string-join (list repo + "repo-local" + (string-append "pkg-map-" + type + ".aldb")) + file-name-separator-string)))) diff --git a/ebuild/repo.scm b/ebuild/repo.scm index 19a5139..7d2ed56 100644 --- a/ebuild/repo.scm +++ b/ebuild/repo.scm @@ -1,6 +1,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; repo.scm -;; Copyright (C) 2025 Cor Legemaat +;; Copyright (C) 2025, 2026 Cor Legemaat ;; ;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; under the terms of the GNU Affero General Public License as published by the @@ -22,10 +22,12 @@ #:use-module (ice-9 pretty-print) #:use-module (ice-9 textual-ports) #:use-module (srfi srfi-1) + #:use-module (git) #:use-module (git bindings) #:use-module (git repository) #:use-module (git clone) #:use-module (git checkout) + #:use-module (git reference) #:use-module (git submodule) #:use-module (rx irregex)) @@ -107,7 +109,8 @@ (define-public cp-repo-file (lambda* (repo folder-dst folder-src file verbosity #:key (file-dst file) - (sub-folder "")) + (sub-folder "") + (required #t)) "" (let ((file-in (string-join (list repo folder-src file) file-name-separator-string)) @@ -139,41 +142,46 @@ file-name-separator-string) "manifest")) (list (string-join (if (string=? sub-folder "") - (list file-dst) - (list sub-folder file)) + (list folder-dst file-dst) + (list folder-dst file)) file-name-separator-string))))) - (if (eq? (stat:type (stat file-in)) 'directory) - (if (file-exists? file-out) - (if (eq? (stat:type (stat file-out)) 'directory) - (for-each-file (scandir file-in)) - (begin (if (>= verbosity verbosity-critical) - (begin (display "warning: \"") - (display file-in) - (display "\" not a folder and won't ") - (display "represent autogen source data!") - (newline))) - '())) - (begin (mkdir file-out) - (for-each-file (scandir file-in)))) - (begin (if (file-exists? file-out) - (let* ((port-in (open-input-file file-in)) - (port-out (open-input-file file-out)) - (data-in (get-string-all port-in)) - (data-out (get-string-all port-out))) - (close port-in) - (close port-out) - (if (diff? data-in data-out) - (let ((output-port (open-output-file file-out))) - (if (>= verbosity verbosity-warn) - (begin (display "Destination differs for \"") - (display file) - (display "\" overriding.") - (newline))) - (display data-in output-port) - (close output-port)) - (finish))) - (copy-file file-in file-out)) - (finish)))))) + (if (file-exists? file-in) + (if (eq? (stat:type (stat file-in)) 'directory) + (if (file-exists? file-out) + (if (eq? (stat:type (stat file-out)) 'directory) + (for-each-file (scandir file-in)) + (begin (if (>= verbosity verbosity-critical) + (begin (display "warning: \"") + (display file-in) + (display "\" not a folder and won't ") + (display "represent autogen source data!") + (newline))) + '())) + (begin (mkdir file-out) + (for-each-file (scandir file-in)))) + (begin (if (file-exists? file-out) + (let* ((port-in (open-input-file file-in)) + (port-out (open-input-file file-out)) + (data-in (get-string-all port-in)) + (data-out (get-string-all port-out))) + (close port-in) + (close port-out) + (if (diff? data-in data-out) + (let ((output-port (open-output-file file-out))) + (if (>= verbosity verbosity-warn) + (begin (display "Destination differs for \"") + (display file) + (display "\" overriding.") + (newline))) + (display data-in output-port) + (close output-port)) + (finish))) + (copy-file file-in file-out)) + (finish))) + (if required + (error (string-append "Required repo file \"" + file-in + "\" does not exits!"))))))) (define-public folder-list (lambda (path ignore-meta) @@ -183,7 +191,8 @@ (stat:type (stat (string-append path "/" entry)))) (if (and ignore-meta (or (string=? entry "metadata") - (string=? entry "profiles"))) + (string=? entry "profiles") + (string=? entry "autogen"))) #f (if (char=? (car (string->list entry)) #\.) #f entry)) @@ -272,38 +281,43 @@ (newline))) (mkpath dst-path)) ;;cp each ebuild and the files folder. - (let ((test (append-map - (lambda (file) - (let ((ret (cp-repo-file - (assoc-ref parms 'repo) - (string-join (list (assoc-ref parms 'category) - (assoc-ref parms 'name)) - file-name-separator-string) - (string-join (list "autogen" - (assoc-ref parms 'category) - (assoc-ref parms 'name)) - file-name-separator-string) - file - (assoc-ref parms 'verbosity)))) - ret)) - (filter-map - (lambda (file) - (if (irregex-search '(or (seq bos "files" eos) - (seq ".ebuild" eos )) - file) - file - #f)) - (scandir src-path))))) - test) - ))) + (append-map + (lambda (file) + (map (lambda (dest) + (string-drop dest + (1+ (string-length + (string-join (list (assoc-ref parms 'category) + (assoc-ref parms 'name)) + file-name-separator-string))))) + (cp-repo-file (assoc-ref parms 'repo) + (string-join (list (assoc-ref parms 'category) + (assoc-ref parms 'name)) + file-name-separator-string) + (string-join (list "autogen" + (assoc-ref parms 'category) + (assoc-ref parms 'name)) + file-name-separator-string) + file + (assoc-ref parms 'verbosity)))) + (filter-map + (lambda (file) + (if (irregex-search '(or (seq bos "files" eos) + (seq ".ebuild" eos )) + file) + file + #f)) + (if (file-exists? src-path) + (scandir src-path) + '())))))) -(define-public clean-files - (lambda (file-list file-folder verbosity) +(define-public clean-ebuilds + (lambda (pkg-list repo verbosity) + "" (letrec* ((for-each-file - (lambda (sub-path) + (lambda (sub-path category pkg) (append-map (lambda (file) - (let ((path (string-join (list file-folder sub-path file) + (let ((path (string-join (list repo category pkg sub-path file) file-name-separator-string))) (if (not (or (char=? (car (string->list file)) #\.) (string=? file "Manifest"))) @@ -311,35 +325,59 @@ (for-each-file (string-join (if (string=? sub-path "") (list file) (list sub-path file)) - file-name-separator-string)) + file-name-separator-string) + category pkg) (list (string-join (if (string=? sub-path "") (list file) (list sub-path file)) file-name-separator-string))) '()))) - (scandir (string-join (list file-folder sub-path) + (scandir (string-join (list repo category pkg sub-path) file-name-separator-string)))))) - ;; (display "file-list:") (newline) - ;; (pretty-print file-list) - ;; (display "each-file:") (newline) - ;; (pretty-print (for-each-file "")) - ;; (display "to-clean:") (newline) - ;; (pretty-print (filter-map (lambda (file) - ;; (if (any (lambda (a) - ;; (string=? a file)) - ;; file-list) - ;; #false file)) - ;; (for-each-file ""))) - (for-each (lambda (absolute-file) - (if (>= verbosity verbosity-notice) - (begin (display "Cleaned absolute file \"") - (display absolute-file) (display "\"") - (newline))) - (delete-file (string-join (list file-folder absolute-file) - file-name-separator-string))) - (filter-map (lambda (file) - (if (any (lambda (a) - (string=? a file)) - file-list) - #false file)) - (for-each-file "")))))) + (for-each (lambda (pkg) + (for-each (lambda (absolute-file) + (delete-file (string-join (list repo + (assoc-ref pkg 'category) + (assoc-ref pkg 'name) + absolute-file) + file-name-separator-string)) + (if (>= verbosity verbosity-notice) + (begin (display "Cleaned absolute pkg file \"") + (display absolute-file) (display "\"") + (newline)))) + (filter-map (lambda (file) + (if (any (lambda (pkg) + (any (lambda (pkg-file) + (string=? pkg-file file)) + (assoc-ref pkg 'pkgfiles))) + pkg-list) + #false file)) + (for-each-file "" + (assoc-ref pkg 'category) + (assoc-ref pkg 'name))))) + pkg-list)))) + +(define-public clean-cache + (lambda (gen-list cache-path verbosity) + "" + (for-each (lambda (absolute-file) + (delete-file (string-join (list cache-path absolute-file) + file-name-separator-string)) + (if (>= verbosity verbosity-notice) + (begin (display "Cleaned absolute cache file \"") + (display absolute-file) (display "\"") + (newline)))) + (filter-map (lambda (file) + (if (any (lambda (pkg) + (if (assoc-ref pkg 'distfiles) + (any (lambda (pkg-file) + (string=? pkg-file file)) + (assoc-ref pkg 'distfiles)) + #f)) + gen-list) + #false file)) + (filter-map (lambda (file) + (cond ((string=? "." file) #f) + ((string=? ".." file) #f) + (else file))) + (scandir cache-path)))))) diff --git a/ebuild/semver.scm b/ebuild/semver.scm new file mode 100644 index 0000000..6b845f6 --- /dev/null +++ b/ebuild/semver.scm @@ -0,0 +1,334 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; semver.scm +;; Copyright (C) 2026 Cor Legemaat +;; +;; This file is part of ebuild-autogen: you can redistribute it and/or modify it +;; under the terms of the GNU Affero General Public License as published by the +;; Free Software Foundation, version 3 of the License. +;; +;; ebuild-autogen 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 +;; ebuild-autogen. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-module (ebuild semver) + #:use-module (rx irregex) + #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-13) + #:use-module (rnrs sorting)) + +;; https://semver.org/ + +(define-public semver->irregex-match + (lambda (version) + "" + (irregex-search + '(seq (+ (or "." bos) (+ num)) + (? (seq "-" (+ alphanum) (* "." (+ num)))) + (look-ahead (or (seq "+" (+ (or alphanum "-")) eos) + (seq (+ space) eos) + eos))) + ;; Strip leading spaces. + (if (string=? version "") + version + (substring version + (string-skip version #\space)))))) + +;;TODO make match keyworded parm to use value from fetch and skip an regex +;; per release. +(define-public semver->comps + (lambda* (version #:key (vers-match (semver->irregex-match version))) + "" + (if vers-match + (filter-map (lambda (component) + (cond ((string=? component "") #f) + ((string=? component "p") -1) + ((string=? component "rc") -2) + ((string=? component "pre") -3) + ((string=? component "beta") -4) + ((string=? component "alpha") -5) + ((not (string-every char-numeric? component)) + component) + (else (string->number component)))) + (irregex-extract '(or (seq (look-behind (or bos ".")) + (+ num)) + (seq (look-behind "-") + (+ alphanum))) + (irregex-match-substring vers-match))) + '()))) + +(define-public comps->semver + (lambda* (comps) + "" + (string-drop + (string-join (map (lambda (comp) + (case comp + ((-1) "-p") + ((-2) "-rc") + ((-3) "-pre") + ((-4) "-beta") + ((-5) "-alpha") + (else (string-append "." + (if (string? comp) + comp + (number->string comp)))))) + comps) + "") + 1))) + +(define-public comps->genver + (lambda* (comps #:key (comp-prefix "")) + "" + (if (or (null? comps) + (string? (car comps))) + "" + (string-append + (if (and (number? (car comps)) + (negative? (car comps))) + "" + comp-prefix) + (case (car comps) + ((-1) "_p") + ((-2) "_rc") + ((-3) "_pre") + ((-4) "_beta") + ((-5) "_alpha") + (else (if (number? (car comps)) + (number->string (car comps)) + ""))) + (comps->genver (if (or (not (negative? (car comps))) + (null? (cdr comps))) + (cdr comps) + (if (and (number? (cadr comps)) + (positive? (cadr comps))) + (list (cadr comps)) + '())) + #:comp-prefix (if (negative? (car comps)) + "" + ".")))))) + +(define-public semver-keep + (lambda* (versions keep #:key + (current-path '())) + "" + (let* ((unique-comps (delete-duplicates (map (lambda (rel) + (if (null? rel) + 0 + (car rel))) + versions))) + (my-quant (if (null? keep) 1 (car keep))) + (my-values (if (> (length unique-comps) my-quant) + (take (list-sort + (lambda (a b) + (cond ((and (string? a) (number? b)) #f) + ((and (number? a) (string? b)) #t) + ((and (string? a) (string? b)) + (string> a b)) + (else (> a b)))) unique-comps) + my-quant) + unique-comps))) + (if (every null? versions) + (list current-path) + (append-map + (lambda (comp) + (semver-keep (filter-map (lambda (rel) + (if (eq? (if (null? rel) 0 (car rel)) + comp) + (if (null? rel) '() (cdr rel)) + #f)) + versions) + (if (null? keep) + '() + (cdr keep)) + #:current-path (append current-path (list comp)))) + my-values))))) + +(define-public semver-stable? + (lambda (vers) + "" + (every (lambda (comp) + (and (number? comp) + (not (negative? comp)))) + vers))) + +(define-public semver-eq? + (lambda* (ref test #:key (cc (length ref))) + "" + (let ((ref-val (if (null? ref) 0 (car ref))) + (test-val (if (null? test) 0 (car test)))) + (cond ((and (null? ref) (null? test)) #t) + ((and (positive? cc) + (not (eqv? ref-val test-val))) + #f) + ((zero? cc) #t) + ((and (string? ref-val) (number? test-val)) #f) + ((and (number? ref-val) (string? test-val)) #t) + ((and (string? ref-val) + (string? test-val) + (not (string=? ref-val test-val))) + #f) + (else (semver-eq? (if (null? ref) '() (cdr ref)) + (if (null? test) '() (cdr test)) + #:cc (if (positive? cc) + (1- cc) + 0))))))) + +(define-public semver-less? + (lambda* (ref test #:key (cc 0)) + "" + (let ((ref-val (if (null? ref) 0 (car ref))) + (test-val (if (null? test) 0 (car test)))) + (cond ((and (null? ref) (null? test)) #f) + ((and (positive? cc) + (not (eqv? ref-val test-val))) + #f) + ((and (number? ref-val) + (number? test-val) + (< ref-val test-val)) #t) + ((and (number? ref-val) + (number? test-val) + (> ref-val test-val)) #f) + ((and (string? ref-val) (number? test-val)) #t) + ((and (string? ref-val) + (string? test-val) + (string ref-val test-val)) #f) + ((and (string? ref-val) (number? test-val)) #t) + ((and (string? ref-val) + (string? test-val) + (string<=? ref-val test-val)) #t) + (else (semver-leq? (if (null? ref) '() (cdr ref)) + (if (null? test) '() (cdr test)) + #:cc (if (positive? cc) + (1- cc) + 0))))))) + +(define-public semver-gr? + (lambda* (ref test #:key (cc 0)) + "" + (let ((ref-val (if (null? ref) 0 (car ref))) + (test-val (if (null? test) 0 (car test)))) + (cond ((and (null? ref) (null? test)) #f) + ((and (positive? cc) + (not (eqv? ref-val test-val))) + #f) + ((and (number? ref-val) + (number? test-val) + (> ref-val test-val)) #t) + ((and (number? ref-val) + (number? test-val) + (< ref-val test-val)) #f) + ((and (number? ref-val) (string? test-val)) #t) + ((and (string? ref-val) + (string? test-val) + (string>? ref-val test-val)) #t) + (else (semver-gr? (if (null? ref) '() (cdr ref)) + (if (null? test) '() (cdr test)) + #:cc (if (positive? cc) + (1- cc) + 0))))))) + +(define-public semver-geq? + (lambda* (ref test #:key (cc 0)) + "" + (let ((ref-val (if (null? ref) 0 (car ref))) + (test-val (if (null? test) 0 (car test)))) + (cond ((and (null? ref) (null? test)) #t) + ((and (positive? cc) + (not (eqv? ref-val + test-val))) + #f) + ((and (number? ref-val) + (number? test-val) + (> ref-val test-val)) #t) + ((and (number? ref-val) + (number? test-val) + (< ref-val test-val)) #f) + ((and (number? ref-val) (string? test-val)) #t) + ((and (string? ref-val) + (string? test-val) + (string>=? ref-val test-val)) #t) + (else (semver-geq? (if (null? ref) '() (cdr ref)) + (if (null? test) '() (cdr test)) + #:cc (if (positive? cc) + (1- cc) + 0))))))) + +(define-public semver-constrain + (lambda* (releases constraints #:key + (allow-unfiletered #f) + (prefer-stable-only #t)) + "" + (let* ((releases-usable + (filter-map + (lambda (rel) + (if (every (lambda (const) + (cond ((and (null? (assoc-ref const 'type)) + (eq? (assoc-ref const 'slot-level) 0)) + #t) + ((eq? (assoc-ref const 'type) '=) + (semver-eq? (assoc-ref rel "version-values") + (assoc-ref const 'components) + #:cc (assoc-ref const 'slot-level))) + ((eq? (assoc-ref const 'type) '<=) + (semver-geq? (assoc-ref rel "version-values") + (assoc-ref const 'components))) + ((eq? (assoc-ref const 'type) '<=) + (semver-leq? (assoc-ref rel "version-values") + (assoc-ref const 'components))) + ((eq? (assoc-ref const 'type) '>) + (semver-gr? (assoc-ref rel "version-values") + (assoc-ref const 'components))) + ((eq? (assoc-ref const 'type) '<) + (semver-less? (assoc-ref rel "version-values") + (assoc-ref const 'components))) + (else #f))) + constraints) + rel #f)) + releases)) + (releases-stable + (filter-map (lambda (rel) + (if (semver-stable? (assoc-ref rel "version-values")) + rel #f)) + releases-usable)) + (answ (sort (if (or (null? releases-stable) + (not prefer-stable-only)) + (if (null? releases-usable) + (if (or (null? releases) + (not allow-unfiletered)) + '() + releases) + releases-usable) + releases-stable) + (lambda (a b) + (semver-gr? (assoc-ref a "version-values") + (assoc-ref b "version-values")))))) + ;; (display "all-releases:") (newline) (pretty-print releases) + ;; (display "releases:") (newline) (pretty-print releases-usable) + ;; (display "stable-releases:") (newline) (pretty-print releases-stable) + ;; (display "ret:") (newline) (pretty-print answ) + answ))) diff --git a/ebuild/state.scm b/ebuild/state.scm new file mode 100644 index 0000000..ff080f2 --- /dev/null +++ b/ebuild/state.scm @@ -0,0 +1,101 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; state.scm +;; Copyright (C) 2025, 2026 Cor Legemaat +;; +;; This file is part of ebuild-autogen: you can redistribute it and/or modify it +;; under the terms of the GNU Affero General Public License as published by the +;; Free Software Foundation, version 3 of the License. +;; +;; ebuild-autogen 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 +;; ebuild-autogen. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-module (ebuild state) + #:use-module (ebuild defs) + #:use-module (ebuild utils) + #:use-module (ice-9 pretty-print) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-43) + #:use-module (rx irregex) + #:use-module (dql dql)) + +(define-public state-load + (lambda (repo category name) + "" + (let ((path (string-join (list repo + category + name + ".state.aldb") + file-name-separator-string))) + (if (file-exists? path) + (dql-read path) + '())))) + +(define-public state-set + (lambda (db constraint ebuild version distfiles) + "" + (if (not (null? (state-get db constraint))) + ((dql (alter (where (lambda (pkg-constraint) + (or (and (not constraint) + (not pkg-constraint)) + (equal? pkg-constraint constraint))) + 'constraint) + (update 'constraint constraint) + (update 'date (date->string (current-date))) + (update 'ebuild ebuild) + (update 'version version) + (update 'distfiles distfiles)) + ;;#:print-query state-set + ) + db) + (append db (list (list (cons 'constraint constraint) + (cons 'date (date->string (current-date))) + (cons 'ebuild ebuild) + (cons 'version version) + (cons 'distfiles distfiles))))))) + +(define-public state-get + (lambda (db constraint) + "" + ;;(display "constraint=") (display constraint) (newline) + (let ((answ ((dql (select (filter (where (lambda (pkg-constraint) + (or (and (not constraint) + (not pkg-constraint)) + (equal? pkg-constraint constraint))) + 'constraint)) + (parm 'date) + (parm 'ebuild) + (parm 'version) + (parm 'distfiles)) + ;;#:print-query state-get + ) + db))) + ;; (display "state-answ") (newline) + ;; (pretty-print answ) + (if (not (nil? answ)) + (let ((date (string->date (assoc-ref (car answ) 'date) + "~a ~b ~d ~H:~M:~S~z ~Y"))) + (assoc-set! (append (alist-copy (car answ)) + (list (cons 'age + (time-difference + (current-time) + (date->time-utc date))))) + 'date + date)) + answ)))) + +(define-public state-write + (lambda (db repo category name) + "" + (dql-write db + (string-join (list repo + category + name + ".state.aldb") + file-name-separator-string)))) diff --git a/ebuild/utils.scm b/ebuild/utils.scm index dd0669d..e17d1f1 100644 --- a/ebuild/utils.scm +++ b/ebuild/utils.scm @@ -1,6 +1,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utils.scm -;; Copyright (C) 2025 Cor Legemaat +;; Copyright (C) 2025, 2026 Cor Legemaat ;; ;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; under the terms of the GNU Affero General Public License as published by the @@ -16,8 +16,11 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-module (ebuild utils) #:use-module (ice-9 ftw) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 regex) #:use-module (rx irregex) - #:use-module (srfi srfi-1)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19)) (define-public list->str-list (lambda* (in-list glue #:key (pre "") (post "")) @@ -42,24 +45,50 @@ test-list))) (define-public diff? - (lambda* (data-a data-b #:key (allow (lambda (a b) #true))) + (lambda* (data-a data-b #:key (allow (lambda (a b) #true)) (print-delta #f)) "" - (any (lambda (t) t) - (map (lambda (a b) - (if (string=? a b) - #false - (allow a b))) - (if (string? data-a) - (string-split data-a #\newline) - data-a) - (if (string? data-b) - (string-split data-b #\newline) - data-b))))) + (let ((a-list (if (string? data-a) + (string-split data-a #\newline) + (append-map (lambda (line) + (string-split line #\newline)) + data-a))) + (b-list (if (string? data-b) + (string-split data-b #\newline) + (append-map (lambda (line) + (string-split line #\newline)) + data-b)))) + (any (lambda (t) t) + (map (lambda (a b) + (if (string=? a b) + #false + (if (and print-delta + (not (allow a b))) + (begin (display "Diff between lines:") + (newline) + (display "\"") (display a) (display "\"") + (newline) + (display "\"") (display b) (display "\"") + newline) + (allow a b)))) + (if (< (length a-list) (length b-list)) + (append a-list + (make-list (- (length b-list) + (length a-list)) + "")) + a-list) + (if (< (length b-list) (length a-list)) + (append b-list + (make-list (- (length a-list) + (length b-list)) + "")) + b-list)))))) (define-public last-ebuild-rel (lambda (folder pkg version) "" - (let* ((files (scandir folder)) + (let* ((files (if (file-exists? folder) + (scandir folder) + '())) (releases (filter-map (lambda (file) (if (string=? file (string-append pkg @@ -115,3 +144,19 @@ (lambda (list1 list2) "" (every string=? list1 list2))) + +(define-public (string->duration str) + "Parses a string like '10m', '2h', or '30s' into seconds." + (let ((match (string-match "^([0-9]+)([smhdSMHD]?)$" str))) + (if match + (let ((val (string->number (match:substring match 1))) + (unit (match:substring match 2))) + (make-time 'time-duration + 0 + (cond + ((string-ci=? unit "s") val) + ((string-ci=? unit "m") (* val 60)) + ((string-ci=? unit "h") (* val 3600)) + ((string-ci=? unit "d") (* val 86400)) + (else val)))) ; Default to seconds if no unit + (error "Invalid duration format" str))))