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.62 KB
Newer Older
1 2
(**************************************************************************)
(*                                                                        *)
3
(*  Copyright (C) 2010-2011                                               *)
4 5 6
(*    François Bobot                                                      *)
(*    Jean-Christophe Filliâtre                                           *)
(*    Claude Marché                                                       *)
7 8 9 10 11 12 13 14 15 16 17 18 19
(*    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
(** Labels *)

25
type label = string
MARCHE Claude's avatar
MARCHE Claude committed
26

27 28 29
(** Identifiers *)

type ident = {
30 31 32 33
  id_string : string;               (* non-unique name *)
  id_label  : label list;           (* identifier labels *)
  id_loc    : Loc.position option;  (* optional location *)
  id_tag    : Hashweak.tag;         (* unique magical tag *)
34 35
}

Andrei Paskevich's avatar
Andrei Paskevich committed
36
module Id = WeakStructMake (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
let id_equal : ident -> ident -> bool = (==)
48

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

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

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

56
let create_ident name labels loc = {
57
  id_string = name;
Andrei Paskevich's avatar
Andrei Paskevich committed
58
  id_label  = labels;
59
  id_loc    = loc;
Andrei Paskevich's avatar
Andrei Paskevich committed
60
  id_tag    = Hashweak.dummy_tag;
61 62
}

63 64
let id_fresh ?(label = []) ?loc nm =
  create_ident nm label loc
Andrei Paskevich's avatar
Andrei Paskevich committed
65

66 67
let id_user ?(label = []) nm loc =
  create_ident nm label (Some loc)
68

69 70
let id_clone ?(label = []) id =
  create_ident id.id_string (label @ id.id_label) id.id_loc
71

72 73
let id_derive ?(label = []) nm id =
  create_ident nm (label @ id.id_label) id.id_loc
Francois Bobot's avatar
Francois Bobot committed
74

75 76
(** Unique names for pretty printing *)

77 78
type ident_printer = {
  indices   : (string, int) Hashtbl.t;
Andrei Paskevich's avatar
Andrei Paskevich committed
79
  values    : string Hid.t;
80 81 82
  sanitizer : string -> string;
  blacklist : string list;
}
83 84

let find_unique indices name =
85 86 87 88 89 90 91 92
  let specname ind = name ^ string_of_int ind in
  let testname ind = Hashtbl.mem indices (specname ind) in
  let rec advance ind =
    if testname ind then advance (succ ind) else ind in
  let rec retreat ind =
    if ind = 1 || testname (pred ind) then ind else retreat (pred ind) in
  let fetch ind =
    if testname ind then advance (succ ind) else retreat ind in
93
  let name = try
94
    let ind = fetch (succ (Hashtbl.find indices name)) in
95
    Hashtbl.replace indices name ind;
96
    specname 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
(** Sanitizers *)

138
let unsanitizable = Debug.register_flag "unsanitizable"
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155

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"
156 157 158 159
  | '9' -> "nn" | '\n' -> "br"
  | _ ->
    Debug.dprintf unsanitizable "Unsanitizable : '%c' can't be sanitized@." c;
    "zz"
160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177

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