Source file Charset.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
(* Claude Code
 *
 * Copyright (C) 2026 Yoann Padioleau
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Library General Public License
 * (LGPL) as published by the Free Software Foundation; either version
 * 2 of the License, or (at your option) any later version.
 *)

(* See Charset.mli *)

type t = Utf_8 | Windows_1252

(*****************************************************************************)
(* Labels *)
(*****************************************************************************)

(* the WHATWG's labels (Encoding, section 4.2) *)
let utf_8_labels = [ "unicode-1-1-utf-8"; "unicode11utf8"; "unicode20utf8"; "utf-8"; "utf8"; "x-unicode20utf8" ]

let windows_1252_labels =
  [
    "ansi_x3.4-1968"; "ascii"; "cp1252"; "cp819"; "csisolatin1"; "ibm819"; "iso-8859-1"; "iso-ir-100"; "iso8859-1";
    "iso88591"; "iso_8859-1"; "iso_8859-1:1987"; "l1"; "latin1"; "us-ascii"; "windows-1252"; "x-cp1252";
  ]

let of_label (label : string) : t option =
  let label = String.lowercase_ascii (String.trim label) in
  if List.mem label utf_8_labels then Some Utf_8
  else if List.mem label windows_1252_labels then Some Windows_1252
  else None

(*****************************************************************************)
(* Finding "charset=" *)
(*****************************************************************************)

(* the index of [sub] in [s] from [from], if any *)
let rec find (s : string) (sub : string) (from : int) : int option =
  let n = String.length sub in
  if from + n > String.length s then None
  else if String.sub s from n = sub then Some from
  else find s sub (from + 1)

(* the value after "charset=" at [i] in [s] (lowercased already):
 * spaces skipped, then quoted, or up to a space, ';', '>' or '/' *)
let value_after (s : string) (i : int) (stop : int) : string =
  let i = ref (i + String.length "charset=") in
  while !i < stop && s.[!i] = ' ' do incr i done;
  let quote = if !i < stop && (s.[!i] = '"' || s.[!i] = '\'') then Some s.[!i] else None in
  if quote <> None then incr i;
  let start = !i in
  let ends c = match quote with Some q -> c = q | None -> c = ' ' || c = ';' || c = '>' || c = '/' || c = '"' || c = '\'' in
  while !i < stop && not (ends s.[!i]) do incr i done;
  String.sub s start (!i - start)

let of_content_type (content_type : string) : t option =
  let s = String.lowercase_ascii content_type in
  match find s "charset=" 0 with Some i -> of_label (value_after s i (String.length s)) | None -> None

let of_meta (bytes : string) : t option =
  let s = String.lowercase_ascii (String.sub bytes 0 (min 1024 (String.length bytes))) in
  (* each <meta ...> in turn, its first "charset=" inside it *)
  let rec from (i : int) : t option =
    match find s "<meta" i with
    | None -> None
    | Some start -> (
        let stop = match String.index_from_opt s start '>' with Some j -> j | None -> String.length s in
        match find s "charset=" start with
        | Some i when i < stop -> (
            match of_label (value_after s i stop) with Some t -> Some t | None -> from stop)
        | _ -> from stop)
  in
  from 0

(*****************************************************************************)
(* UTF-8 *)
(*****************************************************************************)

(* OCaml's decoder (String.get_utf_8_uchar) is the strict one Unicode
 * asks for: an overlong form, a surrogate, a byte that can't start or
 * continue a sequence are each invalid, with the length of the maximal
 * part to skip -- which is also what the WHATWG replaces by one U+FFFD *)
let is_utf_8 (s : string) : bool =
  let rec ok (i : int) : bool =
    if i >= String.length s then true
    else
      let d = String.get_utf_8_uchar s i in
      Uchar.utf_decode_is_valid d && ok (i + Uchar.utf_decode_length d)
  in
  ok 0

let has_bom (s : string) : bool = String.length s >= 3 && String.sub s 0 3 = "\xEF\xBB\xBF"

let is_ascii (s : string) : bool = String.for_all (fun c -> Char.code c < 0x80) s

let detect ?content_type (bytes : string) : t =
  if has_bom bytes then Utf_8
  else
    match Option.bind content_type of_content_type with
    | Some t -> t
    | None -> (
        match of_meta bytes with
        | Some t -> t
        | None -> if (not (is_ascii bytes)) && is_utf_8 bytes then Utf_8 else Windows_1252)

(*****************************************************************************)
(* Decoding *)
(*****************************************************************************)

(* bytes 80 to 9F, the WHATWG's index windows-1252 *)
let windows_1252_high =
  [|
    0x20AC; 0x0081; 0x201A; 0x0192; 0x201E; 0x2026; 0x2020; 0x2021; 0x02C6; 0x2030; 0x0160; 0x2039; 0x0152; 0x008D;
    0x017D; 0x008F; 0x0090; 0x2018; 0x2019; 0x201C; 0x201D; 0x2022; 0x2013; 0x2014; 0x02DC; 0x2122; 0x0161; 0x203A;
    0x0153; 0x009D; 0x017E; 0x0178;
  |]

let windows_1252 (byte : int) : int = if byte >= 0x80 && byte <= 0x9F then windows_1252_high.(byte - 0x80) else byte

let to_utf_8 (t : t) (bytes : string) : string =
  let b = Buffer.create (String.length bytes) in
  (match t with
  | Windows_1252 -> String.iter (fun c -> Buffer.add_utf_8_uchar b (Uchar.of_int (windows_1252 (Char.code c)))) bytes
  | Utf_8 ->
      let rec go (i : int) =
        if i < String.length bytes then (
          let d = String.get_utf_8_uchar bytes i in
          (* an invalid sequence's d is already U+FFFD *)
          Buffer.add_utf_8_uchar b (Uchar.utf_decode_uchar d);
          go (i + Uchar.utf_decode_length d))
      in
      go (if has_bom bytes then 3 else 0));
  Buffer.contents b

let decode ?content_type (bytes : string) : string = to_utf_8 (detect ?content_type bytes) bytes