aherman
/
gnucash
mirror of https://github.com/Gnucash/gnucash
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'maint'

Browse Source
pull/588/head
Christopher Lam 7 years ago
parent 58cfb58b9c 662d29d664
commit 84034044ce
9 changed files with 438 additions and 412 deletions
Show Stats Download Patch File Download Diff File

16
data/accounts/en_GB/uk-vat.gnucash-xea
Unescape View File

@ -137,7 +137,7 @@
<act:parent type="new">9c566ece97799eda4e900b003ce48e48</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>EC Reverse VAT Purchase</act:name>
<act:name>EU Reverse VAT Purchase</act:name>
<act:id type="new">6708e3ff1292c2b5defd07da9f858b60</act:id>
<act:type>ASSET</act:type>
<act:commodity>
@ -273,7 +273,7 @@
<act:parent type="new">3352145930e40b21fee20532ad07501b</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>EC</act:name>
<act:name>EU</act:name>
<act:id type="new">37d726ec68d451d098496b7f5513f6f8</act:id>
<act:type>LIABILITY</act:type>
<act:commodity>
@ -293,7 +293,7 @@
<cmdty:id>GBP</cmdty:id>
</act:commodity>
<act:commodity-scu>100</act:commodity-scu>
<act:description>All, including zero rate UK/EC and World (Box 1)</act:description>
<act:description>All, including zero rate UK/EU and World (Box 1)</act:description>
<act:parent type="new">a46d9e9624070fcd2427973a4c725ed6</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@ -483,7 +483,7 @@
<act:parent type="new">86ef7451027dcb6223bb01204ac09a5e</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>EEC</act:name>
<act:name>EU</act:name>
<act:id type="new">af74692df15b1de7665d5dd7a197cdfb</act:id>
<act:type>INCOME</act:type>
<act:commodity>
@ -491,7 +491,7 @@
<cmdty:id>GBP</cmdty:id>
</act:commodity>
<act:commodity-scu>100</act:commodity-scu>
<act:description>Sales in EEC</act:description>
<act:description>Sales in EU</act:description>
<act:slots>
<slot>
<slot:key>placeholder</slot:key>
@ -509,7 +509,7 @@
<cmdty:id>GBP</cmdty:id>
</act:commodity>
<act:commodity-scu>100</act:commodity-scu>
<act:description>Sale of goods within EEC</act:description>
<act:description>Sale of goods within EU</act:description>
<act:parent type="new">af74692df15b1de7665d5dd7a197cdfb</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@ -521,7 +521,7 @@
<cmdty:id>GBP</cmdty:id>
</act:commodity>
<act:commodity-scu>100</act:commodity-scu>
<act:description>Sale of services within EEC</act:description>
<act:description>Sale of services within EU</act:description>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@ -726,7 +726,7 @@
<act:parent type="new">d77071fafc0de8455dd566b805bfcc40</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
<act:name>EEC Reverse VAT</act:name>
<act:name>EU Reverse VAT</act:name>
<act:id type="new">af9b5ef4814015a83053a4c991ca0c1a</act:id>
<act:type>EXPENSE</act:type>
<act:commodity>

18
gnucash/import-export/aqb/dialog-ab.glade
Unescape View File

@ -664,6 +664,22 @@
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkImage" id="optical_challenge">
<property name="name">optical_challenge</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="hexpand">True</property>
<property name="vexpand">True</property>
<property name="stock">gtk-missing-image</property>
<property name="icon_size">6</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">2</property>
</packing>
</child>
<child>
<object class="GtkGrid" id="grid1">
<property name="visible">True</property>
@ -751,7 +767,7 @@
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">1</property>
<property name="position">3</property>
</packing>
</child>
</object>

102
gnucash/import-export/aqb/gnc-gwen-gui.c
Unescape View File

@ -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)
{

19
gnucash/report/html-document.scm
Unescape View File

@ -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.

598
gnucash/report/html-table.scm
Unescape View File

@ -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
@ -125,14 +127,10 @@
(record-modifier <html-table-cell> '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)
@ -140,25 +138,33 @@
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 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))))
(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))
(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))
(negative? (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))
@ -243,81 +249,50 @@
(record-accessor <html-table> '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 <html-table> '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))
@ -339,9 +314,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)
@ -354,6 +328,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!
@ -368,336 +343,215 @@
'()))
(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...
;; (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))
)
))
;; if the 4th arg is a cell, overwrite the existing cell,
;; otherwise, append all remaining objects to the existing cell
(and-let* ((dd (gnc:html-table-data table))
(len (length dd)))
(list-ref-safe dd (- len row 1))))
;; 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)
(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
(lambda (element)
(gnc:html-table-append-row! table
(widen-and-append
'()
element
width-to-make)))
remaining-elements)
#f))))
(gnc:html-table-set-data! table (reverse (car res)))
(for-each
(lambda (element)
(gnc:html-table-append-row!
table (list-set-safe! '() old-numcols element)))
(cdr res))))))
;;
;; 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)

12
gnucash/report/reports/example/average-balance.scm
Unescape View File

@ -467,7 +467,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
@ -479,7 +480,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))))

9
gnucash/report/reports/standard/budget.scm
Unescape View File

@ -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))

16
gnucash/report/reports/standard/test/test-average-balance.scm
Unescape View File

@ -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)))

60
gnucash/report/test/test-report-html.scm
Unescape View File

@ -798,6 +798,66 @@ HTML Document Title</title></head><body></body>\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"
"<table><tbody><tr><td rowspan=\"1\" colspan=\"1\"><string> x</td>\n</tr>\n</tbody>\n</table>\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"
"<table><tbody><tr><td rowspan=\"1\" colspan=\"1\"><string> x</td>\n</tr>\n<tr></tr>\n<tr><td><string> </td>\n<td><string> </td>\n<td rowspan=\"1\" colspan=\"1\"><string> y<string> z</td>\n</tr>\n</tbody>\n</table>\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"
"<table><tbody><tr></tr>\n<tr><td><string> </td>\n<td><string> </td>\n<td><string> </td>\n<td><string> </td>\n<td rowspan=\"1\" colspan=\"1\"><string> ab</td>\n</tr>\n</tbody>\n</table>\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"
"<table><tbody><tr></tr>\n<tr><td><string> </td>\n<td><string> </td>\n<td><string> </td>\n<td><string> </td>\n<tag rowspan=\"1\" colspan=\"1\"><string> ab</tag>\n</tr>\n</tbody>\n</table>\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)))
(test-equal "html-table-cell renders correctly"
"<td rowspan=\"1\" colspan=\"1\"><number> 4</td>\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 <td class='number-cell neg' ...>
(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"))
(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"
"number-cell-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")
)

Write Preview
Loading…
Cancel
Save