-
Notifications
You must be signed in to change notification settings - Fork 4
/
Copy pathdatetime.el
2089 lines (1871 loc) · 114 KB
/
datetime.el
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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; datetime.el --- Parsing, formatting and matching timestamps -*- lexical-binding: t -*-
;; Copyright (C) 2016-2024 Paul Pogonyshev
;; Author: Paul Pogonyshev <[email protected]>
;; Maintainer: Paul Pogonyshev <[email protected]>
;; Version: 0.10.2snapshot
;; Keywords: lisp, i18n
;; Homepage: https://github.com/doublep/datetime
;; Package-Requires: ((emacs "25.1") (extmap "1.1.1"))
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of
;; the License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see http://www.gnu.org/licenses.
;;; Commentary:
;; Library for generic timestamp handling. It is targeted at bulk
;; processing, therefore many functions are optimized for speed, but
;; not necessarily for ease of use. For example, formatting is done
;; in two steps: first you need to generate a formatting function for
;; given pattern, and only using it obtain formatted strings.
;;
;; Package's main feature is timestamp parsing and formatting based on
;; Java pattern. Arbitrary timezones and locales (i.e. not
;; necessarily those used by the system) are supported. However,
;; specifying timezone in the input string to the parser function is
;; not implemented yet. See functions `datetime-parser-to-float' and
;; `datetime-float-formatter' for details.
;;
;; Library also supports timestamp matching. It can generate regular
;; expressions that match timestamps corresponding to given pattern.
;; These regular expressions can give false positives, but for most
;; purposes are good enough to detect timestamps in text files,
;; e.g. in various application logs. See `datetime-matching-regexp'.
;;
;; Finally, library provides functions to select an appropriate
;; timestamp format for given locale. For example, function
;; `datetime-locale-date-pattern' returns a Java pattern suitable for
;; formatting (or parsing) date only, without time part. However, it
;; is not required that patterns are generated this way.
;;; Code:
;; Internally any date-time pattern is parsed to a list of value pairs
;; (TYPE . DETAILS). Type is a symbol, while details are either nil,
;; another symbol or a number that represents minimum number of
;; characters in formatted number (left padded with zeros). The only
;; exception is "as-is" part: it is just a string, not a cons cell.
;;
;; Here are all currently used types with details in parentheses,
;; grouped roughly by represented date-time value. Context/standalone
;; is meaningful for languages that involve flexing, for English they
;; are the same.
;;
;; In all cases these should be seen as internals and can be changed
;; in a future library versions without prior notice.
;;
;; era (short | full | narrow) --- AD or BC
;;
;; year (add-century-when-parsing | always-two-digits | NUMBER)
;; - add-century-when-parsing: format as-is, but when parsing add
;; century if exactly two digits;
;; year-for-week (same as for year)
;;
;; month (NUMBER)
;; month-context-name (short | full | narrow)
;; month-standalone-name (short | full | narrow)
;;
;; week-in-year (NUMBER)
;; week-in-month (NUMBER)
;;
;; day-in-year (NUMBER)
;; day-in-month (NUMBER)
;; weekday-in-month (NUMBER)
;; e.g. would be 2 for 2015-09-09, because it is the second
;; Wednesday that month;
;; weekday (NUMBER)
;; weekday-context-name (short | full | narrow)
;; weekday-standalone-name (short | full | narrow)
;;
;; am-pm (full | abbreviated)
;; day-period (short | full | narrow)
;;
;; hour-0-23 (NUMBER)
;; hour-1-24 (NUMBER)
;; hour-am-pm-0-11 (NUMBER)
;; hour-am-pm-1-12 (NUMBER)
;;
;; minute (NUMBER)
;; second (NUMBER)
;; second-fractional (NUMBER)
;; parts of a second: (second-fractional . 3) means millis,
;; (second-fractional . 6) -- micros, and so on;
;;
;; decimal-separator (PREFERRED)
;; either dot or comma;
;;
;; timezone (SYMBOL)
;; abbreviated, full --- timezone name, as reported by Java
;; (abbreviated is by far more useful, as full is too
;; verbose for most usecases);
;; offset-* -- different representations of timezone (search
;; the source code for a full list) offset to GMT.
(require 'extmap)
(defun datetime--define-error (name message)
(if (fboundp #'define-error)
(define-error name message)
(put name 'error-conditions `(,name error))
(put name 'error-message message)))
(datetime--define-error 'datetime-invalid-string "Date-time string is invalid")
(datetime--define-error 'datetime-unsupported-timezone "Timezones are currently not supported")
(defconst datetime--directory (file-name-directory (or load-file-name (buffer-file-name))))
;; Extracted from Java using `dev/HarvestData.java'. All patterns are
;; obviously of `java' type.
;;
;; There are many fallbacks involved to reduce size:
;; - for locale XX-YY value for any property defaults to that for
;; locale XX;
;; - `:decimal-separator' defaults to dot;
;; - both `:eras-full' and `:eras-narrow' fall back to
;; `:eras-short';
;; - `:eras-short' and `:am-pm' default to English version;
;; - month/dayweek standalone abbreviations or names default to
;; the corresponding context-aware property;
;; - for day period strings, both `:full' and `:narrow' variants
;; fall back to `:short';
;; - date-time patterns are not stored, instead they are built from
;; date and time parts for that locale; corresponding field is a
;; cons with car determining what should be in the beginning (t
;; for date, nil for time), and cdr being the separator string;
;; the cons defaults to (t . " ");
;; - all patterns have the following fallbacks: `:short' defaults to
;; `:medium', `:long' defaults to `:medium', `:full' defaults to
;; `:long'.
(defvar datetime--locale-extmap (extmap-init (expand-file-name "locale-data.extmap" datetime--directory) :auto-reload t))
;; Extracted from Java using `dev/HarvestData.java'.
(defvar datetime--timezone-extmap (extmap-init (expand-file-name "timezone-data.extmap" datetime--directory) :weak-data t :auto-reload t))
;; Extracted from Java using `dev/HarvestData.java'.
;;
;; Fallbacks:
;; - for locale XX-YY names defaults to those for locale XX;
;; - for locale XX names default to those in English locale;
;; - names themselves can be in several formats (individual values
;; are always strings):
;; FULL -- abbreviated name is taken from the English locale,
;; no special for DST;
;; (FULL-STD . FULL-DST) -- abbreviated names are taken from the
;; English locale;
;; [ABBREVIATED FULL] -- no special for DST;
;; [ABBREVIATED-STD ABBREVIATED-DST FULL-STD FULL-DST].
(defvar datetime--timezone-name-extmap (extmap-init (expand-file-name "timezone-name-data.extmap" datetime--directory) :weak-data t :auto-reload t))
(defvar datetime--pattern-parsers '((parsed . (lambda (pattern options) pattern))
(java . datetime--parse-java-pattern)))
(defvar datetime--pattern-formatters '((parsed . (lambda (parts options) parts))
(java . datetime--format-java-pattern)))
;; Floating-point offset is our internal mark of a transition to DST.
(defvar datetime--last-conversion-offset nil)
(defvar datetime--locale-timezone-name-lookup-cache nil)
(defvar datetime--locale-timezone-name-lookup-cache-version 0)
;; `datetime-list-*' must be defined here, since they are used in
;; `defcustom' forms below.
(defun datetime-list-locales (&optional include-variants)
"List all locales for which the library has information.
If INCLUDE-VARIANTS is nil, only include “base” locales (in
format \"xx\"), if it is t then also include “variants” in format
\"xx-YY\".
Return value is a list of symbols in no particular order; it can
be modified freely."
(if include-variants
(extmap-keys datetime--locale-extmap)
(let (locales)
(extmap-mapc datetime--locale-extmap (lambda (locale data) (unless (plist-get data :parent) (push locale locales))))
locales)))
(defun datetime-list-timezones ()
"List all timezones for which the library has information.
Return value is a list of symbols in no particular order; it can
be modified freely."
(delq :aliases (extmap-keys datetime--timezone-extmap)))
(defgroup datetime nil
"Date-time handling library."
:group 'i18n)
(defcustom datetime-locale nil
"Default locale for date-time formatting and parsing.
Leave unset to let the library auto-determine it from your OS
when necessary.
You can see the list of locales supported by the library by
evaluating this form:
(prin1-to-string (sort (datetime-list-locales t) #\\='string<))"
:group 'datetime
;; The only minor problem is the type won't be rebuilt if `datetime--locale-extmap' is
;; autoreloaded, but oh well.
:type `(choice (const nil) ,@(mapcar (lambda (locale) `(const ,locale)) (datetime-list-locales t))))
(defcustom datetime-timezone nil
"Default timezone for date-time formatting and parsing.
Leave unset to let the library auto-determine it from your OS
when necessary.
You can see the list of supported timezones by evaluating this
form:
(prin1-to-string (sort (datetime-list-timezones) #\\='string<))"
:group 'datetime
:type `(choice (const nil) ,@(mapcar (lambda (locale) `(const ,locale)) (datetime-list-timezones))))
(defun datetime--get-locale (options)
(let ((locale (plist-get options :locale)))
(if (eq locale 'system)
(or (when datetime-locale
(if (extmap-contains-key datetime--locale-extmap datetime-locale)
datetime-locale
(warn "Locale `%S' (value of `datetime-locale' variable) is not known" datetime-locale)
nil))
(let ((system-locale (or (getenv "LC_ALL") (getenv "LC_TIME") (getenv "LANG")))
as-symbol)
(when system-locale
(save-match-data
(when (string-match "^[a-zA-Z_]+" system-locale)
(setq as-symbol (intern (replace-regexp-in-string "_" "-" (match-string 0 system-locale) t t))))))
(if (extmap-contains-key datetime--locale-extmap as-symbol)
as-symbol
(error "Failed to determine system locale%s; consider customizing `datetime-locale' variable"
(if as-symbol (format-message " (found raw value: `%s')" as-symbol) "")))))
(or locale 'en))))
(defun datetime--get-timezone (options)
(let ((timezone (plist-get options :timezone)))
(if (eq timezone 'system)
(or (when datetime-timezone
(if (and (not (eq datetime-timezone :aliases)) (extmap-contains-key datetime--timezone-extmap datetime-timezone))
datetime-timezone
(warn "Timezone `%S' (value of `datetime-timezone' variable) is not known" datetime-timezone)
nil))
(datetime--determine-system-timezone))
(or timezone 'UTC))))
(defun datetime--determine-system-timezone ()
;; Unfortunately, there is no simple way. `current-time-zone' might
;; look as one, but it often returns a name that is not understood
;; by this library. These heuristics are certainly incomplete.
(save-match-data
(let ((system-timezone (intern (or (pcase system-type
((or `gnu `gnu/linux `gnu/kfreebsd `darwin)
(or ;; For Debian-based distros.
(when (file-exists-p "/etc/timezone")
(condition-case nil
(with-temp-buffer
(insert-file-contents-literally "/etc/timezone")
(when (looking-at "\\S-+")
(match-string-no-properties 0)))
(error)))
;; Freedesktop standard (?).
(let ((localtime (file-symlink-p "/etc/localtime")))
;; The link normally points to `/usr/share/...', but at least
;; on macOS the target is `/var/db/timezone...', see
;; https://github.com/doublep/datetime/issues/11. To make
;; this more robust, just accept any target with "zoneinfo"
;; just before the name.
(when (and localtime (string-match "^/.+/zoneinfo/\\(.+\\)$" localtime))
(match-string-no-properties 1 localtime)))))
;; FIXME: On Windows we could (probably) use "tzutil /g" command to get
;; timezone identifier, but then it still needs to be mapped to what we
;; have in `timezone-data.extmap' (i.e. Java format)... So, currently
;; Windows users have to set `datetime-timezone' manually.
)
(cadr (current-time-zone))
"?"))))
(if (and (not (eq system-timezone :aliases)) (extmap-contains-key datetime--timezone-extmap system-timezone))
system-timezone
(let* ((aliases (extmap-get datetime--timezone-extmap :aliases t))
(entry (assoc (symbol-name system-timezone) aliases)))
(if entry
(cdr entry)
(error "Failed to determine system timezone%s; consider customizing `datetime-timezone' variable"
(if (eq system-timezone '\?) "" (format-message " (found raw value: `%s')" system-timezone)))))))))
(defun datetime--parse-pattern (type pattern options)
(let ((parser (cdr (assq type datetime--pattern-parsers))))
(if parser
(funcall parser pattern options)
(error "Unknown pattern type `%s'" type))))
(defun datetime--format-pattern (type parts options)
(let ((formatter (cdr (assq type datetime--pattern-formatters))))
(if formatter
(funcall formatter parts options)
(error "Unknown pattern type `%s'" type))))
;; Appending character-by-character is slow, but pretty sure it
;; doesn't matter for generally short date-time patterns.
(defmacro datetime--extend-as-is-part (parts text)
`(let ((text ,text))
(if (stringp (car ,parts))
(setf (car parts) (concat (car ,parts) text))
(push text ,parts))))
(defun datetime--parse-java-pattern (pattern options)
(let ((scan 0)
(length (length pattern))
parts)
(while (< scan length)
(let ((character (aref pattern scan))
(num-repetitions 1))
(setq scan (1+ scan))
(cond ((= character ?')
(when (= scan length)
(error "Unterminated quote"))
;; Ugly code to parse single-quoted string.
(if (= (aref pattern scan) ?')
(progn
(datetime--extend-as-is-part parts "'")
(setq scan (1+ scan)))
(while (progn
(when (= scan length)
(error "Unterminated quote"))
(setq character (aref pattern scan)
scan (1+ scan))
(if (/= character ?')
(datetime--extend-as-is-part parts (string character))
(when (and (< scan length) (= (aref pattern scan) ?'))
(datetime--extend-as-is-part parts (string ?'))
(setq scan (1+ scan))))))))
((or (and (<= ?A character) (<= character ?Z)) (and (<= ?a character) (<= character ?z)))
(while (and (< scan length) (eq (aref pattern scan) character))
(setq scan (1+ scan)
num-repetitions (1+ num-repetitions)))
(push (pcase character
(?G (cons 'era (pcase num-repetitions
((or 1 2 3) 'short)
(4 'full)
(5 'narrow)
(_ (error "Pattern character `%c' must come in 1-5 repetitions" character)))))
((or ?y ?Y)
(cons (if (= character ?y) 'year 'year-for-week)
(pcase num-repetitions
(1 'add-century-when-parsing)
(2 'always-two-digits)
(_ num-repetitions))))
((or ?M ?L)
(if (<= num-repetitions 2)
(cons 'month num-repetitions)
(cons (if (= character ?M) 'month-context-name 'month-standalone-name)
(pcase num-repetitions
(3 'short)
(4 'full)
(5 'narrow)
(_ (error "Pattern character `%c' must come in 1-5 repetitions" character))))))
((or ?E ?c ?e)
(if (or (cond ((= character ?e) (<= num-repetitions 2))
((= character ?c) (= num-repetitions 1))))
(cons 'weekday num-repetitions)
(cons (if (= character ?c) 'weekday-standalone-name 'weekday-context-name)
(pcase num-repetitions
((or 1 2 3) 'short)
(4 'full)
(5 'narrow)
(_ (error "Pattern character `%c' must come in 1-5 repetitions" character))))))
(?w (cons 'week-in-year num-repetitions))
(?W (cons 'week-in-month num-repetitions))
(?D (cons 'day-in-year num-repetitions))
(?d (cons 'day-in-month num-repetitions))
(?F (cons 'weekday-in-month num-repetitions))
(?u (cons 'weekday num-repetitions))
(?a (cons 'am-pm (pcase num-repetitions
(1 'abbreviated)
(_ (error "Pattern character `%c' must come in exactly 1 repetition" character)))))
(?H (cons 'hour-0-23 num-repetitions))
(?k (cons 'hour-1-24 num-repetitions))
(?K (cons 'hour-am-pm-0-11 num-repetitions))
(?h (cons 'hour-am-pm-1-12 num-repetitions))
(?B (cons 'day-period (pcase num-repetitions
(1 :short)
(4 :full)
(5 :narrow)
(_ (error "Pattern character `%c' must come in exactly 1, 4 or 5 repetitions" character)))))
(?m (cons 'minute num-repetitions))
(?s (cons 'second num-repetitions))
(?S (cons 'second-fractional num-repetitions))
(?z (cons 'timezone (if (>= num-repetitions 4) 'full 'abbreviated)))
(?O (cons 'timezone (pcase num-repetitions
(1 'offset-localized-short)
(4 'offset-localized-full)
(_ (error "Pattern character `%c' must come in exactly 1 or 4 repetitions" character)))))
((or ?x ?X)
(cons 'timezone (let ((details (pcase num-repetitions
(1 'offset-hh?mm)
(2 'offset-hhmm)
(3 'offset-hh:mm)
(4 'offset-hhmm?ss)
(5 'offset-hh:mm?:ss)
(_ (error "Pattern character `%c' must come in 1-5 repetitions" character)))))
(if (= character ?x) details (intern (format "%s-or-z" (symbol-name details)))))))
(?Z (cons 'timezone (pcase num-repetitions
((or 1 2 3) 'offset-hhmm)
(4 'offset-localized-full)
(5 'offset-hh:mm?:ss-or-z)
(_ (error "Pattern character `%c' must come in 1-5 repetitions" character)))))
(_
(error "Illegal pattern character `%c'" character)))
parts))
;; FIXME: Optional pattern sections are currently treated the same as
;; mandatory (brackets are just discarded). May want to treat them
;; as optional at least for parsing purposes later.
((or (= character ?\[) (= character ?\])))
(t
(if (and (or (= character ?.) (= character ?,))
(plist-get options :any-decimal-separator)
(eq (car-safe (car parts)) 'second)
(< scan length) (= (aref pattern scan) ?S))
(push (cons 'decimal-separator character) parts)
(datetime--extend-as-is-part parts (string character)))))))
(nreverse parts)))
(defun datetime--format-java-pattern (parts options)
(ignore options)
(let ((case-fold-search nil)
strings)
(dolist (part parts)
(if (stringp part)
(progn
(when (string-match "\\`'+" part)
(push (concat (match-string-no-properties 0) (match-string-no-properties 0)) strings)
(setq part (substring part (match-end 0))))
(when (> (length part) 0)
(push (if (string-match "['[:alpha:]]" part)
;; TODO: Might want to prettify a bit.
(concat "'" (replace-regexp-in-string "'" "''" part t t) "'")
part)
strings)))
(let* ((type (car part))
(details (cdr part))
(string (pcase type
(`era (pcase details
(`short "G")
(`full "GGGG")
(`narrow "GGGGG")))
((or `year `year-for-week)
(let ((base (if (eq type 'year) ?y ?Y)))
(pcase details
(`add-century-when-parsing base)
(`always-two-digits (cons base 2))
(_ (cons base details)))))
(`month (cons ?M details))
((or `month-context-name `month-standalone-name `weekday-context-name `weekday-standalone-name)
(cons (pcase type
(`month-context-name ?M)
(`month-standalone-name ?L)
(`weekday-context-name ?E)
(`weekday-standalone-name ?c))
(pcase details
(`short 3)
(`full 4)
(`narrow 5)
(_ (error "Unexpected details %s" details)))))
(`week-in-year (cons ?w details))
(`week-in-month (cons ?W details))
(`day-in-year (cons ?D details))
(`day-in-month (cons ?d details))
(`weekday-in-month (cons ?F details))
(`hour-0-23 (cons ?H details))
(`hour-1-24 (cons ?k details))
(`hour-am-pm-0-11 (cons ?K details))
(`hour-am-pm-1-12 (cons ?h details))
(`minute (cons ?m details))
(`second (cons ?s details))
(`decimal-separator details)
(`second-fractional (cons ?S details))
(`am-pm "a")
(`day-period (pcase details
(:short "B")
(:full "BBBB")
(:narrow "BBBBB")
(_ (error "Unexpected details for `%s' part: %s" type details))))
(_ (error "Unexpected part type %s" type)))))
(push (cond ((integerp string)
(string string))
((consp string)
(unless (integerp (cdr string))
(error "Unexpected details %s" (cdr string)))
(make-string (cdr string) (car string)))
(t
string))
strings))))
(apply #'concat (nreverse strings))))
(defsubst datetime--gregorian-leap-year-mod-400-p (year-mod-400)
(aref (eval-when-compile (let (result)
(dotimes (year 400)
(push (and (= (% year 4) 0) (or (/= (% year 100) 0) (= (% year 400) 0))) result))
(with-no-warnings (apply (if (fboundp #'bool-vector) #'bool-vector #'vector) (nreverse result)))))
year-mod-400))
(defsubst datetime--gregorian-leap-year-p (year)
(datetime--gregorian-leap-year-mod-400-p (mod year 400)))
(defconst datetime--gregorian-cumulative-year-days (let ((days 0)
result)
(dotimes (year 400)
(push days result)
(setq days (+ days (if (datetime--gregorian-leap-year-mod-400-p year) 366 365))))
(push days result)
(apply #'vector (nreverse result))))
(defconst datetime--gregorian-days-in-400-years (aref datetime--gregorian-cumulative-year-days 400))
(defconst datetime--gregorian-days-in-1970-years (+ (* datetime--gregorian-days-in-400-years (/ 1970 400))
(aref datetime--gregorian-cumulative-year-days (% 1970 400))))
;; Conveniently, this also has a loop size of 400 years.
(defconst datetime--gregorian-first-day-of-year (let ((first-day 5)
result)
(dotimes (year 400)
(push first-day result)
(setq first-day (% (+ first-day (if (datetime--gregorian-leap-year-mod-400-p year) 2 1)) 7)))
(apply #'vector (nreverse result))))
(defconst datetime--average-seconds-in-year (/ (* datetime--gregorian-days-in-400-years 24 60 60) 400))
;; For non-leap years.
(defconst datetime--gregorian-month-days [31 28 31 30 31 30 31 31 30 31 30 31])
(defconst datetime--gregorian-cumulative-month-days (let ((days 0)
(result (list 0)))
(dolist (month-days (append datetime--gregorian-month-days nil))
(push (setq days (+ days month-days)) result))
(apply #'vector (nreverse result))))
;; FIXME: Maybe use binary lookup or something? Not terribly important.
(defsubst datetime--day-period-index (thresholds minute)
(let ((index 0))
(while (and thresholds (<= (car thresholds) minute))
(setq thresholds (cdr thresholds)
index (1+ index)))
index))
;; In functions below we rely on form arguments being evaluated from left to right. This
;; is documented in Elisp manual. Important as we use `(setf offset ...)' in the first
;; argument's of `format'.
(defsubst datetime--format-offset-hhmm (offset)
(format (if (>= offset 0)
"+%02d%02d"
(setf offset (- offset))
"-%02d%02d")
(/ offset (* 60 60)) (/ (% offset (* 60 60)) 60)))
(defsubst datetime--format-offset-hh?mm (offset)
(let ((sign (if (>= offset 0) ?+ ?-))
(hours (/ (if (>= offset 0) offset (setf offset (- offset))) (* 60 60)))
(minutes (/ (% offset (* 60 60)) 60)))
(if (= minutes 0)
(format "%c%02d" sign hours)
(format "%c%02d%02d" sign hours minutes))))
(defsubst datetime--format-offset-hhmm?ss (offset)
(let ((sign (if (>= offset 0) ?+ ?-))
(seconds (% (if (>= offset 0) offset (setf offset (- offset))) 60)))
(if (= seconds 0)
(format "%c%02d%02d" sign (/ offset (* 60 60)) (/ (% offset (* 60 60)) 60))
(format "%c%02d%02d%02d" sign (/ offset (* 60 60)) (/ (% offset (* 60 60)) 60) seconds))))
(defsubst datetime--format-offset-hh:mm (offset)
(format (if (>= offset 0)
"+%02d:%02d"
(setf offset (- offset))
"-%02d:%02d")
(/ offset (* 60 60)) (/ (% offset (* 60 60)) 60)))
(defsubst datetime--format-offset-hh:mm?:ss (offset)
(let ((sign (if (>= offset 0) ?+ ?-))
(seconds (% (if (>= offset 0) offset (setf offset (- offset))) 60)))
(if (= seconds 0)
(format "%c%02d:%02d" sign (/ offset (* 60 60)) (/ (% offset (* 60 60)) 60))
(format "%c%02d:%02d:%02d" sign (/ offset (* 60 60)) (/ (% offset (* 60 60)) 60) seconds))))
(defsubst datetime--format-offset-hhmm-or-z (offset)
(if (= offset 0) "Z" (datetime--format-offset-hhmm offset)))
(defsubst datetime--format-offset-hh?mm-or-z (offset)
(if (= offset 0) "Z" (datetime--format-offset-hh?mm offset)))
(defsubst datetime--format-offset-hhmm?ss-or-z (offset)
(if (= offset 0) "Z" (datetime--format-offset-hhmm?ss offset)))
(defsubst datetime--format-offset-hh:mm-or-z (offset)
(if (= offset 0) "Z" (datetime--format-offset-hh:mm offset)))
(defsubst datetime--format-offset-hh:mm?:ss-or-z (offset)
(if (= offset 0) "Z" (datetime--format-offset-hh:mm?:ss offset)))
(defsubst datetime--format-offset-localized-short (offset)
(if (= offset 0)
"GMT"
(let ((sign (if (>= offset 0) ?+ ?-))
(minutes-and-seconds (% (if (>= offset 0) offset (setf offset (- offset))) (* 60 60))))
(if (= minutes-and-seconds 0)
(format "GMT%c%d" sign (/ offset (* 60 60)))
(let ((seconds (% minutes-and-seconds 60)))
(if (= seconds 0)
(format "GMT%c%d:%02d" sign (/ offset (* 60 60)) (/ minutes-and-seconds 60))
(format "GMT%c%d:%02d:%02d" sign (/ offset (* 60 60)) (/ minutes-and-seconds 60) seconds)))))))
(defsubst datetime--format-offset-localized-full (offset)
(if (= offset 0)
"GMT"
(let ((sign (if (>= offset 0) ?+ ?-))
(seconds (% (if (>= offset 0) offset (setf offset (- offset))) 60)))
(if (= seconds 0)
(format "GMT%c%02d:%02d" sign (/ offset (* 60 60)) (/ (% offset (* 60 60)) 60))
(format "GMT%c%02d:%02d:%02d" sign (/ offset (* 60 60)) (/ (% offset (* 60 60)) 60) seconds)))))
(defvar datetime--timezone-offset-matching-regexps
'((offset-hhmm . "[-+][01][0-9][0-5][0-9]")
(offset-hh?mm . "[-+][01][0-9]\\(?:[0-5][0-9]\\)?")
(offset-hhmm?ss . "[-+][01][0-9][0-5][0-9]\\(?:[0-5][0-9]\\)?")
(offset-hh:mm . "[-+][01][0-9]:[0-5][0-9]")
(offset-hh:mm?:ss . "[-+][01][0-9]:[0-5][0-9]\\(?::[0-5][0-9]\\)?")
(offset-hhmm-or-z . "[-+][01][0-9][0-5][0-9]\\|Z")
(offset-hh?mm-or-z . "[-+][01][0-9]\\(?:[0-5][0-9]\\)?\\|Z")
(offset-hhmm?ss-or-z . "[-+][01][0-9][0-5][0-9]\\(?:[0-5][0-9]\\)?\\|Z")
(offset-hh:mm-or-z . "[-+][01][0-9]:[0-5][0-9]\\|Z")
(offset-hh:mm?:ss-or-z . "[-+][01][0-9]:[0-5][0-9]\\(?::[0-5][0-9]\\)?\\|Z")
(offset-localized-short . "GMT\\(?:[-+]\\([0-9]\\|1[0-9]\\)\\(?::[0-5][0-9]\\(?::[0-5][0-9]\\)?\\)?\\)?")
(offset-localized-full . "GMT\\(?:[-+][01][0-9]:[0-5][0-9]\\(?::[0-5][0-9]\\)?\\)?")))
(defun datetime--timezone-offset-matching-regexp (details)
(cdr (assq details datetime--timezone-offset-matching-regexps)))
(defsubst datetime--digits-format (num-repetitions)
(if (> num-repetitions 1) (format "%%0%dd" num-repetitions) "%d"))
(defsubst datetime--format-escape-string (string)
(replace-regexp-in-string "%" "%%" string t t))
(defun datetime-float-formatter (type pattern &rest options)
"Return a function that formats date-time expressed as a float.
The returned function accepts single argument---a floating-point
number---and returns a string with given time formatted according
to given PATTERN of given TYPE. Rest of the arguments must be a
property list, i.e. keywords interleaved with values.
OPTIONS should be any keyword arguments understood by
`datetime-recode-pattern' plus any from the list below, specific
to this function.
:locale
Locale (language) used for month, weekday etc. names. Always
defaults to English, even if system locale is different. You
can use special value \\='system to let the library find it.
:timezone
Timezone for time values to be formatted in. Always defaults
to UTC. You can use special value \\='system to let the
library find the value, suitable for the current machine.
:debug
Don't byte-compile the formatter function, leave it in the
form of a Lisp lambda."
(let* ((locale (datetime--get-locale options))
(timezone (datetime--get-timezone options))
(timezone-data (or (unless (eq timezone :aliases) (extmap-get datetime--timezone-extmap timezone t))
(error "Unknown timezone `%s'" timezone)))
need-year need-month need-weekday need-day need-hour need-time
format-parts
format-arguments)
(dolist (part (datetime--parse-pattern type pattern options))
(if (stringp part)
(push (datetime--format-escape-string part) format-parts)
(let ((type (car part))
(details (cdr part)))
(pcase type
(`era
(setq need-year t)
(push "%s" format-parts)
(push `(aref ,(datetime-locale-field locale (datetime--era-field details)) (if (> year 0) 1 0)) format-arguments))
(`year
(setq need-year t)
(push (pcase details
(`add-century-when-parsing "%d")
(`always-two-digits "%02d")
(_ (datetime--digits-format details)))
format-parts)
(push (if (eq type 'year)
`(if (> year 0) year (- 1 year))
(error "Formatting `%s' is currently not implemented" type))
format-arguments)
(when (eq details 'always-two-digits)
(setf (car format-arguments) `(mod ,(car format-arguments) 100))))
(`year-for-week
(error "Formatting `%s' is currently not implemented" type))
(`month
(setq need-month t)
(push (datetime--digits-format details) format-parts)
(push `(1+ month) format-arguments))
((or `month-context-name `month-standalone-name)
(setq need-month t)
(push "%s" format-parts)
(push `(aref ,(datetime-locale-field locale
(if (eq type 'month-context-name)
(datetime--month-context-name-field details)
(datetime--month-standalone-name-field details)))
month)
format-arguments))
(`week-in-year
(error "Formatting `%s' is currently not implemented" type))
(`week-in-month
(error "Formatting `%s' is currently not implemented" type))
(`day-in-year
(setq need-day t)
(push (datetime--digits-format details) format-parts)
(push `(1+ year-day) format-arguments))
(`day-in-month
(setq need-day t)
(push (datetime--digits-format details) format-parts)
(push `(1+ day) format-arguments))
(`weekday-in-month
(error "Formatting `%s' is currently not implemented" type))
(`weekday
(setq need-weekday t)
(push (datetime--digits-format details) format-parts)
(let ((first-day-of-week (datetime-locale-field locale :first-day-of-week)))
(push (if (= first-day-of-week 0)
`(1+ weekday)
`(1+ (mod (- weekday ,first-day-of-week) 7)))
format-arguments)))
((or `weekday-context-name `weekday-standalone-name)
(setq need-weekday t)
(push "%s" format-parts)
(push `(aref ,(datetime-locale-field locale
(if (eq type 'weekday-context-name)
(datetime--weekday-context-name-field details)
(datetime--weekday-standalone-name-field details)))
weekday)
format-arguments))
(`am-pm
(setq need-hour t)
(push "%s" format-parts)
(push `(aref ,(datetime-locale-field locale :am-pm) (if (>= hour 12) 1 0)) format-arguments))
(`day-period
(setq need-time t)
(push "%s" format-parts)
(let* ((day-period-data (datetime-locale-field locale :day-periods))
(thresholds (plist-get day-period-data :thresholds))
(strings (or (plist-get day-period-data details) (plist-get day-period-data :short))))
(push `(aref ,strings (datetime--day-period-index ',thresholds (/ time 60))) format-arguments)))
((or `hour-0-23 `hour-1-24 `hour-am-pm-0-11 `hour-am-pm-1-12)
(setq need-hour t)
(push (datetime--digits-format details) format-parts)
(push (pcase type
(`hour-0-23 `hour)
(`hour-1-24 `(if (> hour 0) hour 24))
(`hour-am-pm-0-11 `(% hour 12))
(`hour-am-pm-1-12 `(let ((hour (% hour 12))) (if (> hour 0) hour 12))))
format-arguments))
(`minute
(setq need-time t)
(push (datetime--digits-format details) format-parts)
(push `(/ (mod time ,(* 60 60)) 60) format-arguments))
(`second
(setq need-time t)
(push (datetime--digits-format details) format-parts)
(push `(mod time 60) format-arguments))
(`second-fractional
(setq need-time t)
(push (datetime--digits-format details) format-parts)
(let ((scale (expt 10 details)))
(push `(mod (* time ,scale) ,scale) format-arguments)))
(`timezone
(pcase details
((or `abbreviated `full)
(let* ((name (datetime-locale-timezone-name locale timezone nil (eq details 'full)))
(dst-name (pcase timezone-data
(`(,_constant-offset) name)
(_ (datetime-locale-timezone-name locale timezone t (eq details 'full))))))
(if (string= name dst-name)
(push (datetime--format-escape-string name) format-parts)
(push "%s" format-parts)
;; See comments for the variable for explanation of `floatp'.
(push `(if (floatp datetime--last-conversion-offset) ,dst-name ,name) format-arguments))))
((or `offset-localized-short `offset-localized-full
`offset-hh?mm `offset-hhmm `offset-hh:mm `offset-hhmm?ss `offset-hh:mm?:ss
`offset-hh?mm-or-z `offset-hhmm-or-z `offset-hh:mm-or-z `offset-hhmm?ss-or-z `offset-hh:mm?:ss-or-z
`offset-hhmm)
(let ((formatter-function (intern (format "datetime--format-%s" (symbol-name details)))))
(pcase timezone-data
(`(,constant-offset)
(push (funcall formatter-function constant-offset) format-parts))
(_
;; At least `offset-hhmm' and `offset-hh:mm' could in principle be
;; inlined since they use (or could use) fixed format substring.
;; Hardly terribly important.
(push "%s" format-parts)
(push `(,formatter-function (round datetime--last-conversion-offset)) format-arguments)))))
(_
(error "Unexpected timezone details `%s'" details))))
(_ (error "Unexpected value `%s'" type))))))
;; 400 is the size of Gregorian calendar leap year loop.
(let* ((days-in-400-years datetime--gregorian-days-in-400-years)
(formatter `(lambda (date-time)
(setq date-time ,(pcase timezone-data
(`(,constant-offset)
(if (/= constant-offset 0)
`(+ (float date-time) ,constant-offset)
`(float date-time)))
(_
`(datetime--convert-to-utc-float (float date-time) ,(datetime--macroexp-quote timezone-data)))))
(let* (,@(when (or need-year need-month need-weekday need-day)
;; Date in days, rebased from 1970-01-01 to 0000-01-01.
`((date-0 (+ (floor (/ date-time ,(* 24 60 60))) ,datetime--gregorian-days-in-1970-years))
(date-%-400-years (mod date-0 ,days-in-400-years))
(full-400-years (/ (- date-0 date-%-400-years) ,days-in-400-years))
(year-%-400 (/ date-%-400-years 366))
(year (+ (* full-400-years 400)
(progn
(if (< date-%-400-years (aref ,datetime--gregorian-cumulative-year-days (1+ year-%-400)))
year-%-400
(setq year-%-400 (1+ year-%-400))))))))
,@(when (or need-month need-weekday need-day)
`((year-day (- date-0 (* full-400-years ,days-in-400-years) (aref ,datetime--gregorian-cumulative-year-days (mod year 400))))))
,@(when (or need-month need-day)
`((day year-day)
;; Using variable `_month' to avoid byte-compilation warnings if day is
;; needed, but month is not. Let's hope byte-compiler elides unneeded
;; code then (only side-effect of `(setq day ...)' is important in that
;; case), such patterns are too uncommon to bother ourselves.
(,(if need-month 'month '_month)
(let ((july-days (if (datetime--gregorian-leap-year-mod-400-p year-%-400)
,(+ 31 29 31 30 31 30)
,(+ 31 28 31 30 31 30))))
(if (>= day july-days)
(if (>= (setq day (- day july-days)) ,(+ 31 31 30))
(cond ((< (setq day (- day ,(+ 31 31 30))) 31) 9) ; October
((< (setq day (- day 31)) 30) 10) ; November
(t (setq day (- day 30)) 11)) ; December
(cond ((< day 31) 6) ; July
((< (setq day (- day 31)) 31) 7) ; August
(t (setq day (- day 31)) 8))) ; September
(let ((february-days (- july-days ,(+ 31 30 31 30))))
(cond ((< day february-days)
(cond ((< day 31) 0) ; January
(t (setq day (- day 31)) 1))) ; February
((< (setq day (- day february-days)) ,(+ 31 30))
(cond ((< day 31) 2) ; March
(t (setq day (- day 31)) 3))) ; April
(t
(cond ((< (setq day (- day ,(+ 31 30))) 31) 4) ; May
(t (setq day (- day 31)) 5)))))))))) ; June
,@(when need-weekday
`((weekday (% (+ year-day (aref ,datetime--gregorian-first-day-of-year (mod year 400))) 7))))
,@(when (or need-time need-hour)
`((time (mod date-time ,(* 24 60 60)))))
,@(when need-hour
`((hour (/ (mod (floor time) ,(* 24 60 60)) ,(* 60 60))))))
(format ,(apply #'concat (nreverse format-parts)) ,@(nreverse format-arguments))))))
(unless (plist-get options :debug)
(setf formatter (datetime--do-byte-compile formatter "the generated formatter")))
formatter)))
;; Not available on older Emacs versions. Copied from recent Emacs source.
(defun datetime--macroexp-quote (v)
(if (and (not (consp v))
(or (keywordp v)
(not (symbolp v))
(memq v '(nil t))))
v
(list 'quote v)))
(defun datetime--do-byte-compile (function description)
(or (byte-compile function)
(error "Internal error: unable to byte-compile %s" description)))
(defun datetime--convert-to-utc-float (date-time timezone-data)
(let ((year-offset (floor (/ (- date-time (car timezone-data)) datetime--average-seconds-in-year)))
(all-year-transitions (nth 1 timezone-data))
offset)
(if (>= year-offset 0)
(let ((year-transitions (or (when (< year-offset (length all-year-transitions))
(aref all-year-transitions year-offset))
(datetime--calculate-year-transitions timezone-data year-offset))))
(setf offset (pop year-transitions))
(when year-transitions
(let ((offset-in-year (floor (- date-time (car timezone-data) (* year-offset datetime--average-seconds-in-year)))))
(while (and (>= offset-in-year (car year-transitions))
(setf offset (cadr year-transitions)
year-transitions (cddr year-transitions)))))))
;; Offset before the very first transition.
(setf offset (car (aref all-year-transitions 0))))
(+ date-time (setf datetime--last-conversion-offset offset))))
;; 146097 is the value of `datetime--gregorian-days-in-400-years'.
;; `eval-when-compile' doesn't allow referring to the mnemonic name.
;;
;; Likewise, 135140 is the value of
;; `(aref datetime--gregorian-cumulative-year-days (mod 1970 400))'.
(defsubst datetime--start-of-day (year year-day)
(* (eval-when-compile (* 24 60 60.0))
(+ (* (floor (/ (float year) 400)) (eval-when-compile 146097))
(aref datetime--gregorian-cumulative-year-days (mod year 400))
(eval-when-compile (- (+ (* (floor (/ (float 1970) 400)) 146097) 135140)))
year-day)))
(defun datetime--calculate-year-transitions (timezone-data year-offset)
(let* ((all-year-transitions (nth 1 timezone-data))
(num-years (length all-year-transitions))
transitions)
(when (>= year-offset num-years)
(setf (cadr timezone-data) (setq all-year-transitions (vconcat all-year-transitions (make-vector (max (1+ (- year-offset num-years)) (/ num-years 2) 10) nil)))))
(let ((year (+ (nth 2 timezone-data) year-offset))
(year-base (+ (nth 0 timezone-data) (* year-offset datetime--average-seconds-in-year)))
(rules (nth 3 timezone-data)))
(if rules
(dolist (rule rules)
(let* ((month (plist-get rule :month))
(day-of-month (plist-get rule :day-of-month))
(effective-month (if (< day-of-month 0) month (1- month)))
(day-of-week (plist-get rule :day-of-week))
(year-day (+ (aref datetime--gregorian-cumulative-month-days effective-month)
(if (and (>= effective-month 2) (datetime--gregorian-leap-year-p year)) 1 0)
day-of-month -1))
(offset-before (plist-get rule :before)))
(unless transitions
;; Preserve our DST "flag" across year boundary.
(push (if (floatp (car (last (aref all-year-transitions (1- year-offset)))))
(float offset-before)
offset-before)
transitions))
(when day-of-week
(let ((current-weekday (% (+ year-day (aref datetime--gregorian-first-day-of-year (mod year 400))) 7)))
(setq year-day (if (< day-of-month 0) (- year-day (mod (- day-of-week current-weekday) 7)) (+ year-day (mod (- day-of-week current-weekday) 7))))))
(when (plist-get rule :end-of-day)
(setq year-day (1+ year-day)))
(push (round (- (+ (datetime--start-of-day year year-day) (plist-get rule :time))
(pcase (plist-get rule :time-definition)
(`utc 0)
(`standard (plist-get rule :standard-offset))
(`wall offset-before)
(type (error "Unhandled time definition type `%s'" type)))
year-base))
transitions)
(let ((after (plist-get rule :after)))
;; Mark transitions to DST by making offset a float.
(push (if (plist-get rule :dst) (float after) after) transitions))))
;; No transition rules. Take the offset after the last historical transition.
(let ((k (length all-year-transitions)))
(while (null transitions)
(let ((historic-transitions (aref all-year-transitions (setf k (1- k)))))
(when historic-transitions
(setf transitions `(,(car (last historic-transitions))))))))))
(aset all-year-transitions year-offset (nreverse transitions))))
;; There is horribly unreadable level of backquoting/unquoting inside this macro...
(defmacro datetime--parser-computation (pattern value-name validating min max &rest arguments)
(let ((computations (make-symbol "$computations"))
(computation (make-symbol "$computation"))
(range-validated (make-symbol "$range-validated"))