Multi-byte character support

libdash.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.4.0"
+version: "0.4.1"
 synopsis: "Bindings to the dash shell's parser"
 maintainer: ["michael@greenberg.science"]
 authors: ["Michael Greenberg"]

libdash/ast.py

@@ -8,6 +8,7 @@
 CTLVAR       = 130
 CTLENDVAR    = 131
 CTLBACKQ     = 132
+CTLMBCHAR    = 133
 CTLARI       = 134
 CTLENDARI    = 135
 CTLQUOTEMARK = 136
@@ -385,6 +386,37 @@ def parse_arg (s, bqlist, stack):
 
                     bqlist = bqlist.contents.next
 
+            # (* CTLMBCHAR *)
+            # | '\133'::s,_ ->
+            elif s[-1] == CTLMBCHAR:
+                s.pop()
+
+                # sometimes there is a CTLESC
+                char_ctor = "C"
+                if s[-1] == CTLESC:
+                    s.pop()
+                    char_ctor = "E"
+
+                # encoded multi-byte length
+                ml = s.pop()
+                assert 1 <= ml and ml <= 4
+
+                # extract bytes, decode to UTF-8, record in acc
+                mb_ords = []
+                count = ml
+                while count > 0:
+                    mb_ords.append(s.pop())
+                    count -= 1
+
+                mb = bytes(mb_ords).decode()
+                acc.extend([(char_ctor, ord(c)) for c in mb])
+
+                # clear out second ml and CTLMBCHAR
+                ml2 = s.pop()
+                assert ml == ml2
+                ctlmbchar = s.pop()
+                assert ctlmbchar == CTLMBCHAR
+
             # (* CTLARI *)
             # | '\134'::s,_ ->
             elif (s [-1] == CTLARI):

ocaml/ast.ml

@@ -220,7 +220,8 @@ and of_binary (n : node union ptr) =
   (of_node (getf n nbinary_ch1), of_node (getf n nbinary_ch2))
 
 and to_arg (n : narg structure) : arg =
-  let a,s,bqlist,stack = parse_arg ~assign:false (explode (getf n narg_text)) (getf n narg_backquote) [] in
+  let s = explode (getf n narg_text) in
+  let a,s,bqlist,stack = parse_arg ~assign:false s (getf n narg_backquote) [] in
   (* we should have used up the string and have no backquotes left in our list *)
   assert (s = []);
   assert (nullptr bqlist);
@@ -277,6 +278,39 @@ and parse_arg ?tilde_ok:(tilde_ok=false) ~assign:(assign:bool) (s : char list) (
      if nullptr bqlist
      then failwith "Saw CTLBACKQ but bqlist was null"
      else arg_char assign (B (of_node (bqlist @-> nodelist_n))) s (bqlist @-> nodelist_next) stack
+  (* CTLMBCHAR *)
+  | '\133'::s,_ ->
+     (* get constructor and multi-byte length *)
+     let char_ctor, ml, s =
+       begin match s with
+       | '\129'::ml::s -> (fun x -> E x), Char.code ml, s
+       |         ml::s -> (fun x -> C x), Char.code ml, s
+       | _ -> failwith "Saw CTLMBCHAR without CTLESC or length"
+       end
+     in
+     (* extract bytes, decode to UTF-8 *)
+     let mb_ords, s =
+       begin match ml, s with
+       | 1, c1            ::s -> [c1],             s
+       | 2, c1::c2        ::s -> [c1; c2],         s
+       | 3, c1::c2::c3    ::s -> [c1; c2; c3],     s
+       | 4, c1::c2::c3::c4::s -> [c1; c2; c3; c4], s
+       | _ -> failwith "Expected 1 <= ml <= 4 after CTLMBCHAR"
+       end
+     in
+     (* double-check final bytes, CTLMBCHAR *)
+     let s = match s with
+       | ml'::'\133'::s ->
+          let ml' = Char.code ml' in
+          if ml <> ml' then
+            failwith (Printf.sprintf "saw %d bytes before, %d bytes after CTLMBCHAR" ml ml');
+          s
+       | _ -> failwith "Expected byte-count and CTLMBCHAR"
+     in
+     let tilde_ok = false in
+     let a,s,bqlist,stack = parse_arg ~tilde_ok ~assign s bqlist stack in
+     (List.map char_ctor mb_ords @ a,s,bqlist,stack)
+
   (* CTLARI *)
   | '\134'::s,_ ->
      let a,s,bqlist,stack' = parse_arg ~assign s bqlist (`CTLAri::stack) in
@@ -336,7 +370,7 @@ and extract_assign v = function
   | '\130'::_ -> failwith "Unexpected CTLVAR in variable name"
   | '\131'::_ -> failwith "Unexpected CTLENDVAR in variable name"
   | '\132'::_ -> failwith "Unexpected CTLBACKQ in variable name"
-  | '\133'::_ -> failwith "Unexpected CTL??? in variable name"
+  | '\133'::_ -> failwith "Unexpected CTLMBCHAR in variable name"
   | '\134'::_ -> failwith "Unexpected CTLARI in variable name"
   | '\135'::_ -> failwith "Unexpected CTLENDARI in variable name"
   | '\136'::_ -> failwith "Unexpected CTLQUOTEMARK in variable name"

ocaml/dash.ml

@@ -16,6 +16,7 @@ let pop_stack stack : unit =
 
 let initialize () : unit =
   initialize_dash_errno ();
+  initialize_dash_setlocale ();
   dash_init ()
 
 let setinputtostdin () : unit =

ocaml/function_description.ml

@@ -14,6 +14,7 @@ module Functions (F : Ctypes.FOREIGN) = struct
 
   let dash_init = foreign "init" (void @-> returning void)
   let initialize_dash_errno = foreign "initialize_dash_errno" (void @-> returning void)
+  let initialize_dash_setlocale = foreign "initialize_dash_setlocale" (void @-> returning void)
 
   let popfile = foreign "popfile" (void @-> returning void)
   let setinputstring = foreign "setinputstring" (ptr char @-> returning void)

ocaml/type_description.ml

@@ -2,10 +2,10 @@ open Ctypes
 
 module Types (F : Ctypes.TYPE) = struct
   open F
-  
+
   (* stackmarks [used for string allocation in dash] *)
   module Stackmark = struct
-    
+
     type stackmark
     type t = stackmark Ctypes.structure
 
@@ -18,173 +18,173 @@ module Types (F : Ctypes.TYPE) = struct
 
   type stackmark = Stackmark.t
   let stackmark = Stackmark.t
-  
+
   (* AST nodes *)
 
   (* define the node type... *)
-  type node       
+  type node
   let node : node union typ = union "node"
   let node_type = field node "type" int
   (* ...but don't seal it yet! *)
-  
+
   type nodelist
-  let nodelist : nodelist structure typ = structure "nodelist"       
+  let nodelist : nodelist structure typ = structure "nodelist"
   let nodelist_next = field nodelist "next" (ptr nodelist)
   let nodelist_n = field nodelist "n" (ptr node)
   let () = seal nodelist
-                         
+
   type ncmd
-  
+
   let ncmd : ncmd structure typ = structure "ncmd"
   let ncmd_type = field ncmd "type" int
   let ncmd_linno = field ncmd "linno" int
   let ncmd_assign = field ncmd "assign" (ptr node)
   let ncmd_args = field ncmd "args" (ptr node)
   let ncmd_redirect = field ncmd "redirect" (ptr node)
   let () = seal ncmd
-  
+
   let node_ncmd = field node "ncmd" ncmd
-  
+
   type npipe
-  
+
   let npipe : npipe structure typ = structure "npipe"
   let npipe_type = field npipe "type" int
   let npipe_backgnd = field npipe "backgnd" int
   let npipe_cmdlist = field npipe "cmdlist" (ptr nodelist)
   let () = seal npipe
-  
+
   let node_npipe = field node "npipe" npipe
-                             
+
   type nredir
-  
+
   let nredir : nredir structure typ = structure "nredir"
   let nredir_type = field nredir "type" int
   let nredir_linno = field nredir "linno" int
   let nredir_n = field nredir "n" (ptr node)
   let nredir_redirect = field nredir "redirect" (ptr node)
   let () = seal nredir
-  
+
   let node_nredir = field node "nredir" nredir
-  
+
   type nbinary
-  
+
   let nbinary : nbinary structure typ = structure "nbinary"
   let nbinary_type = field nbinary "type" int
   let nbinary_ch1 = field nbinary "ch1" (ptr node)
   let nbinary_ch2 = field nbinary "ch2" (ptr node)
   let () = seal nbinary
-  
+
   let node_nbinary = field node "nbinary" nbinary
-  
+
   type nif
-  
+
   let nif : nif structure typ = structure "nif"
   let nif_type = field nif "type" int
   let nif_test = field nif "test" (ptr node)
   let nif_ifpart = field nif "ifpart" (ptr node)
   let nif_elsepart = field nif "elsepart" (ptr node)
   let () = seal nif
-  
+
   let node_nif = field node "nif" nif
-  
+
   type nfor
-  
+
   let nfor : nfor structure typ = structure "nfor"
   let nfor_type = field nfor "type" int
   let nfor_linno = field nfor "linno" int
   let nfor_args = field nfor "args" (ptr node)
   let nfor_body = field nfor "body" (ptr node)
   let nfor_var = field nfor "var" string
   let () = seal nfor
-  
+
   let node_nfor = field node "nfor" nfor
-  
+
   type ncase
-  
+
   let ncase : ncase structure typ = structure "ncase"
   let ncase_type = field ncase "type" int
   let ncase_linno = field ncase "linno" int
   let ncase_expr = field ncase "expr" (ptr node)
   let ncase_cases = field ncase "cases" (ptr node)
   let () = seal ncase
-  
+
   let node_ncase = field node "ncase" ncase
-  
+
   type nclist
-  
+
   let nclist : nclist structure typ = structure "nclist"
   let nclist_type = field nclist "type" int
   let nclist_next = field nclist "next" (ptr node)
   let nclist_pattern = field nclist "pattern" (ptr node)
   let nclist_body = field nclist "body" (ptr node)
   let () = seal nclist
-  
+
   let node_nclist = field node "nclist" nclist
-  
+
   type ndefun
-  
+
   let ndefun : ndefun structure typ = structure "ndefun"
   let ndefun_type = field ndefun "type" int
   let ndefun_linno = field ndefun "linno" int
   let ndefun_text = field ndefun "text" string
   let ndefun_body = field ndefun "body" (ptr node)
   let () = seal ndefun
-  
+
   let node_ndefun = field node "ndefun" ndefun
-  
+
   type narg
-  
+
   let narg : narg structure typ = structure "narg"
   let narg_type = field narg "type" int
   let narg_next = field narg "next" (ptr node)
   let narg_text = field narg "text" string
   let narg_backquote = field narg "backquote" (ptr nodelist)
   let () = seal narg
-  
+
   let node_narg = field node "narg" narg
-  
+
   type nfile
-  
+
   let nfile : nfile structure typ = structure "nfile"
   let nfile_type = field nfile "type" int
   let nfile_next = field nfile "next" (ptr node)
   let nfile_fd = field nfile "fd" int
   let nfile_fname = field nfile "fname" (ptr node)
   let nfile_expfname = field nfile "expfname" string
   let () = seal nfile
-  
+
   let node_nfile = field node "nfile" nfile
-  
+
   type ndup
-  
+
   let ndup : ndup structure typ = structure "ndup"
   let ndup_type = field ndup "type" int
   let ndup_next = field ndup "next" (ptr node)
   let ndup_fd = field ndup "fd" int
   let ndup_dupfd = field ndup "dupfd" int
   let ndup_vname = field ndup "vname" (ptr node)
   let () = seal ndup
-  
+
   let node_ndup = field node "ndup" ndup
-  
+
   type nhere
-  
+
   let nhere : nhere structure typ = structure "nhere"
   let nhere_type = field nhere "type" int
   let nhere_next = field nhere "next" (ptr node)
   let nhere_fd = field nhere "fd" int
   let nhere_doc = field nhere "doc" (ptr node)
   let () = seal nhere
-  
+
   let node_nhere = field node "nhere" nhere
-  
+
   type nnot
-  
+
   let nnot : nnot structure typ = structure "nnot"
   let nnot_type = field nnot "type" int
   let nnot_com = field nnot "com" (ptr node)
   let () = seal nnot
-  
+
   let node_nnot = field node "nnot" nnot
   let () = seal node