Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 160 lines (125 sloc) 5.492 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 ##register concat \ `Pervasives.( ^ )` : string, string -> string
19
20 ##register length \ `String.length` : string -> int
21
22 ##register get : string, int -> string
23 let get s i = String.make 1 (String.get s i)
24
53c835a fpessaux [cleanup] remove chars: stdlib
fpessaux authored
25 ##register repeat \ `BaseString.repeat` : string, int -> string
fccc685 Initial open-source release
MLstate authored
26
27 ##register sub : int, int, string -> string
28 let sub start len src = String.sub src start len
29
30 ##register replace : string, string, string -> string
31 let replace search replacement source =
32 BaseString.replace source search replacement
33
34 ##register strip_quotes \ `BaseString.strip_quotes` : string -> string
35
36 ##register index : string, string -> option(int)
37 let index pattern source =
38 let lp = String.length pattern in
39 let ls = String.length source in
40 let rec aux id =
41 if ls - lp - id >= 0 then
42 if BaseString.is_substring pattern source id then Some id
43 else aux (id + 1)
44 else
45 None
46 in
47 aux 0
48
49 (*Low-level: fails with UTF-8*)
50 ##register reverse : string -> string
51 let reverse s =
52 let len = String.length s in
53 let res = String.make len ' ' in
54 let i = ref 1 in
55 String.iter (fun c ->
56 String.set res (len - !i) c;
57 i := !i + 1;
58 ()) s;
59 res
60
61 ##register lowercase \ `Cactutf.lowercase` : string -> string
62
63 ##register uppercase \ `Cactutf.uppercase` : string -> string
64
65 ##register remove_accents \ `BaseString.remove_accents` : string -> string
66
67 let have_to_be_escaped_table =
68 let have_to_be_escaped chr =
69 let code = Char.code chr in
70 code >= 128 || String.contains Base.Utf8.except_html_char chr || (code < 32 && not (String.contains Base.Utf8.allowed_special_char chr)) in
71 Array.init 256 (fun code -> have_to_be_escaped (Char.unsafe_chr code))
72 let have_to_be_escaped (c:char) = have_to_be_escaped_table.(Char.code c)
73
74 (*Fails with UTF-8 -- use Cactutf?*)
75 (*TODO: This looks slow -- constructing lists ?*)
76 (* I think it works ok with utf8 because whenever the code is greater than 128
77 * (ie we have a character of more than one byte, BaseString.len_from is used to
78 * agglomerate the following bytes whose code is more than 128 (which is the end
79 * of the unicode character if is the input is well formed) *)
80 ##register escapeHTML : string -> string
81 let escapeHTML src =
82 if BaseString.exists have_to_be_escaped src then
83 let len = String.length src in
84 let rec aux pos acc =
85 if pos < len then
86 if not (have_to_be_escaped src.[pos]) then
87 let to_push = String.sub src pos (BaseString.len_from (fun c -> not (have_to_be_escaped c)) src pos) in
88 aux (pos + (String.length to_push)) (to_push::acc)
89 else
90 let to_push = String.sub src pos (BaseString.len_from have_to_be_escaped src pos) in
91 aux (pos + (String.length to_push)) ((Base.Utf8.htmlentities to_push)::acc)
92 else acc
93 in
94 BaseString.rev_sconcat "" (aux 0 [])
95 else
96 src
97
98
99 ##register to_character \ `Base.Utf8.string_of_int` : int -> string
100
101 ##register of_int \ `Pervasives.string_of_int` : int -> string
102
103 ##register of_byte_val : int -> string
104 let of_byte_val byte =
53c835a fpessaux [cleanup] remove chars: stdlib
fpessaux authored
105 try
106 String.make 1 (Char.chr byte)
107 with
108 | Invalid_argument _ -> "\000"
109
110 ##register of_byte_unsafe : int -> string
111 let of_byte_unsafe i =
112 String.make 1 (Base.Char.chr i)
113
114 ##register byte_at_unsafe : int, string -> int
115 let byte_at_unsafe n s = Base.Char.code s.[n]
116
fccc685 Initial open-source release
MLstate authored
117
118 (* special function for TRX *)
119 (* TODO write it in C for better performance (on pointers)?
120 we could then even use some bit-level magic cleverlness to compare word-by-word instead
121 of byte-by-byte*)
122 ##register check_match_literal : string, int, string -> bool
123 let check_match_literal input pos literal =
124 let n = String.length literal in
125 let i = ref 0 in
126 while !i < n && String.unsafe_get input (pos + !i) == String.unsafe_get literal !i do
127 incr i
128 done;
129 !i == n
130
131
132 ##register leq: string, string -> bool
133 let leq (a:string) (b:string) = a <= b
134
135 ##register lt: string, string -> bool
136 let lt (a:string) (b:string) = a < b
137
138 ##register eq: string, string -> bool
139 let eq (a:string) (b:string) = a = b
140
141 ##register geq: string, string -> bool
142 let geq (a:string) (b:string) = a >= b
143
144 ##register gt: string, string -> bool
145 let gt (a:string) (b:string) = a > b
146
147 ##register neq: string, string -> bool
148 let neq (a:string) (b:string) = a <> b
149
150 ##register ordering: string, string -> opa[Order.ordering]
151 let ordering (a:string) (b:string) =
152 match String.compare a b with
153 | -1 -> BslPervasives.ord_result_lt
154 | 0 -> BslPervasives.ord_result_eq
155 | 1 -> BslPervasives.ord_result_gt
156 | _ -> assert false
157
158 ##register encode_uri_component\ `Encodings.encode_uri_component`: string -> string
159 ##register decode_uri_component\ `Encodings.decode_uri_component`: string -> string
Something went wrong with that request. Please try again.