225 lines
10 KiB
Scheme
225 lines
10 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; repo.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 repo)
|
|
#:use-module (ebuild defs)
|
|
#:use-module (ebuild utils)
|
|
#:use-module (ice-9 exceptions)
|
|
#:use-module (ice-9 ftw)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (git bindings)
|
|
#:use-module (git repository)
|
|
#:use-module (rx irregex))
|
|
|
|
;; Required initialization call.
|
|
(libgit2-init!)
|
|
|
|
(define-public repo-root-for
|
|
(lambda (path verbosity)
|
|
(let ((repo-orig
|
|
(with-exception-handler
|
|
(lambda (exception)
|
|
(display exception) (newline)
|
|
(display "error: Failed to find the repository root for \"")
|
|
(display path)
|
|
(display "\", ebuild-autogen is designed to work with ")
|
|
(display "portage overlay repositories in git!") (newline)
|
|
(display "If you are testing and don't have a git repository ")
|
|
(display "yet for your overlay, make it one by running ")
|
|
(display "'git init' in the root of the repository.")
|
|
(newline))
|
|
(lambda ()
|
|
(repository-discover path)))))
|
|
(let ((repo-root (dirname repo-orig)))
|
|
(if (>= verbosity verbosity-notice)
|
|
(begin (display "Using repository: ")
|
|
(display repo-root)
|
|
(newline)))
|
|
(if (not (file-exists? (string-append repo-root
|
|
"/autogen/")))
|
|
(raise-exception
|
|
(make-exception
|
|
(make-external-error)
|
|
(make-exception-with-message
|
|
"Can't find the \"autogen\" folder in repository root")
|
|
(make-exception-with-irritants repo-root))))
|
|
repo-root))))
|
|
|
|
;;(repo-root-for "/home/cor/Projects/portage-overlay" verbosity-notice)
|
|
|
|
(define-public repo-update-src
|
|
(lambda ()
|
|
(display "Willing to update src subtree...") (newline)
|
|
#t))
|
|
|
|
(define-public repo-push-master
|
|
(lambda ()
|
|
(display "Willing to push updates to master...") (newline)
|
|
#t))
|
|
|
|
(define-public test-symlink
|
|
(lambda (repo src dst verbosity)
|
|
""
|
|
(let ((port (open-file repo "r")))
|
|
(if (false-if-exception (statat port src AT_SYMLINK_NOFOLLOW))
|
|
;;Check if src is a symlink.
|
|
(if (eq? (stat:type (statat port src AT_SYMLINK_NOFOLLOW)) 'symlink)
|
|
(if (string=? (readlink (string-append repo "/" src)) dst)
|
|
(if (>= verbosity verbosity-notice)
|
|
(begin (display "Symlink \"")
|
|
(display src)
|
|
(display "\" ok.")
|
|
(newline)))
|
|
(if (>= verbosity verbosity-critical)
|
|
(begin (display "warning: symlink from \"")
|
|
(display src)
|
|
(display "\" not pointing to \"")
|
|
(display dst)
|
|
(display "\" but to \"")
|
|
(display (readlink (string-append repo "/" src)))
|
|
(display "\" and might deliver unexpected results!")
|
|
(newline))))
|
|
(if (>= verbosity verbosity-critical)
|
|
(begin (display "warning: \"")
|
|
(display src)
|
|
(display "\" not a symbolic link and won't ")
|
|
(display "represent autogen source data!")
|
|
(newline))))
|
|
(begin (symlinkat port dst src)
|
|
(if (>= verbosity verbosity-warn)
|
|
(begin (display "Symlink \"")
|
|
(display src)
|
|
(display "\" created.")
|
|
(newline)))))
|
|
(close-port port))))
|
|
|
|
(define-public folder-list
|
|
(lambda (path ignore-meta)
|
|
""
|
|
;;(display "path=\"") (display path) (display "\"") (newline)
|
|
(filter-map (lambda (entry)
|
|
(if (eq? 'directory
|
|
(stat:type (stat (string-append path "/" entry))))
|
|
(if (and ignore-meta
|
|
(or (string=? entry "metadata")
|
|
(string=? entry "profiles")))
|
|
#f
|
|
(if (char=? (car (string->list entry)) #\.)
|
|
#f entry))
|
|
#f))
|
|
(scandir path))))
|
|
|
|
(define-public build-pkg-list
|
|
(lambda (repo folder in-autogen)
|
|
(let* ((file-seperator (car (string->list file-name-separator-string)))
|
|
(repo-list (string-split repo file-seperator))
|
|
(repo-path-len (length repo-list))
|
|
(fpl (let ((folder-list (string-split folder file-seperator)))
|
|
(if in-autogen
|
|
;; In autogen folder, aka the source pkgs.
|
|
(if (> (length folder-list) repo-path-len)
|
|
(if (string=? (car (take-right folder-list
|
|
(- (length folder-list)
|
|
repo-path-len)))
|
|
"autogen")
|
|
folder-list
|
|
(append repo-list
|
|
(list "autogen")
|
|
(take-right folder-list
|
|
(- (length folder-list)
|
|
repo-path-len))))
|
|
(append folder-list (list "autogen")))
|
|
;; Outside autogen folder, the generated pkgs.
|
|
(if (> (length folder-list) repo-path-len)
|
|
(if (string=? (car (take-right folder-list
|
|
(- (length folder-list)
|
|
repo-path-len)))
|
|
"autogen")
|
|
(append repo-list
|
|
(take-right folder-list
|
|
(- (length folder-list)
|
|
(1+ repo-path-len))))
|
|
folder-list)
|
|
folder-list))))
|
|
(depth (- (length fpl)
|
|
repo-path-len
|
|
(if in-autogen 1 0))))
|
|
;;(display "fpl=\"") (display fpl) (display "\"") (newline)
|
|
;;(display "folder-list:") (display (folder-list (string-join fpl "/") #t)) (newline)
|
|
(cond ((= depth 2)
|
|
(list (list (cons 'category (first (take-right fpl 2)))
|
|
(cons 'name (last fpl)))))
|
|
((= depth 1)
|
|
(map (lambda (pkg)
|
|
(list (cons 'category (last fpl))
|
|
(cons 'name pkg)))
|
|
(folder-list (string-join fpl file-name-separator-string)
|
|
#t)))
|
|
((= depth 0)
|
|
(if (null? (folder-list (string-join fpl file-name-separator-string)
|
|
#t))
|
|
(list (list))
|
|
(append-map (lambda (cat)
|
|
(map (lambda (pkg)
|
|
(list (cons 'category cat)
|
|
(cons 'name pkg)))
|
|
(folder-list (string-join (append fpl
|
|
(list cat))
|
|
file-name-separator-string)
|
|
#f)))
|
|
(folder-list (string-join fpl file-name-separator-string) #t))))
|
|
(else "")))))
|
|
|
|
(define-public setup-pkg
|
|
(lambda (parms)
|
|
""
|
|
(let ((src-path (string-join (list (assoc-ref parms 'repo)
|
|
"autogen"
|
|
(assoc-ref parms 'category)
|
|
(assoc-ref parms 'name))
|
|
file-name-separator-string))
|
|
(dst-path (string-join (list (assoc-ref parms 'repo)
|
|
(assoc-ref parms 'category)
|
|
(assoc-ref parms 'name))
|
|
file-name-separator-string)))
|
|
;;Check folder exists.
|
|
(display "SRC-path=") (display src-path) (newline)
|
|
(if (file-exists? dst-path)
|
|
(if (>= (assoc-ref parms 'verbosity))
|
|
(begin (display "Folder for ")
|
|
(display (assoc-ref parms 'category))
|
|
(display "/")
|
|
(display (assoc-ref parms 'name))
|
|
(display " already exist.")
|
|
(newline)))
|
|
(mkpath dst-path))
|
|
;;symlink each ebuild and the files folder.
|
|
(for-each
|
|
(lambda (file)
|
|
(test-symlink (assoc-ref parms 'repo)
|
|
(string-join (list dst-path file)
|
|
file-name-separator-string)
|
|
(string-join (list src-path file)
|
|
file-name-separator-string)
|
|
(assoc-ref parms 'verbosity)))
|
|
(filter-map
|
|
(lambda (file)
|
|
(if (irregex-search '(or (seq bos "files" eos)
|
|
(seq ".ebuild" eos ))
|
|
file)
|
|
file
|
|
#f))
|
|
(scandir src-path))))))
|