blob: 12e2d9a58f618dccb1108bd23f1aa69174fbdc2b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
(define-module (vcalendar)
#:use-module (vcalendar primitive)
#:use-module (vcalendar datetime)
#:use-module (vcalendar recur)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (util)
#:export (make-vcomponent)
#:re-export (repeating?))
(define (parse-dates! cal)
"Parse all start times into scheme date objects."
(for-each-in (children cal 'VEVENT)
(lambda (ev)
(mod! (attr ev "DTSTART") parse-datetime)
(mod! (attr ev "DTEND") parse-datetime)))
cal)
(define-public (type-filter t lst)
(filter (lambda (e) (eqv? t (type e)))
lst))
(define* (children component #:optional only-type)
(let ((childs (%vcomponent-children component)))
(if only-type
(type-filter only-type childs)
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-property! component attr prop val)
(%vcomponent-set-property!
component
(as-string attr)
(as-string prop)
val))
(define-public prop
(make-procedure-with-setter
get-property
set-property!))
(define-public (properties component attr)
(%vcomponent-property-list component (as-string attr)))
;; Enables symmetric get and set:
;; (set! (attr ev "KEY") 10)
(define-public attr (make-procedure-with-setter get-attr set-attr!))
;; (define-public type %vcomponent-get-type)
(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)))
(define-public copy-vcomponent %vcomponent-shallow-copy)
(define-public filter-children! %vcomponent-filter-children!)
(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")
events)
events)))))
(define-public (extract field)
(cut get-attr <> field))
(define-public (key=? k1 k2)
(eq? (as-symb k1)
(as-symb k2)))
(define* (make-vcomponent #:optional path)
(if (not path)
(%vcomponent-make)
(let* ((root (%vcomponent-make path))
(component
(parse-dates!
(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)
(car (%vcomponent-children root)))
;; == Assume vdir ==
;; Also removes the abstract ROOT component, but also
;; merges all VCALENDAR's children into the first
;; VCALENDAR, and return that VCALENDAR.
;;
;; TODO the other VCALENDAR components might not get thrown away,
;; this since I protect them from the GC in the C code.
((vdir)
(reduce (lambda (cal accum)
(for-each (lambda (component)
(case (type component)
((VTIMEZONE)
(let ((zones (children accum 'VTIMEZONE)))
(unless (find (lambda (z)
(string=? (attr z "TZID")
(attr component "TZID")))
zones)
(%vcomponent-push-child! accum component))))
(else (%vcomponent-push-child! accum component))))
(%vcomponent-children cal))
accum)
'() (%vcomponent-children root)))
((no-type) (throw 'no-type))
(else (throw 'something))))))
(set! (attr component "NAME")
(attr root "NAME"))
(set! (attr component "COLOR")
(attr root "COLOR"))
component)))
|
