-
-
Notifications
You must be signed in to change notification settings - Fork 666
/
Copy pathevalStdLib.ml
3847 lines (3437 loc) · 109 KB
/
evalStdLib.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
(*
The Haxe Compiler
Copyright (C) 2005-2019 Haxe Foundation
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 2
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, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*)
open Extlib_leftovers
open Globals
open EvalValue
open EvalEncode
open EvalDecode
open EvalContext
open EvalExceptions
open EvalPrinting
open EvalMisc
open EvalField
open EvalHash
open EvalString
open EvalThread
let catch_unix_error f arg =
try
f arg
with Unix.Unix_error(err,cmd,args) ->
exc_string (Printf.sprintf "%s(%s, %s)" (Unix.error_message err) cmd args)
let ptmap_keys h =
IntMap.fold (fun k _ acc -> k :: acc) h []
let hashtbl_keys h =
Hashtbl.fold (fun k _ acc -> k :: acc) h []
module StdEvalVector = struct
let this this = match this with
| VVector vv -> vv
| v -> unexpected_value v "vector"
let blit = vifun4 (fun vthis srcPos dest destPos len ->
Array.blit (this vthis) (decode_int srcPos) (decode_vector dest) (decode_int destPos) (decode_int len);
vnull
)
let toArray = vifun0 (fun vthis ->
let copy = Array.copy (this vthis) in
encode_array_instance (EvalArray.create copy)
)
let fromArrayCopy = vfun1 (fun arr ->
let a = decode_varray arr in
encode_vector_instance (Array.sub a.avalues 0 a.alength)
)
let copy = vifun0 (fun vthis ->
encode_vector_instance (Array.copy (this vthis))
)
let join = vifun1 (fun vthis sep ->
let this = this vthis in
let sep = decode_vstring sep in
vstring ((EvalArray.array_join this (s_value 0) sep))
)
let map = vifun1 (fun vthis f ->
let this = this vthis in
let a = match f with
| VFunction(f,_) ->
Array.map (fun v -> f [v]) this
| VFieldClosure(v1,f) ->
Array.map (fun v -> f (v1 :: [v])) this
| _ -> exc_string ("Cannot call " ^ (value_string f))
in
encode_vector_instance a
)
end
module StdArray = struct
let this this = match this with
| VArray va -> va
| v -> unexpected_value v "array"
let concat = vifun1 (fun vthis a2 ->
let a2 = decode_varray a2 in
encode_array_instance (EvalArray.concat (this vthis) a2)
)
let copy = vifun0 (fun vthis ->
encode_array_instance (EvalArray.copy (this vthis))
)
let filter = vifun1 (fun vthis f ->
let this = this vthis in
let a = EvalArray.filter this (fun v -> is_true (call_value_on vthis f [v])) in
encode_array_instance a
)
let indexOf = vifun2 (fun vthis x fromIndex ->
let this = this vthis in
let fromIndex = default_int fromIndex 0 in
let fromIndex = if fromIndex < 0 then this.alength + fromIndex else fromIndex in
let fromIndex = if fromIndex < 0 then 0 else fromIndex in
vint (EvalArray.indexOf this equals x fromIndex)
)
let insert = vifun2 (fun vthis pos x ->
let this = this vthis in
let pos = decode_int pos in
if pos >= this.alength then begin
ignore(EvalArray.push this x);
end else begin
let pos = if pos < 0 then this.alength + pos else pos in
let pos = if pos < 0 then 0 else pos in
EvalArray.insert this pos x
end;
vnull
)
let iterator = vifun0 (fun vthis ->
let this = this vthis in
let f_has_next,f_next = EvalArray.iterator this in
encode_obj [
key_hasNext,vifun0 (fun _ -> vbool (f_has_next()));
key_next,vifun0 (fun _ -> f_next())
]
)
let join = vifun1 (fun vthis sep ->
let sep = decode_vstring sep in
let s = EvalArray.join (this vthis) (s_value 0) sep in
vstring s
)
let keyValueIterator = vifun0 (fun vthis ->
let ctx = get_ctx() in
let path = key_haxe_iterators_array_key_value_iterator in
let vit = encode_instance path in
let fnew = get_instance_constructor ctx path null_pos in
ignore(call_value_on vit (Lazy.force fnew) [vthis]);
vit
)
let lastIndexOf = vifun2 (fun vthis x fromIndex ->
let this = this vthis in
let last = this.alength - 1 in
let fromIndex = default_int fromIndex last in
let fromIndex = if fromIndex < 0 then this.alength + fromIndex else fromIndex in
let fromIndex = if fromIndex < 0 then 0 else if fromIndex > last then last else fromIndex in
vint (EvalArray.lastIndexOf this equals x fromIndex)
)
let map = vifun1 (fun vthis f ->
let this = this vthis in
let a = match f with
| VFunction(f,_) ->
EvalArray.map this (fun v -> f [v])
| VFieldClosure(v1,f) ->
EvalArray.map this (fun v -> f (v1 :: [v]))
| _ -> exc_string ("Cannot call " ^ (value_string f))
in
encode_array_instance a
)
let pop = vifun0 (fun vthis ->
let this = this vthis in
EvalArray.pop this
)
let push = vifun1 (fun vthis v ->
let this = this vthis in
vint32 (Int32.of_int (EvalArray.push this v))
)
let remove = vifun1 (fun vthis x ->
let this = this vthis in
vbool (EvalArray.remove this equals x)
)
let contains = vifun1 (fun vthis x ->
let this = this vthis in
vbool (EvalArray.contains this equals x)
)
let reverse = vifun0 (fun vthis ->
let this = this vthis in
EvalArray.reverse this;
vnull
)
let shift = vifun0 (fun vthis ->
let this = this vthis in
EvalArray.shift this
)
let slice = vifun2 (fun vthis pos end' ->
let this = this vthis in
let pos = decode_int pos in
let length = this.alength in
let end' = default_int end' length in
let end' = if end' > length then length else end' in
let pos = if pos < 0 then length + pos else pos in
let end' = if end' < 0 then length + end' else end' in
let pos = if pos < 0 then 0 else pos in
let end' = if end' < 0 then 0 else end' in
encode_array_instance (EvalArray.slice this pos end')
)
let sort = vifun1 (fun vthis f ->
let this = this vthis in
EvalArray.sort this (fun a b -> decode_int (call_value_on vthis f [a;b]));
vnull
)
let splice = vifun2 (fun vthis pos len ->
let this = this vthis in
let pos = decode_int pos in
let len = decode_int len in
let length = this.alength in
if len < 0 || pos > length then
encode_array []
else begin
let pos = if pos < 0 then length + pos else pos in
let pos = if pos < 0 then 0 else pos in
let delta = length - pos in
let len = if len > delta then delta else len in
let end' = pos + len in
encode_array_instance (EvalArray.splice this pos len end')
end
)
let toString = vifun0 (fun vthis ->
vstring (s_array 0 0 (this vthis))
)
let unshift = vifun1 (fun vthis v ->
let this = this vthis in
EvalArray.unshift this v;
vnull
)
let resize = vifun1 (fun vthis len ->
let this = this vthis in
let len = decode_int len in
EvalArray.resize this len;
vnull
)
end
let outside_bounds () =
let haxe_io_Error = get_static_prototype (get_ctx()) key_haxe_io_Error null_pos in
exc (proto_field_direct haxe_io_Error key_OutsideBounds)
module StdBytes = struct
open EvalBytes
let this vthis = match vthis with
| VInstance {ikind = IBytes o} -> o
| v -> unexpected_value v "bytes"
let alloc = vfun1 (fun length ->
let length = decode_int length in
encode_bytes (Bytes.make length (Char.chr 0))
)
let encode_native v = match v with
| VEnumValue {eindex = 1} -> true (* haxe.io.Encoding.RawNative *)
| _ -> false
let blit = vifun4 (fun vthis pos src srcpos len ->
let s = this vthis in
let pos = decode_int pos in
let src = decode_bytes src in
let srcpos = decode_int srcpos in
let len = decode_int len in
(try Bytes.blit src srcpos s pos len with _ -> outside_bounds());
vnull
)
let compare = vifun1 (fun vthis other ->
let this = this vthis in
let other = decode_bytes other in
vint (Stdlib.compare this other)
)
let fastGet = vfun2 (fun b pos ->
let b = decode_bytes b in
let pos = decode_int pos in
try vint (int_of_char (Bytes.unsafe_get b pos)) with _ -> vnull
)
let fill = vifun3 (fun vthis pos len value ->
let this = this vthis in
let pos = decode_int pos in
let len = decode_int len in
let value = decode_int value in
(try Bytes.fill this pos len (char_of_int (value land 0xFF)) with _ -> outside_bounds());
vnull
)
let get = vifun1 (fun vthis pos ->
let this = this vthis in
let pos = decode_int pos in
try vint (read_byte this pos) with _ -> vnull
)
let getData = vifun0 (fun vthis -> vthis)
let getDouble = vifun1 (fun vthis pos ->
try vfloat (Int64.float_of_bits (read_i64 (this vthis) (decode_int pos))) with _ -> outside_bounds()
)
let getFloat = vifun1 (fun vthis pos ->
try vfloat (Int32.float_of_bits (read_i32 (this vthis) (decode_int pos))) with _ -> outside_bounds()
)
let getInt32 = vifun1 (fun vthis pos ->
try vint32 (read_i32 (this vthis) (decode_int pos)) with exc -> outside_bounds()
)
let getInt64 = vifun1 (fun vthis pos ->
let this = this vthis in
let pos = decode_int pos in
try
let low = read_i32 this pos in
let high = read_i32 this (pos + 4) in
EvalIntegers.encode_haxe_i64 low high;
with _ ->
outside_bounds()
)
let getString = vifun3 (fun vthis pos len encoding ->
let this = this vthis in
let pos = decode_int pos in
let len = decode_int len in
let s = try Bytes.sub this pos len with _ -> outside_bounds() in
create_unknown (Bytes.unsafe_to_string s)
)
let getUInt16 = vifun1 (fun vthis pos ->
try vint (read_ui16 (this vthis) (decode_int pos)) with _ -> outside_bounds()
)
let ofData = vfun1 (fun v -> v)
let ofString = vfun2 (fun v encoding ->
let s = decode_vstring v in
encode_bytes (Bytes.of_string s.sstring)
)
let ofHex = vfun1 (fun v ->
let s = decode_string v in
let len = String.length s in
if (len land 1) <> 0 then exc_string "Not a hex string (odd number of digits)";
let ret = (Bytes.make (len lsr 1) (Char.chr 0)) in
for i = 0 to Bytes.length ret - 1 do
let high = int_of_char s.[i * 2] in
let low = int_of_char s.[i * 2 + 1] in
let high = (high land 0xF) + ((high land 0x40) lsr 6) * 9 in
let low = (low land 0xF) + ((low land 0x40) lsr 6) * 9 in
Bytes.set ret i (char_of_int (((high lsl 4) lor low) land 0xFF));
done;
encode_bytes ret
)
let set = vifun2 (fun vthis pos v ->
let this = this vthis in
let pos = decode_int pos in
let v = decode_int v in
(try write_byte this pos v with _ -> ());
vnull;
)
let setDouble = vifun2 (fun vthis pos v ->
(try write_i64 (this vthis) (decode_int pos) (Int64.bits_of_float (num v)) with _ -> outside_bounds());
vnull
)
let setFloat = vifun2 (fun vthis pos v ->
let this = this vthis in
let pos = decode_int pos in
let v = num v in
write_i32 this pos (Int32.bits_of_float v);
vnull
)
let setInt32 = vifun2 (fun vthis pos v ->
(try write_i32 (this vthis) (decode_int pos) (decode_i32 v) with _ -> outside_bounds());
vnull;
)
let setInt64 = vifun2 (fun vthis pos v ->
let v = decode_instance v in
let pos = decode_int pos in
let high = decode_i32 (instance_field v key_high) in
let low = decode_i32 (instance_field v key_low) in
let this = this vthis in
try
write_i32 this pos low;
write_i32 this (pos + 4) high;
vnull
with _ ->
outside_bounds()
)
let setUInt16 = vifun2 (fun vthis pos v ->
(try write_ui16 (this vthis) (decode_int pos) (decode_int v land 0xFFFF) with _ -> outside_bounds());
vnull
)
let sub = vifun2 (fun vthis pos len ->
let this = this vthis in
let pos = decode_int pos in
let len = decode_int len in
let s = try Bytes.sub this pos len with _ -> outside_bounds() in
encode_bytes s
)
let toHex = vifun0 (fun vthis ->
let this = this vthis in
let chars = [|"0";"1";"2";"3";"4";"5";"6";"7";"8";"9";"a";"b";"c";"d";"e";"f"|] in
let l = Bytes.length this in
let rec loop acc i =
if i >= l then List.rev acc
else begin
let c = int_of_char (Bytes.get this i) in
loop ((chars.(c land 15)) :: ((chars.(c lsr 4))) :: acc) (i + 1)
end
in
encode_string (String.concat "" (loop [] 0))
)
let toString = vifun0 (fun vthis ->
let this = this vthis in
try
UTF8.validate (Bytes.unsafe_to_string this);
(create_unknown (Bytes.to_string this))
with UTF8.Malformed_code ->
exc_string "Invalid string"
)
end
module StdBytesBuffer = struct
let this vthis = match vthis with
| VInstance {ikind = IOutput o} -> o
| v -> unexpected_value v "output"
let get_length = vifun0 (fun vthis ->
let this = this vthis in
vint (Buffer.length this)
)
let add_char this i =
Buffer.add_char this (Char.unsafe_chr i)
let add_i32 this v =
let base = Int32.to_int v in
let big = Int32.to_int (Int32.shift_right_logical v 24) in
add_char this base;
add_char this (base lsr 8);
add_char this (base lsr 16);
add_char this big
let addByte = vifun1 (fun vthis byte ->
let this = this vthis in
let byte = decode_int byte in
add_char this byte;
vnull;
)
let add = vifun1 (fun vthis src ->
let this = this vthis in
let src = decode_bytes src in
Buffer.add_bytes this src;
vnull
)
let addString = vifun2 (fun vthis src encoding ->
let this = this vthis in
let src = decode_vstring src in
Buffer.add_string this src.sstring;
vnull
)
let addInt32 = vifun1 (fun vthis v ->
let this = this vthis in
let v = decode_i32 v in
add_i32 this v;
vnull
)
let addInt64 = vifun1 (fun vthis v ->
let this = this vthis in
let v = decode_instance v in
let high = decode_i32 (instance_field v key_high) in
let low = decode_i32 (instance_field v key_low) in
add_i32 this low;
add_i32 this high;
vnull;
)
let addFloat = vifun1 (fun vthis v ->
let this = this vthis in
let v = num v in
add_i32 this (Int32.bits_of_float v);
vnull
)
let addDouble = vifun1 (fun vthis v ->
let this = this vthis in
let v = num v in
let v = Int64.bits_of_float v in
add_i32 this (Int64.to_int32 v);
add_i32 this (Int64.to_int32 (Int64.shift_right_logical v 32));
vnull
)
let addBytes = vifun3 (fun vthis src pos len ->
let this = this vthis in
let src = decode_bytes src in
let pos = decode_int pos in
let len = decode_int len in
if pos < 0 || len < 0 || pos + len > Bytes.length src then outside_bounds();
Buffer.add_subbytes this src pos len;
vnull
)
let getBytes = vifun0 (fun vthis ->
let this = this vthis in
encode_bytes (Bytes.unsafe_of_string (Buffer.contents this))
)
end
module StdCompress = struct
open Extc
type zfun = zstream -> src:string -> spos:int -> slen:int -> dst:bytes -> dpos:int -> dlen:int -> zflush -> zresult
let this vthis = match vthis with
| VInstance {ikind = IZip zip} -> zip
| _ -> unexpected_value vthis "Compress"
let exec (f : zfun) vthis src srcPos dst dstPos =
let this = this vthis in
let src = decode_bytes src in
let srcPos = decode_int srcPos in
let dst = decode_bytes dst in
let dstPos = decode_int dstPos in
let r = try f this.z (Bytes.unsafe_to_string src) srcPos (Bytes.length src - srcPos) dst dstPos (Bytes.length dst - dstPos) this.z_flush with _ -> exc_string "oops" in
encode_obj [
key_done,vbool r.z_finish;
key_read,vint r.z_read;
key_write,vint r.z_wrote
]
let close = vifun0 (fun vthis ->
zlib_deflate_end (this vthis).z;
vnull
)
let execute = vifun4 (fun vthis src srcPos dst dstPos ->
exec zlib_deflate vthis src srcPos dst dstPos
)
let run = vfun2 (fun s level ->
let s = decode_bytes s in
let level = decode_int level in
let zip = zlib_deflate_init level in
let d = Bytes.make (zlib_deflate_bound zip (Bytes.length s)) (char_of_int 0) in
let r = zlib_deflate zip (Bytes.unsafe_to_string s) 0 (Bytes.length s) d 0 (Bytes.length d) Z_FINISH in
zlib_deflate_end zip;
if not r.z_finish || r.z_read <> (Bytes.length s) then exc_string "Compression failed";
encode_bytes (Bytes.sub d 0 r.z_wrote)
)
let setFlushMode = vifun1 (fun vthis f ->
let mode = match fst (decode_enum f) with
| 0 -> Z_NO_FLUSH
| 1 -> Z_SYNC_FLUSH
| 2 -> Z_FULL_FLUSH
| 3 -> Z_FINISH
| 4 -> Z_PARTIAL_FLUSH
| _ -> die "" __LOC__
in
(this vthis).z_flush <- mode;
vnull
)
end
module StdContext = struct
let addBreakpoint = vfun2 (fun file line ->
let file = decode_string file in
let line = decode_int line in
begin try
ignore(EvalDebugMisc.add_breakpoint (get_ctx()) file line BPAny None);
with Not_found ->
exc_string ("Could not find file " ^ file)
end;
vnull
)
let breakHere = vfun0 (fun () ->
if not ((get_ctx()).debug.support_debugger) then vnull
else raise (EvalDebugMisc.BreakHere)
)
let callMacroApi = vfun1 (fun f ->
let f = decode_string f in
try
Hashtbl.find GlobalState.macro_lib f
with Not_found ->
exc_string ("Could not find macro function \"" ^ f ^ "\"")
)
let plugins = ref PMap.empty
let plugin_data = ref None
let register data = plugin_data := Some data
let loadPlugin = vfun1 (fun filePath ->
let filePath = decode_string filePath in
let filePath = Dynlink.adapt_filename filePath in
if PMap.mem filePath !plugins then
PMap.find filePath !plugins
else begin
(try Dynlink.loadfile filePath with Dynlink.Error error -> exc_string (Dynlink.error_message error));
match !plugin_data with
| Some l ->
let vapi = encode_obj_s l in
plugins := PMap.add filePath vapi !plugins;
vapi
| None ->
vnull
end
)
end
module StdCrc32 = struct
let make = vfun1 (fun data ->
let data = decode_bytes data in
let crc32 = Extc.zlib_crc32 data (Bytes.length data) in
vint32 crc32
)
end
module StdDate = struct
open Unix
let encode_date d = encode_instance key_Date ~kind:(IDate d)
let this vthis = match vthis with
| VInstance {ikind = IDate d} -> d
| v -> unexpected_value v "date"
let fromTime = vfun1 (fun f -> encode_date ((num f) /. 1000.))
let fromString = vfun1 (fun s ->
let s = decode_string s in
match String.length s with
| 19 ->
let r = Str.regexp "^\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\) \\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)$" in
if not (Str.string_match r s 0) then exc_string ("Invalid date format : " ^ s);
let t = {
tm_year = int_of_string (Str.matched_group 1 s) - 1900;
tm_mon = int_of_string (Str.matched_group 2 s) - 1;
tm_mday = int_of_string (Str.matched_group 3 s);
tm_hour = int_of_string (Str.matched_group 4 s);
tm_min = int_of_string (Str.matched_group 5 s);
tm_sec = int_of_string (Str.matched_group 6 s);
tm_wday = 0;
tm_yday = 0;
tm_isdst = false;
} in
encode_date (fst (catch_unix_error mktime t))
| 10 ->
let r = Str.regexp "^\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\)$" in
if not (Str.string_match r s 0) then exc_string ("Invalid date format : " ^ s);
let t = {
tm_year = int_of_string (Str.matched_group 1 s) - 1900;
tm_mon = int_of_string (Str.matched_group 2 s) - 1;
tm_mday = int_of_string (Str.matched_group 3 s);
tm_hour = 0;
tm_min = 0;
tm_sec = 0;
tm_wday = 0;
tm_yday = 0;
tm_isdst = false;
} in
encode_date (fst (catch_unix_error mktime t))
| 8 ->
let r = Str.regexp "^\\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)$" in
if not (Str.string_match r s 0) then exc_string ("Invalid date format : " ^ s);
let h = int_of_string (Str.matched_group 1 s) in
let m = int_of_string (Str.matched_group 2 s) in
let s = int_of_string (Str.matched_group 3 s) in
let t = h * 60 * 60 + m * 60 + s in
encode_date (float_of_int t)
| _ ->
exc_string ("Invalid date format : " ^ s)
)
let getDate = vifun0 (fun vthis -> vint (catch_unix_error localtime (this vthis)).tm_mday)
let getDay = vifun0 (fun vthis -> vint (catch_unix_error localtime (this vthis)).tm_wday)
let getFullYear = vifun0 (fun vthis -> vint (((catch_unix_error localtime (this vthis)).tm_year) + 1900))
let getHours = vifun0 (fun vthis -> vint (catch_unix_error localtime (this vthis)).tm_hour)
let getMinutes = vifun0 (fun vthis -> vint (catch_unix_error localtime (this vthis)).tm_min)
let getMonth = vifun0 (fun vthis -> vint (catch_unix_error localtime (this vthis)).tm_mon)
let getSeconds = vifun0 (fun vthis -> vint (catch_unix_error localtime (this vthis)).tm_sec)
let getUTCDate = vifun0 (fun vthis -> vint (catch_unix_error gmtime (this vthis)).tm_mday)
let getUTCDay = vifun0 (fun vthis -> vint (catch_unix_error gmtime (this vthis)).tm_wday)
let getUTCFullYear = vifun0 (fun vthis -> vint (((catch_unix_error gmtime (this vthis)).tm_year) + 1900))
let getUTCHours = vifun0 (fun vthis -> vint (catch_unix_error gmtime (this vthis)).tm_hour)
let getUTCMinutes = vifun0 (fun vthis -> vint (catch_unix_error gmtime (this vthis)).tm_min)
let getUTCMonth = vifun0 (fun vthis -> vint (catch_unix_error gmtime (this vthis)).tm_mon)
let getUTCSeconds = vifun0 (fun vthis -> vint (catch_unix_error gmtime (this vthis)).tm_sec)
let getTime = vifun0 (fun vthis -> vfloat ((this vthis) *. 1000.))
let getTimezoneOffset = vifun0 (fun vthis ->
let tmLocal = catch_unix_error localtime (this vthis) in
let tmUTC = catch_unix_error gmtime (this vthis) in
let tsLocal = fst (catch_unix_error mktime tmLocal) in
let tsUTC = fst (catch_unix_error mktime tmUTC) in
vint (int_of_float ((tsUTC -. tsLocal) /. 60.))
)
let now = vfun0 (fun () -> encode_date (catch_unix_error time()))
let toString = vifun0 (fun vthis -> vstring (s_date (this vthis)))
end
module StdDeque = struct
let this vthis = match vthis with
| VInstance {ikind = IDeque d} -> d
| _ -> unexpected_value vthis "Deque"
let add = vifun1 (fun vthis i ->
let this = this vthis in
Deque.add this i;
vnull
)
let pop = vifun1 (fun vthis blocking ->
let this = this vthis in
let blocking = decode_bool blocking in
match Deque.pop this blocking with
| None -> vnull
| Some v -> v
)
let push = vifun1 (fun vthis i ->
let this = this vthis in
Deque.push this i;
vnull
)
end
module StdEReg = struct
open Pcre2
let create r opt =
let open Pcre2 in
let string_of_pcre_error = function
| BadPattern(s,i) -> Printf.sprintf "at %i: %s" i s
| Partial -> "Partial"
| BadUTF -> "BadUTF"
| BadUTFOffset -> "BadUTFOffset"
| MatchLimit -> "MatchLimit"
| DepthLimit -> "DepthLimit"
| WorkspaceSize -> "WorkspaceSize"
| InternalError s -> "InternalError: " ^ s
in
let global = ref false in
let flags = ExtList.List.filter_map (function
| 'i' -> Some `CASELESS
| 's' -> Some `DOTALL
| 'm' -> Some `MULTILINE
| 'u' -> None
| 'g' -> global := true; None
| c -> failwith ("Unsupported regexp option '" ^ String.make 1 c ^ "'")
) (ExtString.String.explode opt) in
let flags = `UTF :: `UCP :: flags in
let rex = try regexp ~flags r with Error error -> failwith (string_of_pcre_error error) in
let pcre = {
r = rex;
r_rex_string = create_ascii (Printf.sprintf "~/%s/%s" r opt);
r_global = !global;
r_string = "";
r_groups = [||]
} in
IRegex pcre
let maybe_run rex n f =
let substrings = if Array.length rex.r_groups = 0 then exc_string "Invalid regex operation because no match was made" else rex.r_groups.(0) in
if n < 0 || n >= num_of_subs substrings then exc_string "Invalid group"
else try f (get_substring_ofs substrings n)
with Not_found -> vnull
let this this = match this with
| VInstance {ikind = IRegex rex} -> rex
| v -> unexpected_value v "EReg"
let escape = vfun1 (fun s ->
let s = decode_string s in
create_unknown (Str.quote s)
)
let map = vifun2 (fun vthis s f ->
let this = this vthis in
let s = decode_string s in
let l = String.length s in
let buf = Buffer.create 0 in
let rec loop pos =
if pos >= l then
()
else begin try
let a = exec ~rex:this.r ~pos s in
this.r_groups <- [|a|];
let (first,last) = get_substring_ofs a 0 in
Buffer.add_substring buf s pos (first - pos);
Buffer.add_string buf (decode_string (call_value_on vthis f [vthis]));
if last = first then begin
if last >= l then
()
else begin
if this.r_global then begin
Buffer.add_substring buf s first 1;
loop (first + 1)
end else
Buffer.add_substring buf s first (l - first)
end
end else if this.r_global then
loop last
else
Buffer.add_substring buf s last (l - last)
with Not_found ->
Buffer.add_substring buf s pos (l - pos)
end
in
this.r_string <- s;
loop 0;
this.r_string <- "";
this.r_groups <- [||];
create_unknown (Buffer.contents buf)
)
let match' = vifun1 (fun vthis s ->
let this = this vthis in
let open Pcre2 in
let s = decode_string s in
this.r_string <- s;
try
let a = exec_all ~flags:[`NO_UTF_CHECK] ~rex:this.r s in
this.r_groups <- a;
vtrue
with Not_found ->
this.r_groups <- [||];
vfalse
| Pcre2.Error _ ->
exc_string "PCRE Error (invalid unicode string?)"
)
let matched = vifun1 (fun vthis n ->
let this = this vthis in
let n = decode_int n in
maybe_run this n (fun (first,last) ->
create_unknown (ExtString.String.slice ~first ~last this.r_string)
)
)
let matchedLeft = vifun0 (fun vthis ->
let this = this vthis in
maybe_run this 0 (fun (first,_) ->
create_unknown (ExtString.String.slice ~last:first this.r_string)
)
)
let matchedPos = vifun0 (fun vthis ->
let this = this vthis in
let rec byte_offset_to_char_offset_lol s i k o =
if i = 0 then
k
else begin
let n = UTF8.next s o in
let d = n - o in
byte_offset_to_char_offset_lol s (i - d) (k + 1) n
end
in
maybe_run this 0 (fun (first,last) ->
let first = byte_offset_to_char_offset_lol this.r_string first 0 0 in
let last = byte_offset_to_char_offset_lol this.r_string last 0 0 in
encode_obj [key_pos,vint first;key_len,vint (last - first)]
)
)
let matchedRight = vifun0 (fun vthis ->
let this = this vthis in
maybe_run this 0 (fun (_,last) ->
create_unknown (ExtString.String.slice ~first:last this.r_string)
)
)
let matchSub = vifun3 (fun vthis s pos len ->
let this = this vthis in
let s = decode_string s in
let pos = decode_int pos in
let len_default = String.length s - pos in
let len = default_int len len_default in
let len = if len < 0 then len_default else len in
begin try
if pos + len > String.length s then raise Not_found;
let str = String.sub s 0 (pos + len) in
let a = Pcre2.exec_all ~flags:[`NO_UTF_CHECK] ~rex:this.r ~pos str in
this.r_string <- s;
this.r_groups <- a;
vtrue
with Not_found ->
vfalse
end
)
let replace = vifun2 (fun vthis s by ->
let this = this vthis in
let s = decode_string s in
let by = decode_string by in
let s = (if this.r_global then Pcre2.replace else Pcre2.replace_first) ~flags:[`NO_UTF_CHECK] ~rex:this.r ~templ:by s in
create_unknown s
)
let split = vifun1 (fun vthis s ->
let this = this vthis in
let s = decode_string s in
let slength = String.length s in
if slength = 0 then
encode_array [v_empty_string]
else begin
let copy_offset = ref 0 in
let acc = DynArray.create () in
let add first last =
let sub = String.sub s first (last - first) in
DynArray.add acc (create_unknown sub)
in
let exec = Pcre2.exec ~flags:[`NO_UTF_CHECK] ~rex:this.r in
let step pos =
try
let substrings = exec ~pos s in
let (first,last) = Pcre2.get_substring_ofs substrings 0 in
add !copy_offset first;
copy_offset := last;
let next_start = if pos = last then last + 1 else last in
if next_start >= slength then begin
DynArray.add acc (create_unknown "");
None
end else
Some next_start
with Not_found ->
add !copy_offset slength;
None
in
let rec loop pos =
match step pos with
| Some next ->
if this.r_global then
loop next
else
add !copy_offset slength
| _ ->
()
in
loop 0;
encode_array (DynArray.to_list acc)
end
)
end
module StdFile = struct
let create_out path binary flags =
let path = decode_string path in
let binary = match binary with
| VTrue | VNull -> true
| _ -> false
in
let perms = 0o666 in
let l = Open_creat :: flags in
let l = if binary then Open_binary :: l else l in
let ch =
try open_out_gen l perms path
with Sys_error msg -> exc_string msg
in
encode_instance key_sys_io_FileOutput ~kind:(IOutChannel ch)
let write_out path content =
try
let ch = open_out_bin path in