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