Source file netdate.ml
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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
open Printf
let get_localzone_at t =
let gt = Unix.gmtime t
and lt = Unix.localtime t in
let min_diff = (lt.Unix.tm_hour * 60 + lt.Unix.tm_min) -
(gt.Unix.tm_hour * 60 + gt.Unix.tm_min) in
let day_diff = lt.Unix.tm_yday - gt.Unix.tm_yday in
if day_diff < -1 || day_diff = 1 then
min_diff + 24*60
else if day_diff > 1 || day_diff = -1 then
min_diff - 24*60
else
min_diff
;;
let get_localzone() = get_localzone_at (Unix.time()) ;;
let localzone_nodst =
min (get_localzone_at 0.0) (get_localzone_at 15638400.0) ;;
let localzone = get_localzone() ;;
type localization =
{ full_day_names : string array;
abbr_day_names : string array;
parsed_day_names : string list array;
full_month_names : string array;
abbr_month_names : string array;
parsed_month_names : string list array;
timezone_names : (string * int * bool) list;
am_particle : string;
pm_particle : string;
d_format : string;
t_format : string;
d_t_format : string;
t_format_ampm : string;
char_encoding : string;
}
let posix_l9n =
{ full_day_names =
[| "Sunday"; "Monday"; "Tuesday"; "Wednesday"; "Thursday"; "Friday";
"Saturday"
|];
abbr_day_names =
[| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] ;
parsed_day_names =
[| [ "sunday"; "sun" ];
[ "monday"; "mon" ];
[ "tuesday"; "tue"; "tues" ];
[ "wednesday"; "wed"; "wednes" ];
[ "thursday"; "thu"; "thur"; "thurs" ];
[ "friday"; "fri" ];
[ "saturday"; "sat" ];
|];
full_month_names =
[| "January"; "February"; "March"; "April"; "May"; "June";
"July"; "August"; "September"; "October"; "November"; "December"
|];
abbr_month_names =
[| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
"Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec"
|];
parsed_month_names =
[| [ "january"; "jan" ];
[ "february"; "feb" ];
[ "march"; "mar" ];
[ "april"; "apr" ];
[ "may"; "may" ];
[ "june"; "jun" ];
[ "july"; "jul" ];
[ "august"; "aug" ];
[ "september"; "sep"; "sept" ];
[ "october"; "oct" ];
[ "november"; "nov" ];
[ "december"; "dec" ]
|];
timezone_names =
( let z n = (n/100) * 60 in
[ "gmt", z 0000, false;
"ut", z 0000, false;
"utc", z 0000, false;
"wet", z 0000, false;
"z", z 0000, false;
"bst", z 0100, true;
"cet", z 0100, false;
"cest", z 0200, true;
"met", z 0100, false;
"mewt", z 0100, false;
"mest", z 0200, true;
"mesz", z 0200, true;
"swt", z 0100, false;
"sst", z 0200, true;
"fwt", z 0100, false;
"fst", z 0100, true;
"eet", z 0200, false;
"bt", z 0300, false;
"zp4", z 0400, false;
"zp5", z 0500, false;
"zp6", z 0600, false;
"wast", z 0700, false;
"wadt", z 0800, true;
"cct", z 0800, false;
"jst", z 0900, false;
"east", z 1000, false;
"eadt", z 1100, true;
"gst", z 1000, false;
"nzt", z 1200, false;
"nzst", z 1200, false;
"nzdt", z 1300, true;
"idle", z 1200, false;
"idlw", z(-1200), false;
"nt", z(-1100), false;
"hst", z(-1000), false;
"hdt", z(-0900), true;
"cat", z(-1000), false;
"ahst", z(-1000), false;
"ydt", z(-0800), true;
"yst", z(-0900), false;
"pst", z(-0800), false;
"pdt", z(-0700), true;
"mst", z(-0700), false;
"mdt", z(-0600), true;
"cst", z(-0600), false;
"cdt", z(-0500), true;
"est", z(-0500), false;
"edt", z(-0400), true;
"ast", z(-0400), false;
"adt", z(-0300), true;
"wat", z(-0100), false;
"at", z(-0200), false;
]);
am_particle = "am";
pm_particle = "pm";
d_format = "%m/%d/%y";
t_format = "%H:%M:%S";
d_t_format = "%a %b %e %H:%M:%S %Y";
t_format_ampm = "%I:%M:%S %p";
char_encoding = "US-ASCII";
}
let l9n_from_locale name =
let open Netsys_posix in
try
let info = Netsys_posix.query_langinfo name in
let enc = Netconversion.encoding_of_string info.nl_CODESET in
let to_lower = Netconversion.ustring_to_lower enc in
{ full_day_names =
[| info.nl_DAY_1; info.nl_DAY_2; info.nl_DAY_3; info.nl_DAY_4;
info.nl_DAY_5; info.nl_DAY_6; info.nl_DAY_7;
|];
abbr_day_names =
[| info.nl_ABDAY_1; info.nl_ABDAY_2; info.nl_ABDAY_3; info.nl_ABDAY_4;
info.nl_ABDAY_5; info.nl_ABDAY_6; info.nl_ABDAY_7;
|];
parsed_day_names =
[| [ to_lower info.nl_DAY_1; to_lower info.nl_ABDAY_1 ];
[ to_lower info.nl_DAY_2; to_lower info.nl_ABDAY_2 ];
[ to_lower info.nl_DAY_3; to_lower info.nl_ABDAY_3 ];
[ to_lower info.nl_DAY_4; to_lower info.nl_ABDAY_4 ];
[ to_lower info.nl_DAY_5; to_lower info.nl_ABDAY_5 ];
[ to_lower info.nl_DAY_6; to_lower info.nl_ABDAY_6 ];
[ to_lower info.nl_DAY_7; to_lower info.nl_ABDAY_7 ];
|];
full_month_names =
[| info.nl_MON_1; info.nl_MON_2; info.nl_MON_3;
info.nl_MON_4; info.nl_MON_5; info.nl_MON_6;
info.nl_MON_7; info.nl_MON_8; info.nl_MON_9;
info.nl_MON_10; info.nl_MON_11; info.nl_MON_12;
|];
abbr_month_names =
[| info.nl_ABMON_1; info.nl_ABMON_2; info.nl_ABMON_3;
info.nl_ABMON_4; info.nl_ABMON_5; info.nl_ABMON_6;
info.nl_ABMON_7; info.nl_ABMON_8; info.nl_ABMON_9;
info.nl_ABMON_10; info.nl_ABMON_11; info.nl_ABMON_12;
|];
parsed_month_names =
[| [ to_lower info.nl_MON_1; to_lower info.nl_ABMON_1 ];
[ to_lower info.nl_MON_2; to_lower info.nl_ABMON_2 ];
[ to_lower info.nl_MON_3; to_lower info.nl_ABMON_3 ];
[ to_lower info.nl_MON_4; to_lower info.nl_ABMON_4 ];
[ to_lower info.nl_MON_5; to_lower info.nl_ABMON_5 ];
[ to_lower info.nl_MON_6; to_lower info.nl_ABMON_6 ];
[ to_lower info.nl_MON_7; to_lower info.nl_ABMON_7 ];
[ to_lower info.nl_MON_8; to_lower info.nl_ABMON_8 ];
[ to_lower info.nl_MON_9; to_lower info.nl_ABMON_9 ];
[ to_lower info.nl_MON_10; to_lower info.nl_ABMON_10 ];
[ to_lower info.nl_MON_11; to_lower info.nl_ABMON_11 ];
[ to_lower info.nl_MON_12; to_lower info.nl_ABMON_12 ];
|];
timezone_names = posix_l9n.timezone_names;
am_particle = to_lower info.nl_AM_STR;
pm_particle = to_lower info.nl_PM_STR;
d_format = info.nl_D_FMT;
t_format = info.nl_T_FMT;
d_t_format = info.nl_D_T_FMT;
t_format_ampm = info.nl_T_FMT_AMPM;
char_encoding = info.nl_CODESET
}
with
| _ -> posix_l9n
type token =
| Number of int * int
| Day of int
| Month of int
| Meridian of bool
| Zone of int * bool
| Dst
| Plus
| Minus
| Comma
| Colon
| Slash
| Dot
| Time
| Invalid
;;
type compiled_localization =
{ l9n : localization;
tokens : (string, token) Hashtbl.t
}
let compile_l9n l9n =
let tokens = Hashtbl.create 53 in
let add_token (name, value) =
Hashtbl.replace tokens name value in
List.iter
(fun (name,zone,isdst) ->
add_token (name, (Zone(zone,isdst)))
)
l9n.timezone_names;
add_token (l9n.am_particle, Meridian false);
add_token (l9n.pm_particle, Meridian true);
Array.iteri
(fun i names ->
List.iter
(fun name ->
add_token (name, Month(i+1))
)
names
)
l9n.parsed_month_names;
Array.iteri
(fun i names ->
List.iter
(fun name ->
add_token (name, Day i)
)
names
)
l9n.parsed_day_names;
add_token ("t", Time);
add_token ("dst", Dst);
{ l9n = l9n;
tokens = tokens
}
let c_posix_l9n = compile_l9n posix_l9n
let rec ten_power n =
if n<=0 then 1 else 10 * (ten_power (n-1))
let to_lower cl9n =
try
let enc = Netconversion.encoding_of_string cl9n.l9n.char_encoding in
fun s ->
Netconversion.ustring_to_lower enc s
with _ -> (fun s -> s)
let to_upper cl9n =
try
let enc = Netconversion.encoding_of_string cl9n.l9n.char_encoding in
fun s ->
Netconversion.ustring_to_upper enc s
with _ -> (fun s -> s)
let stream_cons prefix stream =
let prefix = ref prefix in
Stream.from
(fun _ ->
match !prefix with
| [] -> ( try Some(Stream.next stream) with Stream.Failure -> None )
| p :: prefix' -> prefix := prefix'; Some p
)
let stream_njunk n stream =
for k = 1 to n do Stream.junk stream done
let tokens_of_string cl9n str =
let to_lower = to_lower cl9n in
let rec scan_any stream =
match Stream.peek stream with
| Some('0'..'9' as c) ->
Stream.junk stream;
scan_number (1, int_of_char c - 48) stream
| Some(('a'..'z' | 'A'..'Z' | '\128'..'\255') as c) ->
Stream.junk stream;
let b = Buffer.create 16 in
Buffer.add_char b c;
scan_word b stream
| Some '(' ->
Stream.junk stream; scan_comment 0 stream
| Some (' ' | '\t') ->
Stream.junk stream; scan_any stream
| Some '+' ->
Stream.junk stream; stream_cons [ Plus ] (scan_any stream)
| Some '-' ->
Stream.junk stream; stream_cons [ Minus ] (scan_any stream)
| Some ':' ->
Stream.junk stream; stream_cons [ Colon ] (scan_any stream)
| Some ',' ->
Stream.junk stream; stream_cons [ Comma ] (scan_any stream)
| Some '/' ->
Stream.junk stream; stream_cons [ Slash ] (scan_any stream)
| Some '.' ->
Stream.junk stream; stream_cons [ Dot ] (scan_any stream)
| Some _ ->
Stream.junk stream; stream_cons [ Invalid ] (scan_any stream)
| None ->
Stream.of_list []
and scan_number (l,a) stream =
match Stream.peek stream with
| Some ( ('0'..'9') as c ) ->
Stream.junk stream;
if l = 9 then failwith "Netdate: number too large";
scan_number (l+1, a * 10 + (int_of_char c - 48)) stream
| _ ->
stream_cons [ Number(l,a) ] (scan_any stream)
and scan_word b stream =
match Stream.peek stream with
| Some(('a'..'z' | 'A'..'Z' | '\128'..'\255') as c) ->
Stream.junk stream;
Buffer.add_char b c;
scan_word b stream
| Some '.' ->
Stream.junk stream;
scan_word b stream
| _ ->
let s = to_lower (Buffer.contents b) in
let tok =
try Hashtbl.find cl9n.tokens s with Not_found -> Invalid in
stream_cons [ tok ] (scan_any stream)
and scan_comment n stream =
mat Stream.peek stream with
| Some ')' ->
Stream.junk stream;
if n=0 then scan_any stream
else scan_comment (n-1) stream
| Some '(' ->
Stream.junk stream;
scan_comment (n+1) stream
| Some _ ->
Stream.junk stream;
scan_comment n stream
| None ->
raise Stream.Failure in
scan_any (Stream.of_string str)
;;
type t = {
year : int;
month : int;
day : int; 1..31 *)
hour : int;
minute : int;
second : int;
nanos : int;
zone : int;
week_day : int
} ;;
let parse ?(localzone=false)
?zone:dzone
?(l9n = c_posix_l9n)
str =
let invalid() = invalid_arg "Netdate.parse" in
let tokens = tokens_of_string l9n str in
let hour = ref None
and minute = ref None
and second = ref None
and nanos = ref None
and zone = ref None
and week_day = ref None
and day = ref None
and month = ref None
and year = ref None in
let add_data ?h ?m ?s ?ns ?mdn ?tz ?wd ?md ?mo ?y ?y2 () =
let may_store r = function
| None -> ()
| v when !r = None -> r := v
| _ -> invalid() in
let h = match h with
| None -> None
| Some h -> match mdn with
| None when h >= 0 && h <= 23 -> Some h
| Some false when h > 0 && h <= 11 -> Some h
| Some false when h = 12 -> Some 0
| Some true when h > 0 && h <= 11 -> Some (h + 12)
| Some true when h = 12 -> Some 12
| _ -> invalid() in
let y = match y with
| None ->
( match y2 with
| Some y -> if y < 69 then Some (2000 + y) else Some(1900 + y)
| None -> None
)
| Some y -> Some y in
may_store hour h;
may_store minute m;
may_store second s;
may_store nanos ns;
may_store zone tz;
may_store week_day wd;
may_store day md;
may_store month mo;
may_store year y in
let rec scan_gen stream =
match Stream.peek stream with
| Some(Number(l,n)) ->
Stream.junk stream;
scan_number (l,n) stream
| Some Time ->
Stream.junk stream;
let tok1 = Stream.next stream in
let tok2 = Stream.next stream in
let tok3 = Stream.next stream in
( match tok1,tok2,tok3 with
| Number((0|1|2),n), Colon, Number((0|1|2),m) ->
scan_hour n m stream
| _ ->
invalid()
)
| Some(Zone(tz,isdst)) ->
Stream.junk stream;
let dst = scan_dst stream in
let eff_tz =
if isdst then tz else
match dst with
| Some true -> tz + 60
| _ -> tz in
add_data ~tz:eff_tz ();
scan_gen stream
| Some(Day wd) ->
Stream.junk stream;
let _ = scan_opt_coma stream in
add_data ~wd ();
scan_gen stream
| Some(Month mo) ->
Stream.junk stream;
let tok1 = Stream.next stream in
( match tok1 with
| Number(lmd,md) ->
scan_date_m mo (lmd,md) stream
| _ ->
invalid()
)
| Some _ ->
Stream.junk stream;
invalid()
| None ->
()
and scan_number (l,n) stream =
match Stream.peek stream with
| Some(Meridian mdn) ->
Stream.junk stream;
add_data ~h:n ~mdn ();
scan_gen stream
| Some Colon ->
Stream.junk stream;
let tok1 = Stream.next stream in
( match tok1 with
| Number((0|1|2),m) ->
if l <= 2 then
scan_hour n m stream
else
invalid()
| _ -> invalid()
)
| Some Slash ->
Stream.junk stream;
let tok1 = Stream.next stream in
( match tok1 with
| Number((0|1|2),m) -> scan_date_s (l,n) m stream
| _ -> invalid()
)
| Some Dot ->
Stream.junk stream;
let tok1 = Stream.next stream in
( match tok1 with
| Number((0|1|2),m) ->
if l<=2 then
scan_date_dot n m stream
else invalid()
| _ -> invalid()
)
| Some Minus ->
Stream.junk stream;
scan_date_d (l,n) stream
| Some (Month mo) ->
Stream.junk stream;
add_data ~md:n ~mo ();
scan_gen stream
| _ ->
if l=4 then
add_data ~y:n ()
else
invalid();
scan_gen stream
and scan_hour h m stream =
match Stream.peek stream with
| Some Colon ->
Stream.junk stream;
let tok1 = Stream.next stream in
( match tok1 with
| Number(_,s) -> scan_hour_second_frac h m s stream
| _ -> invalid()
)
| _ ->
let tz_opt = scan_tz_opt stream in
( match tz_opt with
| Some tz ->
add_data ~h ~m ~tz ();
scan_gen stream
| None ->
let mdn = scan_opt_meridian stream in
add_data ~h ~m ?mdn ();
scan_gen stream
)
and scan_tz_opt stream =
match Stream.peek stream with
| Some Plus -> Stream.junk stream; Some(scan_tz_details 1 stream)
| Some Minus -> Stream.junk stream; Some(scan_tz_details (-1) stream)
| _ -> None
and scan_tz_details sign stream =
match Stream.peek stream with
| Some(Number(l,tz)) when l=4 ->
Stream.junk stream;
sign * ((tz/100) * 60 + (tz mod 100))
| Some(Number(l,tz)) when l<=2 ->
Stream.junk stream;
scan_tz_details2 sign tz stream
| _ ->
invalid()
and scan_tz_details2 sign tz1 stream =
match Stream.npeek 2 stream with
| [ Colon; Number((0|1|2),tz2) ] ->
stream_njunk 2 stream;
sign * (60 * tz1 + tz2)
| _ ->
sign * 60 * tz1
and scan_hour_second_frac h m s stream =
match Stream.npeek 2 stream with
| [ Dot; Number(l,f) ] ->
stream_njunk 2 stream;
let ns = f * ten_power (9-l) in
scan_hour_second h m s ns stream
| _ ->
scan_hour_second h m s 0 stream
and scan_hour_second h m s ns stream =
match scan_tz_opt stream with
| Some tz ->
add_data ~h ~m ~s ~ns ~tz ();
scan_gen stream
| None ->
let mdn = scan_opt_meridian stream in
add_data ~h ~m ~s ~ns ?mdn ();
scan_gen stream
and scan_date_s (ln,n) m stream =
match Stream.npeek 2 stream with
| [ Slash; Number(lp,p) ] ->
stream_njunk 2 stream;
if ln = 4
then add_data ~y:n ~mo:m ~md:p ()
else
if lp = 4 then
add_data ~y:p ~mo:n ~md:m ()
else
if lp = 2 then
add_data ~y2:p ~mo:n ~md:m ()
else
invalid();
scan_gen stream
| _ ->
add_data ~mo:n ~md:m ();
scan_gen stream
and scan_date_dot n m stream =
match Stream.npeek 2 stream with
| [ Dot; Number(l,p) ] ->
stream_njunk 2 stream;
if l=4 then
add_data ~md:n ~mo:m ~y: p ()
else if l=2 then
add_data ~md:n ~mo:m ~y2: p ()
else invalid();
scan_gen stream
| _ ->
add_data ~md:n ~mo:m ();
scan_gen stream
and scan_date_d (ln,n) stream =
match Stream.npeek 3 stream with
| [ Number(_,mo); Minus; Number(_,md) ] ->
stream_njunk 3 stream;
if ln=4 then
add_data ~y:n ~mo ~md ()
else
if ln=2 then
add_data ~y2:n ~mo ~md ()
else invalid();
scan_gen stream
| [ Month mo; Minus; Number(ly,y) ] ->
stream_njunk 3 stream;
if ly=4 then
add_data ~y ~mo ~md:n ()
else if ly=2 then
add_data ~y2:y ~mo ~md:n ()
else invalid();
scan_gen stream
| _ ->
invalid()
and scan_date_m mo (lmd,md) stream =
match Stream.npeek 2 stream with
| [ Comma; Number(4,y) ] ->
stream_njunk 2 stream;
add_data ~y ~mo ~md ();
scan_gen stream
| _ ->
add_data ~mo ~md ();
scan_gen stream
and scan_dst stream =
match Stream.peek stream with
| Some Dst -> Stream.junk stream; Some true
| _ -> None
and scan_opt_coma stream =
match Stream.peek stream with
| Some Comma -> Stream.junk stream; ()
| _ -> ()
and scan_opt_meridian stream =
match Stream.peek stream with
| Some (Meridian mdn) -> Stream.junk stream; Some mdn
| _ -> None
in
(try scan_gen tokens;
with
| Stream.Error _ -> invalid()
| Stream.Failure -> invalid()
);
let may_get r =
match !r with
| None -> invalid()
| Some r -> r in
let get_default d r =
match !r with
| None -> d
| Some r -> r in
let month = may_get month in
if month < 1 || month > 12 then invalid();
let date =
{
year = may_get year;
month = month;
day = may_get day;
hour = get_default 0 hour;
minute = get_default 0 minute;
second = get_default 0 second;
nanos = get_default 0 nanos;
zone = get_default (match dzone with None -> 0 | Some z -> z) zone;
week_day = get_default (-1) week_day
} in
if !zone=None && dzone=None && localzone then
let tm =
{ Unix.tm_year = date.year - 1900;
tm_mon = date.month - 1;
tm_mday = date.day;
tm_hour = date.hour;
tm_min = date.minute;
tm_sec = date.second;
tm_wday = 0;
tm_yday = 0;
tm_isdst = false
} in
let (_,tm) = Unix.mktime tm in
let zone = localzone_nodst + (if tm.Unix.tm_isdst then 60 else 0) in
{ date with zone = zone }
else
date
;;
let months_start =
[| 0; 31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334 |]
;;
let is_leap year =
year mod 4 = 0 && (year mod 100 <> 0 || year mod 400 = 0)
;;
let since_epoch date =
if date.month < 1 || date.month > 12 then invalid_arg "Netdate.since_epoch";
let in_day = float_of_int
(date.hour * 3600 + (date.minute - date.zone) * 60 + date.second) in
let days = date.year * 365 + (date.year + 3) / 4 - (date.year + 99) / 100 +
(date.year + 399) / 400 - 719528 in
let days = days + months_start.(date.month - 1) + date.day - 1 in
let days =
if is_leap date.year && date.month > 2
then days + 1 else days in
86400.0 *. (float_of_int days) +. in_day
;;
let since_epoch_timespec date =
(since_epoch date, date.nanos)
let since_epoch_approx date =
since_epoch date +. (float date.nanos) *. 1E-9
let parse_epoch ?l9n ?localzone ?zone str =
since_epoch (parse ?l9n ?localzone ?zone str) ;;
let parse_epoch_timespec ?l9n ?localzone ?zone str =
since_epoch_timespec (parse ?l9n ?localzone ?zone str) ;;
let parse_epoch_approx ?l9n ?localzone ?zone str =
since_epoch_approx (parse ?l9n ?localzone ?zone str) ;;
let billion = 1_000_000_000
let create ?(localzone=false)
?zone
?(nanos=0)
time =
let t0 = floor time in
let ns0 = truncate ( (time -. t0) *. 1E9 ) in
let ns1 = if ns0 >= billion - nanos then (nanos-billion)+ns0 else nanos+ns0 in
let t1 = if ns0 >= billion - nanos then t0 +. 1.0 else t0 in
let zone =
match zone with
| Some z -> z
| None ->
if localzone then
get_localzone_at t1
else
0 in
let t2 = t1 +. (float_of_int (zone * 60)) in
let days = floor (t2 /. 86400.0) in
let in_day = int_of_float (t2 -. 86400.0 *. days) in
let days = days +. 719528.0 in
let n400 = floor (days /. 146097.0) in
let r400 = int_of_float (days -. n400 *. 146097.0) in
let n400 = int_of_float n400 in
let (n100, r100) =
if r400 < 36525 then (0, r400)
else ((r400 - 1) / 36524, (r400 - 1) mod 36524) in
let (n4, r4) =
if n100 = 0 then (r100 / 1461, r100 mod 1461)
else if r100 < 1460 then (0, r100)
else ((r100 + 1) / 1461, (r100 + 1) mod 1461) in
let (n1, r1) =
if n4 = 0 && n100 <> 0 then (r4 / 365, r4 mod 365)
else if r4 < 366 then (0, r4)
else ((r4 - 1) / 365, (r4 - 1) mod 365) in
let year = 400 * n400 + 100 * n100 + 4 * n4 + n1 in
let month_start =
if is_leap year then
fun m -> months_start.(m) + (if m > 1 then 1 else 0)
else
fun m -> months_start.(m) in
let month_guess = r1 / 29 in
let month =
if month_guess = 12 then 11
else if r1 >= month_start month_guess then month_guess
else month_guess - 1 in
let second = in_day mod 60
and minutes = in_day / 60 in
let minute = minutes mod 60
and hour = minutes / 60 in
{
year = year;
month = month + 1;
day = r1 - (month_start month) + 1;
hour = hour;
minute = minute;
second = second;
nanos = ns1;
zone = zone;
week_day = int_of_float (mod_float (days +. 6.0) 7.0)
}
;;
let week_day date =
if date.week_day = (-1) then
let t1 = since_epoch date in
let t2 = t1 +. (float_of_int (date.zone * 60)) in
let days = floor (t2 /. 86400.0) in
int_of_float (mod_float (days +. 4.0) 7.0)
else
date.week_day
;;
let year_day date =
let is_leap_year = is_leap date.year in
months_start.(date.month - 1) +
(if date.month >= 3 && is_leap_year then 1 else 0) +
date.day - 1
;;
let rec iso8601_week_pair date =
let ( % ) a b = if a >= 0 then a mod b else a mod b + b in
let d_wday = week_day date in
let d_yday = year_day date in
let wday_jan_1 =
(d_wday - d_yday) % 7 in
let shift =
if wday_jan_1 = 1 then 7 else (wday_jan_1 - 1) % 7 in
let offset =
if wday_jan_1 >= 2 && wday_jan_1 <= 4 then 1 else 0 in
let week = (d_yday + shift) / 7 + offset in
if week = 0 then
replace with last week of last year *)
let date' =
{ date with
year = date.year - 1;
month = 12;
day = 31;
week_day = (-1)
} in
iso8601_week_pair date'
else
if week = 53 then
let date' =
{ date with
month = 12;
day = 31;
week_day = (-1)
} in
let d_wday' = week_day date' in
if d_wday' >= 4 || d_wday' = 0 then
(53, date.year)
else
(1, date.year+1)
else
(week, date.year)
let rec format_to ?(l9n=c_posix_l9n) out_ch ~fmt date =
let to_lower = to_lower l9n in
let to_upper = to_upper l9n in
let add_char c = out_ch#output_char c
and add_string s = out_ch#output_string s in
let fail () = invalid_arg "Netdate.format_to" in
let add_digits w b n =
if n >= b * 10 then fail ();
let rec aux b n =
add_char (char_of_int (48 + n / b));
if b >= 10 then aux (b / 10) (n mod b) in
if w then (
let rec aux_spaces b =
if n >= b || b < 10 then (
aux b n
) else (
add_char ' ';
aux_spaces (b / 10)
) in
aux_spaces b
) else (
aux b n
) in
let wd_lz = lazy (week_day date) in
let wd () = Lazy.force wd_lz in
let yd_lz = lazy (year_day date) in
let yd () = Lazy.force yd_lz in
let wp_lz = lazy (iso8601_week_pair date) in
let wp() = Lazy.force wp_lz in
let rec do_format ?(have_colon=false) ?(precision=0) = function
| 'a' -> add_string l9n.l9n.abbr_day_names.( wd() )
| 'A' -> add_string l9n.l9n.full_day_names.( wd() )
| 'b' | 'h' -> add_string l9n.l9n.abbr_month_names.(date.month - 1)
| 'B' -> add_string l9n.l9n.full_month_names.(date.month - 1)
| 'C' -> add_digits false 10 (date.year / 100)
| 'd' -> add_digits false 10 date.day
| 'e' -> add_digits true 10 date.day
| 'g' -> add_digits false 10 (snd(wp()) mod 10)
| 'G' -> add_digits false 1000 (snd(wp()))
| 'H' -> add_digits false 10 date.hour
| 'I' -> add_digits false 10 (match date.hour mod 12 with 0 -> 12 | d -> d)
| 'j' -> add_digits false 100 (yd () + 1)
| 'k' -> add_digits true 10 date.hour
| 'l' -> add_digits true 10 (match date.hour mod 12 with 0 -> 12 | d -> d)
| 'm' -> add_digits false 10 date.month
| 'M' -> add_digits false 10 date.minute
| 'n' -> add_char '\n'
| 'p' -> add_string (if date.hour >= 12 then
to_upper l9n.l9n.pm_particle
else
to_upper l9n.l9n.am_particle
)
| 'P' -> add_string (if date.hour >= 12 then
to_lower l9n.l9n.pm_particle
else
to_lower l9n.l9n.am_particle)
| 's' -> add_string (string_of_float (since_epoch date))
| 'S' -> add_digits false 10 date.second;
if precision > 0 then (
add_char '.';
add_string
(sprintf
"%0*d"
precision (date.nanos / ten_power(9-precision)))
)
| 't' -> add_char '\t'
| 'u' -> add_digits false 1 (match wd () with 0 -> 7 | n -> n)
| 'y' -> add_digits false 10 (date.year mod 100)
| 'Y' -> add_digits false 1000 date.year
| 'z' | 'Z' ->
let (s, z) =
if date.zone >= 0 then ('+', date.zone)
else ('-', -date.zone) in
add_char s;
add_digits false 10 (z / 60);
if have_colon then add_char ':';
add_digits false 10 (z mod 60)
| 'U' -> add_digits false 10 ((yd () - wd () + 7) / 7)
| 'V' -> add_digits false 10 (fst(wp()))
| 'W' -> let wdm = if wd() = 0 then 6 else wd() - 1 in
add_digits false 10 ((yd () - wdm + 7) / 7)
| 'w' -> add_digits false 1 (wd ())
| '%' -> add_char '%'
| 'c' -> format_to ~l9n out_ch ~fmt:l9n.l9n.d_t_format date
| 'F' -> do_format 'Y'; add_char '-'; do_format 'm'; add_char '-';
do_format 'd'
| 'x' -> format_to ~l9n out_ch ~fmt:l9n.l9n.d_format date
| 'X' -> format_to ~l9n out_ch ~fmt:l9n.l9n.t_format date
| 'D' ->
do_format 'm';
add_char '/';
do_format 'd';
add_char '/';
do_format 'y'
| 'r' -> format_to ~l9n out_ch ~fmt:l9n.l9n.t_format_ampm date
| 'R' ->
do_format 'H';
add_char ':';
do_format 'M'
| 'T' ->
do_format 'R';
add_char ':';
do_format 'S'
| _ -> fail () in
let l_fmt = String.length fmt in
let rec aux i =
if i = l_fmt then ()
else match fmt.[i] with
| '%' when i = l_fmt - 1 -> fail ()
| '%' ->
if fmt.[i + 1] = ':' then (
if i+2 >= l_fmt then fail();
do_format ~have_colon:true fmt.[i + 2];
aux (i + 3)
)
else (
if fmt.[i + 1] = '.' then (
if i+3 >= l_fmt then fail();
match fmt.[i+2] with
| '0'..'9' as c ->
let d = Char.code c - 48 in
do_format ~precision:d fmt.[i + 3];
aux (i + 4)
| _ -> fail()
)
else (
do_format fmt.[i + 1];
aux (i + 2)
)
)
| c -> add_char c; aux (i + 1) in
try aux 0
with _ -> fail ()
;;
let format ?l9n ~fmt date =
let b = Buffer.create (String.length fmt * 2) in
format_to ?l9n (new Netchannels.output_buffer b) ~fmt date;
Buffer.contents b
;;
let mk_date ?localzone ?zone ?nanos ~fmt t =
format ~fmt (create ?localzone ?zone ?nanos t)
let mk_mail_date ?localzone ?zone t =
format "%a, %d %b %Y %H:%M:%S %z" (create ?localzone ?zone t)
;;
let mk_usenet_date ?localzone ?zone t =
format "%A, %d-%b-%y %H:%M:%S %z" (create ?localzone ?zone t)
;;
let mk_internet_date ?localzone ?zone ?(digits=0) t =
if digits < 0 || digits > 9 then
failwith "Netdate.mk_internet_date: digits out of bounds";
let fmt =
sprintf
"%%Y-%%m-%%dT%%H:%%M:%%.%dS%%:z"
digits in
format ~fmt (create ?localzone ?zone t)
;;