cor/ebuild-autogen
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

V0.0.3 Nodejs support.

Browse source
This commit is contained in:
Cor Legemaat 2026-03-30 07:00:06 +02:00
commit 54f494163a
17 changed files with 1871 additions and 484 deletions
Download patch file Download diff file Expand all files Collapse all files

5
configure.ac
View file

@ -1,5 +1,5 @@
define(EBUILD_AUTOGEN_CONFIGURE_COPYRIGHT, [[ define(EBUILD_AUTOGEN_CONFIGURE_COPYRIGHT, [[
Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
This file is part of ebuild-autogen: you can redistribute it and/or modify it 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 under the terms of the GNU Affero General Public License as published by the
@ -15,7 +15,7 @@ ebuild-autogen. If not, see <https://www.gnu.org/licenses/>.
m4_define([version_major], [0]) m4_define([version_major], [0])
m4_define([version_minor], [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_PACKAGE_URL([http://www.cor.za.net/code/ebuild-autogen])
AC_INIT(ebuild-autogen, AC_INIT(ebuild-autogen,
@ -94,6 +94,7 @@ AC_CONFIG_FILES([Makefile
po/Makefile.in po/Makefile.in
ebuild/Makefile ebuild/Makefile
ebuild/fetchers/Makefile ebuild/fetchers/Makefile
ebuild/gen/Makefile
doc/Makefile]) doc/Makefile])
AC_CONFIG_COMMANDS([timestamp], [date >timestamp]) AC_CONFIG_COMMANDS([timestamp], [date >timestamp])

7
ebuild/Makefile.am
View file

@ -1,6 +1,6 @@
################################################################################ ################################################################################
# Makefile.am # Makefile.am
# Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> # Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
# #
# This file is part of ebuild-autogen: you can redistribute it and/or modify it # 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 # 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 # You should have received a copy of the GNU General Public License along with
# ebuild-autogen. If not, see <https://www.gnu.org/licenses/>. # ebuild-autogen. If not, see <https://www.gnu.org/licenses/>.
################################################################################ ################################################################################
SUBDIRS = fetchers SUBDIRS = fetchers gen
moddir=$(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION)/ebuild moddir=$(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION)/ebuild
objdir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache/ebuild objdir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache/ebuild
@ -25,7 +25,10 @@ SOURCES = \
cli.scm \ cli.scm \
defs.scm \ defs.scm \
gen.scm \ gen.scm \
pkt-map.scm \
repo.scm \ repo.scm \
state.scm \
semver.scm \
utils.scm \ utils.scm \
version.scm version.scm

184
ebuild/cli.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; cli.scm ;; cli.scm
;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> ;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;; ;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; 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 ;; 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 pretty-print)
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (dql dql) #:use-module (dql dql)
#:use-module (ebuild defs) #:use-module (ebuild defs)
#:use-module (ebuild repo) #:use-module (ebuild repo)
#:use-module (ebuild gen) #:use-module (ebuild gen)
#:use-module (ebuild utils)
#:use-module (ebuild version) #:use-module (ebuild version)
#:use-module (config) #:use-module (config)
#:use-module (config api) #:use-module (config api)
@ -62,6 +64,10 @@
(name 'init-from) (default "") (test string?) (name 'init-from) (default "") (test string?)
(example "https://www.cor.za.net/code/portage-overlay") (example "https://www.cor.za.net/code/portage-overlay")
(synopsis "An url to initialize the repo from scratch")) (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 ;;TODO figure out how to use non parameter options from the command
;; line instead of this. ;; line instead of this.
(switch (switch
@ -90,7 +96,12 @@ authentication when pulling package updates from github."))
(example "/tmp/ebuild-autogen/") (example "/tmp/ebuild-autogen/")
(handler identity) (test string?) (handler identity) (test string?)
(synopsis "Temporary files path.") (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") (synopsis "Auto generate Gentoo ebuild's")
(description "ebuild-autogen is a Guile scheme application to auto generate (description "ebuild-autogen is a Guile scheme application to auto generate
gentoo ebuild package definitions from the \"autogen.scm\" specification for gentoo ebuild package definitions from the \"autogen.scm\" specification for
@ -126,7 +137,18 @@ git repository.")
(cons 'verbosity (option-ref options 'verbosity)) (cons 'verbosity (option-ref options 'verbosity))
(cons 'cache-path (option-ref options (cons 'cache-path (option-ref options
'filecache-path)) '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. ;; Update the source repository if requested.
(if (option-ref options 'submodule-update) (if (option-ref options 'submodule-update)
(repo-update-src folder)) (repo-update-src folder))
@ -141,6 +163,12 @@ git repository.")
'github-token 'github-token
(option-ref options '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 (with-exception-handler
(lambda (exception) (lambda (exception)
(if (>= (option-ref options 'verbosity) (if (>= (option-ref options 'verbosity)
@ -197,14 +225,31 @@ git repository.")
".gitignore-repo" ".gitignore-repo"
(option-ref options 'verbosity) (option-ref options 'verbosity)
#:file-dst ".gitignore") #: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. ;; 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) (if (>= (option-ref options 'verbosity)
verbosity-warn) verbosity-warn)
(begin (display "package-list:") (newline) (begin (display "package-list:") (newline)
(pretty-print pkg-list))) (pretty-print pkg-list)))
(let ((cache-files-used (let* ((cache-files-used
(append-map (lambda (pkg) (append-map (lambda (pkg)
(let ((name (string->symbol (assoc-ref pkg 'name))) (let ((name (string->symbol (assoc-ref pkg 'name)))
(cat (string->symbol (assoc-ref pkg 'category)))) (cat (string->symbol (assoc-ref pkg 'category))))
@ -240,83 +285,118 @@ git repository.")
(lambda () (lambda ()
(let* ((pkg-mod (resolve-module `(,cat ,name autogen))) (let* ((pkg-mod (resolve-module `(,cat ,name autogen)))
(pkg-parms (append parms pkg)) (pkg-parms (append parms pkg))
(distfiles-used '())
(pkgfiles-used (pkgfiles-used
(if pkg-mod (if pkg-mod
(let ((releases ;; 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) (if (module-variable pkg-mod 'get-releases)
((module-ref 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) pkg-parms)
(setup-pkg pkg-parms)) '()))
;; Generate the ebuilds. ;; Generate the ebuilds.
(receive (pkg-files dist-files) (pkg-gen ((if (module-variable pkg-mod 'generate-ebuilds)
(if (module-variable pkg-mod 'generate-ebuilds) (module-ref pkg-mod 'generate-ebuilds)
((module-ref pkg-mod 'generate-ebuilds) ebuild-gen)
pkg-parms (assoc-set! pkg-parms
releases) 'pkgfiles
(ebuild-gen pkg-parms setup-files)
releases)) releases)))
(set! distfiles-used ;; Populate package if no ebuilds generated.
(append distfiles-used dist-files)) (if (null? pkg-gen)
pkg-files))) (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)))) (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 "Done with package: ")
(display (assoc-ref pkg 'category)) (display (assoc-ref pkg 'category))
(display "/") (display "/")
(display (assoc-ref pkg 'name)) (display (assoc-ref pkg 'name))
(newline) (newline)
distfiles-used)) (if (>= (option-ref options 'verbosity)
verbosity-notice)
(begin (display "package results:") (newline)
(pretty-print pkgfiles-used)))
pkgfiles-used))
#:unwind? (< 1 (length pkg-list))))) #:unwind? (< 1 (length pkg-list)))))
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. ;; Clean deprecated cache files if requested.
(if (>= (option-ref options 'verbosity) (if (>= (option-ref options 'verbosity)
verbosity-notice) verbosity-notice)
(begin (display "distfiles-used:") (newline) (begin ;; (display "generated results:") (newline)
(pretty-print cache-files-used) ;; (pretty-print cache-files-used)
(display "\"") (newline))) (display "generated pkgs:") (newline)
(pretty-print unique-pkgfiles)))
(if (and (or (string=? folder repo) (if (and (or (string=? folder repo)
(string=? folder (string=? folder
(string-join (list repo "autogen") (string-join (list repo "autogen")
file-name-separator-string))) file-name-separator-string)))
(option-ref options 'cache-clean)) (option-ref options 'cache-clean))
(clean-files cache-files-used (clean-cache cache-files-used
(option-ref options 'filecache-path) (option-ref options 'filecache-path)
(option-ref options 'verbosity)))) (option-ref options 'verbosity)))
;; The extra folders in repo not in src. ;; 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))) (let ((repo-pkgs (build-pkg-list repo folder #f)))
(map (lambda (pkg) (map (lambda (pkg)
(if (null? ((dql (filter (where (lambda (val) (if (not (any (lambda (list-pkg)
(string=? val (same-pkg? list-pkg pkg))
(assoc-ref pkg 'category))) cache-files-used))
'category) (begin (if (>= (option-ref options 'verbosity)
(where (lambda (val)
(string=? val
(assoc-ref pkg 'name)))
'name)))
pkg-list))
(if (>= (option-ref options 'verbosity)
verbosity-warn) verbosity-warn)
(begin (display "Absolute pkg ") (begin (display "Absolute pkg ")
(display (assoc-ref pkg 'category)) (display (assoc-ref pkg 'category))
(display "/") (display "/")
(display (assoc-ref pkg 'name)) (display (assoc-ref pkg 'name))
(display " found.") (display " deleted.")
(newline))))) (newline)))
repo-pkgs))) (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. ;; Commit and push the updates to master if requested.
(if (option-ref options 'remote-push) (if (option-ref options 'remote-push)

4
ebuild/fetchers/Makefile.am
View file

@ -1,6 +1,6 @@
################################################################################ ################################################################################
# Makefile.am # Makefile.am
# Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> # Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
# #
# This file is part of ebuild-autogen: you can redistribute it and/or modify it # 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 # under the terms of the GNU Affero General Public License as published by the
@ -22,6 +22,7 @@ SOURCES = \
forgejo.scm \ forgejo.scm \
github.scm \ github.scm \
pypi.scm \ pypi.scm \
npmjs.scm \
raw.scm raw.scm
# Manual dependencys. # Manual dependencys.
@ -29,6 +30,7 @@ ebuild.go: ../version.scm
forgejo.go: ../version.scm forgejo.go: ../version.scm
github.go: ../version.scm github.go: ../version.scm
pypi.go: ../version.scm pypi.go: ../version.scm
npmjs.go: ../version.scm
raw.scm: ../version.scm raw.scm: ../version.scm
GOBJECTS = $(SOURCES:%.scm=%.go) GOBJECTS = $(SOURCES:%.scm=%.go)

14
ebuild/fetchers/forgejo.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; forgejo.scm ;; forgejo.scm
;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> ;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;; ;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; 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 ;; under the terms of the GNU Affero General Public License as published by the
@ -17,6 +17,7 @@
(define-module (ebuild fetchers forgejo) (define-module (ebuild fetchers forgejo)
#:use-module (ebuild defs) #:use-module (ebuild defs)
#:use-module (ebuild fetchers raw) #:use-module (ebuild fetchers raw)
#:use-module (ebuild semver)
#:use-module (ebuild utils) #:use-module (ebuild utils)
#:use-module (curl) #:use-module (curl)
#:use-module (json) #:use-module (json)
@ -58,11 +59,12 @@
(if responce (if responce
(begin (check-forgejo-errors responce) (begin (check-forgejo-errors responce)
(let ((scm-responce (json-string->scm responce))) (let ((scm-responce (json-string->scm responce)))
(if (< 100 (vector-length scm-responce)) (if (= 100 (vector-length scm-responce))
(vector-append (fetch-forgejo-pages url (vector-append scm-responce
(fetch-forgejo-pages url
auth-token auth-token
verbosity verbosity
(+1 page))) (1+ page)))
(begin (if (>= verbosity verbosity-info) (begin (if (>= verbosity verbosity-info)
(pretty-print scm-responce)) (pretty-print scm-responce))
scm-responce)))) scm-responce))))
@ -143,6 +145,8 @@
(set! scm (json-string->scm json)) (set! scm (json-string->scm json))
(assoc-set! release "version" version-final) (assoc-set! release "version" version-final)
(append release (append release
(list (cons "version-values"
(semver->comps version-final)))
(list (cons "repo-user" user)) (list (cons "repo-user" user))
(list (cons "repo-repo" repo)) (list (cons "repo-repo" repo))
;;TODO append this with list of custom assets. ;;TODO append this with list of custom assets.
@ -178,6 +182,8 @@
(base-asset-url (string-append host "/" user "/" repo))) (base-asset-url (string-append host "/" user "/" repo)))
(assoc-set! tag "version" version-final) (assoc-set! tag "version" version-final)
(append tag (append tag
(list (cons "version-values"
(semver->comps version-final)))
(list (cons "repo-user" user)) (list (cons "repo-user" user))
(list (cons "repo-name" repo)) (list (cons "repo-name" repo))
(list (list

15
ebuild/fetchers/github.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; github.scm ;; github.scm
;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> ;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;; ;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; 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 ;; 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 defs)
#:use-module (ebuild fetchers raw) #:use-module (ebuild fetchers raw)
#:use-module (ebuild utils) #:use-module (ebuild utils)
#:use-module (ebuild semver)
#:use-module (curl) #:use-module (curl)
#:use-module (json) #:use-module (json)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
@ -63,10 +64,12 @@
(if responce (if responce
(begin (check-github-errors responce) (begin (check-github-errors responce)
(let ((scm-responce (json-string->scm responce))) (let ((scm-responce (json-string->scm responce)))
(if (< 100 (vector-length scm-responce)) (if (= 100 (vector-length scm-responce))
(vector-append (fetch-github-pages url (vector-append scm-responce
(fetch-github-pages url
token
verbosity verbosity
(+1 page))) (1+ page)))
(begin (if (>= verbosity verbosity-info) (begin (if (>= verbosity verbosity-info)
(pretty-print scm-responce)) (pretty-print scm-responce))
scm-responce)))) scm-responce))))
@ -156,6 +159,8 @@
(set! sha7 (string-take sha 7)) (set! sha7 (string-take sha 7))
(assoc-set! release "version" version-final) (assoc-set! release "version" version-final)
(append release (append release
(list (cons "version-values"
(semver->comps version-final)))
(list (cons "sha" sha)) (list (cons "sha" sha))
(list (cons "github-user" user)) (list (cons "github-user" user))
(list (cons "github-repo" repo)) (list (cons "github-repo" repo))
@ -200,6 +205,8 @@
repo))) repo)))
(assoc-set! tag "version" version-final) (assoc-set! tag "version" version-final)
(append tag (append tag
(list (cons "version-values"
(semver->comps version-final)))
(list (cons "github-user" user)) (list (cons "github-user" user))
(list (cons "github-repo" repo)) (list (cons "github-repo" repo))
(list (cons "sha7" sha7)) (list (cons "sha7" sha7))

247
ebuild/fetchers/npmjs.scm Normal file
View file

@ -0,0 +1,247 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; npmjs.scm
;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;;
;; 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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))))

28
ebuild/fetchers/pypi.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pypi.scm ;; pypi.scm
;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> ;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;; ;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; 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 ;; under the terms of the GNU Affero General Public License as published by the
@ -17,6 +17,7 @@
(define-module (ebuild fetchers pypi) (define-module (ebuild fetchers pypi)
#:use-module (ebuild defs) #:use-module (ebuild defs)
#:use-module (ebuild fetchers raw) #:use-module (ebuild fetchers raw)
#:use-module (ebuild semver)
#:use-module (ebuild utils) #:use-module (ebuild utils)
#:use-module (curl) #:use-module (curl)
#:use-module (json) #:use-module (json)
@ -61,8 +62,10 @@
(let* ((data (fetch-pypi-pkg pypi-name display-data)) (let* ((data (fetch-pypi-pkg pypi-name display-data))
(versions (vector->list (assoc-ref data "versions"))) (versions (vector->list (assoc-ref data "versions")))
(files (assoc-ref data "files"))) (files (assoc-ref data "files")))
(map (lambda (version) (filter-map
(let ((upload-date (car ((dql (select (filter (where (lambda (file-name) (lambda (version)
(if (semver->irregex-match version)
(let ((upload-date ((dql (select (filter (where (lambda (file-name)
(if (string? file-name) (if (string? file-name)
(string-contains file-name (string-contains file-name
(string-append "-" (string-append "-"
@ -71,18 +74,20 @@
#f)) #f))
"filename")) "filename"))
(parm-as "date" "upload-time"))) (parm-as "date" "upload-time")))
files)))) files)))
(if (nil? upload-date) (if (nil? upload-date)
(if (>= (assoc-ref parms 'verbosity) (begin (if (>= (assoc-ref parms 'verbosity)
verbosity-error) verbosity-error)
(begin (display "Upload file \"") (begin (display "Upload file for version \"")
(display (string-append "-" (display version)
version (display "\" and type \"")
(car file-types))) (display (car file-types))
(display "\" not found, skipping release!") (display "\" not found, skipping release!")
(newline))) (newline)))
#f)
(list (cons "version" version) (list (cons "version" version)
(car upload-date) (cons "version-values" (semver->comps version))
(car (car upload-date))
(cons "assets" (cons "assets"
(map (lambda (type) (map (lambda (type)
(append (car ((dql (select (filter (where (lambda (file-name) (append (car ((dql (select (filter (where (lambda (file-name)
@ -98,5 +103,6 @@
(parm "hashes" "sha256"))) (parm "hashes" "sha256")))
files)) files))
(list (cons "type" type)))) (list (cons "type" type))))
file-types)))))) file-types)))))
#f))
versions)))) versions))))

9
ebuild/fetchers/raw.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; raw.scm ;; raw.scm
;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> ;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;; ;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; 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 ;; under the terms of the GNU Affero General Public License as published by the
@ -17,6 +17,7 @@
(define-module (ebuild fetchers raw) (define-module (ebuild fetchers raw)
#:use-module (ebuild defs) #:use-module (ebuild defs)
#:use-module (ebuild utils) #:use-module (ebuild utils)
#:use-module (ebuild semver)
#:use-module (curl) #:use-module (curl)
#:use-module (rx irregex) #:use-module (rx irregex)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
@ -41,6 +42,7 @@
(let ((version (version-alter (extract-version release)))) (let ((version (version-alter (extract-version release))))
(if (version-filter version) (if (version-filter version)
(list (cons "version" version) (list (cons "version" version)
(cons "version-values" (semver->comps version))
(cons "assets" (cons "assets"
(map (map
(lambda (type) (lambda (type)
@ -104,13 +106,12 @@
(lambda (release type) (lambda (release type)
"" ""
(let* ((my-file-data (let* ((my-file-data
(car ((dql (select (filter (select (parm-val "assets")) (car ((dql (select (filter (where (lambda (x)
(where (lambda (x)
(string=? x type)) (string=? x type))
"type")) "type"))
(parm "uri") (parm "uri")
(parm "name"))) (parm "name")))
release))) (assoc-ref release "assets"))))
(uri (assoc-ref my-file-data "uri")) (uri (assoc-ref my-file-data "uri"))
(name (assoc-ref my-file-data "name")) (name (assoc-ref my-file-data "name"))
(file-path (string-append (assoc-ref release 'cache-path) (file-path (string-append (assoc-ref release 'cache-path)

389
ebuild/gen.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gen.scm ;; gen.scm
;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> ;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;; ;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; 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 ;; under the terms of the GNU Affero General Public License as published by the
@ -17,29 +17,50 @@
(define-module (ebuild gen) (define-module (ebuild gen)
#:use-module (ebuild utils) #:use-module (ebuild utils)
#:use-module (ebuild defs) #:use-module (ebuild defs)
#:use-module (ebuild semver)
#:use-module (ebuild state)
#:use-module (dql dql) #:use-module (dql dql)
#:use-module (rx irregex) #:use-module (rx irregex)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:use-module (ice-9 receive)
#:use-module (ice-9 string-fun) #:use-module (ice-9 string-fun)
#:use-module (ice-9 textual-ports) #: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. ;;Function to generate template from ebuild with variable substitution.
(define-public ebuild-from-tmpl (define-public ebuild-from-tmpl
(lambda* (vars verbosity #:key (lambda* (vars verbosity #:key
(tmpl (string-append (assoc-ref vars 'name) ".tmpl")) (tmpl #f)
ignore-diff) ignore-diff)
"" ""
(letrec* (letrec*
((input-port (open-input-file (string-join (list (assoc-ref vars 'repo) ((pkg-tmpl (string-join (list (assoc-ref vars 'repo)
"autogen" "autogen"
(assoc-ref vars 'category) (assoc-ref vars 'category)
(assoc-ref vars 'name) (assoc-ref vars 'name)
tmpl) (string-append (assoc-ref vars 'name)
file-name-separator-string))) ".tmpl"))
(data (append (list "# Auto generated from autogen.scm") 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. ;; 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 (+ "#") (if (irregex-search '(seq (+ "#")
(+ space) (+ space)
"-*-" "-*-"
@ -55,35 +76,54 @@
"[" "["
(number->string no) (number->string no)
"]") "]")
(car data)) (if (null? data) '() (car data)))
(if (not (null? (cdr data))) (if (not (null? (cdr data)))
(traverse-list pre (1+ no) (cdr data))))) (traverse-list pre (1+ no) (cdr data)))))
(traverse-alist (traverse-alist
(lambda (pre data) (lambda (pre data)
(for-each (lambda (var) (if (not (eq? pre 'dep-graph))
(if (and (string? (car var)) (for-each
(string? (cdr var))) (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) (replace (if (eq? (string-length pre) 0)
(car var) (if (symbol? (car var))
(symbol->string (car var))
(car var))
(string-append pre (string-append pre
"." "."
(car var))) (if (symbol? (car var))
(cdr var)) (symbol->string (car var))
(car var))))
(if (symbol? (cdr var))
(symbol->string (cdr var))
(cdr var)))
(traverse (if (eq? (string-length pre) 0) (traverse (if (eq? (string-length pre) 0)
(car var) (if (symbol? (car var))
(symbol->string (car var))
(car var))
(string-append pre (string-append pre
"." "."
(car var))) (if (symbol? (car var))
(symbol->string (car var))
(car var))))
(cdr var)))) (cdr var))))
data))) data))))
(traverse (lambda (pre data) (traverse (lambda (pre data)
(cond ((alist? data) (cond ((null? data) '())
((alist? data)
(traverse-alist pre data)) (traverse-alist pre data))
((list? data) ((list? data)
(traverse-list pre 0 data)) (traverse-list pre 0 data))
((number? data) ((number? data)
(replace pre (number->string data))) (replace pre (number->string data)))
((string? data) (replace pre 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 " (else (error (string-append "Error! Don't know how "
"to process \"" "to process \""
(object->string data) (object->string data)
@ -103,7 +143,30 @@
(string-replace-substring line (string-replace-substring line
var-str var-str
val)) 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) (traverse "" vars)
(let* ((folder-out (string-join (list (assoc-ref vars 'repo) (let* ((folder-out (string-join (list (assoc-ref vars 'repo)
(assoc-ref vars 'category) (assoc-ref vars 'category)
@ -111,11 +174,13 @@
file-name-separator-string)) file-name-separator-string))
(rel (last-ebuild-rel folder-out (rel (last-ebuild-rel folder-out
(assoc-ref vars 'name) (assoc-ref vars 'name)
(assoc-ref vars "version"))) (comps->genver (assoc-ref vars
"version-values"))))
(ebuild-name (lambda (rel) (ebuild-name (lambda (rel)
(string-append (assoc-ref vars 'name) (string-append
(assoc-ref vars 'name)
"-" "-"
(assoc-ref vars "version") (comps->genver (assoc-ref vars "version-values"))
(if (< 0 rel) (if (< 0 rel)
(string-append "-r" (string-append "-r"
(number->string rel)) (number->string rel))
@ -126,7 +191,8 @@
file-name-separator-string)) file-name-separator-string))
(if (and (not ignore-diff) (if (and (not ignore-diff)
(diff? data (diff? data
(let* ((port-ebuild (open-input-file (let* ((port-ebuild
(open-input-file
(string-join (list folder-out (string-join (list folder-out
(ebuild-name rel)) (ebuild-name rel))
file-name-separator-string))) file-name-separator-string)))
@ -138,127 +204,72 @@
(match-a (irregex-search rx a)) (match-a (irregex-search rx a))
(match-b (irregex-search rx b))) (match-b (irregex-search rx b)))
(if (and match-a match-b) (if (and match-a match-b)
#false #true))))) #false #true)))
#:print-delta (>= verbosity verbosity-info)))
;; Data the same.
(let ((output-port (open-output-file (let ((output-port (open-output-file
(string-join (list folder-out (string-join (list folder-out
(ebuild-name (1+ rel))) (ebuild-name (1+ rel)))
file-name-separator-string)))) file-name-separator-string))))
(display (string-join data "\n") output-port) (display (string-join data "\n") output-port)
(close output-port) (close output-port)
;;(display "data-diff!!!") (newline) (final-ebuild (ebuild-name (1+ rel))))
(ebuild-name (1+ rel))) ;; Data differs.
(ebuild-name rel)) (final-ebuild (ebuild-name rel)))
(let ((output-port (open-output-file (let ((output-port (open-output-file
(string-join (list folder-out (string-join (list folder-out
(ebuild-name rel)) (ebuild-name rel))
file-name-separator-string)))) file-name-separator-string))))
(display (string-join data "\n") output-port) (display (string-join data "\n") output-port)
(close output-port) (close output-port)
(ebuild-name rel))))))) (final-ebuild (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))))))
(define-public ebuild-version-filter (define-public ebuild-version-filter
(lambda* (releases #:key (lambda* (releases #:key
(keep-components (if (assoc-ref releases 'keep-vers-comps) (keep-components (if (assoc-ref releases 'keep-vers-comps)
(assoc-ref releases 'keep-vers-comps) (assoc-ref releases 'keep-vers-comps)
(list 1 1 1))) (list 1 1 1)))
(version-components default-version-components)
(keep (lambda (version) #f)) (keep (lambda (version) #f))
(drop (lambda (version) #f))) (drop (lambda (version) #f)))
"" ""
(let* ((vlist (map (lambda (release) (let* ((vlist (map (lambda (release)
(list (version-components (assoc-ref release (assoc-ref release "version-values"))
"version"))
(assoc-ref release "version")))
releases)) releases))
(vlist-filtered (vlist-filtered
(append (filter (lambda (vers) (append (filter (lambda (vers)
(if (keep (second vers)) vers #f)) (if (keep vers) vers #f))
vlist) vlist)
(filter (lambda (vers) (semver-keep (filter (lambda (vers)
(if (drop (second vers)) #f vers)) (if (drop vers) #f vers))
(ebuild-fkc vlist keep-components))))) vlist)
keep-components))))
(filter-map (lambda (rel) (filter-map (lambda (rel)
(if (any (lambda (vers) (if (any (lambda (vers)
(string= (assoc-ref rel "version") (semver-eq? (assoc-ref rel "version-values")
(second vers))) vers))
vlist-filtered) vlist-filtered)
(append (list (cons "version-components" rel
(version-components
(assoc-ref rel
"version"))))
rel)
#f)) #f))
releases)))) 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 (define-public ebuild-cp-man
(lambda (parms) (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" "autogen"
(assoc-ref parms 'category) (assoc-ref parms 'category)
(assoc-ref parms 'name)) (assoc-ref parms 'name))
@ -269,19 +280,30 @@
file-name-separator-string)) file-name-separator-string))
(rel-in (last-ebuild-rel folder-in (rel-in (last-ebuild-rel folder-in
(assoc-ref parms 'name) (assoc-ref parms 'name)
(assoc-ref parms "version"))) genver))
(rel-out (last-ebuild-rel folder-out (rel-out (last-ebuild-rel folder-out
(assoc-ref parms 'name) (assoc-ref parms 'name)
(assoc-ref parms "version"))) genver))
(ebuild-name (lambda (rel) (ebuild-name (lambda (rel)
(string-append (assoc-ref parms 'name) (string-append (assoc-ref parms 'name)
"-" "-"
(assoc-ref parms "version") genver
(if (< 0 rel) (if (< 0 rel)
(string-append "-r" (string-append "-r"
(number->string rel)) (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 (if rel-in
(let ((path-in (string-join (list folder-in (let ((path-in (string-join (list folder-in
(ebuild-name rel-in)) (ebuild-name rel-in))
@ -302,70 +324,67 @@
(close port-in) (close port-in)
(close port-out) (close port-out)
(if (diff? data-in data-out (if (diff? data-in data-out
#:allow (lambda (a b) #:allow allow-keyword-comment-diff
(let* ((rx '(or (seq bos "#") #:print-delta (>= (assoc-ref parms "verbosity")
(seq bos verbosity-info))
"KEYWORDS=\"" (let ((output-port
(+ (or alphanumeric whitespace #\- #\~)) (open-output-file
"\""
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 (string-join (list folder-out
(ebuild-name (1+ rel-out))) (ebuild-name (1+ rel-out)))
file-name-separator-string)))) file-name-separator-string))))
(display data-in output-port) (display data-in output-port)
(close output-port) (close output-port)
(string-join (list folder-out (return (1+ rel-out)))
(ebuild-name (1+ rel-out)))
file-name-separator-string))
(if (diff? data-in data-out (if (diff? data-in data-out
#:allow (lambda (a b) #:allow allow-keyword-comment-diff
(let* ((rx '(seq bos #:print-delta (>= (assoc-ref parms "verbosity")
"KEYWORDS=\"" verbosity-info))
(+ (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 (let ((output-port (open-output-file
(string-join (list folder-out (return rel-out))))
(ebuild-name rel-out))
file-name-separator-string))))
(display data-in output-port) (display data-in output-port)
(close output-port) (close output-port)
(string-join (list folder-out (return rel-out))
(ebuild-name rel-out)) '())))
file-name-separator-string)) '()))
#false))) '()))))
#false))
#false))))
;;Procedure to generate the required ebuild from the given releases. (define-public ebuild-default-post
(define-public ebuild-gen (lambda (ebuilds parms)
(lambda* (parms releases #:key ;; (display "parms:") (newline)
(version-components (lambda (version) ;; (pretty-print parms)
(map (lambda (component) ;; (display "ebuild-created:") (newline)
(string->number component)) ;; (pretty-print ebuilds)
(string-split version #\.)))) (let* ((out-file (lambda (ebuild)
(keep-components (list 1 1 2))
(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) (string-join (list (assoc-ref parms 'repo)
(assoc-ref parms 'category) (assoc-ref parms 'category)
(assoc-ref parms 'name) (assoc-ref parms 'name)
ebuild) ebuild)
file-name-separator-string) file-name-separator-string)))
"manifest") (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
(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 #f)
(gen-ebuild-hook ebuild-from-tmpl)
(post-hook ebuild-default-post)
ignore-autogen-diff) ignore-autogen-diff)
"" ""
(if (>= (assoc-ref parms 'verbosity) verbosity-notice) (if (>= (assoc-ref parms 'verbosity) verbosity-notice)
@ -373,36 +392,32 @@
(pretty-print releases))) (pretty-print releases)))
(letrec* ((version-list (letrec* ((version-list
(map (lambda (release) (map (lambda (release)
(list (version-components (assoc-ref release "version")) (assoc-ref release "version-values"))
(assoc-ref release "version")))
releases)) releases))
(selected-versions (ebuild-fkc version-list keep-components)) (selected-versions (semver-keep version-list keep-components))
(distfiles '()) (ebuilds (append-map (lambda (vers)
(ebuilds (filter-map (let* ((vars (append
(lambda (vers) (car (filter
(let* ((vars (append (car (filter (lambda (rel) (lambda (rel)
(string= (assoc-ref rel "version") (equal? (assoc-ref rel
(second vers))) "version-values")
vers))
releases)) releases))
parms)) parms))
(ebuild-man (ebuild-cp-man vars)) (ebuild-man (ebuild-cp-man vars))
(ebuild-created (if (and (not ebuild-man) (ebuild-created
(not (drop (second vers))) (if (and (null? ebuild-man)
(or (find (lambda (test-vers) (not (drop vers))
(string= (second test-vers) (or (find
(second vers))) (lambda (test-vers)
(semver-eq? test-vers vers))
selected-versions) selected-versions)
(keep (second vers)))) (keep vers)))
(ebuild-from-tmpl (gen-ebuild-hook vars
vars
(assoc-ref parms 'verbosity) (assoc-ref parms 'verbosity)
#:tmpl template #:tmpl template
#:ignore-diff ignore-autogen-diff) #:ignore-diff ignore-autogen-diff)
ebuild-man))) ebuild-man)))
(if ebuild-created (post-hook ebuild-created vars)))
(set! distfiles
(append distfiles
(post-hook ebuild-created vars))))
ebuild-created))
version-list))) version-list)))
(values ebuilds distfiles)))) ebuilds)))

51
ebuild/gen/Makefile.am Normal file
View file

@ -0,0 +1,51 @@
################################################################################
# Makefile.am
# Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
#
# 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 <https://www.gnu.org/licenses/>.
################################################################################
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
# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
# 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

371
ebuild/gen/nodejs.scm Normal file
View file

@ -0,0 +1,371 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; nodejs.scm
;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;;
;; 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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)
(time<? (date->time-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)))

79
ebuild/pkt-map.scm Normal file
View file

@ -0,0 +1,79 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pkt-map.scm
;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;;
;; 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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))))

114
ebuild/repo.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; repo.scm ;; repo.scm
;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> ;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;; ;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; 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 ;; 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 pretty-print)
#:use-module (ice-9 textual-ports) #:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (git)
#:use-module (git bindings) #:use-module (git bindings)
#:use-module (git repository) #:use-module (git repository)
#:use-module (git clone) #:use-module (git clone)
#:use-module (git checkout) #:use-module (git checkout)
#:use-module (git reference)
#:use-module (git submodule) #:use-module (git submodule)
#:use-module (rx irregex)) #:use-module (rx irregex))
@ -107,7 +109,8 @@
(define-public cp-repo-file (define-public cp-repo-file
(lambda* (repo folder-dst folder-src file verbosity #:key (lambda* (repo folder-dst folder-src file verbosity #:key
(file-dst file) (file-dst file)
(sub-folder "")) (sub-folder "")
(required #t))
"" ""
(let ((file-in (string-join (list repo folder-src file) (let ((file-in (string-join (list repo folder-src file)
file-name-separator-string)) file-name-separator-string))
@ -139,9 +142,10 @@
file-name-separator-string) file-name-separator-string)
"manifest")) "manifest"))
(list (string-join (if (string=? sub-folder "") (list (string-join (if (string=? sub-folder "")
(list file-dst) (list folder-dst file-dst)
(list sub-folder file)) (list folder-dst file))
file-name-separator-string))))) file-name-separator-string)))))
(if (file-exists? file-in)
(if (eq? (stat:type (stat file-in)) 'directory) (if (eq? (stat:type (stat file-in)) 'directory)
(if (file-exists? file-out) (if (file-exists? file-out)
(if (eq? (stat:type (stat file-out)) 'directory) (if (eq? (stat:type (stat file-out)) 'directory)
@ -173,7 +177,11 @@
(close output-port)) (close output-port))
(finish))) (finish)))
(copy-file file-in file-out)) (copy-file file-in file-out))
(finish)))))) (finish)))
(if required
(error (string-append "Required repo file \""
file-in
"\" does not exits!")))))))
(define-public folder-list (define-public folder-list
(lambda (path ignore-meta) (lambda (path ignore-meta)
@ -183,7 +191,8 @@
(stat:type (stat (string-append path "/" entry)))) (stat:type (stat (string-append path "/" entry))))
(if (and ignore-meta (if (and ignore-meta
(or (string=? entry "metadata") (or (string=? entry "metadata")
(string=? entry "profiles"))) (string=? entry "profiles")
(string=? entry "autogen")))
#f #f
(if (char=? (car (string->list entry)) #\.) (if (char=? (car (string->list entry)) #\.)
#f entry)) #f entry))
@ -272,10 +281,15 @@
(newline))) (newline)))
(mkpath dst-path)) (mkpath dst-path))
;;cp each ebuild and the files folder. ;;cp each ebuild and the files folder.
(let ((test (append-map (append-map
(lambda (file) (lambda (file)
(let ((ret (cp-repo-file (map (lambda (dest)
(assoc-ref parms 'repo) (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) (string-join (list (assoc-ref parms 'category)
(assoc-ref parms 'name)) (assoc-ref parms 'name))
file-name-separator-string) file-name-separator-string)
@ -285,7 +299,6 @@
file-name-separator-string) file-name-separator-string)
file file
(assoc-ref parms 'verbosity)))) (assoc-ref parms 'verbosity))))
ret))
(filter-map (filter-map
(lambda (file) (lambda (file)
(if (irregex-search '(or (seq bos "files" eos) (if (irregex-search '(or (seq bos "files" eos)
@ -293,17 +306,18 @@
file) file)
file file
#f)) #f))
(scandir src-path))))) (if (file-exists? src-path)
test) (scandir src-path)
))) '()))))))
(define-public clean-files (define-public clean-ebuilds
(lambda (file-list file-folder verbosity) (lambda (pkg-list repo verbosity)
""
(letrec* ((for-each-file (letrec* ((for-each-file
(lambda (sub-path) (lambda (sub-path category pkg)
(append-map (append-map
(lambda (file) (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))) file-name-separator-string)))
(if (not (or (char=? (car (string->list file)) #\.) (if (not (or (char=? (car (string->list file)) #\.)
(string=? file "Manifest"))) (string=? file "Manifest")))
@ -311,35 +325,59 @@
(for-each-file (string-join (if (string=? sub-path "") (for-each-file (string-join (if (string=? sub-path "")
(list file) (list file)
(list sub-path file)) (list sub-path file))
file-name-separator-string)) file-name-separator-string)
category pkg)
(list (string-join (if (string=? sub-path "") (list (string-join (if (string=? sub-path "")
(list file) (list file)
(list sub-path file)) (list sub-path file))
file-name-separator-string))) 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)))))) file-name-separator-string))))))
;; (display "file-list:") (newline) (for-each (lambda (pkg)
;; (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) (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) (if (>= verbosity verbosity-notice)
(begin (display "Cleaned absolute file \"") (begin (display "Cleaned absolute pkg file \"")
(display absolute-file) (display "\"") (display absolute-file) (display "\"")
(newline))) (newline))))
(delete-file (string-join (list file-folder absolute-file)
file-name-separator-string)))
(filter-map (lambda (file) (filter-map (lambda (file)
(if (any (lambda (a) (if (any (lambda (pkg)
(string=? a file)) (any (lambda (pkg-file)
file-list) (string=? pkg-file file))
(assoc-ref pkg 'pkgfiles)))
pkg-list)
#false file)) #false file))
(for-each-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))))))

334
ebuild/semver.scm Normal file
View file

@ -0,0 +1,334 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; semver.scm
;; Copyright (C) 2026 Cor Legemaat <cor@cor.za.net>
;;
;; 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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)) #t)
(else (semver-less? (if (null? ref) '() (cdr ref))
(if (null? test) '() (cdr test))
#:cc (if (positive? cc)
(1- cc)
0)))))))
(define-public semver-leq?
(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 (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)))

101
ebuild/state.scm Normal file
View file

@ -0,0 +1,101 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; state.scm
;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;;
;; 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 <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))))

67
ebuild/utils.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utils.scm ;; utils.scm
;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net> ;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;; ;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it ;; 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 ;; under the terms of the GNU Affero General Public License as published by the
@ -16,8 +16,11 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (ebuild utils) (define-module (ebuild utils)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 regex)
#:use-module (rx irregex) #:use-module (rx irregex)
#:use-module (srfi srfi-1)) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19))
(define-public list->str-list (define-public list->str-list
(lambda* (in-list glue #:key (pre "") (post "")) (lambda* (in-list glue #:key (pre "") (post ""))
@ -42,24 +45,50 @@
test-list))) test-list)))
(define-public diff? (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))
"" ""
(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) (any (lambda (t) t)
(map (lambda (a b) (map (lambda (a b)
(if (string=? a b) (if (string=? a b)
#false #false
(allow a b))) (if (and print-delta
(if (string? data-a) (not (allow a b)))
(string-split data-a #\newline) (begin (display "Diff between lines:")
data-a) (newline)
(if (string? data-b) (display "\"") (display a) (display "\"")
(string-split data-b #\newline) (newline)
data-b))))) (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 (define-public last-ebuild-rel
(lambda (folder pkg version) (lambda (folder pkg version)
"" ""
(let* ((files (scandir folder)) (let* ((files (if (file-exists? folder)
(scandir folder)
'()))
(releases (filter-map (releases (filter-map
(lambda (file) (lambda (file)
(if (string=? file (string-append pkg (if (string=? file (string-append pkg
@ -115,3 +144,19 @@
(lambda (list1 list2) (lambda (list1 list2)
"" ""
(every string=? 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))))