COMPOSANT : TDBPVERNAM (CRYPTEUR DE TEXTE/FICHIER)

{
################################################################################
# DBPVERNAM                                                                    #
################################################################################
#                                                                              #
# VERSION       : 1.2                                                          #
# FICHIERS      : dbpVernam.pas,.dcu,.dcr,.bmp,ReadMe.htm                      #
# AUTEUR        : Julio P. (Diabloporc)                                        #
# CREATION      : 09 dec 2004                                                  #
# MODIFIEE      : 10 dec 2004                                                  #
# SITE WEB      : http://diabloporc.free.fr                                    #
# MAIL          : diabloporc@laposte.net                                       #
# LEGAL         : Free sous Licence GNU/GPL                                    #
# INFOS         : Retrouvez moi sur www.delphifr.com : "JulioDelphi"           #
#                                                                              #
################################################################################
}

unit dbpVernam;

interface

uses
  Math, SysUtils, Classes;

type
  TdbpVernam = class(TComponent)
  private
    fText, fTextEncode, fTextDecode, fTextCle, fAbout: string;
    fFile, fFileEncoded, fFileDecoded, fFileKey: TFileName;
    fUseTextCle, fUseFileKey: boolean;

    procedure SetFile(const Value: TFileName);
    procedure SetFileEncoded(const Value: TFileName);
    procedure setFileDecoded(const Value: TFileName);
    procedure SetFileKey(const Value: TFileName);
    procedure SetAbout(const Value: string);

  protected
    { Protected declarations }
  public
    constructor Create(AOwner: TComponent);                       override;
  published
    property About:               String        read fAbout       write SetAbout;
    property Fichier:             TFileName     read fFile        write SetFile;
    property FichierEncode:       TFileName     read fFileEncoded write SetFileEncoded;
    property FichierDecode:       TFileName     read fFileDecoded write SetFileDecoded;
    property FichierCle:          TFileName     read fFileKey     write SetFileKey;
    property UtiliserFichierCle:  boolean       read fUseFileKey  write fUseFileKey;
    property Text:                string        read fText        write fText;
    property TextEncode:          string        read fTextEncode  write fTextEncode;
    property TextDecode:          string        read fTextDecode  write fTextDecode;
    property TextCle:             string        read fTextCle     write fTextCle;
    property UtiliserTextCle:     boolean       read fUseTextCle  write fUseTextCle;

    function EncodeFichier: boolean;
    function DecodeFichier: boolean;
    function EncodeText: boolean;
    function DecodeText: boolean;
  end;

procedure Register;

implementation
{$R dbpVernam.dcr}

procedure VERNAM_CRYPT_FILE(Src, Dest, Chave: TFileName);
var fs_Src, fs_Dest, fs_Chave: TFileStream;
    fs_Src_Buffer, fs_Dest_Buffer, fs_Chave_Buffer: Array[0..1023] of byte; // Buffers de 1Ko ...
    fs_Buffer_size: Int64;
    i: Integer;
begin
  Randomize;
  fs_Src   := TFileStream.Create(Src,   fmOpenRead or fmShareDenyWrite);
  fs_Dest  := TFileStream.Create(Dest,  fmCreate or fmShareExclusive);
  fs_Chave := TFileStream.Create(Chave, fmCreate or fmShareExclusive);

  Try
    While fs_Src.Position < fs_Src.Size Do
    begin
      fs_Buffer_size := fs_Src.Size - fs_Src.Position;

      If fs_Buffer_size > 1024
      Then fs_Buffer_size := 1024;

      fs_Src.Read(fs_Src_Buffer, fs_Buffer_size);

      for i := 0 to fs_Buffer_size - 1 do
      begin
        fs_Chave_Buffer[i] := RandomRange(0, 247);  // 1 byte = 8bits (1 octet en français) donc valeur max. est de 11111111 en binaire = 247 en décimal ...
        fs_Dest_Buffer[i]  := fs_Chave_Buffer[i] XOR fs_Src_Buffer[i];
      end;

      fs_Chave.Write(fs_Chave_Buffer, fs_Buffer_size);
      fs_Dest.Write(fs_Dest_Buffer, fs_Buffer_size);
    end;
  Finally
    fs_Src.Free;
    fs_Dest.Free;
    fs_Chave.Free;
  End;
end;

procedure VERNAM_CRYPT_FILE_WITH_PREDEF_KEY(Src, Dest, Chave: TFileName);
var fs_Src, fs_Dest, fs_Chave: TFileStream;
    fs_Src_Buffer, fs_Dest_Buffer, fs_Chave_Buffer, fs_Chave_Buffer2: Array[0..1023] of byte; // Buffers de 1Ko ...
    fs_Src_Buffer_size, fs_Chave_Buffer_size, TransfBytes: Int64;
    i: Integer;
begin
  Randomize;
  fs_Src   := TFileStream.Create(Src,   fmOpenRead or fmShareDenyWrite);
  fs_Dest  := TFileStream.Create(Dest,  fmCreate or fmShareExclusive);
  fs_Chave := TFileStream.Create(Chave, fmOpenRead or fmShareDenyWrite);

  Try
    While fs_Src.Position < fs_Src.Size Do
    begin
      fs_Src_Buffer_size := fs_Src.Size - fs_Src.Position;
      If fs_Src_Buffer_size > 1024
      Then fs_Src_Buffer_size := 1024;
      fs_Src.Read(fs_Src_Buffer, fs_Src_Buffer_size);

      // On doit contrôler la lecture du fichier clé parce que celui-ci peut être + petit que le fichier crypté !
      fs_Chave_Buffer_size := 0;
      While fs_Chave_Buffer_size < fs_Src_Buffer_size do   // On doit avoir le meme nombre de bytes ...
      begin
        TransfBytes := fs_Chave.Size - fs_Chave.Position;  // Bytes dispo à lire dans le fichier clé ...

        If TransfBytes = 0    // On est à la fin du fichier clé ...
        Then Begin
          fs_Chave.Seek(0, soFromBeginning);
          TransfBytes := fs_Chave.Size;
        End;

        If TransfBytes + fs_Chave_Buffer_size > fs_Src_Buffer_size
        Then TransfBytes := fs_Src_Buffer_size - fs_Chave_Buffer_size;

        fs_Chave.Read(fs_Chave_Buffer2, TransfBytes);      // Mémoire temporaire pour transférer vers fs_Chave_Buffer ...

        for i := 0 to TransfBytes - 1 do                   // Compléter le buffer de la clé ...
          fs_Chave_Buffer[fs_Chave_Buffer_size + i] := fs_Chave_Buffer2[i];

        fs_Chave_Buffer_size := fs_Chave_Buffer_size + TransfBytes;
      end;

      for i := 0 to fs_Src_Buffer_size - 1 do
        fs_Dest_Buffer[i]  := fs_Chave_Buffer[i] XOR fs_Src_Buffer[i];

      fs_Dest.Write(fs_Dest_Buffer, fs_Src_Buffer_size);
    end;
  Finally
    fs_Src.Free;
    fs_Dest.Free;
    fs_Chave.Free;
  End;
end;

procedure VERNAM_DECRYPT_FILE(Src, Dest, Chave: TFileName);
var fs_Src, fs_Dest, fs_Chave: TFileStream;
    fs_Src_Buffer, fs_Dest_Buffer, fs_Chave_Buffer, fs_Chave_Buffer2: Array[0..1023] of byte; // Buffers de 1Ko ...
    fs_Src_Buffer_size, fs_Chave_Buffer_size, TransfBytes: Int64;
    i: Integer;
begin
  fs_Src   := TFileStream.Create(Src,   fmOpenRead or fmShareDenyWrite);
  fs_Dest  := TFileStream.Create(Dest,  fmCreate or fmShareExclusive);
  fs_Chave := TFileStream.Create(Chave, fmOpenRead or fmShareDenyWrite);

  Try
    While fs_Src.Position < fs_Src.Size Do
    begin
      fs_Src_Buffer_size := fs_Src.Size - fs_Src.Position;
      If fs_Src_Buffer_size > 1024
      Then fs_Src_Buffer_size := 1024;
      fs_Src.Read(fs_Src_Buffer, fs_Src_Buffer_size);

      // On doit contrôler la lecture du fichier clé parce que celui-ci peut être + petit que le fichier crypté !
      fs_Chave_Buffer_size := 0;
      While fs_Chave_Buffer_size < fs_Src_Buffer_size do
      begin
        TransfBytes := fs_Chave.Size - fs_Chave.Position;  // Bytes dispo à lire dans le fichier clé ...

        If TransfBytes = 0    // On est à la fin du fichier clé ...
        Then Begin
          fs_Chave.Seek(0, soFromBeginning);
          TransfBytes := fs_Chave.Size;
        End;

        If TransfBytes + fs_Chave_Buffer_size > fs_Src_Buffer_size
        Then TransfBytes := fs_Src_Buffer_size - fs_Chave_Buffer_size;

        fs_Chave.Read(fs_Chave_Buffer2, TransfBytes);      // Mémoire temporaire pour transférer vers fs_Chave_Buffer ...

        for i := 0 to TransfBytes - 1 do                   // Compléter le buffer de la clé ...
          fs_Chave_Buffer[fs_Chave_Buffer_size + i] := fs_Chave_Buffer2[i];

        fs_Chave_Buffer_size := fs_Chave_Buffer_size + TransfBytes;
      end;

      for i := 0 to fs_Src_Buffer_size - 1 do
        fs_Dest_Buffer[i] := fs_Chave_Buffer[i] XOR fs_Src_Buffer[i];

      fs_Dest.Write(fs_Dest_Buffer, fs_Src_Buffer_size);
    end;
  Finally
    fs_Src.Free;
    fs_Dest.Free;
    fs_Chave.Free;
  End;
end;

function VERNAM_CRYPT(Texto: String; Var Chave: String): String;
var i, curOrd: Integer;
    RandomVal : byte;
begin
  RESULT := '';
  Chave  := '';
  Randomize;

  for i := 1 to length(Texto) do
  begin
    repeat
      RandomVal := RandomRange(1, 127);
      curOrd    := Ord(Texto[i]) XOR RandomVal;
    until curOrd <> 0;   // Ça foire si curOrd = 0 (Quand Ord(Texto[i]) = RandomVal)  parce que chr(0) n' existe pas !!!

    RESULT    := RESULT + Chr(curOrd);
    Chave     := Chave + chr(RandomVal);
  end;
end;

function VERNAM_CRYPT_WITH_PREDEF_KEY(Texto: String; Chave: String): String;
var i, curOrd, lengthChave, lengthTexto, repetir: Integer;
begin
  RESULT := '';

  if chave = '' then chave := 'a';    // Mettre qque chose sinon ça va foiré ...

  lengthChave := length(Chave);
  lengthTexto := length(Texto);

  if lengthChave < lengthTexto        // La taille de la clé doit être au moins aussi grande que le message crypté ...
  then begin
    Repetir := 1;
    for i := lengthChave + 1 to lengthTexto do
    begin
      Chave   := chave + chave[Repetir];

      if Repetir < lengthChave
      then Repetir := Repetir + 1
      else Repetir := 1;
    end;
  end;

  for i := 1 to length(Texto) do
  begin
    curOrd    := Ord(Texto[i]) XOR Ord(Chave[i]);

    if curOrd = 0                  // Ça arrive quand Texto[i] = Chave[i] ...
    then curOrd := Ord(Texto[i]);  // Chr(0) n' existe pas, donc on peut pas coder ce caractere ...

    RESULT    := RESULT + Chr(curOrd);
  end;
end;

function VERNAM_DECRYPT(Criptado, Chave: String): String;
var i, repetir, curOrd, lengthChave, lengthTexto: Integer;
begin
  RESULT := '';

  if chave = '' then chave := 'a';

  lengthChave := length(Chave);
  lengthTexto := length(Criptado);

  if lengthChave < lengthTexto
  then begin
    Repetir := 1;
    for i := lengthChave + 1 to lengthTexto do
    begin
      Chave  := chave + chave[Repetir];

      if Repetir < lengthChave
      then Repetir := Repetir + 1
      else Repetir := 1;
    end;
  end;

  for i := 1 to lengthTexto do
  begin
    curOrd := Ord(Criptado[i]) XOR Ord(Chave[i]);

    if curOrd = 0                      // On est dans le cas où Texto[i] était égal à Chave[i] ...
    then curOrd := Ord(Criptado[i]);   // Donc, la lettre ne fut pas cryptée ...

    RESULT := RESULT + Chr(curOrd);
  end;
end;

procedure TdbpVernam.SetAbout;
begin
// rien
end;

constructor TdbpVernam.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FAbout          := 'v1.2 par Julio P. (Diabloporc), Mauricio (Fafe Portugal), RM50Man';
 fFile           := '';
 fFileEncoded    := '';
 fFileDecoded    := '';
 fFileKey        := '';
 fUseFileKey     := false;
 fUseTextCle     := false;
end;

procedure Register;
begin
  RegisterComponents('Diabloporc', [TdbpVernam]);
end;

procedure TdbpVernam.SetFile(const Value: TFileName);
begin
 if (not fileexists(Value)) and (length(value)>0) then exit;
 fFile := Value;
end;

procedure TdbpVernam.SetFileDecoded(const Value: TFileName);
begin
 if fFileDecoded=Value then exit;
 fFileDecoded := Value;
end;

procedure TdbpVernam.SetFileEncoded(const Value: TFileName);
begin
 if fFileEncoded=Value then exit;
 fFileEncoded := Value;
end;

procedure TdbpVernam.SetFileKey(const Value: TFileName);
begin
 if (not fileexists(Value)) and (length(value)>0) then exit;
 fFileKey := Value;
end;

function TdbpVernam.EncodeFichier: boolean;
begin
 if fFile='' then begin result := false; exit; end;
 if fUseFileKey then
  begin
   if fFileKey='' then begin result := false; exit; end;
   VERNAM_CRYPT_FILE_WITH_PREDEF_KEY(fFile, fFileEncoded+'.vn', fFileKey);
  end
 else
  VERNAM_CRYPT_FILE(fFile, fFileEncoded+'.vn', fFile+'.vnk');

 result := fileexists(fFileEncoded+'.vn');
end;

function TdbpVernam.DecodeFichier: boolean;
begin
 if (fFile='') or (fFileKey='') then begin result := false; exit; end;
 VERNAM_DECRYPT_FILE(fFile, fFileDecoded, fFileKey);
 result := fileexists(fFileDecoded);
end;

function TdbpVernam.DecodeText: boolean;
begin
 if (fText='') then begin result := false; exit; end;
 fTextDecode := '';
 fTextDecode := VERNAM_DECRYPT(fText, fTextCle);
 result := fTextDecode <> '';
end;

function TdbpVernam.EncodeText: boolean;
begin
 if (fText='') then begin result := false; exit; end;
  if not fUseTextCle then
   begin
    fTextEncode := '';
    fTextEncode := VERNAM_CRYPT(fText, fTextCle);
    result := fTextEncode <> '';
   end
  else
   begin
    fTextEncode := '';
    fTextEncode := VERNAM_CRYPT_WITH_PREDEF_KEY(fText, fTextCle);
    result := fTextEncode <> '';
   end;
end;

end.