ebuild-autogen/ebuild/gen.scm

424 lines
17 KiB
Scheme
Raw Normal View History

2025-06-30 16:15:39 +02:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gen.scm
2026-03-30 07:00:06 +02:00
;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
2025-06-30 16:15:39 +02:00
;;
;; 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)
#:use-module (ebuild utils)
#:use-module (ebuild defs)
2026-03-30 07:00:06 +02:00
#:use-module (ebuild semver)
#:use-module (ebuild state)
2025-06-30 16:15:39 +02:00
#:use-module (dql dql)
#:use-module (rx irregex)
#:use-module (ice-9 pretty-print)
2026-03-30 07:00:06 +02:00
#:use-module (ice-9 receive)
2025-06-30 16:15:39 +02:00
#:use-module (ice-9 string-fun)
#:use-module (ice-9 textual-ports)
2026-03-30 07:00:06 +02:00
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19))
2025-06-30 16:15:39 +02:00
;;Function to generate template from ebuild with variable substitution.
(define-public ebuild-from-tmpl
(lambda* (vars verbosity #:key
2026-03-30 07:00:06 +02:00
(tmpl #f)
2025-06-30 16:15:39 +02:00
ignore-diff)
""
(letrec*
2026-03-30 07:00:06 +02:00
((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"))
2025-06-30 16:15:39 +02:00
;; Remove mode-line of tmpl file.
2026-03-30 07:00:06 +02:00
(let ((raw (string-split (get-string-all input-port)
#\lf)))
2025-06-30 16:15:39 +02:00
(if (irregex-search '(seq (+ "#")
(+ space)
"-*-"
(+ space))
(car raw))
(cdr raw)
raw))))
(traverse-list
(lambda (pre no data)
(traverse (string-append (if (symbol? pre)
(symbol->string pre)
pre)
"["
(number->string no)
"]")
2026-03-30 07:00:06 +02:00
(if (null? data) '() (car data)))
2025-06-30 16:15:39 +02:00
(if (not (null? (cdr data)))
(traverse-list pre (1+ no) (cdr data)))))
(traverse-alist
(lambda (pre data)
2026-03-30 07:00:06 +02:00
(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))))
2025-06-30 16:15:39 +02:00
(traverse (lambda (pre data)
2026-03-30 07:00:06 +02:00
(cond ((null? data) '())
((alist? data)
(traverse-alist pre data))
2025-06-30 16:15:39 +02:00
((list? data)
(traverse-list pre 0 data))
((number? data)
(replace pre (number->string data)))
((string? data) (replace pre data))
2026-03-30 07:00:06 +02:00
((eqv? #f data) (replace pre "false"))
((eqv? #t data) (replace pre "true"))
((time? data)
(replace pre (number->string (time-second data))))
2025-06-30 16:15:39 +02:00
(else (error (string-append "Error! Don't know how "
"to process \""
(object->string data)
"\" data type."))))))
(replace
(lambda (var val)
(let ((var-str (string-append "{{"
(if (symbol? var)
(symbol->string var)
var)
"}}")))
(if (>= verbosity verbosity-info)
(begin (display "Replacing \"") (display var-str)
(display "\" with \"") (display val)
(display "\"") (newline)))
(set! data (map (lambda (line)
(string-replace-substring line
var-str
val))
2026-03-30 07:00:06 +02:00
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)
'())))))))
2025-06-30 16:15:39 +02:00
(traverse "" vars)
(let* ((folder-out (string-join (list (assoc-ref vars 'repo)
(assoc-ref vars 'category)
(assoc-ref vars 'name))
file-name-separator-string))
(rel (last-ebuild-rel folder-out
(assoc-ref vars 'name)
2026-03-30 07:00:06 +02:00
(comps->genver (assoc-ref vars
"version-values"))))
2025-06-30 16:15:39 +02:00
(ebuild-name (lambda (rel)
2026-03-30 07:00:06 +02:00
(string-append
(assoc-ref vars 'name)
"-"
(comps->genver (assoc-ref vars "version-values"))
(if (< 0 rel)
(string-append "-r"
(number->string rel))
"")
".ebuild"))))
2025-06-30 16:15:39 +02:00
(if (file-exists? (string-join (list folder-out
(ebuild-name rel))
file-name-separator-string))
(if (and (not ignore-diff)
(diff? data
2026-03-30 07:00:06 +02:00
(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.
2025-06-30 16:15:39 +02:00
(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)
2026-03-30 07:00:06 +02:00
(final-ebuild (ebuild-name (1+ rel))))
;; Data differs.
(final-ebuild (ebuild-name rel)))
2025-06-30 16:15:39 +02:00
(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)
2026-03-30 07:00:06 +02:00
(final-ebuild (ebuild-name rel))))))))
2025-06-30 16:15:39 +02:00
(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)))
(keep (lambda (version) #f))
(drop (lambda (version) #f)))
""
(let* ((vlist (map (lambda (release)
2026-03-30 07:00:06 +02:00
(assoc-ref release "version-values"))
2025-06-30 16:15:39 +02:00
releases))
(vlist-filtered
(append (filter (lambda (vers)
2026-03-30 07:00:06 +02:00
(if (keep vers) vers #f))
2025-06-30 16:15:39 +02:00
vlist)
2026-03-30 07:00:06 +02:00
(semver-keep (filter (lambda (vers)
(if (drop vers) #f vers))
vlist)
keep-components))))
2025-06-30 16:15:39 +02:00
(filter-map (lambda (rel)
(if (any (lambda (vers)
2026-03-30 07:00:06 +02:00
(semver-eq? (assoc-ref rel "version-values")
vers))
2025-06-30 16:15:39 +02:00
vlist-filtered)
2026-03-30 07:00:06 +02:00
rel
2025-06-30 16:15:39 +02:00
#f))
releases))))
2026-03-30 07:00:06 +02:00
(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))))
2025-06-30 16:15:39 +02:00
(define-public ebuild-cp-man
(lambda (parms)
""
2026-03-30 07:00:06 +02:00
(let* ((genver (comps->genver (assoc-ref parms "version-values")))
(folder-in (string-join (list (assoc-ref parms 'repo)
2025-06-30 16:15:39 +02:00
"autogen"
(assoc-ref parms 'category)
(assoc-ref parms 'name))
file-name-separator-string))
(folder-out (string-join (list (assoc-ref parms 'repo)
(assoc-ref parms 'category)
(assoc-ref parms 'name))
file-name-separator-string))
(rel-in (last-ebuild-rel folder-in
(assoc-ref parms 'name)
2026-03-30 07:00:06 +02:00
genver))
2025-06-30 16:15:39 +02:00
(rel-out (last-ebuild-rel folder-out
(assoc-ref parms 'name)
2026-03-30 07:00:06 +02:00
genver))
2025-06-30 16:15:39 +02:00
(ebuild-name (lambda (rel)
(string-append (assoc-ref parms 'name)
"-"
2026-03-30 07:00:06 +02:00
genver
2025-06-30 16:15:39 +02:00
(if (< 0 rel)
(string-append "-r"
(number->string rel))
"")
2026-03-30 07:00:06 +02:00
".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)
'())))))))
2025-06-30 16:15:39 +02:00
(if rel-in
(let ((path-in (string-join (list folder-in
(ebuild-name rel-in))
file-name-separator-string))
(path-out (string-join (list folder-out
(ebuild-name rel-out))
file-name-separator-string)))
(if (and (< 0 rel-in)
(< verbosity-warn (assoc-ref parms 'verbosity)))
(begin (display "Warning: Source ebuild should not have ")
(display "revisions, handled automatically!")
(newline)))
(if (file-exists? path-in)
(let* ((port-in (open-input-file path-in))
(port-out (open-input-file path-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
2026-03-30 07:00:06 +02:00
#: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))))
2025-06-30 16:15:39 +02:00
(display data-in output-port)
(close output-port)
2026-03-30 07:00:06 +02:00
(return (1+ rel-out)))
2025-06-30 16:15:39 +02:00
(if (diff? data-in data-out
2026-03-30 07:00:06 +02:00
#:allow allow-keyword-comment-diff
#:print-delta (>= (assoc-ref parms "verbosity")
verbosity-info))
2025-06-30 16:15:39 +02:00
(let ((output-port (open-output-file
2026-03-30 07:00:06 +02:00
(return rel-out))))
2025-06-30 16:15:39 +02:00
(display data-in output-port)
(close output-port)
2026-03-30 07:00:06 +02:00
(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)))
2025-06-30 16:15:39 +02:00
;;Procedure to generate the required ebuild from the given releases.
(define-public ebuild-gen
(lambda* (parms releases #:key
2026-03-30 07:00:06 +02:00
(keep-components (if (assoc-ref parms 'keep-vers-comps)
(assoc-ref parms 'keep-vers-comps)
(list 1 1 1)))
2025-06-30 16:15:39 +02:00
(keep (lambda (version) #f))
(drop (lambda (version) #f))
2026-03-30 07:00:06 +02:00
(template #f)
(gen-ebuild-hook ebuild-from-tmpl)
(post-hook ebuild-default-post)
2025-06-30 16:15:39 +02:00
ignore-autogen-diff)
""
(if (>= (assoc-ref parms 'verbosity) verbosity-notice)
(begin (display "Releases:\n")
(pretty-print releases)))
(letrec* ((version-list
(map (lambda (release)
2026-03-30 07:00:06 +02:00
(assoc-ref release "version-values"))
2025-06-30 16:15:39 +02:00
releases))
2026-03-30 07:00:06 +02:00
(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)))