mirror of
https://codeberg.org/cage/tinmop/
synced 2025-03-26 13:00:05 +01:00
- [GUI] added procedures to get client configuration.
This commit is contained in:
cage
parent
3a0074811d
commit
572eb5c1b7
213
src/gui/client/client-configuration.lisp
Normal file
213
src/gui/client/client-configuration.lisp
Normal file
@ -0,0 +1,213 @@
|
||||
;; tinmop: an humble gemini and pleroma client
|
||||
;; Copyright (C) 2022 cage
|
||||
|
||||
;; This program is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program 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 this program.
|
||||
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
|
||||
|
||||
(in-package :client-configuration)
|
||||
|
||||
;; see src/software-configuration for the grammar
|
||||
|
||||
(defparameter *client-configuration* ())
|
||||
|
||||
(a:define-constant +client-conf-filename+ "gui.conf" :test #'string=)
|
||||
|
||||
(swconf::gen-key-constants text
|
||||
font
|
||||
size
|
||||
weight
|
||||
slant
|
||||
underline
|
||||
preformatted-text)
|
||||
|
||||
(defun load-config-file (&optional (virtual-filepath +client-conf-filename+)
|
||||
(perform-missing-value-check nil))
|
||||
(let* ((file (res:get-config-file virtual-filepath))
|
||||
(tree (swconf:parse-config (fs:namestring->pathname file))))
|
||||
(loop for entry in tree do
|
||||
(let ((key (first entry))
|
||||
(value (second entry)))
|
||||
(cond
|
||||
((keywordp key)
|
||||
(setf (access:accesses *client-configuration* key) value))
|
||||
(t
|
||||
(multiple-value-bind (rest all)
|
||||
(apply #'access:set-accesses value *client-configuration* key)
|
||||
(declare (ignore rest))
|
||||
(setf *client-configuration* all))))))
|
||||
(when perform-missing-value-check
|
||||
(swconf:perform-missing-value-check file))
|
||||
(if *client-configuration*
|
||||
(values *client-configuration* file)
|
||||
(error (format nil (_ "fatal error: The file ~a is empty") file)))))
|
||||
|
||||
;;;; end of parser
|
||||
|
||||
(defun gemini-default-favicon ()
|
||||
(swconf:access-non-null-conf-value *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-favicon+))
|
||||
|
||||
(defun gemini-update-gemlog-at-start-p ()
|
||||
(let ((value (access:accesses *client-configuration*
|
||||
swconf:+key-start+
|
||||
swconf:+key-update+
|
||||
swconf:+key-gemlog+)))
|
||||
(not (swconf:false-value-p value))))
|
||||
|
||||
(defun gemini-window-colors ()
|
||||
(values (access:accesses *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-main-window+
|
||||
swconf:+key-background+)
|
||||
(access:accesses *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-main-window+
|
||||
swconf:+key-foreground+)))
|
||||
|
||||
(defun font-configuration (key)
|
||||
(values (access:accesses *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
key
|
||||
+key-font+)
|
||||
(access:accesses *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
key
|
||||
+key-size+)
|
||||
(access:accesses *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
key
|
||||
+key-weight+)
|
||||
(access:accesses *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
key
|
||||
+key-slant+)
|
||||
(not (swconf:false-value-p (access:accesses *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
key
|
||||
+key-underline+)))))
|
||||
|
||||
(defmacro gen-font-configuration (key)
|
||||
(let* ((no-key (cl-ppcre:regex-replace-all "key-" (string-downcase (symbol-name key)) ""))
|
||||
(no-plus (text-utils:trim-blanks no-key '(#\+))))
|
||||
`(defun ,(misc:format-fn-symbol t "gemini-~a-font-configuration" no-plus) ()
|
||||
(font-configuration ,key))))
|
||||
|
||||
(gen-font-configuration +key-text+)
|
||||
|
||||
(gen-font-configuration swconf:+key-link+)
|
||||
|
||||
(gen-font-configuration swconf:+key-quote+)
|
||||
|
||||
(gen-font-configuration swconf:+key-h1+)
|
||||
|
||||
(gen-font-configuration swconf:+key-h2+)
|
||||
|
||||
(gen-font-configuration swconf:+key-h3+)
|
||||
|
||||
(gen-font-configuration swconf:+key-preformatted-text+)
|
||||
|
||||
(defun gemini-link-configuration ()
|
||||
(values (access:accesses *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-link+
|
||||
swconf:+key-background+)
|
||||
(access:accesses *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-link+
|
||||
swconf:+key-foreground+)
|
||||
(access:accesses *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-link+
|
||||
swconf:+key-attribute+)))
|
||||
|
||||
(defun gemini-link-prefix (scheme)
|
||||
(swconf:access-non-null-conf-value *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-link+
|
||||
swconf:+key-scheme+
|
||||
scheme
|
||||
swconf:+key-prefix+))
|
||||
|
||||
(defun gemini-link-prefix-to-gemini ()
|
||||
(gemini-link-prefix swconf:+key-gemini+))
|
||||
|
||||
(defun gemini-link-prefix-to-other ()
|
||||
(gemini-link-prefix swconf:+key-other+))
|
||||
|
||||
(defun gemini-link-prefix-to-http ()
|
||||
(gemini-link-prefix swconf:+key-http+))
|
||||
|
||||
(defun gemini-quote-prefix ()
|
||||
(swconf:access-non-null-conf-value *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-quote+
|
||||
swconf:+key-prefix+))
|
||||
|
||||
(defun gemini-quote-configuration ()
|
||||
(swconf:access-non-null-conf-value *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-quote+
|
||||
swconf:+key-attribute+))
|
||||
|
||||
(defun gemini-h*-prefix (level)
|
||||
(swconf:access-non-null-conf-value *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
level
|
||||
swconf:+key-prefix+))
|
||||
|
||||
(defun gemini-h1-prefix ()
|
||||
(gemini-h*-prefix swconf:+key-h1+))
|
||||
|
||||
(defun gemini-h2-prefix ()
|
||||
(gemini-h*-prefix swconf:+key-h2+))
|
||||
|
||||
(defun gemini-h3-prefix ()
|
||||
(gemini-h*-prefix swconf:+key-h3+))
|
||||
|
||||
(defun gemini-bullet-prefix ()
|
||||
(swconf:access-non-null-conf-value *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-bullet+
|
||||
swconf:+key-prefix+))
|
||||
|
||||
(defun gemini-preformatted-fg ()
|
||||
(or (swconf:access-non-null-conf-value *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-preformatted-text+
|
||||
swconf:+key-foreground+)
|
||||
:white))
|
||||
|
||||
(defun gemini-preformatted-configuration ()
|
||||
(or (swconf:access-non-null-conf-value *client-configuration*
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-preformatted-text+
|
||||
swconf:+key-attribute+)
|
||||
:white))
|
||||
|
||||
(defun gemini-toc-padding-char ()
|
||||
(let ((padding-from-conf (access:accesses *client-configuration*
|
||||
swconf:+key-gemini-toc-window+
|
||||
swconf:+key-padding+)))
|
||||
(if padding-from-conf
|
||||
(elt padding-from-conf 0)
|
||||
#\Space)))
|
||||
|
||||
(swconf:gen-simple-access (gemini-fragment-as-regex-p
|
||||
:transform-value-fn (lambda (a) (not (swconf:false-value-p a))))
|
||||
swconf:+key-experimental+
|
||||
swconf:+key-gemini+
|
||||
swconf:+key-iri+
|
||||
swconf:+key-fragment+
|
||||
swconf:+key-regex+)
|
||||
Loading…
x
Reference in New Issue
Block a user