277 lines
13 KiB
Scheme
277 lines
13 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; cli.scm
|
|
;; Copyright (C) 2025 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 cli)
|
|
#:use-module (ice-9 exceptions)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (dql dql)
|
|
#:use-module (ebuild defs)
|
|
#:use-module (ebuild repo)
|
|
#:use-module (ebuild gen)
|
|
#:use-module (ebuild version)
|
|
#:use-module (config)
|
|
#:use-module (config api)
|
|
#:use-module (config parser sexp))
|
|
|
|
(define config
|
|
;; Define our root configuration
|
|
(configuration
|
|
(name 'ebuild-autogen)
|
|
(keywords
|
|
(list
|
|
;; Switch to force writing non-eager configuration files
|
|
(switch
|
|
(name 'write) (default #f) (test boolean?) (character #f)
|
|
(synopsis "Write configuration file in local dir."))
|
|
(switch
|
|
(name 'verbosity) (default 3) (example "3")
|
|
(handler string->number) (test integer?)
|
|
(synopsis "The verbosity level."))
|
|
(switch
|
|
(name 'subtree-update) (default #false) (test boolean?)
|
|
(synopsis "Fetch update subtree source repo"))
|
|
(switch
|
|
(name 'pkg-clean) (default #false) (test boolean?)
|
|
(synopsis "Remove packages from repo that's not in autogen subtree."))
|
|
(switch
|
|
(name 'ebuild-clean) (default #false) (test boolean?)
|
|
(synopsis "Remove ebuilds no more active."))
|
|
(switch
|
|
(name 'cache-clean) (default #false) (test boolean?)
|
|
(synopsis "Remove files from cache no more needed in tree gen."))
|
|
(switch
|
|
(name 'remote-push) (default #false) (test boolean?)
|
|
(synopsis "Commit and push updated tree to remote."))
|
|
(switch
|
|
(name 'init-from) (default "") (test string?)
|
|
(example "https://www.cor.za.net/code/portage-overlay")
|
|
(synopsis "An url to initialize the repo from scratch"))
|
|
;; A setting in the configuration file, if it exists.
|
|
(setting
|
|
(name 'github-token) (default "")
|
|
(handler identity) (test string?)
|
|
(synopsis "The github authentication token.")
|
|
(description "The github authentication token as a string for
|
|
authentication when pulling package updates from github."))
|
|
(setting
|
|
(name 'filecache-path)
|
|
(default (if (getenv "XDG_CACHE_HOME")
|
|
(getenv "XDG_CACHE_HOME")
|
|
(string-append (getenv "HOME")
|
|
"/.cache/ebuild-autogen")))
|
|
(example (string-append (getenv "HOME")
|
|
"/.cache/ebuild-autogen"))
|
|
(handler identity) (test string?)
|
|
(synopsis "Cache files path.")
|
|
(description "Full path to the folder where to store the file cache."))
|
|
(setting
|
|
(name 'tmp-path) (default "/tmp/ebuild-autogen/")
|
|
(example "/tmp/ebuild-autogen/")
|
|
(handler identity) (test string?)
|
|
(synopsis "Temporary files path.")
|
|
(description "Full path to the folder for the temporary files."))))
|
|
(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
|
|
the package from the subtree source residing in the autogen folder of the
|
|
git repository.")
|
|
(parser sexp-parser)
|
|
;; Specify where we want to install configuration files
|
|
(directory (list (if (getenv "XDG_CONFIG_HOME")
|
|
(path (given (getenv "XDG_CONFIG_HOME"))
|
|
(eager? #f))
|
|
(in-home ".config/" #:wait?))))
|
|
(version version-str)
|
|
(copyright (list 2025))
|
|
(license agpl3)
|
|
(author "Cor Legemaat")))
|
|
|
|
(define-public main
|
|
(lambda (cmd-line)
|
|
(let ((options (getopt-config-auto cmd-line config)))
|
|
(when (option-ref options 'write)
|
|
(options-write options))
|
|
(let* ((folder (getcwd))
|
|
(repo (repo-root-for folder (option-ref options 'verbosity)))
|
|
(parms (list (cons 'repo repo)
|
|
(cons 'verbosity (option-ref options 'verbosity))
|
|
(cons 'cache-path (option-ref options
|
|
'filecache-path))
|
|
(cons 'tmp-path (option-ref options 'tmp-path)))))
|
|
;; Init repo from url if requested.
|
|
;; TODO.
|
|
|
|
;; Add our repository to the load path.
|
|
(add-to-load-path (string-append repo "/autogen"))
|
|
|
|
;; Add optional parameters if exist.
|
|
(if (not (string-null? (option-ref options 'github-token)))
|
|
(set! parms
|
|
(assoc-set! parms
|
|
'github-token
|
|
(option-ref options 'github-token))))
|
|
(with-exception-handler
|
|
(lambda (exception)
|
|
(if (>= (option-ref options 'verbosity)
|
|
verbosity-warn)
|
|
(begin
|
|
(display "Failed to read the repo parameters 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 ((repo-mod (resolve-module `(repo-local settings))))
|
|
(if (module-variable repo-mod 'parms)
|
|
(set! parms (append parms
|
|
(module-ref repo-mod 'parms))))))
|
|
#:unwind? #t)
|
|
|
|
;; Update the source repository if requested.
|
|
(if (option-ref options 'subtree-update)
|
|
(repo-update-src))
|
|
|
|
;; Test the repo definition symlinks.
|
|
(test-symlink repo
|
|
"README.org"
|
|
"autogen/README-repo.org"
|
|
(option-ref options 'verbosity))
|
|
(test-symlink repo
|
|
"metadata"
|
|
"autogen/metadata"
|
|
(option-ref options 'verbosity))
|
|
(test-symlink repo
|
|
"profiles"
|
|
"autogen/profiles"
|
|
(option-ref options 'verbosity))
|
|
(test-symlink repo
|
|
"repositories.xml"
|
|
"autogen/repositories.xml"
|
|
(option-ref options 'verbosity))
|
|
(test-symlink repo
|
|
".gitignore"
|
|
"autogen/.gitignore-repo"
|
|
(option-ref options 'verbosity))
|
|
|
|
;; Preform ebuild generation.
|
|
(let ((pkg-list (build-pkg-list repo folder #t)))
|
|
(display "package-list:") (newline)
|
|
(pretty-print pkg-list)
|
|
(let ((cache-files-used
|
|
(map (lambda (pkg)
|
|
(let ((name (string->symbol (assoc-ref pkg 'name)))
|
|
(cat (string->symbol (assoc-ref pkg 'category))))
|
|
(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)))
|
|
(if pkg-mod
|
|
(let ((releases
|
|
(if (module-variable pkg-mod 'get-releases)
|
|
((module-ref pkg-mod 'get-releases)
|
|
(append parms pkg))
|
|
'())))
|
|
;; 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.
|
|
(if (module-variable pkg-mod 'generate-ebuilds)
|
|
((module-ref pkg-mod 'generate-ebuilds)
|
|
pkg-parms
|
|
releases)
|
|
(ebuild-gen pkg-parms
|
|
releases)))
|
|
(setup-pkg pkg-parms))
|
|
(display "Done with package: ")
|
|
(display (assoc-ref pkg 'category))
|
|
(display "/")
|
|
(display (assoc-ref pkg 'name))
|
|
(newline)))
|
|
#:unwind? (< 1 (length pkg-list)))))
|
|
pkg-list)))
|
|
;; Clean deprecated cache files if requested.
|
|
(display "distfiles-used:") (newline)
|
|
(pretty-print cache-files-used))
|
|
|
|
;; The extra folders in repo not in src.
|
|
(let ((repo-pkgs (build-pkg-list repo folder #f)))
|
|
;;(display "repo-pkgs:") (newline) (pretty-print repo-pkgs)
|
|
(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 "Obsolete pkg ")
|
|
(display (assoc-ref pkg 'category))
|
|
(display "/")
|
|
(display (assoc-ref pkg 'name))
|
|
(display " found.")
|
|
(newline)))))
|
|
repo-pkgs)))
|
|
|
|
;; Commit and push the updates to master if requested.
|
|
(if (option-ref options 'repo-push)
|
|
(repo-push-master))
|
|
|
|
(display "Completed successfully ...") (newline)))))
|