{$A+,B-,D-,E+,F-,G+,I+,L-,N-,O-,R-,S-,V-,X+}
{$M 4048,0,131040}
Program encrypt;

{ Author Trevor J Carlsen - released into the public domain 1992         }
{        PO Box 568                                                      }
{        Port Hedland                                                    }
{        Western Australia 6721                                          }
{        Voice +61 91 73 2026  Data +61 91 73  2569                      }
{        FidoNet 3:690/644                                               }

{ Syntax: encrypt /p=PassWord /k=KeyFile /f=File                         }
{ Example -                                                              }
{         encrypt /p=billbloggs /k=c:\command.com /f=p:\prog\anyFile.pas }

{         PassWord can be any alpha-numeric sequence of AT LEAST four    }
{         Characters.                                                    }

{         KeyFile is the full path of any File on the system that this   }
{         Program runs on.  This File, preferably a large one, must not  }
{         be subject to changes.  This is critical as it is used as a    }
{         pseudo "one time pad" style key and the slightest change will  }
{         render decryption invalid.                                     }

{         File is the full path of the File to be encrypted or decrypted.}

{ notes:  Running Encrypt a second time With exactly the same parameters }
{         decrypts an encrypted File.  For total security the keyFile    }
{         can be stored separately on a floppy.  Without this keyFile or }
{         knowledge of its contents it is IMPOSSIBLE to decrypt the      }
{         encrypted File.                                                }

{         Parameters are Case insensitive and may be in any order and    }
{         may not contain any Dos separator Characters.                  }

Const
  BufferSize   = 65520;
  Renamed      : Boolean = False;

Type
  buffer_      = Array[0..BufferSize - 1] of Byte;
  buffptr      = ^buffer_;
  str80        = String[80];

Var
  OldExitProc  : Pointer;
  KeyFile,
  OldFile,
  NewFile      : File;
  KeyBuffer,
  Buffer       : buffptr;
  KeyFileSize,
  EncFileSize  : LongInt;
  PassWord,
  KFName,
  FFName       : str80;

Procedure Hash(p : Pointer; numb : Byte; Var result: LongInt);
  { When originally called numb must be equal to sizeof    }
  { whatever p is pointing at.  if that is a String numb   }
  { should be equal to length(the_String) and p should be  }        
  { ptr(seg(the_String),ofs(the_String)+1)                 }
  Var
    temp,
    w    : LongInt;
    x    : Byte;

  begin
    temp := LongInt(p^);  RandSeed := temp;
    For x := 0 to (numb - 4) do begin
      w := random(maxint) * random(maxint) * random(maxint);
      temp := ((temp shr random(16)) shl random(16)) +
                w + MemL[seg(p^):ofs(p^)+x];
    end;
    result := result xor temp;
  end;  { Hash }

Procedure NewExitProc; Far;
  { Does the "housekeeping" necessary on Program termination }
  Var code : Integer;
  begin
    ExitProc := OldExitProc;  { Reset Exit Procedure Pointer to original }
    Case ExitCode of
    0: Writeln('Successfully encrypted or decrypted ',FFName);
    1: begin
         Writeln('This Program requires 3 parameters -');
         Writeln('  /pPassWord');
         Writeln('  /kKeyFile (full path and name)');
         Write  ('  /fFile (The full path and name of the File');
         Writeln(' to be processed)');
         Writeln;
         Write  ('These parameters can be in any order, are Case,');
         Writeln(' insensitive, and may not contain any spaces.');
       end;
    2: Writeln('Could not find key File');
    3: Writeln('Could not rename and/or open original File');
    4: Writeln('Could not create encrypted File');
    5: Writeln('I/O error during processing - could not Complete');
    6: Writeln('Insufficient memory available');
    7: begin
         Writeln('Key  File is too small - aborted');
         Writeln;
         Writeln(' Key File must be at least as large as the buffer size ');
         Write  (' or the size of the File to be encrypted, whatever is the');
         Writeln(' smaller.');
       end;
    8: Writeln('PassWord must consist of at least 4 Characters');
    else { any other error }
      Writeln('Aborted With error ',ExitCode);
    end; { Case }
    if Renamed and (ExitCode <> 0) then
      Writeln(#7'WARNinG: original File''s name is now TEMP.$$$');
    {$I-}
    close(KeyFile); Code := Ioresult;
    close(NewFile); Code := Ioresult;
    close(OldFile); Code := Ioresult;
    if ExitCode = 0 then
      Erase(OldFile); Code := Ioresult;
    {$I+}
  end; { NewExitProc }


Function Str2UpCase(Var S: String): String;
  { Converts a String S to upper Case.  Valid For English. }
  Var
    x : Byte;
  begin
    Str2UpCase[0] := S[0];
    For x := 1 to length(S) do
      Str2UpCase[x] := UpCase(S[x]);
  end; { Str2UpCase }

Procedure Initialise;
  Var
    CommandLine : String;
    FPos,FLen,
    KPos,KLen,
    PPos,PLen   : Byte;

  Procedure  AllocateMemory(Var p: buffptr; size: LongInt);
    begin
      if size < BufferSize then begin
        if MaxAvail < size then halt(6);
        GetMem(p,size);
      end
      else begin
        if MaxAvail < BufferSize then halt(6);
        new(p);
      end;
    end; { AllocateMemory }

  begin
    FillChar(OldExitProc,404,0);       { Initialise all global Variables }
    FillChar(PassWord,243,32);
    ExitProc    := @NewExitProc;             { Set up new Exit Procedure }
    if ParamCount <> 3 then halt(1);
    CommandLine := String(ptr(PrefixSeg,$80)^)+' '; { Add trailing space }
    CommandLine := Str2UpCase(CommandLine);      { Convert to upper Case }
    PPos        := pos('/P=',CommandLine);     { Find passWord parameter }
    KPos        := pos('/K=',CommandLine);      { Find keyFile parameter }
    FPos        := pos('/F=',CommandLine); { Find Filename For encryption}
    if (PPos = 0) or (KPos = 0) or (FPos = 0) then Halt(1);
    FFName      := copy(CommandLine,FPos+3,80);
    FFName[0]   := chr(pos(' ',FFName)-1);       { Correct String length }
    KFName      := copy(CommandLine,KPos+3,80);
    KFName[0]   := chr(pos(' ',KFName)-1);
    PassWord    := copy(CommandLine,PPos+3,80);
    PassWord[0] := chr(pos(' ',PassWord)-1);
    if length(PassWord) < 4 then halt(8);
    { Create a random seed value based on the passWord }
    Hash(ptr(seg(PassWord),ofs(PassWord)+1),length(PassWord),RandSeed);
    assign(OldFile,FFName);
    {$I-}
    rename(OldFile,'TEMP.$$$');
    if Ioresult <> 0 then
      halt(3)
    else
      renamed := True;
    assign(OldFile,'TEMP.$$$');
    reset(OldFile,1);
    if Ioresult <> 0 then halt(3);
    assign(NewFile,FFName);
    reWrite(NewFile,1);
    if Ioresult <> 0 then halt(4);
    assign(KeyFile,KFName);
    reset(KeyFile,1);
    if Ioresult <> 0 then halt(2);
    EncFileSize := FileSize(OldFile);
    KeyFileSize := FileSize(KeyFile);
    if KeyFileSize > EncFileSize then
      KeyFileSize := EncFileSize;
    if Ioresult <> 0 then halt(5);
    {$I+}
    if (KeyFileSize < BufferSize) and (KeyFileSize < EncFileSize) then
      halt(7);
    AllocateMemory(buffer,EncFileSize);
    AllocateMemory(KeyBuffer,KeyFileSize);
  end; { Initialise }

Procedure Main;
  Var
    BytesRead : Word;
    finished  : Boolean;

  Procedure CodeBuffer(number: Word);
    { This is the actual encryption/decryption engine }
    Var x : Word;
    begin
      For x := 0 to number - 1 do
        buffer^[x] := buffer^[x] xor KeyBuffer^[x] xor Random(256);
    end; { CodeBuffer }

  begin
    {$I-}
    finished := False;
    Repeat
      BlockRead(OldFile,buffer^,BufferSize,BytesRead);
      if Ioresult <> 0 then halt(5);
      if (FilePos(KeyFile) + BytesRead) > KeyFileSize then
        seek(KeyFile,0);
      BlockRead(KeyFile,KeyBuffer^,BytesRead,BytesRead);
      if Ioresult <> 0 then halt(5);
      CodeBuffer(BytesRead);
      finished := BytesRead < BufferSize;
      BlockWrite(NewFile,buffer^,BytesRead);
    Until finished;
  end;  { Main }

begin
  Initialise;
  Main;
end.