blob: bea9c0dc12a793c506866776f9b5453a22f9d1fc (
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
|
(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
(if (symbol? attr) (symbol->string attr) attr)
value))
(define (get-attr component attr)
(%vcomponent-get-attribute
component
(if (symbol? attr) (symbol->string attr) 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?
(if (string? k1) (string->symbol k1) k1)
(if (string? k2) (string->symbol k2) 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 cal '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)))
|
