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.7 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 25 26 27 28 29 30 31 32 33 34 35
(** Identifiers *)

type ident = {
  id_short : string;    (* non-unique name for string-based lookup *)
  id_long : string;     (* non-unique name for pretty printing *)
  id_origin : origin;   (* origin of the ident *)
  id_tag : int;         (* unique numeric tag *)
}

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

36
module Id = StructMake (struct
37
  type t = ident
38 39 40 41 42 43
  let tag id = id.id_tag
end)

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

45 46
type preid = ident

47 48
let id_equal = (==)

49 50 51 52
(* constructors *)

let gentag = let r = ref 0 in fun () -> incr r; !r

53 54
let id_register id = { id with id_tag = gentag () }

55 56 57 58
let create_ident short long origin = {
  id_short  = short;
  id_long   = long;
  id_origin = origin;
59
  id_tag    = -1
60 61
}

62 63 64 65 66 67 68 69 70
let id_fresh sh = create_ident sh sh Fresh
let id_fresh_long sh ln = create_ident sh ln Fresh

let id_user sh loc = create_ident sh sh (User loc)
let id_user_long sh ln loc = create_ident sh ln (User loc)

let id_derive sh id = create_ident sh sh (Derived id)
let id_derive_long sh ln id = create_ident sh ln (Derived id)

71
let id_clone id = create_ident id.id_short id.id_long (Derived id)
72
let id_dup id = { id with id_tag = -1 }
73

74
let rec id_derived_from i1 i2 = id_equal i1 i2 ||
75 76 77
  (match i1.id_origin with
    | Derived i3 -> id_derived_from i3 i2
    | _ -> false)
78

79
let rec id_from_user i =
Francois Bobot's avatar
Francois Bobot committed
80 81 82 83 84
  match i.id_origin with
    | Derived i -> id_from_user i
    | User l -> Some l
    | Fresh -> None

85 86
(** Unique names for pretty printing *)

87 88 89 90 91 92
type ident_printer = {
  indices   : (string, int) Hashtbl.t;
  values    : (int, string) Hashtbl.t;
  sanitizer : string -> string;
  blacklist : string list;
}
93 94 95 96 97 98

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 =
99
  let name = try
100 101
    let ind = Hashtbl.find indices name + 1 in
    let ind = find_index indices name ind in
102
    Hashtbl.replace indices name ind;
103
    name ^ string_of_int ind
104 105 106
  with Not_found -> name in
  Hashtbl.replace indices name 0;
  name
107

108 109
let reserve indices name = ignore (find_unique indices name)

110 111
let same x = x

112
let create_ident_printer ?(sanitizer = same) sl =
113
  let indices = Hashtbl.create 1997 in
114 115 116 117 118
  List.iter (reserve indices) sl;
  { indices   = indices;
    values    = Hashtbl.create 1997;
    sanitizer = sanitizer;
    blacklist = sl }
119

120
let id_unique printer ?(sanitizer = same) id =
121
  try
122
    Hashtbl.find printer.values id.id_tag
123
  with Not_found ->
124 125 126
    let name = sanitizer (printer.sanitizer id.id_long) in
    let name = find_unique printer.indices name in
    Hashtbl.replace printer.values id.id_tag name;
127 128
    name

129
let string_unique printer s = find_unique printer.indices s
130

131
let forget_id printer id =
132
  try
133 134 135
    let name = Hashtbl.find printer.values id.id_tag in
    Hashtbl.remove printer.indices name;
    Hashtbl.remove printer.values id.id_tag
136 137
  with Not_found -> ()

138 139 140 141
let forget_all printer =
  Hashtbl.clear printer.indices;
  Hashtbl.clear printer.values;
  List.iter (reserve printer.indices) printer.blacklist
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 176 177 178 179 180 181 182
(** 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