diff options
Diffstat (limited to '')
-rw-r--r-- | doc/ref/guile/vcomponent.texi | 2 | ||||
-rw-r--r-- | module/vcomponent/base.scm | 63 | ||||
-rw-r--r-- | module/vcomponent/create.scm | 2 | ||||
-rw-r--r-- | module/vcomponent/datetime.scm | 6 | ||||
-rw-r--r-- | module/vcomponent/formats/ical/parse.scm | 2 | ||||
-rw-r--r-- | module/vcomponent/formats/vdir/parse.scm | 4 | ||||
-rw-r--r-- | module/vcomponent/formats/vdir/save-delete.scm | 2 | ||||
-rw-r--r-- | module/vcomponent/formats/xcal/parse.scm | 2 | ||||
-rw-r--r-- | module/vcomponent/util/instance/methods.scm | 4 | ||||
-rwxr-xr-x | scripts/generate-test-data.scm | 4 | ||||
-rw-r--r-- | tests/test/add-and-save.scm | 2 | ||||
-rw-r--r-- | tests/test/vcomponent.scm | 32 |
12 files changed, 77 insertions, 48 deletions
diff --git a/doc/ref/guile/vcomponent.texi b/doc/ref/guile/vcomponent.texi index 70af3ad3..2560bdde 100644 --- a/doc/ref/guile/vcomponent.texi +++ b/doc/ref/guile/vcomponent.texi @@ -106,6 +106,8 @@ Curried version of @var{prop}. @end deftp @defun copy-vcomponent vcomponent +Creates a shallow copy of @var{vcomponent}. If the source object has a +parent, then than parent adopts the new event also. @end defun diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index df452f62..2da939d0 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -15,7 +15,9 @@ vcomponent? children type parent - add-child! remove-child! + reparent! + abandon! + orphan! delete-property! prop* prop @@ -75,40 +77,38 @@ (make-vline% key value ht)) (define-record-type <vcomponent> - (make-vcomponent% type children parent properties) + (make-vcomponent% type children properties) vcomponent? (type type) (children children set-component-children!) - (parent get-component-parent set-component-parent!) (properties get-component-properties)) ((@ (srfi srfi-9 gnu) set-record-type-printer!) <vcomponent> (lambda (c p) - (format p "#<<vcomponent> ~a, len(child)=~a, parent=~a>" + (format p "#<<vcomponent> ~a, len(child)=~a>" (type c) (length (children c)) - (and=> (get-component-parent c) type)))) + ))) -;; TODO should this also update the parent -(define parent - (make-procedure-with-setter - get-component-parent set-component-parent!)) + +(define parent% (make-object-property)) +(define (parent x) (parent% x)) (define* (make-vcomponent optional: (type 'VIRTUAL)) - (make-vcomponent% type '() #f (make-hash-table))) + (make-vcomponent% type '() (make-hash-table))) -(define (add-child! parent child) +(define (reparent! parent child) (set-component-children! parent (cons child (children parent))) - (set-component-parent! child parent)) + (set! (parent% child) parent)) -(define (remove-child! parent-component child) - (unless (eq? parent-component (parent child)) - (scm-error - 'wrong-type-arg "remove-child!" "Child doesn't belong to parent" - (list parent-component child) #f)) +(define (abandon! parent-component child) (set-component-children! parent-component (delq1! child (children parent-component))) - (set-component-parent! child #f)) + (when (eq? parent-component (parent% child)) + (orphan! child))) + +(define (orphan! child) + (set! (parent% child) #f)) ;;; TODO key=DTSTART, (date? value) => #t ;;; KRĂ„VER att (props vline 'VALUE) <- "DATE" @@ -195,18 +195,21 @@ (get-vline-parameters vline))) (define (copy-vcomponent component) - (make-vcomponent% - (type component) - ;; TODO deep copy? - (children component) - (parent component) - ;; properties - (alist->hashq-table - (hash-map->list (lambda (key value) - (cons key (if (list? value) - (map copy-vline value) - (copy-vline value)))) - (get-component-properties component))))) + (let ((ev + (make-vcomponent% + (type component) + (children component) + ;; properties + (alist->hashq-table + (hash-map->list (lambda (key value) + (cons key (if (list? value) + (map copy-vline value) + (copy-vline value)))) + (get-component-properties component)))))) + (when (parent component) + (reparent! (parent component) ev)) + ev)) + (define (extract field) (lambda (e) (prop e field))) diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm index 0521b39b..374da8b4 100644 --- a/module/vcomponent/create.scm +++ b/module/vcomponent/create.scm @@ -100,7 +100,7 @@ (upcase-keys (kvlist->assq attrs))) ;; Attach children - (for-each (lambda (child) (add-child! component child)) + (for-each (lambda (child) (reparent! component child)) children))) component) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 440ec5fd..a66ba38a 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -245,7 +245,7 @@ Event must have the DTSTART and DTEND protperty set." (prop component 'TZNAME) (zone-entry-format zone-entry) last-until (zone-entry-until zone-entry) last-offset new-timespec) - (add-child! vtimezone component)))] + (reparent! vtimezone component)))] [(zone-entry-rule zone-entry) => (lambda (rule-name) @@ -278,7 +278,7 @@ Event must have the DTSTART and DTEND protperty set." (awhen (rule->rrule rule) (set! (prop component 'RRULE) it)) - (add-child! vtimezone component))) + (reparent! vtimezone component))) ;; some of the rules might not apply to us since we only ;; started using that rule set later. It's also possible ;; that we stopped using a ruleset which continues existing. @@ -297,5 +297,5 @@ Event must have the DTSTART and DTEND protperty set." (prop component 'TZNAME) (zone-entry-format zone-entry) last-until (zone-entry-until zone-entry) last-offset (zone-entry-stdoff zone-entry)) - (add-child! vtimezone component))])) + (reparent! vtimezone component))])) vtimezone) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 252a155e..f0a19ba5 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -306,7 +306,7 @@ (if (null? (cdr stack)) ;; return (car stack) - (begin (add-child! (cadr stack) (car stack)) + (begin (reparent! (cadr stack) (car stack)) (cdr stack))))] [else (let ((key value params (parse-itemline head))) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index 4e21d4d0..8fe69fc6 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -66,7 +66,7 @@ (case (length events) [(0) (warning (G_ "No events in component~%~a") (prop item '-X-HNH-FILENAME))] - [(1) (add-child! calendar (car events))] + [(1) (reparent! calendar (car events))] ;; two or more [else @@ -108,7 +108,7 @@ ;; we need to filter duplicates either way. (map (extract 'RECURRENCE-ID) (cons head rest)) (cons head rest)))) - (add-child! calendar head))]) + (reparent! calendar head))]) ;; return calendar) diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index ab1985b6..d096405e 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -61,4 +61,4 @@ (list (prop calendar '-X-HNH-SOURCETYPE)) #f)) (delete-file (prop event '-X-HNH-FILENAME)) - (remove-child! parent event)) + (abandon! parent event)) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 0e638d36..7200e18d 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -258,6 +258,6 @@ ;; children (awhen (assoc-ref sxcal 'components) (for child in (map sxcal->vcomponent it) - (add-child! component child))) + (reparent! component child))) component) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index 75510009..fef83958 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -125,7 +125,7 @@ ;;; with the same UID, which is BAD. (define-method (add-event (this <events>) calendar event) - (add-child! calendar event) + (reparent! calendar event) (unless (prop event 'UID) (set! (prop event 'UID) (uuid))) @@ -184,7 +184,7 @@ ;; remove old instance of event from runtime (remove-event this old-event) - (remove-child! old-calendar old-event) + (abandon! old-calendar old-event) ;; Add new event to runtime, ;; MUST be done after since the two events SHOULD share UID. diff --git a/scripts/generate-test-data.scm b/scripts/generate-test-data.scm index 076558e4..b80c4994 100755 --- a/scripts/generate-test-data.scm +++ b/scripts/generate-test-data.scm @@ -63,8 +63,8 @@ (prop cal 'PRODID) "-//hugo//calp TEST//EN" (prop cal 'VERSION) "2.0") -(add-child! cal zoneinfo) -(add-child! cal ev) +(reparent! cal zoneinfo) +(reparent! cal ev) (define sxcal `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") diff --git a/tests/test/add-and-save.scm b/tests/test/add-and-save.scm index 70b8cce2..fb3277bb 100644 --- a/tests/test/add-and-save.scm +++ b/tests/test/add-and-save.scm @@ -112,7 +112,7 @@ (test-equal "Correct amount of children in calendar" - 2 (length (children calendar))) + 5 (length (children calendar))) (define get-events (@@ (vcomponent util instance methods) get-events)) diff --git a/tests/test/vcomponent.scm b/tests/test/vcomponent.scm index 52e1b6bb..a6989776 100644 --- a/tests/test/vcomponent.scm +++ b/tests/test/vcomponent.scm @@ -3,11 +3,13 @@ ;;; Code: (define-module (test vcomponent) + :use-module (srfi srfi-17) :use-module (srfi srfi-64) :use-module (srfi srfi-88) :use-module ((vcomponent base) - :select (prop make-vcomponent add-child! remove-child! - children))) + :select (prop make-vcomponent reparent! abandon! + copy-vcomponent + type parent children))) (define ev (let ((ev (make-vcomponent 'DUMMY))) @@ -22,7 +24,29 @@ (define calendar (make-vcomponent 'VCALENDAR)) -(add-child! calendar ev) +(reparent! calendar ev) (test-equal 1 (length (children calendar))) -(remove-child! calendar ev) +(abandon! calendar ev) (test-equal 0 (length (children calendar))) + + +(test-group "Copy VComponent" + (let ((ev1 (make-vcomponent 'A)) + (ev2 (make-vcomponent 'B)) + (ev3 (make-vcomponent 'C))) + (set! (prop ev3 'TEST) (list 1 2 3)) + (reparent! ev1 ev2) + (reparent! ev2 ev3) + (let* ((ev2* (copy-vcomponent ev2)) + (ev3* (car (children ev2*)))) + ;; NOTE replace this with `vcomponent=?' if that gets written + (test-group "New object is equivalent to old one" + (test-equal (type ev2) (type ev2*)) + (test-equal (length (children ev2)) (length (children ev2*)))) + (test-eq ev1 (parent ev2)) + + (set! (car (prop ev3* 'TEST)) 10) + (test-equal "Property values aren't deep copied" + '(10 2 3) (prop ev3 'TEST)) + (test-equal '(10 2 3) (prop ev3* 'TEST)) + ))) |