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