From f0e2fe43a5e5e22342a13139815556ae3b373d6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 1 Oct 2019 23:03:11 +0200 Subject: Start moving to scheme structs. --- src/guile_type_helpers.c | 11 +-- src/parse.c | 225 ++++++++++++++++++++--------------------------- src/parse.h | 6 +- src/strbuf.h | 1 - src/struct.c | 59 +++++++++++++ src/struct.h | 23 +++++ src/vcal.c | 6 +- 7 files changed, 190 insertions(+), 141 deletions(-) create mode 100644 src/struct.c create mode 100644 src/struct.h diff --git a/src/guile_type_helpers.c b/src/guile_type_helpers.c index 0353a88a..f03ac671 100644 --- a/src/guile_type_helpers.c +++ b/src/guile_type_helpers.c @@ -4,12 +4,13 @@ #include "macro.h" SCM scm_from_strbuf(strbuf* s) { - if (s->scm == NULL) { - s->scm = scm_from_utf8_stringn (s->mem, s->len); - scm_gc_protect_object(s->scm); - } + // if (s->scm == NULL) { + SCM ret = scm_from_utf8_stringn (s->mem, s->len); + scm_gc_protect_object(ret); + // } - return s->scm; + // return s->scm; + return ret; } SCM scm_from_strbuf_symbol(strbuf* s) { diff --git a/src/parse.c b/src/parse.c index 565e1d6c..e79231cb 100644 --- a/src/parse.c +++ b/src/parse.c @@ -9,6 +9,10 @@ #include "err.h" +#include +#include "struct.h" +#include "guile_type_helpers.h" + // #define TYPE vcomponent // #include "linked_list.inc.h" // #undef TYPE @@ -20,10 +24,33 @@ #undef T #undef V +/* + +-------------------------------------------------------+ + v | + BEGIN → key -------------------------------→ ':' → value → CRLF -+-→ EOF + | ^ + v | + ';' → param-key → ':' → param-value --+ + ^ | + +------------------------------------+ + + + vcomponent := map> + line := pair + attributes := map> + + + */ + +#define string_eq(a, b) scm_string_eq(a, b, SCM_BOOL_F,SCM_BOOL_F,SCM_BOOL_F,SCM_BOOL_F) + /* * name *(";" param) ":" value CRLF */ int parse_file(char* filename, FILE* f, vcomponent* root) { + scm_c_use_module ("(vcomponent struct)"); + + part_context p_ctx = p_key; SNEW(parse_ctx, ctx, f, filename); @@ -36,9 +63,18 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { * {cline,param}_key is also temporary register used during * parsing. */ - SNEW(content_line, cline); - SNEW(strbuf, cline_key); - SNEW(strbuf, param_key); + // SNEW(content_line, cline); + // SNEW(strbuf, param_key); + // SNEW(strbuf, param_val); + // SNEW(strbuf, attr_key); + // SNEW(strbuf, attr_val); + + SNEW(strbuf, str); + SCM component; /* TODO init to root */ + SCM line = scm_make_vline(); + SCM attr_key; /* string */ + SCM line_key; /* string */ + SCM param_set; /* hashtable */ char c; while ( (c = fgetc(f)) != EOF) { @@ -48,21 +84,48 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { if (fold(&ctx, c) > 0) { /* Actuall end of line, handle value */ - TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); - handle_kv(&cline_key, &cline, &ctx); + // TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); + /* + * The key being BEGIN means that we decend into a new component. + */ + if (string_eq(line_key, scm_from_utf8_string("BEGIN"))) { + /* key \in { VCALENDAR, VEVENT, VALARM, VTODO, VTIMEZONE, ... } */ + SCM child = scm_make_vcomponent(scm_from_strbuf(&str)); + scm_add_child_x (component, child); + component = child; + + } else if (string_eq(line_key, scm_from_utf8_string("END"))) { + // TODO make current component be parent of current component? + component = scm_component_parent(component); + + /* + * A regular key, value pair. Push it into to the current + * component. + */ + } else { + scm_set_value_x(line, scm_from_strbuf(&str)); + scm_add_line_x(component, line_key, line); + line = scm_make_vline(); + } + + strbuf_soft_reset (&str); p_ctx = p_key; } /* Else continue on current line */ /* We have an escaped character */ } else if (c == '\\') { - handle_escape (&ctx); + char esc = handle_escape (&ctx); + strbuf_append(&str, esc); /* Border between param {key, value} */ } else if (p_ctx == p_param_name && c == '=') { /* Save the current parameter key */ - TRANSFER (¶m_key, &ctx.str); + // TODO + // TRANSFER (¶m_key, &ctx.str); + attr_key = scm_from_strbuf(&str); p_ctx = p_param_value; + strbuf_soft_reset (&str); /* * One of four cases: @@ -77,15 +140,8 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { * the current parameter set. */ if (p_ctx == p_param_value) { /* save current parameter value. */ - - NEW(strbuf, s); - TRANSFER(s, &ctx.str); - - NEW(param_set, ps); - PUSH(param_set)(ps, s); - - PUSH(TRIE(param_set))(CLINE_CUR_PARAMS(&cline), param_key.mem, ps); - strbuf_soft_reset (¶m_key); + scm_add_attribute_x(line, line_key, scm_from_strbuf(&str)); + strbuf_soft_reset (&str); } /* @@ -96,10 +152,12 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { */ if (p_ctx == p_key) { - TRANSFER(&cline_key, &ctx.str); + // TRANSFER(&cline_key, &ctx.str); - NEW(content_set, p); - PUSH(LLIST(content_set))(&cline, p); + // NEW(content_set, p); + // PUSH(LLIST(content_set))(&cline, p); + attr_key = scm_from_strbuf(&str); + strbuf_soft_reset (&str); } if (c == ':') p_ctx = p_value; @@ -110,7 +168,7 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { * the current string. */ } else { - strbuf_append(&ctx.str, c); + strbuf_append(&str, c); ++ctx.column; ++ctx.pcolumn; @@ -121,21 +179,24 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { ERR("Error parsing"); } /* Check to see if empty line */ - else if (ctx.str.ptr != 0) { + else if (str.ptr != 0) { /* * The standard (3.4, l. 2675) says that each icalobject must * end with CRLF. My files however does not, so we also parse * the end here. */ - TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); - handle_kv(&cline_key, &cline, &ctx); + // TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); + // TODO + // handle_kv(&cline_key, &cline, &ctx); } - FREE(content_line)(&cline); - FREE(strbuf)(&cline_key); - FREE(strbuf)(¶m_key); + // FREE(content_line)(&cline); + // FREE(strbuf)(&cline_key); + // FREE(strbuf)(¶m_key); + + FREE(strbuf)(&str); assert(POP(LLIST(vcomponent))(&ctx.comp_stack) == root); assert(EMPTY(LLIST(strbuf))(&ctx.key_stack)); @@ -146,102 +207,6 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { return 0; } -/* - * We have a complete key value pair. - */ -int handle_kv ( - strbuf* key, - content_line* cline, - parse_ctx* ctx - ) { - - /* - * The key being BEGIN means that we decend into a new component. - */ - if (strbuf_c(key, "BEGIN")) { - /* key \in { VCALENDAR, VEVENT, VALARM, VTODO, VTIMEZONE, ... } */ - - /* - * Take a copy of the name of the entered component, and store - * it on the stack of component names. - */ - NEW(strbuf, s); - DEEP_COPY(strbuf)(s, CLINE_CUR_VAL(cline)); - PUSH(LLIST(strbuf))(&ctx->key_stack, s); - - /* Clear the value list in the parse content_line */ - RESET(LLIST(content_set))(cline); - - /* - * Create the new curent component, link it with the current - * component in a parent/child relationship. - * Finally push the new component on to the top of the - * component stack. - */ - NEW(vcomponent, e, - s->mem, - ctx->filename); - vcomponent* parent = PEEK(LLIST(vcomponent))(&ctx->comp_stack); - PUSH(vcomponent)(parent, e); - - PUSH(LLIST(vcomponent))(&ctx->comp_stack, e); - - /* - * The end of a component, go back along the stack to the previous - * component. - */ - } else if (strbuf_c(key, "END")) { - strbuf* expected_key = POP(LLIST(strbuf))(&ctx->key_stack); - - if (strbuf_cmp(expected_key, CLINE_CUR_VAL(cline)) != 0) { - - ERR_P(ctx, "Expected END:%s, got END:%s.\n%s line", - expected_key->mem, - CLINE_CUR_VAL(cline)->mem, - vcomponent_get_val( - PEEK(LLIST(vcomponent))(&ctx->comp_stack), - "X-HNH-FILENAME")); - PUSH(LLIST(strbuf))(&ctx->key_stack, expected_key); - - return -1; - - } else { - FFREE(strbuf, expected_key); - POP(LLIST(vcomponent))(&ctx->comp_stack); - } - - /* - * A regular key, value pair. Push it into to the current - * component. - */ - } else { - - /* - * cline is the value store used during parsing, meaning that - * its values WILL mutate at a later point. Therefore we take - * a copy of it here. - */ - NEW(content_line, c); - DEEP_COPY(content_line)(c, cline); - - /* - * The PUSH(TRIE(T)) method handles collisions by calling - * RESOLVE(T). content_line resolves by merging the new value - * into the old value, and freeing the new value's container. - * - * This means that |c| declared above might be destroyed - * here. - */ - PUSH(TRIE(content_line))( - &PEEK(LLIST(vcomponent))(&ctx->comp_stack)->clines, - key->mem, c); - - RESET(LLIST(content_set))(cline); - } - - return 0; -} - int fold(parse_ctx* ctx, char c) { int retval; @@ -289,7 +254,7 @@ INIT_F(parse_ctx, FILE* f, char* filename) { self->pline = 1; self->pcolumn = 1; - INIT(strbuf, &self->str); + // INIT(strbuf, &self->str); return 0; } @@ -302,12 +267,12 @@ FREE_F(parse_ctx) { self->line = 0; self->column = 0; - FREE(strbuf)(&self->str); + // FREE(strbuf)(&self->str); return 0; } -int handle_escape (parse_ctx* ctx) { +char handle_escape (parse_ctx* ctx) { char esc = fgetc(ctx->f); /* @@ -340,11 +305,13 @@ int handle_escape (parse_ctx* ctx) { ERR_P(ctx, "Non escapable character '%c' (%i)", esc, esc); } - /* save escapade character as a normal character */ - strbuf_append(&ctx->str, esc); - ++ctx->column; ++ctx->pcolumn; - return 0; + return esc; + + /* save escapade character as a normal character */ + // strbuf_append(&ctx->str, esc); + + // return 0; } diff --git a/src/parse.h b/src/parse.h index 53263b4c..a7e97ec8 100644 --- a/src/parse.h +++ b/src/parse.h @@ -47,7 +47,7 @@ typedef struct { FILE* f; - /* + /* * context stacks used since ICS files form a tree. key_stack is * only for sequrity purposes. */ @@ -68,7 +68,7 @@ typedef struct { * String which we write everything read into. * Later copied to appropiate places. */ - strbuf str; + // strbuf str; } parse_ctx; INIT_F(parse_ctx, FILE* f, char* filename); @@ -117,6 +117,6 @@ int handle_kv( */ int fold(parse_ctx* ctx, char c); -int handle_escape (parse_ctx* ctx); +char handle_escape (parse_ctx* ctx); #endif /* PARSE_H */ diff --git a/src/strbuf.h b/src/strbuf.h index 7f936a9e..0c028eb6 100644 --- a/src/strbuf.h +++ b/src/strbuf.h @@ -15,7 +15,6 @@ */ typedef struct { char* mem; - SCM scm; /* TODO add support for negative ptr */ int ptr; unsigned int alloc; diff --git a/src/struct.c b/src/struct.c new file mode 100644 index 00000000..cd3ee412 --- /dev/null +++ b/src/struct.c @@ -0,0 +1,59 @@ +#include "struct.h" + +#include + +SCM_DEFINE(scm_make_vcomponent, "make-vcomponent", 1, 0, 0, + (SCM type), + "") +{ + SCM str = scm_from_utf8_string("pr" "pw" "pw" "pr"); + SCM vcomponent_vtable = scm_make_vtable(str, SCM_BOOL_F); + return scm_c_make_struct (vcomponent_vtable, scm_from_int(0), + type, SCM_EOL, SCM_BOOL_F, + scm_make_hash_table(SCM_BOOL_F), + SCM_UNDEFINED); +} + + +SCM_DEFINE(scm_add_line_x, "add-line!", 3, 0, 0, + (SCM vcomponent, SCM key, SCM line), + "") +{ + scm_hash_set_x (scm_struct_ref(vcomponent, vcomponent_lines), key, line); + return SCM_UNSPECIFIED; +} + + +SCM_DEFINE(scm_add_child_x, "add-child!", 2, 0, 0, + (SCM vcomponent, SCM child), + "") +{ + scm_struct_set_x (child, vcomponent_parent, vcomponent); + scm_struct_set_x (vcomponent, vcomponent_children, + scm_cons (child, scm_struct_ref (vcomponent, vcomponent_children))); + + return SCM_UNSPECIFIED; +} + + +SCM_DEFINE(scm_make_vline, "make-vline", 0, 0, 0, + (), "") +{ + SCM vline_vtable = + scm_make_vtable(scm_from_utf8_string("pw" "pw"), + SCM_BOOL_F); + return scm_c_make_struct (vline_vtable, scm_from_int(0), + SCM_BOOL_F, scm_make_hash_table(SCM_BOOL_F), + SCM_UNDEFINED); +} + + +SCM_DEFINE(scm_add_attribute_x, "add-attribute!", 3, 0, 0, + (SCM vline, SCM key, SCM value), + "") +{ + SCM table = scm_struct_ref (vline, vline_attributes); + scm_hash_set_x (table, key, + scm_cons(value, scm_hash_ref(table, key, SCM_EOL))); + return SCM_UNSPECIFIED; +} diff --git a/src/struct.h b/src/struct.h new file mode 100644 index 00000000..838d8180 --- /dev/null +++ b/src/struct.h @@ -0,0 +1,23 @@ +#ifndef STRUCT_H +#define STRUCT_H + +#include + +#define vcomponent_type scm_from_uint8(0) +#define vcomponent_children scm_from_uint8(1) +#define vcomponent_parent scm_from_uint8(2) +#define vcomponent_lines scm_from_uint8(3) + +inline SCM scm_component_parent(SCM component) { + return scm_struct_ref (component, vcomponent_parent); } + +#define vline_value scm_from_uint8(0) +#define vline_attributes scm_from_uint8(1) + +SCM scm_make_vcomponent(SCM); +SCM scm_add_line_x (SCM, SCM, SCM); +SCM scm_add_child_x (SCM, SCM); +SCM scm_make_vline (); +SCM scm_add_attribute_x (SCM, SCM, SCM); + +#endif /* STRUCT_H */ diff --git a/src/vcal.c b/src/vcal.c index 74af44be..29177bf3 100644 --- a/src/vcal.c +++ b/src/vcal.c @@ -61,11 +61,11 @@ INIT_F(vcomponent, const char* type, const char* filename) { /* * NOTE * RFC-7986 adds additional parameters linked to this one. - * - `SOURCE' :: where a (possibly) updated version of the data can be - * found + * - `SOURCE' :: where a (possibly) updated version of the + * data can be found * - `URL' :: Where the same data can be fonud, but * differently (but not where the original data can be fonud - * agani). + * again). */ vcomponent_push_val (self, "X-HNH-FILENAME", filename); } -- cgit v1.2.3 From 7539f8c8804849294e100c5442e0397f4f4d2c40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 1 Oct 2019 23:39:00 +0200 Subject: Disabled bunch of old stuff, new stuff kinda builds. --- Makefile | 2 +- module/vcomponent.scm | 6 +- module/vcomponent/base.scm | 24 ++-- module/vcomponent/primitive.scm | 30 +++-- src/calendar.c | 23 ++-- src/calendar.h | 12 +- src/graphs.c | 144 -------------------- src/graphs.c.old | 144 ++++++++++++++++++++ src/graphs.h | 15 --- src/graphs.h.old | 15 +++ src/guile_interface.h | 28 ---- src/guile_interface.h.disabled | 28 ++++ src/guile_interface.scm.c | 261 ------------------------------------- src/guile_interface.scm.c.disabled | 261 +++++++++++++++++++++++++++++++++++++ src/guile_type_helpers.c | 1 - src/main.c | 120 ----------------- src/main.c.old | 120 +++++++++++++++++ src/parse.c | 43 +++--- src/parse.h | 19 +-- src/strbuf.c | 13 -- src/struct.c | 59 --------- src/struct.scm.c | 91 +++++++++++++ src/vcal.c | 175 ------------------------- src/vcal.c.old | 175 +++++++++++++++++++++++++ src/vcal.h | 120 ----------------- src/vcal.h.old | 120 +++++++++++++++++ 26 files changed, 1035 insertions(+), 1014 deletions(-) delete mode 100644 src/graphs.c create mode 100644 src/graphs.c.old delete mode 100644 src/graphs.h create mode 100644 src/graphs.h.old delete mode 100644 src/guile_interface.h create mode 100644 src/guile_interface.h.disabled delete mode 100644 src/guile_interface.scm.c create mode 100644 src/guile_interface.scm.c.disabled delete mode 100644 src/main.c create mode 100644 src/main.c.old delete mode 100644 src/struct.c create mode 100644 src/struct.scm.c delete mode 100644 src/vcal.c create mode 100644 src/vcal.c.old delete mode 100644 src/vcal.h create mode 100644 src/vcal.h.old diff --git a/Makefile b/Makefile index dfd080b8..c8e2fd6f 100644 --- a/Makefile +++ b/Makefile @@ -66,7 +66,7 @@ obj/%.scm.go: %.scm $(SO_FILES) html: $(GO_FILES) mkdir -p html ln -sf ../static html - module/main.scm html -f 2019-07-01 -t 2019-08-30 > html/index.html + module/main.scm html -f 2019-10-01 -t 2019-12-31 > html/index.html tags: $(C_FILES) $(H_FILES) ctags -R diff --git a/module/vcomponent.scm b/module/vcomponent.scm index cc79b646..fc360486 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,5 +1,5 @@ (define-module (vcomponent) - #:use-module ((vcomponent primitive) :select (%vcomponent-make)) + #:use-module ((vcomponent primitive) :select (parse-path make-vcomponent)) #:use-module (vcomponent datetime) #:use-module (vcomponent recurrence) #:use-module (vcomponent timezone) @@ -81,8 +81,8 @@ (define* (make-vcomponent #:optional path) (if (not path) - (%vcomponent-make) - (let* ((root (%vcomponent-make path)) + (make-vcomponent) + (let* ((root (parse-path path)) (component (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) ;; == Single ICS file == diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index fd8628f9..4b49ba66 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -6,11 +6,16 @@ :use-module ((ice-9 optargs) :select (define*-public))) (define (get-attr component attr) + (hash-ref (struct-ref component 3) + (as-string attr)) + #; (%vcomponent-get-attribute component (as-string attr))) (define (set-attr! component attr value) + 'noop + #; (set! (car (get-attr component (as-string attr))) value)) @@ -49,21 +54,24 @@ (hash-map->list cons (cdar attrptr))) (define-public type (make-procedure-with-setter - %vcomponent-get-type - %vcomponent-set-type!)) -(define-public parent %vcomponent-parent) -(define-public push-child! %vcomponent-push-child!) -(define-public (attributes component) (map string->symbol (%vcomponent-attribute-list component))) + (lambda (c) (struct-ref c 0)) + (lambda (c v) struct-set! c 0 v) + )) +(define-public (parent c) (struct-ref c 2)) +(define-public push-child! add-child!) +(define-public (attributes component) '("noop") + #; (map string->symbol (%vcomponent-attribute-list component)) + ) (define*-public (children component #:optional only-type) - (let ((childs (%vcomponent-children component))) + (let ((childs (slot-ref component 1))) (if only-type (filter (lambda (e) (eq? only-type (type e))) childs) childs))) -(define-public copy-vcomponent %vcomponent-shallow-copy) +;; (define-public copy-vcomponent %vcomponent-shallow-copy) -(define-public filter-children! %vcomponent-filter-children!) +;; (define-public filter-children! %vcomponent-filter-children!) (define-public (extract field) (lambda (e) (attr e field))) diff --git a/module/vcomponent/primitive.scm b/module/vcomponent/primitive.scm index ad33a3be..e103feae 100644 --- a/module/vcomponent/primitive.scm +++ b/module/vcomponent/primitive.scm @@ -1,19 +1,23 @@ ;;; Primitive export of symbols linked from C binary. (define-module (vcomponent primitive) - #:export (%vcomponent-children - %vcomponent-push-child! - %vcomponent-filter-children! + #:export #; + (%vcomponent-children ; + %vcomponent-push-child! ; + %vcomponent-filter-children! ; + ; + %vcomponent-parent ; + ; + %vcomponent-make ; + %vcomponent-get-type ; + %vcomponent-set-type! ; + ; + %vcomponent-get-attribute ; + %vcomponent-attribute-list ; + ; + %vcomponent-shallow-copy) - %vcomponent-parent - - %vcomponent-make - %vcomponent-get-type - %vcomponent-set-type! - - %vcomponent-get-attribute - %vcomponent-attribute-list - - %vcomponent-shallow-copy)) + (make-vcomponent add-line! add-child! make-vline add-attribute! parse-path) + ) (load-extension "libguile-calendar" "init_lib") diff --git a/src/calendar.c b/src/calendar.c index e634b166..2cd25f13 100644 --- a/src/calendar.c +++ b/src/calendar.c @@ -8,11 +8,12 @@ /* basename */ #include +#include #include "parse.h" #include "err.h" -int read_vcalendar(vcomponent* cal, char* path) { +int read_vcalendar(SCM cal, char* path) { struct stat statbuf; if (stat (path, &statbuf) != 0) { @@ -38,12 +39,12 @@ int read_vcalendar(vcomponent* cal, char* path) { return 0; } -int handle_file(vcomponent* cal, char* path) { +int handle_file(SCM cal, char* path) { INFO("Parsing a single file"); /* NAME is the `fancy' name of the calendar. */ - vcomponent_push_val(cal, "NAME", basename(path)); - vcomponent_push_val(cal, "X-HNH-SOURCETYPE", "file"); + // vcomponent_push_val(cal, "NAME", basename(path)); + // vcomponent_push_val(cal, "X-HNH-SOURCETYPE", "file"); char* resolved_path = realpath(path, NULL); open_ics (resolved_path, cal); free (resolved_path); @@ -52,7 +53,7 @@ int handle_file(vcomponent* cal, char* path) { } -int handle_dir(vcomponent* cal, char* path) { +int handle_dir(SCM cal, char* path) { INFO("Parsing a directory"); DIR* dir = opendir(path); @@ -66,8 +67,8 @@ int handle_dir(vcomponent* cal, char* path) { /* NAME is the `fancy' name of the calendar. */ - vcomponent_push_val(cal, "NAME", basename(path)); - vcomponent_push_val(cal, "X-HNH-SOURCETYPE", "vdir"); + // vcomponent_push_val(cal, "NAME", basename(path)); + // vcomponent_push_val(cal, "X-HNH-SOURCETYPE", "vdir"); struct dirent* d; while ((d = readdir(dir)) != NULL) { @@ -90,7 +91,8 @@ int handle_dir(vcomponent* cal, char* path) { info_buf[read - 1] = '\0'; fclose(f); - vcomponent_push_val(cal, "COLOR", info_buf); + // TODO + // vcomponent_push_val(cal, "COLOR", info_buf); } else if (strcmp (d->d_name, "displayname") == 0) { f = fopen(resolved_path, "r"); read = getline(&info_buf, &size, f); @@ -104,7 +106,8 @@ int handle_dir(vcomponent* cal, char* path) { * This works since *currently* values are returned in * reverse order */ - vcomponent_push_val(cal, "NAME", info_buf); + // TODO + // vcomponent_push_val(cal, "NAME", info_buf); } else { open_ics (resolved_path, cal); } @@ -149,7 +152,7 @@ int check_ext (const char* path, const char* ext) { return has_ext && strcmp(buf, ext) == 0; } -int open_ics (char* resolved_path, vcomponent* cal) { +int open_ics (char* resolved_path, SCM cal) { if (! check_ext(resolved_path, "ics") ) return 2; FILE* f = fopen(resolved_path, "r"); diff --git a/src/calendar.h b/src/calendar.h index 20b78a9f..3e6941f9 100644 --- a/src/calendar.h +++ b/src/calendar.h @@ -1,7 +1,9 @@ #ifndef CALENDAR_H #define CALENDAR_H -#include "vcal.h" +#include + +// #include "vcal.h" /* * Reads all ics flies in path into the given vcomponent. The @@ -11,7 +13,7 @@ * path should either be a single .ics file (vcalendar), or a * directory directly containing .ics files (vdir). */ -int read_vcalendar(vcomponent* cal, char* path); +int read_vcalendar(SCM cal, char* path); /* * Gets extension from filename. Writes output to ext. @@ -27,15 +29,15 @@ int get_extension(const char* filename, char* ext, ssize_t max_len); int check_ext (const char* path, const char* ext); /* Handle a lone ics file */ -int handle_file(vcomponent* cal, char* path); +int handle_file(SCM cal, char* path); /* Handle a directory of ics files */ -int handle_dir(vcomponent* cal, char* path); +int handle_dir(SCM cal, char* path); /* * Helper for opening a single ICS file. Handles file internally, and * writes output to cal. */ -int open_ics (char* resolved_path, vcomponent* cal); +int open_ics (char* resolved_path, SCM cal); #endif /* CALENDAR_H */ diff --git a/src/graphs.c b/src/graphs.c deleted file mode 100644 index 51a26117..00000000 --- a/src/graphs.c +++ /dev/null @@ -1,144 +0,0 @@ -#include "graphs.h" - -#include -#include -#include -#include "err.h" - -// #define TYPE strbuf -// #include "linked_list.h" -// #include "linked_list.inc.h" -// #undef TYPE - -int create_graph_trie (vcomponent* ev, char* filename) { - FILE* f = fopen(filename, "w"); - - fputs("digraph {\n rankdir=LR;", f); - trie_to_dot(&ev->clines, f); - fputs("}", f); - - fclose(f); - - INFO_F("Wrote '%s' to '%s'", vcomponent_get_val(ev, "X-HNH-FILENAME"), filename); - - return 0; -} - -int helper_vcomponent (vcomponent* root, FILE* f) { - fprintf(f, "subgraph \"cluster_root\" { label=File; \"%p\" [label=%s] }\n", root, root->type); - - TRIE(content_line)* trie = &root->clines; - TRIE_NODE(content_line)* n = trie->root->child; - - if (! EMPTY(TRIE(content_line))(trie)) { - fprintf(f, "subgraph \"cluster_%p\" {\n", root); - fprintf(f, "\"%p\" [label=trie fontcolor=gray, color=gray];", trie); - fprintf(f, "\"%p\" -> \"%p\" [color=red]\n", root, trie); - while (n != NULL) { - fprintf(f, "\"%p\" -> \"%p\" [color=gray]\n", - (void*) trie, - (void*) n); - fprintf(f, "subgraph \"cluster_%c_%p\" {\ncolor=red; \n", - n->c, root); - trie_to_dot_helper( n, f ); - - - fputs("}", f); - n = n->next; - } - fputs("}", f); - } - - FOR(LLIST, vcomponent, child, &root->components) { - fprintf(f, "\"%p\" -> \"%p\"\n", root, child); - helper_vcomponent(child, f); - } - return 0; -} - -int create_graph_vcomponent (vcomponent* root, char* outfile) { - FILE* f = fopen(outfile, "w"); - if (f == NULL) { - ERR_F("Error opening file %s, errno = %i", outfile, errno); - return 1; - } - vcomponent* c = root; - fputs("digraph {", f); - helper_vcomponent(c, f); - fputs("}", f); - fclose(f); - return 0; -} - -#define T content_line - -int trie_to_dot ( TRIE(T)* trie, FILE* f ) { - TRIE_NODE(T)* n = trie->root->child; - fprintf(f, "\"%p\" [label=root fontcolor=gray, color=gray];", trie); - while (n != NULL) { - fprintf(f, "\"%p\" -> \"%p\" [color=gray]\n", - (void*) trie, - (void*) n); - fprintf(f, "subgraph \"cluster_%c\" {\n", - n->c); - trie_to_dot_helper( n, f ); - fputs("}", f); - n = n->next; - } - return 0; -} - -int trie_to_dot_helper ( TRIE_NODE(T)* root, FILE* f ) { - if (L(root) == NULL) { - fprintf(f, "\"%p\"[label = \"%c\" style=filled fillcolor=white];\n", - (void*) root, root->c); - } else { - fprintf(f, "\"%p\"[label = \"%c [%i]\" style=filled fillcolor=green];\n", - (void*) root, root->c, - SIZE(LLIST(content_set))(L(root)) - ); - } - TRIE_NODE(T)* child = root->child; - - // ---------------------------------------- -#if 1 /* Toggle values */ - if (L(root) != NULL) { - - FOR(LLIST, content_set, v, L(root)) { - char buf[0x100]; - FMT(strbuf)(&v->key, buf); - fprintf(f, "\"%p\" [label=\"%s\" shape=rectangle color=darkgreen];\n", - v, buf); - /* Edge between TRIE char node and data node */ - fprintf(f, "\"%p\" -> \"%p\";\n", root, v); - - /* Parameters */ - LLIST(strbuf)* keys = KEYS(TRIE(param_set))(&v->val); - FOR(LLIST, strbuf, key, keys) { - param_set* p = GET(TRIE(param_set))(&v->val, key->mem); - - fprintf(f, "\"%p\" [label=\"%s\" color=blue];\n", - key, key->mem); - /* Edge between data node and param key node */ - fprintf(f, "\"%p\" -> \"%p\";", v, key); - - FOR(LLIST, strbuf, str, p) { - fprintf(f, "\"%p\" [label=\"%s\" color=orange];", - str, str->mem); - /* Edge between param key node and param value node */ - fprintf(f, "\"%p\" -> \"%p\";", key, str); - } - } - } - } -#endif - // ---------------------------------------- - - while (child != NULL) { - fprintf(f, "\"%p\" -> \"%p\";\n", - (void*) root, (void*) child); - trie_to_dot_helper(child, f); - child = child->next; - } - return 0; -} diff --git a/src/graphs.c.old b/src/graphs.c.old new file mode 100644 index 00000000..51a26117 --- /dev/null +++ b/src/graphs.c.old @@ -0,0 +1,144 @@ +#include "graphs.h" + +#include +#include +#include +#include "err.h" + +// #define TYPE strbuf +// #include "linked_list.h" +// #include "linked_list.inc.h" +// #undef TYPE + +int create_graph_trie (vcomponent* ev, char* filename) { + FILE* f = fopen(filename, "w"); + + fputs("digraph {\n rankdir=LR;", f); + trie_to_dot(&ev->clines, f); + fputs("}", f); + + fclose(f); + + INFO_F("Wrote '%s' to '%s'", vcomponent_get_val(ev, "X-HNH-FILENAME"), filename); + + return 0; +} + +int helper_vcomponent (vcomponent* root, FILE* f) { + fprintf(f, "subgraph \"cluster_root\" { label=File; \"%p\" [label=%s] }\n", root, root->type); + + TRIE(content_line)* trie = &root->clines; + TRIE_NODE(content_line)* n = trie->root->child; + + if (! EMPTY(TRIE(content_line))(trie)) { + fprintf(f, "subgraph \"cluster_%p\" {\n", root); + fprintf(f, "\"%p\" [label=trie fontcolor=gray, color=gray];", trie); + fprintf(f, "\"%p\" -> \"%p\" [color=red]\n", root, trie); + while (n != NULL) { + fprintf(f, "\"%p\" -> \"%p\" [color=gray]\n", + (void*) trie, + (void*) n); + fprintf(f, "subgraph \"cluster_%c_%p\" {\ncolor=red; \n", + n->c, root); + trie_to_dot_helper( n, f ); + + + fputs("}", f); + n = n->next; + } + fputs("}", f); + } + + FOR(LLIST, vcomponent, child, &root->components) { + fprintf(f, "\"%p\" -> \"%p\"\n", root, child); + helper_vcomponent(child, f); + } + return 0; +} + +int create_graph_vcomponent (vcomponent* root, char* outfile) { + FILE* f = fopen(outfile, "w"); + if (f == NULL) { + ERR_F("Error opening file %s, errno = %i", outfile, errno); + return 1; + } + vcomponent* c = root; + fputs("digraph {", f); + helper_vcomponent(c, f); + fputs("}", f); + fclose(f); + return 0; +} + +#define T content_line + +int trie_to_dot ( TRIE(T)* trie, FILE* f ) { + TRIE_NODE(T)* n = trie->root->child; + fprintf(f, "\"%p\" [label=root fontcolor=gray, color=gray];", trie); + while (n != NULL) { + fprintf(f, "\"%p\" -> \"%p\" [color=gray]\n", + (void*) trie, + (void*) n); + fprintf(f, "subgraph \"cluster_%c\" {\n", + n->c); + trie_to_dot_helper( n, f ); + fputs("}", f); + n = n->next; + } + return 0; +} + +int trie_to_dot_helper ( TRIE_NODE(T)* root, FILE* f ) { + if (L(root) == NULL) { + fprintf(f, "\"%p\"[label = \"%c\" style=filled fillcolor=white];\n", + (void*) root, root->c); + } else { + fprintf(f, "\"%p\"[label = \"%c [%i]\" style=filled fillcolor=green];\n", + (void*) root, root->c, + SIZE(LLIST(content_set))(L(root)) + ); + } + TRIE_NODE(T)* child = root->child; + + // ---------------------------------------- +#if 1 /* Toggle values */ + if (L(root) != NULL) { + + FOR(LLIST, content_set, v, L(root)) { + char buf[0x100]; + FMT(strbuf)(&v->key, buf); + fprintf(f, "\"%p\" [label=\"%s\" shape=rectangle color=darkgreen];\n", + v, buf); + /* Edge between TRIE char node and data node */ + fprintf(f, "\"%p\" -> \"%p\";\n", root, v); + + /* Parameters */ + LLIST(strbuf)* keys = KEYS(TRIE(param_set))(&v->val); + FOR(LLIST, strbuf, key, keys) { + param_set* p = GET(TRIE(param_set))(&v->val, key->mem); + + fprintf(f, "\"%p\" [label=\"%s\" color=blue];\n", + key, key->mem); + /* Edge between data node and param key node */ + fprintf(f, "\"%p\" -> \"%p\";", v, key); + + FOR(LLIST, strbuf, str, p) { + fprintf(f, "\"%p\" [label=\"%s\" color=orange];", + str, str->mem); + /* Edge between param key node and param value node */ + fprintf(f, "\"%p\" -> \"%p\";", key, str); + } + } + } + } +#endif + // ---------------------------------------- + + while (child != NULL) { + fprintf(f, "\"%p\" -> \"%p\";\n", + (void*) root, (void*) child); + trie_to_dot_helper(child, f); + child = child->next; + } + return 0; +} diff --git a/src/graphs.h b/src/graphs.h deleted file mode 100644 index fe521003..00000000 --- a/src/graphs.h +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef GRAPHS_H -#define GRAPHS_H - -#include "vcal.h" - -int create_graph_trie (vcomponent* ev, char* filename); - -int create_graph_vcomponent (vcomponent* root, char* outfile); - -int helper_vcomponent (vcomponent* root, FILE* f); - -int trie_to_dot ( TRIE(content_line)*, FILE* ); -int trie_to_dot_helper ( TRIE_NODE(content_line)*, FILE* ); - -#endif /* GRAPHS_H */ diff --git a/src/graphs.h.old b/src/graphs.h.old new file mode 100644 index 00000000..fe521003 --- /dev/null +++ b/src/graphs.h.old @@ -0,0 +1,15 @@ +#ifndef GRAPHS_H +#define GRAPHS_H + +#include "vcal.h" + +int create_graph_trie (vcomponent* ev, char* filename); + +int create_graph_vcomponent (vcomponent* root, char* outfile); + +int helper_vcomponent (vcomponent* root, FILE* f); + +int trie_to_dot ( TRIE(content_line)*, FILE* ); +int trie_to_dot_helper ( TRIE_NODE(content_line)*, FILE* ); + +#endif /* GRAPHS_H */ diff --git a/src/guile_interface.h b/src/guile_interface.h deleted file mode 100644 index 76ec24d3..00000000 --- a/src/guile_interface.h +++ /dev/null @@ -1,28 +0,0 @@ -#ifndef GUILE_INTERFACE_H -#define GUILE_INTERFACE_H - -#include -#include "vcal.h" - -/* - * At a number of places scm_gc_{un,}protect_object is called. - * This is needed since most of my structures are allocated with the - * regular malloc, instead of the scm_gc_malloc variants. - * This leads to the garbage collector not realizing that I still have - * the components, and deletes them. - * - * The protection markers stop the GC from doing its thing. - */ - -void init_lib (void); -void init_vcomponent_type (void); - -SCM make_vcomponent (SCM); -SCM vcomponent_get_attribute (SCM, SCM); -SCM vcomponent_child_count (SCM); -SCM vcomponent_children (SCM); -SCM vcomponent_typeof (SCM); - -SCM scm_from_vcomponent (vcomponent*); - -#endif /* GUILE_INTERFACE_H */ diff --git a/src/guile_interface.h.disabled b/src/guile_interface.h.disabled new file mode 100644 index 00000000..76ec24d3 --- /dev/null +++ b/src/guile_interface.h.disabled @@ -0,0 +1,28 @@ +#ifndef GUILE_INTERFACE_H +#define GUILE_INTERFACE_H + +#include +#include "vcal.h" + +/* + * At a number of places scm_gc_{un,}protect_object is called. + * This is needed since most of my structures are allocated with the + * regular malloc, instead of the scm_gc_malloc variants. + * This leads to the garbage collector not realizing that I still have + * the components, and deletes them. + * + * The protection markers stop the GC from doing its thing. + */ + +void init_lib (void); +void init_vcomponent_type (void); + +SCM make_vcomponent (SCM); +SCM vcomponent_get_attribute (SCM, SCM); +SCM vcomponent_child_count (SCM); +SCM vcomponent_children (SCM); +SCM vcomponent_typeof (SCM); + +SCM scm_from_vcomponent (vcomponent*); + +#endif /* GUILE_INTERFACE_H */ diff --git a/src/guile_interface.scm.c b/src/guile_interface.scm.c deleted file mode 100644 index 20c413df..00000000 --- a/src/guile_interface.scm.c +++ /dev/null @@ -1,261 +0,0 @@ -#include "guile_interface.h" - -#include "calendar.h" -#include "guile_type_helpers.h" - -static SCM vcomponent_type; -static SCM content_set_lists; - -void init_vcomponent_type (void) { - SCM name = scm_from_utf8_symbol("vcomponent"); - SCM slots = scm_list_1(scm_from_utf8_symbol("data")); - - vcomponent_type = scm_make_foreign_object_type(name, slots, NULL); -} - -SCM_DEFINE (make_vcomponent, "%vcomponent-make", 0, 1, 0, - (SCM path), - "Loads a vdir iCalendar from the given path.") -{ - vcomponent* cal = - (vcomponent*) scm_gc_malloc ( - sizeof(*cal), "vcomponent"); - - if (SCM_UNBNDP(path)) { - INIT(vcomponent, cal); - } else { - INIT(vcomponent, cal, "ROOT"); - - char* p = scm_to_utf8_stringn(path, NULL); - read_vcalendar(cal, p); - free(p); - } - - return scm_from_vcomponent (cal); -} - -/* - * Returns a line from a component. - */ -SCM_DEFINE (vcomponent_get_attribute, "%vcomponent-get-attribute", 2, 0, 0, - (SCM calendar, SCM attr), - "Retuns the given attribute from the vevent object at index in calendar.") -{ - scm_assert_foreign_object_type (vcomponent_type, calendar); - vcomponent* cal = scm_foreign_object_ref (calendar, 0); - - const char* key = scm_i_string_chars (attr); - content_line* c = get_attributes (cal, key); - - if (c == NULL) { - vcomponent_push_val(cal, key, ""); - c = get_attributes (cal, key); - c->cval->key.scm = SCM_BOOL_F; - } - - SCM ptr = scm_from_pointer(c, NULL); - SCM ret = scm_hashq_ref (content_set_lists, ptr, SCM_BOOL_F); - if (! scm_is_false (ret)) { - return ret; - } - - SCM val, proplist; - SCM attrroot = scm_list_1(SCM_BOOL_F); - SCM attrlist = attrroot; - LLIST(strbuf) *triekeys, *trievals; - - /* For every instance of a line */ - FOR (LLIST, content_set, v, c) { - val = scm_from_strbuf(&v->key); - - if (! scm_is_pair(val)) { - // TODO look into using a weak hash table instead - - // TODO why is it an error to unprotect the object here? - // scm_from_strbuf should already have protected it... - // scm_gc_unprotect_object(v->key.scm); - SCM htable = scm_make_hash_table (scm_from_ulong(32)); - val = scm_cons(val, htable); - v->key.scm = val; - scm_gc_protect_object(v->key.scm); - - triekeys = KEYS(TRIE(param_set))(&v->val); - /* For every property key bound to the current attribute */ - FOR (LLIST, strbuf, k, triekeys) { - proplist = SCM_EOL; - - trievals = GET(TRIE(param_set))(&v->val, k->mem); - /* For every value bound to the current property */ - FOR (LLIST, strbuf, s, trievals) { - proplist = scm_cons(scm_from_strbuf(s), proplist); - } - - scm_hashq_set_x(htable, scm_from_strbuf_symbol(k), - scm_reverse(proplist)); - } - } - - attrlist = scm_cons(val, attrlist); - } - - /* create circular list */ - scm_set_cdr_x (attrroot, attrlist); - - - scm_hashq_set_x (content_set_lists, ptr, attrlist); - - return attrlist; -} - -SCM_DEFINE (vcomponent_child_count, "%vcomponent-child-count", 1, 0, 0, - (SCM component), - "Returns number of child components.") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* c = scm_foreign_object_ref (component, 0); - return scm_from_size_t (SIZE(LLIST(vcomponent))(&c->components)); -} - -SCM_DEFINE(vcomponent_children, "%vcomponent-children", 1, 0, 0, - (SCM component), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* cal = scm_foreign_object_ref (component, 0); - - SCM llist = SCM_EOL; - FOR (LLIST, vcomponent, v, &cal->components) { - llist = scm_cons(scm_from_vcomponent(v), llist); - } - return llist; -} - -SCM_DEFINE(vcomponent_filter_children_x, "%vcomponent-filter-children!", - 2, 0, 0, - (SCM pred, SCM component), - "Remove all children from component who DOESN'T satisfy `pred`") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* cal = scm_foreign_object_ref (component, 0); - - for (LINK(vcomponent)* l = FIRST(&cal->components); - l->after != NULL; - l = l->after) - { - if (scm_is_false(scm_call_1 (pred, scm_from_vcomponent(l->value)))) { - FFREE(vcomponent, l->value); - UNLINK(LINK(vcomponent))(l); - } - } - - return SCM_UNSPECIFIED; -} - -SCM_DEFINE(vcomponent_push_child_x, "%vcomponent-push-child!", 2, 0, 0, - (SCM component, SCM child), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - scm_assert_foreign_object_type (vcomponent_type, child); - vcomponent* comp = scm_foreign_object_ref (component, 0); - vcomponent* chil = scm_foreign_object_ref (child, 0); - - PUSH(vcomponent)(comp, chil); - - return SCM_UNSPECIFIED; -} - -SCM_DEFINE (vcomponent_parent, "%vcomponent-parent", 1, 0, 0, - (SCM component), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - - vcomponent* parent = comp->parent; - if (strcmp(parent->type, "ROOT") == 0) { - return SCM_BOOL_F; - } else { - return scm_from_vcomponent(parent); - } -} - -SCM_DEFINE(vcomponent_typeof, "%vcomponent-get-type", 1, 0, 0, - (SCM component), - "Returns type of vcomponent") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - - if (comp->scmtype == NULL) { - comp->scmtype = scm_from_utf8_symbol(comp->type); - } - - return comp->scmtype; -} - -SCM_DEFINE(vcomponent_set_type_x, "%vcomponent-set-type!", 2, 0, 0, - (SCM component, SCM type), - "Replace current type of vcomponent") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - - if (comp->type) free (comp->type); - - char* ntype = scm_to_utf8_stringn (type, NULL); - comp->type = calloc(sizeof(*ntype), strlen(ntype) + 1); - strcpy(comp->type, ntype); - - return SCM_UNSPECIFIED; -} - -SCM scm_from_vcomponent(vcomponent* v) { - if (v->scm == NULL) { - v->scm = scm_make_foreign_object_1 (vcomponent_type, v); - scm_gc_protect_object(v->scm); - } - return v->scm; -} - -SCM_DEFINE(vcomponent_attr_list, "%vcomponent-attribute-list", 1, 0, 0, - (SCM component), - "Returns list of all keys in component.") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - LLIST(strbuf)* keys = KEYS(TRIE(content_line))(&comp->clines); - - SCM llist = SCM_EOL; - FOR (LLIST, strbuf, s, keys) { - llist = scm_cons(scm_from_strbuf(s), llist); - } - - FFREE(LLIST(strbuf), keys); - - return llist; -} - -SCM_DEFINE(vcomponent_shallow_copy, "%vcomponent-shallow-copy", 1, 0, 0, - (SCM component), - "Creates a shallow copy of the given component.") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* src = scm_foreign_object_ref (component, 0); - - vcomponent* dest = - (vcomponent*) scm_gc_malloc ( - sizeof(*dest), "vcomponent"); - INIT(vcomponent, dest, src->type, NULL); - vcomponent_copy (dest, src); - return scm_from_vcomponent (dest); -} - -void init_lib (void) { - init_vcomponent_type(); - content_set_lists = scm_make_weak_key_hash_table (scm_from_uint(0x100)); - -#ifndef SCM_MAGIC_SNARFER -#include "guile_interface.x" -#endif -} diff --git a/src/guile_interface.scm.c.disabled b/src/guile_interface.scm.c.disabled new file mode 100644 index 00000000..20c413df --- /dev/null +++ b/src/guile_interface.scm.c.disabled @@ -0,0 +1,261 @@ +#include "guile_interface.h" + +#include "calendar.h" +#include "guile_type_helpers.h" + +static SCM vcomponent_type; +static SCM content_set_lists; + +void init_vcomponent_type (void) { + SCM name = scm_from_utf8_symbol("vcomponent"); + SCM slots = scm_list_1(scm_from_utf8_symbol("data")); + + vcomponent_type = scm_make_foreign_object_type(name, slots, NULL); +} + +SCM_DEFINE (make_vcomponent, "%vcomponent-make", 0, 1, 0, + (SCM path), + "Loads a vdir iCalendar from the given path.") +{ + vcomponent* cal = + (vcomponent*) scm_gc_malloc ( + sizeof(*cal), "vcomponent"); + + if (SCM_UNBNDP(path)) { + INIT(vcomponent, cal); + } else { + INIT(vcomponent, cal, "ROOT"); + + char* p = scm_to_utf8_stringn(path, NULL); + read_vcalendar(cal, p); + free(p); + } + + return scm_from_vcomponent (cal); +} + +/* + * Returns a line from a component. + */ +SCM_DEFINE (vcomponent_get_attribute, "%vcomponent-get-attribute", 2, 0, 0, + (SCM calendar, SCM attr), + "Retuns the given attribute from the vevent object at index in calendar.") +{ + scm_assert_foreign_object_type (vcomponent_type, calendar); + vcomponent* cal = scm_foreign_object_ref (calendar, 0); + + const char* key = scm_i_string_chars (attr); + content_line* c = get_attributes (cal, key); + + if (c == NULL) { + vcomponent_push_val(cal, key, ""); + c = get_attributes (cal, key); + c->cval->key.scm = SCM_BOOL_F; + } + + SCM ptr = scm_from_pointer(c, NULL); + SCM ret = scm_hashq_ref (content_set_lists, ptr, SCM_BOOL_F); + if (! scm_is_false (ret)) { + return ret; + } + + SCM val, proplist; + SCM attrroot = scm_list_1(SCM_BOOL_F); + SCM attrlist = attrroot; + LLIST(strbuf) *triekeys, *trievals; + + /* For every instance of a line */ + FOR (LLIST, content_set, v, c) { + val = scm_from_strbuf(&v->key); + + if (! scm_is_pair(val)) { + // TODO look into using a weak hash table instead + + // TODO why is it an error to unprotect the object here? + // scm_from_strbuf should already have protected it... + // scm_gc_unprotect_object(v->key.scm); + SCM htable = scm_make_hash_table (scm_from_ulong(32)); + val = scm_cons(val, htable); + v->key.scm = val; + scm_gc_protect_object(v->key.scm); + + triekeys = KEYS(TRIE(param_set))(&v->val); + /* For every property key bound to the current attribute */ + FOR (LLIST, strbuf, k, triekeys) { + proplist = SCM_EOL; + + trievals = GET(TRIE(param_set))(&v->val, k->mem); + /* For every value bound to the current property */ + FOR (LLIST, strbuf, s, trievals) { + proplist = scm_cons(scm_from_strbuf(s), proplist); + } + + scm_hashq_set_x(htable, scm_from_strbuf_symbol(k), + scm_reverse(proplist)); + } + } + + attrlist = scm_cons(val, attrlist); + } + + /* create circular list */ + scm_set_cdr_x (attrroot, attrlist); + + + scm_hashq_set_x (content_set_lists, ptr, attrlist); + + return attrlist; +} + +SCM_DEFINE (vcomponent_child_count, "%vcomponent-child-count", 1, 0, 0, + (SCM component), + "Returns number of child components.") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* c = scm_foreign_object_ref (component, 0); + return scm_from_size_t (SIZE(LLIST(vcomponent))(&c->components)); +} + +SCM_DEFINE(vcomponent_children, "%vcomponent-children", 1, 0, 0, + (SCM component), + "") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* cal = scm_foreign_object_ref (component, 0); + + SCM llist = SCM_EOL; + FOR (LLIST, vcomponent, v, &cal->components) { + llist = scm_cons(scm_from_vcomponent(v), llist); + } + return llist; +} + +SCM_DEFINE(vcomponent_filter_children_x, "%vcomponent-filter-children!", + 2, 0, 0, + (SCM pred, SCM component), + "Remove all children from component who DOESN'T satisfy `pred`") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* cal = scm_foreign_object_ref (component, 0); + + for (LINK(vcomponent)* l = FIRST(&cal->components); + l->after != NULL; + l = l->after) + { + if (scm_is_false(scm_call_1 (pred, scm_from_vcomponent(l->value)))) { + FFREE(vcomponent, l->value); + UNLINK(LINK(vcomponent))(l); + } + } + + return SCM_UNSPECIFIED; +} + +SCM_DEFINE(vcomponent_push_child_x, "%vcomponent-push-child!", 2, 0, 0, + (SCM component, SCM child), + "") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + scm_assert_foreign_object_type (vcomponent_type, child); + vcomponent* comp = scm_foreign_object_ref (component, 0); + vcomponent* chil = scm_foreign_object_ref (child, 0); + + PUSH(vcomponent)(comp, chil); + + return SCM_UNSPECIFIED; +} + +SCM_DEFINE (vcomponent_parent, "%vcomponent-parent", 1, 0, 0, + (SCM component), + "") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* comp = scm_foreign_object_ref (component, 0); + + vcomponent* parent = comp->parent; + if (strcmp(parent->type, "ROOT") == 0) { + return SCM_BOOL_F; + } else { + return scm_from_vcomponent(parent); + } +} + +SCM_DEFINE(vcomponent_typeof, "%vcomponent-get-type", 1, 0, 0, + (SCM component), + "Returns type of vcomponent") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* comp = scm_foreign_object_ref (component, 0); + + if (comp->scmtype == NULL) { + comp->scmtype = scm_from_utf8_symbol(comp->type); + } + + return comp->scmtype; +} + +SCM_DEFINE(vcomponent_set_type_x, "%vcomponent-set-type!", 2, 0, 0, + (SCM component, SCM type), + "Replace current type of vcomponent") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* comp = scm_foreign_object_ref (component, 0); + + if (comp->type) free (comp->type); + + char* ntype = scm_to_utf8_stringn (type, NULL); + comp->type = calloc(sizeof(*ntype), strlen(ntype) + 1); + strcpy(comp->type, ntype); + + return SCM_UNSPECIFIED; +} + +SCM scm_from_vcomponent(vcomponent* v) { + if (v->scm == NULL) { + v->scm = scm_make_foreign_object_1 (vcomponent_type, v); + scm_gc_protect_object(v->scm); + } + return v->scm; +} + +SCM_DEFINE(vcomponent_attr_list, "%vcomponent-attribute-list", 1, 0, 0, + (SCM component), + "Returns list of all keys in component.") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* comp = scm_foreign_object_ref (component, 0); + LLIST(strbuf)* keys = KEYS(TRIE(content_line))(&comp->clines); + + SCM llist = SCM_EOL; + FOR (LLIST, strbuf, s, keys) { + llist = scm_cons(scm_from_strbuf(s), llist); + } + + FFREE(LLIST(strbuf), keys); + + return llist; +} + +SCM_DEFINE(vcomponent_shallow_copy, "%vcomponent-shallow-copy", 1, 0, 0, + (SCM component), + "Creates a shallow copy of the given component.") +{ + scm_assert_foreign_object_type (vcomponent_type, component); + vcomponent* src = scm_foreign_object_ref (component, 0); + + vcomponent* dest = + (vcomponent*) scm_gc_malloc ( + sizeof(*dest), "vcomponent"); + INIT(vcomponent, dest, src->type, NULL); + vcomponent_copy (dest, src); + return scm_from_vcomponent (dest); +} + +void init_lib (void) { + init_vcomponent_type(); + content_set_lists = scm_make_weak_key_hash_table (scm_from_uint(0x100)); + +#ifndef SCM_MAGIC_SNARFER +#include "guile_interface.x" +#endif +} diff --git a/src/guile_type_helpers.c b/src/guile_type_helpers.c index f03ac671..072ddff9 100644 --- a/src/guile_type_helpers.c +++ b/src/guile_type_helpers.c @@ -1,5 +1,4 @@ #include "guile_type_helpers.h" -#include "guile_interface.h" #include "macro.h" diff --git a/src/main.c b/src/main.c deleted file mode 100644 index 4d8da7d3..00000000 --- a/src/main.c +++ /dev/null @@ -1,120 +0,0 @@ -#include -#include -#include -#include - -#include "calendar.h" -#include "macro.h" -#include "vcal.h" -#include "graphs.h" -#include "err.h" - -typedef struct { - int argc; - char** argv; -} arg; - -int arg_shift (arg* a) { - if (a->argc == 0) return 0; - - ++a->argv; - return --a->argc; - -} - -#define GETSET(C, KEY) \ - vcomponent_push_val((C), (KEY), "DUMMY VALUE"); \ - INFO_F("cline = %p", get_attributes((C), (KEY))); - -/* - * Tests defined here instead of in own header to ensure that all the - * correct modules are loaded. - */ -int run_tests() { - NEW(vcomponent, c); - INFO(All the following should print a valid pointer != 0x0); - GETSET(c, "FILENAME"); - GETSET(c, "X-HNH-FILENAME"); - GETSET(c, "DATA"); - GETSET(c, "DAT"); - GETSET(c, "DA"); - GETSET(c, "D"); - GETSET(c, "A"); - GETSET(c, "F"); - FFREE(vcomponent, c); - return 0; -} - -int main (int argc, char** argv) { - arg args = { .argc = argc, .argv = argv }; - - - if (arg_shift(&args) == 0) { - ERR("Please give something to parse, or some other flags"); - exit (1); - } - - if (strcmp(args.argv[0], "--run-tests") == 0) { - run_tests(); - return 0; - } - - char* rootpath = args.argv[0]; - SNEW(vcomponent, root, "ROOT", rootpath); - read_vcalendar(&root, rootpath); - - arg_shift(&args); - - if (args.argc == 0 || strcmp(args.argv[0], "-p") == 0) { - INFO_F("Parsed calendar file containing [%u] events", - root.components.length); - - puts("CAL : OBJ | Filename | Description"); - puts("----------+----------+------------"); - - /* This loops over all VCALENDAR's in root */ - FOR (LLIST, vcomponent, cal, &root.components) { - assert(strcmp(cal->type, "VCALENDAR") == 0); - - char* filename = vcomponent_get_val(cal, "X-HNH-FILENAME"); - - /* This loop over all VEVENT's in the current VCALENDAR */ - FOR (LLIST, vcomponent, ev, &cal->components) { - if (strcmp(ev->type, "VEVENT") != 0) continue; - - printf("%s | %s\n", - filename, - get_attributes(ev, "SUMMARY")->cval->key.mem); - } - } - } else if (strcmp(args.argv[0], "-g") == 0) { - /* TODO self might be broken */ - if (arg_shift(&args) == 0) { - FOR (LLIST, vcomponent, cal, &root.components) { - assert(strcmp(cal->type, "VCALENDAR") == 0); - - vcomponent* ev = FCHILD(cal); - - char target[0xFF]; - target[0] = '\0'; - strcat(target, "/tmp/dot/"); - strcat(target, vcomponent_get_val(ev, "X-HNH-FILENAME")); - strcat(target, ".dot"); - // create_graph(ev, target); - } - } else { - // create_graph(FCHILD(FCHILD(&root)), args.argv[0]); - INFO("Creating graph for single file"); - INFO_F("output = %s\n", args.argv[0]); - create_graph_vcomponent(&root, args.argv[0]); - } - } - - /* - char buf[0x20000]; - FMT(vcomponent)(&root, buf); - puts(buf); - */ - - FREE(vcomponent)(&root); -} diff --git a/src/main.c.old b/src/main.c.old new file mode 100644 index 00000000..4d8da7d3 --- /dev/null +++ b/src/main.c.old @@ -0,0 +1,120 @@ +#include +#include +#include +#include + +#include "calendar.h" +#include "macro.h" +#include "vcal.h" +#include "graphs.h" +#include "err.h" + +typedef struct { + int argc; + char** argv; +} arg; + +int arg_shift (arg* a) { + if (a->argc == 0) return 0; + + ++a->argv; + return --a->argc; + +} + +#define GETSET(C, KEY) \ + vcomponent_push_val((C), (KEY), "DUMMY VALUE"); \ + INFO_F("cline = %p", get_attributes((C), (KEY))); + +/* + * Tests defined here instead of in own header to ensure that all the + * correct modules are loaded. + */ +int run_tests() { + NEW(vcomponent, c); + INFO(All the following should print a valid pointer != 0x0); + GETSET(c, "FILENAME"); + GETSET(c, "X-HNH-FILENAME"); + GETSET(c, "DATA"); + GETSET(c, "DAT"); + GETSET(c, "DA"); + GETSET(c, "D"); + GETSET(c, "A"); + GETSET(c, "F"); + FFREE(vcomponent, c); + return 0; +} + +int main (int argc, char** argv) { + arg args = { .argc = argc, .argv = argv }; + + + if (arg_shift(&args) == 0) { + ERR("Please give something to parse, or some other flags"); + exit (1); + } + + if (strcmp(args.argv[0], "--run-tests") == 0) { + run_tests(); + return 0; + } + + char* rootpath = args.argv[0]; + SNEW(vcomponent, root, "ROOT", rootpath); + read_vcalendar(&root, rootpath); + + arg_shift(&args); + + if (args.argc == 0 || strcmp(args.argv[0], "-p") == 0) { + INFO_F("Parsed calendar file containing [%u] events", + root.components.length); + + puts("CAL : OBJ | Filename | Description"); + puts("----------+----------+------------"); + + /* This loops over all VCALENDAR's in root */ + FOR (LLIST, vcomponent, cal, &root.components) { + assert(strcmp(cal->type, "VCALENDAR") == 0); + + char* filename = vcomponent_get_val(cal, "X-HNH-FILENAME"); + + /* This loop over all VEVENT's in the current VCALENDAR */ + FOR (LLIST, vcomponent, ev, &cal->components) { + if (strcmp(ev->type, "VEVENT") != 0) continue; + + printf("%s | %s\n", + filename, + get_attributes(ev, "SUMMARY")->cval->key.mem); + } + } + } else if (strcmp(args.argv[0], "-g") == 0) { + /* TODO self might be broken */ + if (arg_shift(&args) == 0) { + FOR (LLIST, vcomponent, cal, &root.components) { + assert(strcmp(cal->type, "VCALENDAR") == 0); + + vcomponent* ev = FCHILD(cal); + + char target[0xFF]; + target[0] = '\0'; + strcat(target, "/tmp/dot/"); + strcat(target, vcomponent_get_val(ev, "X-HNH-FILENAME")); + strcat(target, ".dot"); + // create_graph(ev, target); + } + } else { + // create_graph(FCHILD(FCHILD(&root)), args.argv[0]); + INFO("Creating graph for single file"); + INFO_F("output = %s\n", args.argv[0]); + create_graph_vcomponent(&root, args.argv[0]); + } + } + + /* + char buf[0x20000]; + FMT(vcomponent)(&root, buf); + puts(buf); + */ + + FREE(vcomponent)(&root); +} diff --git a/src/parse.c b/src/parse.c index e79231cb..46f9644e 100644 --- a/src/parse.c +++ b/src/parse.c @@ -5,7 +5,7 @@ #include #include "macro.h" -#include "vcal.h" +// #include "vcal.h" #include "err.h" @@ -17,12 +17,12 @@ // #include "linked_list.inc.h" // #undef TYPE -#define T strbuf -#define V strbuf -#include "pair.h" -#include "pair.inc.h" -#undef T -#undef V +// #define T strbuf +// #define V strbuf +// #include "pair.h" +// #include "pair.inc.h" +// #undef T +// #undef V /* +-------------------------------------------------------+ @@ -47,14 +47,12 @@ /* * name *(";" param) ":" value CRLF */ -int parse_file(char* filename, FILE* f, vcomponent* root) { - scm_c_use_module ("(vcomponent struct)"); - +int parse_file(char* filename, FILE* f, SCM root) { part_context p_ctx = p_key; SNEW(parse_ctx, ctx, f, filename); - PUSH(LLIST(vcomponent))(&ctx.comp_stack, root); + // PUSH(LLIST(vcomponent))(&ctx.comp_stack, root); /* * Create a content_line which we use as storage while we are @@ -70,11 +68,10 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { // SNEW(strbuf, attr_val); SNEW(strbuf, str); - SCM component; /* TODO init to root */ + SCM component = root; SCM line = scm_make_vline(); SCM attr_key; /* string */ - SCM line_key; /* string */ - SCM param_set; /* hashtable */ + SCM line_key = scm_from_utf8_string(""); /* string */ char c; while ( (c = fgetc(f)) != EOF) { @@ -103,7 +100,7 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { * component. */ } else { - scm_set_value_x(line, scm_from_strbuf(&str)); + scm_struct_set_x(line, vline_value, scm_from_strbuf(&str)); scm_add_line_x(component, line_key, line); line = scm_make_vline(); } @@ -140,7 +137,7 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { * the current parameter set. */ if (p_ctx == p_param_value) { /* save current parameter value. */ - scm_add_attribute_x(line, line_key, scm_from_strbuf(&str)); + scm_add_attribute_x(line, attr_key, scm_from_strbuf(&str)); strbuf_soft_reset (&str); } @@ -198,9 +195,9 @@ int parse_file(char* filename, FILE* f, vcomponent* root) { FREE(strbuf)(&str); - assert(POP(LLIST(vcomponent))(&ctx.comp_stack) == root); - assert(EMPTY(LLIST(strbuf))(&ctx.key_stack)); - assert(EMPTY(LLIST(vcomponent))(&ctx.comp_stack)); + // assert(POP(LLIST(vcomponent))(&ctx.comp_stack) == root); + // assert(EMPTY(LLIST(strbuf))(&ctx.key_stack)); + // assert(EMPTY(LLIST(vcomponent))(&ctx.comp_stack)); FREE(parse_ctx)(&ctx); @@ -242,8 +239,8 @@ int fold(parse_ctx* ctx, char c) { INIT_F(parse_ctx, FILE* f, char* filename) { - INIT(LLIST(strbuf), &self->key_stack); - INIT(LLIST(vcomponent), &self->comp_stack); + // INIT(LLIST(strbuf), &self->key_stack); + // INIT(LLIST(vcomponent), &self->comp_stack); self->filename = (char*) calloc(sizeof(*filename), strlen(filename) + 1); strcpy(self->filename, filename); self->f = f; @@ -261,8 +258,8 @@ INIT_F(parse_ctx, FILE* f, char* filename) { FREE_F(parse_ctx) { - FREE(LLIST(strbuf))(&self->key_stack); - FREE(LLIST(vcomponent))(&self->comp_stack); + // FREE(LLIST(strbuf))(&self->key_stack); + // FREE(LLIST(vcomponent))(&self->comp_stack); free(self->filename); self->line = 0; diff --git a/src/parse.h b/src/parse.h index a7e97ec8..a5169dd7 100644 --- a/src/parse.h +++ b/src/parse.h @@ -5,7 +5,7 @@ #include #include "strbuf.h" -#include "vcal.h" +// #include "vcal.h" // #define TYPE vcomponent // #include "linked_list.h" @@ -51,8 +51,8 @@ typedef struct { * context stacks used since ICS files form a tree. key_stack is * only for sequrity purposes. */ - LLIST(strbuf) key_stack; - LLIST(vcomponent) comp_stack; + // LLIST(strbuf) key_stack; + // LLIST(vcomponent) comp_stack; /* Number for unfolded lines * TODO remove this @@ -82,18 +82,7 @@ FREE_F(parse_ctx); * Once It has parsed a full line it calls handel_kv. Which build my * actuall datastructure. */ -int parse_file(char* filename, FILE* f, vcomponent* cal); - -/* - * Called whenever parse_file finishes a line. Copies the contents of - * ctx and the current content_line into the object stack, stored in - * ctx. - */ -int handle_kv( - strbuf* key, - content_line* cline, - parse_ctx* ctx - ); +int parse_file(char* filename, FILE* f, SCM cal); /* * Input diff --git a/src/strbuf.c b/src/strbuf.c index 66fe2989..1e1365d5 100644 --- a/src/strbuf.c +++ b/src/strbuf.c @@ -10,7 +10,6 @@ INIT_F(strbuf) { self->mem = (char*) calloc(sizeof(*self->mem), self->alloc); self->ptr = 0; self->len = 0; - self->scm = NULL; return 0; } @@ -69,18 +68,6 @@ int DEEP_COPY(strbuf)(strbuf* dest, strbuf* src) { retval = 1; } - if (src->scm != NULL) { - /* - * Upon Vcomponent binding into scheme I place all - * strings inside cons cells. This leads to a deep - * copy being required. copy-tree however returns - * the same object for atoms and scheme strings. - */ - dest->scm = scm_copy_tree(src->scm); - /* NOTE This is a bit of a leaky abstraction. */ - scm_gc_protect_object(dest->scm); - } - dest->len = src->len; memcpy(dest->mem, src->mem, src->len); return retval; diff --git a/src/struct.c b/src/struct.c deleted file mode 100644 index cd3ee412..00000000 --- a/src/struct.c +++ /dev/null @@ -1,59 +0,0 @@ -#include "struct.h" - -#include - -SCM_DEFINE(scm_make_vcomponent, "make-vcomponent", 1, 0, 0, - (SCM type), - "") -{ - SCM str = scm_from_utf8_string("pr" "pw" "pw" "pr"); - SCM vcomponent_vtable = scm_make_vtable(str, SCM_BOOL_F); - return scm_c_make_struct (vcomponent_vtable, scm_from_int(0), - type, SCM_EOL, SCM_BOOL_F, - scm_make_hash_table(SCM_BOOL_F), - SCM_UNDEFINED); -} - - -SCM_DEFINE(scm_add_line_x, "add-line!", 3, 0, 0, - (SCM vcomponent, SCM key, SCM line), - "") -{ - scm_hash_set_x (scm_struct_ref(vcomponent, vcomponent_lines), key, line); - return SCM_UNSPECIFIED; -} - - -SCM_DEFINE(scm_add_child_x, "add-child!", 2, 0, 0, - (SCM vcomponent, SCM child), - "") -{ - scm_struct_set_x (child, vcomponent_parent, vcomponent); - scm_struct_set_x (vcomponent, vcomponent_children, - scm_cons (child, scm_struct_ref (vcomponent, vcomponent_children))); - - return SCM_UNSPECIFIED; -} - - -SCM_DEFINE(scm_make_vline, "make-vline", 0, 0, 0, - (), "") -{ - SCM vline_vtable = - scm_make_vtable(scm_from_utf8_string("pw" "pw"), - SCM_BOOL_F); - return scm_c_make_struct (vline_vtable, scm_from_int(0), - SCM_BOOL_F, scm_make_hash_table(SCM_BOOL_F), - SCM_UNDEFINED); -} - - -SCM_DEFINE(scm_add_attribute_x, "add-attribute!", 3, 0, 0, - (SCM vline, SCM key, SCM value), - "") -{ - SCM table = scm_struct_ref (vline, vline_attributes); - scm_hash_set_x (table, key, - scm_cons(value, scm_hash_ref(table, key, SCM_EOL))); - return SCM_UNSPECIFIED; -} diff --git a/src/struct.scm.c b/src/struct.scm.c new file mode 100644 index 00000000..abbbba18 --- /dev/null +++ b/src/struct.scm.c @@ -0,0 +1,91 @@ +#include "struct.h" + +#include + +SCM vcomponent_vtable; +SCM vline_vtable; + +SCM_DEFINE(scm_make_vcomponent, "make-vcomponent", 0, 1, 0, + (SCM type), + "") +{ + + if (SCM_UNBNDP (type)) type = SCM_BOOL_F; + + if (scm_is_false(type)) type = scm_from_utf8_symbol("VIRTUAL"); + + return scm_c_make_struct (vcomponent_vtable, scm_from_int(0), + type, SCM_EOL, SCM_BOOL_F, + scm_make_hash_table(SCM_BOOL_F), + SCM_UNDEFINED); +} + + + +SCM_DEFINE(scm_parse_cal_path, "parse-path", 1, 0, 0, + (SCM path), + "") +{ + SCM root = scm_make_vcomponent(SCM_BOOL_F); + + char* p = scm_to_utf8_stringn(path, NULL); + scm_read_vcalendar(root, p); + free(p); +} + +SCM_DEFINE(scm_add_line_x, "add-line!", 3, 0, 0, + (SCM vcomponent, SCM key, SCM line), + "") +{ + scm_hash_set_x (scm_struct_ref(vcomponent, vcomponent_lines), key, line); + return SCM_UNSPECIFIED; +} + + +SCM_DEFINE(scm_add_child_x, "add-child!", 2, 0, 0, + (SCM vcomponent, SCM child), + "") +{ + scm_struct_set_x (child, vcomponent_parent, vcomponent); + scm_struct_set_x (vcomponent, vcomponent_children, + scm_cons (child, scm_struct_ref (vcomponent, vcomponent_children))); + + return SCM_UNSPECIFIED; +} + + +SCM_DEFINE(scm_make_vline, "make-vline", 0, 0, 0, + (), "") +{ + return scm_c_make_struct (vline_vtable, scm_from_int(0), + SCM_BOOL_F, scm_make_hash_table(SCM_BOOL_F), + SCM_UNDEFINED); +} + + +SCM_DEFINE(scm_add_attribute_x, "add-attribute!", 3, 0, 0, + (SCM vline, SCM key, SCM value), + "") +{ + SCM table = scm_struct_ref (vline, vline_attributes); + scm_hash_set_x (table, key, + scm_cons(value, scm_hash_ref(table, key, SCM_EOL))); + return SCM_UNSPECIFIED; +} + +void init_lib (void) { + // init_vcomponent_type(); + // content_set_lists = scm_make_weak_key_hash_table (scm_from_uint(0x100)); + SCM str = scm_from_utf8_string("pr" "pw" "pw" "pr"); + SCM vcomponent_vtable = scm_make_vtable(str, SCM_BOOL_F); + scm_set_struct_vtable_name_x (vcomponent_vtable, scm_from_utf8_symbol("vcomponent")); + + SCM vline_vtable = + scm_make_vtable(scm_from_utf8_string("pw" "pw"), + SCM_BOOL_F); + scm_set_struct_vtable_name_x (vline_vtable, scm_from_utf8_symbol("vline")); + +#ifndef SCM_MAGIC_SNARFER +#include "struct.x" +#endif +} diff --git a/src/vcal.c b/src/vcal.c deleted file mode 100644 index 29177bf3..00000000 --- a/src/vcal.c +++ /dev/null @@ -1,175 +0,0 @@ -#include "vcal.h" - -#include - -#define TYPE strbuf -#include "linked_list.inc.h" -#undef TYPE - -#define TYPE param_set -#include "trie.inc.h" -#undef TYPE - -#define TYPE content_set -#include "linked_list.inc.h" -#undef TYPE - -#define T strbuf - #define V TRIE(param_set) - #include "pair.inc.h" - #undef V -#undef T - -#define TYPE content_line -// #include "hash.inc" -#include "trie.inc.h" -#undef TYPE - -#define TYPE vcomponent -// #include "vector.inc.h" -#include "linked_list.inc.h" -#undef TYPE - -INIT_F(vcomponent) { - INIT(TRIE(content_line), &self->clines); - INIT(LLIST(vcomponent), &self->components); - - // vcomponent_push_val (self, "X-HNH-FILENAME", "VIRTUAL"); - vcomponent_push_val (self, "X-HNH-SOURCETYPE", "virtual"); - char* type = "VIRTUAL"; - self->type = (char*) calloc(sizeof(*type), strlen(type) + 1); - strcpy(self->type, type); - - self->parent = NULL; - self->scm = NULL; - self->scmtype = NULL; - - return 0; - -} - -INIT_F(vcomponent, const char* type) { - return INIT(vcomponent, self, type, NULL); -} - -INIT_F(vcomponent, const char* type, const char* filename) { - - INIT(TRIE(content_line), &self->clines); - INIT(LLIST(vcomponent), &self->components); - - if (filename != NULL) { - /* - * NOTE - * RFC-7986 adds additional parameters linked to this one. - * - `SOURCE' :: where a (possibly) updated version of the - * data can be found - * - `URL' :: Where the same data can be fonud, but - * differently (but not where the original data can be fonud - * again). - */ - vcomponent_push_val (self, "X-HNH-FILENAME", filename); - } - - self->type = (char*) calloc(sizeof(*type), strlen(type) + 1); - strcpy(self->type, type); - - self->parent = NULL; - self->scm = NULL; - self->scmtype = NULL; - - return 0; -} - -content_line* get_attributes (vcomponent* ev, const char* key) { - size_t len = strlen(key) + 1; - char* cpy = (char*) (calloc(sizeof(*cpy), len)); - strncpy (cpy, key, len); - - content_line* ret = GET(TRIE(content_line))(&ev->clines, cpy); - - free (cpy); - return ret; -} - -FREE_F(vcomponent) { - free(self->type); - - if (FREE(TRIE(content_line))(&self->clines) != 0) { - ERR("Error freeing vcomponent"); - } - - FREE(LLIST(vcomponent))(&self->components); - - return 0; -} - -int PUSH(vcomponent)(vcomponent* parent, vcomponent* child) { - child->parent = parent; - return PUSH(LLIST(vcomponent))(&parent->components, child); -} - -int DEEP_COPY(vcomponent)(vcomponent* a, vcomponent* b) { - (void) a; - (void) b; - ERR("Deep copy not implemented for vcomponent"); - return -1; -} - -int vcomponent_copy(vcomponent* dest, vcomponent* src) { - - DEEP_COPY(TRIE(content_line))(&dest->clines, &src->clines); - - /* Children are the same objects */ - FOR(LLIST, vcomponent, c, &src->components) { - PUSH(LLIST(vcomponent))(&dest->components, c); - } - - dest->parent = src->parent; - // PUSH(vcomponent)(src->parent, dest); - - return 0; -} - -FMT_F(vcomponent) { - int seek = 0; - - for (int i = 0; i < 40; i++) fmtf("_"); - - seek += sprintf(buf + seek, _YELLOW); - seek += sprintf(buf + seek, "\nVComponet (Type := %s)\n", self->type); - seek += sprintf(buf + seek, _RESET); - seek += FMT(TRIE(content_line))(&self->clines, buf + seek); - seek += sprintf(buf + seek, "\nComponents:\n"); - FOR(LLIST, vcomponent, comp, &self->components) { - seek += FMT(vcomponent)(comp, buf + seek); - } - - return seek; -} - -int vcomponent_push_val (vcomponent* comp, const char* key, const char* val) { - NEW(content_line, cl); - NEW(content_set, cs); - strbuf_load(&cs->key, val); - PUSH(content_line)(cl, cs); - - char* key_cpy = calloc(sizeof(*key_cpy), strlen(key) + 1); - strcpy (key_cpy, key); - PUSH(TRIE(content_line))(&comp->clines, key_cpy, cl); - free (key_cpy); - - return 0; -} - -char* vcomponent_get_val (vcomponent* comp, const char* key) { - char* key_cpy = calloc(sizeof(*key_cpy), strlen(key) + 1); - strcpy (key_cpy, key); - content_line* cl = GET(TRIE(content_line))(&comp->clines, key_cpy); - free (key_cpy); - - if (cl != NULL && cl->cval != NULL) { - return cl->cval->key.mem; - } - - return NULL; -} diff --git a/src/vcal.c.old b/src/vcal.c.old new file mode 100644 index 00000000..29177bf3 --- /dev/null +++ b/src/vcal.c.old @@ -0,0 +1,175 @@ +#include "vcal.h" + +#include + +#define TYPE strbuf +#include "linked_list.inc.h" +#undef TYPE + +#define TYPE param_set +#include "trie.inc.h" +#undef TYPE + +#define TYPE content_set +#include "linked_list.inc.h" +#undef TYPE + +#define T strbuf + #define V TRIE(param_set) + #include "pair.inc.h" + #undef V +#undef T + +#define TYPE content_line +// #include "hash.inc" +#include "trie.inc.h" +#undef TYPE + +#define TYPE vcomponent +// #include "vector.inc.h" +#include "linked_list.inc.h" +#undef TYPE + +INIT_F(vcomponent) { + INIT(TRIE(content_line), &self->clines); + INIT(LLIST(vcomponent), &self->components); + + // vcomponent_push_val (self, "X-HNH-FILENAME", "VIRTUAL"); + vcomponent_push_val (self, "X-HNH-SOURCETYPE", "virtual"); + char* type = "VIRTUAL"; + self->type = (char*) calloc(sizeof(*type), strlen(type) + 1); + strcpy(self->type, type); + + self->parent = NULL; + self->scm = NULL; + self->scmtype = NULL; + + return 0; + +} + +INIT_F(vcomponent, const char* type) { + return INIT(vcomponent, self, type, NULL); +} + +INIT_F(vcomponent, const char* type, const char* filename) { + + INIT(TRIE(content_line), &self->clines); + INIT(LLIST(vcomponent), &self->components); + + if (filename != NULL) { + /* + * NOTE + * RFC-7986 adds additional parameters linked to this one. + * - `SOURCE' :: where a (possibly) updated version of the + * data can be found + * - `URL' :: Where the same data can be fonud, but + * differently (but not where the original data can be fonud + * again). + */ + vcomponent_push_val (self, "X-HNH-FILENAME", filename); + } + + self->type = (char*) calloc(sizeof(*type), strlen(type) + 1); + strcpy(self->type, type); + + self->parent = NULL; + self->scm = NULL; + self->scmtype = NULL; + + return 0; +} + +content_line* get_attributes (vcomponent* ev, const char* key) { + size_t len = strlen(key) + 1; + char* cpy = (char*) (calloc(sizeof(*cpy), len)); + strncpy (cpy, key, len); + + content_line* ret = GET(TRIE(content_line))(&ev->clines, cpy); + + free (cpy); + return ret; +} + +FREE_F(vcomponent) { + free(self->type); + + if (FREE(TRIE(content_line))(&self->clines) != 0) { + ERR("Error freeing vcomponent"); + } + + FREE(LLIST(vcomponent))(&self->components); + + return 0; +} + +int PUSH(vcomponent)(vcomponent* parent, vcomponent* child) { + child->parent = parent; + return PUSH(LLIST(vcomponent))(&parent->components, child); +} + +int DEEP_COPY(vcomponent)(vcomponent* a, vcomponent* b) { + (void) a; + (void) b; + ERR("Deep copy not implemented for vcomponent"); + return -1; +} + +int vcomponent_copy(vcomponent* dest, vcomponent* src) { + + DEEP_COPY(TRIE(content_line))(&dest->clines, &src->clines); + + /* Children are the same objects */ + FOR(LLIST, vcomponent, c, &src->components) { + PUSH(LLIST(vcomponent))(&dest->components, c); + } + + dest->parent = src->parent; + // PUSH(vcomponent)(src->parent, dest); + + return 0; +} + +FMT_F(vcomponent) { + int seek = 0; + + for (int i = 0; i < 40; i++) fmtf("_"); + + seek += sprintf(buf + seek, _YELLOW); + seek += sprintf(buf + seek, "\nVComponet (Type := %s)\n", self->type); + seek += sprintf(buf + seek, _RESET); + seek += FMT(TRIE(content_line))(&self->clines, buf + seek); + seek += sprintf(buf + seek, "\nComponents:\n"); + FOR(LLIST, vcomponent, comp, &self->components) { + seek += FMT(vcomponent)(comp, buf + seek); + } + + return seek; +} + +int vcomponent_push_val (vcomponent* comp, const char* key, const char* val) { + NEW(content_line, cl); + NEW(content_set, cs); + strbuf_load(&cs->key, val); + PUSH(content_line)(cl, cs); + + char* key_cpy = calloc(sizeof(*key_cpy), strlen(key) + 1); + strcpy (key_cpy, key); + PUSH(TRIE(content_line))(&comp->clines, key_cpy, cl); + free (key_cpy); + + return 0; +} + +char* vcomponent_get_val (vcomponent* comp, const char* key) { + char* key_cpy = calloc(sizeof(*key_cpy), strlen(key) + 1); + strcpy (key_cpy, key); + content_line* cl = GET(TRIE(content_line))(&comp->clines, key_cpy); + free (key_cpy); + + if (cl != NULL && cl->cval != NULL) { + return cl->cval->key.mem; + } + + return NULL; +} diff --git a/src/vcal.h b/src/vcal.h deleted file mode 100644 index 2a3ad294..00000000 --- a/src/vcal.h +++ /dev/null @@ -1,120 +0,0 @@ -#ifndef VCAL_H -#define VCAL_H - -#include - -#include - -#include "strbuf.h" - -#define TYPE strbuf -#include "linked_list.h" -// #include "trie.h" -#undef TYPE - -/* - * content_line: - * (a mapping) between a top level key, and everything it contains. - * content_set: - * A top level value, along with a list of kv pairs for all its - * possible parameters. - * param_set: - * A parameter key, along with a list of all its values. - */ - -#define param_set LLIST(strbuf) - -#define TYPE param_set -#include "trie.h" -#undef TYPE - -#define T strbuf - #define V TRIE(param_set) - #include "pair.h" - /* left := content | right := params */ - #define content_set PAIR(strbuf, TRIE(param_set)) - #undef V -#undef T - -#define TYPE content_set -#include "linked_list.h" -#undef TYPE - -#define content_line LLIST(content_set) - -/* - * Helper macros for accessing fields in - * content_line, content_set, and param_set - */ - -/* content_set */ -#define CLINE_CUR(c) ((c)->cval) - -/* strbuf */ -#define CLINE_CUR_VAL(c) (& CLINE_CUR(c)->key) - -/* TRIE(param_set) */ -#define CLINE_CUR_PARAMS(c) (& CLINE_CUR(c)->val) - -#define TYPE content_line -#include "trie.h" -#undef TYPE - -typedef struct s_vcomponent vcomponent; - -#define TYPE vcomponent -// #include "vector.h" -#include "linked_list.h" -#undef TYPE - -struct s_vcomponent { - /* VCALENDAR, VEVENT, ... */ - char* type; - vcomponent* parent; - TRIE(content_line) clines; - LLIST(vcomponent) components; - - /* - * Holds a Guile representation of this object. Used to always - * return the same foreign (for guile) object for the same - * vcomponent. - */ - SCM scm; - SCM scmtype; -}; - -#define FCHILD(v) FIRST_V(&(v)->components) - -INIT_F(vcomponent); -INIT_F(vcomponent, const char* type); -INIT_F(vcomponent, const char* type, const char* filename); -FREE_F(vcomponent); - -content_line* get_attributes (vcomponent* ev, const char* key); - -int add_content_line (vcomponent* ev, content_line* c); - -int vcomponent_push_val (vcomponent*, const char* key, const char* val); -char* vcomponent_get_val (vcomponent*, const char* key); - -/* - * Appends ev to cal. Doesn't copy ev. So make sure that it wont go - * out of scope. - */ -int PUSH(vcomponent)(vcomponent*, vcomponent*); - -/* - * Deep copy is currently not implemented for vcomponentes. - * The reason for this method being here is since some - * generic methods in other places complain otherwise. - */ -int DEEP_COPY(vcomponent)(vcomponent*, vcomponent*); - -/* - * "Shallow" copy of vcomponent. - */ -int vcomponent_copy(vcomponent*, vcomponent*); - -FMT_F(vcomponent); - -#endif /* VCAL_H */ diff --git a/src/vcal.h.old b/src/vcal.h.old new file mode 100644 index 00000000..2a3ad294 --- /dev/null +++ b/src/vcal.h.old @@ -0,0 +1,120 @@ +#ifndef VCAL_H +#define VCAL_H + +#include + +#include + +#include "strbuf.h" + +#define TYPE strbuf +#include "linked_list.h" +// #include "trie.h" +#undef TYPE + +/* + * content_line: + * (a mapping) between a top level key, and everything it contains. + * content_set: + * A top level value, along with a list of kv pairs for all its + * possible parameters. + * param_set: + * A parameter key, along with a list of all its values. + */ + +#define param_set LLIST(strbuf) + +#define TYPE param_set +#include "trie.h" +#undef TYPE + +#define T strbuf + #define V TRIE(param_set) + #include "pair.h" + /* left := content | right := params */ + #define content_set PAIR(strbuf, TRIE(param_set)) + #undef V +#undef T + +#define TYPE content_set +#include "linked_list.h" +#undef TYPE + +#define content_line LLIST(content_set) + +/* + * Helper macros for accessing fields in + * content_line, content_set, and param_set + */ + +/* content_set */ +#define CLINE_CUR(c) ((c)->cval) + +/* strbuf */ +#define CLINE_CUR_VAL(c) (& CLINE_CUR(c)->key) + +/* TRIE(param_set) */ +#define CLINE_CUR_PARAMS(c) (& CLINE_CUR(c)->val) + +#define TYPE content_line +#include "trie.h" +#undef TYPE + +typedef struct s_vcomponent vcomponent; + +#define TYPE vcomponent +// #include "vector.h" +#include "linked_list.h" +#undef TYPE + +struct s_vcomponent { + /* VCALENDAR, VEVENT, ... */ + char* type; + vcomponent* parent; + TRIE(content_line) clines; + LLIST(vcomponent) components; + + /* + * Holds a Guile representation of this object. Used to always + * return the same foreign (for guile) object for the same + * vcomponent. + */ + SCM scm; + SCM scmtype; +}; + +#define FCHILD(v) FIRST_V(&(v)->components) + +INIT_F(vcomponent); +INIT_F(vcomponent, const char* type); +INIT_F(vcomponent, const char* type, const char* filename); +FREE_F(vcomponent); + +content_line* get_attributes (vcomponent* ev, const char* key); + +int add_content_line (vcomponent* ev, content_line* c); + +int vcomponent_push_val (vcomponent*, const char* key, const char* val); +char* vcomponent_get_val (vcomponent*, const char* key); + +/* + * Appends ev to cal. Doesn't copy ev. So make sure that it wont go + * out of scope. + */ +int PUSH(vcomponent)(vcomponent*, vcomponent*); + +/* + * Deep copy is currently not implemented for vcomponentes. + * The reason for this method being here is since some + * generic methods in other places complain otherwise. + */ +int DEEP_COPY(vcomponent)(vcomponent*, vcomponent*); + +/* + * "Shallow" copy of vcomponent. + */ +int vcomponent_copy(vcomponent*, vcomponent*); + +FMT_F(vcomponent); + +#endif /* VCAL_H */ -- cgit v1.2.3 From 1c3bd94c328df0c8b4293bc42a25b2d7c851fd0c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 2 Oct 2019 23:05:01 +0200 Subject: Made parser work again (for single files). --- Makefile | 2 +- module/vcomponent.scm | 4 ++-- module/vcomponent/primitive.scm | 2 +- src/parse.c | 19 +++++++++++++++---- src/struct.h | 4 ++-- src/struct.scm.c | 40 +++++++++++++++++++++++++--------------- 6 files changed, 46 insertions(+), 25 deletions(-) diff --git a/Makefile b/Makefile index c8e2fd6f..6f25d5c5 100644 --- a/Makefile +++ b/Makefile @@ -52,7 +52,7 @@ lib/%.so: $(O_FILES) @mkdir -p lib $(CC) -shared -o $@ $^ $(LDFLAGS) -obj/%.scm.go: %.scm $(SO_FILES) +obj/%.scm.go: %.scm # $(SO_FILES) @mkdir -p obj guild compile $(GUILE_C_FLAGS) -o $@ $< diff --git a/module/vcomponent.scm b/module/vcomponent.scm index fc360486..a106d993 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,5 +1,5 @@ (define-module (vcomponent) - #:use-module ((vcomponent primitive) :select (parse-path make-vcomponent)) + #:use-module ((vcomponent primitive) :select (parse-cal-path make-vcomponent)) #:use-module (vcomponent datetime) #:use-module (vcomponent recurrence) #:use-module (vcomponent timezone) @@ -82,7 +82,7 @@ (define* (make-vcomponent #:optional path) (if (not path) (make-vcomponent) - (let* ((root (parse-path path)) + (let* ((root (parse-cal-path path)) (component (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) ;; == Single ICS file == diff --git a/module/vcomponent/primitive.scm b/module/vcomponent/primitive.scm index e103feae..2cf12508 100644 --- a/module/vcomponent/primitive.scm +++ b/module/vcomponent/primitive.scm @@ -17,7 +17,7 @@ ; %vcomponent-shallow-copy) - (make-vcomponent add-line! add-child! make-vline add-attribute! parse-path) + (make-vcomponent add-line! add-child! make-vline add-attribute! parse-cal-path) ) (load-extension "libguile-calendar" "init_lib") diff --git a/src/parse.c b/src/parse.c index 46f9644e..0e243234 100644 --- a/src/parse.c +++ b/src/parse.c @@ -42,7 +42,7 @@ */ -#define string_eq(a, b) scm_string_eq(a, b, SCM_BOOL_F,SCM_BOOL_F,SCM_BOOL_F,SCM_BOOL_F) +#define string_eq(a, b) scm_is_true(scm_string_eq(a, b, SCM_UNDEFINED,SCM_UNDEFINED,SCM_UNDEFINED,SCM_UNDEFINED)) /* * name *(";" param) ":" value CRLF @@ -73,11 +73,15 @@ int parse_file(char* filename, FILE* f, SCM root) { SCM attr_key; /* string */ SCM line_key = scm_from_utf8_string(""); /* string */ + INFO("Starting parsing"); char c; + INFO("here"); while ( (c = fgetc(f)) != EOF) { + INFO_F("LOOP %c", c); /* We have a linebreak */ if (c == '\r' || c == '\n') { + INFO("EOL"); if (fold(&ctx, c) > 0) { /* Actuall end of line, handle value */ @@ -87,12 +91,14 @@ int parse_file(char* filename, FILE* f, SCM root) { */ if (string_eq(line_key, scm_from_utf8_string("BEGIN"))) { /* key \in { VCALENDAR, VEVENT, VALARM, VTODO, VTIMEZONE, ... } */ - SCM child = scm_make_vcomponent(scm_from_strbuf(&str)); + INFO("Creating child"); + SCM child = scm_make_vcomponent(scm_string_to_symbol(scm_from_strbuf(&str))); scm_add_child_x (component, child); component = child; } else if (string_eq(line_key, scm_from_utf8_string("END"))) { // TODO make current component be parent of current component? + INFO("back to parent"); component = scm_component_parent(component); /* @@ -100,6 +106,7 @@ int parse_file(char* filename, FILE* f, SCM root) { * component. */ } else { + INFO("Adding attribute"); scm_struct_set_x(line, vline_value, scm_from_strbuf(&str)); scm_add_line_x(component, line_key, line); line = scm_make_vline(); @@ -120,6 +127,7 @@ int parse_file(char* filename, FILE* f, SCM root) { /* Save the current parameter key */ // TODO // TRANSFER (¶m_key, &ctx.str); + INFO("Param key"); attr_key = scm_from_strbuf(&str); p_ctx = p_param_value; strbuf_soft_reset (&str); @@ -136,6 +144,7 @@ int parse_file(char* filename, FILE* f, SCM root) { /* We got a parameter value, push the current string to * the current parameter set. */ if (p_ctx == p_param_value) { + INFO("param value"); /* save current parameter value. */ scm_add_attribute_x(line, attr_key, scm_from_strbuf(&str)); strbuf_soft_reset (&str); @@ -149,11 +158,13 @@ int parse_file(char* filename, FILE* f, SCM root) { */ if (p_ctx == p_key) { + INFO("key"); // TRANSFER(&cline_key, &ctx.str); // NEW(content_set, p); // PUSH(LLIST(content_set))(&cline, p); - attr_key = scm_from_strbuf(&str); + // attr_key + line_key = scm_from_strbuf(&str); strbuf_soft_reset (&str); } @@ -173,7 +184,7 @@ int parse_file(char* filename, FILE* f, SCM root) { } if (! feof(f)) { - ERR("Error parsing"); + ERR_F("Error parsing errno = %i", errno); } /* Check to see if empty line */ else if (str.ptr != 0) { diff --git a/src/struct.h b/src/struct.h index 838d8180..d39cf471 100644 --- a/src/struct.h +++ b/src/struct.h @@ -8,8 +8,8 @@ #define vcomponent_parent scm_from_uint8(2) #define vcomponent_lines scm_from_uint8(3) -inline SCM scm_component_parent(SCM component) { - return scm_struct_ref (component, vcomponent_parent); } +#define scm_component_parent(component) \ + scm_struct_ref (component, vcomponent_parent) #define vline_value scm_from_uint8(0) #define vline_attributes scm_from_uint8(1) diff --git a/src/struct.scm.c b/src/struct.scm.c index abbbba18..b5aa09c1 100644 --- a/src/struct.scm.c +++ b/src/struct.scm.c @@ -2,6 +2,8 @@ #include +#include "parse.h" + SCM vcomponent_vtable; SCM vline_vtable; @@ -10,27 +12,35 @@ SCM_DEFINE(scm_make_vcomponent, "make-vcomponent", 0, 1, 0, "") { - if (SCM_UNBNDP (type)) type = SCM_BOOL_F; - - if (scm_is_false(type)) type = scm_from_utf8_symbol("VIRTUAL"); + if (SCM_UNBNDP (type)) + type = scm_from_utf8_symbol("VIRTUAL"); - return scm_c_make_struct (vcomponent_vtable, scm_from_int(0), - type, SCM_EOL, SCM_BOOL_F, - scm_make_hash_table(SCM_BOOL_F), - SCM_UNDEFINED); + /* This segfaults */ + return scm_make_struct_no_tail + (vcomponent_vtable, + scm_list_4(type, SCM_EOL, SCM_BOOL_F, + scm_make_hash_table(scm_from_int(0x10)))); } -SCM_DEFINE(scm_parse_cal_path, "parse-path", 1, 0, 0, +SCM_DEFINE(scm_parse_cal_path, "parse-cal-path", 1, 0, 0, (SCM path), "") { - SCM root = scm_make_vcomponent(SCM_BOOL_F); + SCM root = scm_make_vcomponent(SCM_UNSPECIFIED); char* p = scm_to_utf8_stringn(path, NULL); - scm_read_vcalendar(root, p); + // scm_read_vcalendar(root, p); + /* TODO check that path is good? */ + printf("Parsing [%s]\n", p); + FILE* f = fopen(p, "r"); + printf("FILE = %p\n", f); + parse_file (p, f, root); + /* TODO free file */ free(p); + + return root; } SCM_DEFINE(scm_add_line_x, "add-line!", 3, 0, 0, @@ -57,9 +67,9 @@ SCM_DEFINE(scm_add_child_x, "add-child!", 2, 0, 0, SCM_DEFINE(scm_make_vline, "make-vline", 0, 0, 0, (), "") { - return scm_c_make_struct (vline_vtable, scm_from_int(0), - SCM_BOOL_F, scm_make_hash_table(SCM_BOOL_F), - SCM_UNDEFINED); + return scm_make_struct_no_tail + (vline_vtable, + scm_list_2(SCM_BOOL_F, scm_make_hash_table(scm_from_int(0x10)))); } @@ -77,10 +87,10 @@ void init_lib (void) { // init_vcomponent_type(); // content_set_lists = scm_make_weak_key_hash_table (scm_from_uint(0x100)); SCM str = scm_from_utf8_string("pr" "pw" "pw" "pr"); - SCM vcomponent_vtable = scm_make_vtable(str, SCM_BOOL_F); + vcomponent_vtable = scm_make_vtable(str, SCM_BOOL_F); scm_set_struct_vtable_name_x (vcomponent_vtable, scm_from_utf8_symbol("vcomponent")); - SCM vline_vtable = + vline_vtable = scm_make_vtable(scm_from_utf8_string("pw" "pw"), SCM_BOOL_F); scm_set_struct_vtable_name_x (vline_vtable, scm_from_utf8_symbol("vline")); -- cgit v1.2.3 From e940c6e74114830fb41c061035b5a160e0c3b6ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 2 Oct 2019 23:11:56 +0200 Subject: Restore directory parsing. --- src/parse.c | 20 ++++++++++---------- src/struct.scm.c | 12 +++--------- 2 files changed, 13 insertions(+), 19 deletions(-) diff --git a/src/parse.c b/src/parse.c index 0e243234..dd8066ed 100644 --- a/src/parse.c +++ b/src/parse.c @@ -73,15 +73,15 @@ int parse_file(char* filename, FILE* f, SCM root) { SCM attr_key; /* string */ SCM line_key = scm_from_utf8_string(""); /* string */ - INFO("Starting parsing"); + INFO_F("Parsing [%s]", filename); + char c; - INFO("here"); while ( (c = fgetc(f)) != EOF) { - INFO_F("LOOP %c", c); + // INFO_F("LOOP %c", c); /* We have a linebreak */ if (c == '\r' || c == '\n') { - INFO("EOL"); + // INFO("EOL"); if (fold(&ctx, c) > 0) { /* Actuall end of line, handle value */ @@ -91,14 +91,14 @@ int parse_file(char* filename, FILE* f, SCM root) { */ if (string_eq(line_key, scm_from_utf8_string("BEGIN"))) { /* key \in { VCALENDAR, VEVENT, VALARM, VTODO, VTIMEZONE, ... } */ - INFO("Creating child"); + // INFO("Creating child"); SCM child = scm_make_vcomponent(scm_string_to_symbol(scm_from_strbuf(&str))); scm_add_child_x (component, child); component = child; } else if (string_eq(line_key, scm_from_utf8_string("END"))) { // TODO make current component be parent of current component? - INFO("back to parent"); + // INFO("back to parent"); component = scm_component_parent(component); /* @@ -106,7 +106,7 @@ int parse_file(char* filename, FILE* f, SCM root) { * component. */ } else { - INFO("Adding attribute"); + // INFO("Adding attribute"); scm_struct_set_x(line, vline_value, scm_from_strbuf(&str)); scm_add_line_x(component, line_key, line); line = scm_make_vline(); @@ -127,7 +127,7 @@ int parse_file(char* filename, FILE* f, SCM root) { /* Save the current parameter key */ // TODO // TRANSFER (¶m_key, &ctx.str); - INFO("Param key"); + // INFO("Param key"); attr_key = scm_from_strbuf(&str); p_ctx = p_param_value; strbuf_soft_reset (&str); @@ -144,7 +144,7 @@ int parse_file(char* filename, FILE* f, SCM root) { /* We got a parameter value, push the current string to * the current parameter set. */ if (p_ctx == p_param_value) { - INFO("param value"); + // INFO("param value"); /* save current parameter value. */ scm_add_attribute_x(line, attr_key, scm_from_strbuf(&str)); strbuf_soft_reset (&str); @@ -158,7 +158,7 @@ int parse_file(char* filename, FILE* f, SCM root) { */ if (p_ctx == p_key) { - INFO("key"); + // INFO("key"); // TRANSFER(&cline_key, &ctx.str); // NEW(content_set, p); diff --git a/src/struct.scm.c b/src/struct.scm.c index b5aa09c1..9b11696d 100644 --- a/src/struct.scm.c +++ b/src/struct.scm.c @@ -3,6 +3,7 @@ #include #include "parse.h" +#include "calendar.h" SCM vcomponent_vtable; SCM vline_vtable; @@ -12,10 +13,9 @@ SCM_DEFINE(scm_make_vcomponent, "make-vcomponent", 0, 1, 0, "") { - if (SCM_UNBNDP (type)) + if (SCM_UNBNDP (type) || scm_is_false (type)) type = scm_from_utf8_symbol("VIRTUAL"); - /* This segfaults */ return scm_make_struct_no_tail (vcomponent_vtable, scm_list_4(type, SCM_EOL, SCM_BOOL_F, @@ -31,13 +31,7 @@ SCM_DEFINE(scm_parse_cal_path, "parse-cal-path", 1, 0, 0, SCM root = scm_make_vcomponent(SCM_UNSPECIFIED); char* p = scm_to_utf8_stringn(path, NULL); - // scm_read_vcalendar(root, p); - /* TODO check that path is good? */ - printf("Parsing [%s]\n", p); - FILE* f = fopen(p, "r"); - printf("FILE = %p\n", f); - parse_file (p, f, root); - /* TODO free file */ + read_vcalendar(root, p); free(p); return root; -- cgit v1.2.3 From e13f6bb201dff690208b9cc951b5c098b0d63356 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 3 Oct 2019 00:46:01 +0200 Subject: Slowly going through and fixing everything. --- module/vcomponent.scm | 113 +++++++++++++++++++++++---------------------- module/vcomponent/base.scm | 32 +++++++------ src/calendar.c | 9 +++- src/parse.c | 15 +++--- 4 files changed, 92 insertions(+), 77 deletions(-) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index a106d993..93449c4b 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -82,59 +82,60 @@ (define* (make-vcomponent #:optional path) (if (not path) (make-vcomponent) - (let* ((root (parse-cal-path path)) - (component - (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) - ;; == Single ICS file == - ;; Remove the abstract ROOT component, - ;; returning the wanted VCALENDAR component - ((file) - ;; TODO test this when an empty file is given. - (car (children root))) - - ;; == Assume vdir == - ;; Also removes the abstract ROOT component, but also - ;; merges all VCALENDAR's children into the a newly - ;; created VCALENDAR component, and return that component. - ;; - ;; TODO the other VCALENDAR components might not get thrown away, - ;; this since I protect them from the GC in the C code. - ((vdir) - (let ((accum (make-vcomponent)) - (ch (children root))) - (set! (type accum) "VCALENDAR") - - (unless (null? ch) - (for key in (attributes (car ch)) - (set! (attr accum key) (attr (car ch) key)))) - - (for cal in ch - (for component in (children cal) - (case (type component) - ((VTIMEZONE) - (unless (find (lambda (z) - (string=? (attr z "TZID") - (attr component "TZID"))) - (children accum 'VTIMEZONE)) - (push-child! accum component))) - (else (push-child! accum component))))) - ;; return - accum)) - - ((no-type) (throw 'no-type)) - - (else (throw 'something))))) - - (parse-dates! component) - - (unless (attr component "NAME") - (set! (attr component "NAME") - (or (attr component "X-WR-CALNAME") - (attr root "NAME")))) - - (unless (attr component "COLOR") - (set! (attr component "COLOR") - (attr root "COLOR"))) - - ;; return - component))) + (let ((root (parse-cal-path path))) + (format #t "root = ~a~%" root ) + (let* ((component + (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) + ;; == Single ICS file == + ;; Remove the abstract ROOT component, + ;; returning the wanted VCALENDAR component + ((file) + ;; TODO test this when an empty file is given. + (display "Hello\n") + (car (children root))) + + ;; == Assume vdir == + ;; Also removes the abstract ROOT component, but also + ;; merges all VCALENDAR's children into the a newly + ;; created VCALENDAR component, and return that component. + ;; + ;; TODO the other VCALENDAR components might not get thrown away, + ;; this since I protect them from the GC in the C code. + ((vdir) + (let ((accum (make-vcomponent)) + (ch (children root))) + (set! (type accum) "VCALENDAR") + + (unless (null? ch) + (for key in (attributes (car ch)) + (set! (attr accum key) (attr (car ch) key)))) + + (for cal in ch + (for component in (children cal) + (case (type component) + ((VTIMEZONE) + (unless (find (lambda (z) + (string=? (attr z "TZID") + (attr component "TZID"))) + (children accum 'VTIMEZONE)) + (push-child! accum component))) + (else (push-child! accum component))))) + ;; return + accum)) + + ((no-type) (throw 'no-type))))) + + (display "Here?\n") + (parse-dates! component) + + (unless (attr component "NAME") + (set! (attr component "NAME") + (or (attr component "X-WR-CALNAME") + (attr root "NAME")))) + + (unless (attr component "COLOR") + (set! (attr component "COLOR") + (attr root "COLOR"))) + + ;; return + component)))) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 4b49ba66..395c2d9c 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -6,8 +6,9 @@ :use-module ((ice-9 optargs) :select (define*-public))) (define (get-attr component attr) - (hash-ref (struct-ref component 3) - (as-string attr)) + (and=> (hash-ref (struct-ref component 3) + (as-string attr)) + (lambda (l) (struct-ref l 0))) #; (%vcomponent-get-attribute component @@ -19,26 +20,29 @@ (set! (car (get-attr component (as-string attr))) value)) -(define-public value caar) +;; (define-public value caar) -(define-public (values-left-count attr-list) - (length (take-while identity attr-list))) +;; (define-public (values-left-count attr-list) +;; (length (take-while identity attr-list))) -(define-public (value-count attr-list) - (length (take-while identity (cdr (drop-while identity attr-list))))) +;; (define-public (value-count attr-list) +;; (length (take-while identity (cdr (drop-while identity attr-list))))) (define-public attr* get-attr) -(define (get-first c a) - (and=> (car (get-attr c a)) car)) +;; (define (get-first c a) +;; (and=> (car (get-attr c a)) car)) -(define (set-first! c a v) - (and=> (car (get-attr c a)) - (lambda (f) (set! (car f) v)))) +;; (define (set-first! c a v) +;; (and=> (car (get-attr c a)) +;; (lambda (f) (set! (car f) v)))) (define-public attr (make-procedure-with-setter - get-first set-first!)) +; get-first set-first! + get-attr + set-attr! + )) (define-public prop @@ -64,7 +68,7 @@ ) (define*-public (children component #:optional only-type) - (let ((childs (slot-ref component 1))) + (let ((childs (struct-ref component 1))) (if only-type (filter (lambda (e) (eq? only-type (type e))) childs) childs))) diff --git a/src/calendar.c b/src/calendar.c index 2cd25f13..a90dfe44 100644 --- a/src/calendar.c +++ b/src/calendar.c @@ -10,6 +10,8 @@ #include #include +#include "struct.h" + #include "parse.h" #include "err.h" @@ -45,6 +47,9 @@ int handle_file(SCM cal, char* path) { /* NAME is the `fancy' name of the calendar. */ // vcomponent_push_val(cal, "NAME", basename(path)); // vcomponent_push_val(cal, "X-HNH-SOURCETYPE", "file"); + SCM line = scm_make_vline(); + scm_struct_set_x(line, vline_value, scm_from_utf8_string("file")); + scm_add_line_x(cal, scm_from_utf8_string("X-HNH-SOURCETYPE"), line); char* resolved_path = realpath(path, NULL); open_ics (resolved_path, cal); free (resolved_path); @@ -68,7 +73,9 @@ int handle_dir(SCM cal, char* path) { /* NAME is the `fancy' name of the calendar. */ // vcomponent_push_val(cal, "NAME", basename(path)); - // vcomponent_push_val(cal, "X-HNH-SOURCETYPE", "vdir"); + SCM line = scm_make_vline(); + scm_struct_set_x(line, vline_value, scm_from_utf8_string("vdir")); + scm_add_line_x(cal, scm_from_utf8_string("X-HNH-SOURCETYPE"), line); struct dirent* d; while ((d = readdir(dir)) != NULL) { diff --git a/src/parse.c b/src/parse.c index dd8066ed..06d8707c 100644 --- a/src/parse.c +++ b/src/parse.c @@ -91,14 +91,14 @@ int parse_file(char* filename, FILE* f, SCM root) { */ if (string_eq(line_key, scm_from_utf8_string("BEGIN"))) { /* key \in { VCALENDAR, VEVENT, VALARM, VTODO, VTIMEZONE, ... } */ - // INFO("Creating child"); + INFO("Creating child"); SCM child = scm_make_vcomponent(scm_string_to_symbol(scm_from_strbuf(&str))); scm_add_child_x (component, child); component = child; } else if (string_eq(line_key, scm_from_utf8_string("END"))) { // TODO make current component be parent of current component? - // INFO("back to parent"); + INFO("back to parent"); component = scm_component_parent(component); /* @@ -106,7 +106,8 @@ int parse_file(char* filename, FILE* f, SCM root) { * component. */ } else { - // INFO("Adding attribute"); + strbuf_cap(&str); // TODO remove + INFO_F("Adding attribute [%s]", str.mem); scm_struct_set_x(line, vline_value, scm_from_strbuf(&str)); scm_add_line_x(component, line_key, line); line = scm_make_vline(); @@ -127,7 +128,7 @@ int parse_file(char* filename, FILE* f, SCM root) { /* Save the current parameter key */ // TODO // TRANSFER (¶m_key, &ctx.str); - // INFO("Param key"); + INFO_F("Param key [%s]", str.mem); attr_key = scm_from_strbuf(&str); p_ctx = p_param_value; strbuf_soft_reset (&str); @@ -144,7 +145,7 @@ int parse_file(char* filename, FILE* f, SCM root) { /* We got a parameter value, push the current string to * the current parameter set. */ if (p_ctx == p_param_value) { - // INFO("param value"); + INFO_F("param value [%s]", str.mem); /* save current parameter value. */ scm_add_attribute_x(line, attr_key, scm_from_strbuf(&str)); strbuf_soft_reset (&str); @@ -158,7 +159,8 @@ int parse_file(char* filename, FILE* f, SCM root) { */ if (p_ctx == p_key) { - // INFO("key"); + strbuf_cap(&str); // TODO remove + INFO_F("key [%s]", str.mem); // TRANSFER(&cline_key, &ctx.str); // NEW(content_set, p); @@ -193,6 +195,7 @@ int parse_file(char* filename, FILE* f, SCM root) { * end with CRLF. My files however does not, so we also parse * the end here. */ + ERR("Not implemented"); // TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); // TODO -- cgit v1.2.3 From 785f70a3d16e549e36b8ef17f081829fe492a193 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 3 Oct 2019 22:02:03 +0200 Subject: Locate bug with DTEND. --- module/main.scm | 4 ++- module/util.scm | 9 +++++- module/vcomponent.scm | 37 ++++++++++++++-------- module/vcomponent/base.scm | 77 +++++++++++++++++++++++++++++++--------------- src/parse.c | 12 +++++++- 5 files changed, 100 insertions(+), 39 deletions(-) diff --git a/module/main.scm b/module/main.scm index 4e75bbf9..2b0fde23 100755 --- a/module/main.scm +++ b/module/main.scm @@ -46,7 +46,9 @@ exec guile -e main -s $0 "$@" ;; Given as a sepparate function from main to ease debugging. (define* (init proc #:key (calendar-files (calendar-files))) (define calendars (map make-vcomponent calendar-files)) - (define events (concatenate (map (cut children <> 'VEVENT) calendars))) + (define events (concatenate (map (lambda (cal) (filter (lambda (o) (eq? 'VEVENT (type o))) + (children cal))) + calendars))) (let* ((repeating regular (partition repeating? events))) diff --git a/module/util.scm b/module/util.scm index 89f6dab6..6aadbc79 100644 --- a/module/util.scm +++ b/module/util.scm @@ -11,7 +11,7 @@ quote? re-export-modules use-modules* - -> set + -> set aif tree-map let-lazy) #:replace (let* set! define-syntax when unless if)) @@ -44,6 +44,13 @@ ((@ (guile) if) p t (begin f ...))])) +(define-syntax aif + (lambda (stx) + (syntax-case stx () + [(_ condition true-clause false-clause) + (with-syntax ((it (datum->syntax stx 'it))) + #'(let ((it condition)) + (if it true-clause false-clause)))]))) (define-public upstring->symbol (compose string->symbol string-upcase)) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 93449c4b..c2e65d19 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,5 +1,5 @@ (define-module (vcomponent) - #:use-module ((vcomponent primitive) :select (parse-cal-path make-vcomponent)) + #:use-module ((vcomponent primitive) :select (parse-cal-path (make-vcomponent . primitive-make-vcomponent))) #:use-module (vcomponent datetime) #:use-module (vcomponent recurrence) #:use-module (vcomponent timezone) @@ -26,7 +26,9 @@ (define (parse-dates! cal) "Parse all start times into scheme date objects." - (for tz in (children cal 'VTIMEZONE) + (for tz in (filter (lambda (o) (eq? 'VTIMEZONE (type o))) (children cal)) + (format #t "TZ = ~a~%" tz) + (for-each (lambda (p) (mod! (attr p "DTSTART") string->time-utc)) (children tz)) @@ -40,15 +42,24 @@ (cadr (children tz)))) )) - (for ev in (children cal 'VEVENT) + (for ev in (filter (lambda (o) (eq? 'VEVENT (type o))) (children cal)) (define dptr (attr* ev 'DTSTART)) (define eptr (attr* ev 'DTEND)) - (define date (parse-datetime (value dptr))) + (define date (parse-datetime (value dptr))) (define end-date - (if (value eptr) - (parse-datetime (value eptr)) - (set (date-hour date) = (+ 1)))) + (begin (format #t "end-date, file = ~a~%" (attr ev 'X-HNH-FILENAME)) + ;; It's here it crashes! + ;; (value eptr) + ;; /home/hugo/.local/var/cal/lithekod_styrelse/9cd19ed2ac0f68f68c405010e43bcf3a5fd6ca01e8f2e0ccf909a0f2fa96532f.ics + ;; An object apparently doesn't need to have a DTEND... + (aif (value eptr) + (parse-datetime it) + (set (date-hour date) = (+ 1))))) + + (format #t "ev = ~a~%file = ~a~%" ev (attr ev 'X-HNH-FILENAME)) + + ;; (format #t "ev = ~a~%file = ~a~%" ev (attr ev 'X-HNH-FILENAME)) (set! (value dptr) (date->time-utc date) (value eptr) (date->time-utc end-date)) @@ -78,10 +89,9 @@ ;; (make-procedure-with-setter car set-car!)) - (define* (make-vcomponent #:optional path) (if (not path) - (make-vcomponent) + (primitive-make-vcomponent) (let ((root (parse-cal-path path))) (format #t "root = ~a~%" root ) (let* ((component @@ -102,14 +112,16 @@ ;; TODO the other VCALENDAR components might not get thrown away, ;; this since I protect them from the GC in the C code. ((vdir) - (let ((accum (make-vcomponent)) + (let ((accum (primitive-make-vcomponent 'VCALENDAR)) (ch (children root))) - (set! (type accum) "VCALENDAR") + ;; What does this even do? (unless (null? ch) + (format #t "Looping over attributes~%") (for key in (attributes (car ch)) (set! (attr accum key) (attr (car ch) key)))) + (format #t "Looping over children, again") (for cal in ch (for component in (children cal) (case (type component) @@ -117,7 +129,7 @@ (unless (find (lambda (z) (string=? (attr z "TZID") (attr component "TZID"))) - (children accum 'VTIMEZONE)) + (filter (lambda (o) (eq? 'VTIMEZONE (type o))) (children accum))) (push-child! accum component))) (else (push-child! accum component))))) ;; return @@ -127,6 +139,7 @@ (display "Here?\n") (parse-dates! component) + (display "Theren") (unless (attr component "NAME") (set! (attr component "NAME") diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 395c2d9c..986037f5 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -5,22 +5,49 @@ :use-module (vcomponent primitive) :use-module ((ice-9 optargs) :select (define*-public))) +;; (define og-struct-ref struct-ref) +;; (define (struct-ref struct field) +;; (format #t "struct = ~a, field = ~a~%" struct field) +;; (og-struct-ref struct field)) + +(use-modules (system vm trap-state)) + +(install-trap-handler! (lambda args (format #t "args = ~a~%" args))) + +(add-trace-at-procedure-call! struct-ref) +(add-trap-at-procedure-call! struct-ref) + +;; vline → value +(define-public value + (make-procedure-with-setter + (lambda (vline) (struct-ref vline 0)) + (lambda (vline value) (struct-set! vline 0 value)))) + +;; vcomponent x (or str symb) → vline +(define-public (attr* component attr) + (hash-ref (struct-ref component 3) + (as-string attr))) + +;; vcomponent x (or str symb) → value (define (get-attr component attr) - (and=> (hash-ref (struct-ref component 3) - (as-string attr)) - (lambda (l) (struct-ref l 0))) - #; - (%vcomponent-get-attribute - component - (as-string attr))) + (and=> (attr* component attr) + value)) (define (set-attr! component attr value) - 'noop - #; - (set! (car (get-attr component (as-string attr))) - value)) + (format #t "attr = ~a~%" attr) + (aif (attr* component attr) + (begin (format #t "Existed~%") (struct-set! it 0 value)) + (begin (format #t "Creating, component = ~a, attr = ~a, value = ~a~%" component attr value) + (format #t "map = ~a~%" (struct-ref component 3)) + (let ((return (hash-set! (struct-ref component 3) + (as-string attr) + value))) + + (format #t "Return = ~a~%" return) + return + ) -;; (define-public value caar) + ))) ;; (define-public (values-left-count attr-list) ;; (length (take-while identity attr-list))) @@ -28,8 +55,6 @@ ;; (define-public (value-count attr-list) ;; (length (take-while identity (cdr (drop-while identity attr-list))))) -(define-public attr* get-attr) - ;; (define (get-first c a) ;; (and=> (car (get-attr c a)) car)) @@ -48,32 +73,36 @@ (define-public prop (make-procedure-with-setter (lambda (attr-obj prop-key) - (hashq-ref (cdar attr-obj) prop-key)) + (hashq-ref (struct-ref attr-obj 1) prop-key)) (lambda (attr-obj prop-key val) - (hashq-set! (cdar attr-obj) prop-key val)))) + (hashq-set! (struct-ref attr-obj 1) prop-key val)))) ;; Returns the properties of attribute as an assoc list. ;; @code{(map car <>)} leads to available properties. (define-public (properties attrptr) - (hash-map->list cons (cdar attrptr))) + (hash-map->list cons (struct-ref attrptr 1))) (define-public type (make-procedure-with-setter (lambda (c) (struct-ref c 0)) (lambda (c v) struct-set! c 0 v) )) + (define-public (parent c) (struct-ref c 2)) (define-public push-child! add-child!) -(define-public (attributes component) '("noop") +(define-public (attributes component) + (hash-map->list cons (struct-ref component 3)) #; (map string->symbol (%vcomponent-attribute-list component)) ) -(define*-public (children component #:optional only-type) - (let ((childs (struct-ref component 1))) - (if only-type - (filter (lambda (e) (eq? only-type (type e))) childs) - childs))) +(define*-public (children component) + (struct-ref component 1)) -;; (define-public copy-vcomponent %vcomponent-shallow-copy) +(define-public (copy-vcomponent component) + (make-struct/no-tail (struct-vtable component) + (struct-ref component 0) + (struct-ref component 1) + (struct-ref component 2) + (struct-ref component 3))) ;; (define-public filter-children! %vcomponent-filter-children!) diff --git a/src/parse.c b/src/parse.c index 06d8707c..48b58b95 100644 --- a/src/parse.c +++ b/src/parse.c @@ -94,6 +94,16 @@ int parse_file(char* filename, FILE* f, SCM root) { INFO("Creating child"); SCM child = scm_make_vcomponent(scm_string_to_symbol(scm_from_strbuf(&str))); scm_add_child_x (component, child); + + /* TODO it should be possible to create this object once + at the top of this function + */ + SCM templine = scm_make_vline(); + scm_struct_set_x(templine, vline_value, + scm_from_utf8_stringn(filename, strlen(filename))); + scm_add_line_x(child, scm_from_utf8_string("X-HNH-FILENAME"), + templine); + component = child; } else if (string_eq(line_key, scm_from_utf8_string("END"))) { @@ -195,7 +205,7 @@ int parse_file(char* filename, FILE* f, SCM root) { * end with CRLF. My files however does not, so we also parse * the end here. */ - ERR("Not implemented"); + ERR("Handling of missing trailing endline not reimplemented."); // TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); // TODO -- cgit v1.2.3 From d42ba61061a105389796b4aa36194e74dce83e40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 3 Oct 2019 23:22:24 +0200 Subject: Fix problem with no end date. --- module/vcomponent.scm | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index c2e65d19..9bd70689 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -48,14 +48,18 @@ (define date (parse-datetime (value dptr))) (define end-date - (begin (format #t "end-date, file = ~a~%" (attr ev 'X-HNH-FILENAME)) - ;; It's here it crashes! - ;; (value eptr) - ;; /home/hugo/.local/var/cal/lithekod_styrelse/9cd19ed2ac0f68f68c405010e43bcf3a5fd6ca01e8f2e0ccf909a0f2fa96532f.ics - ;; An object apparently doesn't need to have a DTEND... - (aif (value eptr) - (parse-datetime it) - (set (date-hour date) = (+ 1))))) + (cond [(not eptr) + (format #t "date = ~a~%" date) + (let ((d (set (date-hour date) = (+ 1)))) + (set! (attr ev 'DTEND) d + eptr (attr* ev 'DTEND)) + d + )] + [(value eptr) => parse-datetime] + [else + (format #t "date = ~a~%" date) + (set (date-hour date) = (+ 1))]) + ) (format #t "ev = ~a~%file = ~a~%" ev (attr ev 'X-HNH-FILENAME)) @@ -64,6 +68,8 @@ (set! (value dptr) (date->time-utc date) (value eptr) (date->time-utc end-date)) + (format #t "After first set") + (when (prop (attr* ev 'DTSTART) 'TZID) (set! (zone-offset date) (get-tz-offset ev) (value dptr) (date->time-utc date) -- cgit v1.2.3 From 60d51e5700a55bc3ae17e34f9f3da1d4653a3026 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 3 Oct 2019 23:56:59 +0200 Subject: Everything seems to parse now. --- module/vcomponent/base.scm | 2 +- module/vcomponent/recurrence/generate.scm | 19 +++++++++++++++---- src/calendar.c | 6 ++---- src/parse.c | 9 ++++----- src/struct.h | 2 +- src/struct.scm.c | 13 ++++++++----- 6 files changed, 31 insertions(+), 20 deletions(-) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 986037f5..38034a81 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -41,7 +41,7 @@ (format #t "map = ~a~%" (struct-ref component 3)) (let ((return (hash-set! (struct-ref component 3) (as-string attr) - value))) + (make-vline value)))) (format #t "Return = ~a~%" return) return diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 435d3009..a274ecfa 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -73,6 +73,8 @@ (date->time-utc d)) (when (attr e 'DTEND) + (format #t "file = ~a~%dtstart = ~a~%duration = ~a~%" + (attr e 'X-HNH-FILENAME) (attr e 'DTSTART) (attr e 'DURATION)) (set! (attr e 'DTEND) (add-duration (attr e 'DTSTART) (attr e 'DURATION)))) @@ -124,12 +126,21 @@ (if (not (attr event 'RRULE)) (stream event) (begin + (format #t "!!! DURATION = ~a~%" (attr event 'DURATION)) (when (and (attr event 'DTEND) (not (attr event 'DURATION))) - (set! (attr event "DURATION") - (time-difference - (attr event "DTEND") - (attr event "DTSTART")))) + (let ((dt (time-difference (attr event "DTEND") (attr event "DTSTART") ))) + (format #t "duration = ~a~%start = ~a, end = ~a~%diff = ~a~%" + (attr event "DURATION") + (attr event "DTSTART") (attr event "DTEND") + dt) + (set! (attr event "DURATION") + dt + #; + (time-difference + (attr event "DTEND") + (attr event "DTSTART"))))) + (format #t "||| DURATION = ~a~%" (attr* event "DURATION")) (if (attr event "RRULE") (recur-event-stream event (parse-recurrence-rule (attr event "RRULE"))) ;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather diff --git a/src/calendar.c b/src/calendar.c index a90dfe44..7d8d598e 100644 --- a/src/calendar.c +++ b/src/calendar.c @@ -47,8 +47,7 @@ int handle_file(SCM cal, char* path) { /* NAME is the `fancy' name of the calendar. */ // vcomponent_push_val(cal, "NAME", basename(path)); // vcomponent_push_val(cal, "X-HNH-SOURCETYPE", "file"); - SCM line = scm_make_vline(); - scm_struct_set_x(line, vline_value, scm_from_utf8_string("file")); + SCM line = scm_make_vline(scm_from_utf8_string("file")); scm_add_line_x(cal, scm_from_utf8_string("X-HNH-SOURCETYPE"), line); char* resolved_path = realpath(path, NULL); open_ics (resolved_path, cal); @@ -73,8 +72,7 @@ int handle_dir(SCM cal, char* path) { /* NAME is the `fancy' name of the calendar. */ // vcomponent_push_val(cal, "NAME", basename(path)); - SCM line = scm_make_vline(); - scm_struct_set_x(line, vline_value, scm_from_utf8_string("vdir")); + SCM line = scm_make_vline(scm_from_utf8_string("vdir")); scm_add_line_x(cal, scm_from_utf8_string("X-HNH-SOURCETYPE"), line); struct dirent* d; diff --git a/src/parse.c b/src/parse.c index 48b58b95..8c370958 100644 --- a/src/parse.c +++ b/src/parse.c @@ -69,7 +69,7 @@ int parse_file(char* filename, FILE* f, SCM root) { SNEW(strbuf, str); SCM component = root; - SCM line = scm_make_vline(); + SCM line = scm_make_vline(SCM_UNDEFINED); SCM attr_key; /* string */ SCM line_key = scm_from_utf8_string(""); /* string */ @@ -98,9 +98,8 @@ int parse_file(char* filename, FILE* f, SCM root) { /* TODO it should be possible to create this object once at the top of this function */ - SCM templine = scm_make_vline(); - scm_struct_set_x(templine, vline_value, - scm_from_utf8_stringn(filename, strlen(filename))); + SCM templine = + scm_make_vline(scm_from_utf8_stringn(filename, strlen(filename))); scm_add_line_x(child, scm_from_utf8_string("X-HNH-FILENAME"), templine); @@ -120,7 +119,7 @@ int parse_file(char* filename, FILE* f, SCM root) { INFO_F("Adding attribute [%s]", str.mem); scm_struct_set_x(line, vline_value, scm_from_strbuf(&str)); scm_add_line_x(component, line_key, line); - line = scm_make_vline(); + line = scm_make_vline(SCM_UNDEFINED); } strbuf_soft_reset (&str); diff --git a/src/struct.h b/src/struct.h index d39cf471..a66dc201 100644 --- a/src/struct.h +++ b/src/struct.h @@ -17,7 +17,7 @@ SCM scm_make_vcomponent(SCM); SCM scm_add_line_x (SCM, SCM, SCM); SCM scm_add_child_x (SCM, SCM); -SCM scm_make_vline (); +SCM scm_make_vline (SCM); SCM scm_add_attribute_x (SCM, SCM, SCM); #endif /* STRUCT_H */ diff --git a/src/struct.scm.c b/src/struct.scm.c index 9b11696d..a8e7b3c6 100644 --- a/src/struct.scm.c +++ b/src/struct.scm.c @@ -28,7 +28,7 @@ SCM_DEFINE(scm_parse_cal_path, "parse-cal-path", 1, 0, 0, (SCM path), "") { - SCM root = scm_make_vcomponent(SCM_UNSPECIFIED); + SCM root = scm_make_vcomponent(SCM_UNDEFINED); char* p = scm_to_utf8_stringn(path, NULL); read_vcalendar(root, p); @@ -58,12 +58,15 @@ SCM_DEFINE(scm_add_child_x, "add-child!", 2, 0, 0, } -SCM_DEFINE(scm_make_vline, "make-vline", 0, 0, 0, - (), "") +SCM_DEFINE(scm_make_vline, "make-vline", 0, 1, 0, + (SCM value), "") { + + if (SCM_UNBNDP (value)) value = SCM_BOOL_F; + return scm_make_struct_no_tail - (vline_vtable, - scm_list_2(SCM_BOOL_F, scm_make_hash_table(scm_from_int(0x10)))); + (vline_vtable, + scm_list_2(value, scm_make_hash_table(scm_from_int(0x10)))); } -- cgit v1.2.3 From 3521ad64ef664f8303fa93ac237212b97dd0f69c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 4 Oct 2019 00:01:27 +0200 Subject: Remove debug prints.. --- module/vcomponent.scm | 16 ---------------- module/vcomponent/base.scm | 29 ++++------------------------- module/vcomponent/recurrence/generate.scm | 21 +++++---------------- src/parse.c | 16 ---------------- 4 files changed, 9 insertions(+), 73 deletions(-) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 9bd70689..e7ffb785 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -27,8 +27,6 @@ "Parse all start times into scheme date objects." (for tz in (filter (lambda (o) (eq? 'VTIMEZONE (type o))) (children cal)) - (format #t "TZ = ~a~%" tz) - (for-each (lambda (p) (mod! (attr p "DTSTART") string->time-utc)) (children tz)) @@ -49,7 +47,6 @@ (define date (parse-datetime (value dptr))) (define end-date (cond [(not eptr) - (format #t "date = ~a~%" date) (let ((d (set (date-hour date) = (+ 1)))) (set! (attr ev 'DTEND) d eptr (attr* ev 'DTEND)) @@ -57,19 +54,12 @@ )] [(value eptr) => parse-datetime] [else - (format #t "date = ~a~%" date) (set (date-hour date) = (+ 1))]) ) - (format #t "ev = ~a~%file = ~a~%" ev (attr ev 'X-HNH-FILENAME)) - - ;; (format #t "ev = ~a~%file = ~a~%" ev (attr ev 'X-HNH-FILENAME)) - (set! (value dptr) (date->time-utc date) (value eptr) (date->time-utc end-date)) - (format #t "After first set") - (when (prop (attr* ev 'DTSTART) 'TZID) (set! (zone-offset date) (get-tz-offset ev) (value dptr) (date->time-utc date) @@ -99,7 +89,6 @@ (if (not path) (primitive-make-vcomponent) (let ((root (parse-cal-path path))) - (format #t "root = ~a~%" root ) (let* ((component (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) ;; == Single ICS file == @@ -107,7 +96,6 @@ ;; returning the wanted VCALENDAR component ((file) ;; TODO test this when an empty file is given. - (display "Hello\n") (car (children root))) ;; == Assume vdir == @@ -123,11 +111,9 @@ ;; What does this even do? (unless (null? ch) - (format #t "Looping over attributes~%") (for key in (attributes (car ch)) (set! (attr accum key) (attr (car ch) key)))) - (format #t "Looping over children, again") (for cal in ch (for component in (children cal) (case (type component) @@ -143,9 +129,7 @@ ((no-type) (throw 'no-type))))) - (display "Here?\n") (parse-dates! component) - (display "Theren") (unless (attr component "NAME") (set! (attr component "NAME") diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 38034a81..399f7af9 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -5,18 +5,6 @@ :use-module (vcomponent primitive) :use-module ((ice-9 optargs) :select (define*-public))) -;; (define og-struct-ref struct-ref) -;; (define (struct-ref struct field) -;; (format #t "struct = ~a, field = ~a~%" struct field) -;; (og-struct-ref struct field)) - -(use-modules (system vm trap-state)) - -(install-trap-handler! (lambda args (format #t "args = ~a~%" args))) - -(add-trace-at-procedure-call! struct-ref) -(add-trap-at-procedure-call! struct-ref) - ;; vline → value (define-public value (make-procedure-with-setter @@ -34,20 +22,11 @@ value)) (define (set-attr! component attr value) - (format #t "attr = ~a~%" attr) (aif (attr* component attr) - (begin (format #t "Existed~%") (struct-set! it 0 value)) - (begin (format #t "Creating, component = ~a, attr = ~a, value = ~a~%" component attr value) - (format #t "map = ~a~%" (struct-ref component 3)) - (let ((return (hash-set! (struct-ref component 3) - (as-string attr) - (make-vline value)))) - - (format #t "Return = ~a~%" return) - return - ) - - ))) + (struct-set! it 0 value) + (hash-set! (struct-ref component 3) + (as-string attr) + (make-vline value)))) ;; (define-public (values-left-count attr-list) ;; (length (take-while identity attr-list))) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index a274ecfa..c2863954 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -73,10 +73,8 @@ (date->time-utc d)) (when (attr e 'DTEND) - (format #t "file = ~a~%dtstart = ~a~%duration = ~a~%" - (attr e 'X-HNH-FILENAME) (attr e 'DTSTART) (attr e 'DURATION)) - (set! (attr e 'DTEND) - (add-duration (attr e 'DTSTART) (attr e 'DURATION)))) + (set! (attr e 'DTEND) + (add-duration (attr e 'DTSTART) (attr e 'DURATION)))) ;; Return e)) @@ -126,21 +124,12 @@ (if (not (attr event 'RRULE)) (stream event) (begin - (format #t "!!! DURATION = ~a~%" (attr event 'DURATION)) (when (and (attr event 'DTEND) (not (attr event 'DURATION))) - (let ((dt (time-difference (attr event "DTEND") (attr event "DTSTART") ))) - (format #t "duration = ~a~%start = ~a, end = ~a~%diff = ~a~%" - (attr event "DURATION") - (attr event "DTSTART") (attr event "DTEND") - dt) - (set! (attr event "DURATION") - dt - #; - (time-difference + (set! (attr event "DURATION") + (time-difference (attr event "DTEND") - (attr event "DTSTART"))))) - (format #t "||| DURATION = ~a~%" (attr* event "DURATION")) + (attr event "DTSTART")))) (if (attr event "RRULE") (recur-event-stream event (parse-recurrence-rule (attr event "RRULE"))) ;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather diff --git a/src/parse.c b/src/parse.c index 8c370958..996c0a92 100644 --- a/src/parse.c +++ b/src/parse.c @@ -73,16 +73,10 @@ int parse_file(char* filename, FILE* f, SCM root) { SCM attr_key; /* string */ SCM line_key = scm_from_utf8_string(""); /* string */ - INFO_F("Parsing [%s]", filename); - char c; while ( (c = fgetc(f)) != EOF) { - // INFO_F("LOOP %c", c); - /* We have a linebreak */ if (c == '\r' || c == '\n') { - // INFO("EOL"); - if (fold(&ctx, c) > 0) { /* Actuall end of line, handle value */ // TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); @@ -91,7 +85,6 @@ int parse_file(char* filename, FILE* f, SCM root) { */ if (string_eq(line_key, scm_from_utf8_string("BEGIN"))) { /* key \in { VCALENDAR, VEVENT, VALARM, VTODO, VTIMEZONE, ... } */ - INFO("Creating child"); SCM child = scm_make_vcomponent(scm_string_to_symbol(scm_from_strbuf(&str))); scm_add_child_x (component, child); @@ -107,7 +100,6 @@ int parse_file(char* filename, FILE* f, SCM root) { } else if (string_eq(line_key, scm_from_utf8_string("END"))) { // TODO make current component be parent of current component? - INFO("back to parent"); component = scm_component_parent(component); /* @@ -115,8 +107,6 @@ int parse_file(char* filename, FILE* f, SCM root) { * component. */ } else { - strbuf_cap(&str); // TODO remove - INFO_F("Adding attribute [%s]", str.mem); scm_struct_set_x(line, vline_value, scm_from_strbuf(&str)); scm_add_line_x(component, line_key, line); line = scm_make_vline(SCM_UNDEFINED); @@ -135,9 +125,6 @@ int parse_file(char* filename, FILE* f, SCM root) { } else if (p_ctx == p_param_name && c == '=') { /* Save the current parameter key */ - // TODO - // TRANSFER (¶m_key, &ctx.str); - INFO_F("Param key [%s]", str.mem); attr_key = scm_from_strbuf(&str); p_ctx = p_param_value; strbuf_soft_reset (&str); @@ -154,7 +141,6 @@ int parse_file(char* filename, FILE* f, SCM root) { /* We got a parameter value, push the current string to * the current parameter set. */ if (p_ctx == p_param_value) { - INFO_F("param value [%s]", str.mem); /* save current parameter value. */ scm_add_attribute_x(line, attr_key, scm_from_strbuf(&str)); strbuf_soft_reset (&str); @@ -168,8 +154,6 @@ int parse_file(char* filename, FILE* f, SCM root) { */ if (p_ctx == p_key) { - strbuf_cap(&str); // TODO remove - INFO_F("key [%s]", str.mem); // TRANSFER(&cline_key, &ctx.str); // NEW(content_set, p); -- cgit v1.2.3 From 6d5a32fc3bf707bafc19e239dd60371bece90fd1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 4 Oct 2019 00:05:46 +0200 Subject: General cleanup in parse. --- src/parse.c | 15 ++++----------- 1 file changed, 4 insertions(+), 11 deletions(-) diff --git a/src/parse.c b/src/parse.c index 996c0a92..fbfb2387 100644 --- a/src/parse.c +++ b/src/parse.c @@ -73,6 +73,9 @@ int parse_file(char* filename, FILE* f, SCM root) { SCM attr_key; /* string */ SCM line_key = scm_from_utf8_string(""); /* string */ + SCM scm_filename = scm_from_utf8_stringn(filename, strlen(filename)); + SCM filename_key = scm_from_utf8_string("X-HNH-FILENAME"); + char c; while ( (c = fgetc(f)) != EOF) { /* We have a linebreak */ @@ -91,15 +94,11 @@ int parse_file(char* filename, FILE* f, SCM root) { /* TODO it should be possible to create this object once at the top of this function */ - SCM templine = - scm_make_vline(scm_from_utf8_stringn(filename, strlen(filename))); - scm_add_line_x(child, scm_from_utf8_string("X-HNH-FILENAME"), - templine); + scm_add_line_x(child, filename_key, scm_make_vline(scm_filename)); component = child; } else if (string_eq(line_key, scm_from_utf8_string("END"))) { - // TODO make current component be parent of current component? component = scm_component_parent(component); /* @@ -153,12 +152,6 @@ int parse_file(char* filename, FILE* f, SCM root) { * parameters. */ if (p_ctx == p_key) { - - // TRANSFER(&cline_key, &ctx.str); - - // NEW(content_set, p); - // PUSH(LLIST(content_set))(&cline, p); - // attr_key line_key = scm_from_strbuf(&str); strbuf_soft_reset (&str); } -- cgit v1.2.3 From 100ac33c561d59057425ddfeb26c4bd7b054db57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 4 Oct 2019 00:08:45 +0200 Subject: Reintroduce color and name parsing. --- src/calendar.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/calendar.c b/src/calendar.c index 7d8d598e..bafc13c3 100644 --- a/src/calendar.c +++ b/src/calendar.c @@ -96,8 +96,8 @@ int handle_dir(SCM cal, char* path) { info_buf[read - 1] = '\0'; fclose(f); - // TODO - // vcomponent_push_val(cal, "COLOR", info_buf); + scm_add_line_x(cal, scm_from_utf8_string("COLOR"), + scm_make_vline(scm_from_utf8_stringn(info_buf, read))); } else if (strcmp (d->d_name, "displayname") == 0) { f = fopen(resolved_path, "r"); read = getline(&info_buf, &size, f); @@ -111,8 +111,8 @@ int handle_dir(SCM cal, char* path) { * This works since *currently* values are returned in * reverse order */ - // TODO - // vcomponent_push_val(cal, "NAME", info_buf); + scm_add_line_x(cal, scm_from_utf8_string("NAME"), + scm_make_vline(scm_from_utf8_stringn(info_buf, read))); } else { open_ics (resolved_path, cal); } -- cgit v1.2.3 From 533b1994a73b6ae5003ad73109a600c0d05b4a92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 4 Oct 2019 00:15:19 +0200 Subject: Actually fix NAME. --- module/output/html.scm | 1 + module/vcomponent/base.scm | 4 ++-- module/vcomponent/control.scm | 2 +- src/calendar.c | 2 ++ 4 files changed, 6 insertions(+), 3 deletions(-) diff --git a/module/output/html.scm b/module/output/html.scm index 3df48159..cb3d07a5 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -221,6 +221,7 @@ ;; (display "") (newline) + ((@ (sxml simple) sxml->xml) `(html (@ (lang sv)) (head diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 399f7af9..3bd58c21 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -52,9 +52,9 @@ (define-public prop (make-procedure-with-setter (lambda (attr-obj prop-key) - (hashq-ref (struct-ref attr-obj 1) prop-key)) + (hash-ref (struct-ref attr-obj 1) prop-key)) (lambda (attr-obj prop-key val) - (hashq-set! (struct-ref attr-obj 1) prop-key val)))) + (hash-set! (struct-ref attr-obj 1) prop-key val)))) ;; Returns the properties of attribute as an assoc list. ;; @code{(map car <>)} leads to available properties. diff --git a/module/vcomponent/control.scm b/module/vcomponent/control.scm index 38199161..3bdecc5a 100644 --- a/module/vcomponent/control.scm +++ b/module/vcomponent/control.scm @@ -5,7 +5,7 @@ (eval-when (expand load) ; No idea why I must have load here. - (define href (make-procedure-with-setter hashq-ref hashq-set!)) + (define href (make-procedure-with-setter hash-ref hash-set!)) (define (set-temp-values! table component kvs) (for-each (lambda (kv) diff --git a/src/calendar.c b/src/calendar.c index bafc13c3..f3a9b254 100644 --- a/src/calendar.c +++ b/src/calendar.c @@ -72,6 +72,8 @@ int handle_dir(SCM cal, char* path) { /* NAME is the `fancy' name of the calendar. */ // vcomponent_push_val(cal, "NAME", basename(path)); + scm_add_line_x(cal, scm_from_utf8_string("NAME"), + scm_make_vline(scm_from_utf8_stringn(basename(path), strlen(basename(path))))); SCM line = scm_make_vline(scm_from_utf8_string("vdir")); scm_add_line_x(cal, scm_from_utf8_string("X-HNH-SOURCETYPE"), line); -- cgit v1.2.3 From 2782987949ffbd8b7ac92cd92a3ab65c78865cb3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 4 Oct 2019 00:18:40 +0200 Subject: Comments in parser. --- src/parse.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/parse.c b/src/parse.c index fbfb2387..81312967 100644 --- a/src/parse.c +++ b/src/parse.c @@ -180,12 +180,12 @@ int parse_file(char* filename, FILE* f, SCM root) { * The standard (3.4, l. 2675) says that each icalobject must * end with CRLF. My files however does not, so we also parse * the end here. + * + * Actually we don't any more. + * Since the last thing in a file should always be END:VCALENDAR + * it might be a good idea to verify that. Or we could just, you + * know, not. */ - ERR("Handling of missing trailing endline not reimplemented."); - - // TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); - // TODO - // handle_kv(&cline_key, &cline, &ctx); } -- cgit v1.2.3 From 77791305d6e1483fa5ae46f26616242c00f99989 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 4 Oct 2019 21:02:17 +0200 Subject: HTML output seems to work in full now. --- module/main.scm | 8 +++++--- module/output/terminal.scm | 1 + module/vcomponent/base.scm | 11 ++++++++++- module/vcomponent/group.scm | 1 + module/vcomponent/recurrence/generate.scm | 3 +++ src/parse.c | 3 --- 6 files changed, 20 insertions(+), 7 deletions(-) diff --git a/module/main.scm b/module/main.scm index 2b0fde23..ce327f39 100755 --- a/module/main.scm +++ b/module/main.scm @@ -46,9 +46,11 @@ exec guile -e main -s $0 "$@" ;; Given as a sepparate function from main to ease debugging. (define* (init proc #:key (calendar-files (calendar-files))) (define calendars (map make-vcomponent calendar-files)) - (define events (concatenate (map (lambda (cal) (filter (lambda (o) (eq? 'VEVENT (type o))) - (children cal))) - calendars))) + (define events (concatenate + ;; TODO does this drop events? + (map (lambda (cal) (filter (lambda (o) (eq? 'VEVENT (type o))) + (children cal))) + calendars))) (let* ((repeating regular (partition repeating? events))) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index 67548537..a2c5486e 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -67,6 +67,7 @@ ;; I currently have no idea why, but it's BAD. (let ((groups (get-groups-between (group-stream event-stream) (time-utc->date time) (time-utc->date time)))) + (format (current-error-port) "len(groups) = ~a~%" (stream-length groups)) (let ((events (if (stream-null? groups) '() (group->event-list (stream-car groups))))) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 3bd58c21..246566ee 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -3,6 +3,7 @@ :use-module (srfi srfi-1) :use-module (srfi srfi-17) :use-module (vcomponent primitive) + :use-module (ice-9 hash-table) :use-module ((ice-9 optargs) :select (define*-public))) ;; vline → value @@ -76,12 +77,20 @@ (define*-public (children component) (struct-ref component 1)) +(define (copy-vline vline) + (make-struct/no-tail (struct-vtable vline) + (struct-ref vline 0) + ;; TODO deep-copy on properties? + (struct-ref vline 1))) + (define-public (copy-vcomponent component) (make-struct/no-tail (struct-vtable component) (struct-ref component 0) (struct-ref component 1) (struct-ref component 2) - (struct-ref component 3))) + (alist->hash-table + (hash-map->list (lambda (key value) (cons key (copy-vline value))) + (struct-ref component 3))))) ;; (define-public filter-children! %vcomponent-filter-children!) diff --git a/module/vcomponent/group.scm b/module/vcomponent/group.scm index c5b6948e..41123126 100644 --- a/module/vcomponent/group.scm +++ b/module/vcomponent/group.scm @@ -7,6 +7,7 @@ #:use-module (srfi srfi-41 util) #:export (group-stream)) +;; TODO templetize this (define-stream (group-stream in-stream) (define (ein? day) (lambda (e) (event-contains? e (date->time-utc day)))) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index c2863954..3f4cb869 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -51,6 +51,9 @@ (get-tz-offset e) 0)))) + (set! (attr ev 'DTSTART) + (copy-time (attr ev 'DTSTART))) + (let ((i (interval r))) (case (freq r) ((SECONDLY) (mod! (second d) = (+ i))) diff --git a/src/parse.c b/src/parse.c index 81312967..3a5907c8 100644 --- a/src/parse.c +++ b/src/parse.c @@ -91,9 +91,6 @@ int parse_file(char* filename, FILE* f, SCM root) { SCM child = scm_make_vcomponent(scm_string_to_symbol(scm_from_strbuf(&str))); scm_add_child_x (component, child); - /* TODO it should be possible to create this object once - at the top of this function - */ scm_add_line_x(child, filename_key, scm_make_vline(scm_filename)); component = child; -- cgit v1.2.3 From 1bc8f0c31fd94b3936fc13ed325ecd8308d73f87 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 5 Oct 2019 23:51:50 +0200 Subject: Fix day-stream, and in effect terminal output. --- module/output/terminal.scm | 5 ++++- module/srfi/srfi-19/util.scm | 6 +++--- module/util.scm | 3 +++ module/vcomponent/group.scm | 8 +++++--- 4 files changed, 15 insertions(+), 7 deletions(-) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index a2c5486e..37fe1b86 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -62,10 +62,12 @@ (define-values (height width) (get-terminal-size)) + (define grouped-stream (group-stream event-stream)) + (while #t ;; TODO reusing the same grouping causes it to lose events. ;; I currently have no idea why, but it's BAD. - (let ((groups (get-groups-between (group-stream event-stream) + (let ((groups (get-groups-between grouped-stream (time-utc->date time) (time-utc->date time)))) (format (current-error-port) "len(groups) = ~a~%" (stream-length groups)) (let ((events @@ -157,5 +159,6 @@ (let ((time (date->time-utc (drop-time (or (and=> (option-ref opts 'date #f) parse-freeform-date) (current-date)))))) + ;; (format (current-error-port) "len(events) = ~a~%" (stream-length events)) (with-vulgar (lambda () (main-loop time events)))))) diff --git a/module/srfi/srfi-19/util.scm b/module/srfi/srfi-19/util.scm index 2e969f6e..4155b263 100644 --- a/module/srfi/srfi-19/util.scm +++ b/module/srfi/srfi-19/util.scm @@ -108,9 +108,9 @@ attribute set to 0. Can also be seen as \"Start of day\"" (define-public (day-stream start-day) (stream-iterate (lambda (d) - (mod! (day d) = (+ 1)) - (set! d (drop-time (normalize-date* d))) - d) + (drop-time + (normalize-date* + (set (date-day d) = (+ 1))))) (drop-time start-day))) (define-public (in-date-range? start-date end-date) diff --git a/module/util.scm b/module/util.scm index 6aadbc79..707cba90 100644 --- a/module/util.scm +++ b/module/util.scm @@ -363,6 +363,9 @@ (-> (func obj) rest ...)])) +;; Non-destructive set, syntax extension from set-fields from (srfi +;; srfi-9 gnu). Also doubles as a non-destructive mod!, if the `=' +;; operator is used. (define-syntax set (syntax-rules (=) [(set (acc obj) value) diff --git a/module/vcomponent/group.scm b/module/vcomponent/group.scm index 41123126..7733d981 100644 --- a/module/vcomponent/group.scm +++ b/module/vcomponent/group.scm @@ -5,7 +5,7 @@ #:use-module (srfi srfi-19 util) #:use-module (srfi srfi-41) #:use-module (srfi srfi-41 util) - #:export (group-stream)) + #:export (group-stream get-groups-between)) ;; TODO templetize this (define-stream (group-stream in-stream) @@ -16,7 +16,8 @@ (if (stream-null? stream) stream-null (let* ((day (stream-car days)) - (tomorow (add-day (date->time-utc (drop-time day))))) + (tomorow (date->time-utc (stream-car (stream-cdr days))))) + (let ((head (stream-take-while (ein? day) stream)) (tail (filter-sorted-stream* @@ -24,11 +25,12 @@ (lambda (e) (time<=? tomorow (attr e 'DTSTART))) stream))) + (stream-cons (cons day head) (loop (stream-cdr days) tail))))))) -(define-public (get-groups-between groups start-date end-date) +(define (get-groups-between groups start-date end-date) (filter-sorted-stream ;; TODO in-date-range? drops the first date (compose (in-date-range? start-date end-date) -- cgit v1.2.3 From 68dfd8bb5abcc449500614c46566ffa4a83177a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 5 Oct 2019 23:58:03 +0200 Subject: Documentation of stream behavior. --- module/srfi/srfi-41/util.scm | 14 +++++++++++--- module/vcomponent/group.scm | 5 +++++ 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index 050e1d2e..be363146 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -24,11 +24,19 @@ (define-public (stream-insert < item s) (interleave-streams < (list (stream item) s))) -(define-public (filter-sorted-stream proc stream) +;; Requires that stream is a total order in regards to what we filter +;; on. From there it knows that once it has found the first element +;; that satisfies our predicate all remaining elements satisfying pred +;; will be in direct succession. +(define-public (filter-sorted-stream pred stream) (stream-take-while - proc (stream-drop-while - (negate proc) stream))) + pred (stream-drop-while + (negate pred) stream))) + +;; Simmilar to the regular @code{filter-sorted-stream}, but once an +;; element satisfies @code{keep-remaning?} then the remaining tail +;; of the stream is all assumed to be good. (define-public (filter-sorted-stream* pred? keep-remaining? stream) (cond [(stream-null? stream) stream-null] [(keep-remaining? (stream-car stream)) stream] diff --git a/module/vcomponent/group.scm b/module/vcomponent/group.scm index 7733d981..46160a3a 100644 --- a/module/vcomponent/group.scm +++ b/module/vcomponent/group.scm @@ -20,6 +20,11 @@ (let ((head (stream-take-while (ein? day) stream)) (tail + ;; This is a filter, instead of a stream-span together with head, + ;; since events can span multiple days. + ;; This starts with taking everything which end after the beginning + ;; of tommorow, and finishes with the rest when it finds the first + ;; object which begins tomorow (after midnight, exclusize). (filter-sorted-stream* (lambda (e) (time Date: Sun, 6 Oct 2019 13:35:14 +0200 Subject: Remove old C code. --- Makefile | 12 -- src/calendar.c | 2 - src/calendar.h | 2 - src/graphs.c.old | 144 -------------------- src/graphs.h.old | 15 --- src/guile_interface.h.disabled | 28 ---- src/guile_interface.scm.c.disabled | 261 ------------------------------------- src/linked_list.h | 93 ------------- src/linked_list.inc.h | 179 ------------------------- src/main.c.old | 120 ----------------- src/pair.h | 19 --- src/pair.inc.h | 34 ----- src/trie.h | 54 -------- src/trie.inc.h | 231 -------------------------------- src/vcal.c.old | 175 ------------------------- src/vcal.h.old | 120 ----------------- 16 files changed, 1489 deletions(-) delete mode 100644 src/graphs.c.old delete mode 100644 src/graphs.h.old delete mode 100644 src/guile_interface.h.disabled delete mode 100644 src/guile_interface.scm.c.disabled delete mode 100644 src/linked_list.h delete mode 100644 src/linked_list.inc.h delete mode 100644 src/main.c.old delete mode 100644 src/pair.h delete mode 100644 src/pair.inc.h delete mode 100644 src/trie.h delete mode 100644 src/trie.inc.h delete mode 100644 src/vcal.c.old delete mode 100644 src/vcal.h.old diff --git a/Makefile b/Makefile index 6f25d5c5..a3fe93d2 100644 --- a/Makefile +++ b/Makefile @@ -33,10 +33,6 @@ GUILE_C_FLAGS = -Lmodule \ all: $(SO_FILES) $(GO_FILES) -# Old C main -parse: $(O_FILES) - $(CC) -o $@ $^ $(LDFLAGS) - src/%.x : src/%.scm.c guile-snarf -o $@ $< $(CFLAGS) @@ -56,13 +52,6 @@ obj/%.scm.go: %.scm # $(SO_FILES) @mkdir -p obj guild compile $(GUILE_C_FLAGS) -o $@ $< -.SECONDARY += %.dot -%.dot: testcal/%.ics parse - ./parse $< -g $@ - -%.pdf: %.dot - dot -Tpdf -o $@ $< - html: $(GO_FILES) mkdir -p html ln -sf ../static html @@ -73,7 +62,6 @@ tags: $(C_FILES) $(H_FILES) ./rfc-tags rfc5545.txt >> tags clean: - -rm parse -rm -r html -rm -r obj -rm -r lib diff --git a/src/calendar.c b/src/calendar.c index f3a9b254..1362ee2e 100644 --- a/src/calendar.c +++ b/src/calendar.c @@ -11,7 +11,6 @@ #include #include "struct.h" - #include "parse.h" #include "err.h" @@ -46,7 +45,6 @@ int handle_file(SCM cal, char* path) { /* NAME is the `fancy' name of the calendar. */ // vcomponent_push_val(cal, "NAME", basename(path)); - // vcomponent_push_val(cal, "X-HNH-SOURCETYPE", "file"); SCM line = scm_make_vline(scm_from_utf8_string("file")); scm_add_line_x(cal, scm_from_utf8_string("X-HNH-SOURCETYPE"), line); char* resolved_path = realpath(path, NULL); diff --git a/src/calendar.h b/src/calendar.h index 3e6941f9..776d9900 100644 --- a/src/calendar.h +++ b/src/calendar.h @@ -3,8 +3,6 @@ #include -// #include "vcal.h" - /* * Reads all ics flies in path into the given vcomponent. The * component is assumed to be a abstract ROOT element, whose first diff --git a/src/graphs.c.old b/src/graphs.c.old deleted file mode 100644 index 51a26117..00000000 --- a/src/graphs.c.old +++ /dev/null @@ -1,144 +0,0 @@ -#include "graphs.h" - -#include -#include -#include -#include "err.h" - -// #define TYPE strbuf -// #include "linked_list.h" -// #include "linked_list.inc.h" -// #undef TYPE - -int create_graph_trie (vcomponent* ev, char* filename) { - FILE* f = fopen(filename, "w"); - - fputs("digraph {\n rankdir=LR;", f); - trie_to_dot(&ev->clines, f); - fputs("}", f); - - fclose(f); - - INFO_F("Wrote '%s' to '%s'", vcomponent_get_val(ev, "X-HNH-FILENAME"), filename); - - return 0; -} - -int helper_vcomponent (vcomponent* root, FILE* f) { - fprintf(f, "subgraph \"cluster_root\" { label=File; \"%p\" [label=%s] }\n", root, root->type); - - TRIE(content_line)* trie = &root->clines; - TRIE_NODE(content_line)* n = trie->root->child; - - if (! EMPTY(TRIE(content_line))(trie)) { - fprintf(f, "subgraph \"cluster_%p\" {\n", root); - fprintf(f, "\"%p\" [label=trie fontcolor=gray, color=gray];", trie); - fprintf(f, "\"%p\" -> \"%p\" [color=red]\n", root, trie); - while (n != NULL) { - fprintf(f, "\"%p\" -> \"%p\" [color=gray]\n", - (void*) trie, - (void*) n); - fprintf(f, "subgraph \"cluster_%c_%p\" {\ncolor=red; \n", - n->c, root); - trie_to_dot_helper( n, f ); - - - fputs("}", f); - n = n->next; - } - fputs("}", f); - } - - FOR(LLIST, vcomponent, child, &root->components) { - fprintf(f, "\"%p\" -> \"%p\"\n", root, child); - helper_vcomponent(child, f); - } - return 0; -} - -int create_graph_vcomponent (vcomponent* root, char* outfile) { - FILE* f = fopen(outfile, "w"); - if (f == NULL) { - ERR_F("Error opening file %s, errno = %i", outfile, errno); - return 1; - } - vcomponent* c = root; - fputs("digraph {", f); - helper_vcomponent(c, f); - fputs("}", f); - fclose(f); - return 0; -} - -#define T content_line - -int trie_to_dot ( TRIE(T)* trie, FILE* f ) { - TRIE_NODE(T)* n = trie->root->child; - fprintf(f, "\"%p\" [label=root fontcolor=gray, color=gray];", trie); - while (n != NULL) { - fprintf(f, "\"%p\" -> \"%p\" [color=gray]\n", - (void*) trie, - (void*) n); - fprintf(f, "subgraph \"cluster_%c\" {\n", - n->c); - trie_to_dot_helper( n, f ); - fputs("}", f); - n = n->next; - } - return 0; -} - -int trie_to_dot_helper ( TRIE_NODE(T)* root, FILE* f ) { - if (L(root) == NULL) { - fprintf(f, "\"%p\"[label = \"%c\" style=filled fillcolor=white];\n", - (void*) root, root->c); - } else { - fprintf(f, "\"%p\"[label = \"%c [%i]\" style=filled fillcolor=green];\n", - (void*) root, root->c, - SIZE(LLIST(content_set))(L(root)) - ); - } - TRIE_NODE(T)* child = root->child; - - // ---------------------------------------- -#if 1 /* Toggle values */ - if (L(root) != NULL) { - - FOR(LLIST, content_set, v, L(root)) { - char buf[0x100]; - FMT(strbuf)(&v->key, buf); - fprintf(f, "\"%p\" [label=\"%s\" shape=rectangle color=darkgreen];\n", - v, buf); - /* Edge between TRIE char node and data node */ - fprintf(f, "\"%p\" -> \"%p\";\n", root, v); - - /* Parameters */ - LLIST(strbuf)* keys = KEYS(TRIE(param_set))(&v->val); - FOR(LLIST, strbuf, key, keys) { - param_set* p = GET(TRIE(param_set))(&v->val, key->mem); - - fprintf(f, "\"%p\" [label=\"%s\" color=blue];\n", - key, key->mem); - /* Edge between data node and param key node */ - fprintf(f, "\"%p\" -> \"%p\";", v, key); - - FOR(LLIST, strbuf, str, p) { - fprintf(f, "\"%p\" [label=\"%s\" color=orange];", - str, str->mem); - /* Edge between param key node and param value node */ - fprintf(f, "\"%p\" -> \"%p\";", key, str); - } - } - } - } -#endif - // ---------------------------------------- - - while (child != NULL) { - fprintf(f, "\"%p\" -> \"%p\";\n", - (void*) root, (void*) child); - trie_to_dot_helper(child, f); - child = child->next; - } - return 0; -} diff --git a/src/graphs.h.old b/src/graphs.h.old deleted file mode 100644 index fe521003..00000000 --- a/src/graphs.h.old +++ /dev/null @@ -1,15 +0,0 @@ -#ifndef GRAPHS_H -#define GRAPHS_H - -#include "vcal.h" - -int create_graph_trie (vcomponent* ev, char* filename); - -int create_graph_vcomponent (vcomponent* root, char* outfile); - -int helper_vcomponent (vcomponent* root, FILE* f); - -int trie_to_dot ( TRIE(content_line)*, FILE* ); -int trie_to_dot_helper ( TRIE_NODE(content_line)*, FILE* ); - -#endif /* GRAPHS_H */ diff --git a/src/guile_interface.h.disabled b/src/guile_interface.h.disabled deleted file mode 100644 index 76ec24d3..00000000 --- a/src/guile_interface.h.disabled +++ /dev/null @@ -1,28 +0,0 @@ -#ifndef GUILE_INTERFACE_H -#define GUILE_INTERFACE_H - -#include -#include "vcal.h" - -/* - * At a number of places scm_gc_{un,}protect_object is called. - * This is needed since most of my structures are allocated with the - * regular malloc, instead of the scm_gc_malloc variants. - * This leads to the garbage collector not realizing that I still have - * the components, and deletes them. - * - * The protection markers stop the GC from doing its thing. - */ - -void init_lib (void); -void init_vcomponent_type (void); - -SCM make_vcomponent (SCM); -SCM vcomponent_get_attribute (SCM, SCM); -SCM vcomponent_child_count (SCM); -SCM vcomponent_children (SCM); -SCM vcomponent_typeof (SCM); - -SCM scm_from_vcomponent (vcomponent*); - -#endif /* GUILE_INTERFACE_H */ diff --git a/src/guile_interface.scm.c.disabled b/src/guile_interface.scm.c.disabled deleted file mode 100644 index 20c413df..00000000 --- a/src/guile_interface.scm.c.disabled +++ /dev/null @@ -1,261 +0,0 @@ -#include "guile_interface.h" - -#include "calendar.h" -#include "guile_type_helpers.h" - -static SCM vcomponent_type; -static SCM content_set_lists; - -void init_vcomponent_type (void) { - SCM name = scm_from_utf8_symbol("vcomponent"); - SCM slots = scm_list_1(scm_from_utf8_symbol("data")); - - vcomponent_type = scm_make_foreign_object_type(name, slots, NULL); -} - -SCM_DEFINE (make_vcomponent, "%vcomponent-make", 0, 1, 0, - (SCM path), - "Loads a vdir iCalendar from the given path.") -{ - vcomponent* cal = - (vcomponent*) scm_gc_malloc ( - sizeof(*cal), "vcomponent"); - - if (SCM_UNBNDP(path)) { - INIT(vcomponent, cal); - } else { - INIT(vcomponent, cal, "ROOT"); - - char* p = scm_to_utf8_stringn(path, NULL); - read_vcalendar(cal, p); - free(p); - } - - return scm_from_vcomponent (cal); -} - -/* - * Returns a line from a component. - */ -SCM_DEFINE (vcomponent_get_attribute, "%vcomponent-get-attribute", 2, 0, 0, - (SCM calendar, SCM attr), - "Retuns the given attribute from the vevent object at index in calendar.") -{ - scm_assert_foreign_object_type (vcomponent_type, calendar); - vcomponent* cal = scm_foreign_object_ref (calendar, 0); - - const char* key = scm_i_string_chars (attr); - content_line* c = get_attributes (cal, key); - - if (c == NULL) { - vcomponent_push_val(cal, key, ""); - c = get_attributes (cal, key); - c->cval->key.scm = SCM_BOOL_F; - } - - SCM ptr = scm_from_pointer(c, NULL); - SCM ret = scm_hashq_ref (content_set_lists, ptr, SCM_BOOL_F); - if (! scm_is_false (ret)) { - return ret; - } - - SCM val, proplist; - SCM attrroot = scm_list_1(SCM_BOOL_F); - SCM attrlist = attrroot; - LLIST(strbuf) *triekeys, *trievals; - - /* For every instance of a line */ - FOR (LLIST, content_set, v, c) { - val = scm_from_strbuf(&v->key); - - if (! scm_is_pair(val)) { - // TODO look into using a weak hash table instead - - // TODO why is it an error to unprotect the object here? - // scm_from_strbuf should already have protected it... - // scm_gc_unprotect_object(v->key.scm); - SCM htable = scm_make_hash_table (scm_from_ulong(32)); - val = scm_cons(val, htable); - v->key.scm = val; - scm_gc_protect_object(v->key.scm); - - triekeys = KEYS(TRIE(param_set))(&v->val); - /* For every property key bound to the current attribute */ - FOR (LLIST, strbuf, k, triekeys) { - proplist = SCM_EOL; - - trievals = GET(TRIE(param_set))(&v->val, k->mem); - /* For every value bound to the current property */ - FOR (LLIST, strbuf, s, trievals) { - proplist = scm_cons(scm_from_strbuf(s), proplist); - } - - scm_hashq_set_x(htable, scm_from_strbuf_symbol(k), - scm_reverse(proplist)); - } - } - - attrlist = scm_cons(val, attrlist); - } - - /* create circular list */ - scm_set_cdr_x (attrroot, attrlist); - - - scm_hashq_set_x (content_set_lists, ptr, attrlist); - - return attrlist; -} - -SCM_DEFINE (vcomponent_child_count, "%vcomponent-child-count", 1, 0, 0, - (SCM component), - "Returns number of child components.") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* c = scm_foreign_object_ref (component, 0); - return scm_from_size_t (SIZE(LLIST(vcomponent))(&c->components)); -} - -SCM_DEFINE(vcomponent_children, "%vcomponent-children", 1, 0, 0, - (SCM component), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* cal = scm_foreign_object_ref (component, 0); - - SCM llist = SCM_EOL; - FOR (LLIST, vcomponent, v, &cal->components) { - llist = scm_cons(scm_from_vcomponent(v), llist); - } - return llist; -} - -SCM_DEFINE(vcomponent_filter_children_x, "%vcomponent-filter-children!", - 2, 0, 0, - (SCM pred, SCM component), - "Remove all children from component who DOESN'T satisfy `pred`") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* cal = scm_foreign_object_ref (component, 0); - - for (LINK(vcomponent)* l = FIRST(&cal->components); - l->after != NULL; - l = l->after) - { - if (scm_is_false(scm_call_1 (pred, scm_from_vcomponent(l->value)))) { - FFREE(vcomponent, l->value); - UNLINK(LINK(vcomponent))(l); - } - } - - return SCM_UNSPECIFIED; -} - -SCM_DEFINE(vcomponent_push_child_x, "%vcomponent-push-child!", 2, 0, 0, - (SCM component, SCM child), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - scm_assert_foreign_object_type (vcomponent_type, child); - vcomponent* comp = scm_foreign_object_ref (component, 0); - vcomponent* chil = scm_foreign_object_ref (child, 0); - - PUSH(vcomponent)(comp, chil); - - return SCM_UNSPECIFIED; -} - -SCM_DEFINE (vcomponent_parent, "%vcomponent-parent", 1, 0, 0, - (SCM component), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - - vcomponent* parent = comp->parent; - if (strcmp(parent->type, "ROOT") == 0) { - return SCM_BOOL_F; - } else { - return scm_from_vcomponent(parent); - } -} - -SCM_DEFINE(vcomponent_typeof, "%vcomponent-get-type", 1, 0, 0, - (SCM component), - "Returns type of vcomponent") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - - if (comp->scmtype == NULL) { - comp->scmtype = scm_from_utf8_symbol(comp->type); - } - - return comp->scmtype; -} - -SCM_DEFINE(vcomponent_set_type_x, "%vcomponent-set-type!", 2, 0, 0, - (SCM component, SCM type), - "Replace current type of vcomponent") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - - if (comp->type) free (comp->type); - - char* ntype = scm_to_utf8_stringn (type, NULL); - comp->type = calloc(sizeof(*ntype), strlen(ntype) + 1); - strcpy(comp->type, ntype); - - return SCM_UNSPECIFIED; -} - -SCM scm_from_vcomponent(vcomponent* v) { - if (v->scm == NULL) { - v->scm = scm_make_foreign_object_1 (vcomponent_type, v); - scm_gc_protect_object(v->scm); - } - return v->scm; -} - -SCM_DEFINE(vcomponent_attr_list, "%vcomponent-attribute-list", 1, 0, 0, - (SCM component), - "Returns list of all keys in component.") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - LLIST(strbuf)* keys = KEYS(TRIE(content_line))(&comp->clines); - - SCM llist = SCM_EOL; - FOR (LLIST, strbuf, s, keys) { - llist = scm_cons(scm_from_strbuf(s), llist); - } - - FFREE(LLIST(strbuf), keys); - - return llist; -} - -SCM_DEFINE(vcomponent_shallow_copy, "%vcomponent-shallow-copy", 1, 0, 0, - (SCM component), - "Creates a shallow copy of the given component.") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* src = scm_foreign_object_ref (component, 0); - - vcomponent* dest = - (vcomponent*) scm_gc_malloc ( - sizeof(*dest), "vcomponent"); - INIT(vcomponent, dest, src->type, NULL); - vcomponent_copy (dest, src); - return scm_from_vcomponent (dest); -} - -void init_lib (void) { - init_vcomponent_type(); - content_set_lists = scm_make_weak_key_hash_table (scm_from_uint(0x100)); - -#ifndef SCM_MAGIC_SNARFER -#include "guile_interface.x" -#endif -} diff --git a/src/linked_list.h b/src/linked_list.h deleted file mode 100644 index 0d32b988..00000000 --- a/src/linked_list.h +++ /dev/null @@ -1,93 +0,0 @@ -#ifndef LINKED_LIST_H -#define LINKED_LIST_H - -#include "macro.h" - -#define LLIST(T) TEMPL(llist, T) -#define LINK(T) TEMPL(llist_link, T) - -#define UNLINK(T) TEMPL(unlink, T) - -#endif /* LINKED_LIST_H */ -#ifdef TYPE - -typedef struct LINK(TYPE) { - struct LINK(TYPE)* before; - struct LINK(TYPE)* after; - TYPE* value; -} LINK(TYPE); - -#define L(link) (link)->value - -typedef struct { - LINK(TYPE)* head; - LINK(TYPE)* tail; - LINK(TYPE)* cur; - TYPE* cval; - int length; -} LLIST(TYPE); - -#define FIRST(lst) (lst)->head->after -#define FIRST_V(lst) (lst)->head->after->value -#define LAST(lst) (lst)->tail->before -#define LAST_V(lst) (lst)->tail->before->value - -INIT_F ( LLIST(TYPE) ); - -/* - * NOTE freeing a linked list alsa FFREE's all its contents. - * TODO some form of shared pointer to ensure nothing is free'd twice - * would be a good idea. - */ -FREE_F ( LLIST(TYPE) ); - -INIT_F ( LINK(TYPE) ); -INIT_F ( LINK(TYPE), TYPE* val ); -FREE_F ( LINK(TYPE) ); - -int UNLINK(LINK(TYPE)) ( LINK(TYPE)* ); - -int PUSH(LLIST(TYPE)) ( LLIST(TYPE)*, TYPE* ); -TYPE* PEEK(LLIST(TYPE)) ( LLIST(TYPE)* ); -TYPE* POP(LLIST(TYPE)) ( LLIST(TYPE)* ); - -int DEEP_COPY(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* src ); - -int APPEND(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* new_ ); - -int SIZE(LLIST(TYPE)) ( LLIST(TYPE)* llist ); -int EMPTY(LLIST(TYPE)) ( LLIST(TYPE)* llist ); - -/* - * Resets a linked list by removing all it's objects. - * FREE's all elements stored in the list. - */ -int RESET(LLIST(TYPE)) ( LLIST(TYPE)* llist ); - -/* - * Takes to lists, and merges them into a single one. Destroys new_ in - * the process. - */ -LLIST(TYPE)* RESOLVE(LLIST(TYPE)) (LLIST(TYPE)* dest, LLIST(TYPE)* new_); - -FMT_F(LLIST(TYPE)); - -/* Iterator */ - -#define __PRE_LLIST(T, l, set) \ - T* l; LINK(T)* __INTER(l); - -#define PRE_FOR_LLIST(T) __PRE_LLIST - -// #define __BEG_LLIST(v, set) v = (set)->head -#define __BEG_LLIST(T, l, set) __INTER(l) = FIRST(set), l = L(__INTER(l)) -#define BEG_LLIST(T) __BEG_LLIST - -#define __END_LLIST(T, l, set) __INTER(l) != (set)->tail -#define END_LLIST(T) __END_LLIST - -#define __NXT_LLIST(T, l, set) __INTER(l) = __INTER(l)->after, l = L(__INTER(l)) -// #define __NXT_LLIST(T, l, set) l = L(__INTER(l) = __INTER(l)->after) -#define NXT_LLIST(T) __NXT_LLIST - -#endif /* TYPE */ diff --git a/src/linked_list.inc.h b/src/linked_list.inc.h deleted file mode 100644 index 3984e485..00000000 --- a/src/linked_list.inc.h +++ /dev/null @@ -1,179 +0,0 @@ -#ifndef TYPE -#error "Set TYPE before including self file" -#else - -INIT_F ( LLIST(TYPE) ) { - self->length = 0; - NEW(LINK(TYPE), head); - NEW(LINK(TYPE), tail); - self->head = head; - self->tail = tail; - head->after = tail; - tail->before = head; - self->cur = head; - self->cval = head->value; - return 0; -} - -FREE_F (LINK(TYPE)) { - UNLINK(LINK(TYPE))(self); - - if (self->value != NULL) FFREE(TYPE, self->value); - return 0; -} - -FREE_F( LLIST(TYPE) ) { - LINK(TYPE) *n, *next; - n = self->head; - while ( n != NULL ) { - next = n->after; - FFREE(LINK(TYPE), n); - n = next; - } - - self->length = -1; - - return 0; -} - -INIT_F ( LINK(TYPE) ) { - self->before = NULL; - self->after = NULL; - self->value = NULL; - return 0; -} - -INIT_F ( LINK(TYPE), TYPE* val ) { - self->before = NULL; - self->after = NULL; - self->value = val; - return 0; -} - -int UNLINK(LINK(TYPE)) ( LINK(TYPE)* self ) { - if (self->before != NULL) self->before->after = self->after; - if (self->after != NULL) self->after->before = self->before; - return 0; -} - - -int PUSH(LLIST(TYPE)) ( LLIST(TYPE)* lst, TYPE* val) { - NEW(LINK(TYPE), link, val); - - link->after = FIRST(lst); - FIRST(lst) = link; - - link->after->before = link; - link->before = lst->head; - - ++lst->length; - - // TODO do I want to change that? - lst->cur = link; - lst->cval = link->value; - - return 0; -} - -TYPE* PEEK(LLIST(TYPE)) ( LLIST(TYPE)* lst ) { - if (EMPTY(LLIST(TYPE))(lst)) return NULL; - - return FIRST(lst)->value; -} - -TYPE* POP(LLIST(TYPE)) ( LLIST(TYPE)* lst) { - if (EMPTY(LLIST(TYPE))(lst)) return NULL; - - LINK(TYPE)* frst = FIRST(lst); - UNLINK(LINK(TYPE))(frst); - - TYPE* retval = frst->value; - --lst->length; - free (frst); - return retval; -} - -int DEEP_COPY(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* src ) { - LINK(TYPE)* n = FIRST(src); - - while (n->after != NULL) { - NEW(TYPE, cpy); - DEEP_COPY(TYPE)(cpy, n->value); - PUSH(LLIST(TYPE)) ( dest, cpy ); - n = n->after; - } - - return 0; -} - -/* - * Adds two linked lists together. - * O(1) time. - * destroys new__ in the process, but keeps the elements. - * make sure to free(new__) after. - */ -int APPEND(LLIST(TYPE)) ( LLIST(TYPE)* dest, LLIST(TYPE)* new__ ) { - - /* Link end of dest onto start of new__. */ - LAST(dest)->after = FIRST(new__); - FIRST(new__)->before = LAST(dest); - - /* Free the two now not needed end links. */ - free(new__->head); - free(dest->tail); - - /* Update dest with new__ tail ptr. */ - dest->tail = new__->tail; - - dest->length += new__->length; - - return 0; -} - -int SIZE(LLIST(TYPE)) ( LLIST(TYPE)* llist ) { - return llist->length; -} - -int EMPTY(LLIST(TYPE)) ( LLIST(TYPE)* llist ) { - return FIRST(llist) == llist->tail; -} - -LLIST(TYPE)* RESOLVE(LLIST(TYPE)) (LLIST(TYPE)* dest, LLIST(TYPE)* new__) { - if (dest == NULL) return new__; - APPEND(LLIST(TYPE))(dest, new__); - free(new__); - return dest; -} - -int RESET(LLIST(TYPE)) ( LLIST(TYPE)* llist ) { - - LINK(TYPE) *link = FIRST(llist), *next; - /* - * Manual looping rather than itterators since we destroyed the - * loop variable. - */ - while (link != llist->tail) { - next = link->after; - FFREE(LINK(TYPE), link); - link = next; - } - - llist->cur = llist->head; - llist->cval = llist->head->value; - - return 0; -} - -FMT_F(LLIST(TYPE)) { - int seek = 0; - fmtf("("); - FOR(LLIST, TYPE, v, self) { - seek += FMT(TYPE)(v, buf + seek); - fmtf(" "); - } - fmtf(")"); - - return seek; -} - -#endif /* TYPE */ diff --git a/src/main.c.old b/src/main.c.old deleted file mode 100644 index 4d8da7d3..00000000 --- a/src/main.c.old +++ /dev/null @@ -1,120 +0,0 @@ -#include -#include -#include -#include - -#include "calendar.h" -#include "macro.h" -#include "vcal.h" -#include "graphs.h" -#include "err.h" - -typedef struct { - int argc; - char** argv; -} arg; - -int arg_shift (arg* a) { - if (a->argc == 0) return 0; - - ++a->argv; - return --a->argc; - -} - -#define GETSET(C, KEY) \ - vcomponent_push_val((C), (KEY), "DUMMY VALUE"); \ - INFO_F("cline = %p", get_attributes((C), (KEY))); - -/* - * Tests defined here instead of in own header to ensure that all the - * correct modules are loaded. - */ -int run_tests() { - NEW(vcomponent, c); - INFO(All the following should print a valid pointer != 0x0); - GETSET(c, "FILENAME"); - GETSET(c, "X-HNH-FILENAME"); - GETSET(c, "DATA"); - GETSET(c, "DAT"); - GETSET(c, "DA"); - GETSET(c, "D"); - GETSET(c, "A"); - GETSET(c, "F"); - FFREE(vcomponent, c); - return 0; -} - -int main (int argc, char** argv) { - arg args = { .argc = argc, .argv = argv }; - - - if (arg_shift(&args) == 0) { - ERR("Please give something to parse, or some other flags"); - exit (1); - } - - if (strcmp(args.argv[0], "--run-tests") == 0) { - run_tests(); - return 0; - } - - char* rootpath = args.argv[0]; - SNEW(vcomponent, root, "ROOT", rootpath); - read_vcalendar(&root, rootpath); - - arg_shift(&args); - - if (args.argc == 0 || strcmp(args.argv[0], "-p") == 0) { - INFO_F("Parsed calendar file containing [%u] events", - root.components.length); - - puts("CAL : OBJ | Filename | Description"); - puts("----------+----------+------------"); - - /* This loops over all VCALENDAR's in root */ - FOR (LLIST, vcomponent, cal, &root.components) { - assert(strcmp(cal->type, "VCALENDAR") == 0); - - char* filename = vcomponent_get_val(cal, "X-HNH-FILENAME"); - - /* This loop over all VEVENT's in the current VCALENDAR */ - FOR (LLIST, vcomponent, ev, &cal->components) { - if (strcmp(ev->type, "VEVENT") != 0) continue; - - printf("%s | %s\n", - filename, - get_attributes(ev, "SUMMARY")->cval->key.mem); - } - } - } else if (strcmp(args.argv[0], "-g") == 0) { - /* TODO self might be broken */ - if (arg_shift(&args) == 0) { - FOR (LLIST, vcomponent, cal, &root.components) { - assert(strcmp(cal->type, "VCALENDAR") == 0); - - vcomponent* ev = FCHILD(cal); - - char target[0xFF]; - target[0] = '\0'; - strcat(target, "/tmp/dot/"); - strcat(target, vcomponent_get_val(ev, "X-HNH-FILENAME")); - strcat(target, ".dot"); - // create_graph(ev, target); - } - } else { - // create_graph(FCHILD(FCHILD(&root)), args.argv[0]); - INFO("Creating graph for single file"); - INFO_F("output = %s\n", args.argv[0]); - create_graph_vcomponent(&root, args.argv[0]); - } - } - - /* - char buf[0x20000]; - FMT(vcomponent)(&root, buf); - puts(buf); - */ - - FREE(vcomponent)(&root); -} diff --git a/src/pair.h b/src/pair.h deleted file mode 100644 index e96cf180..00000000 --- a/src/pair.h +++ /dev/null @@ -1,19 +0,0 @@ -#ifndef PAIR_H -#define PAIR_H - -#define PAIR(T, V) TEMPL2(pair, T, V) - -#endif /* PAIR_H */ -#if defined(T) && defined(V) - -typedef struct { - T key; - V val; -} PAIR(T, V); - -INIT_F(PAIR(T, V)); -FREE_F(PAIR(T, V)); -FMT_F(PAIR(T, V)); -int DEEP_COPY(PAIR(T, V)) (PAIR(T, V)* dest, PAIR(T, V)* src); - -#endif diff --git a/src/pair.inc.h b/src/pair.inc.h deleted file mode 100644 index c42b2dfd..00000000 --- a/src/pair.inc.h +++ /dev/null @@ -1,34 +0,0 @@ -#if ! (defined(T) && defined(V)) -#error "Both T and V must be defiend here" -#else - -INIT_F(PAIR(T, V)) { - INIT(T, &self->key); - INIT(V, &self->val); - - return 0; -} - -FREE_F(PAIR(T, V)) { - FREE(T)(&self->key); - FREE(V)(&self->val); - - return 0; -} - -FMT_F(PAIR(T, V)) { - char lbuf[0x100]; - char rbuf[0x1000]; - FMT(T)(&self->key, lbuf); - FMT(V)(&self->val, rbuf); - - return sprintf(buf, "<%s, %s>", lbuf, rbuf); -} - -int DEEP_COPY(PAIR(T, V)) (PAIR(T, V)* dest, PAIR(T, V)* src) { - DEEP_COPY(T)(&dest->key, &src->key); - DEEP_COPY(V)(&dest->val, &src->val); - return 0; -} - -#endif /* T & V */ diff --git a/src/trie.h b/src/trie.h deleted file mode 100644 index 9de38be3..00000000 --- a/src/trie.h +++ /dev/null @@ -1,54 +0,0 @@ -#ifndef TRIE_H -#define TRIE_H - -#include - -#include "macro.h" - -#define TRIE(T) TEMPL(trie, T) -#define TRIE_NODE(T) TEMPL(trie_node, T) - -#endif /* TRIE_H */ -#ifdef TYPE - -#include "linked_list.h" -#include "strbuf.h" - -typedef struct TRIE_NODE(TYPE) { - char c; - TYPE* value; - struct TRIE_NODE(TYPE)* next; - struct TRIE_NODE(TYPE)* child; -} TRIE_NODE(TYPE); - -typedef struct { - TRIE_NODE(TYPE)* root; -} TRIE(TYPE); - - -INIT_F ( TRIE(TYPE) ); - -INIT_F (TRIE_NODE(TYPE), char c); - -INIT_F (TRIE_NODE(TYPE), - char c, TRIE_NODE(TYPE)* next, TRIE_NODE(TYPE)* child ); - -int PUSH(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key, TYPE* val ); - -TYPE* GET(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key ); - -FREE_F(TRIE_NODE(TYPE)); - -FREE_F(TRIE(TYPE)); - -int EMPTY(TRIE(TYPE))(TRIE(TYPE)*); - -FMT_F(TRIE_NODE(TYPE)); -FMT_F(TRIE(TYPE)); - -int DEEP_COPY(TRIE_NODE(TYPE)) (TRIE_NODE(TYPE)* dest, TRIE_NODE(TYPE)* src); -int DEEP_COPY(TRIE(TYPE)) (TRIE(TYPE)* dest, TRIE(TYPE)* src); - -LLIST(strbuf)* KEYS(TRIE(TYPE)) (TRIE(TYPE)*); - -#endif /* TYPE */ diff --git a/src/trie.inc.h b/src/trie.inc.h deleted file mode 100644 index 64e5239d..00000000 --- a/src/trie.inc.h +++ /dev/null @@ -1,231 +0,0 @@ -#ifndef TYPE -#error "Set TYPE before including self file" -#else - -#include - -#include "err.h" -#include "macro.h" -#include "linked_list.inc.h" -#include "strbuf.h" - -INIT_F ( TRIE(TYPE) ) { - NEW(TRIE_NODE(TYPE), t, '\0'); - self->root = t; - return 0; -} - -INIT_F (TRIE_NODE(TYPE), char c) { - self->c = c; - self->value = NULL; - self->next = NULL; - self->child = NULL; - return 0; -} - -INIT_F (TRIE_NODE(TYPE), - char c, - TRIE_NODE(TYPE)* next, - TRIE_NODE(TYPE)* child ) -{ - self->c = c; - self->next = next; - self->child = child; - return 0; -} - -int PUSH(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key, TYPE* val ) { - TRIE_NODE(TYPE) *cur, *last; - - last = trie->root; - cur = last->child; - - char* subkey = key; - - while (1) { - if (cur == NULL) { - /* Build direct LL for remaining subkey */ - for (char* c = subkey; c[0] != '\0'; c++) { - NEW(TRIE_NODE(TYPE), t, *c); - last->child = t; - last = t; - } - last->value = RESOLVE(TYPE)(last->value, val); - return 0; - } else if (cur->c == subkey[0]) { - /* This node belongs to the key, - * Decend further */ - last = cur; - cur = cur->child; - subkey++; - } else if (subkey[0] == '\0') { - /* Key finished */ - last->value = RESOLVE(TYPE)(last->value, val); - return 0; - } else if (cur->next != NULL) { - /* This node was not part of the set, but it's sibling might */ - cur = cur->next; - /* `last` not set since we aren't moving down */ - } else { - /* No node on self level was part of the set, create a new__ - * sibling and follow down that parse */ - NEW(TRIE_NODE(TYPE), t, *subkey); - cur->next = t; - last = cur; - cur = t; - } - } - - return 0; -} - -/* - * TODO what happens when I give an invalid key? - */ -TYPE* GET(TRIE(TYPE)) ( TRIE(TYPE)* trie, char* key ) { - TRIE_NODE(TYPE)* n = trie->root->child; - char* subkey = key; - - while (n != NULL) { - if (subkey[0] == n->c) { - if (subkey[1] == '\0') { - /* Wanted node found, - * value can however be NULL */ - return n->value; - } else { - n = n->child; - subkey++; - } - } else { - n = n->next; - } - - } - - /* Position not found */ - return 0; -} - -FREE_F(TRIE_NODE(TYPE)) { - if (self == NULL) return 0; - if (self->value != NULL) FFREE(TYPE, self->value); - if (self->next != NULL) FREE(TRIE_NODE(TYPE))(self->next); - if (self->child != NULL) FREE(TRIE_NODE(TYPE))(self->child); - free (self); - return 0; -} - -FREE_F(TRIE(TYPE)) { - if (self->root->c != '\0') { - // ERR("Invalid trie"); - return 1; - } - return FREE(TRIE_NODE(TYPE))(self->root); -} - -int EMPTY(TRIE(TYPE))(TRIE(TYPE)* self) { - return self->root->child == NULL; -} - -FMT_F(TRIE_NODE(TYPE)) { - - va_list ap; - va_start(ap, buf); - int argc = va_arg(ap, int); - int depth = argc >= 1 - ? va_arg(ap, int) - : 0; - va_end(ap); - - int seek = 0; - - TRIE_NODE(TYPE)* n = self; - - if (n == NULL) { fmtf("\n"); } - while (n != NULL) { - fmtf("|"); - // FOR(int, i, depth) fmtf(" "); - for (int i = 0; i < depth; i++) fmtf(" "); - fmtf("%c ", n->c == '\0' ? '0' : n->c); - if (n->value != NULL) { - seek += FMT(TYPE)(n->value, buf + seek); - fmtf("\n"); - } - - if (n->child != NULL) { - fmtf("\n"); - seek += FMT(TRIE_NODE(TYPE))(n->child, buf + seek, depth + 1); - } - n = n->next; - } - return seek; - -} - -FMT_F(TRIE(TYPE)) { - int seek = 0; - fmtf("Trie: %p: {", self); - if (EMPTY(TRIE(TYPE))(self)) { - fmtf(" [EMPTY] "); - } else { - fmtf("\n"); - seek += FMT(TRIE_NODE(TYPE))(self->root->child, buf + seek); - } - fmtf("}"); - return seek; -} - -int DEEP_COPY(TRIE_NODE(TYPE)) (TRIE_NODE(TYPE)* dest, TRIE_NODE(TYPE)* src) { - dest->c = src->c; - - if (src->value != NULL) { - RENEW(TYPE, dest->value); - DEEP_COPY(TYPE)(dest->value, src->value); - } - - if (src->next != NULL) { - RENEW(TRIE_NODE(TYPE), dest->next, '\0'); - DEEP_COPY(TRIE_NODE(TYPE))(dest->next, src->next); - } - - if (src->child != NULL) { - RENEW(TRIE_NODE(TYPE), dest->child, '\0'); - DEEP_COPY(TRIE_NODE(TYPE))(dest->child, src->child); - } - - return 0; -} - -int DEEP_COPY(TRIE(TYPE)) (TRIE(TYPE)* dest, TRIE(TYPE)* src) { - return DEEP_COPY(TRIE_NODE(TYPE))(dest->root, src->root); -} - -void KEYS(TRIE_NODE(TYPE)) (TRIE_NODE(TYPE)* node, LLIST(strbuf)* list, strbuf* path) { - if (node == NULL) return; - - - if (node->value != NULL) { - strbuf_append(path, node->c); - NEW(strbuf, c); - DEEP_COPY(strbuf)(c, path); - PUSH(LLIST(strbuf))(list, c); - strbuf_pop(path); - } - if (node->next != NULL) { - KEYS(TRIE_NODE(TYPE)) (node->next, list, path); - } - if (node->child != NULL) { - if (node->c != '\0') strbuf_append(path, node->c); - KEYS(TRIE_NODE(TYPE)) (node->child, list, path); - if (node->c != '\0') strbuf_pop(path); - } -} - -LLIST(strbuf)* KEYS(TRIE(TYPE)) (TRIE(TYPE)* trie) { - NEW(LLIST(strbuf), retlist); - SNEW(strbuf, key); - KEYS(TRIE_NODE(TYPE)) (trie->root, retlist, &key); - return retlist; -} - -#endif /* TYPE */ diff --git a/src/vcal.c.old b/src/vcal.c.old deleted file mode 100644 index 29177bf3..00000000 --- a/src/vcal.c.old +++ /dev/null @@ -1,175 +0,0 @@ -#include "vcal.h" - -#include - -#define TYPE strbuf -#include "linked_list.inc.h" -#undef TYPE - -#define TYPE param_set -#include "trie.inc.h" -#undef TYPE - -#define TYPE content_set -#include "linked_list.inc.h" -#undef TYPE - -#define T strbuf - #define V TRIE(param_set) - #include "pair.inc.h" - #undef V -#undef T - -#define TYPE content_line -// #include "hash.inc" -#include "trie.inc.h" -#undef TYPE - -#define TYPE vcomponent -// #include "vector.inc.h" -#include "linked_list.inc.h" -#undef TYPE - -INIT_F(vcomponent) { - INIT(TRIE(content_line), &self->clines); - INIT(LLIST(vcomponent), &self->components); - - // vcomponent_push_val (self, "X-HNH-FILENAME", "VIRTUAL"); - vcomponent_push_val (self, "X-HNH-SOURCETYPE", "virtual"); - char* type = "VIRTUAL"; - self->type = (char*) calloc(sizeof(*type), strlen(type) + 1); - strcpy(self->type, type); - - self->parent = NULL; - self->scm = NULL; - self->scmtype = NULL; - - return 0; - -} - -INIT_F(vcomponent, const char* type) { - return INIT(vcomponent, self, type, NULL); -} - -INIT_F(vcomponent, const char* type, const char* filename) { - - INIT(TRIE(content_line), &self->clines); - INIT(LLIST(vcomponent), &self->components); - - if (filename != NULL) { - /* - * NOTE - * RFC-7986 adds additional parameters linked to this one. - * - `SOURCE' :: where a (possibly) updated version of the - * data can be found - * - `URL' :: Where the same data can be fonud, but - * differently (but not where the original data can be fonud - * again). - */ - vcomponent_push_val (self, "X-HNH-FILENAME", filename); - } - - self->type = (char*) calloc(sizeof(*type), strlen(type) + 1); - strcpy(self->type, type); - - self->parent = NULL; - self->scm = NULL; - self->scmtype = NULL; - - return 0; -} - -content_line* get_attributes (vcomponent* ev, const char* key) { - size_t len = strlen(key) + 1; - char* cpy = (char*) (calloc(sizeof(*cpy), len)); - strncpy (cpy, key, len); - - content_line* ret = GET(TRIE(content_line))(&ev->clines, cpy); - - free (cpy); - return ret; -} - -FREE_F(vcomponent) { - free(self->type); - - if (FREE(TRIE(content_line))(&self->clines) != 0) { - ERR("Error freeing vcomponent"); - } - - FREE(LLIST(vcomponent))(&self->components); - - return 0; -} - -int PUSH(vcomponent)(vcomponent* parent, vcomponent* child) { - child->parent = parent; - return PUSH(LLIST(vcomponent))(&parent->components, child); -} - -int DEEP_COPY(vcomponent)(vcomponent* a, vcomponent* b) { - (void) a; - (void) b; - ERR("Deep copy not implemented for vcomponent"); - return -1; -} - -int vcomponent_copy(vcomponent* dest, vcomponent* src) { - - DEEP_COPY(TRIE(content_line))(&dest->clines, &src->clines); - - /* Children are the same objects */ - FOR(LLIST, vcomponent, c, &src->components) { - PUSH(LLIST(vcomponent))(&dest->components, c); - } - - dest->parent = src->parent; - // PUSH(vcomponent)(src->parent, dest); - - return 0; -} - -FMT_F(vcomponent) { - int seek = 0; - - for (int i = 0; i < 40; i++) fmtf("_"); - - seek += sprintf(buf + seek, _YELLOW); - seek += sprintf(buf + seek, "\nVComponet (Type := %s)\n", self->type); - seek += sprintf(buf + seek, _RESET); - seek += FMT(TRIE(content_line))(&self->clines, buf + seek); - seek += sprintf(buf + seek, "\nComponents:\n"); - FOR(LLIST, vcomponent, comp, &self->components) { - seek += FMT(vcomponent)(comp, buf + seek); - } - - return seek; -} - -int vcomponent_push_val (vcomponent* comp, const char* key, const char* val) { - NEW(content_line, cl); - NEW(content_set, cs); - strbuf_load(&cs->key, val); - PUSH(content_line)(cl, cs); - - char* key_cpy = calloc(sizeof(*key_cpy), strlen(key) + 1); - strcpy (key_cpy, key); - PUSH(TRIE(content_line))(&comp->clines, key_cpy, cl); - free (key_cpy); - - return 0; -} - -char* vcomponent_get_val (vcomponent* comp, const char* key) { - char* key_cpy = calloc(sizeof(*key_cpy), strlen(key) + 1); - strcpy (key_cpy, key); - content_line* cl = GET(TRIE(content_line))(&comp->clines, key_cpy); - free (key_cpy); - - if (cl != NULL && cl->cval != NULL) { - return cl->cval->key.mem; - } - - return NULL; -} diff --git a/src/vcal.h.old b/src/vcal.h.old deleted file mode 100644 index 2a3ad294..00000000 --- a/src/vcal.h.old +++ /dev/null @@ -1,120 +0,0 @@ -#ifndef VCAL_H -#define VCAL_H - -#include - -#include - -#include "strbuf.h" - -#define TYPE strbuf -#include "linked_list.h" -// #include "trie.h" -#undef TYPE - -/* - * content_line: - * (a mapping) between a top level key, and everything it contains. - * content_set: - * A top level value, along with a list of kv pairs for all its - * possible parameters. - * param_set: - * A parameter key, along with a list of all its values. - */ - -#define param_set LLIST(strbuf) - -#define TYPE param_set -#include "trie.h" -#undef TYPE - -#define T strbuf - #define V TRIE(param_set) - #include "pair.h" - /* left := content | right := params */ - #define content_set PAIR(strbuf, TRIE(param_set)) - #undef V -#undef T - -#define TYPE content_set -#include "linked_list.h" -#undef TYPE - -#define content_line LLIST(content_set) - -/* - * Helper macros for accessing fields in - * content_line, content_set, and param_set - */ - -/* content_set */ -#define CLINE_CUR(c) ((c)->cval) - -/* strbuf */ -#define CLINE_CUR_VAL(c) (& CLINE_CUR(c)->key) - -/* TRIE(param_set) */ -#define CLINE_CUR_PARAMS(c) (& CLINE_CUR(c)->val) - -#define TYPE content_line -#include "trie.h" -#undef TYPE - -typedef struct s_vcomponent vcomponent; - -#define TYPE vcomponent -// #include "vector.h" -#include "linked_list.h" -#undef TYPE - -struct s_vcomponent { - /* VCALENDAR, VEVENT, ... */ - char* type; - vcomponent* parent; - TRIE(content_line) clines; - LLIST(vcomponent) components; - - /* - * Holds a Guile representation of this object. Used to always - * return the same foreign (for guile) object for the same - * vcomponent. - */ - SCM scm; - SCM scmtype; -}; - -#define FCHILD(v) FIRST_V(&(v)->components) - -INIT_F(vcomponent); -INIT_F(vcomponent, const char* type); -INIT_F(vcomponent, const char* type, const char* filename); -FREE_F(vcomponent); - -content_line* get_attributes (vcomponent* ev, const char* key); - -int add_content_line (vcomponent* ev, content_line* c); - -int vcomponent_push_val (vcomponent*, const char* key, const char* val); -char* vcomponent_get_val (vcomponent*, const char* key); - -/* - * Appends ev to cal. Doesn't copy ev. So make sure that it wont go - * out of scope. - */ -int PUSH(vcomponent)(vcomponent*, vcomponent*); - -/* - * Deep copy is currently not implemented for vcomponentes. - * The reason for this method being here is since some - * generic methods in other places complain otherwise. - */ -int DEEP_COPY(vcomponent)(vcomponent*, vcomponent*); - -/* - * "Shallow" copy of vcomponent. - */ -int vcomponent_copy(vcomponent*, vcomponent*); - -FMT_F(vcomponent); - -#endif /* VCAL_H */ -- cgit v1.2.3 From feefb97cf9118c8e5d7018e33887a371dadc5eab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 6 Oct 2019 13:35:20 +0200 Subject: Minor cleanup in scheme code. --- module/output/terminal.scm | 2 +- module/server/macro.scm | 10 ++-------- module/vcomponent.scm | 36 +++++++----------------------------- module/vcomponent/base.scm | 27 +++++---------------------- module/vcomponent/primitive.scm | 22 ++++------------------ module/vcomponent/timezone.scm | 3 ++- 6 files changed, 21 insertions(+), 79 deletions(-) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index 37fe1b86..16ba31e9 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -138,7 +138,7 @@ (let ((ev ((@ (vcomponent primitive) %vcomponent-make) fname))) (serialize-vcomponent ev (current-error-port)) - (push-child! (parent (list-ref events cur-event)) ev) + (add-child! (parent (list-ref events cur-event)) ev) (format (current-error-port) "Children: ~a~%start: ~a~%" (children ev) (attr ev 'DTSTART)) (set! event-stream (stream-insert ev-time parse-datetime] [else - (set (date-hour date) = (+ 1))]) - ) + (set (date-hour date) = (+ 1))])) (set! (value dptr) (date->time-utc date) (value eptr) (date->time-utc end-date)) @@ -70,21 +62,6 @@ (value eptr) (date->time-utc end-date))))) -;; (define-public value caar) -;; (define-public next cdr) -;; (define-public next! pop!) - - -;; (define-public (reset! attr-list) -;; (while (not (car attr-list)) -;; (next! attr-list)) -;; (next! attr-list)) - -;; value -;; (define-public v -;; (make-procedure-with-setter car set-car!)) - - (define* (make-vcomponent #:optional path) (if (not path) (primitive-make-vcomponent) @@ -121,9 +98,10 @@ (unless (find (lambda (z) (string=? (attr z "TZID") (attr component "TZID"))) - (filter (lambda (o) (eq? 'VTIMEZONE (type o))) (children accum))) - (push-child! accum component))) - (else (push-child! accum component))))) + (filter (lambda (o) (eq? 'VTIMEZONE (type o))) + (children accum))) + (add-child! accum component))) + (else (add-child! accum component))))) ;; return accum)) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 246566ee..69fab656 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -6,6 +6,8 @@ :use-module (ice-9 hash-table) :use-module ((ice-9 optargs) :select (define*-public))) +(export add-child!) + ;; vline → value (define-public value (make-procedure-with-setter @@ -29,25 +31,10 @@ (as-string attr) (make-vline value)))) -;; (define-public (values-left-count attr-list) -;; (length (take-while identity attr-list))) - -;; (define-public (value-count attr-list) -;; (length (take-while identity (cdr (drop-while identity attr-list))))) - -;; (define (get-first c a) -;; (and=> (car (get-attr c a)) car)) - -;; (define (set-first! c a v) -;; (and=> (car (get-attr c a)) -;; (lambda (f) (set! (car f) v)))) - (define-public attr (make-procedure-with-setter -; get-first set-first! get-attr - set-attr! - )) + set-attr!)) (define-public prop @@ -68,11 +55,9 @@ )) (define-public (parent c) (struct-ref c 2)) -(define-public push-child! add-child!) + (define-public (attributes component) - (hash-map->list cons (struct-ref component 3)) - #; (map string->symbol (%vcomponent-attribute-list component)) - ) + (hash-map->list cons (struct-ref component 3))) (define*-public (children component) (struct-ref component 1)) @@ -92,8 +77,6 @@ (hash-map->list (lambda (key value) (cons key (copy-vline value))) (struct-ref component 3))))) -;; (define-public filter-children! %vcomponent-filter-children!) - (define-public (extract field) (lambda (e) (attr e field))) diff --git a/module/vcomponent/primitive.scm b/module/vcomponent/primitive.scm index 2cf12508..5fef08cc 100644 --- a/module/vcomponent/primitive.scm +++ b/module/vcomponent/primitive.scm @@ -1,23 +1,9 @@ ;;; Primitive export of symbols linked from C binary. (define-module (vcomponent primitive) - #:export #; - (%vcomponent-children ; - %vcomponent-push-child! ; - %vcomponent-filter-children! ; - ; - %vcomponent-parent ; - ; - %vcomponent-make ; - %vcomponent-get-type ; - %vcomponent-set-type! ; - ; - %vcomponent-get-attribute ; - %vcomponent-attribute-list ; - ; - %vcomponent-shallow-copy) - - (make-vcomponent add-line! add-child! make-vline add-attribute! parse-cal-path) - ) + #:export (make-vcomponent + add-line! add-child! + make-vline add-attribute! + parse-cal-path)) (load-extension "libguile-calendar" "init_lib") diff --git a/module/vcomponent/timezone.scm b/module/vcomponent/timezone.scm index 4a312288..dde32cc2 100644 --- a/module/vcomponent/timezone.scm +++ b/module/vcomponent/timezone.scm @@ -68,7 +68,8 @@ ;; Crashes on error. (define (find-tz cal tzid) (let ((ret (find (lambda (tz) (string=? tzid (attr tz 'TZID))) - (children cal 'VTIMEZONE)))) + (filter (lambda (o) (eq? 'VTIMEZONE (type o))) + (children cal))))) ret)) ;; Takes a VEVENT. -- cgit v1.2.3 From ab964d17145114eda93cda35f69a4b1e1779e242 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 6 Oct 2019 13:41:00 +0200 Subject: Cleanup in C code. --- src/guile_type_helpers.c | 10 +++------ src/guile_type_helpers.h | 4 +++- src/parse.c | 53 +++--------------------------------------------- src/parse.h | 12 ----------- src/struct.scm.c | 2 -- 5 files changed, 9 insertions(+), 72 deletions(-) diff --git a/src/guile_type_helpers.c b/src/guile_type_helpers.c index 072ddff9..2864df0d 100644 --- a/src/guile_type_helpers.c +++ b/src/guile_type_helpers.c @@ -3,13 +3,9 @@ #include "macro.h" SCM scm_from_strbuf(strbuf* s) { - // if (s->scm == NULL) { - SCM ret = scm_from_utf8_stringn (s->mem, s->len); - scm_gc_protect_object(ret); - // } - - // return s->scm; - return ret; + SCM ret = scm_from_utf8_stringn (s->mem, s->len); + scm_gc_protect_object(ret); + return ret; } SCM scm_from_strbuf_symbol(strbuf* s) { diff --git a/src/guile_type_helpers.h b/src/guile_type_helpers.h index c936f45d..fe0e875a 100644 --- a/src/guile_type_helpers.h +++ b/src/guile_type_helpers.h @@ -3,10 +3,12 @@ #include -#include "calendar.h" #include "strbuf.h" #define SCM_IS_LIST(x) scm_is_true(scm_list_p(x)) +#define string_eq(a, b) \ + scm_is_true(scm_string_eq(a, b, \ + SCM_UNDEFINED,SCM_UNDEFINED,SCM_UNDEFINED,SCM_UNDEFINED)) SCM scm_from_strbuf(strbuf* s); SCM scm_from_strbuf_symbol(strbuf* s); diff --git a/src/parse.c b/src/parse.c index 3a5907c8..586a43b4 100644 --- a/src/parse.c +++ b/src/parse.c @@ -5,7 +5,6 @@ #include #include "macro.h" -// #include "vcal.h" #include "err.h" @@ -13,17 +12,6 @@ #include "struct.h" #include "guile_type_helpers.h" -// #define TYPE vcomponent -// #include "linked_list.inc.h" -// #undef TYPE - -// #define T strbuf -// #define V strbuf -// #include "pair.h" -// #include "pair.inc.h" -// #undef T -// #undef V - /* +-------------------------------------------------------+ v | @@ -42,7 +30,6 @@ */ -#define string_eq(a, b) scm_is_true(scm_string_eq(a, b, SCM_UNDEFINED,SCM_UNDEFINED,SCM_UNDEFINED,SCM_UNDEFINED)) /* * name *(";" param) ":" value CRLF @@ -52,26 +39,12 @@ int parse_file(char* filename, FILE* f, SCM root) { part_context p_ctx = p_key; SNEW(parse_ctx, ctx, f, filename); - // PUSH(LLIST(vcomponent))(&ctx.comp_stack, root); - - /* - * Create a content_line which we use as storage while we are - * parsing. This object is constantly broken down and rebuilt. - * - * {cline,param}_key is also temporary register used during - * parsing. - */ - // SNEW(content_line, cline); - // SNEW(strbuf, param_key); - // SNEW(strbuf, param_val); - // SNEW(strbuf, attr_key); - // SNEW(strbuf, attr_val); SNEW(strbuf, str); SCM component = root; SCM line = scm_make_vline(SCM_UNDEFINED); SCM attr_key; /* string */ - SCM line_key = scm_from_utf8_string(""); /* string */ + SCM line_key = scm_from_utf8_string(""); SCM scm_filename = scm_from_utf8_stringn(filename, strlen(filename)); SCM filename_key = scm_from_utf8_string("X-HNH-FILENAME"); @@ -82,13 +55,12 @@ int parse_file(char* filename, FILE* f, SCM root) { if (c == '\r' || c == '\n') { if (fold(&ctx, c) > 0) { /* Actuall end of line, handle value */ - // TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str); /* * The key being BEGIN means that we decend into a new component. */ if (string_eq(line_key, scm_from_utf8_string("BEGIN"))) { /* key \in { VCALENDAR, VEVENT, VALARM, VTODO, VTIMEZONE, ... } */ - SCM child = scm_make_vcomponent(scm_string_to_symbol(scm_from_strbuf(&str))); + SCM child = scm_make_vcomponent(scm_from_strbuf_symbol(&str)); scm_add_child_x (component, child); scm_add_line_x(child, filename_key, scm_make_vline(scm_filename)); @@ -186,16 +158,8 @@ int parse_file(char* filename, FILE* f, SCM root) { } - // FREE(content_line)(&cline); - // FREE(strbuf)(&cline_key); - // FREE(strbuf)(¶m_key); - FREE(strbuf)(&str); - // assert(POP(LLIST(vcomponent))(&ctx.comp_stack) == root); - // assert(EMPTY(LLIST(strbuf))(&ctx.key_stack)); - // assert(EMPTY(LLIST(vcomponent))(&ctx.comp_stack)); - FREE(parse_ctx)(&ctx); return 0; @@ -236,8 +200,6 @@ int fold(parse_ctx* ctx, char c) { INIT_F(parse_ctx, FILE* f, char* filename) { - // INIT(LLIST(strbuf), &self->key_stack); - // INIT(LLIST(vcomponent), &self->comp_stack); self->filename = (char*) calloc(sizeof(*filename), strlen(filename) + 1); strcpy(self->filename, filename); self->f = f; @@ -248,20 +210,15 @@ INIT_F(parse_ctx, FILE* f, char* filename) { self->pline = 1; self->pcolumn = 1; - // INIT(strbuf, &self->str); - return 0; } FREE_F(parse_ctx) { - // FREE(LLIST(strbuf))(&self->key_stack); - // FREE(LLIST(vcomponent))(&self->comp_stack); free(self->filename); self->line = 0; self->column = 0; - // FREE(strbuf)(&self->str); return 0; } @@ -302,10 +259,6 @@ char handle_escape (parse_ctx* ctx) { ++ctx->column; ++ctx->pcolumn; + /* Returns the escaped char, for appending to the current string */ return esc; - - /* save escapade character as a normal character */ - // strbuf_append(&ctx->str, esc); - - // return 0; } diff --git a/src/parse.h b/src/parse.h index a5169dd7..898abe5b 100644 --- a/src/parse.h +++ b/src/parse.h @@ -47,13 +47,6 @@ typedef struct { FILE* f; - /* - * context stacks used since ICS files form a tree. key_stack is - * only for sequrity purposes. - */ - // LLIST(strbuf) key_stack; - // LLIST(vcomponent) comp_stack; - /* Number for unfolded lines * TODO remove this * */ @@ -64,11 +57,6 @@ typedef struct { int pline; int pcolumn; - /* - * String which we write everything read into. - * Later copied to appropiate places. - */ - // strbuf str; } parse_ctx; INIT_F(parse_ctx, FILE* f, char* filename); diff --git a/src/struct.scm.c b/src/struct.scm.c index a8e7b3c6..051faf63 100644 --- a/src/struct.scm.c +++ b/src/struct.scm.c @@ -81,8 +81,6 @@ SCM_DEFINE(scm_add_attribute_x, "add-attribute!", 3, 0, 0, } void init_lib (void) { - // init_vcomponent_type(); - // content_set_lists = scm_make_weak_key_hash_table (scm_from_uint(0x100)); SCM str = scm_from_utf8_string("pr" "pw" "pw" "pr"); vcomponent_vtable = scm_make_vtable(str, SCM_BOOL_F); scm_set_struct_vtable_name_x (vcomponent_vtable, scm_from_utf8_symbol("vcomponent")); -- cgit v1.2.3 From de97337a13ffd480355148da252859a205e10b74 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 6 Oct 2019 19:53:27 +0200 Subject: Fix re-export of add-child! --- Makefile | 5 +++-- module/vcomponent.scm | 4 +++- module/vcomponent/base.scm | 5 ++--- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index a3fe93d2..2065bda9 100644 --- a/Makefile +++ b/Makefile @@ -17,8 +17,6 @@ C_FILES = $(wildcard src/*.c) SCM_C_FILES = $(wildcard src/*.scm.c) X_FILES = $(SCM_C_FILES:.scm.c=.x) -.SECONDARY: $(X_FILES) - O_FILES = $(C_FILES:src/%.c=obj/%.o) SCM_FILES = $(shell find module/ -type f -name \*.scm) @@ -30,6 +28,9 @@ GUILE_C_FLAGS = -Lmodule \ -Wmacro-use-before-definition -Warity-mismatch \ -Wduplicate-case-datum -Wbad-case-datum +.SECONDARY: $(X_FILES) $(O_FILES) + + all: $(SO_FILES) $(GO_FILES) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 4d13dbc8..a65ef2d4 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,5 +1,7 @@ (define-module (vcomponent) - #:use-module ((vcomponent primitive) :select (parse-cal-path (make-vcomponent . primitive-make-vcomponent))) + #:use-module ((vcomponent primitive) + :select (parse-cal-path + (make-vcomponent . primitive-make-vcomponent))) #:use-module (vcomponent datetime) #:use-module (vcomponent recurrence) #:use-module (vcomponent timezone) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 69fab656..3072c0a5 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -4,9 +4,8 @@ :use-module (srfi srfi-17) :use-module (vcomponent primitive) :use-module (ice-9 hash-table) - :use-module ((ice-9 optargs) :select (define*-public))) - -(export add-child!) + :use-module ((ice-9 optargs) :select (define*-public)) + :re-export (add-child!)) ;; vline → value (define-public value -- cgit v1.2.3 From 7578a9c3375a364e5fd2bf629811394208c4cf5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 6 Oct 2019 22:48:56 +0200 Subject: Fix property access. --- module/vcomponent/base.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 3072c0a5..98b2aa89 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -39,9 +39,9 @@ (define-public prop (make-procedure-with-setter (lambda (attr-obj prop-key) - (hash-ref (struct-ref attr-obj 1) prop-key)) + (hash-ref (struct-ref attr-obj 1) (as-string prop-key))) (lambda (attr-obj prop-key val) - (hash-set! (struct-ref attr-obj 1) prop-key val)))) + (hash-set! (struct-ref attr-obj 1) (as-string prop-key) val)))) ;; Returns the properties of attribute as an assoc list. ;; @code{(map car <>)} leads to available properties. -- cgit v1.2.3 From 86ae614050a1aba19a2d14e12ff7b62cc47b778c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 6 Oct 2019 22:56:35 +0200 Subject: Slight impromevents to parse-offset. --- module/vcomponent/timezone.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/module/vcomponent/timezone.scm b/module/vcomponent/timezone.scm index dde32cc2..f6112ebc 100644 --- a/module/vcomponent/timezone.scm +++ b/module/vcomponent/timezone.scm @@ -58,11 +58,13 @@ [else (stream-zip strm (stream-cdr strm))]))) +;; str ::= ±[0-9]{4} +;; str → int seconds (define (parse-offset str) - (let* (((pm h1 h0 m1 m0) (string->list str))) - ((primitive-eval (symbol pm)) - (+ (* 60 (string->number (list->string (list m1 m0)))) - (* 60 60 (string->number (list->string (list h1 h0)))))))) + (let* (((± h1 h0 m1 m0) (string->list str))) + ((primitive-eval (symbol ±)) + (+ (* 60 (string->number (string m1 m0))) + (* 60 60 (string->number (string h1 h0))))))) ;; Finds the VTIMEZONE with id @var{tzid} in calendar. ;; Crashes on error. -- cgit v1.2.3 From fd7c76fc987dcaa928139ac4991ea02e61a2a1d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 8 Oct 2019 21:57:23 +0200 Subject: Remove tailing null from parsed color files. --- src/calendar.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/calendar.c b/src/calendar.c index 1362ee2e..28891330 100644 --- a/src/calendar.c +++ b/src/calendar.c @@ -92,12 +92,14 @@ int handle_dir(SCM cal, char* path) { if (strcmp (d->d_name, "color") == 0) { f = fopen(resolved_path, "r"); read = getline(&info_buf, &size, f); + // TODO this isn't actually needed since we trim the + // string into an SCM string directly here. if (info_buf[read - 1] == '\n') info_buf[read - 1] = '\0'; fclose(f); scm_add_line_x(cal, scm_from_utf8_string("COLOR"), - scm_make_vline(scm_from_utf8_stringn(info_buf, read))); + scm_make_vline(scm_from_utf8_stringn(info_buf, read - 1))); } else if (strcmp (d->d_name, "displayname") == 0) { f = fopen(resolved_path, "r"); read = getline(&info_buf, &size, f); -- cgit v1.2.3 From 3554f1b34bb6937cdac6ffc48d8f4d7bf2f4ce3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 15 Oct 2019 22:06:54 +0200 Subject: Add final fallback for name. --- module/vcomponent.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index a65ef2d4..31d5b2bf 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -114,7 +114,8 @@ (unless (attr component "NAME") (set! (attr component "NAME") (or (attr component "X-WR-CALNAME") - (attr root "NAME")))) + (attr root "NAME") + "[NAMELESS]"))) (unless (attr component "COLOR") (set! (attr component "COLOR") -- cgit v1.2.3 From 69d36e6e02fa2ded0c036446c18c80f4d16740f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 15 Oct 2019 23:43:29 +0200 Subject: Made extrapolate-tz-stream slightly less worse. --- module/vcomponent/timezone.scm | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/module/vcomponent/timezone.scm b/module/vcomponent/timezone.scm index f6112ebc..ed3bef6b 100644 --- a/module/vcomponent/timezone.scm +++ b/module/vcomponent/timezone.scm @@ -28,15 +28,20 @@ ;; : TZOFFSETFROM: +0200 ;; @end example -;; Given a tz stream of length 2, takes the time difference between the DTSTART -;; of those two. And creates a new VTIMEZONE with that end time. -;; TODO set remaining properties, and type of the newly created component. +;; Given a tz stream of length 2, extrapolates when the next timezone +;; change aught to be. +;; Currently it does so by taking the first time zone, and adding one +;; year. This kind of works. +;; Previously it took the difference between element 2 and 1, and added +;; that to the start of the secound time zone. This was even more wrong. +;; TODO? set remaining properties, and type of the newly created component. (define (extrapolate-tz-stream strm) - (let ((nevent (copy-vcomponent (stream-ref strm 1)))) - (mod! (attr nevent 'DTSTART) - = (add-duration (time-difference - (attr (stream-ref strm 1) 'DTSTART) - (attr (stream-ref strm 0) 'DTSTART)))) + (let ((nevent (copy-vcomponent (stream-car strm)))) + (set! (attr nevent 'DTSTART) + (date->time-utc + (set (date-year + (time-utc->date (attr nevent 'DTSTART))) + = (+ 1)))) (stream-append strm (stream nevent)))) ;; The RFC requires that at least one DAYLIGHT or STANDARD component is present. -- cgit v1.2.3 From f6823f7c06cda1e27f374e6b10bc9fccd9e855d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 29 Oct 2019 17:40:51 +0100 Subject: Move env init out from main.scm. --- env | 12 ++++++++++++ module/main.scm | 9 +-------- 2 files changed, 13 insertions(+), 8 deletions(-) create mode 100755 env diff --git a/env b/env new file mode 100755 index 00000000..2ba1cd1d --- /dev/null +++ b/env @@ -0,0 +1,12 @@ +# -*- mode: sh -*- + +root=$(dirname $(realpath $BASH_SOURCE)) + +GUILE_LOAD_PATH="$root/module:$GUILE_LOAD_PATH" +GUILE_LOAD_COMPILED_PATH="$root/obj/module:$GUILE_LOAD_COMPILED_PATH" +LD_LIBRARY_PATH="$root/lib:$LD_LIBRARY_PATH" + +export GUILE_LOAD_PATH GUILE_LOAD_COMPILED_PATH LD_LIBRARY_PATH +export GUILE_AUTO_COMPILE=0 + +# exec "$@" diff --git a/module/main.scm b/module/main.scm index ce327f39..dbd8ae35 100755 --- a/module/main.scm +++ b/module/main.scm @@ -1,14 +1,7 @@ #!/bin/bash # -*- mode: scheme -*- -root=$(dirname $(dirname $(realpath $0))) - -GUILE_LOAD_PATH="$root/module:$GUILE_LOAD_PATH" -GUILE_LOAD_COMPILED_PATH="$root/obj/module:$GUILE_LOAD_COMPILED_PATH" -LD_LIBRARY_PATH="$root/lib:$LD_LIBRARY_PATH" - -export GUILE_LOAD_PATH GUILE_LOAD_COMPILED_PATH LD_LIBRARY_PATH -export GUILE_AUTO_COMPILE=0 +. $(dirname $(dirname $(realpath $0)))/env exec guile -e main -s $0 "$@" !# -- cgit v1.2.3 From 306c2470fbc1085b34f9575c7179c89be2a8cd9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 29 Oct 2019 17:43:10 +0100 Subject: Minor improvements on timezone loading. --- module/vcomponent.scm | 43 ++++++++++++++++++++++++++++++------------- 1 file changed, 30 insertions(+), 13 deletions(-) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 31d5b2bf..8751440d 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -42,7 +42,8 @@ (define date (parse-datetime (value dptr))) (define end-date - (cond [(not eptr) + (cond ;; [(attr ev 'DURATION) => (lambda (d) (add-duration ...))] + [(not eptr) (let ((d (set (date-hour date) = (+ 1)))) (set! (attr ev 'DTEND) d eptr (attr* ev 'DTEND)) @@ -88,22 +89,38 @@ (let ((accum (primitive-make-vcomponent 'VCALENDAR)) (ch (children root))) - ;; What does this even do? + ;; Copy attributes from our parsed VCALENDAR + ;; to our newly created one. (unless (null? ch) (for key in (attributes (car ch)) (set! (attr accum key) (attr (car ch) key)))) - (for cal in ch - (for component in (children cal) - (case (type component) - ((VTIMEZONE) - (unless (find (lambda (z) - (string=? (attr z "TZID") - (attr component "TZID"))) - (filter (lambda (o) (eq? 'VTIMEZONE (type o))) - (children accum))) - (add-child! accum component))) - (else (add-child! accum component))))) + ;; Merge all children + (let ((tz '())) + (for cal in ch + (for component in (children cal) + (case (type component) + ((VTIMEZONE) + (set! tz (cons component tz)) + #; + (unless (find (lambda (z) + (string=? (attr z "TZID") + (attr component "TZID"))) + (filter (lambda (o) (eq? 'VTIMEZONE (type o))) + (children accum))) + (add-child! accum component))) + ((VEVENT) + (add-child! accum component) + ) + (else => (lambda (type) + (format (current-error-port) + "Got unexpected component of type ~a~%" type)) + #; (add-child! accum component) + )))) + + (unless (null? tz) + (add-child! accum (car tz))) + ) ;; return accum)) -- cgit v1.2.3 From c852afb7efd07c6d414d0904be68c29a2bd20e24 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 29 Oct 2019 18:50:56 +0100 Subject: Start work on ical output. --- module/main.scm | 2 ++ module/output/ical.scm | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 84 insertions(+) create mode 100644 module/output/ical.scm diff --git a/module/main.scm b/module/main.scm index dbd8ae35..f765496f 100755 --- a/module/main.scm +++ b/module/main.scm @@ -23,6 +23,7 @@ exec guile -e main -s $0 "$@" (output text) (output import) (output info) + (output ical) (server) (ice-9 getopt-long) @@ -93,6 +94,7 @@ exec guile -e main -s $0 "$@" ((term) terminal-main) ((import) import-main) ((info) info-main) + ((ical) ical-main) ((server) server-main)) c e ropt))) calendar-files: (or (and=> (option-ref opts 'file #f) diff --git a/module/output/ical.scm b/module/output/ical.scm new file mode 100644 index 00000000..c8d9a11d --- /dev/null +++ b/module/output/ical.scm @@ -0,0 +1,82 @@ +(define-module (output ical) + use-module: (ice-9 getopt-long) + use-module: (ice-9 format) + use-module: (vcomponent) + use-module: (srfi srfi-19) + use-module: (srfi srfi-19 util) + use-module: (srfi srfi-41) + use-module: (srfi srfi-41 util) + ) + +(define opt-spec + '((from (value #t) (single-char #\f)) + (to (value #t) (single-char #\t)))) + +(define (value-format key value) + ;; TODO remove once key's are normalized to symbols. + (case (string->symbol key) + ((DTSTART DTEND) + (time->string value "~Y~m~dT~H~M~SZ")) + ((DURATION) + #; (time->string value "~H~M~S") + (let ((s (time-second value))) + (format #f "~a~a~a" + (floor/ s 3600) + (floor/ (modulo s 3600) 60) + (modulo s 60)) + )) + (else value))) + +(define (escape-chars str) + (with-output-to-string + (lambda () + (string-for-each (lambda (ch) + (case ch + ((#\, #\\) => (lambda (c) (display "\\") (display c))) + (else (display ch))) + ) str)))) + +(define (component->ical-string component) + (format #t "BEGIN:~a~%" (type component)) + (for-each (lambda (kv) + (let ((key (car kv)) + (vline (cdr kv))) + ;; key;p1=v;p3=10:value + (format #t "~a~:{;~a=~@{~a~^,~}~}:~a~%" + key (properties vline) + (escape-chars (value-format key (value vline))) + ))) + (attributes component)) + (for-each component->ical-string (children component)) + (format #t "END:~a~%" (type component)) + + ) + +(define (print-header) + (format #t +"BEGIN:VCALENDAR +PRODID:~a +VERSION:2.0 +CALSCALE:GREGORIAN +" +"Hugo" +)) + + +(define (print-footer) + (format #t "END:VCALENDAR~%")) + +(define-public (ical-main calendars events args) + (define opts (getopt-long args opt-spec)) + (define start (parse-freeform-date (option-ref opts 'from "2019-04-15"))) + (define end (parse-freeform-date (option-ref opts 'to "2019-05-10"))) + + (print-header) + + (stream-for-each + component->ical-string + (filter-sorted-stream (lambda (ev) ((in-date-range? start end) + (time-utc->date (attr ev 'DTSTART)))) + events)) + + (print-footer)) -- cgit v1.2.3 From 04b31c9b820e6756043a87027458c0b8d0546d7b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 1 Nov 2019 21:10:06 +0100 Subject: Start port of parse to scheme. --- Makefile | 6 +- src/parse.c | 2 +- src/parse.scm | 229 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 235 insertions(+), 2 deletions(-) create mode 100644 src/parse.scm diff --git a/Makefile b/Makefile index 2065bda9..9ad9f533 100644 --- a/Makefile +++ b/Makefile @@ -49,7 +49,11 @@ lib/%.so: $(O_FILES) @mkdir -p lib $(CC) -shared -o $@ $^ $(LDFLAGS) -obj/%.scm.go: %.scm # $(SO_FILES) +obj/module/vcomponent/primitive.scm.go: module/vcomponent/primitive.scm $(SO_FILES) + @mkdir -p obj + guild compile $(GUILE_C_FLAGS) -o $@ $< + +obj/%.scm.go: %.scm @mkdir -p obj guild compile $(GUILE_C_FLAGS) -o $@ $< diff --git a/src/parse.c b/src/parse.c index 586a43b4..3edbd874 100644 --- a/src/parse.c +++ b/src/parse.c @@ -18,7 +18,7 @@ BEGIN → key -------------------------------→ ':' → value → CRLF -+-→ EOF | ^ v | - ';' → param-key → ':' → param-value --+ + ';' → param-key → '=' → param-value --+ ^ | +------------------------------------+ diff --git a/src/parse.scm b/src/parse.scm new file mode 100644 index 00000000..e5b3ae32 --- /dev/null +++ b/src/parse.scm @@ -0,0 +1,229 @@ + +(define-module (parse) + :use-module (rnrs io ports) + :use-module (rnrs bytevectors) + :use-module (srfi srfi-9) + + ) + + +(define-record-type + (make-vcomponent% type children parent attributes) + vcomponent? + (type component-type) + (children get-component-children set-component-children!) + (parent get-component-parent set-component-parent!) + (attributes get-component-attributes)) + +(define* (make-vcomponent #:optional (type 'VIRTUAL)) + (make-vcomponent% type '() #f (make-hash-table #x10))) + +(define (add-child! parent child) + (set-component-children! parent (cons child (get-component-children parent))) + (set-component-parent! child parent)) + +(define (set-attribute! component key value) + (let ((ht (get-component-attributes component))) + (cond [(hashq-ref ht key #f) + => (lambda (pair) (set-cdr! pair value))] + [else (hashq-set! ht key (cons (make-hash-table) value))]))) + + + + +(define contexts '(key value param-name param-value escape)) + + +(define-record-type + (make-parse-ctx% row col ctx line-key param-key param-table) + parse-ctx? + (row get-row set-row!) + (col get-col set-col!) + (ctx get-ctx set-ctx!) + (line-key get-line-key set-line-key!) + (param-key get-param-key set-param-key!) + (param-table get-param-table set-param-table!) + ) + +(define (make-parse-ctx) + (make-parse-ctx% 0 0 'key + #f #f (make-hash-table))) + +(define (increment-column! ctx) + (set-col! ctx (1+ (get-col ctx)))) + +(define (increment-row! ctx) + (set-col! ctx 0) + (set-row! ctx (1+ (get-row ctx)))) + + +(define-record-type + (make-strbuf% len bytes) + strbuf? + (len get-length set-length!) + (bytes get-bytes) + ) + +(define (make-strbuf) + (make-strbuf% 0 (make-u8vector #x1000)) + ) + +(define (strbuf->string strbuf) + (let ((bv (make-u8vector (get-length strbuf)))) + (bytevector-copy! (get-bytes strbuf) 0 + bv 0 + (get-length strbuf)) + (bytevector->string bv (native-transcoder)))) ; TODO charset + +(define (strbuf-reset! strbuf) + (set-length! strbuf 0)) + +(define (strbuf-append! strbuf u8) + (u8vector-set! (get-bytes strbuf) + (get-length strbuf) + u8) + (set-length! strbuf (1+ (get-length strbuf)))) + +(define (fold-proc ctx c) + (let ((pair (cons (if (= c (char->integer #\newline)) + c (get-u8 (current-input-port))) + (get-u8 (current-input-port))))) + (increment-row! ctx) + (cond [(not (= (char->integer #\newline) + (car pair))) + ;; ERROR expected newline after CR + 'error + ] + + [(memv (integer->char (cdr pair)) '(#\space #\tab)) + (increment-column! ctx) + 'fold + ] + + #; + [ungetc... + 'writeback-error + ] + + [else + ;; ... + 'end-of-line + ] + + ))) + +(define (parse-file filename file root) + (set-current-input-port file) + (let ((component root) + (ctx (make-parse-ctx)) + (strbuf (make-strbuf))) + (catch #t + (lambda () + (while #t + (let ((c (get-u8 (current-input-port)))) + (cond + + [(eof-object? c) + (break)] + + [(memv (integer->char c) '(#\return #\newline)) + (case (fold-proc ctx c) + [(error writeback-error) => (lambda (t) (throw t))] + [(end-of-line) + (let ((str (strbuf->string strbuf))) + (cond [(string=? (get-line-key ctx) "BEGIN") + (let ((child (make-vcomponent (string->symbol str)))) + (add-child! component child) + (set! component child))] + + [(string=? (get-line-key ctx) "END") + (set! component (get-component-parent component))] + + [else + (let ((ht (get-component-attributes component))) + ;; TODO repeated keys + (hashq-set! ht (string->symbol (get-line-key ctx)) + (cons (get-param-table ctx) + str)) + (set-param-table! ctx (make-hash-table)))]) + + (strbuf-reset! strbuf) + (set-ctx! ctx 'key))])] + + [(char=? (integer->char c) #\\) + (let ((cc (get-u8 (current-input-port)))) + (case cc + [(#\return #\newline) ;; TODO fold? + (fold-proc ctx cc) + ] + [(#\n #\N) + (strbuf-append! strbuf (char->integer #\newline))] + [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf c))] + [else 'err] + ) + (increment-column! ctx))] + + [(and (eq? (get-ctx ctx) 'panam-name) (char=? (integer->char c) #\=)) + (set-param-key! ctx (strbuf->string strbuf)) + (strbuf-reset! strbuf) + (set-ctx! ctx 'param-value)] + + [(memv (integer->char c) '(#\: #\;)) + (case (get-ctx ctx) + [(param-value) + (hashq-set! (get-param-table ctx) + (get-param-key ctx) + (strbuf->string strbuf)) + (strbuf-reset! strbuf)] + [(key) + (set-line-key! ctx (strbuf->string strbuf)) + (strbuf-reset! strbuf)]) + (set-ctx! ctx (case c + [(#\:) 'value] + [(#\;) 'param-name]))] + + [else + (strbuf-append! strbuf c) + (increment-column! ctx) + ])))) + (lambda (err . args) + (format #t "err = ~a~%ctx = ~a~%args = ~a~%" + err ctx args) + )))) + + +;;; TODO + +(define (open-ics path cal) + (define f (open-input-file path)) + (parse-file path f cal)) + +(define (handle-dir cal path) + 'TODO + ;; TODO + ) + +(define (handle-file cal path) + (set-attribute! cal 'X-HNH-SOURCETYPE "file") + (open-ics path cal) + ) + + +(define (read-vcalendar root path) + (define st (stat path)) + (case (stat:type st) + [(regular) (handle-file root path)] + [(directory) (handle-dir root path)] + [(block-special char-special fifo socket unknown symlink) + => (lambda (t) (throw t))]) + ) + +(define (parse-cal-path path) + (define root (make-vcomponent)) + (read-vcalendar root path) + root) + + +(define root (parse-cal-path "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics")) + +(format #t "root = ~a~%" root) -- cgit v1.2.3 From 785e9ae4fe709ea42e87ad4908b7da65943b5d22 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 2 Nov 2019 12:50:49 +0100 Subject: Work on parser port. --- src/parse.scm | 72 ++++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 49 insertions(+), 23 deletions(-) diff --git a/src/parse.scm b/src/parse.scm index e5b3ae32..3f245002 100644 --- a/src/parse.scm +++ b/src/parse.scm @@ -3,8 +3,10 @@ :use-module (rnrs io ports) :use-module (rnrs bytevectors) :use-module (srfi srfi-9) + :use-module ((ice-9 textual-ports) :select (unget-char)) ) + (define-record-type @@ -22,6 +24,15 @@ (set-component-children! parent (cons child (get-component-children parent))) (set-component-parent! child parent)) +(define* (get-attribute-value component key #:optional default) + (cond [(hashq-ref (get-component-attributes component) + key #f) + => (lambda (p) (cdr p))] + [else default])) + +(define (get-attribute component key) + (hashq-ref (get-component-attributes component) key)) + (define (set-attribute! component key value) (let ((ht (get-component-attributes component))) (cond [(hashq-ref ht key #f) @@ -30,10 +41,8 @@ - (define contexts '(key value param-name param-value escape)) - (define-record-type (make-parse-ctx% row col ctx line-key param-key param-table) parse-ctx? @@ -55,6 +64,7 @@ (define (increment-row! ctx) (set-col! ctx 0) (set-row! ctx (1+ (get-row ctx)))) + (define-record-type @@ -91,24 +101,18 @@ (increment-row! ctx) (cond [(not (= (char->integer #\newline) (car pair))) - ;; ERROR expected newline after CR - 'error - ] + (throw 'fold-error "Expected newline after CR")] [(memv (integer->char (cdr pair)) '(#\space #\tab)) (increment-column! ctx) - 'fold - ] - - #; - [ungetc... - 'writeback-error - ] + 'fold] [else - ;; ... - 'end-of-line - ] + ;; TODO check if this failed, and signal a writeback error + (unget-char (current-input-port) + (integer->char (cdr pair))) + + 'end-of-line] ))) @@ -123,9 +127,12 @@ (let ((c (get-u8 (current-input-port)))) (cond + ;; End of file [(eof-object? c) + ;; TODO handle final line here (break)] + ;; End of line [(memv (integer->char c) '(#\return #\newline)) (case (fold-proc ctx c) [(error writeback-error) => (lambda (t) (throw t))] @@ -150,24 +157,33 @@ (strbuf-reset! strbuf) (set-ctx! ctx 'key))])] + ;; Escaped characters [(char=? (integer->char c) #\\) - (let ((cc (get-u8 (current-input-port)))) + (let ((cc (integer->char (get-u8 (current-input-port))))) (case cc - [(#\return #\newline) ;; TODO fold? - (fold-proc ctx cc) - ] + ;; Escape character '\' and escaped token sepparated by a newline + ;; (since the standard for some reason allows that (!!!)) + ;; We are at least guaranteed that it's a folded line, so just + ;; unfold it and continue trying to find a token to escape. + [(#\return #\newline) + (case (fold-proc ctx cc) + [(end-of-line) (throw 'escape-error "ESC before not folded line")] + [(fold) + (increment-column! ctx) + (strbuf-append! strbuf (get-u8 (current-input-port)))])] [(#\n #\N) (strbuf-append! strbuf (char->integer #\newline))] [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf c))] - [else 'err] - ) + [else (throw 'escape-error "Non-escapable character" cc)]) (increment-column! ctx))] + ;; Delimiter between param key and param value [(and (eq? (get-ctx ctx) 'panam-name) (char=? (integer->char c) #\=)) (set-param-key! ctx (strbuf->string strbuf)) (strbuf-reset! strbuf) (set-ctx! ctx 'param-value)] + ;; Delimiter between parameters (;), or between "something" and attribute value (:) [(memv (integer->char c) '(#\: #\;)) (case (get-ctx ctx) [(param-value) @@ -182,17 +198,22 @@ [(#\:) 'value] [(#\;) 'param-name]))] + ;; Regular character [else (strbuf-append! strbuf c) (increment-column! ctx) ])))) + (lambda (err . args) (format #t "err = ~a~%ctx = ~a~%args = ~a~%" err ctx args) )))) -;;; TODO + +;;; These parts are more or less taken verbatim (with language trans- +;;; literation) from calendar.c. The code is horcrible from a scheme +;;; perspective. TODO replace it with propper code. (define (open-ics path cal) (define f (open-input-file path)) @@ -224,6 +245,11 @@ root) -(define root (parse-cal-path "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics")) + +(define *path* "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics") +(define root (parse-cal-path *path*)) (format #t "root = ~a~%" root) + + + -- cgit v1.2.3 From 6dd5ff6ff9915259cfd23ad757408e1697d852a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 2 Nov 2019 18:24:30 +0100 Subject: Parser works now. --- src/main.scm | 24 ++++++ src/parse.scm | 237 ++++++++++++++++++++++++++-------------------------------- 2 files changed, 129 insertions(+), 132 deletions(-) create mode 100755 src/main.scm diff --git a/src/main.scm b/src/main.scm new file mode 100755 index 00000000..efc4e897 --- /dev/null +++ b/src/main.scm @@ -0,0 +1,24 @@ +#!/usr/bin/guile \ +-e main -s +!# + +(add-to-load-path (dirname (current-filename))) + +(use-modules (parse)) + +(define (main args) + +;; (define *path* "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics") +;; (define root (parse-cal-path *path*)) + +;; (format #t "root = ~a~%" root) + + + (format (current-error-port) "Parsing ~s~%" (cadr args)) + (let ((cal (read-vcalendar (cadr args)))) + (format #t "cal = ~a~%" cal) + (format (current-error-port) "~a events~%" (length cal))) + + ) + + diff --git a/src/parse.scm b/src/parse.scm index 3f245002..9b7098b9 100644 --- a/src/parse.scm +++ b/src/parse.scm @@ -4,6 +4,7 @@ :use-module (rnrs bytevectors) :use-module (srfi srfi-9) :use-module ((ice-9 textual-ports) :select (unget-char)) + :use-module ((ice-9 ftw) :select (scandir)) ) @@ -44,8 +45,9 @@ (define contexts '(key value param-name param-value escape)) (define-record-type - (make-parse-ctx% row col ctx line-key param-key param-table) + (make-parse-ctx% filename row col ctx line-key param-key param-table) parse-ctx? + (filename get-filename) (row get-row set-row!) (col get-col set-col!) (ctx get-ctx set-ctx!) @@ -54,8 +56,8 @@ (param-table get-param-table set-param-table!) ) -(define (make-parse-ctx) - (make-parse-ctx% 0 0 'key +(define (make-parse-ctx filename) + (make-parse-ctx% filename 1 0 'key #f #f (make-hash-table))) (define (increment-column! ctx) @@ -116,140 +118,111 @@ ))) -(define (parse-file filename file root) - (set-current-input-port file) - (let ((component root) - (ctx (make-parse-ctx)) - (strbuf (make-strbuf))) - (catch #t - (lambda () - (while #t - (let ((c (get-u8 (current-input-port)))) - (cond - - ;; End of file - [(eof-object? c) - ;; TODO handle final line here - (break)] - - ;; End of line - [(memv (integer->char c) '(#\return #\newline)) - (case (fold-proc ctx c) - [(error writeback-error) => (lambda (t) (throw t))] - [(end-of-line) - (let ((str (strbuf->string strbuf))) - (cond [(string=? (get-line-key ctx) "BEGIN") - (let ((child (make-vcomponent (string->symbol str)))) - (add-child! component child) - (set! component child))] - - [(string=? (get-line-key ctx) "END") - (set! component (get-component-parent component))] - - [else - (let ((ht (get-component-attributes component))) - ;; TODO repeated keys - (hashq-set! ht (string->symbol (get-line-key ctx)) - (cons (get-param-table ctx) - str)) - (set-param-table! ctx (make-hash-table)))]) - - (strbuf-reset! strbuf) - (set-ctx! ctx 'key))])] - - ;; Escaped characters - [(char=? (integer->char c) #\\) - (let ((cc (integer->char (get-u8 (current-input-port))))) - (case cc - ;; Escape character '\' and escaped token sepparated by a newline - ;; (since the standard for some reason allows that (!!!)) - ;; We are at least guaranteed that it's a folded line, so just - ;; unfold it and continue trying to find a token to escape. - [(#\return #\newline) - (case (fold-proc ctx cc) - [(end-of-line) (throw 'escape-error "ESC before not folded line")] - [(fold) - (increment-column! ctx) - (strbuf-append! strbuf (get-u8 (current-input-port)))])] - [(#\n #\N) - (strbuf-append! strbuf (char->integer #\newline))] - [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf c))] - [else (throw 'escape-error "Non-escapable character" cc)]) - (increment-column! ctx))] - - ;; Delimiter between param key and param value - [(and (eq? (get-ctx ctx) 'panam-name) (char=? (integer->char c) #\=)) - (set-param-key! ctx (strbuf->string strbuf)) - (strbuf-reset! strbuf) - (set-ctx! ctx 'param-value)] - - ;; Delimiter between parameters (;), or between "something" and attribute value (:) - [(memv (integer->char c) '(#\: #\;)) - (case (get-ctx ctx) - [(param-value) - (hashq-set! (get-param-table ctx) - (get-param-key ctx) - (strbuf->string strbuf)) - (strbuf-reset! strbuf)] - [(key) - (set-line-key! ctx (strbuf->string strbuf)) - (strbuf-reset! strbuf)]) - (set-ctx! ctx (case c - [(#\:) 'value] - [(#\;) 'param-name]))] - - ;; Regular character - [else - (strbuf-append! strbuf c) - (increment-column! ctx) - ])))) - - (lambda (err . args) - (format #t "err = ~a~%ctx = ~a~%args = ~a~%" - err ctx args) - )))) +(define (parse-calendar port) + (with-input-from-port port + (lambda () + (let ((component (make-vcomponent)) + (ctx (make-parse-ctx (port-filename port))) + (strbuf (make-strbuf))) + (catch #t + (lambda () + (while #t + (let ((c (get-u8 (current-input-port)))) + (cond + + ;; End of file + [(eof-object? c) + ;; TODO handle final line here + (break)] + + ;; End of line + [(memv (integer->char c) '(#\return #\newline)) + (case (fold-proc ctx c) + [(error writeback-error) => (lambda (t) (throw t))] + [(end-of-line) + (let ((str (strbuf->string strbuf))) + (cond [(string=? (get-line-key ctx) "BEGIN") + (let ((child (make-vcomponent (string->symbol str)))) + (add-child! component child) + (set! component child))] + + [(string=? (get-line-key ctx) "END") + (set! component (get-component-parent component))] + + [else + (let ((ht (get-component-attributes component))) + ;; TODO repeated keys + (hashq-set! ht (string->symbol (get-line-key ctx)) + (cons (get-param-table ctx) + str)) + (set-param-table! ctx (make-hash-table)))]) + + (strbuf-reset! strbuf) + (set-ctx! ctx 'key))])] + + ;; Escaped characters + [(char=? (integer->char c) #\\) + (let ((cc (integer->char (get-u8 (current-input-port))))) + (case cc + ;; Escape character '\' and escaped token sepparated by a newline + ;; (since the standard for some reason allows that (!!!)) + ;; We are at least guaranteed that it's a folded line, so just + ;; unfold it and continue trying to find a token to escape. + [(#\return #\newline) + (case (fold-proc ctx cc) + [(end-of-line) (throw 'escape-error "ESC before not folded line")] + [(fold) + (increment-column! ctx) + (strbuf-append! strbuf (get-u8 (current-input-port)))])] + [(#\n #\N) + (strbuf-append! strbuf (char->integer #\newline))] + [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf (char->integer c)))] + [else (throw 'escape-error "Non-escapable character" cc)]) + (increment-column! ctx))] + + ;; Delimiter between param key and param value + [(and (eq? (get-ctx ctx) 'panam-name) (char=? (integer->char c) #\=)) + (set-param-key! ctx (strbuf->string strbuf)) + (strbuf-reset! strbuf) + (set-ctx! ctx 'param-value)] + + ;; Delimiter between parameters (;), or between "something" and attribute value (:) + [(memv (integer->char c) '(#\: #\;)) + (case (get-ctx ctx) + [(param-value) + (hashq-set! (get-param-table ctx) + (get-param-key ctx) + (strbuf->string strbuf)) + (strbuf-reset! strbuf)] + [(key) + (set-line-key! ctx (strbuf->string strbuf)) + (strbuf-reset! strbuf)]) + (set-ctx! ctx (case c + [(#\:) 'value] + [(#\;) 'param-name]))] + + ;; Regular character + [else + (strbuf-append! strbuf c) + (increment-column! ctx) + ]))) + component) + + (lambda (err . args) + (format (current-error-port) "err = ~a~%ctx = ~a~%args = ~s~%" + err ctx args) + )))))) -;;; These parts are more or less taken verbatim (with language trans- -;;; literation) from calendar.c. The code is horcrible from a scheme -;;; perspective. TODO replace it with propper code. - -(define (open-ics path cal) - (define f (open-input-file path)) - (parse-file path f cal)) - -(define (handle-dir cal path) - 'TODO - ;; TODO - ) - -(define (handle-file cal path) - (set-attribute! cal 'X-HNH-SOURCETYPE "file") - (open-ics path cal) - ) - - -(define (read-vcalendar root path) +(define-public (read-vcalendar path) (define st (stat path)) (case (stat:type st) - [(regular) (handle-file root path)] - [(directory) (handle-dir root path)] + [(regular) (call-with-input-file path parse-calendar)] + [(directory) (map (lambda (fname) (call-with-input-file (string-append path file-name-separator-string fname) + parse-calendar)) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3))))))] [(block-special char-special fifo socket unknown symlink) => (lambda (t) (throw t))]) ) - -(define (parse-cal-path path) - (define root (make-vcomponent)) - (read-vcalendar root path) - root) - - - -(define *path* "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics") -(define root (parse-cal-path *path*)) - -(format #t "root = ~a~%" root) - - - -- cgit v1.2.3 From f2a6efedc594533c5d755bf0d8bec8814f459834 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 2 Nov 2019 19:56:52 +0100 Subject: General improvements. --- src/parse.scm | 303 +++++++++++++++++++++++++++++++++------------------------- 1 file changed, 174 insertions(+), 129 deletions(-) diff --git a/src/parse.scm b/src/parse.scm index 9b7098b9..a6f3bed1 100644 --- a/src/parse.scm +++ b/src/parse.scm @@ -4,9 +4,7 @@ :use-module (rnrs bytevectors) :use-module (srfi srfi-9) :use-module ((ice-9 textual-ports) :select (unget-char)) - :use-module ((ice-9 ftw) :select (scandir)) - - ) + :use-module ((ice-9 ftw) :select (scandir))) @@ -28,11 +26,12 @@ (define* (get-attribute-value component key #:optional default) (cond [(hashq-ref (get-component-attributes component) key #f) - => (lambda (p) (cdr p))] + => cdr] [else default])) (define (get-attribute component key) - (hashq-ref (get-component-attributes component) key)) + (hashq-ref (get-component-attributes component) + key)) (define (set-attribute! component key value) (let ((ht (get-component-attributes component))) @@ -42,18 +41,16 @@ -(define contexts '(key value param-name param-value escape)) - (define-record-type (make-parse-ctx% filename row col ctx line-key param-key param-table) parse-ctx? - (filename get-filename) - (row get-row set-row!) - (col get-col set-col!) - (ctx get-ctx set-ctx!) - (line-key get-line-key set-line-key!) - (param-key get-param-key set-param-key!) - (param-table get-param-table set-param-table!) + (filename get-filename) ; string + (row get-row set-row!) ; [0, ] + (col get-col set-col!) ; [1, ) + (ctx get-ctx set-ctx!) ; '(key value param-name param-value escape) + (line-key get-line-key set-line-key!) ; string + (param-key get-param-key set-param-key!) ; string + (param-table get-param-table set-param-table!) ; hash-map ) (define (make-parse-ctx filename) @@ -73,12 +70,17 @@ (make-strbuf% len bytes) strbuf? (len get-length set-length!) - (bytes get-bytes) - ) + (bytes get-bytes set-bytes!)) (define (make-strbuf) - (make-strbuf% 0 (make-u8vector #x1000)) - ) + (make-strbuf% 0 (make-u8vector #x1000))) + +(define (strbuf-realloc! strbuf) + (let* ((len (u8vector-length (get-bytes strbuf))) + (nv (make-u8vector (ash len 1)))) + (bytevector-copy! (get-bytes strbuf) 0 + nv 0 len) + (set-bytes! strbuf nv))) (define (strbuf->string strbuf) (let ((bv (make-u8vector (get-length strbuf)))) @@ -91,22 +93,41 @@ (set-length! strbuf 0)) (define (strbuf-append! strbuf u8) - (u8vector-set! (get-bytes strbuf) - (get-length strbuf) - u8) + (catch 'out-of-range + (lambda () + (u8vector-set! (get-bytes strbuf) + (get-length strbuf) + u8)) + (lambda (err . args) + (strbuf-realloc! strbuf) + (strbuf-append! strbuf u8))) (set-length! strbuf (1+ (get-length strbuf)))) + + (define (fold-proc ctx c) - (let ((pair (cons (if (= c (char->integer #\newline)) - c (get-u8 (current-input-port))) - (get-u8 (current-input-port))))) + ;; First extra character optionall read is to get the \n if our line + ;; ended with \r\n. Secound read is to get the first character of the + ;; next line. The initial \r which might recide in @var{c} is discarded. + (let ((pair (cons (if (char=? #\newline (integer->char c)) + c (get-u8 (current-input-port))) + (get-u8 (current-input-port))))) (increment-row! ctx) - (cond [(not (= (char->integer #\newline) - (car pair))) - (throw 'fold-error "Expected newline after CR")] + (cond [(not (char=? #\newline (integer->char (car pair)))) + (error "Expected newline after CR")] + + ;; The standard (3.4, l. 2675) says that each icalobject must + ;; end with CRLF. My files however does not. This means that + ;; an EOF can immideately follow a \n\r pair. But this case is the + ;; same as that we are at the end of line, so we spoof it and let + ;; the regular parser loop handle it. + [(eof-object? (cdr pair)) + 'end-of-line] + ;; Following line begins with a whitespace character, + ;; meaning that we don't break the logical line here. [(memv (integer->char (cdr pair)) '(#\space #\tab)) - (increment-column! ctx) + (increment-column! ctx) ; since we just read the space 'fold] [else @@ -114,115 +135,139 @@ (unget-char (current-input-port) (integer->char (cdr pair))) - 'end-of-line] - - ))) + 'end-of-line]))) (define (parse-calendar port) (with-input-from-port port (lambda () - (let ((component (make-vcomponent)) - (ctx (make-parse-ctx (port-filename port))) - (strbuf (make-strbuf))) - (catch #t - (lambda () - (while #t - (let ((c (get-u8 (current-input-port)))) - (cond - - ;; End of file - [(eof-object? c) - ;; TODO handle final line here - (break)] - - ;; End of line - [(memv (integer->char c) '(#\return #\newline)) - (case (fold-proc ctx c) - [(error writeback-error) => (lambda (t) (throw t))] - [(end-of-line) - (let ((str (strbuf->string strbuf))) - (cond [(string=? (get-line-key ctx) "BEGIN") - (let ((child (make-vcomponent (string->symbol str)))) - (add-child! component child) - (set! component child))] - - [(string=? (get-line-key ctx) "END") - (set! component (get-component-parent component))] - - [else - (let ((ht (get-component-attributes component))) - ;; TODO repeated keys - (hashq-set! ht (string->symbol (get-line-key ctx)) - (cons (get-param-table ctx) - str)) - (set-param-table! ctx (make-hash-table)))]) - - (strbuf-reset! strbuf) - (set-ctx! ctx 'key))])] - - ;; Escaped characters - [(char=? (integer->char c) #\\) - (let ((cc (integer->char (get-u8 (current-input-port))))) - (case cc - ;; Escape character '\' and escaped token sepparated by a newline - ;; (since the standard for some reason allows that (!!!)) - ;; We are at least guaranteed that it's a folded line, so just - ;; unfold it and continue trying to find a token to escape. - [(#\return #\newline) - (case (fold-proc ctx cc) - [(end-of-line) (throw 'escape-error "ESC before not folded line")] - [(fold) - (increment-column! ctx) - (strbuf-append! strbuf (get-u8 (current-input-port)))])] - [(#\n #\N) - (strbuf-append! strbuf (char->integer #\newline))] - [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf (char->integer c)))] - [else (throw 'escape-error "Non-escapable character" cc)]) - (increment-column! ctx))] - - ;; Delimiter between param key and param value - [(and (eq? (get-ctx ctx) 'panam-name) (char=? (integer->char c) #\=)) - (set-param-key! ctx (strbuf->string strbuf)) - (strbuf-reset! strbuf) - (set-ctx! ctx 'param-value)] - - ;; Delimiter between parameters (;), or between "something" and attribute value (:) - [(memv (integer->char c) '(#\: #\;)) - (case (get-ctx ctx) - [(param-value) - (hashq-set! (get-param-table ctx) - (get-param-key ctx) - (strbuf->string strbuf)) - (strbuf-reset! strbuf)] - [(key) - (set-line-key! ctx (strbuf->string strbuf)) - (strbuf-reset! strbuf)]) - (set-ctx! ctx (case c - [(#\:) 'value] - [(#\;) 'param-name]))] - - ;; Regular character - [else - (strbuf-append! strbuf c) - (increment-column! ctx) - ]))) - component) - - (lambda (err . args) - (format (current-error-port) "err = ~a~%ctx = ~a~%args = ~s~%" - err ctx args) - )))))) + (let ((component (make-vcomponent)) + (ctx (make-parse-ctx (port-filename port))) + (strbuf (make-strbuf))) + (with-throw-handler #t + (lambda () + (while #t + (let ((c (get-u8 (current-input-port)))) + (cond + + ;; End of file + [(eof-object? c) + ;; == NOTE == + ;; We never check the final line here. But since it + ;; ALWAYS should be "END:VCOMPONENT", and we do all + ;; the setup at creation this shouldn't be a problem. + (break (case (get-ctx ctx) + [(key) ; line ended + (let ((root-component + (car (get-component-children component)))) + (set-component-parent! root-component #f) + root-component)] + [(value) ; still ending line + (set-component-parent! component #f) + component] + [else => (lambda (a) + (scm-error 'wrong-type-arg "parse-break" + (string-append + "Bad context at end of file. " + "Expected `key' or `value', got ~a") + (list a) #f))]))] + + ;; End of line + [(memv (integer->char c) '(#\return #\newline)) + (case (fold-proc ctx c) + [(end-of-line) + (let ((str (strbuf->string strbuf))) + (cond [(string=? (get-line-key ctx) "BEGIN") + (let ((child (make-vcomponent (string->symbol str)))) + (add-child! component child) + (set! component child))] + + [(string=? (get-line-key ctx) "END") + (set! component (get-component-parent component))] + + [else + (let ((ht (get-component-attributes component))) + ;; TODO repeated keys + (hashq-set! ht (string->symbol (get-line-key ctx)) + (cons (get-param-table ctx) + str)) + (set-param-table! ctx (make-hash-table)))]) + + (strbuf-reset! strbuf) + (set-ctx! ctx 'key))] + [(fold) 'noop] ; Good case, here to catch errors in else + [else => (lambda (a) (error "Bad return from fold, unexpected" a))])] + + ;; Escaped characters + [(char=? #\\ (integer->char c)) + (case (integer->char (get-u8 (current-input-port))) + ;; Escape character '\' and escaped token sepparated by a newline + ;; (since the standard for some reason allows that (!!!)) + ;; We are at least guaranteed that it's a folded line, so just + ;; unfold it and continue trying to find a token to escape. + [(#\return #\newline) + => (lambda (c) + (case (fold-proc ctx (char->integer c)) + [(end-of-line) + (throw 'escape-error "ESC before not folded line")] + [(fold) + (increment-column! ctx) + (strbuf-append! strbuf (get-u8 (current-input-port)))]))] + + [(#\n #\N) (strbuf-append! strbuf (char->integer #\newline))] + [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf (char->integer c)))] + [else => (lambda (c) (throw 'escape-error "Non-escapable character" c))]) + (increment-column! ctx)] + + ;; Delimiter between param key and param value + [(and (eq? (get-ctx ctx) 'panam-name) (char=? #\= (integer->char c))) + (set-param-key! ctx (strbuf->string strbuf)) + (strbuf-reset! strbuf) + (set-ctx! ctx 'param-value)] + + ;; Delimiter between parameters (;), or between + ;; "something" and attribute value (:) + [(memv (integer->char c) '(#\: #\;)) + (case (get-ctx ctx) + [(param-value) + (hashq-set! (get-param-table ctx) + (get-param-key ctx) + (strbuf->string strbuf)) + (strbuf-reset! strbuf)] + [(key) + (set-line-key! ctx (strbuf->string strbuf)) + (strbuf-reset! strbuf)]) + + (set-ctx! ctx (case (integer->char c) + [(#\:) 'value] + [(#\;) 'param-name]))] + + ;; Regular character + [else + (strbuf-append! strbuf c) + (increment-column! ctx)])))) + + (lambda _ + (format (current-error-port) + "== PARSE ERROR == +filename = ~a +row ~a column ~a ctx = ~a +~a ; ~a = ... : ...~%~%" + (get-filename ctx) + (get-row ctx) (get-col ctx) (get-ctx ctx) + (get-line-key ctx) (get-param-key ctx)))))))) (define-public (read-vcalendar path) (define st (stat path)) (case (stat:type st) - [(regular) (call-with-input-file path parse-calendar)] - [(directory) (map (lambda (fname) (call-with-input-file (string-append path file-name-separator-string fname) - parse-calendar)) - (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) - (string= "ics" (string-take-right s 3))))))] + [(regular) (list (call-with-input-file path parse-calendar))] + [(directory) + (map (lambda (fname) + (call-with-input-file + (string-append path file-name-separator-string fname) + parse-calendar)) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3))))))] [(block-special char-special fifo socket unknown symlink) - => (lambda (t) (throw t))]) - ) + => (lambda (t) (error "Can't parse file of type " t))])) -- cgit v1.2.3 From a7af12880e92d382653bb4231a05fbf4da3a804a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 2 Nov 2019 20:08:24 +0100 Subject: Add slightly silly parse-tree. --- src/main.scm | 2 +- src/parse.scm | 22 +++++++++++++++++++++- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/src/main.scm b/src/main.scm index efc4e897..408b9de0 100755 --- a/src/main.scm +++ b/src/main.scm @@ -15,7 +15,7 @@ (format (current-error-port) "Parsing ~s~%" (cadr args)) - (let ((cal (read-vcalendar (cadr args)))) + (let ((cal (read-tree (cadr args)))) (format #t "cal = ~a~%" cal) (format (current-error-port) "~a events~%" (length cal))) diff --git a/src/parse.scm b/src/parse.scm index a6f3bed1..b11240df 100644 --- a/src/parse.scm +++ b/src/parse.scm @@ -4,7 +4,7 @@ :use-module (rnrs bytevectors) :use-module (srfi srfi-9) :use-module ((ice-9 textual-ports) :select (unget-char)) - :use-module ((ice-9 ftw) :select (scandir))) + :use-module ((ice-9 ftw) :select (scandir ftw))) @@ -271,3 +271,23 @@ row ~a column ~a ctx = ~a (string= "ics" (string-take-right s 3))))))] [(block-special char-special fifo socket unknown symlink) => (lambda (t) (error "Can't parse file of type " t))])) + + +(define-public (read-tree path) + (define list '()) + (ftw path + (lambda (filename statinfo flag) + (case flag + [(regular) + (case (stat:type statinfo) + [(regular) + (when (and (not (string= "." (string-take filename 1))) + (string= "ics" (string-take-right filename 3))) + (set! list (cons filename list))) + #t] + [else #t])] + [(directory) #t] + [else #f]))) + ((@ (ice-9 threads) n-par-map) 12 + (lambda (fname) (call-with-input-file fname parse-calendar)) + list)) -- cgit v1.2.3 From 55468e5000e6ab91fd27c054b6398325f1efeeb9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 2 Nov 2019 22:26:33 +0100 Subject: Minor changes to env and ical. --- env | 6 +++--- module/output/ical.scm | 14 +++++++------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/env b/env index 2ba1cd1d..c1bd360f 100755 --- a/env +++ b/env @@ -3,10 +3,10 @@ root=$(dirname $(realpath $BASH_SOURCE)) GUILE_LOAD_PATH="$root/module:$GUILE_LOAD_PATH" -GUILE_LOAD_COMPILED_PATH="$root/obj/module:$GUILE_LOAD_COMPILED_PATH" -LD_LIBRARY_PATH="$root/lib:$LD_LIBRARY_PATH" +#GUILE_LOAD_COMPILED_PATH="$root/obj/module:$GUILE_LOAD_COMPILED_PATH" +#LD_LIBRARY_PATH="$root/lib:$LD_LIBRARY_PATH" export GUILE_LOAD_PATH GUILE_LOAD_COMPILED_PATH LD_LIBRARY_PATH -export GUILE_AUTO_COMPILE=0 +#export GUILE_AUTO_COMPILE=0 # exec "$@" diff --git a/module/output/ical.scm b/module/output/ical.scm index c8d9a11d..5eff7915 100644 --- a/module/output/ical.scm +++ b/module/output/ical.scm @@ -1,11 +1,11 @@ (define-module (output ical) - use-module: (ice-9 getopt-long) - use-module: (ice-9 format) - use-module: (vcomponent) - use-module: (srfi srfi-19) - use-module: (srfi srfi-19 util) - use-module: (srfi srfi-41) - use-module: (srfi srfi-41 util) + :use-module (ice-9 getopt-long) + :use-module (ice-9 format) + :use-module (vcomponent) + :use-module (srfi srfi-19) + :use-module (srfi srfi-19 util) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) ) (define opt-spec -- cgit v1.2.3 From 4cfb8ec5e6dad161dfefb683a64490d468caad7e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 2 Nov 2019 22:26:18 +0100 Subject: Move parser into module subtree. --- module/vcomponent.scm | 5 +- module/vcomponent/base.scm | 86 ++++++----- module/vcomponent/parse.scm | 322 ++++++++++++++++++++++++++++++++++++++++ module/vcomponent/primitive.scm | 9 -- src/parse.scm | 293 ------------------------------------ 5 files changed, 373 insertions(+), 342 deletions(-) create mode 100644 module/vcomponent/parse.scm delete mode 100644 module/vcomponent/primitive.scm delete mode 100644 src/parse.scm diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 8751440d..d3e574b5 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,7 +1,4 @@ (define-module (vcomponent) - #:use-module ((vcomponent primitive) - :select (parse-cal-path - (make-vcomponent . primitive-make-vcomponent))) #:use-module (vcomponent datetime) #:use-module (vcomponent recurrence) #:use-module (vcomponent timezone) @@ -124,7 +121,7 @@ ;; return accum)) - ((no-type) (throw 'no-type))))) + ((no-type) (error 'no-type))))) (parse-dates! component) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 98b2aa89..f43f532e 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -2,33 +2,43 @@ :use-module (util) :use-module (srfi srfi-1) :use-module (srfi srfi-17) - :use-module (vcomponent primitive) + :use-module ((vcomponent parse) + :renamer (lambda (symb) + (case symb + ;; [(set-attribute!) 'get-attribute] + [(make-vcomponent) 'primitive-make-vcomponent] + [else symb]))) :use-module (ice-9 hash-table) :use-module ((ice-9 optargs) :select (define*-public)) - :re-export (add-child!)) + :re-export (add-child! primitive-make-vcomponent)) + +(define-public (parse-cal-path path) + (let ((parent (primitive-make-vcomponent))) + (for-each (lambda (child) (add-child! parent child)) + (read-vcalendar path)) + (if (null? (get-component-children parent)) + (set-attribute! parent 'X-HNH-SOURCETYPE "vdir") + (set-attribute! parent 'X-HNH-SOURCETYPE + (get-attribute-value (car (get-component-children parent)) + 'X-HNH-SOURCETYPE "vdir"))) + parent)) ;; vline → value (define-public value (make-procedure-with-setter - (lambda (vline) (struct-ref vline 0)) - (lambda (vline value) (struct-set! vline 0 value)))) + get-vline-value set-vline-value!)) ;; vcomponent x (or str symb) → vline (define-public (attr* component attr) - (hash-ref (struct-ref component 3) - (as-string attr))) + (hashq-ref (get-component-attributes component) + (as-symb attr))) ;; vcomponent x (or str symb) → value -(define (get-attr component attr) - (and=> (attr* component attr) - value)) +(define (get-attr component key) + (get-attribute-value component (as-symb key) #f)) -(define (set-attr! component attr value) - (aif (attr* component attr) - (struct-set! it 0 value) - (hash-set! (struct-ref component 3) - (as-string attr) - (make-vline value)))) +(define (set-attr! component key value) + (set-attribute! component (as-symb key) value)) (define-public attr (make-procedure-with-setter @@ -39,42 +49,46 @@ (define-public prop (make-procedure-with-setter (lambda (attr-obj prop-key) - (hash-ref (struct-ref attr-obj 1) (as-string prop-key))) + ;; TODO `list' is a hack since a bit to much code depends + ;; on prop always returning a list of values. + (and=> (hashq-ref (get-vline-parameters attr-obj) + (as-symb prop-key)) + list)) (lambda (attr-obj prop-key val) - (hash-set! (struct-ref attr-obj 1) (as-string prop-key) val)))) + (hashq-set! (get-vline-parameters attr-obj) + (as-symb prop-key) val)))) ;; Returns the properties of attribute as an assoc list. ;; @code{(map car <>)} leads to available properties. (define-public (properties attrptr) - (hash-map->list cons (struct-ref attrptr 1))) + (hash-map->list cons (get-attribute-parameters attrptr))) (define-public type (make-procedure-with-setter - (lambda (c) (struct-ref c 0)) - (lambda (c v) struct-set! c 0 v) - )) + (lambda (c) (component-type c)) + (lambda (c v) ; struct-set! c 0 v + (format (current-error-port) + "This method is a deprecated NOOP")))) -(define-public (parent c) (struct-ref c 2)) +(define-public parent get-component-parent) (define-public (attributes component) - (hash-map->list cons (struct-ref component 3))) + (hash-map->list cons (get-component-attributes component))) -(define*-public (children component) - (struct-ref component 1)) +(define*-public children get-component-children) (define (copy-vline vline) - (make-struct/no-tail (struct-vtable vline) - (struct-ref vline 0) - ;; TODO deep-copy on properties? - (struct-ref vline 1))) + (make-vline (get-vline-value vline) + ;; TODO deep-copy on properties? + (get-vline-parameters vline))) (define-public (copy-vcomponent component) - (make-struct/no-tail (struct-vtable component) - (struct-ref component 0) - (struct-ref component 1) - (struct-ref component 2) - (alist->hash-table - (hash-map->list (lambda (key value) (cons key (copy-vline value))) - (struct-ref component 3))))) + (make-vcomponent% (component-type component) + (get-component-children component) + (get-component-parent component) + ;; attributes + (alist->hashq-table + (hash-map->list (lambda (key value) (cons key (copy-vline value))) + (get-component-attributes component))))) (define-public (extract field) (lambda (e) (attr e field))) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm new file mode 100644 index 00000000..9eabacb3 --- /dev/null +++ b/module/vcomponent/parse.scm @@ -0,0 +1,322 @@ + +(define-module (vcomponent parse) + :use-module (rnrs io ports) + :use-module (rnrs bytevectors) + :use-module (srfi srfi-9) + :use-module ((ice-9 textual-ports) :select (unget-char)) + :use-module ((ice-9 ftw) :select (scandir ftw))) + + + +(define-record-type + (make-vline% value parameters) + vline? + (value get-vline-value set-vline-value!) + (parameters get-vline-parameters)) + +(define* (make-vline value #:optional ht) + (make-vline% value (or ht (make-hash-table)))) + +(define-record-type + (make-vcomponent% type children parent attributes) + vcomponent? + (type component-type) + (children get-component-children set-component-children!) + (parent get-component-parent set-component-parent!) + (attributes get-component-attributes)) + +(define* (make-vcomponent #:optional (type 'VIRTUAL)) + (make-vcomponent% type '() #f (make-hash-table #x10))) + +(define (add-child! parent child) + (set-component-children! parent (cons child (get-component-children parent))) + (set-component-parent! child parent)) + +(define* (get-attribute-value component key #:optional default) + (cond [(hashq-ref (get-component-attributes component) + key #f) + => get-vline-value] + [else default])) + +(define (get-attribute component key) + (hashq-ref (get-component-attributes component) + key)) + +(define (set-attribute! component key value) + (let ((ht (get-component-attributes component))) + (cond [(hashq-ref ht key #f) + => (lambda (vline) (set-vline-value! vline value))] + [else (hashq-set! ht key (make-vline value))]))) + +(define (set-vline! component key vline) + (hashq-set! (get-component-attributes component) + key vline)) + + + +(define-record-type + (make-parse-ctx% filename row col ctx line-key param-key param-table) + parse-ctx? + (filename get-filename) ; string + (row get-row set-row!) ; [0, ] + (col get-col set-col!) ; [1, ) + (ctx get-ctx set-ctx!) ; '(key value param-name param-value escape) + (line-key get-line-key set-line-key!) ; string + (param-key get-param-key set-param-key!) ; string + (param-table get-param-table set-param-table!) ; hash-map + ) + +(define (make-parse-ctx filename) + (make-parse-ctx% filename 1 0 'key + #f #f (make-hash-table))) + +(define (increment-column! ctx) + (set-col! ctx (1+ (get-col ctx)))) + +(define (increment-row! ctx) + (set-col! ctx 0) + (set-row! ctx (1+ (get-row ctx)))) + + + +(define-record-type + (make-strbuf% len bytes) + strbuf? + (len get-length set-length!) + (bytes get-bytes set-bytes!)) + +(define (make-strbuf) + (make-strbuf% 0 (make-u8vector #x1000))) + +(define (strbuf-realloc! strbuf) + (let* ((len (u8vector-length (get-bytes strbuf))) + (nv (make-u8vector (ash len 1)))) + (bytevector-copy! (get-bytes strbuf) 0 + nv 0 len) + (set-bytes! strbuf nv))) + +(define (strbuf->string strbuf) + (let ((bv (make-u8vector (get-length strbuf)))) + (bytevector-copy! (get-bytes strbuf) 0 + bv 0 + (get-length strbuf)) + (bytevector->string bv (native-transcoder)))) ; TODO charset + +(define (strbuf-reset! strbuf) + (set-length! strbuf 0)) + +(define (strbuf-append! strbuf u8) + (catch 'out-of-range + (lambda () + (u8vector-set! (get-bytes strbuf) + (get-length strbuf) + u8)) + (lambda (err . args) + (strbuf-realloc! strbuf) + (strbuf-append! strbuf u8))) + (set-length! strbuf (1+ (get-length strbuf)))) + + + +(define (fold-proc ctx c) + ;; First extra character optionall read is to get the \n if our line + ;; ended with \r\n. Secound read is to get the first character of the + ;; next line. The initial \r which might recide in @var{c} is discarded. + (let ((pair (cons (if (char=? #\newline (integer->char c)) + c (get-u8 (current-input-port))) + (get-u8 (current-input-port))))) + (increment-row! ctx) + (cond [(not (char=? #\newline (integer->char (car pair)))) + (error "Expected newline after CR")] + + ;; The standard (3.4, l. 2675) says that each icalobject must + ;; end with CRLF. My files however does not. This means that + ;; an EOF can immideately follow a \n\r pair. But this case is the + ;; same as that we are at the end of line, so we spoof it and let + ;; the regular parser loop handle it. + [(eof-object? (cdr pair)) + 'end-of-line] + + ;; Following line begins with a whitespace character, + ;; meaning that we don't break the logical line here. + [(memv (integer->char (cdr pair)) '(#\space #\tab)) + (increment-column! ctx) ; since we just read the space + 'fold] + + [else + ;; TODO check if this failed, and signal a writeback error + (unget-char (current-input-port) + (integer->char (cdr pair))) + + 'end-of-line]))) + +(define (parse-calendar port) + (with-input-from-port port + (lambda () + (let ((component (make-vcomponent)) + (ctx (make-parse-ctx (port-filename port))) + (strbuf (make-strbuf))) + (with-throw-handler #t + (lambda () + + (set-attribute! component 'X-HNH-FILENAME + (get-filename ctx)) + + (while #t + (let ((c (get-u8 (current-input-port)))) + (cond + + ;; End of file + [(eof-object? c) + ;; == NOTE == + ;; We never check the final line here. But since it + ;; ALWAYS should be "END:VCOMPONENT", and we do all + ;; the setup at creation this shouldn't be a problem. + (break (case (get-ctx ctx) + [(key) ; line ended + (let ((root-component + (car (get-component-children component)))) + (set-component-parent! root-component #f) + root-component)] + [(value) ; still ending line + (set-component-parent! component #f) + component] + [else => (lambda (a) + (scm-error 'wrong-type-arg "parse-break" + (string-append + "Bad context at end of file. " + "Expected `key' or `value', got ~a") + (list a) #f))]))] + + ;; End of line + [(memv (integer->char c) '(#\return #\newline)) + (case (fold-proc ctx c) + [(end-of-line) + (let ((str (strbuf->string strbuf))) + (cond [(eq? (get-line-key ctx) 'BEGIN) + (let ((child (make-vcomponent (string->symbol str)))) + ;; TOOD remove this copying of attributes!!! + (for-each (lambda (pair) + (set-attribute! child + (car pair) + (cdr pair))) + (hash-map->list + cons (get-component-attributes component))) + (add-child! component child) + (set! component child))] + + [(eq? (get-line-key ctx) 'END) + (set! component (get-component-parent component))] + + [else + ;; TODO repeated keys + (set-vline! component (get-line-key ctx) + (make-vline str (get-param-table ctx))) + (set-param-table! ctx (make-hash-table))]) + + (strbuf-reset! strbuf) + (set-ctx! ctx 'key))] + [(fold) 'noop] ; Good case, here to catch errors in else + [else => (lambda (a) (error "Bad return from fold, unexpected" a))])] + + ;; Escaped characters + [(char=? #\\ (integer->char c)) + (case (integer->char (get-u8 (current-input-port))) + ;; Escape character '\' and escaped token sepparated by a newline + ;; (since the standard for some reason allows that (!!!)) + ;; We are at least guaranteed that it's a folded line, so just + ;; unfold it and continue trying to find a token to escape. + [(#\return #\newline) + => (lambda (c) + (case (fold-proc ctx (char->integer c)) + [(end-of-line) + (throw 'escape-error "ESC before not folded line")] + [(fold) + (increment-column! ctx) + (strbuf-append! strbuf (get-u8 (current-input-port)))]))] + + [(#\n #\N) (strbuf-append! strbuf (char->integer #\newline))] + [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf (char->integer c)))] + [else => (lambda (c) (throw 'escape-error "Non-escapable character" c))]) + (increment-column! ctx)] + + ;; Delimiter between param key and param value + [(and (eq? (get-ctx ctx) 'param-name) + (char=? #\= (integer->char c))) + (set-param-key! ctx (string->symbol (strbuf->string strbuf))) + (strbuf-reset! strbuf) + (set-ctx! ctx 'param-value)] + + ;; Delimiter between parameters (;), or between + ;; "something" and attribute value (:) + [(and (memv (integer->char c) '(#\: #\;)) + (memv (get-ctx ctx) '(param-value key))) + (case (get-ctx ctx) + [(param-value) + (hashq-set! (get-param-table ctx) + (get-param-key ctx) + (strbuf->string strbuf)) + (strbuf-reset! strbuf)] + [(key) + (set-line-key! ctx (string->symbol (strbuf->string strbuf))) + (strbuf-reset! strbuf)]) + + (set-ctx! ctx (case (integer->char c) + [(#\:) 'value] + [(#\;) 'param-name]))] + + ;; Regular character + [else + (strbuf-append! strbuf c) + (increment-column! ctx)])))) + + (lambda _ + (format (current-error-port) + "== PARSE ERROR == +filename = ~a +row ~a column ~a ctx = ~a +~a ; ~a = ... : ...~%~%" + (get-filename ctx) + (get-row ctx) (get-col ctx) (get-ctx ctx) + (get-line-key ctx) (get-param-key ctx)))))))) + + + +(define-public (read-vcalendar path) + (define st (stat path)) + (case (stat:type st) + [(regular) (let ((comp (call-with-input-file path parse-calendar))) + (set-attribute! comp 'X-HNH-SOURCETYPE "file") + (list comp))] + [(directory) + (map (lambda (fname) + (call-with-input-file + (string-append path file-name-separator-string fname) + parse-calendar)) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3))))))] + [(block-special char-special fifo socket unknown symlink) + => (lambda (t) (error "Can't parse file of type " t))])) + + +(define-public (read-tree path) + (define list '()) + (ftw path + (lambda (filename statinfo flag) + (case flag + [(regular) + (case (stat:type statinfo) + [(regular) + (when (and (not (string= "." (string-take filename 1))) + (string= "ics" (string-take-right filename 3))) + (set! list (cons filename list))) + #t] + [else #t])] + [(directory) #t] + [else #f]))) + ((@ (ice-9 threads) n-par-map) 12 + (lambda (fname) (call-with-input-file fname parse-calendar)) + list)) + + +(export add-child! make-vcomponent get-vline-value set-vline-value! get-component-parent get-component-children get-attribute-value set-attribute! get-component-attributes component-type make-vcomponent% make-vline get-vline-parameters) diff --git a/module/vcomponent/primitive.scm b/module/vcomponent/primitive.scm deleted file mode 100644 index 5fef08cc..00000000 --- a/module/vcomponent/primitive.scm +++ /dev/null @@ -1,9 +0,0 @@ -;;; Primitive export of symbols linked from C binary. - -(define-module (vcomponent primitive) - #:export (make-vcomponent - add-line! add-child! - make-vline add-attribute! - parse-cal-path)) - -(load-extension "libguile-calendar" "init_lib") diff --git a/src/parse.scm b/src/parse.scm deleted file mode 100644 index b11240df..00000000 --- a/src/parse.scm +++ /dev/null @@ -1,293 +0,0 @@ - -(define-module (parse) - :use-module (rnrs io ports) - :use-module (rnrs bytevectors) - :use-module (srfi srfi-9) - :use-module ((ice-9 textual-ports) :select (unget-char)) - :use-module ((ice-9 ftw) :select (scandir ftw))) - - - -(define-record-type - (make-vcomponent% type children parent attributes) - vcomponent? - (type component-type) - (children get-component-children set-component-children!) - (parent get-component-parent set-component-parent!) - (attributes get-component-attributes)) - -(define* (make-vcomponent #:optional (type 'VIRTUAL)) - (make-vcomponent% type '() #f (make-hash-table #x10))) - -(define (add-child! parent child) - (set-component-children! parent (cons child (get-component-children parent))) - (set-component-parent! child parent)) - -(define* (get-attribute-value component key #:optional default) - (cond [(hashq-ref (get-component-attributes component) - key #f) - => cdr] - [else default])) - -(define (get-attribute component key) - (hashq-ref (get-component-attributes component) - key)) - -(define (set-attribute! component key value) - (let ((ht (get-component-attributes component))) - (cond [(hashq-ref ht key #f) - => (lambda (pair) (set-cdr! pair value))] - [else (hashq-set! ht key (cons (make-hash-table) value))]))) - - - -(define-record-type - (make-parse-ctx% filename row col ctx line-key param-key param-table) - parse-ctx? - (filename get-filename) ; string - (row get-row set-row!) ; [0, ] - (col get-col set-col!) ; [1, ) - (ctx get-ctx set-ctx!) ; '(key value param-name param-value escape) - (line-key get-line-key set-line-key!) ; string - (param-key get-param-key set-param-key!) ; string - (param-table get-param-table set-param-table!) ; hash-map - ) - -(define (make-parse-ctx filename) - (make-parse-ctx% filename 1 0 'key - #f #f (make-hash-table))) - -(define (increment-column! ctx) - (set-col! ctx (1+ (get-col ctx)))) - -(define (increment-row! ctx) - (set-col! ctx 0) - (set-row! ctx (1+ (get-row ctx)))) - - - -(define-record-type - (make-strbuf% len bytes) - strbuf? - (len get-length set-length!) - (bytes get-bytes set-bytes!)) - -(define (make-strbuf) - (make-strbuf% 0 (make-u8vector #x1000))) - -(define (strbuf-realloc! strbuf) - (let* ((len (u8vector-length (get-bytes strbuf))) - (nv (make-u8vector (ash len 1)))) - (bytevector-copy! (get-bytes strbuf) 0 - nv 0 len) - (set-bytes! strbuf nv))) - -(define (strbuf->string strbuf) - (let ((bv (make-u8vector (get-length strbuf)))) - (bytevector-copy! (get-bytes strbuf) 0 - bv 0 - (get-length strbuf)) - (bytevector->string bv (native-transcoder)))) ; TODO charset - -(define (strbuf-reset! strbuf) - (set-length! strbuf 0)) - -(define (strbuf-append! strbuf u8) - (catch 'out-of-range - (lambda () - (u8vector-set! (get-bytes strbuf) - (get-length strbuf) - u8)) - (lambda (err . args) - (strbuf-realloc! strbuf) - (strbuf-append! strbuf u8))) - (set-length! strbuf (1+ (get-length strbuf)))) - - - -(define (fold-proc ctx c) - ;; First extra character optionall read is to get the \n if our line - ;; ended with \r\n. Secound read is to get the first character of the - ;; next line. The initial \r which might recide in @var{c} is discarded. - (let ((pair (cons (if (char=? #\newline (integer->char c)) - c (get-u8 (current-input-port))) - (get-u8 (current-input-port))))) - (increment-row! ctx) - (cond [(not (char=? #\newline (integer->char (car pair)))) - (error "Expected newline after CR")] - - ;; The standard (3.4, l. 2675) says that each icalobject must - ;; end with CRLF. My files however does not. This means that - ;; an EOF can immideately follow a \n\r pair. But this case is the - ;; same as that we are at the end of line, so we spoof it and let - ;; the regular parser loop handle it. - [(eof-object? (cdr pair)) - 'end-of-line] - - ;; Following line begins with a whitespace character, - ;; meaning that we don't break the logical line here. - [(memv (integer->char (cdr pair)) '(#\space #\tab)) - (increment-column! ctx) ; since we just read the space - 'fold] - - [else - ;; TODO check if this failed, and signal a writeback error - (unget-char (current-input-port) - (integer->char (cdr pair))) - - 'end-of-line]))) - -(define (parse-calendar port) - (with-input-from-port port - (lambda () - (let ((component (make-vcomponent)) - (ctx (make-parse-ctx (port-filename port))) - (strbuf (make-strbuf))) - (with-throw-handler #t - (lambda () - (while #t - (let ((c (get-u8 (current-input-port)))) - (cond - - ;; End of file - [(eof-object? c) - ;; == NOTE == - ;; We never check the final line here. But since it - ;; ALWAYS should be "END:VCOMPONENT", and we do all - ;; the setup at creation this shouldn't be a problem. - (break (case (get-ctx ctx) - [(key) ; line ended - (let ((root-component - (car (get-component-children component)))) - (set-component-parent! root-component #f) - root-component)] - [(value) ; still ending line - (set-component-parent! component #f) - component] - [else => (lambda (a) - (scm-error 'wrong-type-arg "parse-break" - (string-append - "Bad context at end of file. " - "Expected `key' or `value', got ~a") - (list a) #f))]))] - - ;; End of line - [(memv (integer->char c) '(#\return #\newline)) - (case (fold-proc ctx c) - [(end-of-line) - (let ((str (strbuf->string strbuf))) - (cond [(string=? (get-line-key ctx) "BEGIN") - (let ((child (make-vcomponent (string->symbol str)))) - (add-child! component child) - (set! component child))] - - [(string=? (get-line-key ctx) "END") - (set! component (get-component-parent component))] - - [else - (let ((ht (get-component-attributes component))) - ;; TODO repeated keys - (hashq-set! ht (string->symbol (get-line-key ctx)) - (cons (get-param-table ctx) - str)) - (set-param-table! ctx (make-hash-table)))]) - - (strbuf-reset! strbuf) - (set-ctx! ctx 'key))] - [(fold) 'noop] ; Good case, here to catch errors in else - [else => (lambda (a) (error "Bad return from fold, unexpected" a))])] - - ;; Escaped characters - [(char=? #\\ (integer->char c)) - (case (integer->char (get-u8 (current-input-port))) - ;; Escape character '\' and escaped token sepparated by a newline - ;; (since the standard for some reason allows that (!!!)) - ;; We are at least guaranteed that it's a folded line, so just - ;; unfold it and continue trying to find a token to escape. - [(#\return #\newline) - => (lambda (c) - (case (fold-proc ctx (char->integer c)) - [(end-of-line) - (throw 'escape-error "ESC before not folded line")] - [(fold) - (increment-column! ctx) - (strbuf-append! strbuf (get-u8 (current-input-port)))]))] - - [(#\n #\N) (strbuf-append! strbuf (char->integer #\newline))] - [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf (char->integer c)))] - [else => (lambda (c) (throw 'escape-error "Non-escapable character" c))]) - (increment-column! ctx)] - - ;; Delimiter between param key and param value - [(and (eq? (get-ctx ctx) 'panam-name) (char=? #\= (integer->char c))) - (set-param-key! ctx (strbuf->string strbuf)) - (strbuf-reset! strbuf) - (set-ctx! ctx 'param-value)] - - ;; Delimiter between parameters (;), or between - ;; "something" and attribute value (:) - [(memv (integer->char c) '(#\: #\;)) - (case (get-ctx ctx) - [(param-value) - (hashq-set! (get-param-table ctx) - (get-param-key ctx) - (strbuf->string strbuf)) - (strbuf-reset! strbuf)] - [(key) - (set-line-key! ctx (strbuf->string strbuf)) - (strbuf-reset! strbuf)]) - - (set-ctx! ctx (case (integer->char c) - [(#\:) 'value] - [(#\;) 'param-name]))] - - ;; Regular character - [else - (strbuf-append! strbuf c) - (increment-column! ctx)])))) - - (lambda _ - (format (current-error-port) - "== PARSE ERROR == -filename = ~a -row ~a column ~a ctx = ~a -~a ; ~a = ... : ...~%~%" - (get-filename ctx) - (get-row ctx) (get-col ctx) (get-ctx ctx) - (get-line-key ctx) (get-param-key ctx)))))))) - - - -(define-public (read-vcalendar path) - (define st (stat path)) - (case (stat:type st) - [(regular) (list (call-with-input-file path parse-calendar))] - [(directory) - (map (lambda (fname) - (call-with-input-file - (string-append path file-name-separator-string fname) - parse-calendar)) - (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) - (string= "ics" (string-take-right s 3))))))] - [(block-special char-special fifo socket unknown symlink) - => (lambda (t) (error "Can't parse file of type " t))])) - - -(define-public (read-tree path) - (define list '()) - (ftw path - (lambda (filename statinfo flag) - (case flag - [(regular) - (case (stat:type statinfo) - [(regular) - (when (and (not (string= "." (string-take filename 1))) - (string= "ics" (string-take-right filename 3))) - (set! list (cons filename list))) - #t] - [else #t])] - [(directory) #t] - [else #f]))) - ((@ (ice-9 threads) n-par-map) 12 - (lambda (fname) (call-with-input-file fname parse-calendar)) - list)) -- cgit v1.2.3 From 3a1d3898c3d42d43645b79586f0b26ab4f8ff331 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 2 Nov 2019 22:29:47 +0100 Subject: Remove ALL c code. --- src/calendar.c | 173 ------------------------------- src/calendar.h | 41 -------- src/err.h | 42 -------- src/guile_type_helpers.c | 13 --- src/guile_type_helpers.h | 16 --- src/macro.h | 134 ------------------------ src/main.scm | 24 ----- src/parse.c | 264 ----------------------------------------------- src/parse.h | 99 ------------------ src/strbuf.c | 143 ------------------------- src/strbuf.h | 108 ------------------- src/struct.h | 23 ----- src/struct.scm.c | 96 ----------------- 13 files changed, 1176 deletions(-) delete mode 100644 src/calendar.c delete mode 100644 src/calendar.h delete mode 100644 src/err.h delete mode 100644 src/guile_type_helpers.c delete mode 100644 src/guile_type_helpers.h delete mode 100644 src/macro.h delete mode 100755 src/main.scm delete mode 100644 src/parse.c delete mode 100644 src/parse.h delete mode 100644 src/strbuf.c delete mode 100644 src/strbuf.h delete mode 100644 src/struct.h delete mode 100644 src/struct.scm.c diff --git a/src/calendar.c b/src/calendar.c deleted file mode 100644 index 28891330..00000000 --- a/src/calendar.c +++ /dev/null @@ -1,173 +0,0 @@ -#include "calendar.h" - -#include -#include -#include -#include -#include - -/* basename */ -#include -#include - -#include "struct.h" -#include "parse.h" -#include "err.h" - -int read_vcalendar(SCM cal, char* path) { - - struct stat statbuf; - if (stat (path, &statbuf) != 0) { - fprintf(stderr, - "Error stating file or directory, errno = %i\npath = [%s]\n", - errno, path); - } - - int type = statbuf.st_mode & 0777000; - int chmod = statbuf.st_mode & 0777; - INFO_F("file has mode 0%o, with chmod = 0%o", type, chmod); - - switch (type) { - case S_IFREG: handle_file(cal, path); break; - case S_IFDIR: handle_dir (cal, path); break; - case S_IFLNK: - ERR("Found symlink, can't be bothered to check it further."); - break; - - default: ; - } - - return 0; -} - -int handle_file(SCM cal, char* path) { - INFO("Parsing a single file"); - - /* NAME is the `fancy' name of the calendar. */ - // vcomponent_push_val(cal, "NAME", basename(path)); - SCM line = scm_make_vline(scm_from_utf8_string("file")); - scm_add_line_x(cal, scm_from_utf8_string("X-HNH-SOURCETYPE"), line); - char* resolved_path = realpath(path, NULL); - open_ics (resolved_path, cal); - free (resolved_path); - - return 0; -} - - -int handle_dir(SCM cal, char* path) { - INFO("Parsing a directory"); - DIR* dir = opendir(path); - - /* Buffer for holding search path and filename */ - char buf[PATH_MAX] = { [0 ... PATH_MAX - 1] = '\0' }; - strcpy(buf, path); - int path_len = strlen(path) + 1; - - /* Slash to guarantee we have at least one */ - buf[path_len - 1] = '/'; - - - /* NAME is the `fancy' name of the calendar. */ - // vcomponent_push_val(cal, "NAME", basename(path)); - scm_add_line_x(cal, scm_from_utf8_string("NAME"), - scm_make_vline(scm_from_utf8_stringn(basename(path), strlen(basename(path))))); - SCM line = scm_make_vline(scm_from_utf8_string("vdir")); - scm_add_line_x(cal, scm_from_utf8_string("X-HNH-SOURCETYPE"), line); - - struct dirent* d; - while ((d = readdir(dir)) != NULL) { - /* Check that it's a regular file */ - if (d->d_type != DT_REG) continue; - - /* Append filename with currentt searchpath */ - strcat(buf, d->d_name); - char* resolved_path = realpath(buf, NULL); - /* Remove file part from combined path */ - buf[path_len] = '\0'; - - FILE* f; - size_t read, size = 0x100; - char* info_buf = malloc(size); - if (strcmp (d->d_name, "color") == 0) { - f = fopen(resolved_path, "r"); - read = getline(&info_buf, &size, f); - // TODO this isn't actually needed since we trim the - // string into an SCM string directly here. - if (info_buf[read - 1] == '\n') - info_buf[read - 1] = '\0'; - - fclose(f); - scm_add_line_x(cal, scm_from_utf8_string("COLOR"), - scm_make_vline(scm_from_utf8_stringn(info_buf, read - 1))); - } else if (strcmp (d->d_name, "displayname") == 0) { - f = fopen(resolved_path, "r"); - read = getline(&info_buf, &size, f); - if (info_buf[read - 1] == '\n') - info_buf[read - 1] = '\0'; - - fclose(f); - - /* This adds the new list to the set of names, keeping the - * filename name. - * This works since *currently* values are returned in - * reverse order - */ - scm_add_line_x(cal, scm_from_utf8_string("NAME"), - scm_make_vline(scm_from_utf8_stringn(info_buf, read))); - } else { - open_ics (resolved_path, cal); - } - - free (resolved_path); - } - - closedir(dir); - return 0; -} - -int get_extension(const char* filename, char* ext, ssize_t max_len) { - - if (filename == NULL) { - ext[0] = '\0'; - return 0; - } - - int ext_idx = -1; - ext[0] = '\0'; - for (int i = 0; filename[i] != '\0'; i++) { - if (filename[i] == '.') ext_idx = i + 1; - if (filename[i] == '/') ext_idx = -1; - } - - if (ext_idx == -1) return 0; - - int ext_len = 0; - for (int i = 0; i < max_len; i++, ext_len++) { - char c = filename[i + ext_idx]; - if (c == '\0') break; - ext[i] = c; - } - ext[ext_len] = '\0'; - return ext_len; -} - -int check_ext (const char* path, const char* ext) { - char buf[10]; - int has_ext = get_extension(path, buf, 9); - - return has_ext && strcmp(buf, ext) == 0; -} - -int open_ics (char* resolved_path, SCM cal) { - if (! check_ext(resolved_path, "ics") ) return 2; - - FILE* f = fopen(resolved_path, "r"); - - if (f == NULL) return 1; - - parse_file(resolved_path, f, cal); - fclose(f); - - return 0; -} diff --git a/src/calendar.h b/src/calendar.h deleted file mode 100644 index 776d9900..00000000 --- a/src/calendar.h +++ /dev/null @@ -1,41 +0,0 @@ -#ifndef CALENDAR_H -#define CALENDAR_H - -#include - -/* - * Reads all ics flies in path into the given vcomponent. The - * component is assumed to be a abstract ROOT element, whose first - * component will most likely become a VCALENDAR. - * - * path should either be a single .ics file (vcalendar), or a - * directory directly containing .ics files (vdir). - */ -int read_vcalendar(SCM cal, char* path); - -/* - * Gets extension from filename. Writes output to ext. - * Assumes that the extension is the text between the last dot and - * the end of the string, and that no slashes can occur between the - * dot and the end. - * - * Returns the length of the extension, 0 if no extension. - */ -int get_extension(const char* filename, char* ext, ssize_t max_len); - -/* Returns 1 if path has extension ext, 0 otherwise */ -int check_ext (const char* path, const char* ext); - -/* Handle a lone ics file */ -int handle_file(SCM cal, char* path); - -/* Handle a directory of ics files */ -int handle_dir(SCM cal, char* path); - -/* - * Helper for opening a single ICS file. Handles file internally, and - * writes output to cal. - */ -int open_ics (char* resolved_path, SCM cal); - -#endif /* CALENDAR_H */ diff --git a/src/err.h b/src/err.h deleted file mode 100644 index d9d19ec7..00000000 --- a/src/err.h +++ /dev/null @@ -1,42 +0,0 @@ -#ifndef ERR_H -#define ERR_H - -#include - -#include "macro.h" - -#define _RESET "\x1b[m" -#define _BLACK "\x1B[0;30m" -#define _RED "\x1B[0;31m" -#define _GREEN "\x1B[0;32m" -#define _YELLOW "\x1B[0;33m" -#define _BLUE "\x1B[0;34m" -#define _PURPLE "\x1B[0;35m" -#define _CYAN "\x1B[0;36m" -#define _WHITE "\x1B[0;37m" - -#define ERR(msg) fprintf(stderr, _RED "ERR" _RESET " (%s:%i) %s\n", __FILE__, __LINE__, #msg) -#define ERR_F(fmt, ...) fprintf(stderr, _RED "ERR" _RESET " (%s:%i) " fmt "\n", \ - __FILE__, __LINE__, ##__VA_ARGS__) - -/* Parse error */ -#define ERR_P(ctx, fmt, ...) fprintf(stderr, _RED "PARSE" _RESET " (%s:%i) %i:%i " fmt "\n", \ - __FILE__, __LINE__, (ctx)->pline, (ctx)->pcolumn, ##__VA_ARGS__) - -#define INFO(msg) fprintf(stderr, _BLUE "INFO" _RESET " (%s:%i) %s\n", __FILE__, __LINE__, #msg) -#define INFO_F(fmt, ...) fprintf(stderr, _BLUE "INFO" _RESET " (%s:%i) " fmt "\n", \ - __FILE__, __LINE__, ##__VA_ARGS__) - -#define LINE(len) do { \ - printf(_GREEN); \ - FOR(int, i, len) printf("_"); \ - printf("\n"); \ -} while (0) - -#define PRINT(T, v) do { \ - char buf[0x1000]; \ - FMT(T)(v, buf); \ - INFO_F("%s", buf); \ -} while (0) - -#endif /* ERR_H */ diff --git a/src/guile_type_helpers.c b/src/guile_type_helpers.c deleted file mode 100644 index 2864df0d..00000000 --- a/src/guile_type_helpers.c +++ /dev/null @@ -1,13 +0,0 @@ -#include "guile_type_helpers.h" - -#include "macro.h" - -SCM scm_from_strbuf(strbuf* s) { - SCM ret = scm_from_utf8_stringn (s->mem, s->len); - scm_gc_protect_object(ret); - return ret; -} - -SCM scm_from_strbuf_symbol(strbuf* s) { - return scm_string_to_symbol(scm_from_strbuf(s)); -} diff --git a/src/guile_type_helpers.h b/src/guile_type_helpers.h deleted file mode 100644 index fe0e875a..00000000 --- a/src/guile_type_helpers.h +++ /dev/null @@ -1,16 +0,0 @@ -#ifndef GUILE_TYPE_HELPERS_H -#define GUILE_TYPE_HELPERS_H - -#include - -#include "strbuf.h" - -#define SCM_IS_LIST(x) scm_is_true(scm_list_p(x)) -#define string_eq(a, b) \ - scm_is_true(scm_string_eq(a, b, \ - SCM_UNDEFINED,SCM_UNDEFINED,SCM_UNDEFINED,SCM_UNDEFINED)) - -SCM scm_from_strbuf(strbuf* s); -SCM scm_from_strbuf_symbol(strbuf* s); - -#endif /* GUILE_TYPE_HELPERS_H */ diff --git a/src/macro.h b/src/macro.h deleted file mode 100644 index 7b620f83..00000000 --- a/src/macro.h +++ /dev/null @@ -1,134 +0,0 @@ -#ifndef MACRO_H -#define MACRO_H - -/* - * Token paste - */ -#define TP(a, b) a ## b -#define TP3(a, b, c) a ## b ## c -#define TP4(a, b, c, d) a ## b ## c ## d -#define TP5(a, b, c, d, e) a ## b ## c ## d ## e -#define TP6(a, b, c, d, e, f) a ## b ## c ## d ## e ## f - -/* - * Get length of __VA_ARGS__ - * Borrowed fram: - * https://stackoverflow.com/a/35986932 - */ -#define VA_ARGS_NUM_PRIV(P1, P2, P3, P4, P5, P6, Pn, ...) Pn -#define VA_ARGS_NUM(...) VA_ARGS_NUM_PRIV(-1, ## __VA_ARGS__, 5, 4, 3, 2, 1, 0) - -/* - * Templatization macros. Forms symbols on the from name, which - * looks really good in debuggers and the like. Unicode characters - * written in \U notation since C apparently doesn't support unicode - * literals. - * - * Can be nested (useful for container types). - * - * Doesn't use ASCII <>, but rather some other ᐸᐳ, meaning that it's - * not a reserved character. - * - * nameᐸTᐳ - */ -#define TEMPL(name, T) TP4(name, \U00001438 , T, \U00001433 ) -#define TEMPL2(name, T, V) TP6(name, \U00001438\U00001438 , T , \U00001433_\U00001438 , V, \U00001433\U00001433) -#define TEMPL_N(name, T, argcount) TP6(name, \U00001438 , T, _, argcount, \U00001433 ) - -/* Constructor type name */ -#define __INIT_T(T, C) TEMPL_N(init, T, C) - -/* Returns full type of constructor */ -#define INIT_F(T, ...) \ - int __INIT_T(T, VA_ARGS_NUM(__VA_ARGS__)) (T* self, ## __VA_ARGS__) - -/* - * Call the constructor of an object - * `int` part of the macro, to ensure that any attempt to call self - * function results in an error. - */ -#define INIT(T, N, ...) \ - __INIT_T(T, VA_ARGS_NUM(__VA_ARGS__)) (N, ## __VA_ARGS__) - -/* Allocate a new_ object on the HEAP */ -#define NEW(T, N, ...) \ - T* N = (T*) malloc(sizeof(*N)); \ - INIT(T, N, ## __VA_ARGS__); - -/* - * Reconstructs a object. Use with caution. - */ -#define RENEW(T, N, ...) do { \ - N = (T*) malloc(sizeof(*N)); \ - INIT(T, N, ## __VA_ARGS__); \ -} while (0) - - -/* Allocate a new_ object on the STACK */ -#define SNEW(T, N, ...) \ - T N; \ - INIT(T, & N, ## __VA_ARGS__); - -/* Destructor for type */ -#define FREE(T) TEMPL(free, T) - -/* Call destructor for type, and free object */ -#define FFREE(T, N) do { FREE(T)(N); free(N); } while (0) - -/* Declare destructor */ -#define FREE_F(T) int FREE(T) (T* self) - -/* generate reusable internal symbol */ -#define __INTER(s) TP3(__, s, __internal) -#define __INTER2(s) __INTER(__INTER(s)) -#define __INTER3(s) __INTER(__INTER(__INTER(s))) - -/* Iterator macros. */ -#define FOR(CONT_T, T, var, set) \ - PRE_FOR_ ## CONT_T (T) (T, var, set); \ - for( BEG_ ## CONT_T (T) (T, var, set); \ - END_ ## CONT_T (T) (T, var, set); \ - NXT_ ## CONT_T (T) (T, var, set)) - -/* Example int implementation - * FOR(int, i, 10) { } */ - -#define PRE_FOR_int(i, set) -#define BEG_int(i, set) int i = 0 -#define NXT_int(i, set) i++ -#define END_int(i, set) i < set - -/* - * General functions that different container types may implement. - * Actuall implementation and type signature is mostly left to - * individual implementations. - */ -#define DEEP_COPY(T) TEMPL(copy , T) -#define RESOLVE(T) TEMPL(resolve , T) -#define APPEND(T) TEMPL(append , T) -#define SIZE(T) TEMPL(size , T) -#define EMPTY(T) TEMPL(empty , T) -#define PUSH(T) TEMPL(push , T) -#define PEEK(T) TEMPL(peek , T) -#define POP(T) TEMPL(pop , T) -#define GET(T) TEMPL(get , T) -#define RESET(T) TEMPL(reset , T) -#define KEYS(T) TEMPL(keys , T) - -/* - * Formatting macros. - * Transform objects into string representation of themselves. - * buf should be a suffisiently large memmory location, if it's to - * small then bad stuff might happen. - * - * Should return the number of bytes written (like sprintf). - */ - -#define FMT_T(T) TEMPL(format , T) -#define FMT_F(T) int FMT_T(T)(T* self, char* buf, ...) -// TODO change order of buf and item -#define __FMT_HELP(item, buf, ...) ((item), (buf), VA_ARGS_NUM(__VA_ARGS__), ## __VA_ARGS__) -#define FMT(T) FMT_T(T) __FMT_HELP -#define fmtf(...) seek += sprintf(buf + seek, __VA_ARGS__) - -#endif /* MACRO_H */ diff --git a/src/main.scm b/src/main.scm deleted file mode 100755 index 408b9de0..00000000 --- a/src/main.scm +++ /dev/null @@ -1,24 +0,0 @@ -#!/usr/bin/guile \ --e main -s -!# - -(add-to-load-path (dirname (current-filename))) - -(use-modules (parse)) - -(define (main args) - -;; (define *path* "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics") -;; (define root (parse-cal-path *path*)) - -;; (format #t "root = ~a~%" root) - - - (format (current-error-port) "Parsing ~s~%" (cadr args)) - (let ((cal (read-tree (cadr args)))) - (format #t "cal = ~a~%" cal) - (format (current-error-port) "~a events~%" (length cal))) - - ) - - diff --git a/src/parse.c b/src/parse.c deleted file mode 100644 index 3edbd874..00000000 --- a/src/parse.c +++ /dev/null @@ -1,264 +0,0 @@ -#include "parse.h" - -#include -#include -#include - -#include "macro.h" - -#include "err.h" - -#include -#include "struct.h" -#include "guile_type_helpers.h" - -/* - +-------------------------------------------------------+ - v | - BEGIN → key -------------------------------→ ':' → value → CRLF -+-→ EOF - | ^ - v | - ';' → param-key → '=' → param-value --+ - ^ | - +------------------------------------+ - - - vcomponent := map> - line := pair - attributes := map> - - - */ - - -/* - * name *(";" param) ":" value CRLF - */ -int parse_file(char* filename, FILE* f, SCM root) { - - part_context p_ctx = p_key; - - SNEW(parse_ctx, ctx, f, filename); - - SNEW(strbuf, str); - SCM component = root; - SCM line = scm_make_vline(SCM_UNDEFINED); - SCM attr_key; /* string */ - SCM line_key = scm_from_utf8_string(""); - - SCM scm_filename = scm_from_utf8_stringn(filename, strlen(filename)); - SCM filename_key = scm_from_utf8_string("X-HNH-FILENAME"); - - char c; - while ( (c = fgetc(f)) != EOF) { - /* We have a linebreak */ - if (c == '\r' || c == '\n') { - if (fold(&ctx, c) > 0) { - /* Actuall end of line, handle value */ - /* - * The key being BEGIN means that we decend into a new component. - */ - if (string_eq(line_key, scm_from_utf8_string("BEGIN"))) { - /* key \in { VCALENDAR, VEVENT, VALARM, VTODO, VTIMEZONE, ... } */ - SCM child = scm_make_vcomponent(scm_from_strbuf_symbol(&str)); - scm_add_child_x (component, child); - - scm_add_line_x(child, filename_key, scm_make_vline(scm_filename)); - - component = child; - - } else if (string_eq(line_key, scm_from_utf8_string("END"))) { - component = scm_component_parent(component); - - /* - * A regular key, value pair. Push it into to the current - * component. - */ - } else { - scm_struct_set_x(line, vline_value, scm_from_strbuf(&str)); - scm_add_line_x(component, line_key, line); - line = scm_make_vline(SCM_UNDEFINED); - } - - strbuf_soft_reset (&str); - p_ctx = p_key; - } /* Else continue on current line */ - - /* We have an escaped character */ - } else if (c == '\\') { - char esc = handle_escape (&ctx); - strbuf_append(&str, esc); - - /* Border between param {key, value} */ - } else if (p_ctx == p_param_name && c == '=') { - - /* Save the current parameter key */ - attr_key = scm_from_strbuf(&str); - p_ctx = p_param_value; - strbuf_soft_reset (&str); - - /* - * One of four cases: - * 1) end of key , start of value - * 2) ,, key , ,, param - * 3) ,, param, ,, param - * 4) ,, param, ,, value - */ - } else if ((p_ctx == p_key || p_ctx == p_param_value) && (c == ':' || c == ';')) { - - /* We got a parameter value, push the current string to - * the current parameter set. */ - if (p_ctx == p_param_value) { - /* save current parameter value. */ - scm_add_attribute_x(line, attr_key, scm_from_strbuf(&str)); - strbuf_soft_reset (&str); - } - - /* - * Top level key. - * Copy the key into the current cline, and create a - * content_set for the upcomming value and (possible) - * parameters. - */ - if (p_ctx == p_key) { - line_key = scm_from_strbuf(&str); - strbuf_soft_reset (&str); - } - - if (c == ':') p_ctx = p_value; - else if (c == ';') p_ctx = p_param_name; - - /* - * Nothing interesting happened, append the read character to - * the current string. - */ - } else { - strbuf_append(&str, c); - - ++ctx.column; - ++ctx.pcolumn; - } - } - - if (! feof(f)) { - ERR_F("Error parsing errno = %i", errno); - } - /* Check to see if empty line */ - else if (str.ptr != 0) { - /* - * The standard (3.4, l. 2675) says that each icalobject must - * end with CRLF. My files however does not, so we also parse - * the end here. - * - * Actually we don't any more. - * Since the last thing in a file should always be END:VCALENDAR - * it might be a good idea to verify that. Or we could just, you - * know, not. - */ - - } - - FREE(strbuf)(&str); - - FREE(parse_ctx)(&ctx); - - return 0; -} - -int fold(parse_ctx* ctx, char c) { - int retval; - - char buf[2] = { - (c == '\n' ? '\n' : (char) fgetc(ctx->f)), - (char) fgetc(ctx->f) - }; - - ctx->pcolumn = 1; - - if (buf[0] != '\n') { - ERR_P(ctx, "expected new_line after CR"); - retval = -1; - - } else if (buf[1] == ' ' || buf[1] == '\t') { - retval = 0; - ctx->pcolumn++; - - } else if (ungetc(buf[1], ctx->f) != buf[1]) { - ERR_P(ctx, "Failed to put character back on FILE"); - retval = -2; - - } else { - retval = 1; - ++ctx->line; - ctx->column = 0; - } - - ++ctx->pline; - - return retval; -} - - -INIT_F(parse_ctx, FILE* f, char* filename) { - self->filename = (char*) calloc(sizeof(*filename), strlen(filename) + 1); - strcpy(self->filename, filename); - self->f = f; - - self->line = 0; - self->column = 0; - - self->pline = 1; - self->pcolumn = 1; - - return 0; -} - -FREE_F(parse_ctx) { - - free(self->filename); - - self->line = 0; - self->column = 0; - - return 0; -} - -char handle_escape (parse_ctx* ctx) { - char esc = fgetc(ctx->f); - - /* - * Escape character '\' and escaped token sepparated by a newline - * (since the standard for some reason allows that (!!!)) - * We are at least guaranteed that it's a folded line, so just - * unfold it and continue trying to find a token to escape. - */ - if (esc == '\r' || esc == '\n') { - int ret; - if ( (ret = fold(ctx, esc)) != 0) { - if (ret == 1) ERR_P(ctx, "ESC before not folded line"); - else ERR_P(ctx, "other error: val = %i", ret); - exit (2); - } else { - esc = fgetc(ctx->f); - } - } - - /* Escaped new_line */ - if (esc == 'n' || esc == 'N') { - esc = '\n'; - - /* "Standard" escaped character */ - } else if (esc == ';' || esc == ',' || esc == '\\') { - /* esc already contains character, do nothing */ - - /* Invalid escaped character */ - } else { - ERR_P(ctx, "Non escapable character '%c' (%i)", esc, esc); - } - - ++ctx->column; - ++ctx->pcolumn; - - /* Returns the escaped char, for appending to the current string */ - return esc; -} diff --git a/src/parse.h b/src/parse.h deleted file mode 100644 index 898abe5b..00000000 --- a/src/parse.h +++ /dev/null @@ -1,99 +0,0 @@ -#ifndef PARSE_H -#define PARSE_H - -#include -#include - -#include "strbuf.h" -// #include "vcal.h" - -// #define TYPE vcomponent -// #include "linked_list.h" -// #undef TYPE - -/* - * The standard says that no line should be longer than 75 octets. - * This sets the default amount of memory to allocate for each string, - * but strings are reallocated when needed. - */ -#define SEGSIZE 75 - -/* - * Transfers a strbuf from src to target. - * Does this first copying the contents, followed by capping the - * target and reseting the src. - */ -#define TRANSFER(target, src) do { \ - DEEP_COPY(strbuf)((target), (src)); \ - strbuf_cap(target); \ - strbuf_soft_reset(src); \ -} while (0) - -/* - * Current context for the character consumer (parse_file). - */ -typedef enum { - p_key, p_value, p_param_name, p_param_value, p_escape -} part_context; - -/* - * Struct holding most state information needed while parsing. - * Kept together for simplicity. - */ -typedef struct { - /* Which file we are parsing, copied to all components to allow - * writebacks later */ - char* filename; - - FILE* f; - - /* Number for unfolded lines - * TODO remove this - * */ - int line; - int column; - - /* Actuall lines and columns from file */ - int pline; - int pcolumn; - -} parse_ctx; - -INIT_F(parse_ctx, FILE* f, char* filename); -FREE_F(parse_ctx); - - -/* - * Character consumer. Reads characters from stdin until end of file. - * Whenever it finds a token with a special value (such as ':', ';', - * ...) it saves it away. - * Once It has parsed a full line it calls handel_kv. Which build my - * actuall datastructure. - */ -int parse_file(char* filename, FILE* f, SCM cal); - -/* - * Input - * f: file to get characters from - * ctx: current parse context - * c: last read character - * output: - * 0: line folded - * 1: line ended - * - * A carrige return means that the current line is at an - * end. The following character should always be \n. - * However, if the first character on the next line is a - * whitespace then the two lines should be concatenated. - * - * NOTE - * The above is true according to the standard. But I have - * found files with only NL. The code below ends line on the - * first of NL or CR, and then ensures that the program thinks - * it got the expected CRNL. - */ -int fold(parse_ctx* ctx, char c); - -char handle_escape (parse_ctx* ctx); - -#endif /* PARSE_H */ diff --git a/src/strbuf.c b/src/strbuf.c deleted file mode 100644 index 1e1365d5..00000000 --- a/src/strbuf.c +++ /dev/null @@ -1,143 +0,0 @@ -#include "strbuf.h" - -#include -#include - -#include "err.h" - -INIT_F(strbuf) { - self->alloc = 0x10; - self->mem = (char*) calloc(sizeof(*self->mem), self->alloc); - self->ptr = 0; - self->len = 0; - return 0; -} - -int strbuf_realloc(strbuf* str, size_t len) { - str->mem = (char*) realloc(str->mem, len); - str->alloc = len; - return 0; -} - -FREE_F(strbuf) { - /* has already been freed */ - if (self->mem == NULL) return 1; - - free (self->mem); - self->mem = NULL; - self->alloc = 0; - self->len = 0; - return 0; -} - -/* - * Reallocates memmory for you. Returns 1 if memory was reallocated. - */ -int strbuf_append(strbuf* s, char c) { - int retval = 0; - - if (s->len + 1 > s->alloc) { - s->alloc <<= 1; - s->mem = (char*) realloc(s->mem, s->alloc); - retval = 1; - } - - s->mem[s->len] = c; - s->ptr = ++s->len; - return retval; -} - -char strbuf_pop(strbuf* s) { - char ret = s->mem[--s->len]; - s->mem[s->len + 1] = '\0'; - return ret; -} - -int strbuf_cap(strbuf* s) { - strbuf_append(s, 0); - --s->len; - return 0; -} - -int DEEP_COPY(strbuf)(strbuf* dest, strbuf* src) { - int retval = 0; - - if (dest->alloc < src->len) { - /* +1 in length is to have room for '\0'. */ - strbuf_realloc(dest, src->len + 1); - retval = 1; - } - - dest->len = src->len; - memcpy(dest->mem, src->mem, src->len); - return retval; -} - -int strbuf_cmp(strbuf* a, strbuf* b) { - if (a == NULL || a->alloc == 0 || - b == NULL || b->alloc == 0) - { - ERR("a or b not alloced"); - return -1; - } else { - return strncmp(a->mem, b->mem, a->len); - } -} - -int strbuf_c(strbuf* a, const char* b) { - if (a == NULL || a->alloc == 0) { - ERR("a not allocated"); - return -1; - } - - return strcmp(a->mem, b) == 0; -} - -char* charat(strbuf* s, unsigned int idx) { - if (idx > s->len) { - ERR("Index out of bounds"); - return (char*) -1; - } - - return &s->mem[idx]; -} - -char* strbuf_cur(strbuf* s) { - return &s->mem[s->ptr]; -} - -char* strbuf_end(strbuf* s) { - return &s->mem[s->len]; -} - -int strbuf_reset(strbuf* s) { - s->ptr = 0; - return 0; -} - - -int strbuf_soft_reset(strbuf* s) { - s->ptr = s->len = 0; - return 0; -} - -strbuf* RESOLVE(strbuf)(strbuf* dest, strbuf* new_) { - if (dest == NULL) return new_; - else return dest; -} - -FMT_F(strbuf) { - return sprintf(buf, "%s", self->mem); -} - -int SIZE(strbuf)(strbuf* self) { - return self->len; -} - -int strbuf_load(strbuf* self, const char* str) { - for (int i = 0; str[i] != '\0'; i++) { - strbuf_append(self, str[i]); - } - strbuf_cap(self); - return 0; -} diff --git a/src/strbuf.h b/src/strbuf.h deleted file mode 100644 index 0c028eb6..00000000 --- a/src/strbuf.h +++ /dev/null @@ -1,108 +0,0 @@ -#ifndef STRBUF_H -#define STRBUF_H - -#include -#include -#include "macro.h" - -/* - * A high level string type which holds it's own length, how much - * memmory it has allocated for itself, and a seek pointer into the - * string. - * - * Also comes with a number of functions which allow for safe(er) - * access to the memmory. - */ -typedef struct { - char* mem; - /* TODO add support for negative ptr */ - int ptr; - unsigned int alloc; - unsigned int len; -} strbuf; - -/* - * Init strbuf to size of 10 - */ -INIT_F(strbuf); - -/* - * Like realloc, but for strbuf - */ -int strbuf_realloc(strbuf* str, size_t len); - -/* - * Free's contents of str, but keeps str. - */ -FREE_F(strbuf); - -int strbuf_cmp(strbuf* a, strbuf* b); -int strbuf_c(strbuf* a, const char* b); - -/* - * Copy contents from src to dest. - * Assumes that dest is already initialized. - */ -int DEEP_COPY(strbuf)(strbuf*, strbuf*); - -/* - * Append char to end of strbuf, determined by s->len. - * - * TODO rename this PUSH(strbuf)? - */ -int strbuf_append(strbuf* s, char c); - -char strbuf_pop(strbuf*); - -/* - * Calls strbuf_append with NULL. - */ -int strbuf_cap(strbuf* s); - -/* - * Returns a pointer to character at index. Allows mutation of the - * value pointed to by the return address. - */ -char* charat(strbuf* s, unsigned int idx); - -/* - * Same as `charat`, But returns the current character. - */ -char* strbuf_cur(strbuf* s); - -/* - * Resets the seek for strbuf to 0. - */ -int strbuf_reset(strbuf* s); - -/* - * Sets the length and seek ptr to 0, but doesn't touch the memmory. - */ -int strbuf_soft_reset(strbuf* s); - -/* - * Returns the character after the last, so where null hopefully is. - */ -char* strbuf_end(strbuf* s); - -/* - * Reallocs dest to be the same size as src, and copies the contents - * of src into dest. - */ -int strbuf_realloc_copy(strbuf* dest, strbuf* src); - -/* - * Copies contents from src to dest, also allocating dest in the - * process. dest should not be initialized before self call. - */ -int strbuf_init_copy(strbuf* dest, strbuf* src); - -strbuf* RESOLVE(strbuf)(strbuf*, strbuf*); - -FMT_F(strbuf); - -int SIZE(strbuf)(strbuf*); - -int strbuf_load(strbuf* self, const char* str); - -#endif /* STRBUF_H */ diff --git a/src/struct.h b/src/struct.h deleted file mode 100644 index a66dc201..00000000 --- a/src/struct.h +++ /dev/null @@ -1,23 +0,0 @@ -#ifndef STRUCT_H -#define STRUCT_H - -#include - -#define vcomponent_type scm_from_uint8(0) -#define vcomponent_children scm_from_uint8(1) -#define vcomponent_parent scm_from_uint8(2) -#define vcomponent_lines scm_from_uint8(3) - -#define scm_component_parent(component) \ - scm_struct_ref (component, vcomponent_parent) - -#define vline_value scm_from_uint8(0) -#define vline_attributes scm_from_uint8(1) - -SCM scm_make_vcomponent(SCM); -SCM scm_add_line_x (SCM, SCM, SCM); -SCM scm_add_child_x (SCM, SCM); -SCM scm_make_vline (SCM); -SCM scm_add_attribute_x (SCM, SCM, SCM); - -#endif /* STRUCT_H */ diff --git a/src/struct.scm.c b/src/struct.scm.c deleted file mode 100644 index 051faf63..00000000 --- a/src/struct.scm.c +++ /dev/null @@ -1,96 +0,0 @@ -#include "struct.h" - -#include - -#include "parse.h" -#include "calendar.h" - -SCM vcomponent_vtable; -SCM vline_vtable; - -SCM_DEFINE(scm_make_vcomponent, "make-vcomponent", 0, 1, 0, - (SCM type), - "") -{ - - if (SCM_UNBNDP (type) || scm_is_false (type)) - type = scm_from_utf8_symbol("VIRTUAL"); - - return scm_make_struct_no_tail - (vcomponent_vtable, - scm_list_4(type, SCM_EOL, SCM_BOOL_F, - scm_make_hash_table(scm_from_int(0x10)))); -} - - - -SCM_DEFINE(scm_parse_cal_path, "parse-cal-path", 1, 0, 0, - (SCM path), - "") -{ - SCM root = scm_make_vcomponent(SCM_UNDEFINED); - - char* p = scm_to_utf8_stringn(path, NULL); - read_vcalendar(root, p); - free(p); - - return root; -} - -SCM_DEFINE(scm_add_line_x, "add-line!", 3, 0, 0, - (SCM vcomponent, SCM key, SCM line), - "") -{ - scm_hash_set_x (scm_struct_ref(vcomponent, vcomponent_lines), key, line); - return SCM_UNSPECIFIED; -} - - -SCM_DEFINE(scm_add_child_x, "add-child!", 2, 0, 0, - (SCM vcomponent, SCM child), - "") -{ - scm_struct_set_x (child, vcomponent_parent, vcomponent); - scm_struct_set_x (vcomponent, vcomponent_children, - scm_cons (child, scm_struct_ref (vcomponent, vcomponent_children))); - - return SCM_UNSPECIFIED; -} - - -SCM_DEFINE(scm_make_vline, "make-vline", 0, 1, 0, - (SCM value), "") -{ - - if (SCM_UNBNDP (value)) value = SCM_BOOL_F; - - return scm_make_struct_no_tail - (vline_vtable, - scm_list_2(value, scm_make_hash_table(scm_from_int(0x10)))); -} - - -SCM_DEFINE(scm_add_attribute_x, "add-attribute!", 3, 0, 0, - (SCM vline, SCM key, SCM value), - "") -{ - SCM table = scm_struct_ref (vline, vline_attributes); - scm_hash_set_x (table, key, - scm_cons(value, scm_hash_ref(table, key, SCM_EOL))); - return SCM_UNSPECIFIED; -} - -void init_lib (void) { - SCM str = scm_from_utf8_string("pr" "pw" "pw" "pr"); - vcomponent_vtable = scm_make_vtable(str, SCM_BOOL_F); - scm_set_struct_vtable_name_x (vcomponent_vtable, scm_from_utf8_symbol("vcomponent")); - - vline_vtable = - scm_make_vtable(scm_from_utf8_string("pw" "pw"), - SCM_BOOL_F); - scm_set_struct_vtable_name_x (vline_vtable, scm_from_utf8_symbol("vline")); - -#ifndef SCM_MAGIC_SNARFER -#include "struct.x" -#endif -} -- cgit v1.2.3 From 3f49d48ae608d5fb618453a8e2fa875b9d5420e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 3 Nov 2019 13:36:22 +0100 Subject: Readd color parsing, fix minor bugs. --- module/vcomponent/base.scm | 13 +++++++------ module/vcomponent/parse.scm | 27 +++++++++++++++++++++------ 2 files changed, 28 insertions(+), 12 deletions(-) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index f43f532e..86ea40e8 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -16,11 +16,12 @@ (let ((parent (primitive-make-vcomponent))) (for-each (lambda (child) (add-child! parent child)) (read-vcalendar path)) - (if (null? (get-component-children parent)) - (set-attribute! parent 'X-HNH-SOURCETYPE "vdir") - (set-attribute! parent 'X-HNH-SOURCETYPE - (get-attribute-value (car (get-component-children parent)) - 'X-HNH-SOURCETYPE "vdir"))) + (set-attribute! + parent 'X-HNH-SOURCETYPE + (if (null? (get-component-children parent)) + "vdir" + (get-attribute-value (car (get-component-children parent)) + 'X-HNH-SOURCETYPE "vdir"))) parent)) ;; vline → value @@ -72,7 +73,7 @@ (define-public parent get-component-parent) (define-public (attributes component) - (hash-map->list cons (get-component-attributes component))) + (map car (hash-map->list cons (get-component-attributes component)))) (define*-public children get-component-children) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 9eabacb3..46a256a1 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -3,6 +3,7 @@ :use-module (rnrs io ports) :use-module (rnrs bytevectors) :use-module (srfi srfi-9) + :use-module ((ice-9 rdelim) :select (read-line)) :use-module ((ice-9 textual-ports) :select (unget-char)) :use-module ((ice-9 ftw) :select (scandir ftw))) @@ -289,12 +290,26 @@ row ~a column ~a ctx = ~a (set-attribute! comp 'X-HNH-SOURCETYPE "file") (list comp))] [(directory) - (map (lambda (fname) - (call-with-input-file - (string-append path file-name-separator-string fname) - parse-calendar)) - (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) - (string= "ics" (string-take-right s 3))))))] + + (let ((/ (lambda args (string-join args file-name-separator-string 'infix)))) + (let ((color + (catch 'system-error + (lambda () (call-with-input-file (/ path "color") read-line)) + (const "#FFFFFF"))) + (name + (catch 'system-error + (lambda () (call-with-input-file (/ path "displayname") read-line)) + (const (basename path))))) + + (map (lambda (fname) + (let ((fullname (/ path fname))) + (let ((cal (call-with-input-file fullname + parse-calendar))) + (set-attribute! cal 'COLOR color) + (set-attribute! cal 'NAME name) + cal))) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3))))))))] [(block-special char-special fifo socket unknown symlink) => (lambda (t) (error "Can't parse file of type " t))])) -- cgit v1.2.3 From 275dfc4b4fc7bd8ad3244dbd6c9053fe1ceb7f5b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 3 Nov 2019 13:39:57 +0100 Subject: Remove make-vcomponent. --- module/main.scm | 2 +- module/vcomponent.scm | 152 ++++++++++++++++++++++----------------------- module/vcomponent/base.scm | 11 +--- 3 files changed, 79 insertions(+), 86 deletions(-) diff --git a/module/main.scm b/module/main.scm index f765496f..423daeb9 100755 --- a/module/main.scm +++ b/module/main.scm @@ -39,7 +39,7 @@ exec guile -e main -s $0 "$@" ;; ;; Given as a sepparate function from main to ease debugging. (define* (init proc #:key (calendar-files (calendar-files))) - (define calendars (map make-vcomponent calendar-files)) + (define calendars (map parse-calendar calendar-files)) (define events (concatenate ;; TODO does this drop events? (map (lambda (cal) (filter (lambda (o) (eq? 'VEVENT (type o))) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index d3e574b5..8eeeaff9 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -9,8 +9,8 @@ #:use-module (srfi srfi-19 setters) #:use-module (srfi srfi-26) #:use-module (util) - #:export (make-vcomponent) - #:re-export (repeating?)) + #:export (parse-calendar) + #:re-export (repeating? make-vcomponent)) ;; All VTIMEZONE's seem to be in "local" time in relation to ;; themselves. Therefore, a simple comparison should work, @@ -62,78 +62,76 @@ (value eptr) (date->time-utc end-date))))) -(define* (make-vcomponent #:optional path) - (if (not path) - (primitive-make-vcomponent) - (let ((root (parse-cal-path path))) - (let* ((component - (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) - ;; == Single ICS file == - ;; Remove the abstract ROOT component, - ;; returning the wanted VCALENDAR component - ((file) - ;; TODO test this when an empty file is given. - (car (children root))) - - ;; == Assume vdir == - ;; Also removes the abstract ROOT component, but also - ;; merges all VCALENDAR's children into the a newly - ;; created VCALENDAR component, and return that component. - ;; - ;; TODO the other VCALENDAR components might not get thrown away, - ;; this since I protect them from the GC in the C code. - ((vdir) - (let ((accum (primitive-make-vcomponent 'VCALENDAR)) - (ch (children root))) - - ;; Copy attributes from our parsed VCALENDAR - ;; to our newly created one. - (unless (null? ch) - (for key in (attributes (car ch)) - (set! (attr accum key) (attr (car ch) key)))) - - ;; Merge all children - (let ((tz '())) - (for cal in ch - (for component in (children cal) - (case (type component) - ((VTIMEZONE) - (set! tz (cons component tz)) - #; - (unless (find (lambda (z) - (string=? (attr z "TZID") - (attr component "TZID"))) - (filter (lambda (o) (eq? 'VTIMEZONE (type o))) - (children accum))) - (add-child! accum component))) - ((VEVENT) - (add-child! accum component) - ) - (else => (lambda (type) - (format (current-error-port) - "Got unexpected component of type ~a~%" type)) - #; (add-child! accum component) - )))) - - (unless (null? tz) - (add-child! accum (car tz))) - ) - ;; return - accum)) - - ((no-type) (error 'no-type))))) - - (parse-dates! component) - - (unless (attr component "NAME") - (set! (attr component "NAME") - (or (attr component "X-WR-CALNAME") - (attr root "NAME") - "[NAMELESS]"))) - - (unless (attr component "COLOR") - (set! (attr component "COLOR") - (attr root "COLOR"))) - - ;; return - component)))) +(define* (parse-calendar path) + (let ((root (parse-cal-path path))) + (let* ((component + (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) + ;; == Single ICS file == + ;; Remove the abstract ROOT component, + ;; returning the wanted VCALENDAR component + ((file) + ;; TODO test this when an empty file is given. + (car (children root))) + + ;; == Assume vdir == + ;; Also removes the abstract ROOT component, but also + ;; merges all VCALENDAR's children into the a newly + ;; created VCALENDAR component, and return that component. + ;; + ;; TODO the other VCALENDAR components might not get thrown away, + ;; this since I protect them from the GC in the C code. + ((vdir) + (let ((accum (make-vcomponent 'VCALENDAR)) + (ch (children root))) + + ;; Copy attributes from our parsed VCALENDAR + ;; to our newly created one. + (unless (null? ch) + (for key in (attributes (car ch)) + (set! (attr accum key) (attr (car ch) key)))) + + ;; Merge all children + (let ((tz '())) + (for cal in ch + (for component in (children cal) + (case (type component) + ((VTIMEZONE) + (set! tz (cons component tz)) + #; + (unless (find (lambda (z) + (string=? (attr z "TZID") + (attr component "TZID"))) + (filter (lambda (o) (eq? 'VTIMEZONE (type o))) + (children accum))) + (add-child! accum component))) + ((VEVENT) + (add-child! accum component) + ) + (else => (lambda (type) + (format (current-error-port) + "Got unexpected component of type ~a~%" type)) + #; (add-child! accum component) + )))) + + (unless (null? tz) + (add-child! accum (car tz))) + ) + ;; return + accum)) + + ((no-type) (error 'no-type))))) + + (parse-dates! component) + + (unless (attr component "NAME") + (set! (attr component "NAME") + (or (attr component "X-WR-CALNAME") + (attr root "NAME") + "[NAMELESS]"))) + + (unless (attr component "COLOR") + (set! (attr component "COLOR") + (attr root "COLOR"))) + + ;; return + component))) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 86ea40e8..60a27f94 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -2,18 +2,13 @@ :use-module (util) :use-module (srfi srfi-1) :use-module (srfi srfi-17) - :use-module ((vcomponent parse) - :renamer (lambda (symb) - (case symb - ;; [(set-attribute!) 'get-attribute] - [(make-vcomponent) 'primitive-make-vcomponent] - [else symb]))) + :use-module (vcomponent parse) :use-module (ice-9 hash-table) :use-module ((ice-9 optargs) :select (define*-public)) - :re-export (add-child! primitive-make-vcomponent)) + :re-export (add-child! make-vcomponent)) (define-public (parse-cal-path path) - (let ((parent (primitive-make-vcomponent))) + (let ((parent (make-vcomponent))) (for-each (lambda (child) (add-child! parent child)) (read-vcalendar path)) (set-attribute! -- cgit v1.2.3 From cecffe9ebdd0bb1efb628da320039fec9e6cba39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 3 Nov 2019 13:57:46 +0100 Subject: Move stuff between vcomponent/{base,parse}. --- module/output/info.scm | 4 +- module/vcomponent.scm | 1 + module/vcomponent/base.scm | 89 ++++++++++++++++++--------- module/vcomponent/parse.scm | 142 +++++++++++++++++--------------------------- 4 files changed, 120 insertions(+), 116 deletions(-) diff --git a/module/output/info.scm b/module/output/info.scm index 62600472..eba0979c 100644 --- a/module/output/info.scm +++ b/module/output/info.scm @@ -11,7 +11,9 @@ (format #t "~%Found ~a calendars, named:~%~{ - [~4@a] ~a~a\x1b[m~%~}~%" (length calendars) (concatenate - (zip (map (lambda (c) (length (children c 'VEVENT))) calendars) + (zip (map (lambda (c) (length (filter (lambda (e) (eq? 'VEVENT (type e))) + (children c)))) + calendars) (map (compose color-escape (extract 'COLOR)) calendars) (map (extract 'NAME) calendars))))) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 8eeeaff9..871ac2e7 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -3,6 +3,7 @@ #:use-module (vcomponent recurrence) #:use-module (vcomponent timezone) #:use-module (vcomponent base) + #:use-module (vcomponent parse) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-19 util) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 60a27f94..52bbe0c3 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -1,23 +1,66 @@ (define-module (vcomponent base) :use-module (util) :use-module (srfi srfi-1) + :use-module (srfi srfi-9) :use-module (srfi srfi-17) - :use-module (vcomponent parse) :use-module (ice-9 hash-table) :use-module ((ice-9 optargs) :select (define*-public)) - :re-export (add-child! make-vcomponent)) - -(define-public (parse-cal-path path) - (let ((parent (make-vcomponent))) - (for-each (lambda (child) (add-child! parent child)) - (read-vcalendar path)) - (set-attribute! - parent 'X-HNH-SOURCETYPE - (if (null? (get-component-children parent)) - "vdir" - (get-attribute-value (car (get-component-children parent)) - 'X-HNH-SOURCETYPE "vdir"))) - parent)) + ) + + + +;; The type is a bit to many times refered to as a attr ptr. +(define-record-type + (make-vline% value parameters) + vline? + (value get-vline-value set-vline-value!) + (parameters get-vline-parameters)) + +(define*-public (make-vline value #:optional ht) + (make-vline% value (or ht (make-hash-table)))) + +(define-record-type + (make-vcomponent% type children parent attributes) + vcomponent? + (type type) + (children children set-component-children!) + (parent get-component-parent set-component-parent!) + (attributes get-component-attributes)) +(export children type) + +;; TODO should this also update the parent +(define-public parent + (make-procedure-with-setter + get-component-parent set-component-parent!)) + +(define*-public (make-vcomponent #:optional (type 'VIRTUAL)) + (make-vcomponent% type '() #f (make-hash-table))) + +(define-public (add-child! parent child) + (set-component-children! parent (cons child (children parent))) + (set-component-parent! child parent)) + +(define* (get-attribute-value component key #:optional default) + (cond [(hashq-ref (get-component-attributes component) + key #f) + => get-vline-value] + [else default])) + +(define (get-attribute component key) + (hashq-ref (get-component-attributes component) + key)) + +(define (set-attribute! component key value) + (let ((ht (get-component-attributes component))) + (cond [(hashq-ref ht key #f) + => (lambda (vline) (set-vline-value! vline value))] + [else (hashq-set! ht key (make-vline value))]))) + +(define-public (set-vline! component key vline) + (hashq-set! (get-component-attributes component) + key vline)) + + ;; vline → value (define-public value @@ -57,30 +100,20 @@ ;; Returns the properties of attribute as an assoc list. ;; @code{(map car <>)} leads to available properties. (define-public (properties attrptr) - (hash-map->list cons (get-attribute-parameters attrptr))) - -(define-public type (make-procedure-with-setter - (lambda (c) (component-type c)) - (lambda (c v) ; struct-set! c 0 v - (format (current-error-port) - "This method is a deprecated NOOP")))) - -(define-public parent get-component-parent) + (hash-map->list cons (get-vline-parameters attrptr))) (define-public (attributes component) (map car (hash-map->list cons (get-component-attributes component)))) -(define*-public children get-component-children) - (define (copy-vline vline) (make-vline (get-vline-value vline) ;; TODO deep-copy on properties? (get-vline-parameters vline))) (define-public (copy-vcomponent component) - (make-vcomponent% (component-type component) - (get-component-children component) - (get-component-parent component) + (make-vcomponent% (type component) + (children component) + (parent component) ;; attributes (alist->hashq-table (hash-map->list (lambda (key value) (cons key (copy-vline value))) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 46a256a1..40e5a141 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,83 +1,16 @@ - (define-module (vcomponent parse) :use-module (rnrs io ports) :use-module (rnrs bytevectors) :use-module (srfi srfi-9) :use-module ((ice-9 rdelim) :select (read-line)) :use-module ((ice-9 textual-ports) :select (unget-char)) - :use-module ((ice-9 ftw) :select (scandir ftw))) - - + :use-module ((ice-9 ftw) :select (scandir ftw)) -(define-record-type - (make-vline% value parameters) - vline? - (value get-vline-value set-vline-value!) - (parameters get-vline-parameters)) - -(define* (make-vline value #:optional ht) - (make-vline% value (or ht (make-hash-table)))) - -(define-record-type - (make-vcomponent% type children parent attributes) - vcomponent? - (type component-type) - (children get-component-children set-component-children!) - (parent get-component-parent set-component-parent!) - (attributes get-component-attributes)) - -(define* (make-vcomponent #:optional (type 'VIRTUAL)) - (make-vcomponent% type '() #f (make-hash-table #x10))) - -(define (add-child! parent child) - (set-component-children! parent (cons child (get-component-children parent))) - (set-component-parent! child parent)) - -(define* (get-attribute-value component key #:optional default) - (cond [(hashq-ref (get-component-attributes component) - key #f) - => get-vline-value] - [else default])) - -(define (get-attribute component key) - (hashq-ref (get-component-attributes component) - key)) - -(define (set-attribute! component key value) - (let ((ht (get-component-attributes component))) - (cond [(hashq-ref ht key #f) - => (lambda (vline) (set-vline-value! vline value))] - [else (hashq-set! ht key (make-vline value))]))) - -(define (set-vline! component key vline) - (hashq-set! (get-component-attributes component) - key vline)) + :use-module (util) + :use-module (vcomponent base) - - -(define-record-type - (make-parse-ctx% filename row col ctx line-key param-key param-table) - parse-ctx? - (filename get-filename) ; string - (row get-row set-row!) ; [0, ] - (col get-col set-col!) ; [1, ) - (ctx get-ctx set-ctx!) ; '(key value param-name param-value escape) - (line-key get-line-key set-line-key!) ; string - (param-key get-param-key set-param-key!) ; string - (param-table get-param-table set-param-table!) ; hash-map ) -(define (make-parse-ctx filename) - (make-parse-ctx% filename 1 0 'key - #f #f (make-hash-table))) - -(define (increment-column! ctx) - (set-col! ctx (1+ (get-col ctx)))) - -(define (increment-row! ctx) - (set-col! ctx 0) - (set-row! ctx (1+ (get-row ctx)))) - (define-record-type @@ -119,6 +52,31 @@ +(define-record-type + (make-parse-ctx% filename row col ctx line-key param-key param-table) + parse-ctx? + (filename get-filename) ; string + (row get-row set-row!) ; [0, ] + (col get-col set-col!) ; [1, ) + (ctx get-ctx set-ctx!) ; '(key value param-name param-value escape) + (line-key get-line-key set-line-key!) ; string + (param-key get-param-key set-param-key!) ; string + (param-table get-param-table set-param-table!) ; hash-map + ) + +(define (make-parse-ctx filename) + (make-parse-ctx% filename 1 0 'key + #f #f (make-hash-table))) + +(define (increment-column! ctx) + (set-col! ctx (1+ (get-col ctx)))) + +(define (increment-row! ctx) + (set-col! ctx 0) + (set-row! ctx (1+ (get-row ctx)))) + + + (define (fold-proc ctx c) ;; First extra character optionall read is to get the \n if our line ;; ended with \r\n. Secound read is to get the first character of the @@ -160,8 +118,8 @@ (with-throw-handler #t (lambda () - (set-attribute! component 'X-HNH-FILENAME - (get-filename ctx)) + (set! (attr component 'X-HNH-FILENAME) + (get-filename ctx)) (while #t (let ((c (get-u8 (current-input-port)))) @@ -175,12 +133,11 @@ ;; the setup at creation this shouldn't be a problem. (break (case (get-ctx ctx) [(key) ; line ended - (let ((root-component - (car (get-component-children component)))) - (set-component-parent! root-component #f) + (let ((root-component (car (children component)))) + (set! (parent root-component) #f) root-component)] [(value) ; still ending line - (set-component-parent! component #f) + (set! (parent component) #f) component] [else => (lambda (a) (scm-error 'wrong-type-arg "parse-break" @@ -198,16 +155,17 @@ (let ((child (make-vcomponent (string->symbol str)))) ;; TOOD remove this copying of attributes!!! (for-each (lambda (pair) - (set-attribute! child - (car pair) - (cdr pair))) + (set! (attr child (car pair)) + (cdr pair))) (hash-map->list - cons (get-component-attributes component))) + cons ((@@ (vcomponent base) + get-component-attributes) + component))) (add-child! component child) (set! component child))] [(eq? (get-line-key ctx) 'END) - (set! component (get-component-parent component))] + (set! component (parent component))] [else ;; TODO repeated keys @@ -287,7 +245,7 @@ row ~a column ~a ctx = ~a (define st (stat path)) (case (stat:type st) [(regular) (let ((comp (call-with-input-file path parse-calendar))) - (set-attribute! comp 'X-HNH-SOURCETYPE "file") + (set! (attribute comp 'X-HNH-SOURCETYPE) "file") (list comp))] [(directory) @@ -305,8 +263,8 @@ row ~a column ~a ctx = ~a (let ((fullname (/ path fname))) (let ((cal (call-with-input-file fullname parse-calendar))) - (set-attribute! cal 'COLOR color) - (set-attribute! cal 'NAME name) + (set! (attr cal 'COLOR) color + (attr cal 'NAME) name) cal))) (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) (string= "ics" (string-take-right s 3))))))))] @@ -314,6 +272,19 @@ row ~a column ~a ctx = ~a => (lambda (t) (error "Can't parse file of type " t))])) +(define-public (parse-cal-path path) + (let ((parent (make-vcomponent))) + (for-each (lambda (child) (add-child! parent child)) + (read-vcalendar path)) + (set! (attr parent 'X-HNH-SOURCETYPE) + (if (null? (children parent)) + "vdir" + (or (attr (car (children parent)) + 'X-HNH-SOURCETYPE) + "vdir"))) + parent)) + + (define-public (read-tree path) (define list '()) (ftw path @@ -332,6 +303,3 @@ row ~a column ~a ctx = ~a ((@ (ice-9 threads) n-par-map) 12 (lambda (fname) (call-with-input-file fname parse-calendar)) list)) - - -(export add-child! make-vcomponent get-vline-value set-vline-value! get-component-parent get-component-children get-attribute-value set-attribute! get-component-attributes component-type make-vcomponent% make-vline get-vline-parameters) -- cgit v1.2.3 From 63cb5445d481c2857c7ebb96434be6f7bc6cf20d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 3 Nov 2019 14:28:56 +0100 Subject: Cleanup in parse. --- module/vcomponent/parse.scm | 53 +++++++++++++++++++++------------------------ 1 file changed, 25 insertions(+), 28 deletions(-) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 40e5a141..78217368 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -117,10 +117,6 @@ (strbuf (make-strbuf))) (with-throw-handler #t (lambda () - - (set! (attr component 'X-HNH-FILENAME) - (get-filename ctx)) - (while #t (let ((c (get-u8 (current-input-port)))) (cond @@ -131,36 +127,37 @@ ;; We never check the final line here. But since it ;; ALWAYS should be "END:VCOMPONENT", and we do all ;; the setup at creation this shouldn't be a problem. - (break (case (get-ctx ctx) - [(key) ; line ended - (let ((root-component (car (children component)))) - (set! (parent root-component) #f) - root-component)] - [(value) ; still ending line - (set! (parent component) #f) - component] - [else => (lambda (a) - (scm-error 'wrong-type-arg "parse-break" - (string-append - "Bad context at end of file. " - "Expected `key' or `value', got ~a") - (list a) #f))]))] + (let ((component + (case (get-ctx ctx) + ;; Line ended before we came here, get the actual root + ;; component (instead of our virtual one: + [(key) (car (children component))] + ;; Line wasn't ended before we get here, so our current + ;; component is our "actual" root. + [(value) component] + [else + => (lambda (a) + (scm-error + 'wrong-type-arg "parse-break" + (string-append + "Bad context at end of file. " + "Expected `key' or `value', got ~a") + (list a) #f))]))) + ;; == NOTE == + ;; This sets to the VCALENDAR, which is correct, + ;; but the program later squashes together everything + ;; and drops this information. + (set! (attr component 'X-HNH-FILENAME) (get-filename ctx) + (parent component) #f) + (break component))] ;; End of line [(memv (integer->char c) '(#\return #\newline)) (case (fold-proc ctx c) [(end-of-line) (let ((str (strbuf->string strbuf))) - (cond [(eq? (get-line-key ctx) 'BEGIN) + (cond [(eq? 'BEGIN (get-line-key ctx)) (let ((child (make-vcomponent (string->symbol str)))) - ;; TOOD remove this copying of attributes!!! - (for-each (lambda (pair) - (set! (attr child (car pair)) - (cdr pair))) - (hash-map->list - cons ((@@ (vcomponent base) - get-component-attributes) - component))) (add-child! component child) (set! component child))] @@ -245,7 +242,7 @@ row ~a column ~a ctx = ~a (define st (stat path)) (case (stat:type st) [(regular) (let ((comp (call-with-input-file path parse-calendar))) - (set! (attribute comp 'X-HNH-SOURCETYPE) "file") + (set! (attr comp 'X-HNH-SOURCETYPE) "file") (list comp))] [(directory) -- cgit v1.2.3 From a7af480101881af9e007453c0003328fde89f3b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 3 Nov 2019 14:44:27 +0100 Subject: Move strbuf to own file. --- module/util/strbuf.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++ module/vcomponent/parse.scm | 42 ++-------------------------------------- 2 files changed, 49 insertions(+), 40 deletions(-) create mode 100644 module/util/strbuf.scm diff --git a/module/util/strbuf.scm b/module/util/strbuf.scm new file mode 100644 index 00000000..9c1b1e6a --- /dev/null +++ b/module/util/strbuf.scm @@ -0,0 +1,47 @@ +(define-module (util strbuf) + :use-module (srfi srfi-9) + :use-module (rnrs bytevectors) + :use-module ((rnrs io ports) + :select (bytevector->string native-transcoder)) + :use-module ((ice-9 optargs) :select (define*-public)) + ) + +(define-record-type + (make-strbuf% len bytes) + strbuf? + (len get-length set-length!) + (bytes get-bytes set-bytes!)) + +(define-public (make-strbuf) + (make-strbuf% 0 (make-u8vector #x1000))) + +(define (strbuf-realloc! strbuf) + (let* ((len (u8vector-length (get-bytes strbuf))) + (nv (make-u8vector (ash len 1)))) + (bytevector-copy! (get-bytes strbuf) 0 + nv 0 len) + (set-bytes! strbuf nv))) + +;; TODO charset +(define*-public (strbuf->string strbuf #:optional + (transcoder (native-transcoder))) + (let ((bv (make-u8vector (get-length strbuf)))) + (bytevector-copy! (get-bytes strbuf) 0 + bv 0 + (get-length strbuf)) + (bytevector->string bv transcoder))) + +(define-public (strbuf-reset! strbuf) + (set-length! strbuf 0)) + +(define-public (strbuf-append! strbuf u8) + (catch 'out-of-range + (lambda () + (u8vector-set! (get-bytes strbuf) + (get-length strbuf) + u8)) + (lambda (err . args) + (strbuf-realloc! strbuf) + (strbuf-append! strbuf u8))) + (set-length! strbuf (1+ (get-length strbuf)))) + diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 78217368..04a06d54 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,5 +1,5 @@ (define-module (vcomponent parse) - :use-module (rnrs io ports) + :use-module ((rnrs io ports) :select (get-u8)) :use-module (rnrs bytevectors) :use-module (srfi srfi-9) :use-module ((ice-9 rdelim) :select (read-line)) @@ -7,50 +7,12 @@ :use-module ((ice-9 ftw) :select (scandir ftw)) :use-module (util) + :use-module (util strbuf) :use-module (vcomponent base) - ) -(define-record-type - (make-strbuf% len bytes) - strbuf? - (len get-length set-length!) - (bytes get-bytes set-bytes!)) - -(define (make-strbuf) - (make-strbuf% 0 (make-u8vector #x1000))) - -(define (strbuf-realloc! strbuf) - (let* ((len (u8vector-length (get-bytes strbuf))) - (nv (make-u8vector (ash len 1)))) - (bytevector-copy! (get-bytes strbuf) 0 - nv 0 len) - (set-bytes! strbuf nv))) - -(define (strbuf->string strbuf) - (let ((bv (make-u8vector (get-length strbuf)))) - (bytevector-copy! (get-bytes strbuf) 0 - bv 0 - (get-length strbuf)) - (bytevector->string bv (native-transcoder)))) ; TODO charset - -(define (strbuf-reset! strbuf) - (set-length! strbuf 0)) - -(define (strbuf-append! strbuf u8) - (catch 'out-of-range - (lambda () - (u8vector-set! (get-bytes strbuf) - (get-length strbuf) - u8)) - (lambda (err . args) - (strbuf-realloc! strbuf) - (strbuf-append! strbuf u8))) - (set-length! strbuf (1+ (get-length strbuf)))) - - (define-record-type (make-parse-ctx% filename row col ctx line-key param-key param-table) -- cgit v1.2.3 From 56a72ae506821cc37a6bdf1e74d0bfb158c36f99 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 3 Nov 2019 14:45:52 +0100 Subject: Add descirption to strbuf. --- module/util/strbuf.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/module/util/strbuf.scm b/module/util/strbuf.scm index 9c1b1e6a..2b574e82 100644 --- a/module/util/strbuf.scm +++ b/module/util/strbuf.scm @@ -1,3 +1,8 @@ +;;; Description: +;; Alternative class to regular string, optimized for really fast appending, +;; Works on a byte level, and isn't really good for anything else. +;;; Code: + (define-module (util strbuf) :use-module (srfi srfi-9) :use-module (rnrs bytevectors) -- cgit v1.2.3