752 lines
23 KiB
OCaml
752 lines
23 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
(* under the terms of the GNU Library General Public License, with *)
|
|
(* the special exception on linking described in file ../../LICENSE. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* In this module, [@ocaml.warnerror "-3"] is used in several places
|
|
that use deprecated functions to preserve legacy behavior.
|
|
It overrides -w @3 given on the command line. *)
|
|
|
|
(** String utilities *)
|
|
|
|
let string_before s n = String.sub s 0 n
|
|
|
|
let string_after s n = String.sub s n (String.length s - n)
|
|
|
|
let first_chars s n = String.sub s 0 n
|
|
|
|
let last_chars s n = String.sub s (String.length s - n) n
|
|
|
|
(** Representation of character sets **)
|
|
|
|
module Charset =
|
|
struct
|
|
type t = bytes (* of length 32 *)
|
|
|
|
(*let empty = Bytes.make 32 '\000'*)
|
|
let full = Bytes.make 32 '\255'
|
|
|
|
let make_empty () = Bytes.make 32 '\000'
|
|
|
|
let add s c =
|
|
let i = Char.code c in
|
|
Bytes.set s (i lsr 3)
|
|
(Char.chr (Char.code (Bytes.get s (i lsr 3))
|
|
lor (1 lsl (i land 7))))
|
|
|
|
let add_range s c1 c2 =
|
|
for i = Char.code c1 to Char.code c2 do add s (Char.chr i) done
|
|
|
|
let singleton c =
|
|
let s = make_empty () in add s c; s
|
|
|
|
(*let range c1 c2 =
|
|
let s = make_empty () in add_range s c1 c2; s
|
|
*)
|
|
let complement s =
|
|
let r = Bytes.create 32 in
|
|
for i = 0 to 31 do
|
|
Bytes.set r i (Char.chr(Char.code (Bytes.get s i) lxor 0xFF))
|
|
done;
|
|
r
|
|
|
|
let union s1 s2 =
|
|
let r = Bytes.create 32 in
|
|
for i = 0 to 31 do
|
|
Bytes.set r i (Char.chr(Char.code (Bytes.get s1 i)
|
|
lor Char.code (Bytes.get s2 i)))
|
|
done;
|
|
r
|
|
|
|
let disjoint s1 s2 =
|
|
try
|
|
for i = 0 to 31 do
|
|
if Char.code (Bytes.get s1 i) land Char.code (Bytes.get s2 i)
|
|
<> 0
|
|
then raise Exit
|
|
done;
|
|
true
|
|
with Exit ->
|
|
false
|
|
|
|
let iter fn s =
|
|
for i = 0 to 31 do
|
|
let c = Char.code (Bytes.get s i) in
|
|
if c <> 0 then
|
|
for j = 0 to 7 do
|
|
if c land (1 lsl j) <> 0 then fn (Char.chr ((i lsl 3) + j))
|
|
done
|
|
done
|
|
|
|
let expand s =
|
|
let r = Bytes.make 256 '\000' in
|
|
iter (fun c -> Bytes.set r (Char.code c) '\001') s;
|
|
r
|
|
|
|
let fold_case s =
|
|
(let r = make_empty() in
|
|
iter (fun c -> add r (Char.lowercase c); add r (Char.uppercase c)) s;
|
|
r)[@ocaml.warnerror "-3"]
|
|
|
|
end
|
|
|
|
(** Abstract syntax tree for regular expressions *)
|
|
|
|
type re_syntax =
|
|
Char of char
|
|
| String of string
|
|
| CharClass of Charset.t * bool (* true = complemented, false = normal *)
|
|
| Seq of re_syntax list
|
|
| Alt of re_syntax * re_syntax
|
|
| Star of re_syntax
|
|
| Plus of re_syntax
|
|
| Option of re_syntax
|
|
| Group of int * re_syntax
|
|
| Refgroup of int
|
|
| Bol
|
|
| Eol
|
|
| Wordboundary
|
|
|
|
(** Representation of compiled regular expressions *)
|
|
|
|
type regexp = {
|
|
prog: int array; (* bytecode instructions *)
|
|
cpool: string array; (* constant pool (string literals) *)
|
|
normtable: string; (* case folding table (if any) *)
|
|
numgroups: int; (* number of \(...\) groups *)
|
|
numregisters: int; (* number of nullable Star or Plus *)
|
|
startchars: int (* index of set of starting chars, or -1 if none *)
|
|
}
|
|
|
|
(** Opcodes for bytecode instructions; see strstubs.c for description *)
|
|
|
|
let op_CHAR = 0
|
|
let op_CHARNORM = 1
|
|
let op_STRING = 2
|
|
let op_STRINGNORM = 3
|
|
let op_CHARCLASS = 4
|
|
let op_BOL = 5
|
|
let op_EOL = 6
|
|
let op_WORDBOUNDARY = 7
|
|
let op_BEGGROUP = 8
|
|
let op_ENDGROUP = 9
|
|
let op_REFGROUP = 10
|
|
let op_ACCEPT = 11
|
|
let op_SIMPLEOPT = 12
|
|
let op_SIMPLESTAR = 13
|
|
let op_SIMPLEPLUS = 14
|
|
let op_GOTO = 15
|
|
let op_PUSHBACK = 16
|
|
let op_SETMARK = 17
|
|
let op_CHECKPROGRESS = 18
|
|
|
|
(* Encoding of bytecode instructions *)
|
|
|
|
let instr opc arg = opc lor (arg lsl 8)
|
|
|
|
(* Computing relative displacements for GOTO and PUSHBACK instructions *)
|
|
|
|
let displ dest from = dest - from - 1
|
|
|
|
(** Compilation of a regular expression *)
|
|
|
|
(* Determine if a regexp can match the empty string *)
|
|
|
|
let rec is_nullable = function
|
|
Char c -> false
|
|
| String s -> s = ""
|
|
| CharClass(cl, cmpl) -> false
|
|
| Seq rl -> List.for_all is_nullable rl
|
|
| Alt (r1, r2) -> is_nullable r1 || is_nullable r2
|
|
| Star r -> true
|
|
| Plus r -> is_nullable r
|
|
| Option r -> true
|
|
| Group(n, r) -> is_nullable r
|
|
| Refgroup n -> true
|
|
| Bol -> true
|
|
| Eol -> true
|
|
| Wordboundary -> true
|
|
|
|
(* first r returns a set of characters C such that:
|
|
for all string s, s matches r => the first character of s is in C.
|
|
For convenience, return Charset.full if r is nullable. *)
|
|
|
|
let rec first = function
|
|
Char c -> Charset.singleton c
|
|
| String s -> if s = "" then Charset.full else Charset.singleton s.[0]
|
|
| CharClass(cl, cmpl) -> if cmpl then Charset.complement cl else cl
|
|
| Seq rl -> first_seq rl
|
|
| Alt (r1, r2) -> Charset.union (first r1) (first r2)
|
|
| Star r -> Charset.full
|
|
| Plus r -> first r
|
|
| Option r -> Charset.full
|
|
| Group(n, r) -> first r
|
|
| Refgroup n -> Charset.full
|
|
| Bol -> Charset.full
|
|
| Eol -> Charset.full
|
|
| Wordboundary -> Charset.full
|
|
|
|
and first_seq = function
|
|
[] -> Charset.full
|
|
| (Bol | Eol | Wordboundary) :: rl -> first_seq rl
|
|
| Star r :: rl -> Charset.union (first r) (first_seq rl)
|
|
| Option r :: rl -> Charset.union (first r) (first_seq rl)
|
|
| r :: rl -> first r
|
|
|
|
(* Transform a Char or CharClass regexp into a character class *)
|
|
|
|
let charclass_of_regexp fold_case re =
|
|
let (cl1, compl) =
|
|
match re with
|
|
| Char c -> (Charset.singleton c, false)
|
|
| CharClass(cl, compl) -> (cl, compl)
|
|
| _ -> assert false in
|
|
let cl2 = if fold_case then Charset.fold_case cl1 else cl1 in
|
|
Bytes.to_string (if compl then Charset.complement cl2 else cl2)
|
|
|
|
(* The case fold table: maps characters to their lowercase equivalent *)
|
|
|
|
let fold_case_table =
|
|
(let t = Bytes.create 256 in
|
|
for i = 0 to 255 do Bytes.set t i (Char.lowercase(Char.chr i)) done;
|
|
Bytes.to_string t)[@ocaml.warnerror "-3"]
|
|
|
|
module StringMap =
|
|
Map.Make(struct type t = string let compare (x:t) y = compare x y end)
|
|
|
|
(* Compilation of a regular expression *)
|
|
|
|
let compile fold_case re =
|
|
|
|
(* Instruction buffering *)
|
|
let prog = ref (Array.make 32 0)
|
|
and progpos = ref 0
|
|
and cpool = ref StringMap.empty
|
|
and cpoolpos = ref 0
|
|
and numgroups = ref 1
|
|
and numregs = ref 0 in
|
|
(* Add a new instruction *)
|
|
let emit_instr opc arg =
|
|
if !progpos >= Array.length !prog then begin
|
|
let newlen = ref (Array.length !prog) in
|
|
while !progpos >= !newlen do newlen := !newlen * 2 done;
|
|
let nprog = Array.make !newlen 0 in
|
|
Array.blit !prog 0 nprog 0 (Array.length !prog);
|
|
prog := nprog
|
|
end;
|
|
(!prog).(!progpos) <- (instr opc arg);
|
|
incr progpos in
|
|
(* Reserve an instruction slot and return its position *)
|
|
let emit_hole () =
|
|
let p = !progpos in incr progpos; p in
|
|
(* Fill a reserved instruction slot with a GOTO or PUSHBACK instruction *)
|
|
let patch_instr pos opc dest =
|
|
(!prog).(pos) <- (instr opc (displ dest pos)) in
|
|
(* Return the cpool index for the given string, adding it if not
|
|
already there *)
|
|
let cpool_index s =
|
|
try
|
|
StringMap.find s !cpool
|
|
with Not_found ->
|
|
let p = !cpoolpos in
|
|
cpool := StringMap.add s p !cpool;
|
|
incr cpoolpos;
|
|
p in
|
|
(* Allocate fresh register if regexp is nullable *)
|
|
let allocate_register_if_nullable r =
|
|
if is_nullable r then begin
|
|
let n = !numregs in
|
|
if n >= 64 then failwith "too many r* or r+ where r is nullable";
|
|
incr numregs;
|
|
n
|
|
end else
|
|
-1 in
|
|
(* Main recursive compilation function *)
|
|
let rec emit_code = function
|
|
Char c ->
|
|
if fold_case then
|
|
emit_instr op_CHARNORM (Char.code (Char.lowercase c))[@ocaml.warnerror "-3"]
|
|
else
|
|
emit_instr op_CHAR (Char.code c)
|
|
| String s ->
|
|
begin match String.length s with
|
|
0 -> ()
|
|
| 1 ->
|
|
if fold_case then
|
|
emit_instr op_CHARNORM (Char.code (Char.lowercase s.[0]))[@ocaml.warnerror "-3"]
|
|
else
|
|
emit_instr op_CHAR (Char.code s.[0])
|
|
| _ ->
|
|
try
|
|
(* null characters are not accepted by the STRING* instructions;
|
|
if one is found, split string at null character *)
|
|
let i = String.index s '\000' in
|
|
emit_code (String (string_before s i));
|
|
emit_instr op_CHAR 0;
|
|
emit_code (String (string_after s (i+1)))
|
|
with Not_found ->
|
|
if fold_case then
|
|
emit_instr op_STRINGNORM (cpool_index (String.lowercase s))[@ocaml.warnerror "-3"]
|
|
else
|
|
emit_instr op_STRING (cpool_index s)
|
|
end
|
|
| CharClass(cl, compl) ->
|
|
let cl1 = if fold_case then Charset.fold_case cl else cl in
|
|
let cl2 = if compl then Charset.complement cl1 else cl1 in
|
|
emit_instr op_CHARCLASS (cpool_index (Bytes.to_string cl2))
|
|
| Seq rl ->
|
|
emit_seq_code rl
|
|
| Alt(r1, r2) ->
|
|
(* PUSHBACK lbl1
|
|
<match r1>
|
|
GOTO lbl2
|
|
lbl1: <match r2>
|
|
lbl2: ... *)
|
|
let pos_pushback = emit_hole() in
|
|
emit_code r1;
|
|
let pos_goto_end = emit_hole() in
|
|
let lbl1 = !progpos in
|
|
emit_code r2;
|
|
let lbl2 = !progpos in
|
|
patch_instr pos_pushback op_PUSHBACK lbl1;
|
|
patch_instr pos_goto_end op_GOTO lbl2
|
|
| Star r ->
|
|
(* Implement longest match semantics for compatibility with old Str *)
|
|
(* General translation:
|
|
lbl1: PUSHBACK lbl2
|
|
SETMARK regno
|
|
<match r>
|
|
CHECKPROGRESS regno
|
|
GOTO lbl1
|
|
lbl2:
|
|
If r cannot match the empty string, code can be simplified:
|
|
lbl1: PUSHBACK lbl2
|
|
<match r>
|
|
GOTO lbl1
|
|
lbl2:
|
|
*)
|
|
let regno = allocate_register_if_nullable r in
|
|
let lbl1 = emit_hole() in
|
|
if regno >= 0 then emit_instr op_SETMARK regno;
|
|
emit_code r;
|
|
if regno >= 0 then emit_instr op_CHECKPROGRESS regno;
|
|
emit_instr op_GOTO (displ lbl1 !progpos);
|
|
let lbl2 = !progpos in
|
|
patch_instr lbl1 op_PUSHBACK lbl2
|
|
| Plus r ->
|
|
(* Implement longest match semantics for compatibility with old Str *)
|
|
(* General translation:
|
|
lbl1: <match r>
|
|
CHECKPROGRESS regno
|
|
PUSHBACK lbl2
|
|
SETMARK regno
|
|
GOTO lbl1
|
|
lbl2:
|
|
If r cannot match the empty string, code can be simplified:
|
|
lbl1: <match r>
|
|
PUSHBACK lbl2
|
|
GOTO_PLUS lbl1
|
|
lbl2:
|
|
*)
|
|
let regno = allocate_register_if_nullable r in
|
|
let lbl1 = !progpos in
|
|
emit_code r;
|
|
if regno >= 0 then emit_instr op_CHECKPROGRESS regno;
|
|
let pos_pushback = emit_hole() in
|
|
if regno >= 0 then emit_instr op_SETMARK regno;
|
|
emit_instr op_GOTO (displ lbl1 !progpos);
|
|
let lbl2 = !progpos in
|
|
patch_instr pos_pushback op_PUSHBACK lbl2
|
|
| Option r ->
|
|
(* Implement longest match semantics for compatibility with old Str *)
|
|
(* PUSHBACK lbl
|
|
<match r>
|
|
lbl:
|
|
*)
|
|
let pos_pushback = emit_hole() in
|
|
emit_code r;
|
|
let lbl = !progpos in
|
|
patch_instr pos_pushback op_PUSHBACK lbl
|
|
| Group(n, r) ->
|
|
if n >= 32 then failwith "too many \\(...\\) groups";
|
|
emit_instr op_BEGGROUP n;
|
|
emit_code r;
|
|
emit_instr op_ENDGROUP n;
|
|
numgroups := max !numgroups (n+1)
|
|
| Refgroup n ->
|
|
emit_instr op_REFGROUP n
|
|
| Bol ->
|
|
emit_instr op_BOL 0
|
|
| Eol ->
|
|
emit_instr op_EOL 0
|
|
| Wordboundary ->
|
|
emit_instr op_WORDBOUNDARY 0
|
|
|
|
and emit_seq_code = function
|
|
[] -> ()
|
|
| Star(Char _ | CharClass _ as r) :: rl
|
|
when disjoint_modulo_case (first r) (first_seq rl) ->
|
|
emit_instr op_SIMPLESTAR (cpool_index (charclass_of_regexp fold_case r));
|
|
emit_seq_code rl
|
|
| Plus(Char _ | CharClass _ as r) :: rl
|
|
when disjoint_modulo_case (first r) (first_seq rl) ->
|
|
emit_instr op_SIMPLEPLUS (cpool_index (charclass_of_regexp fold_case r));
|
|
emit_seq_code rl
|
|
| Option(Char _ | CharClass _ as r) :: rl
|
|
when disjoint_modulo_case (first r) (first_seq rl) ->
|
|
emit_instr op_SIMPLEOPT (cpool_index (charclass_of_regexp fold_case r));
|
|
emit_seq_code rl
|
|
| r :: rl ->
|
|
emit_code r;
|
|
emit_seq_code rl
|
|
|
|
and disjoint_modulo_case c1 c2 =
|
|
if fold_case
|
|
then Charset.disjoint (Charset.fold_case c1) (Charset.fold_case c2)
|
|
else Charset.disjoint c1 c2
|
|
in
|
|
|
|
emit_code re;
|
|
emit_instr op_ACCEPT 0;
|
|
let start = first re in
|
|
let start' = if fold_case then Charset.fold_case start else start in
|
|
let start_pos =
|
|
if start = Charset.full
|
|
then -1
|
|
else cpool_index (Bytes.to_string (Charset.expand start')) in
|
|
let constantpool = Array.make !cpoolpos "" in
|
|
StringMap.iter (fun str idx -> constantpool.(idx) <- str) !cpool;
|
|
{ prog = Array.sub !prog 0 !progpos;
|
|
cpool = constantpool;
|
|
normtable = if fold_case then fold_case_table else "";
|
|
numgroups = !numgroups;
|
|
numregisters = !numregs;
|
|
startchars = start_pos }
|
|
|
|
(** Parsing of a regular expression *)
|
|
|
|
(* Efficient buffering of sequences *)
|
|
|
|
module SeqBuffer = struct
|
|
|
|
type t = { sb_chars: Buffer.t; mutable sb_next: re_syntax list }
|
|
|
|
let create() = { sb_chars = Buffer.create 16; sb_next = [] }
|
|
|
|
let flush buf =
|
|
let s = Buffer.contents buf.sb_chars in
|
|
Buffer.clear buf.sb_chars;
|
|
match String.length s with
|
|
0 -> ()
|
|
| 1 -> buf.sb_next <- Char s.[0] :: buf.sb_next
|
|
| _ -> buf.sb_next <- String s :: buf.sb_next
|
|
|
|
let add buf re =
|
|
match re with
|
|
Char c -> Buffer.add_char buf.sb_chars c
|
|
| _ -> flush buf; buf.sb_next <- re :: buf.sb_next
|
|
|
|
let extract buf =
|
|
flush buf; Seq(List.rev buf.sb_next)
|
|
|
|
end
|
|
|
|
(* The character class corresponding to `.' *)
|
|
|
|
let dotclass = Charset.complement (Charset.singleton '\n')
|
|
|
|
(* Parse a regular expression *)
|
|
|
|
let parse s =
|
|
let len = String.length s in
|
|
let group_counter = ref 1 in
|
|
|
|
let rec regexp0 i =
|
|
let (r, j) = regexp1 i in
|
|
regexp0cont r j
|
|
and regexp0cont r1 i =
|
|
if i + 2 <= len && s.[i] = '\\' && s.[i+1] = '|' then
|
|
let (r2, j) = regexp1 (i+2) in
|
|
regexp0cont (Alt(r1, r2)) j
|
|
else
|
|
(r1, i)
|
|
and regexp1 i =
|
|
regexp1cont (SeqBuffer.create()) i
|
|
and regexp1cont sb i =
|
|
if i >= len
|
|
|| i + 2 <= len && s.[i] = '\\' && (let c = s.[i+1] in c = '|' || c = ')')
|
|
then
|
|
(SeqBuffer.extract sb, i)
|
|
else
|
|
let (r, j) = regexp2 i in
|
|
SeqBuffer.add sb r;
|
|
regexp1cont sb j
|
|
and regexp2 i =
|
|
let (r, j) = regexp3 i in
|
|
regexp2cont r j
|
|
and regexp2cont r i =
|
|
if i >= len then (r, i) else
|
|
match s.[i] with
|
|
'?' -> regexp2cont (Option r) (i+1)
|
|
| '*' -> regexp2cont (Star r) (i+1)
|
|
| '+' -> regexp2cont (Plus r) (i+1)
|
|
| _ -> (r, i)
|
|
and regexp3 i =
|
|
match s.[i] with
|
|
'\\' -> regexpbackslash (i+1)
|
|
| '[' -> let (c, compl, j) = regexpclass0 (i+1) in
|
|
(CharClass(c, compl), j)
|
|
| '^' -> (Bol, i+1)
|
|
| '$' -> (Eol, i+1)
|
|
| '.' -> (CharClass(dotclass, false), i+1)
|
|
| c -> (Char c, i+1)
|
|
and regexpbackslash i =
|
|
if i >= len then (Char '\\', i) else
|
|
match s.[i] with
|
|
'|' | ')' ->
|
|
assert false
|
|
| '(' ->
|
|
let group_no = !group_counter in
|
|
if group_no < 32 then incr group_counter;
|
|
let (r, j) = regexp0 (i+1) in
|
|
if j + 1 < len && s.[j] = '\\' && s.[j+1] = ')' then
|
|
if group_no < 32
|
|
then (Group(group_no, r), j + 2)
|
|
else (r, j + 2)
|
|
else
|
|
failwith "\\( group not closed by \\)"
|
|
| '1' .. '9' as c ->
|
|
(Refgroup(Char.code c - 48), i + 1)
|
|
| 'b' ->
|
|
(Wordboundary, i + 1)
|
|
| c ->
|
|
(Char c, i + 1)
|
|
and regexpclass0 i =
|
|
if i < len && s.[i] = '^'
|
|
then let (c, j) = regexpclass1 (i+1) in (c, true, j)
|
|
else let (c, j) = regexpclass1 i in (c, false, j)
|
|
and regexpclass1 i =
|
|
let c = Charset.make_empty() in
|
|
let j = regexpclass2 c i i in
|
|
(c, j)
|
|
and regexpclass2 c start i =
|
|
if i >= len then failwith "[ class not closed by ]";
|
|
if s.[i] = ']' && i > start then i+1 else begin
|
|
let c1 = s.[i] in
|
|
if i+2 < len && s.[i+1] = '-' && s.[i+2] <> ']' then begin
|
|
let c2 = s.[i+2] in
|
|
Charset.add_range c c1 c2;
|
|
regexpclass2 c start (i+3)
|
|
end else begin
|
|
Charset.add c c1;
|
|
regexpclass2 c start (i+1)
|
|
end
|
|
end in
|
|
|
|
let (r, j) = regexp0 0 in
|
|
if j = len then r else failwith "spurious \\) in regular expression"
|
|
|
|
(** Parsing and compilation *)
|
|
|
|
let regexp e = compile false (parse e)
|
|
|
|
let regexp_case_fold e = compile true (parse e)
|
|
|
|
let quote s =
|
|
let len = String.length s in
|
|
let buf = Bytes.create (2 * len) in
|
|
let pos = ref 0 in
|
|
for i = 0 to len - 1 do
|
|
match s.[i] with
|
|
'[' | ']' | '*' | '.' | '\\' | '?' | '+' | '^' | '$' as c ->
|
|
Bytes.set buf !pos '\\';
|
|
Bytes.set buf (!pos + 1) c;
|
|
pos := !pos + 2
|
|
| c ->
|
|
Bytes.set buf !pos c;
|
|
pos := !pos + 1
|
|
done;
|
|
Bytes.sub_string buf 0 !pos
|
|
|
|
let regexp_string s = compile false (String s)
|
|
|
|
let regexp_string_case_fold s = compile true (String s)
|
|
|
|
(** Matching functions **)
|
|
|
|
external re_string_match: regexp -> string -> int -> int array
|
|
= "re_string_match"
|
|
external re_partial_match: regexp -> string -> int -> int array
|
|
= "re_partial_match"
|
|
external re_search_forward: regexp -> string -> int -> int array
|
|
= "re_search_forward"
|
|
external re_search_backward: regexp -> string -> int -> int array
|
|
= "re_search_backward"
|
|
|
|
let last_search_result = ref [||]
|
|
|
|
let string_match re s pos =
|
|
let res = re_string_match re s pos in
|
|
last_search_result := res;
|
|
Array.length res > 0
|
|
|
|
let string_partial_match re s pos =
|
|
let res = re_partial_match re s pos in
|
|
last_search_result := res;
|
|
Array.length res > 0
|
|
|
|
let search_forward re s pos =
|
|
let res = re_search_forward re s pos in
|
|
last_search_result := res;
|
|
if Array.length res = 0 then raise Not_found else res.(0)
|
|
|
|
let search_backward re s pos =
|
|
let res = re_search_backward re s pos in
|
|
last_search_result := res;
|
|
if Array.length res = 0 then raise Not_found else res.(0)
|
|
|
|
let group_beginning n =
|
|
let n2 = n + n in
|
|
if n < 0 || n2 >= Array.length !last_search_result then
|
|
invalid_arg "Str.group_beginning"
|
|
else
|
|
let pos = !last_search_result.(n2) in
|
|
if pos = -1 then raise Not_found else pos
|
|
|
|
let group_end n =
|
|
let n2 = n + n in
|
|
if n < 0 || n2 >= Array.length !last_search_result then
|
|
invalid_arg "Str.group_end"
|
|
else
|
|
let pos = !last_search_result.(n2 + 1) in
|
|
if pos = -1 then raise Not_found else pos
|
|
|
|
let matched_group n txt =
|
|
let n2 = n + n in
|
|
if n < 0 || n2 >= Array.length !last_search_result then
|
|
invalid_arg "Str.matched_group"
|
|
else
|
|
let b = !last_search_result.(n2)
|
|
and e = !last_search_result.(n2 + 1) in
|
|
if b = -1 then raise Not_found else String.sub txt b (e - b)
|
|
|
|
let match_beginning () = group_beginning 0
|
|
and match_end () = group_end 0
|
|
and matched_string txt = matched_group 0 txt
|
|
|
|
(** Replacement **)
|
|
|
|
external re_replacement_text: string -> int array -> string -> string
|
|
= "re_replacement_text"
|
|
|
|
let replace_matched repl matched =
|
|
re_replacement_text repl !last_search_result matched
|
|
|
|
let substitute_first expr repl_fun text =
|
|
try
|
|
let pos = search_forward expr text 0 in
|
|
String.concat "" [string_before text pos;
|
|
repl_fun text;
|
|
string_after text (match_end())]
|
|
with Not_found ->
|
|
text
|
|
|
|
let opt_search_forward re s pos =
|
|
try Some(search_forward re s pos) with Not_found -> None
|
|
|
|
let global_substitute expr repl_fun text =
|
|
let rec replace accu start last_was_empty =
|
|
let startpos = if last_was_empty then start + 1 else start in
|
|
if startpos > String.length text then
|
|
string_after text start :: accu
|
|
else
|
|
match opt_search_forward expr text startpos with
|
|
| None ->
|
|
string_after text start :: accu
|
|
| Some pos ->
|
|
let end_pos = match_end() in
|
|
let repl_text = repl_fun text in
|
|
replace (repl_text :: String.sub text start (pos-start) :: accu)
|
|
end_pos (end_pos = pos)
|
|
in
|
|
String.concat "" (List.rev (replace [] 0 false))
|
|
|
|
let global_replace expr repl text =
|
|
global_substitute expr (replace_matched repl) text
|
|
and replace_first expr repl text =
|
|
substitute_first expr (replace_matched repl) text
|
|
|
|
(** Splitting *)
|
|
|
|
let opt_search_forward_progress expr text start =
|
|
match opt_search_forward expr text start with
|
|
| None -> None
|
|
| Some pos ->
|
|
if match_end() > start then
|
|
Some pos
|
|
else if start < String.length text then
|
|
opt_search_forward expr text (start + 1)
|
|
else None
|
|
|
|
let bounded_split expr text num =
|
|
let start =
|
|
if string_match expr text 0 then match_end() else 0 in
|
|
let rec split accu start n =
|
|
if start >= String.length text then accu else
|
|
if n = 1 then string_after text start :: accu else
|
|
match opt_search_forward_progress expr text start with
|
|
| None ->
|
|
string_after text start :: accu
|
|
| Some pos ->
|
|
split (String.sub text start (pos-start) :: accu)
|
|
(match_end()) (n-1)
|
|
in
|
|
List.rev (split [] start num)
|
|
|
|
let split expr text = bounded_split expr text 0
|
|
|
|
let bounded_split_delim expr text num =
|
|
let rec split accu start n =
|
|
if start > String.length text then accu else
|
|
if n = 1 then string_after text start :: accu else
|
|
match opt_search_forward_progress expr text start with
|
|
| None ->
|
|
string_after text start :: accu
|
|
| Some pos ->
|
|
split (String.sub text start (pos-start) :: accu)
|
|
(match_end()) (n-1)
|
|
in
|
|
if text = "" then [] else List.rev (split [] 0 num)
|
|
|
|
let split_delim expr text = bounded_split_delim expr text 0
|
|
|
|
type split_result = Text of string | Delim of string
|
|
|
|
let bounded_full_split expr text num =
|
|
let rec split accu start n =
|
|
if start >= String.length text then accu else
|
|
if n = 1 then Text(string_after text start) :: accu else
|
|
match opt_search_forward_progress expr text start with
|
|
| None ->
|
|
Text(string_after text start) :: accu
|
|
| Some pos ->
|
|
let s = matched_string text in
|
|
if pos > start then
|
|
split (Delim(s) :: Text(String.sub text start (pos-start)) :: accu)
|
|
(match_end()) (n-1)
|
|
else
|
|
split (Delim(s) :: accu)
|
|
(match_end()) (n-1)
|
|
in
|
|
List.rev (split [] 0 num)
|
|
|
|
let full_split expr text = bounded_full_split expr text 0
|