From 3e8c9ad807d8ce9b6bef5fefc1b34cd9ab762329 Mon Sep 17 00:00:00 2001 From: Ingo Haschler Date: Thu, 26 Sep 2019 22:03:05 +0200 Subject: [PATCH 01/17] Partly fixes bug 667490. It implements the presentation of static optical TAN challenges (photoTAN and QR) inside the enter TAN dialogue. --- gnucash/import-export/aqb/dialog-ab.glade | 18 +++- gnucash/import-export/aqb/gnc-gwen-gui.c | 102 +++++++++++++++++++++- 2 files changed, 117 insertions(+), 3 deletions(-) diff --git a/gnucash/import-export/aqb/dialog-ab.glade b/gnucash/import-export/aqb/dialog-ab.glade index 829f19ddf4..03632c5dc1 100644 --- a/gnucash/import-export/aqb/dialog-ab.glade +++ b/gnucash/import-export/aqb/dialog-ab.glade @@ -664,6 +664,22 @@ 0 + + + optical_challenge + True + False + True + True + gtk-missing-image + 6 + + + False + True + 2 + + True @@ -751,7 +767,7 @@ False True - 1 + 3 diff --git a/gnucash/import-export/aqb/gnc-gwen-gui.c b/gnucash/import-export/aqb/gnc-gwen-gui.c index d3c9fe0125..9fda5adf8e 100644 --- a/gnucash/import-export/aqb/gnc-gwen-gui.c +++ b/gnucash/import-export/aqb/gnc-gwen-gui.c @@ -170,9 +170,16 @@ static gboolean keep_alive(GncGWENGui *gui); static void cm_close_handler(gpointer user_data); static void erase_password(gchar *password); static gchar *strip_html(gchar *text); +#ifndef AQBANKING6 static void get_input(GncGWENGui *gui, guint32 flags, const gchar *title, const gchar *text, gchar **input, gint min_len, gint max_len); +#else +static void get_input(GncGWENGui *gui, guint32 flags, const gchar *title, + const gchar *text, const char *mimeType, + const char *pChallenge, uint32_t lChallenge, + gchar **input, gint min_len, gint max_len); +#endif static gint messagebox_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *title, const gchar *text, const gchar *b1, const gchar *b2, const gchar *b3, guint32 guiid); @@ -190,7 +197,7 @@ static gint progress_advance_cb(GWEN_GUI *gwen_gui, uint32_t id, static gint progress_log_cb(GWEN_GUI *gwen_gui, guint32 id, GWEN_LOGGER_LEVEL level, const gchar *text); static gint progress_end_cb(GWEN_GUI *gwen_gui, guint32 id); -#ifndef GWENHYWFAR5 +#ifndef AQBANKING6 static gint GNC_GWENHYWFAR_CB getpassword_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *token, const gchar *title, @@ -977,8 +984,15 @@ strip_html(gchar *text) } static void +#ifndef AQBANKING6 get_input(GncGWENGui *gui, guint32 flags, const gchar *title, const gchar *text, gchar **input, gint min_len, gint max_len) +#else +get_input(GncGWENGui *gui, guint32 flags, const gchar *title, + const gchar *text, const char *mimeType, + const char *pChallenge, uint32_t lChallenge, + gchar **input, gint min_len, gint max_len) +#endif { GtkBuilder *builder; GtkWidget *dialog; @@ -987,6 +1001,7 @@ get_input(GncGWENGui *gui, guint32 flags, const gchar *title, const gchar *text, GtkWidget *confirm_entry; GtkWidget *confirm_label; GtkWidget *remember_pin_checkbutton; + GtkImage *optical_challenge; const gchar *internal_input, *internal_confirmed; gboolean confirm = (flags & GWEN_GUI_INPUT_FLAGS_CONFIRM) != 0; gboolean is_tan = (flags & GWEN_GUI_INPUT_FLAGS_TAN) != 0; @@ -1006,6 +1021,14 @@ get_input(GncGWENGui *gui, guint32 flags, const gchar *title, const gchar *text, confirm_entry = GTK_WIDGET(gtk_builder_get_object (builder, "confirm_entry")); confirm_label = GTK_WIDGET(gtk_builder_get_object (builder, "confirm_label")); remember_pin_checkbutton = GTK_WIDGET(gtk_builder_get_object (builder, "remember_pin")); + optical_challenge = GTK_IMAGE(gtk_builder_get_object (builder, "optical_challenge")); + gtk_widget_set_visible(GTK_WIDGET(optical_challenge), FALSE); + #ifdef AQBANKING6 + if(mimeType != NULL && pChallenge != NULL && lChallenge > 0) + { + gtk_widget_set_visible(GTK_WIDGET(optical_challenge), TRUE); + } + #endif if (is_tan) { gtk_widget_hide(remember_pin_checkbutton); @@ -1035,6 +1058,35 @@ get_input(GncGWENGui *gui, guint32 flags, const gchar *title, const gchar *text, g_free(raw_text); } + #ifdef AQBANKING6 + //if (optical_challenge) + if(mimeType != NULL && pChallenge != NULL && lChallenge > 0) + { + // convert PNG and load into widget + // TBD: check mimeType? + guchar *gudata = (guchar*)pChallenge; + + GError *error = NULL; + GdkPixbufLoader *loader = gdk_pixbuf_loader_new_with_mime_type(mimeType, &error); + GdkPixbuf *pixbuf; + + if(error != NULL) + { + PERR("Pixbuf loader not loaded: %s, perhaps MIME type %s isn't supported.", error->message, mimeType); + } + + gdk_pixbuf_loader_write(loader, gudata, lChallenge, NULL); + gdk_pixbuf_loader_close(loader, NULL); + + pixbuf = gdk_pixbuf_loader_get_pixbuf(loader); + + g_object_ref(pixbuf); + g_object_unref(loader); + + gtk_image_set_from_pixbuf(optical_challenge, pixbuf); + } + #endif + if (*input) { gtk_entry_set_text(GTK_ENTRY(input_entry), *input); @@ -1170,7 +1222,11 @@ inputbox_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *title, ENTER("gui=%p, flags=%d", gui, flags); + #ifndef AQBANKING6 get_input(gui, flags, title, text, &input, min_len, max_len); + #else + get_input(gui, flags, title, text, NULL, NULL, 0, &input, min_len, max_len); + #endif if (input) { @@ -1406,7 +1462,7 @@ progress_end_cb(GWEN_GUI *gwen_gui, guint32 id) } static gint GNC_GWENHYWFAR_CB -#ifndef GWENHYWFAR5 +#ifndef AQBANKING6 getpassword_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *token, const gchar *title, const gchar *text, gchar *buffer, gint min_len, gint max_len, guint32 guiid) @@ -1421,8 +1477,46 @@ getpassword_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *token, gchar *password = NULL; gboolean is_tan = (flags & GWEN_GUI_INPUT_FLAGS_TAN) != 0; + #ifdef AQBANKING6 + int opticalMethodId; + const char *mimeType = NULL; + const char *pChallenge = NULL; + uint32_t lChallenge = 0; + #endif + g_return_val_if_fail(gui, -1); + #ifdef AQBANKING6 + // cf. https://www.aquamaniac.de/rdm/projects/aqbanking/wiki/ImplementTanMethods + if(is_tan && methodId == GWEN_Gui_PasswordMethod_OpticalHHD) + { + /** + * TODO: How to handle Flicker code (use WebView and JS???) + * + * use GWEN_Gui_PasswordMethod_Mask to get the basic method id + * cf. gui/gui.h of gwenhywfar + */ + opticalMethodId=GWEN_DB_GetIntValue(methodParams, "tanMethodId", 0, AB_BANKING_TANMETHOD_TEXT); + switch(opticalMethodId) + { + case AB_BANKING_TANMETHOD_PHOTOTAN: + case AB_BANKING_TANMETHOD_CHIPTAN_QR: + /** + * image data is in methodParams + */ + mimeType=GWEN_DB_GetCharValue(methodParams, "mimeType", 0, NULL); + pChallenge=(const char*) GWEN_DB_GetBinValue(methodParams, "imageData", 0, NULL, 0, &lChallenge); + if (!(pChallenge && lChallenge)) { + /* empty optical data */ + return GWEN_ERROR_NO_DATA; + } + break; + default: + break; + } + } + #endif + ENTER("gui=%p, flags=%d, token=%s", gui, flags, token ? token : "(null"); /* Check remembered passwords, excluding TANs */ @@ -1450,7 +1544,11 @@ getpassword_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *token, } } + #ifndef AQBANKING6 get_input(gui, flags, title, text, &password, min_len, max_len); + #else + get_input(gui, flags, title, text, mimeType, pChallenge, lChallenge, &password, min_len, max_len); + #endif if (password) { From b00a95c0b39e2666eac09bf13304782492d886b8 Mon Sep 17 00:00:00 2001 From: Geert Janssens Date: Sun, 6 Oct 2019 21:27:10 +0200 Subject: [PATCH 02/17] Tweak install rule to be able to compile glib's schema's on Windows as well (Cherry picked from master) It's a bit of a hack based on the assumption DESTDIR is never set on Windows. A install time guard is added to assert this. It needed a few changes to make this working: - Have cmake expand DESTDIR instead of delaying this to bash If not, bash would see "$DESTDIRC:/gcdev64/..." and we'd loose the drive letter in bash' expansion of $DESTDIRC. So work with $ENV{DESTDIR} instead - To prevent cmake from already expanding this in the build system generation step add the appropriate escapes to that variable. - Add guard code in the install command that asserts DESTDIR is not set on Windows. Use similar escapes as necessary to ensure the evaluation happens at install time rather than in the generation step. --- CMakeLists.txt | 2 ++ gnucash/gschemas/CMakeLists.txt | 18 ++++++++++++++---- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 1d1c327b1a..20ec5ce101 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -86,6 +86,8 @@ foreach(install_dir ${CMAKE_INSTALL_FULL_BINDIR} break() endif() endforeach() +message(STATUS "CMAKE_INSTALL_FULL_DATADIR: ${CMAKE_INSTALL_FULL_DATADIR}") +message(STATUS "DESTDIR: ${DESTDIR}") # GnuCash installs two files in ${CMAKE_INSTALL_SYSCONFDIR} set(BINDIR ${CMAKE_INSTALL_BINDIR} CACHE STRING "user executables") diff --git a/gnucash/gschemas/CMakeLists.txt b/gnucash/gschemas/CMakeLists.txt index 0b1fcb91b7..735e5c11d0 100644 --- a/gnucash/gschemas/CMakeLists.txt +++ b/gnucash/gschemas/CMakeLists.txt @@ -32,10 +32,20 @@ if (COMPILE_GSCHEMAS) add_custom_target(compiled-schemas ALL DEPENDS ${SCHEMADIR_BUILD}/gschemas.compiled) - - install(CODE "execute_process( - COMMAND ${SHELL} -c \"echo Compiling gschema files in $DESTDIR${CMAKE_INSTALL_FULL_DATADIR}/glib-2.0/schemas ; - ${GLIB_COMPILE_SCHEMAS} $DESTDIR${CMAKE_INSTALL_FULL_DATADIR}/glib-2.0/schemas\")") + # On Windows concatenating two absolute paths results in an invalid path (having two drive letters) + # If DESTDIR is not set on the other hand, the below install command works just fine + # So verify DESTDIR is not set on Windows + # Note we have to do this at build time, not configure time so the guard is part of the custom install command + install(CODE " + if (WIN32) + set (DESTDIR \$ENV\{DESTDIR\}) + if (DESTDIR) + message(SEND_ERROR \"GnuCash can't be built with the DESTDIR environment variable set on Windows (due to bad interference with glib-compile-schemas).\") + endif() + endif() + execute_process( + COMMAND ${SHELL} -c \"echo Compiling gschema files in \$ENV\{DESTDIR\}${CMAKE_INSTALL_FULL_DATADIR}/glib-2.0/schemas ; + ${GLIB_COMPILE_SCHEMAS} \$ENV\{DESTDIR\}${CMAKE_INSTALL_FULL_DATADIR}/glib-2.0/schemas\")") endif () set(gschemas_DIST_local "") From 9d0d3fd3be45015a1dbf2800a049eb40361fd09f Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Mon, 7 Oct 2019 20:16:06 +0800 Subject: [PATCH 03/17] Bug 759005 - Print negatives in red Fixes display of negative monetary-amounts so that they are rendered according to style-sheet option. Note this commit fixes via renderer -- if it has a single datum, and has a negative monetary amount, then its tag gets "-neg" appended. If a gnc:monetary is renderer *outside* html-table-cell, it will not be rendered as red (in default stylesheet). --- gnucash/report/report-system/html-table.scm | 33 +++++++++++-------- .../report-system/test/test-report-html.scm | 25 ++++++++++++++ 2 files changed, 44 insertions(+), 14 deletions(-) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index ceedb8eced..636c041299 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -140,25 +140,30 @@ cell (append (gnc:html-table-cell-data cell) objects))) (define (gnc:html-table-cell-render cell doc) + ;; This function renders a html-table-cell to a document tree + ;; segment. Note: if the html-table-cell datum is a negative + ;; gnc:monetary, it fixes the tag eg. "number-cell" becomes + ;; "number-cell-red". The gnc:monetary renderer does not have an + ;; automatic -neg tag modifier. See bug 759005 and bug 797357. (let* ((retval '()) (push (lambda (l) (set! retval (cons l retval)))) - (style (gnc:html-table-cell-style cell))) - -; ;; why dont colspans export??! -; (gnc:html-table-cell-set-style! cell "td" -; 'attribute (list "colspan" -; (or (gnc:html-table-cell-colspan cell) 1))) - (gnc:html-document-push-style doc style) - (push (gnc:html-document-markup-start - doc (gnc:html-table-cell-tag cell) #t + (cell-tag (gnc:html-table-cell-tag cell)) + (cell-data (gnc:html-table-cell-data cell)) + (tag (if (and (= 1 (length cell-data)) + (gnc:gnc-monetary? (car cell-data)) + (negative? (gnc:gnc-monetary-amount (car cell-data)))) + (string-append cell-tag "-neg") + cell-tag))) + (gnc:html-document-push-style doc (gnc:html-table-cell-style cell)) + (push (gnc:html-document-markup-start + doc tag #t (format #f "rowspan=\"~a\"" (gnc:html-table-cell-rowspan cell)) (format #f "colspan=\"~a\"" (gnc:html-table-cell-colspan cell)))) - (for-each - (lambda (child) + (for-each + (lambda (child) (push (gnc:html-object-render child doc))) - (gnc:html-table-cell-data cell)) - (push (gnc:html-document-markup-end - doc (gnc:html-table-cell-tag cell))) + cell-data) + (push (gnc:html-document-markup-end doc cell-tag)) (gnc:html-document-pop-style doc) retval)) diff --git a/gnucash/report/report-system/test/test-report-html.scm b/gnucash/report/report-system/test/test-report-html.scm index e4a854d488..e4178e316c 100644 --- a/gnucash/report/report-system/test/test-report-html.scm +++ b/gnucash/report/report-system/test/test-report-html.scm @@ -798,6 +798,31 @@ HTML Document Title\n\ ) (test-end "HTML Table - Table Rendering") + (test-begin "html-table-cell renderers") + (let ((doc (gnc:make-html-document)) + (cell (gnc:make-html-table-cell 4))) + (test-equal "html-table-cell renders correctly" + " 4\n" + (string-concatenate + (gnc:html-document-tree-collapse + (gnc:html-table-cell-render cell doc))))) + + ;; the following is tailor-made to test bug 797357. if the report + ;; system is refactored, this test will probably need fixing. it + ;; aims to ensure the table-cell class eg 'number-cell' + ;; 'total-number-cell' is augmented with a '-neg', and the + ;; resulting renderer renders as + (let* ((doc (gnc:make-html-document)) + (comm-table (gnc-commodity-table-get-table (gnc-get-current-book))) + (USD (gnc-commodity-table-lookup comm-table "CURRENCY" "USD")) + (cell (gnc:make-html-table-cell (gnc:make-gnc-monetary USD -10)))) + (test-equal "html-table-cell negative-monetary -> tag gets -neg appended" + "td-neg" + (cadr + (gnc:html-document-tree-collapse + (gnc:html-table-cell-render cell doc))))) + (test-end "html-table-cell renderers") + (test-end "HTML Tables - without style sheets") ) From 2d9969262112efa35a14f3fb3ed9627985a57579 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Mon, 7 Oct 2019 21:03:37 +0800 Subject: [PATCH 04/17] [budget] bug 759005 we don't need style-tag "-neg" anymore --- gnucash/report/standard-reports/budget.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm index b5c1c6443e..80b98dd6a1 100644 --- a/gnucash/report/standard-reports/budget.scm +++ b/gnucash/report/standard-reports/budget.scm @@ -350,25 +350,24 @@ ;; col - next column (define (disp-cols style-tag col0 bgt-val act-val dif-val) - (let* ((style-tag-neg (string-append style-tag "-neg")) - (col1 (+ col0 (if show-budget? 1 0))) + (let* ((col1 (+ col0 (if show-budget? 1 0))) (col2 (+ col1 (if show-actual? 1 0))) (col3 (+ col2 (if show-diff? 1 0)))) (if show-budget? (gnc:html-table-set-cell/tag! html-table rownum col0 - (if (negative? bgt-val) style-tag-neg style-tag) + style-tag (if (zero? bgt-val) "." (gnc:make-gnc-monetary comm bgt-val)))) (if show-actual? (gnc:html-table-set-cell/tag! html-table rownum col1 - (if (negative? act-val) style-tag-neg style-tag) + style-tag (gnc:make-gnc-monetary comm act-val))) (if show-diff? (gnc:html-table-set-cell/tag! html-table rownum col2 - (if (negative? dif-val) style-tag-neg style-tag) + style-tag (if (and (zero? bgt-val) (zero? act-val)) "." (gnc:make-gnc-monetary comm dif-val)))) col3)) From a90b874995e2234da9e2d360e693fe48b8e11ece Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Mon, 7 Oct 2019 21:54:38 +0800 Subject: [PATCH 05/17] Bug 759005 - Print negatives in red, bis addendum to 9d0d3fd3b; addition to negative monetaries, also print negative numbers in red --- gnucash/report/report-system/html-table.scm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index 636c041299..a54206897c 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -141,17 +141,19 @@ (define (gnc:html-table-cell-render cell doc) ;; This function renders a html-table-cell to a document tree - ;; segment. Note: if the html-table-cell datum is a negative - ;; gnc:monetary, it fixes the tag eg. "number-cell" becomes - ;; "number-cell-red". The gnc:monetary renderer does not have an - ;; automatic -neg tag modifier. See bug 759005 and bug 797357. + ;; segment. Note: if the html-table-cell datum is a negative number + ;; or gnc:monetary, it fixes the tag eg. "number-cell" becomes + ;; "number-cell-red". The number and gnc:monetary renderers do not + ;; have an automatic -neg tag modifier. See bug 759005 and 797357. (let* ((retval '()) (push (lambda (l) (set! retval (cons l retval)))) (cell-tag (gnc:html-table-cell-tag cell)) (cell-data (gnc:html-table-cell-data cell)) (tag (if (and (= 1 (length cell-data)) - (gnc:gnc-monetary? (car cell-data)) - (negative? (gnc:gnc-monetary-amount (car cell-data)))) + (or (and (gnc:gnc-monetary? (car cell-data)) + (negative? (gnc:gnc-monetary-amount (car cell-data)))) + (and (number? (car cell-data)) + (negative? (car cell-data))))) (string-append cell-tag "-neg") cell-tag))) (gnc:html-document-push-style doc (gnc:html-table-cell-style cell)) From f4379bbd8c33c2208aeadb5a5bdb7888a329db87 Mon Sep 17 00:00:00 2001 From: "Frank H. Ellenberger" Date: Tue, 8 Oct 2019 22:48:42 +0200 Subject: [PATCH 06/17] UK VAT template: replace obsolete EEC and EC by EU --- data/accounts/en_GB/uk-vat.gnucash-xea | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/data/accounts/en_GB/uk-vat.gnucash-xea b/data/accounts/en_GB/uk-vat.gnucash-xea index 31bdb59eb7..8222baa89d 100644 --- a/data/accounts/en_GB/uk-vat.gnucash-xea +++ b/data/accounts/en_GB/uk-vat.gnucash-xea @@ -137,7 +137,7 @@ 9c566ece97799eda4e900b003ce48e48 - EC Reverse VAT Purchase + EU Reverse VAT Purchase 6708e3ff1292c2b5defd07da9f858b60 ASSET @@ -273,7 +273,7 @@ 3352145930e40b21fee20532ad07501b - EC + EU 37d726ec68d451d098496b7f5513f6f8 LIABILITY @@ -293,7 +293,7 @@ GBP 100 - All, including zero rate UK/EC and World (Box 1) + All, including zero rate UK/EU and World (Box 1) a46d9e9624070fcd2427973a4c725ed6 @@ -483,7 +483,7 @@ 86ef7451027dcb6223bb01204ac09a5e - EEC + EU af74692df15b1de7665d5dd7a197cdfb INCOME @@ -491,7 +491,7 @@ GBP 100 - Sales in EEC + Sales in EU placeholder @@ -509,7 +509,7 @@ GBP 100 - Sale of goods within EEC + Sale of goods within EU af74692df15b1de7665d5dd7a197cdfb @@ -521,7 +521,7 @@ GBP 100 - Sale of services within EEC + Sale of services within EU notes @@ -726,7 +726,7 @@ d77071fafc0de8455dd566b805bfcc40 - EEC Reverse VAT + EU Reverse VAT af9b5ef4814015a83053a4c991ca0c1a EXPENSE From 7bb7d3cdd655d23c7af902e57aa6326df59933c1 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Mon, 7 Oct 2019 23:18:34 +0800 Subject: [PATCH 07/17] [html-document] schemify gnc:html-document-tree-collapse this function is technically a flattening function, converted to classic scheme form. very efficient in time and space. it is used extensively in reports which are still running well, therefore no additional testing is required. --- .../report/report-system/html-document.scm | 19 +++++-------------- 1 file changed, 5 insertions(+), 14 deletions(-) diff --git a/gnucash/report/report-system/html-document.scm b/gnucash/report/report-system/html-document.scm index ecb045e2c3..906ab30b89 100644 --- a/gnucash/report/report-system/html-document.scm +++ b/gnucash/report/report-system/html-document.scm @@ -105,20 +105,11 @@ (apply gnc:make-html-data-style-info rest) (apply gnc:make-html-markup-style-info rest)))) -(define (gnc:html-document-tree-collapse tree) - (let ((retval '())) - (let loop ((lst tree)) - (for-each - (lambda (elt) - (cond - ((string? elt) - (set! retval (cons elt retval))) - ((not (list? elt)) - (set! retval (cons (object->string elt) retval))) - (else - (loop elt)))) - lst)) - retval)) +(define (gnc:html-document-tree-collapse . tree) + (let lp ((e tree) (accum '())) + (cond ((list? e) (fold lp accum e)) + ((string? e) (cons e accum)) + (else (cons (object->string e) accum))))) ;; first optional argument is "headers?" ;; returns the html document as a string, I think. From f4794d516ffa194dcf2fe4af9e4cd2ace2c30f65 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 9 Oct 2019 05:40:00 +0800 Subject: [PATCH 08/17] [test-report-html] add tests for html-table-cell row/col modifiers --- .../report-system/test/test-report-html.scm | 34 +++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/gnucash/report/report-system/test/test-report-html.scm b/gnucash/report/report-system/test/test-report-html.scm index e4178e316c..6c5a3e6375 100644 --- a/gnucash/report/report-system/test/test-report-html.scm +++ b/gnucash/report/report-system/test/test-report-html.scm @@ -798,6 +798,40 @@ HTML Document Title\n\ ) (test-end "HTML Table - Table Rendering") + (test-begin "html-table arbitrary row/col modification") + (let ((doc (gnc:make-html-document)) + (table (gnc:make-html-table))) + (gnc:html-table-set-cell! table 0 0 "x") + (test-equal "html-table-set-cell! 0 0" + "\n\n\n
x
\n" + (string-concatenate + (gnc:html-document-tree-collapse + (gnc:html-table-render table doc)))) + + (gnc:html-table-set-cell! table 2 2 "y" "z") + (test-equal "html-table-set-cell! 2 2" + "\n\n\n\n\n\n\n\n
x
y z
\n" + (string-concatenate + (gnc:html-document-tree-collapse + (gnc:html-table-render table doc)))) + + (let* ((table1 (gnc:make-html-table)) + (cell (gnc:make-html-table-cell "ab"))) + (gnc:html-table-set-cell! table1 1 4 cell) + (test-equal "html-table-set-cell! 1 4" + "\n\n\n\n\n\n\n\n
ab
\n" + (string-concatenate + (gnc:html-document-tree-collapse + (gnc:html-table-render table1 doc)))) + + (gnc:html-table-set-cell/tag! table1 1 4 "tag" cell) + (test-equal "html-table-set-cell/tag! 1 4" + "\n\n\n\n\n ab\n\n\n
\n" + (string-concatenate + (gnc:html-document-tree-collapse + (gnc:html-table-render table1 doc)))))) + (test-end "html-table arbitrary row/col modification") + (test-begin "html-table-cell renderers") (let ((doc (gnc:make-html-document)) (cell (gnc:make-html-table-cell 4))) From 3a2c85f577ed580d39a51abbbf043fe7155001c6 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Tue, 8 Oct 2019 22:59:31 +0800 Subject: [PATCH 09/17] [html-table] deprecate gnc:html-table-remove-last-row! this function is unused in code. --- gnucash/report/report-system/html-table.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index a54206897c..edf96071d3 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -361,6 +361,7 @@ new-num-rows)) (define (gnc:html-table-remove-last-row! table) + (issue-deprecation-warning "gnc:html-table-remove-last-row! is unused.") (if (> (gnc:html-table-num-rows table) 0) (begin (gnc:html-table-set-num-rows-internal! From 49e651304261b04e79401487e97cd8d124baedd3 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 9 Oct 2019 20:12:28 +0800 Subject: [PATCH 10/17] [html-table] compact functions, define vars in formals --- gnucash/report/report-system/html-table.scm | 100 +++++++------------- 1 file changed, 32 insertions(+), 68 deletions(-) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index edf96071d3..9654225a79 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -125,14 +125,10 @@ (record-modifier 'style)) (define (gnc:html-table-cell-set-style! cell tag . rest) - (let ((newstyle #f) + (let ((newstyle (if (and (= (length rest) 2) (procedure? (car rest))) + (apply gnc:make-html-data-style-info rest) + (apply gnc:make-html-markup-style-info rest))) (styletable (gnc:html-table-cell-style cell))) - (if (and (= (length rest) 2) - (procedure? (car rest))) - (set! newstyle - (apply gnc:make-html-data-style-info rest)) - (set! newstyle - (apply gnc:make-html-markup-style-info rest))) (gnc:html-style-table-set! styletable tag newstyle))) (define (gnc:html-table-cell-append-objects! cell . objects) @@ -250,81 +246,50 @@ (record-accessor 'col-headers-style)) (define (gnc:html-table-set-col-headers-style! table tag . rest) - (let ((newstyle #f) + (let ((newstyle (if (and (= (length rest) 2) (procedure? (car rest))) + (apply gnc:make-html-data-style-info rest) + (apply gnc:make-html-markup-style-info rest))) (style (gnc:html-table-col-headers-style table))) - (if (and (= (length rest) 2) - (procedure? (car rest))) - (set! newstyle - (apply gnc:make-html-data-style-info rest)) - (set! newstyle - (apply gnc:make-html-markup-style-info rest))) (gnc:html-style-table-set! style tag newstyle))) (define gnc:html-table-row-headers-style (record-accessor 'row-headers-style)) (define (gnc:html-table-set-row-headers-style! table tag . rest) - (let ((newstyle #f) - (style (gnc:html-table-row-headers-style table))) - (if (and (= (length rest) 2) - (procedure? (car rest))) - (set! newstyle - (apply gnc:make-html-data-style-info rest)) - (set! newstyle - (apply gnc:make-html-markup-style-info rest))) + (let* ((newstyle (if (and (= (length rest) 2) (procedure? (car rest))) + (apply gnc:make-html-data-style-info rest) + (apply gnc:make-html-markup-style-info rest))) + (style (gnc:html-table-row-headers-style table))) (gnc:html-style-table-set! style tag newstyle))) (define (gnc:html-table-set-style! table tag . rest) - (let ((newstyle #f) - (style (gnc:html-table-style table))) - (if (and (= (length rest) 2) - (procedure? (car rest))) - (set! newstyle - (apply gnc:make-html-data-style-info rest)) - (set! newstyle - (apply gnc:make-html-markup-style-info rest))) + (let* ((newstyle (if (and (= (length rest) 2) (procedure? (car rest))) + (apply gnc:make-html-data-style-info rest) + (apply gnc:make-html-markup-style-info rest))) + (style (gnc:html-table-style table))) (gnc:html-style-table-set! style tag newstyle))) (define (gnc:html-table-set-col-style! table col tag . rest) - (let ((newstyle #f) - (style #f) - (newhash #f)) - (if (and (= (length rest) 2) - (procedure? (car rest))) - (set! newstyle - (apply gnc:make-html-data-style-info rest)) - (set! newstyle - (apply gnc:make-html-markup-style-info rest))) - (set! style - (gnc:html-table-col-style table col)) - (if (not style) - (begin - (set! style (gnc:make-html-style-table)) - (set! newhash #t))) + (let* ((newstyle (if (and (= (length rest) 2) (procedure? (car rest))) + (apply gnc:make-html-data-style-info rest) + (apply gnc:make-html-markup-style-info rest))) + (newhash #f) + (style (or (gnc:html-table-col-style table col) + (begin (set! newhash #t) + (gnc:make-html-style-table))))) (gnc:html-style-table-set! style tag newstyle) - (if newhash - (hash-set! (gnc:html-table-col-styles table) col style)))) + (if newhash (hash-set! (gnc:html-table-col-styles table) col style)))) (define (gnc:html-table-set-row-style! table row tag . rest) - (let ((newstyle #f) - (style #f) - (newhash #f)) - (if (and (= (length rest) 2) - (procedure? (car rest))) - (set! newstyle - (apply gnc:make-html-data-style-info rest)) - (set! newstyle - (apply gnc:make-html-markup-style-info rest))) - (set! style - (gnc:html-table-row-style table row)) - (if (not style) - (begin - (set! style (gnc:make-html-style-table)) - (set! newhash #t))) + (let* ((newstyle (if (and (= (length rest) 2) (procedure? (car rest))) + (apply gnc:make-html-data-style-info rest) + (apply gnc:make-html-markup-style-info rest))) + (newhash #f) + (style (or (gnc:html-table-row-style table row) + (begin (set! newhash #t) + (gnc:make-html-style-table))))) (gnc:html-style-table-set! style tag newstyle) - (if newhash - (hash-set! - (gnc:html-table-row-styles table) row style)))) + (when newhash (hash-set! (gnc:html-table-row-styles table) row style)))) (define (gnc:html-table-row-style table row) (hash-ref (gnc:html-table-row-styles table) row)) @@ -346,9 +311,8 @@ (gnc:html-table-set-row-markup! table (- rownum 1) markup))) (define (gnc:html-table-prepend-row/markup! table markup newrow) - (begin - (gnc:html-table-prepend-row! table newrow) - (gnc:html-table-set-row-markup! table 0 markup))) + (gnc:html-table-prepend-row! table newrow) + (gnc:html-table-set-row-markup! table 0 markup)) (define (gnc:html-table-append-row! table newrow) From d45f06215f1f1d10cb360148f74f0385d76cb62e Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 9 Oct 2019 20:12:59 +0800 Subject: [PATCH 11/17] [html-table] compact gnc:html-table-prepend-row! --- gnucash/report/report-system/html-table.scm | 33 ++++++++------------- 1 file changed, 13 insertions(+), 20 deletions(-) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index 9654225a79..d7f20c5a6a 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -340,35 +340,28 @@ '())) (define (gnc:html-table-prepend-row! table newrow) - (let* ((dd (gnc:html-table-data table)) - (current-num-rows (gnc:html-table-num-rows table)) - (new-num-rows (+ current-num-rows 1)) - (newrow-list (if (list? newrow) newrow (list newrow)))) - (set! dd (append dd (list newrow-list))) - (gnc:html-table-set-num-rows-internal! - table - new-num-rows) + (let* ((new-num-rows (1+ (gnc:html-table-num-rows table))) + (newrow-list (if (list? newrow) newrow (list newrow))) + (dd (append (gnc:html-table-data table) (list newrow-list)))) + (gnc:html-table-set-num-rows-internal! table new-num-rows) (gnc:html-table-set-data! table dd) - + ;; have to bump up the row index of the row styles and row markup ;; table on a prepend. just another reason you probably don't ;; want to prepend. (let ((new-rowstyles (make-hash-table 21))) - (hash-fold - (lambda (row style prev) - (hash-set! new-rowstyles (+ 1 row) style) - #f) - #f (gnc:html-table-row-styles table)) + (hash-for-each + (lambda (row style) + (hash-set! new-rowstyles (+ 1 row) style)) + (gnc:html-table-row-styles table)) (gnc:html-table-set-row-styles! table new-rowstyles)) (let ((new-rowmarkup (make-hash-table 21))) - (hash-fold - (lambda (row markup prev) - (hash-set! new-rowmarkup (+ 1 row) markup) - #f) - #f (gnc:html-table-row-markup-table table)) + (hash-for-each + (lambda (row markup) + (hash-set! new-rowmarkup (+ 1 row) markup)) + (gnc:html-table-row-markup-table table)) (gnc:html-table-set-row-markup-table! table new-rowmarkup)) - new-num-rows)) ;; list-set! is 0-based... From 1abda45cf62d4fea18aefa1877749f78b673e9f9 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 9 Oct 2019 20:13:17 +0800 Subject: [PATCH 12/17] [html-table] compact gnc:html-table-append-column! --- gnucash/report/report-system/html-table.scm | 88 ++++++--------------- 1 file changed, 26 insertions(+), 62 deletions(-) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index d7f20c5a6a..6703da5014 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -457,72 +457,36 @@ row-loc rowdata))))) (define (gnc:html-table-append-column! table newcol) - (define (maxwidth table-data) - (if (null? table-data) 0 - (max (length (car table-data)) (maxwidth (cdr table-data))))) - - ;; widen an individual row to the required width and append element - (define (widen-and-append row element width) - (let ((current-width (length row)) - (new-suffix (list element))) - (do - ((i current-width (+ i 1))) - ((>= 1 (- width i))) - (set! new-suffix (cons #f new-suffix))) - (append row new-suffix))) - - ;; append the elements of newcol to each of the existing rows, widening - ;; to width-to-make if necessary - (define (append-to-element newcol existing-data length-to-append - width-to-make) - (if (= length-to-append 0) + + ;; append the elements of newcol to each of the existing rows, + ;; widening to width-to-make if necessary + (define (append-to-element newcol existing-data length-to-append colnum) + (if (= length-to-append 0) (cons '() newcol) - (let* - ((current-new (car newcol)) - (current-existing (car existing-data)) - (rest-new (cdr newcol)) - (rest-existing (cdr existing-data)) - (rest-result (append-to-element rest-new rest-existing - (- length-to-append 1) - width-to-make))) - (cons (cons (widen-and-append - current-existing - current-new - width-to-make ) - (car rest-result)) - (cdr rest-result))))) - - (let* ((existing-data (reverse (gnc:html-table-data table))) - (existing-length (length existing-data)) - (width-to-make (+ (maxwidth existing-data) 1)) - (newcol-length (length newcol))) - (if (<= newcol-length existing-length) - (gnc:html-table-set-data! + (let ((result (append-to-element + (cdr newcol) (cdr existing-data) (1- length-to-append) + colnum))) + (cons (cons (list-set-safe! (car existing-data) colnum (car newcol)) + (car result)) + (cdr result))))) + + (let* ((old-data (reverse (gnc:html-table-data table))) + (old-numrows (length old-data)) + (old-numcols (apply max (cons 0 (map length old-data)))) + (new-numrows (length newcol))) + (if (<= new-numrows old-numrows) + (gnc:html-table-set-data! table - (reverse (car (append-to-element - newcol - existing-data - newcol-length - width-to-make)))) - (let* ((temp-result (append-to-element - newcol - existing-data - existing-length - width-to-make)) - (joined-table-data (car temp-result)) - (remaining-elements (cdr temp-result))) + (reverse (car (append-to-element newcol old-data new-numrows old-numcols)))) + (let ((res (append-to-element newcol old-data old-numrows old-numcols))) ;; Invariant maintained - table data in reverse order - (gnc:html-table-set-data! table (reverse joined-table-data)) - - (for-each + (gnc:html-table-set-data! table (reverse (car res))) + + (for-each (lambda (element) - (gnc:html-table-append-row! table - (widen-and-append - '() - element - width-to-make))) - remaining-elements) - #f)))) + (gnc:html-table-append-row! + table (list-set-safe! '() old-numcols element))) + (cdr res)))))) (define (gnc:html-table-prepend-column! table newcol) ;; returns a pair, the car of which is the prepending of newcol From ca5f587156ed28aa40f76d81aefc325c89be1974 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 9 Oct 2019 20:14:08 +0800 Subject: [PATCH 13/17] [html-table] compact gnc:html-table-render --- gnucash/report/report-system/html-table.scm | 220 +++++++++----------- 1 file changed, 98 insertions(+), 122 deletions(-) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index 6703da5014..c2a28efc61 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -529,144 +529,120 @@ remaining-elements) #f)))) -;; -;; It would be nice to have table row/col/cell accessor functions in here. -;; It would also be nice to have table juxtaposition functions, too. -;; i.e., (gnc:html-table-nth-row table n) -;; [ CAS: how is that different from gnc:html-table-get-row ? ] - -;; (gnc:html-table-append-table-horizontal table add-table) -;; (An old merge-table used to exist inside balance-sheet.scm/GnuCash 1.8.9.) -;; Feel free to contribute! :-) -;; - (define (gnc:html-table-render table doc) (let* ((retval '()) (push (lambda (l) (set! retval (cons l retval))))) - - ;; compile the table style to make other compiles faster - (gnc:html-style-table-compile - (gnc:html-table-style table) (gnc:html-document-style-stack doc)) - + + ;; compile the table style to make other compiles faster + (gnc:html-style-table-compile (gnc:html-table-style table) + (gnc:html-document-style-stack doc)) + (gnc:html-document-push-style doc (gnc:html-table-style table)) (push (gnc:html-document-markup-start doc "table" #t)) - - ;; render the caption + + ;; render the caption (let ((c (gnc:html-table-caption table))) - (if c - (begin - (push (gnc:html-document-markup-start doc "caption" #t)) - (push (gnc:html-object-render c doc)) - (push (gnc:html-document-markup-end doc "caption"))))) - + (when c + (push (gnc:html-document-markup-start doc "caption" #t)) + (push (gnc:html-object-render c doc)) + (push (gnc:html-document-markup-end doc "caption")))) + ;; the first row is the column headers. Columns styles apply. ;; compile the col styles with the header style pushed; we'll ;; recompile them later, but this will have the benefit of ;; compiling in the col-header-style. - (let ((ch (gnc:html-table-col-headers table)) - (colnum 0)) - (if ch - (begin - (gnc:html-document-push-style - doc (gnc:html-table-col-headers-style table)) - - ;; compile the column styles just in case there's - ;; something interesting in the table header cells. - (hash-fold - (lambda (col style init) - (if style - (gnc:html-style-table-compile - style (gnc:html-document-style-stack doc))) - #f) - #f (gnc:html-table-col-styles table)) - - ;; render the headers - (push (gnc:html-document-markup-start doc "thead" #t)) - (push (gnc:html-document-markup-start doc "tr" #t)) - (for-each - (lambda (hdr) - (gnc:html-document-push-style - doc (gnc:html-table-col-style table colnum)) - (if (not (gnc:html-table-cell? hdr)) - (push (gnc:html-document-markup-start doc "th" #t))) - (push (gnc:html-object-render hdr doc)) - (if (not (gnc:html-table-cell? hdr)) - (push (gnc:html-document-markup-end doc "th"))) - (gnc:html-document-pop-style doc) - (if (not (gnc:html-table-cell? hdr)) - (set! colnum (+ 1 colnum)) - (set! colnum (+ (gnc:html-table-cell-colspan hdr) - colnum)))) - ch) - (push (gnc:html-document-markup-end doc "tr")) - (push (gnc:html-document-markup-end doc "thead")) - - ;; pop the col header style - (gnc:html-document-pop-style doc)))) - + (let ((ch (gnc:html-table-col-headers table))) + (when ch + (gnc:html-document-push-style doc (gnc:html-table-col-headers-style table)) + + ;; compile the column styles just in case there's something + ;; interesting in the table header cells. + (hash-for-each + (lambda (col style) + (when style + (gnc:html-style-table-compile + style (gnc:html-document-style-stack doc)))) + (gnc:html-table-col-styles table)) + + ;; render the headers + (push (gnc:html-document-markup-start doc "thead" #t)) + (push (gnc:html-document-markup-start doc "tr" #t)) + (let lp ((ch ch) + (colnum 0)) + (unless (null? ch) + (let ((hdr (car ch))) + (gnc:html-document-push-style + doc (gnc:html-table-col-style table colnum)) + (unless (gnc:html-table-cell? hdr) + (push (gnc:html-document-markup-start doc "th" #t))) + (push (gnc:html-object-render hdr doc)) + (unless (gnc:html-table-cell? hdr) + (push (gnc:html-document-markup-end doc "th"))) + (gnc:html-document-pop-style doc) + (lp (cdr ch) + (+ colnum + (if (gnc:html-table-cell? hdr) + (gnc:html-table-cell-colspan hdr) + 1)))))) + (push (gnc:html-document-markup-end doc "tr")) + (push (gnc:html-document-markup-end doc "thead")) + + ;; pop the col header style + (gnc:html-document-pop-style doc))) + ;; recompile the column styles. We won't worry about the row ;; styles; if they're there, we may lose, but not much, and they ;; will be pretty rare (I think). - (hash-fold - (lambda (col style init) - (if style - (gnc:html-style-table-compile - style (gnc:html-document-style-stack doc))) - #f) - #f (gnc:html-table-col-styles table)) - + (hash-for-each + (lambda (col style) + (when style + (gnc:html-style-table-compile style (gnc:html-document-style-stack doc)))) + (gnc:html-table-col-styles table)) + (push (gnc:html-document-markup-start doc "tbody" #t)) - ;; now iterate over the rows - (let ((rownum 0) (colnum 0)) - (for-each - (lambda (row) - (let ((rowstyle - (gnc:html-table-row-style table rownum)) - (rowmarkup - (gnc:html-table-row-markup table rownum))) - ;; set default row markup - (if (not rowmarkup) - (set! rowmarkup "tr")) - - ;; push the style for this row and write the start tag, then - ;; pop it again. - (if rowstyle (gnc:html-document-push-style doc rowstyle)) - (push (gnc:html-document-markup-start doc rowmarkup #t)) - (if rowstyle (gnc:html-document-pop-style doc)) - - ;; write the column data, pushing the right column style - ;; each time, then the row style. - (for-each - (lambda (datum) - (let ((colstyle - (gnc:html-table-col-style table colnum))) - ;; push col and row styles - (if colstyle (gnc:html-document-push-style doc colstyle)) - (if rowstyle (gnc:html-document-push-style doc rowstyle)) - - ;; render the cell contents - (if (not (gnc:html-table-cell? datum)) - (push (gnc:html-document-markup-start doc "td" #t))) + ;; now iterate over the rows + (let rowloop ((rows (reverse (gnc:html-table-data table))) (rownum 0)) + (unless (null? rows) + (let* ((row (car rows)) + (rowstyle (gnc:html-table-row-style table rownum)) + (rowmarkup (or (gnc:html-table-row-markup table rownum) "tr"))) + + ;; push the style for this row and write the start tag, then + ;; pop it again. + (when rowstyle (gnc:html-document-push-style doc rowstyle)) + (push (gnc:html-document-markup-start doc rowmarkup #t)) + (when rowstyle (gnc:html-document-pop-style doc)) + + ;; write the column data, pushing the right column style + ;; each time, then the row style. + (let colloop ((cols row) (colnum 0)) + (unless (null? cols) + (let* ((datum (car cols)) + (colstyle (gnc:html-table-col-style table colnum))) + ;; push col and row styles + (when colstyle (gnc:html-document-push-style doc colstyle)) + (when rowstyle (gnc:html-document-push-style doc rowstyle)) + + ;; render the cell contents + (unless (gnc:html-table-cell? datum) + (push (gnc:html-document-markup-start doc "td" #t))) (push (gnc:html-object-render datum doc)) - (if (not (gnc:html-table-cell? datum)) - (push (gnc:html-document-markup-end doc "td"))) - - ;; pop styles - (if rowstyle (gnc:html-document-pop-style doc)) - (if colstyle (gnc:html-document-pop-style doc)) - (set! colnum (+ 1 colnum)))) - row) - - ;; write the row end tag and pop the row style - (if rowstyle (gnc:html-document-push-style doc rowstyle)) - (push (gnc:html-document-markup-end doc rowmarkup)) - (if rowstyle (gnc:html-document-pop-style doc)) - - (set! colnum 0) - (set! rownum (+ 1 rownum)))) - (reverse (gnc:html-table-data table)))) + (unless (gnc:html-table-cell? datum) + (push (gnc:html-document-markup-end doc "td"))) + + ;; pop styles + (when rowstyle (gnc:html-document-pop-style doc)) + (when colstyle (gnc:html-document-pop-style doc)) + (colloop (cdr cols) (1+ colnum))))) + + ;; write the row end tag and pop the row style + (when rowstyle (gnc:html-document-push-style doc rowstyle)) + (push (gnc:html-document-markup-end doc rowmarkup)) + (when rowstyle (gnc:html-document-pop-style doc)) + + (rowloop (cdr rows) (1+ rownum))))) (push (gnc:html-document-markup-end doc "tbody")) - + ;; write the table end tag and pop the table style (push (gnc:html-document-markup-end doc "table")) (gnc:html-document-pop-style doc) From 6370b0f7ee4399fe223a269e95bf4283a9f7d773 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 9 Oct 2019 20:27:18 +0800 Subject: [PATCH 14/17] [html-table] html-table-cell negative amount does not apply to Only number-cell and total-number-cell have negative-amount styles. --- gnucash/report/report-system/html-table.scm | 1 + gnucash/report/report-system/test/test-report-html.scm | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index c2a28efc61..69f3b7b3ff 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -146,6 +146,7 @@ (cell-tag (gnc:html-table-cell-tag cell)) (cell-data (gnc:html-table-cell-data cell)) (tag (if (and (= 1 (length cell-data)) + (not (string=? cell-tag "td")) (or (and (gnc:gnc-monetary? (car cell-data)) (negative? (gnc:gnc-monetary-amount (car cell-data)))) (and (number? (car cell-data)) diff --git a/gnucash/report/report-system/test/test-report-html.scm b/gnucash/report/report-system/test/test-report-html.scm index 6c5a3e6375..5c672690c4 100644 --- a/gnucash/report/report-system/test/test-report-html.scm +++ b/gnucash/report/report-system/test/test-report-html.scm @@ -849,9 +849,10 @@ HTML Document Title\n\ (let* ((doc (gnc:make-html-document)) (comm-table (gnc-commodity-table-get-table (gnc-get-current-book))) (USD (gnc-commodity-table-lookup comm-table "CURRENCY" "USD")) - (cell (gnc:make-html-table-cell (gnc:make-gnc-monetary USD -10)))) + (USD-neg10 (gnc:make-gnc-monetary USD -10)) + (cell (gnc:make-html-table-cell/markup "number-cell" USD-neg10))) (test-equal "html-table-cell negative-monetary -> tag gets -neg appended" - "td-neg" + "number-cell-neg" (cadr (gnc:html-document-tree-collapse (gnc:html-table-cell-render cell doc))))) From 8a46daeb8c67ed4a6900d15dc8c916665f698d61 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 9 Oct 2019 05:49:53 +0800 Subject: [PATCH 15/17] [html-table] convert to srfi-2 and-let* --- gnucash/report/report-system/html-table.scm | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index 69f3b7b3ff..eb4cea9905 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -23,6 +23,8 @@ ;; Boston, MA 02110-1301, USA gnu@gnu.org ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(use-modules (srfi srfi-2)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; NB: In this code, "markup" and "/markup" *do not* refer to @@ -365,22 +367,14 @@ (gnc:html-table-set-row-markup-table! table new-rowmarkup)) new-num-rows)) -;; list-set! is 0-based... -;; (let ((a '(0 1 2))) (list-set! a 1 "x") a) -;; => (0 "x" 2) (define (gnc:html-table-get-cell table row col) - (let* ((row (gnc:html-table-get-row table row))) - (and row (list-ref-safe row col))) - ) + (and-let* ((row (gnc:html-table-get-row table row))) + (list-ref-safe row col))) (define (gnc:html-table-get-row table row) - (let* ((dd (gnc:html-table-data table)) - (len (and dd (length dd))) - ) - (and len - (list-ref-safe dd (- (- len 1) row)) - ) - )) + (and-let* ((dd (gnc:html-table-data table)) + (len (length dd))) + (list-ref-safe dd (- len row 1)))) ;; if the 4th arg is a cell, overwrite the existing cell, ;; otherwise, append all remaining objects to the existing cell From ef3bc616b2dafbd2ef9886b12e603e9e37bee565 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Tue, 8 Oct 2019 22:01:45 +0800 Subject: [PATCH 16/17] [html-table] refactor and dedupe row/col modifiers * dedupe gnc:html-table-set-cell/tag! * dedupe gnc:html-table-set-cell! * create internal fn gnc:html-table-set-cell-datum! for above fns --- gnucash/report/report-system/html-table.scm | 98 ++++++--------------- 1 file changed, 26 insertions(+), 72 deletions(-) diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm index eb4cea9905..755fa01516 100644 --- a/gnucash/report/report-system/html-table.scm +++ b/gnucash/report/report-system/html-table.scm @@ -376,80 +376,34 @@ (len (length dd))) (list-ref-safe dd (- len row 1)))) -;; if the 4th arg is a cell, overwrite the existing cell, -;; otherwise, append all remaining objects to the existing cell +;; this function is not exported +(define (gnc:html-table-set-cell-datum! table row col datum) + (let lp ((len (length (gnc:html-table-data table)))) + (cond + ((< row len) + (let* ((row-loc (- len row 1)) + (old-tbldata (gnc:html-table-data table)) + (old-rowdata (list-ref old-tbldata row-loc)) + (new-rowdata (list-set-safe! old-rowdata col datum)) + (new-tbldata (list-set-safe! old-tbldata row-loc new-rowdata))) + ;; add the row-data back to the table + (gnc:html-table-set-data! table new-tbldata))) + (else + (gnc:html-table-append-row! table '()) + (lp (1+ len)))))) + (define (gnc:html-table-set-cell! table row col . objects) - (let ((rowdata #f) - (row-loc #f) - (l (length (gnc:html-table-data table))) - (objs (length objects)) - ) - ;; ensure the row-data is there - (if (>= row l) - (begin - (let loop ((i l)) - (gnc:html-table-append-row! table (list)) - (if (< i row) - (loop (+ i 1)))) - (set! l (gnc:html-table-num-rows table)) - (set! row-loc (- (- l 1) row)) - (set! rowdata (list))) - (begin - (set! row-loc (- (- l 1) row)) - (set! rowdata (list-ref (gnc:html-table-data table) row-loc)))) - - ;; make a table-cell and set the data - (let* ((tc (gnc:make-html-table-cell)) - (first (car objects))) - (if (and (equal? objs 1) (gnc:html-table-cell? first)) - (set! tc first) - (apply gnc:html-table-cell-append-objects! tc objects) - ) - (set! rowdata (list-set-safe! rowdata col tc)) - - ;; add the row-data back to the table - (gnc:html-table-set-data! - table (list-set-safe! - (gnc:html-table-data table) - row-loc rowdata))))) - -;; if the 4th arg is a cell, overwrite the existing cell, -;; otherwise, append all remaining objects to the existing cell + (let ((tc (if (and (= (length objects) 1) (gnc:html-table-cell? (car objects))) + (car objects) + (apply gnc:make-html-table-cell objects)))) + (gnc:html-table-set-cell-datum! table row col tc))) + (define (gnc:html-table-set-cell/tag! table row col tag . objects) - (let ((rowdata #f) - (row-loc #f) - (l (length (gnc:html-table-data table))) - (num-objs (length objects)) - ) - ;; ensure the row-data is there - (if (>= row l) - (begin - (let loop ((i l)) - (gnc:html-table-append-row! table (list)) - (if (< i row) - (loop (+ i 1)))) - (set! l (gnc:html-table-num-rows table)) - (set! row-loc (- (- l 1) row)) - (set! rowdata (list))) - (begin - (set! row-loc (- (- l 1) row)) - (set! rowdata (list-ref (gnc:html-table-data table) row-loc)))) - - ;; make a table-cell and set the data - (let* ((tc (gnc:make-html-table-cell)) - (first (car objects))) - (if (and (equal? num-objs 1) (gnc:html-table-cell? first)) - (set! tc first) - (apply gnc:html-table-cell-append-objects! tc objects) - ) - (gnc:html-table-cell-set-tag! tc tag) - (set! rowdata (list-set-safe! rowdata col tc)) - - ;; add the row-data back to the table - (gnc:html-table-set-data! - table (list-set-safe! - (gnc:html-table-data table) - row-loc rowdata))))) + (let ((tc (if (and (= (length objects) 1) (gnc:html-table-cell? (car objects))) + (car objects) + (apply gnc:make-html-table-cell objects)))) + (gnc:html-table-cell-set-tag! tc tag) + (gnc:html-table-set-cell-datum! table row col tc))) (define (gnc:html-table-append-column! table newcol) From 662d29d664d6834b66caf7c9a24a9543d8571d13 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 9 Oct 2019 20:42:26 +0800 Subject: [PATCH 17/17] [average-balance] show monetaries instead of numbers in data table instead of numbers, show monetary amounts, rounded to SCU --- .../report/standard-reports/average-balance.scm | 12 ++++++++++-- .../test/test-average-balance.scm | 16 ++++++++-------- 2 files changed, 18 insertions(+), 10 deletions(-) diff --git a/gnucash/report/standard-reports/average-balance.scm b/gnucash/report/standard-reports/average-balance.scm index 07d2390656..8da8063edf 100644 --- a/gnucash/report/standard-reports/average-balance.scm +++ b/gnucash/report/standard-reports/average-balance.scm @@ -486,7 +486,8 @@ ;; make a table (optionally) (gnc:report-percent-done 80) (if show-table? - (let ((table (gnc:make-html-table))) + (let ((table (gnc:make-html-table)) + (scu (gnc-commodity-get-fraction report-currency))) (gnc:html-table-set-col-headers! table columns) (for-each @@ -498,7 +499,14 @@ (list "date-cell" "date-cell" "number-cell" "number-cell" "number-cell" "number-cell" "number-cell" "number-cell") - row))) + (cons* (car row) + (cadr row) + (map + (lambda (amt) + (gnc:make-gnc-monetary + report-currency + (gnc-numeric-convert amt scu GNC-RND-ROUND))) + (cddr row)))))) data) (gnc:html-document-add-object! document table)))) diff --git a/gnucash/report/standard-reports/test/test-average-balance.scm b/gnucash/report/standard-reports/test/test-average-balance.scm index c40ca3d22d..0f96a01fa4 100644 --- a/gnucash/report/standard-reports/test/test-average-balance.scm +++ b/gnucash/report/standard-reports/test/test-average-balance.scm @@ -67,35 +67,35 @@ (let* ((options (default-testing-options)) (sxml (options->sxml options "default"))) (test-equal "averages" - '("0.00" "50.00" "100.00" "150.00" "200.00" "200.00") + '("$0.00" "$50.00" "$100.00" "$150.00" "$200.00" "$200.00") (get-row-col sxml #f 3)) (test-equal "maximums" - '("0.00" "100.00" "100.00" "200.00" "200.00" "200.00") + '("$0.00" "$100.00" "$100.00" "$200.00" "$200.00" "$200.00") (get-row-col sxml #f 4)) (test-equal "minimums" - '("0.00" "0.00" "100.00" "100.00" "200.00" "200.00") + '("$0.00" "$0.00" "$100.00" "$100.00" "$200.00" "$200.00") (get-row-col sxml #f 5)) (test-equal "net" - '("0.00" "100.00" "0.00" "100.00" "0.00" "0.00") + '("$0.00" "$100.00" "$0.00" "$100.00" "$0.00" "$0.00") (get-row-col sxml #f 8))) (env-transfer env 15 03 1979 bank bank2 25) (let* ((options (default-testing-options)) (sxml (options->sxml options "include-internal"))) (test-equal "gains-include-internal" - '("0.00" "100.00" "25.00" "100.00" "0.00" "0.00") + '("$0.00" "$100.00" "$25.00" "$100.00" "$0.00" "$0.00") (get-row-col sxml #f 6)) (test-equal "loss-include-internal" - '("0.00" "0.00" "25.00" "0.00" "0.00" "0.00") + '("$0.00" "$0.00" "$25.00" "$0.00" "$0.00" "$0.00") (get-row-col sxml #f 7))) (let* ((options (default-testing-options))) (set-option! options "Accounts" "Exclude transactions between selected accounts" #t) (let ((sxml (options->sxml options "exclude-internal"))) (test-equal "gain-exclude-internal" - '("0.00" "100.00" "0.00" "100.00" "0.00" "0.00") + '("$0.00" "$100.00" "$0.00" "$100.00" "$0.00" "$0.00") (get-row-col sxml #f 6)) (test-equal "loss-exclude-internal" - '("0.00" "0.00" "0.00" "0.00" "0.00" "0.00") + '("$0.00" "$0.00" "$0.00" "$0.00" "$0.00" "$0.00") (get-row-col sxml #f 7)))) (teardown)))