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, [[
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
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_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])

7
ebuild/Makefile.am
View file

@ -1,6 +1,6 @@
################################################################################
# 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
# 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 <https://www.gnu.org/licenses/>.
################################################################################
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

298
ebuild/cli.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 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)

4
ebuild/fetchers/Makefile.am
View file

@ -1,6 +1,6 @@
################################################################################
# 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
# 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)

14
ebuild/fetchers/forgejo.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 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

15
ebuild/fetchers/github.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 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))

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))))

50
ebuild/fetchers/pypi.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 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))))

17
ebuild/fetchers/raw.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 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)

467
ebuild/gen.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 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)))

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))))

220
ebuild/repo.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 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))))))

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))))

75
ebuild/utils.scm
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 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))))