diff options
Diffstat (limited to 'email')
| -rw-r--r-- | email/email.scm | 91 |
1 files changed, 71 insertions, 20 deletions
diff --git a/email/email.scm b/email/email.scm index 52f7f58..56c1b57 100644 --- a/email/email.scm +++ b/email/email.scm @@ -227,32 +227,61 @@ (define-peg-pattern day-name body (or "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) +(define-peg-pattern obs-day-of-week body + (and (ignore (? cfws)) day-name (ignore (? cfws)))) + +;; We set day-of-week to be the same as obs-day-of-week since, +;; according to their definitions in RFC5322, all days-of-week are +;; obs-days-of-week. (define-peg-pattern day-of-week all - (and (ignore (? fws)) day-name)) + obs-day-of-week) -;; TODO: Remove workaround guile peg bug for ignore +(define-peg-pattern obs-day body + (and (ignore (? cfws)) digit (? digit) (ignore (? cfws)))) + +;; We set day to be the same as obs-day since, according to their +;; definitions in RFC5322, all days are obs-days. (define-peg-pattern day all - (and (ignore (? fws)) digit (? digit) (ignore (and fws)))) + obs-day) (define-peg-pattern month all (or "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) -;; TODO: Remove workaround guile peg bug for ignore +(define-peg-pattern obs-year body + (and (ignore (? cfws)) (and digit digit) (* digit) (ignore (? cfws)))) + +;; We set year to be the same as obs-year since, according to their +;; definitions in RFC5322, all years are obs-years. (define-peg-pattern year all - (and (ignore (and fws)) digit digit digit digit (ignore (and fws)))) + obs-year) (define-peg-pattern date all (and day month year)) +(define-peg-pattern obs-hour body + (and (ignore (? cfws)) digit digit (ignore (? cfws)))) + +;; We set hours to be the same as obs-hour since, according to their +;; definitions in RFC5322, all hours are obs-hours. (define-peg-pattern hours all - (and digit digit)) + obs-hour) +(define-peg-pattern obs-minute body + (and (ignore (? cfws)) digit digit (ignore (? cfws)))) + +;; We set minutes to be the same as obs-minute since, according to +;; their definitions in RFC5322, all minutes are obs-minutes. (define-peg-pattern minutes all - (and digit digit)) + obs-minute) + +(define-peg-pattern obs-second body + (and (ignore (? cfws)) digit digit (ignore (? cfws)))) +;; We set seconds to be the same as obs-second since, according to +;; their definitions in RFC5322, all seconds are obs-seconds. (define-peg-pattern seconds all - (and digit digit)) + obs-second) (define-peg-pattern time-of-day all (and hours (ignore ":") minutes (? (and (ignore ":") seconds)))) @@ -270,9 +299,17 @@ (define-peg-pattern zone-minutes all (and digit digit)) -;; TODO: Remove workaround guile peg bug for ignore +(define-peg-pattern obs-zone body + (or "UT" "GMT" + "EST" "EDT" "CST" "CDT" + "MST" "MDT" "PST" "PDT" + (and (not-followed-by (or "j" "J")) + (or (range #\a #\z) + (range #\A #\Z))))) + (define-peg-pattern zone all - (and (ignore (and fws)) zone-sign zone-hours zone-minutes)) + (or (and zone-sign zone-hours zone-minutes) + obs-zone)) (define-peg-pattern time all (and time-of-day zone)) @@ -954,11 +991,9 @@ list of header keys and values." `((date-time . ,(lambda node (match-let ((`((day ,day) (month ,month) (year ,year) - (hours ,hours) (minutes ,minutes) (seconds ,seconds) - (zone-sign ,zone-sign) (zone-hours ,zone-hours) (zone-minutes ,zone-minutes)) + (hours ,hours) (minutes ,minutes) (seconds ,seconds) (zone . ,zone)) (flatten-and-filter - '(day month year hours minutes seconds - zone-sign zone-hours zone-minutes) + '(day month year hours minutes seconds zone) node))) (make-date 0 (string->number seconds) @@ -969,12 +1004,28 @@ list of header keys and values." (cut equal? <> month) (list "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))) - (string->number year) - (* (case (string->symbol zone-sign) - ((+) 1) - ((-) -1)) - (+ (* 60 60 (string->number zone-hours)) - (* 60 (string->number zone-minutes)))))))) + (let ((year (string->number year))) + (cond + ((and (>= year 0) (<= year 49)) + (+ year 2000)) + ((and (>= year 50) (<= year 999)) + (+ year 1900)) + (else year))) + (match zone + (((or "UT" "GMT")) 0) + (("EDT") (* -4 3600)) + (((or "EST" "CDT")) (* -5 3600)) + (((or "CST" "MDT")) (* -6 3600)) + (((or "MST" "PDT")) (* -7 3600)) + (("PST") (* -8 3600)) + (`((zone-sign ,zone-sign) + (zone-hours ,zone-hours) + (zone-minutes ,zone-minutes)) + (* (case (string->symbol zone-sign) + ((+) 1) + ((-) -1)) + (+ (* 60 60 (string->number zone-hours)) + (* 60 (string->number zone-minutes)))))))))) (orig-date . ,(lambda (_ date) (list 'date date))) (mailbox . ,post-process-mailbox) (address-list *macro* . ,macro-process-address-list) |