gcc/ada/g-md5.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                             G N A T . M D 5                              --
   6 --                                                                          --
   7 --                                B o d y                                   --
   8 --                                                                          --
   9 --              Copyright (C) 2002 Ada Core Technologies, Inc.              --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Unchecked_Conversion;
  35
  36 package body GNAT.MD5 is
  37
  38    use Interfaces;
  39
  40    Padding : constant String :=
  41      (1 => Character'Val (16#80#), 2 .. 64 => ASCII.NUL);
  42
  43    Hex_Digit : constant array (Unsigned_32 range 0 .. 15) of Character :=
  44      ('0', '1', '2', '3', '4', '5', '6', '7',
  45       '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');
  46    --  Look-up table for each hex digit of the Message-Digest.
  47    --  Used by function Digest (Context).
  48
  49    --  The sixten values used to rotate the context words.
  50    --  Four for each rounds. Used in procedure Transform.
  51
  52    --  Round 1
  53
  54    S11 : constant := 7;
  55    S12 : constant := 12;
  56    S13 : constant := 17;
  57    S14 : constant := 22;
  58
  59    --  Round 2
  60
  61    S21 : constant := 5;
  62    S22 : constant := 9;
  63    S23 : constant := 14;
  64    S24 : constant := 20;
  65
  66    --  Round 3
  67
  68    S31 : constant := 4;
  69    S32 : constant := 11;
  70    S33 : constant := 16;
  71    S34 : constant := 23;
  72
  73    --  Round 4
  74
  75    S41 : constant := 6;
  76    S42 : constant := 10;
  77    S43 : constant := 15;
  78    S44 : constant := 21;
  79
  80    type Sixteen_Words is array (Natural range 0 .. 15)
  81      of Interfaces.Unsigned_32;
  82    --  Sixteen 32-bit words, converted from block of 64 characters.
  83    --  Used in procedure Decode and Transform.
  84
  85    procedure Decode
  86      (Block : String;
  87       X     : out Sixteen_Words);
  88    --  Convert a String of 64 characters into 16 32-bit numbers
  89
  90    --  The following functions (F, FF, G, GG, H, HH, I and II) are the
  91    --  equivalent of the macros of the same name in the example
  92    --  C implementation in the annex of RFC 1321.
  93
  94    function F (X, Y, Z : Unsigned_32) return Unsigned_32;
  95    pragma Inline (F);
  96
  97    procedure FF
  98      (A       : in out Unsigned_32;
  99       B, C, D : Unsigned_32;
 100       X       : Unsigned_32;
 101       AC      : Unsigned_32;
 102       S       : Positive);
 103    pragma Inline (FF);
 104
 105    function G (X, Y, Z : Unsigned_32) return Unsigned_32;
 106    pragma Inline (G);
 107
 108    procedure GG
 109      (A       : in out Unsigned_32;
 110       B, C, D : Unsigned_32;
 111       X       : Unsigned_32;
 112       AC      : Unsigned_32;
 113       S       : Positive);
 114    pragma Inline (GG);
 115
 116    function H (X, Y, Z : Unsigned_32) return Unsigned_32;
 117    pragma Inline (H);
 118
 119    procedure HH
 120      (A       : in out Unsigned_32;
 121       B, C, D : Unsigned_32;
 122       X       : Unsigned_32;
 123       AC      : Unsigned_32;
 124       S       : Positive);
 125    pragma Inline (HH);
 126
 127    function I (X, Y, Z : Unsigned_32) return Unsigned_32;
 128    pragma Inline (I);
 129
 130    procedure II
 131      (A       : in out Unsigned_32;
 132       B, C, D : Unsigned_32;
 133       X       : Unsigned_32;
 134       AC      : Unsigned_32;
 135       S       : Positive);
 136    pragma Inline (II);
 137
 138    procedure Transform
 139      (C     : in out Context;
 140       Block : String);
 141    --  Process one block of 64 characters.
 142
 143    ------------
 144    -- Decode --
 145    ------------
 146
 147    procedure Decode
 148      (Block : String;
 149       X     : out Sixteen_Words)
 150    is
 151       Cur   : Positive := Block'First;
 152
 153    begin
 154       pragma Assert (Block'Length = 64);
 155
 156       for Index in X'Range loop
 157          X (Index) :=
 158            Unsigned_32 (Character'Pos (Block (Cur))) +
 159            Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 1))), 8) +
 160            Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 2))), 16) +
 161            Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 3))), 24);
 162          Cur := Cur + 4;
 163       end loop;
 164    end Decode;
 165
 166    ------------
 167    -- Digest --
 168    ------------
 169
 170    function Digest (C : Context) return Message_Digest is
 171       Result : Message_Digest;
 172
 173       Cur : Natural := 1;
 174       --  Index in Result where the next character will be placed.
 175
 176       procedure Convert (X : Unsigned_32);
 177       --  Put the contribution of one of the four words (A, B, C, D) of the
 178       --  Context in Result. Increments Cur.
 179
 180       -------------
 181       -- Convert --
 182       -------------
 183
 184       procedure Convert (X : Unsigned_32) is
 185          Y : Unsigned_32 := X;
 186
 187       begin
 188          for J in 1 .. 4 loop
 189             Result (Cur + 1) := Hex_Digit (Y and Unsigned_32'(16#0F#));
 190             Y := Shift_Right (Y, 4);
 191             Result (Cur) := Hex_Digit (Y and Unsigned_32'(16#0F#));
 192             Y := Shift_Right (Y, 4);
 193             Cur := Cur + 2;
 194          end loop;
 195       end Convert;
 196
 197    --  Start of processing for Digest
 198
 199    begin
 200       Convert (C.A);
 201       Convert (C.B);
 202       Convert (C.C);
 203       Convert (C.D);
 204       return Result;
 205    end Digest;
 206
 207    function Digest (S : String) return Message_Digest is
 208       C : Context;
 209
 210    begin
 211       Update (C, S);
 212       return Digest (C);
 213    end Digest;
 214
 215    function Digest
 216      (A    : Ada.Streams.Stream_Element_Array)
 217       return Message_Digest
 218    is
 219       C : Context;
 220
 221    begin
 222       Update (C, A);
 223       return Digest (C);
 224    end Digest;
 225
 226    -------
 227    -- F --
 228    -------
 229
 230    function F (X, Y, Z : Unsigned_32) return Unsigned_32 is
 231    begin
 232       return (X and Y) or ((not X) and Z);
 233    end F;
 234
 235    --------
 236    -- FF --
 237    --------
 238
 239    procedure FF
 240      (A       : in out Unsigned_32;
 241       B, C, D : Unsigned_32;
 242       X       : Unsigned_32;
 243       AC      : Unsigned_32;
 244       S       : Positive)
 245    is
 246    begin
 247       A := A + F (B, C, D) + X + AC;
 248       A := Rotate_Left (A, S);
 249       A := A + B;
 250    end FF;
 251
 252    -------
 253    -- G --
 254    -------
 255
 256    function G (X, Y, Z : Unsigned_32) return Unsigned_32 is
 257    begin
 258       return (X and Z) or (Y and (not Z));
 259    end G;
 260
 261    --------
 262    -- GG --
 263    --------
 264
 265    procedure GG
 266      (A       : in out Unsigned_32;
 267       B, C, D : Unsigned_32;
 268       X       : Unsigned_32;
 269       AC      : Unsigned_32;
 270       S       : Positive)
 271    is
 272    begin
 273       A := A + G (B, C, D) + X + AC;
 274       A := Rotate_Left (A, S);
 275       A := A + B;
 276    end GG;
 277
 278    -------
 279    -- H --
 280    -------
 281
 282    function H (X, Y, Z : Unsigned_32) return Unsigned_32 is
 283    begin
 284       return X xor Y xor Z;
 285    end H;
 286
 287    --------
 288    -- HH --
 289    --------
 290
 291    procedure HH
 292      (A       : in out Unsigned_32;
 293       B, C, D : Unsigned_32;
 294       X       : Unsigned_32;
 295       AC      : Unsigned_32;
 296       S       : Positive)
 297    is
 298    begin
 299       A := A + H (B, C, D) + X + AC;
 300       A := Rotate_Left (A, S);
 301       A := A + B;
 302    end HH;
 303
 304    -------
 305    -- I --
 306    -------
 307
 308    function I (X, Y, Z : Unsigned_32) return Unsigned_32 is
 309    begin
 310       return Y xor (X or (not Z));
 311    end I;
 312
 313    --------
 314    -- II --
 315    --------
 316
 317    procedure II
 318      (A       : in out Unsigned_32;
 319       B, C, D : Unsigned_32;
 320       X       : Unsigned_32;
 321       AC      : Unsigned_32;
 322       S       : Positive)
 323    is
 324    begin
 325       A := A + I (B, C, D) + X + AC;
 326       A := Rotate_Left (A, S);
 327       A := A + B;
 328    end II;
 329
 330    ---------------
 331    -- Transform --
 332    ---------------
 333
 334    procedure Transform
 335      (C     : in out Context;
 336       Block : String)
 337    is
 338       X : Sixteen_Words;
 339
 340       AA : Unsigned_32 := C.A;
 341       BB : Unsigned_32 := C.B;
 342       CC : Unsigned_32 := C.C;
 343       DD : Unsigned_32 := C.D;
 344
 345    begin
 346       pragma Assert (Block'Length = 64);
 347
 348       Decode (Block, X);
 349
 350       --  Round 1
 351
 352       FF (AA, BB, CC, DD, X (00), 16#D76aa478#, S11); --  1
 353       FF (DD, AA, BB, CC, X (01), 16#E8c7b756#, S12); --  2
 354       FF (CC, DD, AA, BB, X (02), 16#242070db#, S13); --  3
 355       FF (BB, CC, DD, AA, X (03), 16#C1bdceee#, S14); --  4
 356
 357       FF (AA, BB, CC, DD, X (04), 16#f57c0faf#, S11); --  5
 358       FF (DD, AA, BB, CC, X (05), 16#4787c62a#, S12); --  6
 359       FF (CC, DD, AA, BB, X (06), 16#a8304613#, S13); --  7
 360       FF (BB, CC, DD, AA, X (07), 16#fd469501#, S14); --  8
 361
 362       FF (AA, BB, CC, DD, X (08), 16#698098d8#, S11); --  9
 363       FF (DD, AA, BB, CC, X (09), 16#8b44f7af#, S12); --  10
 364       FF (CC, DD, AA, BB, X (10), 16#ffff5bb1#, S13); --  11
 365       FF (BB, CC, DD, AA, X (11), 16#895cd7be#, S14); --  12
 366
 367       FF (AA, BB, CC, DD, X (12), 16#6b901122#, S11); --  13
 368       FF (DD, AA, BB, CC, X (13), 16#fd987193#, S12); --  14
 369       FF (CC, DD, AA, BB, X (14), 16#a679438e#, S13); --  15
 370       FF (BB, CC, DD, AA, X (15), 16#49b40821#, S14); --  16
 371
 372       --  Round 2
 373
 374       GG (AA, BB, CC, DD, X (01), 16#f61e2562#, S21); --  17
 375       GG (DD, AA, BB, CC, X (06), 16#c040b340#, S22); --  18
 376       GG (CC, DD, AA, BB, X (11), 16#265e5a51#, S23); --  19
 377       GG (BB, CC, DD, AA, X (00), 16#e9b6c7aa#, S24); --  20
 378
 379       GG (AA, BB, CC, DD, X (05), 16#d62f105d#, S21); --  21
 380       GG (DD, AA, BB, CC, X (10), 16#02441453#, S22); --  22
 381       GG (CC, DD, AA, BB, X (15), 16#d8a1e681#, S23); --  23
 382       GG (BB, CC, DD, AA, X (04), 16#e7d3fbc8#, S24); --  24
 383
 384       GG (AA, BB, CC, DD, X (09), 16#21e1cde6#, S21); --  25
 385       GG (DD, AA, BB, CC, X (14), 16#c33707d6#, S22); --  26
 386       GG (CC, DD, AA, BB, X (03), 16#f4d50d87#, S23); --  27
 387       GG (BB, CC, DD, AA, X (08), 16#455a14ed#, S24); --  28
 388
 389       GG (AA, BB, CC, DD, X (13), 16#a9e3e905#, S21); --  29
 390       GG (DD, AA, BB, CC, X (02), 16#fcefa3f8#, S22); --  30
 391       GG (CC, DD, AA, BB, X (07), 16#676f02d9#, S23); --  31
 392       GG (BB, CC, DD, AA, X (12), 16#8d2a4c8a#, S24); --  32
 393
 394       --  Round 3
 395
 396       HH (AA, BB, CC, DD, X (05), 16#fffa3942#, S31); --  33
 397       HH (DD, AA, BB, CC, X (08), 16#8771f681#, S32); --  34
 398       HH (CC, DD, AA, BB, X (11), 16#6d9d6122#, S33); --  35
 399       HH (BB, CC, DD, AA, X (14), 16#fde5380c#, S34); --  36
 400
 401       HH (AA, BB, CC, DD, X (01), 16#a4beea44#, S31); --  37
 402       HH (DD, AA, BB, CC, X (04), 16#4bdecfa9#, S32); --  38
 403       HH (CC, DD, AA, BB, X (07), 16#f6bb4b60#, S33); --  39
 404       HH (BB, CC, DD, AA, X (10), 16#bebfbc70#, S34); --  40
 405
 406       HH (AA, BB, CC, DD, X (13), 16#289b7ec6#, S31); --  41
 407       HH (DD, AA, BB, CC, X (00), 16#eaa127fa#, S32); --  42
 408       HH (CC, DD, AA, BB, X (03), 16#d4ef3085#, S33); --  43
 409       HH (BB, CC, DD, AA, X (06), 16#04881d05#, S34); --  44
 410
 411       HH (AA, BB, CC, DD, X (09), 16#d9d4d039#, S31); --  45
 412       HH (DD, AA, BB, CC, X (12), 16#e6db99e5#, S32); --  46
 413       HH (CC, DD, AA, BB, X (15), 16#1fa27cf8#, S33); --  47
 414       HH (BB, CC, DD, AA, X (02), 16#c4ac5665#, S34); --  48
 415
 416       --  Round 4
 417
 418       II (AA, BB, CC, DD, X (00), 16#f4292244#, S41); --  49
 419       II (DD, AA, BB, CC, X (07), 16#432aff97#, S42); --  50
 420       II (CC, DD, AA, BB, X (14), 16#ab9423a7#, S43); --  51
 421       II (BB, CC, DD, AA, X (05), 16#fc93a039#, S44); --  52
 422
 423       II (AA, BB, CC, DD, X (12), 16#655b59c3#, S41); --  53
 424       II (DD, AA, BB, CC, X (03), 16#8f0ccc92#, S42); --  54
 425       II (CC, DD, AA, BB, X (10), 16#ffeff47d#, S43); --  55
 426       II (BB, CC, DD, AA, X (01), 16#85845dd1#, S44); --  56
 427
 428       II (AA, BB, CC, DD, X (08), 16#6fa87e4f#, S41); --  57
 429       II (DD, AA, BB, CC, X (15), 16#fe2ce6e0#, S42); --  58
 430       II (CC, DD, AA, BB, X (06), 16#a3014314#, S43); --  59
 431       II (BB, CC, DD, AA, X (13), 16#4e0811a1#, S44); --  60
 432
 433       II (AA, BB, CC, DD, X (04), 16#f7537e82#, S41); --  61
 434       II (DD, AA, BB, CC, X (11), 16#bd3af235#, S42); --  62
 435       II (CC, DD, AA, BB, X (02), 16#2ad7d2bb#, S43); --  63
 436       II (BB, CC, DD, AA, X (09), 16#eb86d391#, S44); --  64
 437
 438       C.A := C.A + AA;
 439       C.B := C.B + BB;
 440       C.C := C.C + CC;
 441       C.D := C.D + DD;
 442
 443    end Transform;
 444
 445    ------------
 446    -- Update --
 447    ------------
 448
 449    procedure Update
 450      (C     : in out Context;
 451       Input : String)
 452    is
 453       Cur        : Positive := Input'First;
 454       Last_Block : String (1 .. 64);
 455
 456    begin
 457       while Cur + 63 <= Input'Last loop
 458          Transform (C, Input (Cur .. Cur + 63));
 459          Cur := Cur + 64;
 460       end loop;
 461
 462       Last_Block (1 .. Input'Last - Cur + 1) := Input (Cur .. Input'Last);
 463
 464       if Input'Last - Cur + 1 > 56 then
 465          Cur := Input'Last - Cur + 2;
 466          Last_Block (Cur .. 64) := Padding (1 .. 64 - Cur + 1);
 467          Transform (C, Last_Block);
 468          Last_Block := (others => ASCII.NUL);
 469
 470       else
 471          Cur := Input'Last - Cur + 2;
 472          Last_Block (Cur .. 56) := Padding (1 .. 56 - Cur + 1);
 473       end if;
 474
 475       --  Add the input length as 8 characters
 476
 477       Last_Block (57 .. 64) := (others => ASCII.NUL);
 478
 479       declare
 480          L : Unsigned_64 := Unsigned_64 (Input'Length) * 8;
 481
 482       begin
 483          Cur := 57;
 484          while L > 0 loop
 485             Last_Block (Cur) := Character'Val (L and 16#Ff#);
 486             L := Shift_Right (L, 8);
 487             Cur := Cur + 1;
 488          end loop;
 489       end;
 490
 491       Transform (C, Last_Block);
 492    end Update;
 493
 494    procedure Update
 495      (C     : in out Context;
 496       Input : Ada.Streams.Stream_Element_Array)
 497    is
 498       subtype Stream_Array is Ada.Streams.Stream_Element_Array (Input'Range);
 499       subtype Stream_String is
 500         String (1 + Integer (Input'First) .. 1 + Integer (Input'Last));
 501
 502       function To_String is new Ada.Unchecked_Conversion
 503         (Stream_Array, Stream_String);
 504
 505       String_Input : constant String := To_String (Input);
 506    begin
 507       Update (C, String_Input);
 508    end Update;
 509
 510    -----------------
 511    -- Wide_Digest --
 512    -----------------
 513
 514    function Wide_Digest (W : Wide_String) return Message_Digest is
 515       C : Context;
 516
 517    begin
 518       Wide_Update (C, W);
 519       return Digest (C);
 520    end Wide_Digest;
 521
 522    -----------------
 523    -- Wide_Update --
 524    -----------------
 525
 526    procedure Wide_Update
 527      (C     : in out Context;
 528       Input : Wide_String)
 529    is
 530
 531       String_Input : String (1 .. 2 * Input'Length);
 532       Cur          : Positive := 1;
 533
 534    begin
 535       for Index in Input'Range loop
 536          String_Input (Cur) :=
 537            Character'Val
 538             (Unsigned_32 (Wide_Character'Pos (Input (Index))) and 16#FF#);
 539          Cur := Cur + 1;
 540          String_Input (Cur) :=
 541            Character'Val
 542            (Shift_Right (Unsigned_32 (Wide_Character'Pos (Input (Index))), 8)
 543             and 16#FF#);
 544          Cur := Cur + 1;
 545       end loop;
 546
 547       Update (C, String_Input);
 548    end Wide_Update;
 549
 550 end GNAT.MD5;