diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2019-04-10 00:51:35 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2019-04-10 00:51:35 +0200 |
commit | 124f8b42c01a440c6998a13ef13996ac1d312092 (patch) | |
tree | fc7faf2a6faa11fa6968f9b4a12e5467513bfe1f | |
parent | Add {format,print}-recur-rule. (diff) | |
download | calp-124f8b42c01a440c6998a13ef13996ac1d312092.tar.gz calp-124f8b42c01a440c6998a13ef13996ac1d312092.tar.xz |
Rework how attributes and properties are accessed.
Made the fact that properties belong to an attribute shine through to
scheme. This by setting the SCM field in the strbuf:ers in my
vcomponents to a pair of their old SCM value, and a hash table
representing the properties.
This also meant that the primitive set-attribute! could be replaced by a
set-car! on the pair returned by the primitive get-attribute. And that
both set- and get-property now simple works on the hash table returned
by get-attribute.
The major problem with this release was that I for a while missed that
DEEP_COPY(strbuf) now also needed to deep copy the SCM values. Without
that attributes in a copied vcomponent would be shared with the
original. This mainly lead to repeating events all being the same.
Diffstat (limited to '')
-rw-r--r-- | module/vcalendar.scm | 56 | ||||
-rw-r--r-- | module/vcalendar/primitive.scm | 6 | ||||
-rw-r--r-- | src/guile_interface.scm.c | 158 | ||||
-rw-r--r-- | src/strbuf.c | 9 |
4 files changed, 70 insertions, 159 deletions
diff --git a/module/vcalendar.scm b/module/vcalendar.scm index 12e2d9a5..a4da1527 100644 --- a/module/vcalendar.scm +++ b/module/vcalendar.scm @@ -28,41 +28,36 @@ childs))) (export children) -(define (set-attr! component attr value) - (%vcomponent-set-attribute! - component - (as-string attr) - value)) - (define (get-attr component attr) (%vcomponent-get-attribute component (as-string attr))) -(define (get-property component attr prop) - (%vcomponent-get-property - component - (as-string attr) - (as-string prop))) +(define (set-attr! component attr value) + (set-car! (get-attr component (as-string attr)) + value)) -(define (set-property! component attr prop val) - (%vcomponent-set-property! - component - (as-string attr) - (as-string prop) - val)) +(define-public attr* + (make-procedure-with-setter + get-attr set-attr!)) -(define-public prop +(define-public attr (make-procedure-with-setter - get-property - set-property!)) + (compose car get-attr) set-attr!)) -(define-public (properties component attr) - (%vcomponent-property-list component (as-string attr))) +;; value +(define-public v + (make-procedure-with-setter car set-car!)) -;; Enables symmetric get and set: -;; (set! (attr ev "KEY") 10) -(define-public attr (make-procedure-with-setter get-attr set-attr!)) +(define-public prop + (make-procedure-with-setter + (lambda (attr-obj prop-key) + (hashq-ref (cdr attr-obj) prop-key)) + (lambda (attr-obj prop-key val) + (hashq-set! (cdr attr-obj) prop-key val)))) + +(define-public (properties component attr-key) + (hash-map->list cons (cdr (attr component (as-string attr-key))))) ;; (define-public type %vcomponent-get-type) (define-public type (make-procedure-with-setter @@ -76,17 +71,20 @@ (define-public filter-children! %vcomponent-filter-children!) +(define-public (extract field) + (lambda (e) (attr e field))) + +(define-public (extract* field) + (lambda (e) (attr* e field))) + (define-public (search cal term) (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev))) (children cal)))) (find (lambda (ev) (string-contains-ci (car ev) term)) - (map cons (map (cut get-attr <> "SUMMARY") + (map cons (map (extract "SUMMARY") events) events))))) -(define-public (extract field) - (cut get-attr <> field)) - (define-public (key=? k1 k2) (eq? (as-symb k1) (as-symb k2))) diff --git a/module/vcalendar/primitive.scm b/module/vcalendar/primitive.scm index 400750c9..27ae6e17 100644 --- a/module/vcalendar/primitive.scm +++ b/module/vcalendar/primitive.scm @@ -11,13 +11,7 @@ %vcomponent-get-type %vcomponent-set-type! - %vcomponent-set-attribute! %vcomponent-get-attribute - - %vcomponent-get-property - %vcomponent-set-property! - %vcomponent-property-list - %vcomponent-attribute-list %vcomponent-shallow-copy)) diff --git a/src/guile_interface.scm.c b/src/guile_interface.scm.c index 036e9e9c..0f795d44 100644 --- a/src/guile_interface.scm.c +++ b/src/guile_interface.scm.c @@ -45,109 +45,54 @@ SCM_DEFINE (vcomponent_get_attribute, "%vcomponent-get-attribute", 2, 0, 0, char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL); content_line* c = get_attributes (cal, key); - free(key); - - if (c == NULL) return SCM_BOOL_F; - - SCM llist = SCM_EOL; - FOR (LLIST, content_set, v, c) { - llist = scm_cons(scm_from_strbuf(&v->key), llist); - } - /* returns the car of list if list is one long. */ - if (scm_to_int(scm_length(llist)) == 1) { - return SCM_CAR(llist); - } else { - return llist; + if (c == NULL) { + vcomponent_push_val(cal, key, ""); + c = get_attributes (cal, key); + c->cval->key.scm = SCM_BOOL_F; } -} - -SCM_DEFINE (vcomponent_get_property, "%vcomponent-get-property", 3, 0, 0, - (SCM component, SCM attr, SCM prop), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL); - char* prop_key = scm_to_utf8_stringn(scm_string_upcase(prop), NULL); - content_line* cl = get_attributes (comp, key); free(key); - if (cl == NULL) return SCM_BOOL_F; - - SCM llist = SCM_EOL; - FOR (LLIST, content_set, cs, cl) { - LLIST(strbuf)* strs = GET(TRIE(param_set))(&cs->val, prop_key); - if (strs == NULL) continue; - SCM subl = SCM_EOL; - FOR (LLIST, strbuf, s, strs) { - subl = scm_cons(scm_from_strbuf(s), subl); + SCM val, attrlist = SCM_EOL, proplist; + 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); + val = scm_cons(val, SCM_MAKE_HASH_TABLE()); + v->key.scm = val; + scm_gc_protect_object(v->key.scm); } - llist = scm_cons(subl, llist); - } - - return llist; -} -SCM_DEFINE (vcomponent_set_property_x, "%vcomponent-set-property!", 4, 0, 0, - (SCM component, SCM attr, SCM prop, SCM val), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); + triekeys = KEYS(TRIE(param_set))(&v->val); + /* For every property key bound to the current attribute */ + FOR (LLIST, strbuf, k, triekeys) { + proplist = SCM_EOL; - char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL); - char* prop_key = scm_to_utf8_stringn(scm_string_upcase(prop), NULL); - content_line* cl = get_attributes (comp, key); - free(key); - - TRIE(param_set)* tt = &cl->cval->val; - LLIST(strbuf)* vals = GET(TRIE(param_set))(tt, prop_key); - vals->cval->scm = val; - - return SCM_UNSPECIFIED; -} - -SCM_DEFINE (vcomponent_set_attr_x, "%vcomponent-set-attribute!", 3, 0, 0, - (SCM component, SCM attr, SCM new_value), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* com = scm_foreign_object_ref (component, 0); - - char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL); - content_line* c = get_attributes (com, key); + 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); + } - /* Create the position in the TRIE if it doesn't already exist */ - if (c == NULL) { - /* Insert empty key since this allows me to use the helper - * function */ - vcomponent_push_val(com, key, ""); - c = get_attributes (com, key); - } else { - /* - * The SCM representation of an object is usually initialized - * when an attribute is first accessed from guile. If we - * however try to set it before accessing it then that field - * will still be NULL. - * - * If the object, and its SCM instance exist, unprotect it. - * Otherwise we know that it's NULL and safe to write a new - * SCM value there. - */ - if (c->cval->key.scm != NULL) { - scm_gc_unprotect_object(c->cval->key.scm); + scm_hashq_set_x(scm_cdr(val), scm_from_strbuf_symbol(k), + scm_reverse(proplist)); } + attrlist = scm_cons(val, attrlist); } - free(key); - - strbuf* target = &c->cval->key; - target->scm = new_value; - scm_gc_protect_object(target->scm); - - return SCM_UNSPECIFIED; + /* returns the car of list if list is one long. */ + if (scm_to_int(scm_length(attrlist)) == 1) { + return SCM_CAR(attrlist); + } else { + return attrlist; + } } SCM_DEFINE (vcomponent_child_count, "%vcomponent-child-count", 1, 0, 0, @@ -274,37 +219,6 @@ SCM_DEFINE(vcomponent_attr_list, "%vcomponent-attribute-list", 1, 0, 0, return llist; } -SCM_DEFINE(vcomponent_prop_list, "%vcomponent-property-list", 2, 0, 0, - (SCM component, SCM attr), - "") -{ - scm_assert_foreign_object_type (vcomponent_type, component); - vcomponent* comp = scm_foreign_object_ref (component, 0); - - char* key = scm_to_utf8_stringn(scm_string_upcase(attr), NULL); - content_line* cl = get_attributes (comp, key); - free(key); - - if (cl == NULL) return SCM_BOOL_F; - - SCM llist = SCM_EOL; - FOR (LLIST, content_set, cs, cl) { - LLIST(strbuf)* keys = KEYS(TRIE(param_set))(&cs->val); - if (keys == NULL) continue; - - FOR (LLIST, strbuf, s, keys) { - SCM symb = scm_string_to_symbol(scm_from_strbuf(s)); - if ( scm_is_false(scm_memv (symb, llist)) ) { - llist = scm_cons(symb, 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.") diff --git a/src/strbuf.c b/src/strbuf.c index c7e3f2b5..66fe2989 100644 --- a/src/strbuf.c +++ b/src/strbuf.c @@ -70,8 +70,13 @@ int DEEP_COPY(strbuf)(strbuf* dest, strbuf* src) { } if (src->scm != NULL) { - /* The magic SCM type is copied when reassigned. */ - dest->scm = src->scm; + /* + * 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); } |