helm/DEVEL/pxp/netstring/netencoding.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  *
   4  *)
   5
   6
   7 module Str = Netstring_str;;
   8
   9 module Base64 = struct
  10   let b64_pattern plus slash =
  11     [| 'A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M';
  12        'N'; 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z';
  13        'a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g'; 'h'; 'i'; 'j'; 'k'; 'l'; 'm';
  14        'n'; 'o'; 'p'; 'q'; 'r'; 's'; 't'; 'u'; 'v'; 'w'; 'x'; 'y'; 'z';
  15        '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; plus; slash |];;
  16
  17
  18   let rfc_pattern = b64_pattern '+' '/';;
  19   let url_pattern = b64_pattern '-' '/';;
  20
  21   let encode_with_options b64 equal s pos len linelen crlf =
  22   (* encode using "base64".
  23    * 'b64': The encoding table, created by b64_pattern.
  24    * 'equal': The character that should be used instead of '=' in the original
  25    *          encoding scheme. Pass '=' to get the original encoding scheme.
  26    * s, pos, len, linelen: See the interface description of encode_substring.
  27    *)
  28     assert (Array.length b64 = 64);
  29     if len < 0 or pos < 0 or pos > String.length s or linelen < 0 then
  30       invalid_arg "Netencoding.Base64.encode_with_options";
  31     if pos + len > String.length s then
  32       invalid_arg "Netencoding.Base64.encode_with_options";
  33
  34     let linelen =
  35       (linelen/4) * 4 in
  36
  37     let l_t = if len = 0 then 0 else ((len - 1) / 3 + 1) * 4 in
  38     (* l_t: length of the result without additional line endings *)
  39
  40     let l_t' =
  41       if linelen < 4 then
  42         l_t
  43       else
  44         if l_t = 0 then 0 else
  45           let n_lines = ((l_t - 1) / linelen) + 1 in
  46           l_t + n_lines * (if crlf then 2 else 1)
  47     in
  48     (* l_t': length of the result with CRLF or LF characters *)
  49
  50     let t = String.make l_t' equal in
  51     let j = ref 0 in
  52     let q = ref 0 in
  53     for k = 0 to len / 3 - 1 do
  54       let p = pos + 3*k in
  55       (* p >= pos >= 0: this is evident
  56        * p+2 < pos+len <= String.length s:
  57        *   Because k <= len/3-1
  58        *         3*k <= 3*(len/3-1) = len - 3
  59        *   pos+3*k+2 <= pos + len - 3 + 2 = pos + len - 1 < pos + len
  60        * So it is proved that the following unsafe string accesses always
  61        * work.
  62        *)
  63       let bits = (Char.code (String.unsafe_get s (p))   lsl 16) lor
  64                  (Char.code (String.unsafe_get s (p+1)) lsl  8) lor
  65                  (Char.code (String.unsafe_get s (p+2))) in
  66       (* Obviously, 'bits' is a 24 bit entity (i.e. bits < 2**24) *)
  67       assert(!j + 3 < l_t');
  68       String.unsafe_set t !j     (Array.unsafe_get b64 ( bits lsr 18));
  69       String.unsafe_set t (!j+1) (Array.unsafe_get b64 ((bits lsr 12) land 63));
  70       String.unsafe_set t (!j+2) (Array.unsafe_get b64 ((bits lsr  6) land 63));
  71       String.unsafe_set t (!j+3) (Array.unsafe_get b64 ( bits         land 63));
  72       j := !j + 4;
  73       if linelen > 3 then begin
  74         q := !q + 4;
  75         if !q + 4 > linelen then begin
  76           (* The next 4 characters won't fit on the current line. So insert
  77            * a line ending.
  78            *)
  79           if crlf then begin
  80             t.[ !j ] <- '\013';
  81             t.[ !j+1 ] <- '\010';
  82             j := !j + 2;
  83           end
  84           else begin
  85             t.[ !j ] <- '\010';
  86             incr j
  87           end;
  88           q := 0;
  89         end;
  90       end;
  91     done;
  92     (* padding if needed: *)
  93     let m = len mod 3 in
  94     begin
  95       match m with
  96           0 -> ()
  97         | 1 ->
  98             let bits = Char.code (s.[pos + len - 1]) in
  99             t.[ !j     ] <- b64.( bits lsr 2);
 100             t.[ !j + 1 ] <- b64.( (bits land 0x03) lsl 4);
 101             j := !j + 4;
 102             q := !q + 4;
 103         | 2 ->
 104             let bits = (Char.code (s.[pos + len - 2]) lsl 8) lor
 105                        (Char.code (s.[pos + len - 1])) in
 106             t.[ !j     ] <- b64.( bits lsr 10);
 107             t.[ !j + 1 ] <- b64.((bits lsr  4) land 0x3f);
 108             t.[ !j + 2 ] <- b64.((bits lsl  2) land 0x3f);
 109             j := !j + 4;
 110             q := !q + 4;
 111         | _ -> assert false
 112     end;
 113
 114     (* If required, add another line end: *)
 115
 116     if linelen > 3 & !q > 0 then begin
 117       if crlf then begin
 118         t.[ !j ] <- '\013';
 119         t.[ !j+1 ] <- '\010';
 120         j := !j + 2;
 121       end
 122       else begin
 123         t.[ !j ] <- '\010';
 124         incr j
 125       end;
 126     end;
 127
 128     t ;;
 129
 130
 131
 132   let encode ?(pos=0) ?len ?(linelength=0) ?(crlf=false) s =
 133     let l = match len with None -> String.length s - pos | Some x -> x in
 134     encode_with_options rfc_pattern '=' s pos l linelength crlf;;
 135
 136
 137   let encode_substring s ~pos ~len ~linelength ~crlf =
 138     encode_with_options rfc_pattern '=' s pos len linelength crlf;;
 139
 140
 141   let url_encode ?(pos=0) ?len ?(linelength=0) ?(crlf=false) s =
 142     let l = match len with None -> String.length s - pos | Some x -> x in
 143     encode_with_options url_pattern '.' s pos l linelength crlf;;
 144
 145
 146   let decode_substring t ~pos ~len ~url_variant:p_url ~accept_spaces:p_spaces =
 147     if len < 0 or pos < 0 or pos > String.length t then
 148       invalid_arg "Netencoding.Base64.decode_substring";
 149     if pos + len > String.length t then
 150       invalid_arg "Netencoding.Base64.decode_substring";
 151
 152     (* Compute the number of effective characters l_t in 't';
 153      * pad_chars: number of '=' characters at the end of the string.
 154      *)
 155     let l_t, pad_chars =
 156       if p_spaces then begin
 157         (* Count all non-whitespace characters: *)
 158         let c = ref 0 in
 159         let p = ref 0 in
 160         for i = pos to pos + len - 1 do
 161           match String.unsafe_get t i with
 162               (' '|'\t'|'\r'|'\n') -> ()
 163             | ('='|'.') as ch ->
 164                 if ch = '.' & not p_url then
 165                   invalid_arg "Netencoding.Base64.decode_substring";
 166                 incr c;
 167                 incr p;
 168                 if !p > 2 then
 169                   invalid_arg "Netencoding.Base64.decode_substring";
 170                 for j = i+1 to pos + len - 1 do
 171                   match String.unsafe_get t j with
 172                       (' '|'\t'|'\r'|'\n'|'.'|'=') -> ()
 173                     | _ ->
 174                         (* Only another '=' or spaces allowed *)
 175                         invalid_arg "Netencoding.Base64.decode_substring";
 176                 done
 177             | _ -> incr c
 178         done;
 179         if !c mod 4 <> 0 then
 180           invalid_arg "Netencoding.Base64.decode_substring";
 181         !c, !p
 182       end
 183       else
 184         len,
 185         ( if len mod 4 <> 0 then
 186             invalid_arg "Netencoding.Base64.decode_substring";
 187           if len > 0 then (
 188             if String.sub t (len - 2) 2 = "==" or
 189                (p_url & String.sub t (len - 2) 2 = "..") then 2
 190             else
 191               if String.sub t (len - 1) 1 = "=" or
 192                  (p_url & String.sub t (len - 1) 1 = ".") then 1
 193               else
 194                 0
 195           )
 196           else 0
 197         )
 198     in
 199
 200     let l_s = (l_t / 4) * 3 - pad_chars in       (* sic! *)
 201     let s = String.create l_s in
 202
 203     let decode_char c =
 204       match c with
 205           'A' .. 'Z'  -> Char.code(c) - 65     (* 65 = Char.code 'A' *)
 206         | 'a' .. 'z'  -> Char.code(c) - 71     (* 71 = Char.code 'a' - 26 *)
 207         | '0' .. '9'  -> Char.code(c) + 4      (* -4 = Char.code '0' - 52 *)
 208         | '+'         -> 62
 209         | '-'         -> if not p_url then
 210                            invalid_arg "Netencoding.Base64.decode_substring";
 211                          62
 212         | '/'         -> 63
 213         | _           -> invalid_arg "Netencoding.Base64.decode_substring";
 214     in
 215
 216     (* Decode all but the last quartet: *)
 217
 218     let cursor = ref pos in
 219     let rec next_char() =
 220       match t.[ !cursor ] with
 221           (' '|'\t'|'\r'|'\n') ->
 222             if p_spaces then (incr cursor; next_char())
 223             else invalid_arg "Netencoding.Base64.decode_substring"
 224         | c ->
 225             incr cursor; c
 226     in
 227
 228     if p_spaces then begin
 229       for k = 0 to l_t / 4 - 2 do
 230         let q = 3*k in
 231         let c0 = next_char() in
 232         let c1 = next_char() in
 233         let c2 = next_char() in
 234         let c3 = next_char() in
 235         let n0 = decode_char c0 in
 236         let n1 = decode_char c1 in
 237         let n2 = decode_char c2 in
 238         let n3 = decode_char c3 in
 239         let x0 = (n0 lsl 2) lor (n1 lsr 4) in
 240         let x1 = ((n1 lsl 4) land 0xf0) lor (n2 lsr 2) in
 241         let x2 = ((n2 lsl 6) land 0xc0) lor n3 in
 242         String.unsafe_set s q     (Char.chr x0);
 243         String.unsafe_set s (q+1) (Char.chr x1);
 244         String.unsafe_set s (q+2) (Char.chr x2);
 245       done;
 246     end
 247     else begin
 248       (* Much faster: *)
 249       for k = 0 to l_t / 4 - 2 do
 250         let p = pos + 4*k in
 251         let q = 3*k in
 252         let c0 = String.unsafe_get t p in
 253         let c1 = String.unsafe_get t (p + 1) in
 254         let c2 = String.unsafe_get t (p + 2) in
 255         let c3 = String.unsafe_get t (p + 3) in
 256         let n0 = decode_char c0 in
 257         let n1 = decode_char c1 in
 258         let n2 = decode_char c2 in
 259         let n3 = decode_char c3 in
 260         let x0 = (n0 lsl 2) lor (n1 lsr 4) in
 261         let x1 = ((n1 lsl 4) land 0xf0) lor (n2 lsr 2) in
 262         let x2 = ((n2 lsl 6) land 0xc0) lor n3 in
 263         String.unsafe_set s q     (Char.chr x0);
 264         String.unsafe_set s (q+1) (Char.chr x1);
 265         String.unsafe_set s (q+2) (Char.chr x2);
 266       done;
 267       cursor := pos + l_t - 4;
 268     end;
 269
 270     (* Decode the last quartet: *)
 271
 272     if l_t > 0 then begin
 273       let q = 3*(l_t / 4 - 1) in
 274       let c0 = next_char() in
 275       let c1 = next_char() in
 276       let c2 = next_char() in
 277       let c3 = next_char() in
 278
 279       if (c2 = '=' & c3 = '=') or (p_url & c2 = '.' & c3 = '.') then begin
 280         let n0 = decode_char c0 in
 281         let n1 = decode_char c1 in
 282         let x0 = (n0 lsl 2) lor (n1 lsr 4) in
 283         s.[ q ]   <- Char.chr x0;
 284       end
 285       else
 286         if (c3 = '=') or (p_url & c3 = '.') then begin
 287           let n0 = decode_char c0 in
 288           let n1 = decode_char c1 in
 289           let n2 = decode_char c2 in
 290           let x0 = (n0 lsl 2) lor (n1 lsr 4) in
 291           let x1 = ((n1 lsl 4) land 0xf0) lor (n2 lsr 2) in
 292           s.[ q ]   <- Char.chr x0;
 293           s.[ q+1 ] <- Char.chr x1;
 294         end
 295         else begin
 296           let n0 = decode_char c0 in
 297           let n1 = decode_char c1 in
 298           let n2 = decode_char c2 in
 299           let n3 = decode_char c3 in
 300           let x0 = (n0 lsl 2) lor (n1 lsr 4) in
 301           let x1 = ((n1 lsl 4) land 0xf0) lor (n2 lsr 2) in
 302           let x2 = ((n2 lsl 6) land 0xc0) lor n3 in
 303           s.[ q ]   <- Char.chr x0;
 304           s.[ q+1 ] <- Char.chr x1;
 305           s.[ q+2 ] <- Char.chr x2;
 306         end
 307
 308     end;
 309
 310     s ;;
 311
 312
 313
 314   let decode ?(pos=0) ?len ?(url_variant=true) ?(accept_spaces=false) s =
 315     let l = match len with None -> String.length s - pos | Some x -> x in
 316     decode_substring s pos l url_variant accept_spaces;;
 317
 318   let decode_ignore_spaces s =
 319     decode_substring s 0 (String.length s) true true;;
 320
 321
 322 end
 323
 324
 325
 326 module QuotedPrintable = struct
 327
 328   let encode_substring s ~pos ~len =
 329
 330     if len < 0 or pos < 0 or pos > String.length s then
 331       invalid_arg "Netencoding.QuotedPrintable.encode_substring";
 332     if pos + len > String.length s then
 333       invalid_arg "Netencoding.QuotedPrintable.encode_substring";
 334
 335     let rec count n i =
 336       if i < len then
 337         match String.unsafe_get s (pos+i) with
 338             ('\r'|'\n') ->
 339               count (n+1) (i+1)
 340           | ('\000'..'\031'|'\127'..'\255'|
 341              '!'|'"'|'#'|'$'|'@'|'['|']'|'^'|'\''|'{'|'|'|'}'|'~'|'=') ->
 342               count (n+3) (i+1)
 343           | ' ' ->
 344               (* Protect spaces only if they occur at the end of a line *)
 345               if i+1 < len then
 346                 match s.[pos+i+1] with
 347                     ('\r'|'\n') ->
 348                       count (n+3) (i+1)
 349                   | _ ->
 350                       count (n+1) (i+1)
 351               else
 352                 count (n+3) (i+1)
 353           | _ ->
 354               count (n+1) (i+1)
 355       else
 356         n
 357     in
 358
 359     let l = count 0 0 in
 360     let t = String.create l in
 361
 362     let hexdigit =
 363       [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7';
 364          '8'; '9'; 'A'; 'B'; 'C'; 'D'; 'E'; 'F'; |] in
 365
 366     let k = ref 0 in
 367
 368     let add_quoted c =
 369       t.[ !k ]   <- '=';
 370       t.[ !k+1 ] <- hexdigit.( Char.code c lsr 4 );
 371       t.[ !k+2 ] <- hexdigit.( Char.code c land 15 )
 372     in
 373
 374     for i = 0 to len - 1 do
 375       match String.unsafe_get s i with
 376           ('\r'|'\n') as c ->
 377             String.unsafe_set t !k c;
 378             incr k
 379         | ('\000'..'\031'|'\127'..'\255'|
 380            '!'|'"'|'#'|'$'|'@'|'['|']'|'^'|'\''|'{'|'|'|'}'|'~'|'=') as c ->
 381             add_quoted c;
 382             k := !k + 3
 383         | ' ' ->
 384             (* Protect spaces only if they occur at the end of a line *)
 385             if i+1 < len then
 386               match s.[pos+i+1] with
 387                   ('\r'|'\n') ->
 388                     add_quoted ' ';
 389                     k := !k + 3;
 390                 | _ ->
 391                     String.unsafe_set t !k ' ';
 392                     incr k
 393             else begin
 394               add_quoted ' ';
 395               k := !k + 3;
 396             end
 397         | c ->
 398             String.unsafe_set t !k c;
 399             incr k
 400     done;
 401
 402     t ;;
 403
 404
 405   let encode ?(pos=0) ?len s =
 406     let l = match len with None -> String.length s - pos | Some x -> x in
 407     encode_substring s pos l;;
 408
 409
 410
 411   let decode_substring s ~pos ~len =
 412
 413     if len < 0 or pos < 0 or pos > String.length s then
 414       invalid_arg "Netencoding.QuotedPrintable.decode_substring";
 415     if pos + len > String.length s then
 416       invalid_arg "Netencoding.QuotedPrintable.decode_substring";
 417
 418     let decode_hex c =
 419       match c with
 420           '0'..'9' -> Char.code c - 48
 421         | 'A'..'F' -> Char.code c - 55
 422         | 'a'..'f' -> Char.code c - 87
 423         | _ ->
 424            invalid_arg "Netencoding.QuotedPrintable.decode_substring";
 425     in
 426
 427     let rec count n i =
 428       if i < len then
 429         match String.unsafe_get s (pos+i) with
 430             '=' ->
 431               if i+1 = len then
 432                 (* A '=' at EOF is ignored *)
 433                 count n (i+1)
 434               else
 435                 if i+1 < len then
 436                   match s.[pos+i+1] with
 437                       '\r' ->
 438                         (* Official soft break *)
 439                         if i+2 < len & s.[pos+i+2] = '\n' then
 440                           count n (i+3)
 441                         else
 442                           count n (i+2)
 443                     | '\n' ->
 444                         (* Inofficial soft break *)
 445                         count n (i+2)
 446                     | _ ->
 447                         if i+2 >= len then
 448                           invalid_arg
 449                             "Netencoding.QuotedPrintable.decode_substring";
 450                         let _ = decode_hex s.[pos+i+1] in
 451                         let _ = decode_hex s.[pos+i+2] in
 452                         count (n+1) (i+3)
 453                 else
 454                   invalid_arg "Netencoding.QuotedPrintable.decode_substring"
 455           | _ ->
 456               count (n+1) (i+1)
 457       else
 458         n
 459     in
 460
 461     let l = count 0 0 in
 462     let t = String.create l in
 463     let k = ref pos in
 464     let e = pos + len in
 465     let i = ref 0 in
 466
 467     while !i < l do
 468       match String.unsafe_get s !k with
 469           '=' ->
 470             if !k+1 = e then
 471               (* A '=' at EOF is ignored *)
 472               ()
 473             else
 474               if !k+1 < e then
 475                 match s.[!k+1] with
 476                     '\r' ->
 477                       (* Official soft break *)
 478                       if !k+2 < e & s.[!k+2] = '\n' then
 479                         k := !k + 3
 480                       else
 481                         k := !k + 2
 482                   | '\n' ->
 483                       (* Inofficial soft break *)
 484                       k := !k + 2
 485                   | _ ->
 486                       if !k+2 >= e then
 487                         invalid_arg
 488                           "Netencoding.QuotedPrintable.decode_substring";
 489                       let x1 = decode_hex s.[!k+1] in
 490                       let x2 = decode_hex s.[!k+2] in
 491                       t.[ !i ] <- Char.chr ((x1 lsl 4) lor x2);
 492                       k := !k + 3;
 493                       incr i
 494               else
 495                 invalid_arg "Netencoding.QuotedPrintable.decode_substring"
 496         | c ->
 497             String.unsafe_set t !i c;
 498             incr k;
 499             incr i
 500     done;
 501
 502     t ;;
 503
 504
 505   let decode ?(pos=0) ?len s =
 506     let l = match len with None -> String.length s - pos | Some x -> x in
 507     decode_substring s pos l;;
 508
 509 end
 510
 511
 512 module Q = struct
 513
 514   let encode_substring s ~pos ~len =
 515
 516     if len < 0 or pos < 0 or pos > String.length s then
 517       invalid_arg "Netencoding.Q.encode_substring";
 518     if pos + len > String.length s then
 519       invalid_arg "Netencoding.Q.encode_substring";
 520
 521     let rec count n i =
 522       if i < len then
 523         match String.unsafe_get s (pos+i) with
 524           | ('A'..'Z'|'a'..'z'|'0'..'9') ->
 525               count (n+1) (i+1)
 526           | _ ->
 527               count (n+3) (i+1)
 528       else
 529         n
 530     in
 531
 532     let l = count 0 0 in
 533     let t = String.create l in
 534
 535     let hexdigit =
 536       [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7';
 537          '8'; '9'; 'A'; 'B'; 'C'; 'D'; 'E'; 'F'; |] in
 538
 539     let k = ref 0 in
 540
 541     let add_quoted c =
 542       t.[ !k ]   <- '=';
 543       t.[ !k+1 ] <- hexdigit.( Char.code c lsr 4 );
 544       t.[ !k+2 ] <- hexdigit.( Char.code c land 15 )
 545     in
 546
 547     for i = 0 to len - 1 do
 548       match String.unsafe_get s i with
 549         | ('A'..'Z'|'a'..'z'|'0'..'9') as c ->
 550             String.unsafe_set t !k c;
 551             incr k
 552         | c ->
 553             add_quoted c;
 554             k := !k + 3
 555     done;
 556
 557     t ;;
 558
 559
 560   let encode ?(pos=0) ?len s =
 561     let l = match len with None -> String.length s - pos | Some x -> x in
 562     encode_substring s pos l;;
 563
 564
 565
 566   let decode_substring s ~pos ~len =
 567
 568     if len < 0 or pos < 0 or pos > String.length s then
 569       invalid_arg "Netencoding.Q.decode_substring";
 570     if pos + len > String.length s then
 571       invalid_arg "Netencoding.Q.decode_substring";
 572
 573     let decode_hex c =
 574       match c with
 575           '0'..'9' -> Char.code c - 48
 576         | 'A'..'F' -> Char.code c - 55
 577         | 'a'..'f' -> Char.code c - 87
 578         | _ ->
 579            invalid_arg "Netencoding.Q.decode_substring";
 580     in
 581
 582     let rec count n i =
 583       if i < len then
 584         match String.unsafe_get s (pos+i) with
 585             '=' ->
 586               if i+2 >= len then
 587                 invalid_arg "Netencoding.Q.decode_substring";
 588               let _ = decode_hex s.[pos+i+1] in
 589               let _ = decode_hex s.[pos+i+2] in
 590               count (n+1) (i+3)
 591           | _ ->  (* including '_' *)
 592               count (n+1) (i+1)
 593       else
 594         n
 595     in
 596
 597     let l = count 0 0 in
 598     let t = String.create l in
 599     let k = ref pos in
 600     let e = pos + len in
 601     let i = ref 0 in
 602
 603     while !i < l do
 604       match String.unsafe_get s !k with
 605           '=' ->
 606             if !k+2 >= e then
 607               invalid_arg "Netencoding.Q.decode_substring";
 608             let x1 = decode_hex s.[!k+1] in
 609             let x2 = decode_hex s.[!k+2] in
 610             t.[ !i ] <- Char.chr ((x1 lsl 4) lor x2);
 611             k := !k + 3;
 612             incr i
 613         | '_' ->
 614             String.unsafe_set t !i ' ';
 615             incr k;
 616             incr i
 617         | c ->
 618             String.unsafe_set t !i c;
 619             incr k;
 620             incr i
 621     done;
 622
 623     t ;;
 624
 625
 626   let decode ?(pos=0) ?len s =
 627     let l = match len with None -> String.length s - pos | Some x -> x in
 628     decode_substring s pos l ;;
 629
 630 end
 631
 632
 633 module Url = struct
 634   let hex_digits =
 635     [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7';
 636        '8'; '9'; 'A'; 'B'; 'C'; 'D'; 'E'; 'F' |];;
 637
 638   let to_hex2 k =
 639     (* Converts k to a 2-digit hex string *)
 640     let s = String.create 2 in
 641     s.[0] <- hex_digits.( (k lsr 4) land 15 );
 642     s.[1] <- hex_digits.( k land 15 );
 643     s ;;
 644
 645
 646   let of_hex1 c =
 647     match c with
 648         ('0'..'9') -> Char.code c - Char.code '0'
 649       | ('A'..'F') -> Char.code c - Char.code 'A' + 10
 650       | ('a'..'f') -> Char.code c - Char.code 'a' + 10
 651       | _ ->
 652         raise Not_found ;;
 653
 654
 655
 656   let url_encoding_re =
 657     Str.regexp "[^A-Za-z0-9$_.!*'(),-]";;
 658
 659   let url_decoding_re =
 660     Str.regexp "\\+\\|%..\\|%.\\|%";;
 661
 662
 663   let encode s =
 664     Str.global_substitute
 665       url_encoding_re
 666       (fun r _ ->
 667          match Str.matched_string r s with
 668              " " -> "+"
 669            | x ->
 670                let k = Char.code(x.[0]) in
 671                "%" ^ to_hex2 k
 672       )
 673       s ;;
 674
 675
 676   let decode s =
 677     let l = String.length s in
 678     Str.global_substitute
 679       url_decoding_re
 680       (fun r _ ->
 681          match Str.matched_string r s with
 682            | "+" -> " "
 683            | _ ->
 684                let i = Str.match_beginning r in
 685                (* Assertion: s.[i] = '%' *)
 686                if i+2 >= l then failwith "Cgi.decode";
 687                let c1 = s.[i+1] in
 688                let c2 = s.[i+2] in
 689                begin
 690                  try
 691                    let k1 = of_hex1 c1 in
 692                    let k2 = of_hex1 c2 in
 693                    String.make 1 (Char.chr((k1 lsl 4) lor k2))
 694                  with
 695                      Not_found ->
 696                        failwith "Cgi.decode"
 697                end
 698       )
 699       s ;;
 700
 701 end
 702
 703
 704 module Html = struct
 705
 706   let eref_re =
 707     Str.regexp
 708       "&\\(#\\([0-9]+\\);\\|\\([a-zA-Z]+\\);\\)" ;;
 709   let unsafe_re = Str.regexp "[<>&\"\000-\008\011-\012\014-\031\127-\255]" ;;
 710
 711   let etable =
 712     [ "lt", "<";
 713       "gt", ">";
 714       "amp", "&";
 715       "quot", "\"";
 716          (* Note: &quot; is new in HTML-4.0, but it has been widely used
 717           * much earlier.
 718           *)
 719       "nbsp", "\160";
 720       "iexcl", "\161";
 721       "cent", "\162";
 722       "pound", "\163";
 723       "curren", "\164";
 724       "yen", "\165";
 725       "brvbar", "\166";
 726       "sect", "\167";
 727       "uml", "\168";
 728       "copy", "\169";
 729       "ordf", "\170";
 730       "laquo", "\171";
 731       "not", "\172";
 732       "shy", "\173";
 733       "reg", "\174";
 734       "macr", "\175";
 735       "deg", "\176";
 736       "plusmn", "\177";
 737       "sup2", "\178";
 738       "sup3", "\179";
 739       "acute", "\180";
 740       "micro", "\181";
 741       "para", "\182";
 742       "middot", "\183";
 743       "cedil", "\184";
 744       "sup1", "\185";
 745       "ordm", "\186";
 746       "raquo", "\187";
 747       "frac14", "\188";
 748       "frac12", "\189";
 749       "frac34", "\190";
 750       "iquest", "\191";
 751       "Agrave", "\192";
 752       "Aacute", "\193";
 753       "Acirc", "\194";
 754       "Atilde", "\195";
 755       "Auml", "\196";
 756       "Aring", "\197";
 757       "AElig", "\198";
 758       "Ccedil", "\199";
 759       "Egrave", "\200";
 760       "Eacute", "\201";
 761       "Ecirc", "\202";
 762       "Euml", "\203";
 763       "Igrave", "\204";
 764       "Iacute", "\205";
 765       "Icirc", "\206";
 766       "Iuml", "\207";
 767       "ETH", "\208";
 768       "Ntilde", "\209";
 769       "Ograve", "\210";
 770       "Oacute", "\211";
 771       "Ocirc", "\212";
 772       "Otilde", "\213";
 773       "Ouml", "\214";
 774       "times", "\215";
 775       "Oslash", "\216";
 776       "Ugrave", "\217";
 777       "Uacute", "\218";
 778       "Ucirc", "\219";
 779       "Uuml", "\220";
 780       "Yacute", "\221";
 781       "THORN", "\222";
 782       "szlig", "\223";
 783       "agrave", "\224";
 784       "aacute", "\225";
 785       "acirc", "\226";
 786       "atilde", "\227";
 787       "auml", "\228";
 788       "aring", "\229";
 789       "aelig", "\230";
 790       "ccedil", "\231";
 791       "egrave", "\232";
 792       "eacute", "\233";
 793       "ecirc", "\234";
 794       "euml", "\235";
 795       "igrave", "\236";
 796       "iacute", "\237";
 797       "icirc", "\238";
 798       "iuml", "\239";
 799       "eth", "\240";
 800       "ntilde", "\241";
 801       "ograve", "\242";
 802       "oacute", "\243";
 803       "ocirc", "\244";
 804       "otilde", "\245";
 805       "ouml", "\246";
 806       "divide", "\247";
 807       "oslash", "\248";
 808       "ugrave", "\249";
 809       "uacute", "\250";
 810       "ucirc", "\251";
 811       "uuml", "\252";
 812       "yacute", "\253";
 813       "thorn", "\254";
 814       "yuml", "\255";
 815     ] ;;
 816
 817   let quick_etable =
 818     let ht = Hashtbl.create 50 in
 819     List.iter (fun (name,value) -> Hashtbl.add ht name value) etable;
 820     (* Entities to be decoded, but that must not be encoded: *)
 821     Hashtbl.add ht "apos" "'";        (* used in XML documents *)
 822     ht ;;
 823
 824   let rev_etable =
 825     let a = Array.create 256 "" in
 826     List.iter (fun (name,value) ->
 827                  a.(Char.code(value.[0])) <- "&" ^ name ^ ";") etable;
 828     for i = 0 to 8 do
 829       a.(i) <- "&#" ^ string_of_int i ^ ";"
 830     done;
 831     for i = 11 to 12 do
 832       a.(i) <- "&#" ^ string_of_int i ^ ";"
 833     done;
 834     for i = 14 to 31 do
 835       a.(i) <- "&#" ^ string_of_int i ^ ";"
 836     done;
 837     for i = 127 to 159 do
 838       a.(i) <- "&#" ^ string_of_int i ^ ";"
 839     done;
 840     a ;;
 841
 842   let decode_to_latin1 s =
 843     Str.global_substitute
 844       eref_re
 845       (fun r _ ->
 846          let t = Str.matched_string r s in
 847          try
 848            let n = int_of_string(Str.matched_group r 2 s) in
 849            if n < 256 then
 850              String.make 1 (Char.chr n)
 851            else
 852              t
 853          with
 854              Not_found ->
 855                try
 856                  let name = Str.matched_group r 3 s in
 857                  try
 858                    Hashtbl.find quick_etable name
 859                  with
 860                      Not_found ->
 861                        t
 862                with
 863                    Not_found -> assert false
 864       )
 865       s ;;
 866
 867   let encode_from_latin1 s =
 868     Str.global_substitute
 869       unsafe_re
 870       (fun r _ ->
 871          let t = Str.matched_string r s in
 872          let i = Char.code (t.[0]) in
 873          rev_etable.(i)
 874       )
 875       s ;;
 876 end
 877
 878
 879
 880 (* ======================================================================
 881  * History:
 882  *
 883  * $Log$
 884  * Revision 1.1  2000/11/17 09:57:27  lpadovan
 885  * Initial revision
 886  *
 887  * Revision 1.5  2000/06/25 22:34:43  gerd
 888  *      Added labels to arguments.
 889  *
 890  * Revision 1.4  2000/06/25 21:15:48  gerd
 891  *      Checked thread-safety.
 892  *
 893  * Revision 1.3  2000/03/03 17:03:16  gerd
 894  *      Q encoding: CR and LF are quoted.
 895  *
 896  * Revision 1.2  2000/03/03 01:08:29  gerd
 897  *      Added Netencoding.Html functions.
 898  *
 899  * Revision 1.1  2000/03/02 01:14:48  gerd
 900  *      Initial revision.
 901  *
 902  *
 903  *)