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.42 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.                  *)
(*                                                                        *)
(**************************************************************************)

20 21
open Util

22 23 24
(** Identifiers *)

type ident = {
25 26
  id_string : string;       (* non-unique name *)
  id_origin : origin;       (* origin of the ident *)
Andrei Paskevich's avatar
Andrei Paskevich committed
27
  id_tag    : Hashweak.tag; (* unique magical tag *)
28 29 30 31 32 33 34
}

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

Andrei Paskevich's avatar
Andrei Paskevich committed
35
module Id = WeakStructMake (struct
36
  type t = ident
37 38 39 40 41 42
  let tag id = id.id_tag
end)

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

44 45
type preid = ident

46 47
let id_equal = (==)

Andrei Paskevich's avatar
Andrei Paskevich committed
48
let id_hash id = Hashweak.tag_hash id.id_tag
49

Andrei Paskevich's avatar
Andrei Paskevich committed
50
(* constructors *)
51

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

55 56
let create_ident name origin = {
  id_string = name;
57
  id_origin = origin;
Andrei Paskevich's avatar
Andrei Paskevich committed
58
  id_tag    = Hashweak.dummy_tag;
59 60
}

61 62 63 64
let id_fresh nm = create_ident nm Fresh
let id_user nm loc = create_ident nm (User loc)
let id_derive nm id = create_ident nm (Derived id)
let id_clone id = create_ident id.id_string (Derived id)
Andrei Paskevich's avatar
Andrei Paskevich committed
65
let id_dup id = { id with id_tag = Hashweak.dummy_tag }
66

67
let rec id_derived_from i1 i2 = id_equal i1 i2 ||
68 69 70
  (match i1.id_origin with
    | Derived i3 -> id_derived_from i3 i2
    | _ -> false)
71

72
let rec id_from_user i =
Francois Bobot's avatar
Francois Bobot committed
73 74 75 76 77
  match i.id_origin with
    | Derived i -> id_from_user i
    | User l -> Some l
    | Fresh -> None

78 79
(** Unique names for pretty printing *)

80 81
type ident_printer = {
  indices   : (string, int) Hashtbl.t;
Andrei Paskevich's avatar
Andrei Paskevich committed
82
  values    : string Hid.t;
83 84 85
  sanitizer : string -> string;
  blacklist : string list;
}
86 87 88 89 90 91

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 =
92
  let name = try
93 94
    let ind = Hashtbl.find indices name + 1 in
    let ind = find_index indices name ind in
95
    Hashtbl.replace indices name ind;
96
    name ^ string_of_int ind
97 98 99
  with Not_found -> name in
  Hashtbl.replace indices name 0;
  name
100

101 102
let reserve indices name = ignore (find_unique indices name)

103 104
let same x = x

105
let create_ident_printer ?(sanitizer = same) sl =
106
  let indices = Hashtbl.create 1997 in
107 108
  List.iter (reserve indices) sl;
  { indices   = indices;
Andrei Paskevich's avatar
Andrei Paskevich committed
109
    values    = Hid.create 1997;
110 111
    sanitizer = sanitizer;
    blacklist = sl }
112

113
let id_unique printer ?(sanitizer = same) id =
114
  try
Andrei Paskevich's avatar
Andrei Paskevich committed
115
    Hid.find printer.values id
116
  with Not_found ->
117
    let name = sanitizer (printer.sanitizer id.id_string) in
118
    let name = find_unique printer.indices name in
Andrei Paskevich's avatar
Andrei Paskevich committed
119
    Hid.replace printer.values id name;
120 121
    name

122
let string_unique printer s = find_unique printer.indices s
123

124
let forget_id printer id =
125
  try
Andrei Paskevich's avatar
Andrei Paskevich committed
126
    let name = Hid.find printer.values id in
127
    Hashtbl.remove printer.indices name;
Andrei Paskevich's avatar
Andrei Paskevich committed
128
    Hid.remove printer.values id
129 130
  with Not_found -> ()

131
let forget_all printer =
Andrei Paskevich's avatar
Andrei Paskevich committed
132
  Hid.clear printer.values;
133 134
  Hashtbl.clear printer.indices;
  List.iter (reserve printer.indices) printer.blacklist
135

136 137 138 139 140 141 142 143 144 145 146 147 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
(** 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