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-2004 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       Last_Block : String (1 .. 64);
 177
 178       C1 : Context := C;
 179
 180       procedure Convert (X : Unsigned_32);
 181       --  Put the contribution of one of the four words (A, B, C, D) of the
 182       --  Context in Result. Increments Cur.
 183
 184       -------------
 185       -- Convert --
 186       -------------
 187
 188       procedure Convert (X : Unsigned_32) is
 189          Y : Unsigned_32 := X;
 190
 191       begin
 192          for J in 1 .. 4 loop
 193             Result (Cur + 1) := Hex_Digit (Y and Unsigned_32'(16#0F#));
 194             Y := Shift_Right (Y, 4);
 195             Result (Cur) := Hex_Digit (Y and Unsigned_32'(16#0F#));
 196             Y := Shift_Right (Y, 4);
 197             Cur := Cur + 2;
 198          end loop;
 199       end Convert;
 200
 201    --  Start of processing for Digest
 202
 203    begin
 204       --  Process characters in the context buffer, if any
 205
 206       Last_Block (1 .. C.Last) := C.Buffer (1 .. C.Last);
 207
 208       if C.Last > 56 then
 209          Last_Block (C.Last + 1 .. 64) := Padding (1 .. 64 - C.Last);
 210          Transform (C1, Last_Block);
 211          Last_Block := (others => ASCII.NUL);
 212
 213       else
 214          Last_Block (C.Last + 1 .. 56) := Padding (1 .. 56 - C.Last);
 215       end if;
 216
 217       --  Add the input length (as stored in the context) as 8 characters
 218
 219       Last_Block (57 .. 64) := (others => ASCII.NUL);
 220
 221       declare
 222          L : Unsigned_64 := Unsigned_64 (C.Length) * 8;
 223          Idx : Positive := 57;
 224
 225       begin
 226          while L > 0 loop
 227             Last_Block (Idx) := Character'Val (L and 16#Ff#);
 228             L := Shift_Right (L, 8);
 229             Idx := Idx + 1;
 230          end loop;
 231       end;
 232
 233       Transform (C1, Last_Block);
 234
 235       Convert (C1.A);
 236       Convert (C1.B);
 237       Convert (C1.C);
 238       Convert (C1.D);
 239       return Result;
 240    end Digest;
 241
 242    function Digest (S : String) return Message_Digest is
 243       C : Context;
 244    begin
 245       Update (C, S);
 246       return Digest (C);
 247    end Digest;
 248
 249    function Digest
 250      (A : Ada.Streams.Stream_Element_Array) return Message_Digest
 251    is
 252       C : Context;
 253    begin
 254       Update (C, A);
 255       return Digest (C);
 256    end Digest;
 257
 258    -------
 259    -- F --
 260    -------
 261
 262    function F (X, Y, Z : Unsigned_32) return Unsigned_32 is
 263    begin
 264       return (X and Y) or ((not X) and Z);
 265    end F;
 266
 267    --------
 268    -- FF --
 269    --------
 270
 271    procedure FF
 272      (A       : in out Unsigned_32;
 273       B, C, D : Unsigned_32;
 274       X       : Unsigned_32;
 275       AC      : Unsigned_32;
 276       S       : Positive)
 277    is
 278    begin
 279       A := A + F (B, C, D) + X + AC;
 280       A := Rotate_Left (A, S);
 281       A := A + B;
 282    end FF;
 283
 284    -------
 285    -- G --
 286    -------
 287
 288    function G (X, Y, Z : Unsigned_32) return Unsigned_32 is
 289    begin
 290       return (X and Z) or (Y and (not Z));
 291    end G;
 292
 293    --------
 294    -- GG --
 295    --------
 296
 297    procedure GG
 298      (A       : in out Unsigned_32;
 299       B, C, D : Unsigned_32;
 300       X       : Unsigned_32;
 301       AC      : Unsigned_32;
 302       S       : Positive)
 303    is
 304    begin
 305       A := A + G (B, C, D) + X + AC;
 306       A := Rotate_Left (A, S);
 307       A := A + B;
 308    end GG;
 309
 310    -------
 311    -- H --
 312    -------
 313
 314    function H (X, Y, Z : Unsigned_32) return Unsigned_32 is
 315    begin
 316       return X xor Y xor Z;
 317    end H;
 318
 319    --------
 320    -- HH --
 321    --------
 322
 323    procedure HH
 324      (A       : in out Unsigned_32;
 325       B, C, D : Unsigned_32;
 326       X       : Unsigned_32;
 327       AC      : Unsigned_32;
 328       S       : Positive)
 329    is
 330    begin
 331       A := A + H (B, C, D) + X + AC;
 332       A := Rotate_Left (A, S);
 333       A := A + B;
 334    end HH;
 335
 336    -------
 337    -- I --
 338    -------
 339
 340    function I (X, Y, Z : Unsigned_32) return Unsigned_32 is
 341    begin
 342       return Y xor (X or (not Z));
 343    end I;
 344
 345    --------
 346    -- II --
 347    --------
 348
 349    procedure II
 350      (A       : in out Unsigned_32;
 351       B, C, D : Unsigned_32;
 352       X       : Unsigned_32;
 353       AC      : Unsigned_32;
 354       S       : Positive)
 355    is
 356    begin
 357       A := A + I (B, C, D) + X + AC;
 358       A := Rotate_Left (A, S);
 359       A := A + B;
 360    end II;
 361
 362    ---------------
 363    -- Transform --
 364    ---------------
 365
 366    procedure Transform
 367      (C     : in out Context;
 368       Block : String)
 369    is
 370       X : Sixteen_Words;
 371
 372       AA : Unsigned_32 := C.A;
 373       BB : Unsigned_32 := C.B;
 374       CC : Unsigned_32 := C.C;
 375       DD : Unsigned_32 := C.D;
 376
 377    begin
 378       pragma Assert (Block'Length = 64);
 379
 380       Decode (Block, X);
 381
 382       --  Round 1
 383
 384       FF (AA, BB, CC, DD, X (00), 16#D76aa478#, S11); --  1
 385       FF (DD, AA, BB, CC, X (01), 16#E8c7b756#, S12); --  2
 386       FF (CC, DD, AA, BB, X (02), 16#242070db#, S13); --  3
 387       FF (BB, CC, DD, AA, X (03), 16#C1bdceee#, S14); --  4
 388
 389       FF (AA, BB, CC, DD, X (04), 16#f57c0faf#, S11); --  5
 390       FF (DD, AA, BB, CC, X (05), 16#4787c62a#, S12); --  6
 391       FF (CC, DD, AA, BB, X (06), 16#a8304613#, S13); --  7
 392       FF (BB, CC, DD, AA, X (07), 16#fd469501#, S14); --  8
 393
 394       FF (AA, BB, CC, DD, X (08), 16#698098d8#, S11); --  9
 395       FF (DD, AA, BB, CC, X (09), 16#8b44f7af#, S12); --  10
 396       FF (CC, DD, AA, BB, X (10), 16#ffff5bb1#, S13); --  11
 397       FF (BB, CC, DD, AA, X (11), 16#895cd7be#, S14); --  12
 398
 399       FF (AA, BB, CC, DD, X (12), 16#6b901122#, S11); --  13
 400       FF (DD, AA, BB, CC, X (13), 16#fd987193#, S12); --  14
 401       FF (CC, DD, AA, BB, X (14), 16#a679438e#, S13); --  15
 402       FF (BB, CC, DD, AA, X (15), 16#49b40821#, S14); --  16
 403
 404       --  Round 2
 405
 406       GG (AA, BB, CC, DD, X (01), 16#f61e2562#, S21); --  17
 407       GG (DD, AA, BB, CC, X (06), 16#c040b340#, S22); --  18
 408       GG (CC, DD, AA, BB, X (11), 16#265e5a51#, S23); --  19
 409       GG (BB, CC, DD, AA, X (00), 16#e9b6c7aa#, S24); --  20
 410
 411       GG (AA, BB, CC, DD, X (05), 16#d62f105d#, S21); --  21
 412       GG (DD, AA, BB, CC, X (10), 16#02441453#, S22); --  22
 413       GG (CC, DD, AA, BB, X (15), 16#d8a1e681#, S23); --  23
 414       GG (BB, CC, DD, AA, X (04), 16#e7d3fbc8#, S24); --  24
 415
 416       GG (AA, BB, CC, DD, X (09), 16#21e1cde6#, S21); --  25
 417       GG (DD, AA, BB, CC, X (14), 16#c33707d6#, S22); --  26
 418       GG (CC, DD, AA, BB, X (03), 16#f4d50d87#, S23); --  27
 419       GG (BB, CC, DD, AA, X (08), 16#455a14ed#, S24); --  28
 420
 421       GG (AA, BB, CC, DD, X (13), 16#a9e3e905#, S21); --  29
 422       GG (DD, AA, BB, CC, X (02), 16#fcefa3f8#, S22); --  30
 423       GG (CC, DD, AA, BB, X (07), 16#676f02d9#, S23); --  31
 424       GG (BB, CC, DD, AA, X (12), 16#8d2a4c8a#, S24); --  32
 425
 426       --  Round 3
 427
 428       HH (AA, BB, CC, DD, X (05), 16#fffa3942#, S31); --  33
 429       HH (DD, AA, BB, CC, X (08), 16#8771f681#, S32); --  34
 430       HH (CC, DD, AA, BB, X (11), 16#6d9d6122#, S33); --  35
 431       HH (BB, CC, DD, AA, X (14), 16#fde5380c#, S34); --  36
 432
 433       HH (AA, BB, CC, DD, X (01), 16#a4beea44#, S31); --  37
 434       HH (DD, AA, BB, CC, X (04), 16#4bdecfa9#, S32); --  38
 435       HH (CC, DD, AA, BB, X (07), 16#f6bb4b60#, S33); --  39
 436       HH (BB, CC, DD, AA, X (10), 16#bebfbc70#, S34); --  40
 437
 438       HH (AA, BB, CC, DD, X (13), 16#289b7ec6#, S31); --  41
 439       HH (DD, AA, BB, CC, X (00), 16#eaa127fa#, S32); --  42
 440       HH (CC, DD, AA, BB, X (03), 16#d4ef3085#, S33); --  43
 441       HH (BB, CC, DD, AA, X (06), 16#04881d05#, S34); --  44
 442
 443       HH (AA, BB, CC, DD, X (09), 16#d9d4d039#, S31); --  45
 444       HH (DD, AA, BB, CC, X (12), 16#e6db99e5#, S32); --  46
 445       HH (CC, DD, AA, BB, X (15), 16#1fa27cf8#, S33); --  47
 446       HH (BB, CC, DD, AA, X (02), 16#c4ac5665#, S34); --  48
 447
 448       --  Round 4
 449
 450       II (AA, BB, CC, DD, X (00), 16#f4292244#, S41); --  49
 451       II (DD, AA, BB, CC, X (07), 16#432aff97#, S42); --  50
 452       II (CC, DD, AA, BB, X (14), 16#ab9423a7#, S43); --  51
 453       II (BB, CC, DD, AA, X (05), 16#fc93a039#, S44); --  52
 454
 455       II (AA, BB, CC, DD, X (12), 16#655b59c3#, S41); --  53
 456       II (DD, AA, BB, CC, X (03), 16#8f0ccc92#, S42); --  54
 457       II (CC, DD, AA, BB, X (10), 16#ffeff47d#, S43); --  55
 458       II (BB, CC, DD, AA, X (01), 16#85845dd1#, S44); --  56
 459
 460       II (AA, BB, CC, DD, X (08), 16#6fa87e4f#, S41); --  57
 461       II (DD, AA, BB, CC, X (15), 16#fe2ce6e0#, S42); --  58
 462       II (CC, DD, AA, BB, X (06), 16#a3014314#, S43); --  59
 463       II (BB, CC, DD, AA, X (13), 16#4e0811a1#, S44); --  60
 464
 465       II (AA, BB, CC, DD, X (04), 16#f7537e82#, S41); --  61
 466       II (DD, AA, BB, CC, X (11), 16#bd3af235#, S42); --  62
 467       II (CC, DD, AA, BB, X (02), 16#2ad7d2bb#, S43); --  63
 468       II (BB, CC, DD, AA, X (09), 16#eb86d391#, S44); --  64
 469
 470       C.A := C.A + AA;
 471       C.B := C.B + BB;
 472       C.C := C.C + CC;
 473       C.D := C.D + DD;
 474
 475    end Transform;
 476
 477    ------------
 478    -- Update --
 479    ------------
 480
 481    procedure Update
 482      (C     : in out Context;
 483       Input : String)
 484    is
 485       Inp : constant String := C.Buffer (1 .. C.Last) & Input;
 486       Cur        : Positive := Inp'First;
 487
 488    begin
 489       C.Length := C.Length + Input'Length;
 490
 491       while Cur + 63 <= Inp'Last loop
 492          Transform (C, Inp (Cur .. Cur + 63));
 493          Cur := Cur + 64;
 494       end loop;
 495
 496       C.Last := Inp'Last - Cur + 1;
 497       C.Buffer (1 .. C.Last) := Inp (Cur .. Inp'Last);
 498    end Update;
 499
 500    procedure Update
 501      (C     : in out Context;
 502       Input : Ada.Streams.Stream_Element_Array)
 503    is
 504       subtype Stream_Array is Ada.Streams.Stream_Element_Array (Input'Range);
 505       subtype Stream_String is
 506         String (1 + Integer (Input'First) .. 1 + Integer (Input'Last));
 507
 508       function To_String is new Ada.Unchecked_Conversion
 509         (Stream_Array, Stream_String);
 510
 511       String_Input : constant String := To_String (Input);
 512    begin
 513       Update (C, String_Input);
 514    end Update;
 515
 516    -----------------
 517    -- Wide_Digest --
 518    -----------------
 519
 520    function Wide_Digest (W : Wide_String) return Message_Digest is
 521       C : Context;
 522
 523    begin
 524       Wide_Update (C, W);
 525       return Digest (C);
 526    end Wide_Digest;
 527
 528    -----------------
 529    -- Wide_Update --
 530    -----------------
 531
 532    procedure Wide_Update
 533      (C     : in out Context;
 534       Input : Wide_String)
 535    is
 536
 537       String_Input : String (1 .. 2 * Input'Length);
 538       Cur          : Positive := 1;
 539
 540    begin
 541       for Index in Input'Range loop
 542          String_Input (Cur) :=
 543            Character'Val
 544             (Unsigned_32 (Wide_Character'Pos (Input (Index))) and 16#FF#);
 545          Cur := Cur + 1;
 546          String_Input (Cur) :=
 547            Character'Val
 548            (Shift_Right (Unsigned_32 (Wide_Character'Pos (Input (Index))), 8)
 549             and 16#FF#);
 550          Cur := Cur + 1;
 551       end loop;
 552
 553       Update (C, String_Input);
 554    end Wide_Update;
 555
 556 end GNAT.MD5;