From 7c6ecafd610ebe263131e538f7eabc06eacffdbd Mon Sep 17 00:00:00 2001 From: John Ralls Date: Sun, 11 Jul 2021 15:03:13 -0700 Subject: [PATCH] Rewrite options.scm to wrap options.hpp functions where needed. --- libgnucash/app-utils/options.scm | 2187 +++++------------------------- 1 file changed, 324 insertions(+), 1863 deletions(-) diff --git a/libgnucash/app-utils/options.scm b/libgnucash/app-utils/options.scm index 2188c4eaa0..4acf907baa 100644 --- a/libgnucash/app-utils/options.scm +++ b/libgnucash/app-utils/options.scm @@ -25,1831 +25,89 @@ (use-modules (gnucash core-utils)) (use-modules (gnucash engine)) (use-modules (sw_app_utils)) -(use-modules (gnucash app-utils date-utilities)) (use-modules (gnucash utilities)) (use-modules (srfi srfi-1)) (use-modules (ice-9 regex)) +(use-modules (ice-9 format)) +(use-modules (ice-9 pretty-print)) -(export gnc:color->html) -(export gnc:color-option->hex-string) -(export gnc:color-option->html) -(export gnc:currency-accounting-option-get-curr-doc-string) -(export gnc:currency-accounting-option-get-default-curr) -(export gnc:currency-accounting-option-get-default-policy) -(export gnc:currency-accounting-option-get-gain-loss-account-doc-string) -(export gnc:currency-accounting-option-get-policy-doc-string) -(export gnc:currency-accounting-option-selected-currency) -(export gnc:currency-accounting-option-selected-gain-loss-account) -(export gnc:currency-accounting-option-selected-method) -(export gnc:currency-accounting-option-selected-policy) -(export gnc:date-option-absolute-time) -(export gnc:date-option-get-subtype) -(export gnc:date-option-relative-time) -(export gnc:date-option-show-time?) -(export gnc:date-option-value-type) -(export gnc:dateformat-get-format) -(export gnc:generate-restore-forms) -(export gnc:get-rd-option-data-rd-list) -(export gnc:get-rd-option-data-show-time) -(export gnc:get-rd-option-data-subtype) -(export gnc:lookup-option) -(export gnc:make-account-list-limited-option) -(export gnc:make-account-list-option) -(export gnc:make-account-sel-limited-option) -(export gnc:make-account-sel-option) -(export gnc:make-budget-option) -(export gnc:make-color-option) -(export gnc:make-commodity-option) -(export gnc:make-complex-boolean-option) -(export gnc:make-currency-option) -(export gnc:make-date-option) -(export gnc:make-dateformat-option) -(export gnc:make-font-option) -(export gnc:make-internal-option) -(export gnc:make-list-option) -(export gnc:make-multichoice-callback-option) -(export gnc:make-multichoice-option) -(export gnc:make-number-plot-size-option) -(export gnc:make-number-range-option) -(export gnc:make-option) -(export gnc:make-pixmap-option) -(export gnc:make-query-option) -(export gnc:make-radiobutton-callback-option) -(export gnc:make-radiobutton-option) -(export gnc:make-simple-boolean-option) -(export gnc:make-string-option) -(export gnc:make-text-option) -(export gnc:multichoice-list-lookup) -(export gnc:new-options) -(export gnc:option-data) -(export gnc:option-data-fns) -(export gnc:option-default-getter) -(export gnc:option-default-value) -(export gnc:option-documentation) -(export gnc:option-generate-restore-form) -(export gnc:option-get-value) -(export gnc:option-getter) -(export gnc:option-index-get-name) -(export gnc:option-index-get-value) -(export gnc:option-kvp->scm) -(export gnc:option-make-internal!) -(export gnc:option-name) -(export gnc:option-number-of-indices) -(export gnc:option-scm->kvp) -(export gnc:option-section) -(export gnc:option-set-changed-callback) -(export gnc:option-set-default-value) -(export gnc:option-set-value) -(export gnc:option-setter) -(export gnc:option-sort-tag) -(export gnc:option-strings-getter) -(export gnc:option-type) -(export gnc:option-value) -(export gnc:option-value-get-index) -(export gnc:option-value-validator) -(export gnc:option-widget-changed-proc) -(export gnc:options-clear-changes) -(export gnc:options-copy-values) -(export gnc:options-for-each) -(export gnc:options-for-each-general) -(export gnc:options-get-default-section) -(export gnc:options-kvp->scm) -(export gnc:options-make-date-interval!) -(export gnc:options-make-end-date!) -(export gnc:options-register-c-callback) -(export gnc:options-register-callback) -(export gnc:options-run-callbacks) -(export gnc:options-scm->kvp) -(export gnc:options-set-default-section) -(export gnc:options-touch) -(export gnc:options-unregister-callback-id) -(export gnc:plot-size-option-value) -(export gnc:plot-size-option-value-type) -(export gnc:register-option) -(export gnc:restore-form-generator) -(export gnc:send-options) -(export gnc:set-option-kvp->scm) -(export gnc:set-option-scm->kvp) -(export gnc:unregister-option) -(export gnc:value->string) -(export gnc:*option-name-trading-accounts*) -(export gnc:*option-name-book-currency*) -(export gnc:*option-section-accounts*) -(export gnc:*option-name-default-gains-policy*) -(export gnc:*option-name-default-gain-loss-account*) +(define-public (gnc:value->string value) + (format #f "~s" value)) -(define gnc:*option-section-accounts* OPTION-SECTION-ACCOUNTS) -(define gnc:*option-name-trading-accounts* OPTION-NAME-TRADING-ACCOUNTS) +(define-public (gnc:lookup-option options section name) + (if options + (gnc-lookup-option options section name) + #f)) -(define (gnc:option-get-value book category key) +(define-public (gnc:option-setter option) + (issue-deprecation-warning "gnc:option-setter is deprecated. Option values are set and retrieved by gnc-set-option and gnc-option-db-lookup.") + (lambda (value) + (GncOption-set-value-from-scm option value) + )) + +(define-public (gnc:option-set-value option value) + (issue-deprecation-warning "gnc:option-set-value and indeed all direct option access is deprecated. Use gnc-set-option instead.") + (GncOption-set-value-from-scm option value)) + +(define-public (gnc:option-set-default-value option value) + (issue-deprecation-warning "gnc:option-set-default-value and indeed all direct option access is deprecated. Use gnc-set-option instead.") + (GncOption-set-default-value-from-scm option value)) + +(define-public (gnc:option-section option) + (GncOption-get-section option)) + +(define-public (gnc:option-name option) + (GncOption-get-name option)) + +(define-public (gnc:option-default-value option) + (GncOption-get-scm-default-value option)) + +(define-public (gnc:option-value option) + (issue-deprecation-warning "gnc:option-value and indeed all direct option access is deprecated. Use gnc-option-db-lookup-option instead.") + (GncOption-get-scm-value option)) + +(define-public (gnc:color-option->html opt) + (format #f "#~a" (GncOption-get-scm-value opt))) + +(define-public (gnc:color-option->hex-string opt) + (format #f "~a" (GncOption-get-scm-value opt))) + +(define-public (gnc:option-get-value book category key) (define acc (if (pair? key) cons list)) (qof-book-get-option book (acc category key))) -(define (rpterror-earlier type newoption fallback) - ;; Translators: the 3 ~a below refer to (1) option type (2) unknown - ;; new option name, (3) fallback option name. The order is - ;; important, and must not be changed. - (let* ((template (N_ "This report was saved using a later version of \ -GnuCash. One of the newer ~a options '~a' is not available, fallback to \ -the option '~a'.")) - (console-msg (format #f template type newoption fallback)) - (ui-msg (format #f (G_ template) type newoption fallback))) - (gnc:gui-warn console-msg ui-msg))) - -(define (gnc:make-option - ;; The category of this option - section - name - ;; The sort-tag determines the relative ordering of options in - ;; this category. It is used by the gui for display. - sort-tag - type - documentation-string - getter - ;; The setter is responsible for ensuring that the value is valid. - setter - default-getter - ;; Restore form generator should generate an ascii representation - ;; of a function taking one argument. The argument will be an - ;; option. The function should restore the option to the original - ;; value. - generate-restore-form - ;; the scm->kvp and kvp->scm functions should save and load - ;; the option to the book. The arguments to these function will be - ;; a book and a base key-path list for this option. - scm->kvp - kvp->scm - ;; Validation func should accept a value and return (#t value) - ;; on success, and (#f "failure-message") on failure. If #t, - ;; the supplied value will be used by the gui to set the option. - value-validator - ;;; free-form storage depending on type. - option-data - ;; If this is a "multiple choice" type of option, - ;; this should be a vector of the following five functions: - ;; - ;; Function 1: taking no arguments, giving the number of choices - ;; - ;; Function 2: taking one argument, a non-negative integer, that - ;; returns the scheme value (usually a symbol) matching the - ;; nth choice - ;; - ;; Function 3: taking one argument, a non-negative integer, - ;; that returns the string matching the nth choice - ;; - ;; Function 4: #f, this was the individual tool tip and not used now - ;; - ;; Function 5: giving a possible value and returning the index - ;; if an option doesn't use these, this should just be a #f - option-data-fns - ;; This function should return a list of all the strings - ;; in the option other than the section, name, (define - ;; (list-lookup list item) and documentation-string that - ;; might be displayed to the user (and thus should be - ;; translated). - strings-getter - ;; This function will be called when the GUI representation - ;; of the option is changed. This will normally occur before - ;; the setter is called, because setters are only called when - ;; the user selects "OK" or "Apply". Therefore, this - ;; callback shouldn't be used to make changes to the actual - ;; options database. - option-widget-changed-proc) - (let ((changed-callback #f)) - (vector section - name - sort-tag - type - documentation-string - getter - (lambda args - (apply setter args) - (if changed-callback (changed-callback))) - default-getter - generate-restore-form - scm->kvp - kvp->scm - value-validator - option-data - option-data-fns - (lambda (callback) (set! changed-callback callback)) - strings-getter - option-widget-changed-proc))) - -(define (gnc:option-section option) - (vector-ref option 0)) -(define (gnc:option-name option) - (vector-ref option 1)) -(define (gnc:option-sort-tag option) - (vector-ref option 2)) -(define (gnc:option-type option) - (vector-ref option 3)) -(define (gnc:option-documentation option) - (vector-ref option 4)) -(define (gnc:option-getter option) - (vector-ref option 5)) -(define (gnc:option-setter option) - (vector-ref option 6)) -(define (gnc:option-default-getter option) - (vector-ref option 7)) -(define (gnc:option-generate-restore-form option) - (vector-ref option 8)) -(define (gnc:option-scm->kvp option) - (vector-ref option 9)) -(define (gnc:set-option-scm->kvp option v) - (vector-set! option 9 v)) -(define (gnc:option-kvp->scm option) - (vector-ref option 10)) -(define (gnc:set-option-kvp->scm option v) - (vector-set! option 10 v)) -(define (gnc:option-value-validator option) - (vector-ref option 11)) -(define (gnc:option-data option) - (vector-ref option 12)) -(define (gnc:option-data-fns option) - (vector-ref option 13)) - -(define (gnc:option-set-changed-callback option callback) - (let ((cb-setter (vector-ref option 14))) - (cb-setter callback))) -(define (gnc:option-strings-getter option) - (vector-ref option 15)) -(define (gnc:option-widget-changed-proc option) - (vector-ref option 16)) - -(define (gnc:option-value option) - (let ((getter (gnc:option-getter option))) - (getter))) - -(define (gnc:option-set-value option value) - (let ((setter (gnc:option-setter option))) - (setter value))) - -(define (gnc:option-index-get-name option index) - (let* ((option-data-fns (gnc:option-data-fns option)) - (name-fn (vector-ref option-data-fns 2))) - (name-fn index))) - -(define (gnc:option-index-get-value option index) - (let* ((option-data-fns (gnc:option-data-fns option)) - (name-fn (vector-ref option-data-fns 1))) - (name-fn index))) - -(define (gnc:option-value-get-index option value) - (let* ((option-data-fns (gnc:option-data-fns option)) - (name-fn (vector-ref option-data-fns 4))) - (name-fn value))) - -(define (gnc:option-number-of-indices option) - (let* ((option-data-fns (gnc:option-data-fns option)) - (name-fn (vector-ref option-data-fns 0))) - (name-fn))) - -(define (gnc:option-default-value option) - (let ((getter (gnc:option-default-getter option))) - (getter))) - -;; Attention: this function can only be used with restrictions -;; - only during option generation, not in arbitrary code -;; - only for option types for which no conversion is required -;; between default-value and value. In the various gnc:make-option -;; functions below this is ok when -;; 1. there's (value default-value) in the let* call -;; 2. default-getter is set to (lambda() default-value) -(define (gnc:option-set-default-value option default-value) - (vector-set! option 7 (lambda() default-value)) - (gnc:option-set-value option default-value)) - - -(define (gnc:restore-form-generator value->string) - (lambda () - (string-append "(lambda (o) (if o (gnc:option-set-value o " - (value->string) ")))"))) - -(define (gnc:value->string value) - (format #f "~s" value)) - -(define (gnc:make-string-option - section - name - sort-tag - documentation-string - default-value) - (let* ((value default-value) - (value->string (lambda () (gnc:value->string value)))) - (gnc:make-option - section name sort-tag 'string documentation-string - (lambda () value) - (lambda (x) (set! value x)) - (lambda () default-value) - (gnc:restore-form-generator value->string) - (lambda (b p) (qof-book-set-option b value p)) - (lambda (b p) - (let ((v (qof-book-get-option b p))) - (if (and v (string? v)) - (set! value v)))) - (lambda (x) - (cond ((string? x)(list #t x)) - (else (list #f "string-option: not a string")))) - #f #f #f #f))) - -(define (gnc:make-text-option - section - name - sort-tag - documentation-string - default-value) - (let* ((value default-value) - (value->string (lambda () (gnc:value->string value)))) - (gnc:make-option - section name sort-tag 'text documentation-string - (lambda () value) - (lambda (x) (set! value x)) - (lambda () default-value) - (gnc:restore-form-generator value->string) - (lambda (b p) (qof-book-set-option b value p)) - (lambda (b p) - (let ((v (qof-book-get-option b p))) - (if (and v (string? v)) - (set! value v)))) - (lambda (x) - (cond ((string? x)(list #t x)) - (else (list #f "text-option: not a string")))) - #f #f #f #f))) - -;;; font options store fonts as strings a la the X Logical -;;; Font Description. You should always provide a default -;;; value, as currently there seems to be no way to go from -;;; an actual font to a logical font description, and thus -;;; there is no way for the gui to pick a default value. - -(define (gnc:make-font-option - section - name - sort-tag - documentation-string - default-value) - (let* ((value default-value) - (value->string (lambda () (gnc:value->string value)))) - (gnc:make-option - section - name - sort-tag - 'font - documentation-string - (lambda () value) - (lambda (x) (set! value x)) - (lambda () default-value) - (gnc:restore-form-generator value->string) - (lambda (b p) (qof-book-set-option b value p)) - (lambda (b p) - (let ((v (qof-book-get-option b p))) - (if (and v (string? v)) - (set! value v)))) - (lambda (x) - (cond ((string? x)(list #t x)) - (else (list #f "font-option: not a string")))) - #f #f #f #f))) - -;; currency options use a specialized widget for entering currencies -;; in the GUI implementation. -(define (gnc:make-currency-option - section - name - sort-tag - documentation-string - default-value) - - (define (currency->scm currency) - (if (string? currency) - currency - (gnc-commodity-get-mnemonic currency))) - - (define (scm->currency currency) - (if (string? currency) - (gnc-commodity-table-lookup - (gnc-commodity-table-get-table (gnc-get-current-book)) - GNC_COMMODITY_NS_CURRENCY currency) - currency)) - - (let* ((value (currency->scm default-value)) - (value->string (lambda () (gnc:value->string value)))) - (gnc:make-option - section name sort-tag 'currency documentation-string - (lambda () (scm->currency value)) - (lambda (x) (set! value (currency->scm x))) - (lambda () (scm->currency default-value)) - (gnc:restore-form-generator value->string) - (lambda (b p) (qof-book-set-option b value p)) - (lambda (b p) - (let ((v (qof-book-get-option b p))) - (if (and v (string? v)) - (set! value v)))) - (lambda (x) (list #t x)) - #f #f #f #f))) - -;; budget option -;; TODO: need to double-check this proc (dates back to r11545 or eariler) -;; -;; Always takes/returns a budget -;; Stores the GUID in the KVP -;; -(define (gnc:make-budget-option - section - name - sort-tag - documentation-string) - - (let* ((initial-budget (gnc-budget-get-default (gnc-get-current-book))) - (selection-budget initial-budget) - ) - - (gnc:make-option - section - name - sort-tag - 'budget - documentation-string - - ;; getter -- Return a budget pointer - (lambda () - selection-budget) - - ;; setter -- takes a budget - (lambda (x) - (set! selection-budget x)) - - ;; default-getter - ;; Default now is #f so saving is independent of book-level default - (lambda () - #f) - - ;; generate-restore-form - ;; "return 'ascii represention of a function' - ;; that will set the option passed as its lone parameter - ;; to the value it was when the picker was first displayed" - ;; - ;; *This* is used to restore reports, not the KVP -- and is stored as text - ;; This does not run in closure with direct access to the option's - ;; internal variables, so the setter generally gets used - (lambda () - (string-append - "(lambda (option) " - "(if option ((gnc:option-setter option) " - "(gnc-budget-lookup " - (gnc:value->string (gncBudgetGetGUID selection-budget)) - " (gnc-get-current-book)))))")) - - ;; scm->kvp -- commit the change - ;; b -- book; p -- key-path - (lambda (b p) - (qof-book-set-option - b (gncBudgetGetGUID selection-budget) p)) - - ;; kvp->scm -- get the stored value - (lambda (b p) - (let ((v (qof-book-get-option b p))) - (if (and v (string? v)) - (begin - (set! selection-budget (gnc-budget-lookup v (gnc-get-current-book))))))) - - ;; value-validator -- returns (#t value) or (#f "failure message") - ;; As no user-generated input, this legacy hard-wire is probably ok - (lambda (x) - (list #t x)) - - ;; option-data - #f - - ;; option-data-fns -- used for multi-pick (this isn't one), or #f - ;; Vector of five functions - ;; 1) () => number of choices - ;; 2) (n) => key for the nth choice - ;; 3) (n) => string for the nth choice - ;; 4) (n) => description for the nth choice - ;; 5) (key) => n (assuming this is the reverse key lookup) - #f - - ;; strings-getter -- list of all translatable strings in the option - #f - - ;; options-widget-changed-proc -- callback for what it sounds like - #f - - ))) ;; completes gnc:make-budget-option - - -;; commodity options use a specialized widget for entering commodities -;; in the GUI implementation. -(define (gnc:make-commodity-option - section - name - sort-tag - documentation-string - default-value) - - (define (commodity->scm commodity) - (if (string? commodity) - (list 'commodity-scm - GNC_COMMODITY_NS_CURRENCY - commodity) - (list 'commodity-scm - (gnc-commodity-get-namespace commodity) - (gnc-commodity-get-mnemonic commodity)))) - - (define (scm->commodity scm) - (gnc-commodity-table-lookup - (gnc-commodity-table-get-table (gnc-get-current-book)) - (cadr scm) (caddr scm))) - - (let* ((value (commodity->scm default-value)) - (value->string (lambda () - (string-append "'" (gnc:value->string value))))) - (gnc:make-option - section name sort-tag 'commodity documentation-string - (lambda () (scm->commodity value)) - (lambda (x) (if (and (pair? x) (eqv? (car x) 'commodity-scm)) - (set! value x) - (set! value (commodity->scm x)))) - (lambda () default-value) - (gnc:restore-form-generator value->string) - (lambda (b p) - (qof-book-set-option b (cadr value) (append p '("ns"))) - (qof-book-set-option b (caddr value) (append p '("monic")))) - (lambda (b p) - (let ((ns (qof-book-get-option b (append p '("ns")))) - (monic (qof-book-get-option b (append p '("monic"))))) - (if (and ns monic (string? ns) (string? monic)) - (set! value (list 'commodity-scm ns monic))))) - (lambda (x) (list #t x)) - #f #f #f #f))) - - -(define (gnc:make-simple-boolean-option - section - name - sort-tag - documentation-string - default-value) - (gnc:make-complex-boolean-option section - name - sort-tag - documentation-string - default-value - #f - #f)) - -;; Complex boolean options are the same as simple boolean options (see -;; above), with the addition of two function arguments. (If both of -;; them are #f, you have exactly a simple-boolean-option.) Both -;; functions should expect one boolean argument. When the option's -;; value is changed, the function option-widget-changed-cb will be -;; called with the new option value at the time that the GUI widget -;; representing the option is changed, and the function -;; setter-function-called-cb will be called when the option's setter -;; is called (that is, when the user selects "OK" or "Apply"). - -;; The option-widget-changed-cb is tested for procedurehood before -;; it is called, so it is not validated to be a procedure here. -;; However, since there could be an option-widget-changed-cb but not -;; a setter-function-called-cb, the procedurehood of the -;; setter-function-called-cb is checked here. -(define (gnc:make-complex-boolean-option - section - name - sort-tag - documentation-string - default-value - setter-function-called-cb - option-widget-changed-cb) - (let* ((value default-value) - (value->string (lambda () (gnc:value->string value)))) - (gnc:make-option - section name sort-tag 'boolean documentation-string - (lambda () value) - (lambda (x) (set! value x) - (if (procedure? setter-function-called-cb) - (setter-function-called-cb x))) - (lambda () default-value) - (gnc:restore-form-generator value->string) - (lambda (b p) (qof-book-set-option b - ;; As no boolean KvpValue exists, as a workaround - ;; we store the string "t" for TRUE and "f" for - ;; FALSE in a string KvpValue. - (if value "t" "f") - p)) - (lambda (b p) - (let ((v (qof-book-get-option b p))) - ;; As no boolean KvpValue exists, as a workaround we store - ;; the string "t" for TRUE and "f" for FALSE. - (cond ((equal? v "t") (set! v #t)) - ((equal? v "f") (set! v #f))) - (if (and v (boolean? v) (not (equal? v default-value))) - (set! value v)))) - (lambda (x) - (if (boolean? x) - (list #t x) - (list #f "boolean-option: not a boolean"))) - #f #f #f (and option-widget-changed-cb - (lambda (x) (option-widget-changed-cb x)))))) - - -(define (gnc:make-pixmap-option - section name sort-tag doc-string - default-value) - (let* ((value default-value)) - (gnc:make-option - section name sort-tag 'pixmap doc-string - (lambda () value) - (lambda (x) (set! value x)) - (lambda () default-value) - (gnc:restore-form-generator (lambda () (gnc:value->string value))) - #f - #f - (lambda (x) - (if (string? x) - (begin - (list #t x)) - (begin - (list #f "pixmap-option: not a string")))) - #f #f #f #f))) - -;; show-time is boolean -;; subtype should be one of 'relative 'absolute or 'both -;; if subtype is 'absolute then relative-date-list should be #f -;; relative-date-list should be the list of relative dates permitted -;; gnc:all-relative-dates contains a list of all relative dates. - -(define (gnc:make-date-option - section - name - sort-tag - documentation-string - default-getter - show-time - subtype - relative-date-list) - (define (date-legal date) - (and (pair? date) - (or - (and (eq? 'relative (car date)) (symbol? (cdr date))) - (and (eq? 'absolute (car date)) - (or (and (pair? (cdr date)) ; we can still accept - (exact? (cadr date)) ; old-style timepairs - (exact? (cddr date))) - (and (number? (cdr date)) - (exact? (cdr date)))))))) - (define (maybe-convert-to-time64 date) - ;; compatibility shim. this is triggered only when date is type - ;; (cons 'absolute (cons sec nsec)) - we'll convert to - ;; (cons 'absolute sec). this shim must always be kept for gnucash - ;; to reload saved reports, or reload reports launched at startup, - ;; which had been saved as timepairs. - (if (pair? (cdr date)) - (cons (car date) (cadr date)) - date)) - (define (list-lookup full-list item) - (or (list-index (lambda (i) (eq? i item)) full-list) - (begin - (rpterror-earlier "date" item (car full-list)) - 0))) - (let* ((value (default-getter)) - (value->string (lambda () - (string-append "'" (gnc:value->string value))))) - (gnc:make-option - section name sort-tag 'date documentation-string - (lambda () value) - (lambda (date) - (if (date-legal date) - (set! value (maybe-convert-to-time64 date)) - (gnc:error "Illegal date value set:" date))) - default-getter - (gnc:restore-form-generator value->string) - (lambda (b p) - (qof-book-set-option b (symbol->string (car value)) - (append p '("type"))) - (qof-book-set-option b - (if (symbol? (cdr value)) - (symbol->string (cdr value)) - (cdr value)) - (append p '("value")))) - (lambda (b p) - (let ((t (qof-book-get-option b (append p '("type")))) - (v (qof-book-get-option b (append p '("value"))))) - (if (and t v (string? t)) - (set! value (cons (string->symbol t) - (if (string? v) (string->symbol v) v)))))) - (lambda (date) - (if (date-legal date) - (list #t date) - (list #f "date-option: illegal date"))) - (vector subtype show-time relative-date-list) - (vector (lambda () (length relative-date-list)) - (lambda (x) (list-ref relative-date-list x)) - (lambda (x) (gnc:get-relative-date-string - (list-ref relative-date-list x))) - (lambda (x) (gnc:get-relative-date-desc - (list-ref relative-date-list x))) - (lambda (x) (list-lookup relative-date-list x))) - #f - #f))) - -(define (gnc:get-rd-option-data-subtype option-data) - (vector-ref option-data 0)) - -(define (gnc:get-rd-option-data-show-time option-data) - (vector-ref option-data 1)) - -(define (gnc:get-rd-option-data-rd-list option-data) - (vector-ref option-data 2)) - -(define (gnc:date-option-get-subtype option) - (if (eq? (gnc:option-type option) 'date) - (gnc:get-rd-option-data-subtype (gnc:option-data option)) - (gnc:error "Not a date option"))) - -(define (gnc:date-option-show-time? option) - (if (eq? (gnc:option-type option) 'date) - (gnc:get-rd-option-data-show-time (gnc:option-data option)) - (gnc:error "Not a date option"))) - -(define (gnc:date-option-value-type option-value) - (car option-value)) - -(define (gnc:date-option-absolute-time option-value) - (if (eq? (car option-value) 'absolute) - (cdr option-value) - (gnc:get-absolute-from-relative-date (cdr option-value)))) - -(define (gnc:date-option-relative-time option-value) - (if (eq? (car option-value) 'absolute) - #f - (cdr option-value))) - -;; Just like gnc:make-account-list-limited-option except it -;; does not limit the types of accounts that are available -;; to the user. -(define (gnc:make-account-list-option - section - name - sort-tag - documentation-string - default-getter - value-validator - multiple-selection) - - (gnc:make-account-list-limited-option - section name sort-tag documentation-string - default-getter value-validator multiple-selection '())) - -;; account-list options use the option-data as a pair; the car is -;; a boolean value, the cdr is a list of account-types. If the boolean is -;; true, the gui should allow the user to select multiple accounts. -;; If the cdr is an empty list, then all account types are shown. -;; Internally, values are always a list of guids. Externally, both -;; guids and account pointers may be used to set the value of the -;; option. The option always returns a list of account pointers. -(define (gnc:make-account-list-limited-option - section - name - sort-tag - documentation-string - default-getter - value-validator - multiple-selection - acct-type-list) - - (define (convert-to-guid item) - (if (string? item) - item - (gncAccountGetGUID item))) - - (define (convert-to-account item) - (if (string? item) - (xaccAccountLookup item (gnc-get-current-book)) - item)) - - (let* ((option (map convert-to-guid (default-getter))) - (option-set #f) - (getter (lambda () (map convert-to-account - (if option-set - option - (default-getter))))) - (value->string (lambda () - (string-append - "'" (gnc:value->string (if option-set option #f))))) - (validator - (if (not value-validator) - (lambda (account-list) (list #t account-list)) - (lambda (account-list) - (value-validator (map convert-to-account account-list)))))) - (gnc:make-option - section name sort-tag 'account-list documentation-string getter - (lambda (account-list) - (if (or (not account-list) (null? account-list)) - (set! account-list (default-getter))) - (set! account-list - (filter (lambda (x) (if (string? x) - (xaccAccountLookup - x (gnc-get-current-book)) - x)) account-list)) - (let* ((result (validator account-list)) - (valid (car result)) - (value (cadr result))) - (if valid - (begin - (set! option (map convert-to-guid value)) - (set! option-set #t)) - (gnc:error "Illegal account list value set")))) - (lambda () (map convert-to-account (default-getter))) - (gnc:restore-form-generator value->string) - (lambda (b p) - (when option-set - (qof-book-set-option b (length option) (append p '("len"))) - (let loop ((option option) (idx 0)) - (unless (null? option) - (qof-book-set-option - b (car option) (append p (list (format #f "acc~a" idx)))) - (loop (cdr option) (1+ idx)))))) - (lambda (b p) - (let ((len (qof-book-get-option b (append p '("len"))))) - (when (and len (integer? len)) - (set! option - (map - (lambda (idx) - (qof-book-get-option b (append p (list (format #f "acc~a" idx))))) - (iota len))) - (set! option-set #t)))) - validator - (cons multiple-selection acct-type-list) #f #f #f))) - -;; Just like gnc:make-account-sel-limited-option except it -;; does not limit the types of accounts that are available -;; to the user. -(define (gnc:make-account-sel-option - section - name - sort-tag - documentation-string - default-getter - value-validator) - - (gnc:make-account-sel-limited-option - section name sort-tag documentation-string - default-getter value-validator '())) - -;; account-sel options use the option-data as a pair; the car is -;; ignored, the cdr is a list of account-types. If the cdr is an empty -;; list, then all account types are shown. Internally, the value is -;; always a guid. Externally, both guids and account pointers may be -;; used to set the value of the option. The option always returns the -;; "current" account pointer. -(define (gnc:make-account-sel-limited-option - section - name - sort-tag - documentation-string - default-getter - value-validator - acct-type-list) - - (define (convert-to-guid item) - (if (string? item) - item - (gncAccountGetGUID item))) - - (define (convert-to-account item) - (if (string? item) - (xaccAccountLookup item (gnc-get-current-book)) - item)) - - (define (find-first-account) - (define (find-first account-list) - (if (null? account-list) - '() - (let* ((this-account (car account-list)) - (account-type (xaccAccountGetType this-account))) - (if (if (null? acct-type-list) - #t - (member account-type acct-type-list)) - this-account - (find-first (cdr account-list)))))) - - (let* ((current-root (gnc-get-current-root-account)) - (account-list (gnc-account-get-descendants-sorted current-root))) - (find-first account-list))) - - (define (get-default) - (if default-getter - (default-getter) - (find-first-account))) - - (let* ((option (convert-to-guid (get-default))) - (option-set #f) - (getter (lambda () (convert-to-account - (if option-set - option - (get-default))))) - (value->string (lambda () - (string-append - (gnc:value->string (if option-set option #f))))) - (validator - (if (not value-validator) - (lambda (account) (list #t account)) - (lambda (account) - (value-validator (convert-to-account account)))))) - (gnc:make-option - section name sort-tag 'account-sel documentation-string getter - (lambda (account) - (if (or (not account) (null? account)) (set! account (get-default))) - (set! account (convert-to-account account)) - (let* ((result (validator account)) - (valid (car result)) - (value (cadr result))) - (if valid - (begin - (set! option (convert-to-guid value)) - (set! option-set #t)) - (gnc:error "Illegal account value set")))) - (lambda () (convert-to-account (get-default))) - (gnc:restore-form-generator value->string) - (lambda (b p) (qof-book-set-option b option p)) - (lambda (b p) - (let ((v (qof-book-get-option b p))) - (if (and v (string? v)) - (set! option v)))) - validator - (cons #f acct-type-list) #f #f #f))) - -(define (gnc:multichoice-list-lookup full-lst item) - (or (list-index (lambda (i) (eq? (vector-ref i 0) item)) full-lst) - (begin - (rpterror-earlier "multichoice" item (car full-lst)) - 0))) - -(define (check-ok-values ok-values fn) - (for-each - (lambda (ok-value) - (when (> (vector-length ok-value) 2) - (issue-deprecation-warning - (format #f "~a: the tooltip in ~a is not supported anymore. Please remove." fn ok-value)))) - ok-values)) - -;; multichoice options use the option-data as a list of vectors. -;; Each vector contains a permissible value (scheme symbol), a -;; name, and a description string. -(define (gnc:make-multichoice-option - section - name - sort-tag - documentation-string - default-value - ok-values) - (gnc:make-multichoice-callback-option section - name - sort-tag - documentation-string - default-value - ok-values - #f - #f)) - -;; The multichoice-option with callback function is the same as the -;; usual multichoice options (see above), with the addition of two -;; function arguments. (If both of them are #f, you have exactly a -;; multichoice-option.) Both functions should expect one argument. -;; When the option's value is changed, the function -;; option-widget-changed-cb will be called with the new option value -;; at the time that the GUI widget representing the option is changed, -;; and the function setter-function-called-cb will be called when the -;; option's setter is called (that is, when the user selects "OK" or -;; "Apply"). -(define (gnc:make-multichoice-callback-option - section - name - sort-tag - documentation-string - default-value - ok-values - setter-function-called-cb - option-widget-changed-cb) - (define (multichoice-legal val p-vals) - (cond ((null? p-vals) #f) - ((eq? val (vector-ref (car p-vals) 0)) #t) - (else (multichoice-legal val (cdr p-vals))))) - - (define (multichoice-strings p-vals) - (if (null? p-vals) - '() - (cons (vector-ref (car p-vals) 1) - (multichoice-strings (cdr p-vals))))) - - (check-ok-values ok-values "gnc:make-multichoice-[callback-]option") - - (let* ((value default-value) - (value->string (lambda () - (string-append "'" (gnc:value->string value))))) - (gnc:make-option - section name sort-tag 'multichoice documentation-string - (lambda () value) - (lambda (x) - (cond - ((and (equal? section "Display") - (equal? name "Parent account subtotals") - (equal? x 'canonically-tabbed)) - (gnc:warn "canonically-tabbed obsolete. switching to 't") - (set! value 't)) - ((not (multichoice-legal x ok-values)) - (rpterror-earlier "multichoice" x default-value)) - (else - (set! value x) - (if (procedure? setter-function-called-cb) - (setter-function-called-cb x))))) - (lambda () default-value) - (gnc:restore-form-generator value->string) - (lambda (b p) (qof-book-set-option b (symbol->string value) p)) - (lambda (b p) - (let ((v (qof-book-get-option b p))) - (if (and v (string? v)) - (set! value (string->symbol v))))) - (lambda (x) - (if (multichoice-legal x ok-values) - (list #t x) - (list #f "multichoice-option: illegal choice"))) - ok-values - (vector (lambda () (length ok-values)) - (lambda (x) (vector-ref (list-ref ok-values x) 0)) - (lambda (x) (vector-ref (list-ref ok-values x) 1)) - #f ;old tooltip - (lambda (x) - (gnc:multichoice-list-lookup ok-values x))) - (lambda () (multichoice-strings ok-values)) - (and option-widget-changed-cb - (lambda (x) (option-widget-changed-cb x)))))) - - -;; radiobutton options use the option-data as a list of vectors. -;; Each vector contains a permissible value (scheme symbol), a -;; name, and a description string. -(define (gnc:make-radiobutton-option - section - name - sort-tag - documentation-string - default-value - ok-values) - (gnc:make-radiobutton-callback-option section - name - sort-tag - documentation-string - default-value - ok-values - #f - #f)) - -;; The radiobutton-option with callback function is the same as the -;; usual radiobutton options (see above), with the addition of two -;; function arguments. (If both of them are #f, you have exactly a -;; radiobutton-option.) Both functions should expect one argument. -;; When the option's value is changed, the function -;; option-widget-changed-cb will be called with the new option value -;; at the time that the GUI widget representing the option is changed, -;; and the function setter-function-called-cb will be called when the -;; option's setter is called (that is, when the user selects "OK" or -;; "Apply"). -(define (gnc:make-radiobutton-callback-option - section - name - sort-tag - documentation-string - default-value - ok-values - setter-function-called-cb - option-widget-changed-cb) - (define (radiobutton-legal val p-vals) - (cond ((null? p-vals) #f) - ((eq? val (vector-ref (car p-vals) 0)) #t) - (else (radiobutton-legal val (cdr p-vals))))) - - (define (radiobutton-strings p-vals) - (if (null? p-vals) - '() - (cons (vector-ref (car p-vals) 1) - (radiobutton-strings (cdr p-vals))))) - - (let* ((value default-value) - (value->string (lambda () - (string-append "'" (gnc:value->string value))))) - (gnc:make-option - section name sort-tag 'radiobutton documentation-string - (lambda () value) - (lambda (x) - (if (radiobutton-legal x ok-values) - (begin - (set! value x) - (if (procedure? setter-function-called-cb) - (setter-function-called-cb x))) - (rpterror-earlier "radiobutton" x default-value))) - (lambda () default-value) - (gnc:restore-form-generator value->string) - (lambda (b p) (qof-book-set-option b (symbol->string value) p)) - (lambda (b p) - (let ((v (qof-book-get-option b p))) - (if (and v (string? v)) - (set! value (string->symbol v))))) - (lambda (x) - (if (radiobutton-legal x ok-values) - (list #t x) - (list #f "radiobutton-option: illegal choice"))) - ok-values - (vector (lambda () (length ok-values)) - (lambda (x) (vector-ref (list-ref ok-values x) 0)) - (lambda (x) (vector-ref (list-ref ok-values x) 1)) - #f ;old tooltip - (lambda (x) - (gnc:multichoice-list-lookup ok-values x))) - (lambda () (radiobutton-strings ok-values)) - (and option-widget-changed-cb - (lambda (x) (option-widget-changed-cb x)))))) - - -;; list options use the option-data in the same way as multichoice -;; options. List options allow the user to select more than one option. -(define (gnc:make-list-option - section - name - sort-tag - documentation-string - default-value - ok-values) - - (define (legal-value? value legal-values) - (cond ((null? legal-values) #f) - ((eq? value (vector-ref (car legal-values) 0)) #t) - (else (legal-value? value (cdr legal-values))))) - - (define (list-legal values) - (cond ((null? values) #t) - (else - (and - (legal-value? (car values) ok-values) - (list-legal (cdr values)))))) - - (define (list-strings p-vals) - (if (null? p-vals) - '() - (cons (vector-ref (car p-vals) 1) - (list-strings (cdr p-vals))))) - - (check-ok-values ok-values "gnc:make-list-option") - - (let* ((value default-value) - (value->string (lambda () - (string-append "'" (gnc:value->string value))))) - (gnc:make-option - section name sort-tag 'list documentation-string - (lambda () value) - (lambda (x) - (if (list-legal x) - (set! value x) - (rpterror-earlier "list" x default-value))) - (lambda () default-value) - (gnc:restore-form-generator value->string) - (lambda (b p) - (qof-book-set-option b (length value) (append p '("len"))) - (let loop ((value value) (idx 0)) - (unless (null? value) - (qof-book-set-option - b (caar value) (append p (list (format #f "item~a" idx)))) - (loop (cdr value) (1+ idx))))) - (lambda (b p) - (let ((len (qof-book-get-option b (append p '("len"))))) - (if (and len (integer? len)) - (set! value - (map - (lambda (idx) - (qof-book-get-option b (append p (list (format #f "item~a" idx))))) - (iota len)))))) - (lambda (x) - (if (list-legal x) - (list #t x) - (list #f "list-option: illegal value"))) - ok-values - (vector (lambda () (length ok-values)) - (lambda (x) (vector-ref (list-ref ok-values x) 0)) - (lambda (x) (vector-ref (list-ref ok-values x) 1)) - #f ;old tooltip - (lambda (x) (gnc:multichoice-list-lookup ok-values x))) - (lambda () (list-strings ok-values)) #f))) - -;; number range options use the option-data as a list whose -;; elements are: (lower-bound upper-bound num-decimals step-size) -(define (gnc:make-number-range-option - section - name - sort-tag - documentation-string - default-value - lower-bound - upper-bound - num-decimals - step-size) - (let* ((value default-value) - (value->string (lambda () (number->string value)))) - (gnc:make-option - section name sort-tag 'number-range documentation-string - (lambda () value) - (lambda (x) (set! value x)) - (lambda () default-value) - (gnc:restore-form-generator value->string) - (lambda (b p) (qof-book-set-option b value p)) - (lambda (b p) - (let ((v (qof-book-get-option b p))) - (if (and v (number? v)) - (set! value v)))) - (lambda (x) - (cond ((not (number? x)) (list #f "number-range-option: not a number")) - ((and (>= value lower-bound) - (<= value upper-bound)) - (list #t x)) - (else (list #f "number-range-option: out of range")))) - (list lower-bound upper-bound num-decimals step-size) - #f #f #f))) - -;; number plot size options use the option-data as a list whose -;; elements are: (lower-bound upper-bound num-decimals step-size) -;; which is used for the valid pixel range -(define (gnc:make-number-plot-size-option - section - name - sort-tag - documentation-string - default-value - lower-bound - upper-bound - num-decimals - step-size) - (let* ((value default-value) - (value->string (lambda () - (string-append "'" (gnc:value->string value))))) - (gnc:make-option - section name sort-tag 'plot-size documentation-string - (lambda () value) ;;getter - (lambda (x) - (if (number? x) ;; this is for old style plot size - (set! value (cons 'pixels x)) - (set! value x))) ;;setter - - (lambda () default-value) ;;default-getter - (gnc:restore-form-generator value->string) ;;restore-form - (lambda (b p) - (qof-book-set-option b (symbol->string (car value)) - (append p '("type"))) - (qof-book-set-option b (if (symbol? (cdr value)) - (symbol->string (cdr value)) - (cdr value)) - (append p '("value")))) ;;scm->kvp - (lambda (b p) - (let ((t (qof-book-get-option b (append p '("type")))) - (v (qof-book-get-option b (append p '("value"))))) - (if (and t v (string? t)) - (set! value (cons (string->symbol t) - (if (string? v) (string->number v) v)))))) ;;kvp->scm - (lambda (x) - (if (eq? 'pixels (car x)) - (cond ((not (number? (cdr x))) (list #f "number-plot-size-option-pixels: not a number")) - ((and (>= (cdr x) lower-bound) - (<= (cdr x) upper-bound)) - (list #t x)) - (else (list #f "number-plot-size-option-pixels: out of range"))) - (cond ((not (number? (cdr x))) (list #f "number-plot-size-option-percentage: not a number")) - ((and (>= (cdr x) 10) - (<= (cdr x) 100)) - (list #t x)) - (else (list #f "number-plot-size-option-percentage: out of range"))) - ) - ) ;;value-validator - (list lower-bound upper-bound num-decimals step-size) ;;option-data - #f #f #f))) ;;option-data-fns, strings-getter, option-widget-changed-proc - -(define (gnc:plot-size-option-value-type option-value) - (car option-value)) - -(define (gnc:plot-size-option-value option-value) - (cdr option-value)) - -(define (gnc:make-internal-option - section - name - default-value) - (let* ((value default-value) - (value->string (lambda () - (string-append "'" (gnc:value->string value))))) - (gnc:make-option - section name "" 'internal #f - (lambda () value) - (lambda (x) (set! value x)) - (lambda () default-value) - (gnc:restore-form-generator value->string) - #f - #f - (lambda (x) (list #t x)) - #f #f #f #f))) - - -(define (gnc:make-query-option - section - name - default-value) - (let* ((value (if (list? default-value) - default-value - (gnc-query2scm default-value))) - (value->string (lambda () - (string-append "'" (gnc:value->string value))))) - (gnc:make-option - section name "" 'query #f - (lambda () value) - (lambda (x) (set! value (if (list? x) x (gnc-query2scm x)))) - (lambda () (if (list? default-value) - default-value - (gnc-query2scm default-value))) - (gnc:restore-form-generator value->string) - #f - #f - (lambda (x) (list #t x)) - #f #f #f #f))) - - -;; Color options store rgba values in a list. -;; The option-data is a list, whose first element -;; is the range of possible rgba values and whose -;; second element is a boolean indicating whether -;; to use alpha transparency. -(define (gnc:make-color-option - section - name - sort-tag - documentation-string - default-value - range - use-alpha) - - (define (canonicalize values) - (map exact->inexact values)) - - (define (values-in-range values) - (if (null? values) - #t - (let ((value (car values))) - (and (number? value) - (>= value 0) - (<= value range) - (values-in-range (cdr values)))))) - - (define (validate-color color) - (cond ((not (list? color)) (list #f "color-option: not a list")) - ((not (= 4 (length color))) (list #f "color-option: wrong length")) - ((not (values-in-range color)) - (list #f "color-option: bad color values")) - (else (list #t color)))) - - (let* ((value (canonicalize default-value)) - (value->string (lambda () - (string-append "'" (gnc:value->string value))))) - (gnc:make-option - section name sort-tag 'color documentation-string - (lambda () value) - (lambda (x) (set! value (canonicalize x))) - (lambda () (canonicalize default-value)) - (gnc:restore-form-generator value->string) - #f - #f - validate-color - (list range use-alpha) - #f #f #f))) - -(define (gnc:color->hex-string color range) - (define (html-value value) - (inexact->exact - (min 255.0 - (truncate (* (/ 255.0 range) value))))) - (define (number->hex-string number) - (let ((ret (number->string number 16))) - (cond ((< (string-length ret) 2) (string-append "0" ret)) - (else ret)))) - (let ((red (car color)) - (green (cadr color)) - (blue (caddr color))) - (string-append - (number->hex-string (html-value red)) - (number->hex-string (html-value green)) - (number->hex-string (html-value blue))))) - -(define (gnc:color->html color range) - (string-append "#" - (gnc:color->hex-string color range))) - -(define (gnc:color-option->html color-option) - (let ((color (gnc:option-value color-option)) - (range (car (gnc:option-data color-option)))) - (gnc:color->html color range))) - -(define (gnc:color-option->hex-string color-option) - (let ((color (gnc:option-value color-option)) - (range (car (gnc:option-data color-option)))) - (gnc:color->hex-string color range))) - -;; -;; dateformat option -;; -(define (gnc:make-dateformat-option - section - name - sort-tag - documentation-string - default-value) - - (define (def-value) - (if (list? default-value) - default-value - (list 'unset 'number #t ""))) - - (let* ((value (def-value)) - (value->string (lambda () - (string-append "'" (gnc:value->string value))))) - (gnc:make-option - section name sort-tag 'dateformat documentation-string - (lambda () value) - (lambda (x) (set! value x)) - (lambda () (def-value)) - (gnc:restore-form-generator value->string) - (lambda (b p) - (if (eq? (car value) 'unset) - (qof-book-options-delete b p );; delete the kvp when unset - (begin - (qof-book-set-option - b (symbol->string (car value)) (append p '("fmt"))) - (qof-book-set-option - b (symbol->string (cadr value)) (append p '("month"))) - (qof-book-set-option - b (if (caddr value) 1 0) (append p '("years"))) - (qof-book-set-option - b (cadddr value) (append p '("custom")))))) - (lambda (f p) - (let ((fmt (qof-book-get-option f (append p '("fmt")))) - (month (qof-book-get-option f (append p '("month")))) - (years (qof-book-get-option f (append p '("years")))) - (custom (qof-book-get-option f (append p '("custom"))))) - (if (and - fmt (string? fmt) - month (string? month) - years (number? years) - custom (string? custom)) - (set! value (list (string->symbol fmt) (string->symbol month) - (if (= years 0) #f #t) custom))))) - (lambda (x) - (cond ((not (list? x)) (list #f "dateformat-option: not a list")) - ((not (= (length x) 4)) - (list #f "dateformat-option: wrong list length" (length x))) - ((not (symbol? (car x))) - (list #f "dateformat-option: no format symbol")) - ((not (symbol? (cadr x))) - (list #f "dateformat-option: no months symbol")) - ((not (string? (cadddr x))) - (list #f "dateformat-option: no custom string")) - (else (list #t x)))) - #f #f #f #f))) - -(define (gnc:dateformat-get-format v) - (cadddr v)) - -;; Create a new options database -(define (gnc:new-options) - (define option-hash (make-hash-table 23)) - - (define options-changed #f) - (define changed-hash (make-hash-table 23)) - - (define callback-hash (make-hash-table 23)) - (define last-callback-id 0) - (define new-names-alist - '(("Accounts to include" #f "Accounts") - ("Exclude transactions between selected accounts?" #f - "Exclude transactions between selected accounts") - ("Filter Accounts" #f "Filter By...") - ("Flatten list to depth limit?" #f "Flatten list to depth limit") - ("From" #f "Start Date") - ("Report Accounts" #f "Accounts") - ("Report Currency" #f "Report's currency") - ("Show Account Code?" #f "Show Account Code") - ("Show Full Account Name?" #f "Show Full Account Name") - ("Show Multi-currency Totals?" #f "Show Multi-currency Totals") - ("Show zero balance items?" #f "Show zero balance items") - ("Sign Reverses?" #f "Sign Reverses") - ("To" #f "End Date") - ("Charge Type" #f "Action") ;easy-invoice.scm, renamed June 2018 - ;; the following 4 options in income-gst-statement.scm renamed Dec 2018 - ("Individual income columns" #f "Individual sales columns") - ("Individual expense columns" #f "Individual purchases columns") - ("Remittance amount" #f "Gross Balance") - ("Net Income" #f "Net Balance") - ;; transaction.scm: - ("Use Full Account Name?" #f "Use Full Account Name") - ("Use Full Other Account Name?" #f "Use Full Other Account Name") - ("Void Transactions?" "Filter" "Void Transactions") - ("Void Transactions" "Filter" "Void Transactions") - ("Account Substring" "Filter" "Account Name Filter") - ("Enable links" #f "Enable Links") - ;; trep-engine: moved currency options to own tab - ("Common Currency" "Currency" "Common Currency") - ("Show original currency amount" "Currency" "Show original currency amount") - ("Report's currency" "Currency" "Report's currency") - ("Reconcile Status" #f "Reconciled Status") - ;; new-owner-report.scm, renamed Oct 2020 to differentiate with - ;; Document Links: - ("Links" #f "Transaction Links") - ;; invoice.scm, renamed November 2018 - ("Individual Taxes" #f "Use Detailed Tax Summary") - ;; income-gst-statement.scm - ("default format" #f "Default Format") - ("Report format" #f "Report Format") - )) - - (define (lookup-option section name) - (let ((section-hash (hash-ref option-hash section))) - (and section-hash - (or (hash-ref section-hash name) - ;; Option name was not found. Perhaps it was renamed? - ;; Let's try to map to a known new name. The alist - ;; new-names-alist will try match names - car is the old - ;; name, cdr is the 2-element list describing - ;; newsection newname. If newsection is #f then reuse - ;; previous section name. Please note the rename list - ;; currently supports renaming individual option names, - ;; or individual option names moved to another - ;; section. It does not currently support renaming - ;; whole sections. - (let ((name-match (assoc-ref new-names-alist name))) - (and name-match - (let ((new-section (car name-match)) - (new-name (cadr name-match))) - (gnc:warn - (format #f "option ~a/~a has been renamed to ~a/~a\n" - section name new-section new-name)) - (cond - ;; new-name only - ((not new-section) - (lookup-option section new-name)) - ;; new-section different to current section - ;; name, and possibly new-name - ((not (string=? new-section section)) - (lookup-option new-section new-name)) - ;; no match, return #f - (else #f))))))))) - - (define (option-changed section name) - (set! options-changed #t) - (let ((section-changed-hash (hash-ref changed-hash section))) - (if (not section-changed-hash) - (begin - (set! section-changed-hash (make-hash-table 23)) - (hash-set! changed-hash section section-changed-hash))) - (hash-set! section-changed-hash name #t))) - - (define (clear-changes) - (set! options-changed #f) - (set! changed-hash (make-hash-table 23))) - - (define (register-option new-option) - (let* ((name (gnc:option-name new-option)) - (section (gnc:option-section new-option)) - (section-hash (hash-ref option-hash section))) - (if (not section-hash) - (begin - (set! section-hash (make-hash-table 23)) - (hash-set! option-hash section section-hash))) - (hash-set! section-hash name new-option) - (gnc:option-set-changed-callback - new-option - (lambda () (option-changed section name))))) - - (define (unregister-option section name) - (let* ((section-hash (hash-ref option-hash section))) - (if (and section-hash - (hash-ref section-hash name)) - (begin - (hash-remove! section-hash name) - (if (zero? (hash-count (const #t) section-hash)) - (hash-remove! option-hash section))) - (gnc:error "options:unregister-option: no such option\n")))) - -; Call (thunk option) for each option in the database - (define (options-for-each thunk) - (define (section-for-each section-hash thunk) - (hash-for-each - (lambda (name option) - (thunk option)) - section-hash)) - (hash-for-each - (lambda (section hash) - (section-for-each hash thunk)) - option-hash)) - - (define (options-for-each-general section-thunk option-thunk) - (define (section-for-each section-hash thunk) - (hash-for-each - (lambda (name option) - (thunk option)) - section-hash)) - (hash-for-each - (lambda (section hash) - (if section-thunk - (section-thunk section hash)) - (if option-thunk - (section-for-each hash option-thunk))) - option-hash)) - - (define (generate-restore-forms options-string) - - (define (generate-option-restore-form option restore-code) - (let* ((section (gnc:option-section option)) - (name (gnc:option-name option))) - (string-append - "(let ((option (gnc:lookup-option " options-string "\n" - " " (gnc:value->string section) "\n" - " " (gnc:value->string name) ")))\n" - " (" restore-code " option))\n\n"))) - - (define (generate-forms port) - (options-for-each-general - (lambda (section hash) - (display - (string-append "\n; Section: " section "\n\n") - port)) - (lambda (option) - (let ((value (gnc:option-value option)) - (default-value (gnc:option-default-value option))) - (if (not (equal? value default-value)) - (let* ((generator (gnc:option-generate-restore-form option)) - (restore-code (false-if-exception (generator)))) - (if restore-code - (display - (generate-option-restore-form option restore-code) - port)))))))) - - (call-with-output-string generate-forms)) - - (define (scm->kvp book) - (options-for-each - (lambda (option) - (let ((value (gnc:option-value option)) - (default-value (gnc:option-default-value option)) - (section (gnc:option-section option)) - (name (gnc:option-name option))) - (if (not (equal? value default-value)) - (let ((save-fcn (gnc:option-scm->kvp option))) - (if save-fcn - (save-fcn book (list section name))))))))) - - (define (kvp->scm book) - (options-for-each - (lambda (option) - (let ((section (gnc:option-section option)) - (name (gnc:option-name option)) - (load-fcn (gnc:option-kvp->scm option))) - (if load-fcn - (load-fcn book (list section name))))))) - - (define (register-callback section name callback) - (let ((id last-callback-id) - (data (list section name callback))) - (set! last-callback-id (+ last-callback-id 1)) - (hashv-set! callback-hash id data) - id)) - - (define (unregister-callback-id id) - (if (hashv-ref callback-hash id) - (hashv-remove! callback-hash id) - (gnc:error "options:unregister-callback-id: no such id\n"))) - - (define (run-callbacks) - (define (run-callback id cbdata) - (let ((section (car cbdata)) - (name (cadr cbdata)) - (callback (caddr cbdata))) - (if (not section) - (callback) - (let ((section-changed-hash (hash-ref changed-hash section))) - (if section-changed-hash - (if (not name) - (callback) - (if (hash-ref section-changed-hash name) - (callback)))))))) - - (if options-changed - (let ((cblist '())) - (hash-for-each - (lambda (k v) (set! cblist (cons (cons k v) cblist))) - callback-hash) - (set! cblist (sort cblist - (lambda (a b) - (< (car a) (car b))))) - (for-each - (lambda (elt) (run-callback (car elt) (cdr elt))) - cblist))) - (clear-changes)) - - (define default-section #f) - - (define (touch) - (set! options-changed #t) - (run-callbacks)) - - (define (set-default-section section-name) - (set! default-section section-name)) - - (define (get-default-section) - default-section) - - (define (dispatch key) - (case key - ((lookup) lookup-option) - ((register-option) register-option) - ((unregister-option) unregister-option) - ((register-callback) register-callback) - ((unregister-callback-id) unregister-callback-id) - ((for-each) options-for-each) - ((for-each-general) options-for-each-general) - ((generate-restore-forms) generate-restore-forms) - ((scm->kvp) scm->kvp) - ((kvp->scm) kvp->scm) - ((touch) touch) - ((clear-changes) clear-changes) - ((run-callbacks) run-callbacks) - ((set-default-section) set-default-section) - ((get-default-section) get-default-section) - (else (gnc:warn "options: bad key: " key "\n")))) - - dispatch) - -(define (gnc:register-option options new-option) - ((options 'register-option) new-option)) - -(define (gnc:options-register-callback section name callback options) - ((options 'register-callback) section name callback)) - -(define (gnc:options-register-c-callback section name c-callback data options) - (let ((callback (lambda () (gncp-option-invoke-callback c-callback data)))) - ((options 'register-callback) section name callback))) - -(define (gnc:options-unregister-callback-id id options) - ((options 'unregister-callback-id) id)) - -(define (gnc:options-for-each thunk options) - ((options 'for-each) thunk)) - -(define (gnc:options-for-each-general section-thunk option-thunk options) - ((options 'for-each-general) section-thunk option-thunk)) - -(define (gnc:lookup-option options section name) - (if options - ((options 'lookup) section name) - #f)) - -(define (gnc:unregister-option options section name) - ((options 'unregister-option) section name)) - -(define (gnc:generate-restore-forms options options-string) - ((options 'generate-restore-forms) options-string)) - -(define (gnc:options-scm->kvp options book clear-option?) - (if clear-option? - (qof-book-options-delete book '())) - ((options 'scm->kvp) book)) - -(define (gnc:options-kvp->scm options book) - ((options 'kvp->scm) book)) - -(define (gnc:options-clear-changes options) - ((options 'clear-changes))) - -(define (gnc:options-touch options) - ((options 'touch))) - -(define (gnc:options-run-callbacks options) - ((options 'run-callbacks))) - -(define (gnc:options-set-default-section options section-name) - ((options 'set-default-section) section-name)) - -(define (gnc:options-get-default-section options) - ((options 'get-default-section))) +(define-public (gnc:option-make-internal! options section name) + (let ((option (gnc-lookup-option options section name))) + (and option (GncOption-make-internal option)))) + +(define-public (gnc:option-type option) + (GncOption-get-type option)) + +;; Used only by test-stress-options.scm +(define-public (gnc:option-data option) + (let ((num-values (GncOption-num-permissible-values option)) + (retval '())) + (do ((i 0 (1+ i))) ((>= i num-values)) + (let ((value (GncOption-permissible-value option i)) + (name (GncOption-permissible-value-name option i)) + (desc (GncOption-permissible-value-description option i))) + (set! retval (cons retval (vector value name desc))))) + retval)) + +(define-public (gnc:new-options) + (new-gnc-optiondb)) + +(define-public (gnc:options-set-default-section optiondb section) + (GncOptionDB-set-default-section (GncOptionDBPtr-get optiondb) section)) + +(define-public (gnc:options-for-each func optdb) + (gnc-optiondb-foreach optdb func)) ;; Copies all values from src-options to dest-options, that is, it ;; copies the values of all options from src which exist in dest to ;; there. -(define (gnc:options-copy-values src-options dest-options) +(define-public (gnc:options-copy-values src-options dest-options) (if dest-options (gnc:options-for-each @@ -1862,58 +120,261 @@ the option '~a'.")) (gnc:option-value src-option))))) src-options))) -(define (gnc:send-options db_handle options) - (gnc:options-for-each - (lambda (option) - (gnc-option-db-register-option db_handle option)) - options)) +;; FIXME: Fake callback functions for boolean-complex and multichoice-callback -(define (gnc:options-make-end-date! options pagename optname sort-tag info) - (gnc:register-option - options - (gnc:make-date-option - pagename optname - sort-tag info - (lambda () - (cons 'relative 'end-accounting-period)) - #f 'both - '( - today - end-this-month - end-prev-month - end-current-quarter - end-prev-quarter - end-cal-year - end-prev-year - end-accounting-period - )))) +(define-public (gnc:options-register-callback section name callback options) 1) +(define-public (gnc:options-register-c-callback section name callback data options) 1) +(define-public (gnc:options-unregister-callback-id id) 0 options) -(define (gnc:options-make-date-interval! options pagename name-from info-from - name-to info-to sort-tag) - (gnc:register-option - options - (gnc:make-date-option - pagename name-from - (string-append sort-tag "a") info-from - (lambda () (cons 'relative 'start-accounting-period)) - #f 'both - '( - today - start-this-month - start-prev-month - start-current-quarter - start-prev-quarter - start-cal-year - start-prev-year - start-accounting-period - ))) - (gnc:options-make-end-date! options pagename name-to - (string-append sort-tag "b") info-to)) +;; The following implement the old API that separated creation from registration. +(define-public (gnc:register-option optdb opt) + (issue-deprecation-warning "gnc:register-option is deprecated. Use gnc-register-foo-option instead.") + (GncOptionDB-register-option (GncOptionDBPtr-get optdb) + (GncOption-get-section opt) opt)) -(define (gnc:option-make-internal! options section name) - ;; this function will hide the option specified - ;; the option functionality is unchanged - (let ((opt (gnc:lookup-option options section name))) - (if opt - (vector-set! opt 3 'internal) - (gnc:error "gnc:option-make-internal! cannot find " section " / " name)))) +(define-public (gnc:unregister-option optdb section name) + (GncOptionDB-unregister-option (GncOptionDBPtr-get optdb) section name)) + +(define-public (gnc:make-string-option section name key docstring default) + (issue-deprecation-warning "gnc:make-string-option is deprecated. Make and register the option in one command with gnc-register-string-option.") + (gnc-make-string-option section name key docstring default (GncOptionUIType-STRING))) +(define-public (gnc:make-text-option section name key docstring default) + (issue-deprecation-warning "gnc:make-text-option is deprecated. Make and register the option in one command with gnc-register-text-option.") + (gnc-make-string-option section name key docstring default (GncOptionUIType-TEXT))) +(define-public (gnc:make-font-option section name key docstring default) + (issue-deprecation-warning "gnc:make-font-option is deprecated. Make and register the option in one command with gnc-register-font-option.") + (gnc-make-string-option section name key docstring default (GncOptionUIType-FONT))) +(define-public (gnc:make-color-option section name key docstring colors range use-alpha) + (issue-deprecation-warning "gnc:make-color-option is deprecated. Make and register the option in one command with gnc-register-color-option.") + (let ((color-str (if use-alpha + (format #f "~x~x~x~x" (car colors) (cadr colors) (caddr colors) (cadddr colors)) + (format #f "~x~x~x" (car colors) (cadr colors) (caddr colors))))) + (gnc-make-string-option section name key docstring color-str (GncOptionUIType-COLOR)))) +(define-public (gnc:make-budget-option section name key docstring) + (issue-deprecation-warning "gnc:make-budget-option is deprecated. Make and register the option in one command with gnc-register-color-option.") + (gnc-make-qofinstance-option section name key docstring #f (GncOptionUIType-BUDGET))) +(define-public (gnc:make-commodity-option section name key docstring default) + (issue-deprecation-warning "gnc:make-commodity-option is deprecated. Make and register the option in one command with gnc-register-commodity-option.") + (gnc-make-commodity-option section name key docstring default)) +(define-public (gnc:make-simple-boolean-option section name key docstring default) + (issue-deprecation-warning "gnc:make-simple-boolean-option is deprecated. Make and register the option in one command with gnc-register-simple-boolean-option.") + (gnc-make-bool-option section name key docstring default (GncOptionUIType-BOOLEAN))) +(define-public (gnc:make-complex-boolean-option section name key docstring default setter-cb widget-changed-cb) + (issue-deprecation-warning "gnc:make-complex-boolean-option is deprecated and its functionality removed. Make and register a simple-boolean in one command with gnc-register-simple-boolean-option and figure out some other way to change widget sensitivity.") + (gnc-make-bool-option section name key docstring default (GncOptionUIType-BOOLEAN))) +(define-public (gnc:make-pixmap-option section name key docstring default) + (issue-deprecation-warning "gnc:make-pixmap-option is deprecated. Make and register the option in one command with gnc-register-pixmap-option.") + (gnc-make-string-option section name key docstring default (GncOptionUIType-PIXMAP))) +;; gnc:make-account-list-option's getter and validator parameters are functions. +(define-public (gnc:make-account-list-option section name key docstring default validator multi) + (issue-deprecation-warning "gnc:make-account-list-option is deprecated. Make and register the option in one command with gnc-register-account-list-option.") + (gnc-make-account-list-option section name key docstring (default))) +(define-public (gnc:make-account-list-limited-option section name key docstring default validator multi permitted) + (issue-deprecation-warning "gnc:make-account-list-limited-option is deprecated. Make and register the option in one command with gnc-register-account-list-limited-option.") + (gnc-make-account-list-limited-option section name key docstring (default) permitted)) +(define-public (gnc:make-account-sel-limited-option section name key docstring default validator permitted) + (issue-deprecation-warning "gnc:make-account-sel-limited-option is deprecated. Make and register the option in one command with gnc-register-account-sel-limited-option.") + (gnc-make-account-sel-limited-option section name key docstring (default) permitted)) +(define-public (gnc:make-account-sel-option section name key docstring default validator) + (let ((defval (if default (default) #f))) + (gnc-make-account-sel-limited-option section name key docstring defval '()))) +(define-public (gnc:make-multichoice-option section name key docstring default multichoice) + (issue-deprecation-warning "gnc:make-multichoice-option is deprecated. Make and register the option in one command with gnc-register-multichoice-option.") + (let ((defval (cond ((symbol? default) + (symbol->string default)) + ((number? default) + (number->string default)) + (else default)))) + (gnc-make-multichoice-option section name key docstring defval multichoice))) +(define-public (gnc:make-multichoice-callback-option section name key docstring default multichoice setter-cb widget-changed-cb) + (issue-deprecation-warning "gnc:make-multichoice-callback-option is deprecated in favor of a not-yet-written but more sensible way to conditionally enable and disable option widgets.") + (gnc:make-multichoice-option section name key docstring default multichoice)) + +(define-public (gnc:make-list-option section name key docstring default multichoice) + (issue-deprecation-warning "gnc:make-list-option is deprecated. Make and register the option in one command with gnc-register-list-option.") + (let ((indexes (if default (map (lambda (def-item) + (list-index (lambda (choice) + (eq? def-item + (vector-ref choice 0))) + multichoice)) + default) 0))) + (gnc-make-list-option section name key docstring indexes multichoice))) +(define-public (gnc:make-radiobutton-option section name key docstring default multichoice) + (gnc:warn "gnc:make-radiobutton-option is no longer available. Using gnc:make-multichoice-option instead.") + (gnc:make-multichoice-option section name key docstring default multichoice)) +(define-public (gnc:make-number-range-option section name key docstring default min max dec-places step) + (issue-deprecation-warning "gnc:make-number-range-option is deprecated. Make and register the option in one command with gnc-register-number-range-option.") + (gnc-make-range-value-option section name key docstring default min max step)) +(define-public (gnc:make-number-plot-size-option section name key docstring default min max dec-places step) + (issue-deprecation-warning "gnc:make-number-plot-size-option is deprecated. Make and register the option in one command with gnc-register-plot-size-range-option.") + ;; Ignore what the call asks for, only 10-100% makes sense. + (gnc-make-plot-size-option section name key docstring 100 10 100 1)) +(define-public (gnc:make-query-option section name default) + (issue-deprecation-warning "gnc:make-query-option is deprecated. Make and register the option in one command with gnc-register-query-option.") + (let ((defv (if (list? default) default (gnc-query2scm default)))) + (gnc-make-SCM-option section name "" "query" defv (GncOptionUIType-INTERNAL)))) +(define-public (gnc:make-internal-option section name default) + (issue-deprecation-warning "gnc:make-internal-option is deprecated. Make and register the option in one command with gnc-register-internal-option.") + (let ((type (GncOptionUIType-INTERNAL)) + (key "_") + (desc "internal")) + (gnc-make-SCM-option section name key desc default type))) +(define-public (gnc:make-owner-option section name key docstring getter validator owner-type) + (issue-deprecation-warning "gnc:make-owner-option is deprecated. Make and register the option in one command with gnc-register-owner-option.") + (let ((ui-type (cond + ((eqv? owner-type GNC-OWNER-CUSTOMER) (GncOptionUIType-CUSTOMER)) + ((eqv? owner-type GNC-OWNER-VENDOR) (GncOptionUIType-VENDOR)) + ((eqv? owner-type GNC-OWNER-EMPLOYEE) (GncOptionUIType-EMPLOYEE)) + ((eqv? owner-type GNC-OWNER-JOB) (GncOptionUIType-JOB)) + (else (GncOptionUIType-INTERNAL)))) + (defval (if getter (getter) #f))) + (format #t "Making owner option ~a:~a ~a ~a~%" section name defval ui-type)(force-output) + (gnc-make-qofinstance-option section name key docstring defval ui-type))) +(define-public (gnc:make-invoice-option section name key docstring getter validator) + (issue-deprecation-warning "gnc:make-invoice-option is deprecated. Make and register the option in one command with gnc-register-ionvoice-option.") + (gnc-make-qofinstance-option section name key docstring #f (GncOptionUIType-INVOICE))) +(define-public (gnc:make-taxtable-option section name key docstring default) + (issue-deprecation-warning "gnc:make-taxtable-option is deprecated. Make and register the option in one command with gnc-register-taxtable-option.") + (gnc-make-qofinstance-option section name key docstring default (GncOptionUIType-TAX_TABLE))) +(define-public (gnc:make-counter-option section name key docstring default) + (issue-deprecation-warning "gnc:make-number-range-option is deprecated. Make and register the option in one command with gnc-register-number-range-option.") + (gnc-make-range-value-option section name key docstring default 0.0 999999999.0, 1.0)) + +(define-public (gnc:make-counter-format-option section name key docstring default) + (issue-deprecation-warning "gnc:make-counter-format-option is deprecated. Make and register the option in one command with gnc-register-counter-format-option.") + (gnc-make-string-option section name key docstring default (GncOptionUIType-STRING))) +(define-public (gnc:make-date-format-option section name key docstring default) + (issue-deprecation-warning "gnc:make-date-format-option is deprecated. Make and register the option in one command with gnc-register-date-format-option.") + (gnc-make-string-option section name key docstring default (GncOptionUIType-DATE_FORMAT))) +(define-public (gnc:make-currency-option section name key docstring default) + (issue-deprecation-warning "gnc:make-currency-option is deprecated. Make and register the option in one command with gnc-register-currency-option.") + (gnc-make-currency-option section name key docstring default)) +(define-public (gnc:make-date-option section name key docstring getter showtime + subtype relative-date-list) + (let ((default (getter)) + (both (if (eq? subtype 'both) #t #f))) + (gnc-make-date-option section name key docstring default relative-date-list both))) + +(define-public (gnc:options-make-end-date! optiondb pagename optname sort-tag docstring) + (gnc-register-end-date-option optiondb pagename optname sort-tag docstring)) + +(define-public (gnc:options-make-date-interval! optiondb pagename name-from info-from name-to info-to sort-tag) + (gnc-register-start-date-option optiondb pagename name-from + (string-append sort-tag "a") info-from) + (gnc-register-end-date-option optiondb pagename name-to + (string-append sort-tag "b") info-to)) +(define-public (gnc:date-option-absolute-time option-value) + (if (pair? option-value) + (if (eq? (car option-value) 'absolute) + (cdr option-value) + (gnc-relative-date-to-time64 (cdr option-value))) + option-value)) +;; This is a special case where we can't use the exported registration function +;; because we need to transform the default argument first depending on its +;; Scheme type. +(define-public (gnc:register-multichoice-option options section name key docstring default multichoice) + (issue-deprecation-warning "gnc:make-multichoice-option is deprecated. Make and register the option in one command with gnc-register-multichoice-option.") + (let ((defval (cond ((symbol? default) + (symbol->string default)) + ((number? default) + (number->string default)) + (else default)))) + (gnc-register-multichoice-option options section name key docstring defval multichoice))) + +;; Scheme code for supporting options for the business modules +;; +;; Created by: Derek Atkins +;; +;; 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 2 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, contact: +;; +;; Free Software Foundation Voice: +1-617-542-5942 +;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652 +;; Boston, MA 02110-1301, USA gnu@gnu.org + + +;; Internally, values are always a guid. Externally, both guids and +;; invoice pointers may be used to set the value of the option. The +;; option always returns a single invoice pointer. + +(use-modules (gnucash core-utils)) +(use-modules (gnucash engine)) +(use-modules (gnucash utilities)) +(use-modules (gnucash app-utils options)) +(use-modules (sw_app_utils)) + +(export gnc:*business-label*) +(export gnc:*company-name*) +(export gnc:*company-addy*) +(export gnc:*company-id*) +(export gnc:*company-phone*) +(export gnc:*company-fax*) +(export gnc:*company-url*) +(export gnc:*company-email*) +(export gnc:*company-contact*) +(export gnc:*fancy-date-label*) +(export gnc:*fancy-date-format*) +(export gnc:*tax-label*) +(export gnc:*tax-nr-label*) +(export gnc:company-info) +(export gnc:fancy-date-info) +(export gnc:*option-section-budgeting*) +(export gnc:*option-name-auto-readonly-days*) +(export gnc:*option-name-num-field-source*) +(export gnc:*kvp-option-path*) +(export gnc:options-fancy-date) +(export gnc:*option-name-default-budget*) + +(define gnc:*kvp-option-path* (list KVP-OPTION-PATH)) +(define gnc:*option-name-auto-readonly-days* OPTION-NAME-AUTO-READONLY-DAYS) +(define gnc:*option-name-num-field-source* OPTION-NAME-NUM-FIELD-SOURCE) + +(define gnc:*option-section-budgeting* OPTION-SECTION-BUDGETING) +(define gnc:*option-name-default-budget* OPTION-NAME-DEFAULT-BUDGET) + +(define gnc:*business-label* (N_ "Business")) +(define gnc:*company-name* (N_ "Company Name")) +(define gnc:*company-addy* (N_ "Company Address")) +(define gnc:*company-id* (N_ "Company ID")) +(define gnc:*company-phone* (N_ "Company Phone Number")) +(define gnc:*company-fax* (N_ "Company Fax Number")) +(define gnc:*company-url* (N_ "Company Website URL")) +(define gnc:*company-email* (N_ "Company Email Address")) +(define gnc:*company-contact* (N_ "Company Contact Person")) +(define gnc:*fancy-date-label* (N_ "Fancy Date Format")) +(define gnc:*fancy-date-format* (N_ "custom")) +(define gnc:*tax-label* (N_ "Tax")) +(define gnc:*tax-nr-label* (N_ "Tax Number")) + + +(define (gnc:options-fancy-date book) + (let ((date-format (gnc:fancy-date-info book gnc:*fancy-date-format*))) + (if (boolean? date-format) ;; date-format does not exist + (qof-date-format-get-string (qof-date-format-get)) + date-format))) + +(define (gnc:company-info book key) + ;; Access company info from key-value pairs for current book + (gnc:option-get-value book gnc:*business-label* key)) + +(define (gnc:fancy-date-info book key) + ;; Access fancy date info from key-value pairs for current book + (gnc:option-get-value book gnc:*business-label* (list gnc:*fancy-date-label* key))) + + + +(define (gnc:options-fancy-date book) + (let ((date-format (gnc:fancy-date-info book gnc:*fancy-date-format*))) + (if (boolean? date-format) ;; date-format does not exist + (qof-date-format-get-string (qof-date-format-get)) + date-format)))