Maj terminée. Pour consulter la release notes associée voici le lien :
https://about.gitlab.com/releases/2021/07/07/critical-security-release-gitlab-14-0-4-released/

ident.ml 5.74 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
(**************************************************************************)
(*                                                                        *)
(*  Copyright (C) 2010-                                                   *)
(*    Francois Bobot                                                      *)
(*    Jean-Christophe Filliatre                                           *)
(*    Johannes Kanig                                                      *)
(*    Andrei Paskevich                                                    *)
(*                                                                        *)
(*  This software is free software; you can redistribute it and/or        *)
(*  modify it under the terms of the GNU Library General Public           *)
(*  License version 2.1, with the special exception on linking            *)
(*  described in file LICENSE.                                            *)
(*                                                                        *)
(*  This software 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.                  *)
(*                                                                        *)
(**************************************************************************)

François Bobot's avatar
François Bobot committed
20
open Stdlib
21 22
open Util

MARCHE Claude's avatar
MARCHE Claude committed
23 24 25 26 27 28
(** Labels *)

type label = string * Loc.position option

let label ?loc s = (s,loc)

29 30 31
(** Identifiers *)

type ident = {
32 33
  id_string : string;       (* non-unique name *)
  id_origin : origin;       (* origin of the ident *)
Andrei Paskevich's avatar
Andrei Paskevich committed
34
  id_label  : label list;   (* identifier labels *)
Andrei Paskevich's avatar
Andrei Paskevich committed
35
  id_tag    : Hashweak.tag; (* unique magical tag *)
36 37 38 39 40 41 42
}

and origin =
  | User of Loc.position
  | Derived of ident
  | Fresh

Andrei Paskevich's avatar
Andrei Paskevich committed
43
module Id = WeakStructMake (struct
44
  type t = ident
45 46 47 48 49 50
  let tag id = id.id_tag
end)

module Sid = Id.S
module Mid = Id.M
module Hid = Id.H
51

52 53
type preid = ident

54 55
let id_equal = (==)

Andrei Paskevich's avatar
Andrei Paskevich committed
56
let id_hash id = Hashweak.tag_hash id.id_tag
57

Andrei Paskevich's avatar
Andrei Paskevich committed
58
(* constructors *)
59

Andrei Paskevich's avatar
Andrei Paskevich committed
60 61
let id_register = let r = ref 0 in fun id ->
  { id with id_tag = (incr r; Hashweak.create_tag !r) }
62

Andrei Paskevich's avatar
Andrei Paskevich committed
63
let create_ident name origin labels = {
64
  id_string = name;
65
  id_origin = origin;
Andrei Paskevich's avatar
Andrei Paskevich committed
66
  id_label  = labels;
Andrei Paskevich's avatar
Andrei Paskevich committed
67
  id_tag    = Hashweak.dummy_tag;
68 69
}

Andrei Paskevich's avatar
Andrei Paskevich committed
70 71 72 73 74 75 76 77 78
let id_fresh ?(labels = []) nm = create_ident nm Fresh labels
let id_user ?(labels = []) nm loc = create_ident nm (User loc) labels
let id_derive ?(labels = []) nm id = create_ident nm (Derived id) labels

let id_clone ?(labels = []) id =
  create_ident id.id_string (Derived id) (labels @ id.id_label)

let id_dup ?(labels = []) id =
  create_ident id.id_string id.id_origin (labels @ id.id_label)
79

80
let rec id_derived_from i1 i2 = id_equal i1 i2 ||
81 82 83
  (match i1.id_origin with
    | Derived i3 -> id_derived_from i3 i2
    | _ -> false)
84

85
let rec id_from_user i =
Francois Bobot's avatar
Francois Bobot committed
86 87 88 89 90
  match i.id_origin with
    | Derived i -> id_from_user i
    | User l -> Some l
    | Fresh -> None

91 92
(** Unique names for pretty printing *)

93 94
type ident_printer = {
  indices   : (string, int) Hashtbl.t;
Andrei Paskevich's avatar
Andrei Paskevich committed
95
  values    : string Hid.t;
96 97 98
  sanitizer : string -> string;
  blacklist : string list;
}
99 100 101 102 103 104

let rec find_index indices name ind =
  if Hashtbl.mem indices (name ^ string_of_int ind)
  then find_index indices name (succ ind) else ind

let find_unique indices name =
105
  let name = try
106 107
    let ind = Hashtbl.find indices name + 1 in
    let ind = find_index indices name ind in
108
    Hashtbl.replace indices name ind;
109
    name ^ string_of_int ind
110 111 112
  with Not_found -> name in
  Hashtbl.replace indices name 0;
  name
113

114 115
let reserve indices name = ignore (find_unique indices name)

116 117
let same x = x

118
let create_ident_printer ?(sanitizer = same) sl =
119
  let indices = Hashtbl.create 1997 in
120 121
  List.iter (reserve indices) sl;
  { indices   = indices;
Andrei Paskevich's avatar
Andrei Paskevich committed
122
    values    = Hid.create 1997;
123 124
    sanitizer = sanitizer;
    blacklist = sl }
125

126
let id_unique printer ?(sanitizer = same) id =
127
  try
Andrei Paskevich's avatar
Andrei Paskevich committed
128
    Hid.find printer.values id
129
  with Not_found ->
130
    let name = sanitizer (printer.sanitizer id.id_string) in
131
    let name = find_unique printer.indices name in
Andrei Paskevich's avatar
Andrei Paskevich committed
132
    Hid.replace printer.values id name;
133 134
    name

135
let string_unique printer s = find_unique printer.indices s
136

137
let forget_id printer id =
138
  try
Andrei Paskevich's avatar
Andrei Paskevich committed
139
    let name = Hid.find printer.values id in
140
    Hashtbl.remove printer.indices name;
Andrei Paskevich's avatar
Andrei Paskevich committed
141
    Hid.remove printer.values id
142 143
  with Not_found -> ()

144
let forget_all printer =
Andrei Paskevich's avatar
Andrei Paskevich committed
145
  Hid.clear printer.values;
146 147
  Hashtbl.clear printer.indices;
  List.iter (reserve printer.indices) printer.blacklist
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
(** Sanitizers *)

exception Unsanitizable

let char_to_alpha c = match c with
  | 'a'..'z' | 'A'..'Z' -> String.make 1 c
  | ' ' -> "sp" | '_'  -> "us" | '#' -> "sh"
  | '`' -> "bq" | '~'  -> "tl" | '!' -> "ex"
  | '@' -> "at" | '$'  -> "dl" | '%' -> "pc"
  | '^' -> "cf" | '&'  -> "et" | '*' -> "as"
  | '(' -> "lp" | ')'  -> "rp" | '-' -> "mn"
  | '+' -> "pl" | '='  -> "eq" | '[' -> "lb"
  | ']' -> "rb" | '{'  -> "lc" | '}' -> "rc"
  | ':' -> "cl" | '\'' -> "qt" | '"' -> "dq"
  | '<' -> "ls" | '>'  -> "gt" | '/' -> "sl"
  | '?' -> "qu" | '\\' -> "bs" | '|' -> "br"
  | ';' -> "sc" | ','  -> "cm" | '.' -> "dt"
  | '0' -> "zr" | '1'  -> "un" | '2' -> "du"
  | '3' -> "tr" | '4'  -> "qr" | '5' -> "qn"
  | '6' -> "sx" | '7'  -> "st" | '8' -> "oc"
  | '9' -> "nn" | _ -> raise Unsanitizable

let char_to_lalpha c = String.uncapitalize (char_to_alpha c)
let char_to_ualpha c = String.capitalize (char_to_alpha c)

let char_to_alnum c =
  match c with '0'..'9' -> String.make 1 c | _ -> char_to_alpha c

let char_to_alnumus c =
  match c with '_' | ' ' -> "_" | _ -> char_to_alnum c

let sanitizer head rest n =
  let lst = ref [] in
  let code c = lst := rest c :: !lst in
  let n = if n = "" then "zilch" else n in
  String.iter code n;
  let rst = List.tl (List.rev !lst) in
  let cs = head (String.get n 0) :: rst in
  String.concat "" cs