home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / encrypt.swg / 0003_ENCRYPT.PAS.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-28  |  8.2 KB  |  233 lines
  1. {$A+,B-,D-,E+,F-,G+,I+,L-,N-,O-,R-,S-,V-,X+}
  2. {$M 4048,0,131040}
  3. Program encrypt;
  4.  
  5. { Author Trevor J Carlsen - released into the public domain 1992         }
  6. {        PO Box 568                                                      }
  7. {        Port Hedland                                                    }
  8. {        Western Australia 6721                                          }
  9. {        Voice +61 91 73 2026  Data +61 91 73  2569                      }
  10. {        FidoNet 3:690/644                                               }
  11.  
  12. { Syntax: encrypt /p=PassWord /k=KeyFile /f=File                         }
  13. { Example -                                                              }
  14. {         encrypt /p=billbloggs /k=c:\command.com /f=p:\prog\anyFile.pas }
  15.  
  16. {         PassWord can be any alpha-numeric sequence of AT LEAST four    }
  17. {         Characters.                                                    }
  18.  
  19. {         KeyFile is the full path of any File on the system that this   }
  20. {         Program runs on.  This File, preferably a large one, must not  }
  21. {         be subject to changes.  This is critical as it is used as a    }
  22. {         pseudo "one time pad" style key and the slightest change will  }
  23. {         render decryption invalid.                                     }
  24.  
  25. {         File is the full path of the File to be encrypted or decrypted.}
  26.  
  27. { notes:  Running Encrypt a second time With exactly the same parameters }
  28. {         decrypts an encrypted File.  For total security the keyFile    }
  29. {         can be stored separately on a floppy.  Without this keyFile or }
  30. {         knowledge of its contents it is IMPOSSIBLE to decrypt the      }
  31. {         encrypted File.                                                }
  32.  
  33. {         Parameters are Case insensitive and may be in any order and    }
  34. {         may not contain any Dos separator Characters.                  }
  35.  
  36. Const
  37.   BufferSize   = 65520;
  38.   Renamed      : Boolean = False;
  39.  
  40. Type
  41.   buffer_      = Array[0..BufferSize - 1] of Byte;
  42.   buffptr      = ^buffer_;
  43.   str80        = String[80];
  44.  
  45. Var
  46.   OldExitProc  : Pointer;
  47.   KeyFile,
  48.   OldFile,
  49.   NewFile      : File;
  50.   KeyBuffer,
  51.   Buffer       : buffptr;
  52.   KeyFileSize,
  53.   EncFileSize  : LongInt;
  54.   PassWord,
  55.   KFName,
  56.   FFName       : str80;
  57.  
  58. Procedure Hash(p : Pointer; numb : Byte; Var result: LongInt);
  59.   { When originally called numb must be equal to sizeof    }
  60.   { whatever p is pointing at.  if that is a String numb   }
  61.   { should be equal to length(the_String) and p should be  }        
  62.   { ptr(seg(the_String),ofs(the_String)+1)                 }
  63.   Var
  64.     temp,
  65.     w    : LongInt;
  66.     x    : Byte;
  67.  
  68.   begin
  69.     temp := LongInt(p^);  RandSeed := temp;
  70.     For x := 0 to (numb - 4) do begin
  71.       w := random(maxint) * random(maxint) * random(maxint);
  72.       temp := ((temp shr random(16)) shl random(16)) +
  73.                 w + MemL[seg(p^):ofs(p^)+x];
  74.     end;
  75.     result := result xor temp;
  76.   end;  { Hash }
  77.  
  78. Procedure NewExitProc; Far;
  79.   { Does the "housekeeping" necessary on Program termination }
  80.   Var code : Integer;
  81.   begin
  82.     ExitProc := OldExitProc;  { Reset Exit Procedure Pointer to original }
  83.     Case ExitCode of
  84.     0: Writeln('Successfully encrypted or decrypted ',FFName);
  85.     1: begin
  86.          Writeln('This Program requires 3 parameters -');
  87.          Writeln('  /pPassWord');
  88.          Writeln('  /kKeyFile (full path and name)');
  89.          Write  ('  /fFile (The full path and name of the File');
  90.          Writeln(' to be processed)');
  91.          Writeln;
  92.          Write  ('These parameters can be in any order, are Case,');
  93.          Writeln(' insensitive, and may not contain any spaces.');
  94.        end;
  95.     2: Writeln('Could not find key File');
  96.     3: Writeln('Could not rename and/or open original File');
  97.     4: Writeln('Could not create encrypted File');
  98.     5: Writeln('I/O error during processing - could not Complete');
  99.     6: Writeln('Insufficient memory available');
  100.     7: begin
  101.          Writeln('Key  File is too small - aborted');
  102.          Writeln;
  103.          Writeln(' Key File must be at least as large as the buffer size ');
  104.          Write  (' or the size of the File to be encrypted, whatever is the');
  105.          Writeln(' smaller.');
  106.        end;
  107.     8: Writeln('PassWord must consist of at least 4 Characters');
  108.     else { any other error }
  109.       Writeln('Aborted With error ',ExitCode);
  110.     end; { Case }
  111.     if Renamed and (ExitCode <> 0) then
  112.       Writeln(#7'WARNinG: original File''s name is now TEMP.$$$');
  113.     {$I-}
  114.     close(KeyFile); Code := Ioresult;
  115.     close(NewFile); Code := Ioresult;
  116.     close(OldFile); Code := Ioresult;
  117.     if ExitCode = 0 then
  118.       Erase(OldFile); Code := Ioresult;
  119.     {$I+}
  120.   end; { NewExitProc }
  121.  
  122.  
  123. Function Str2UpCase(Var S: String): String;
  124.   { Converts a String S to upper Case.  Valid For English. }
  125.   Var
  126.     x : Byte;
  127.   begin
  128.     Str2UpCase[0] := S[0];
  129.     For x := 1 to length(S) do
  130.       Str2UpCase[x] := UpCase(S[x]);
  131.   end; { Str2UpCase }
  132.  
  133. Procedure Initialise;
  134.   Var
  135.     CommandLine : String;
  136.     FPos,FLen,
  137.     KPos,KLen,
  138.     PPos,PLen   : Byte;
  139.  
  140.   Procedure  AllocateMemory(Var p: buffptr; size: LongInt);
  141.     begin
  142.       if size < BufferSize then begin
  143.         if MaxAvail < size then halt(6);
  144.         GetMem(p,size);
  145.       end
  146.       else begin
  147.         if MaxAvail < BufferSize then halt(6);
  148.         new(p);
  149.       end;
  150.     end; { AllocateMemory }
  151.  
  152.   begin
  153.     FillChar(OldExitProc,404,0);       { Initialise all global Variables }
  154.     FillChar(PassWord,243,32);
  155.     ExitProc    := @NewExitProc;             { Set up new Exit Procedure }
  156.     if ParamCount <> 3 then halt(1);
  157.     CommandLine := String(ptr(PrefixSeg,$80)^)+' '; { Add trailing space }
  158.     CommandLine := Str2UpCase(CommandLine);      { Convert to upper Case }
  159.     PPos        := pos('/P=',CommandLine);     { Find passWord parameter }
  160.     KPos        := pos('/K=',CommandLine);      { Find keyFile parameter }
  161.     FPos        := pos('/F=',CommandLine); { Find Filename For encryption}
  162.     if (PPos = 0) or (KPos = 0) or (FPos = 0) then Halt(1);
  163.     FFName      := copy(CommandLine,FPos+3,80);
  164.     FFName[0]   := chr(pos(' ',FFName)-1);       { Correct String length }
  165.     KFName      := copy(CommandLine,KPos+3,80);
  166.     KFName[0]   := chr(pos(' ',KFName)-1);
  167.     PassWord    := copy(CommandLine,PPos+3,80);
  168.     PassWord[0] := chr(pos(' ',PassWord)-1);
  169.     if length(PassWord) < 4 then halt(8);
  170.     { Create a random seed value based on the passWord }
  171.     Hash(ptr(seg(PassWord),ofs(PassWord)+1),length(PassWord),RandSeed);
  172.     assign(OldFile,FFName);
  173.     {$I-}
  174.     rename(OldFile,'TEMP.$$$');
  175.     if Ioresult <> 0 then
  176.       halt(3)
  177.     else
  178.       renamed := True;
  179.     assign(OldFile,'TEMP.$$$');
  180.     reset(OldFile,1);
  181.     if Ioresult <> 0 then halt(3);
  182.     assign(NewFile,FFName);
  183.     reWrite(NewFile,1);
  184.     if Ioresult <> 0 then halt(4);
  185.     assign(KeyFile,KFName);
  186.     reset(KeyFile,1);
  187.     if Ioresult <> 0 then halt(2);
  188.     EncFileSize := FileSize(OldFile);
  189.     KeyFileSize := FileSize(KeyFile);
  190.     if KeyFileSize > EncFileSize then
  191.       KeyFileSize := EncFileSize;
  192.     if Ioresult <> 0 then halt(5);
  193.     {$I+}
  194.     if (KeyFileSize < BufferSize) and (KeyFileSize < EncFileSize) then
  195.       halt(7);
  196.     AllocateMemory(buffer,EncFileSize);
  197.     AllocateMemory(KeyBuffer,KeyFileSize);
  198.   end; { Initialise }
  199.  
  200. Procedure Main;
  201.   Var
  202.     BytesRead : Word;
  203.     finished  : Boolean;
  204.  
  205.   Procedure CodeBuffer(number: Word);
  206.     { This is the actual encryption/decryption engine }
  207.     Var x : Word;
  208.     begin
  209.       For x := 0 to number - 1 do
  210.         buffer^[x] := buffer^[x] xor KeyBuffer^[x] xor Random(256);
  211.     end; { CodeBuffer }
  212.  
  213.   begin
  214.     {$I-}
  215.     finished := False;
  216.     Repeat
  217.       BlockRead(OldFile,buffer^,BufferSize,BytesRead);
  218.       if Ioresult <> 0 then halt(5);
  219.       if (FilePos(KeyFile) + BytesRead) > KeyFileSize then
  220.         seek(KeyFile,0);
  221.       BlockRead(KeyFile,KeyBuffer^,BytesRead,BytesRead);
  222.       if Ioresult <> 0 then halt(5);
  223.       CodeBuffer(BytesRead);
  224.       finished := BytesRead < BufferSize;
  225.       BlockWrite(NewFile,buffer^,BytesRead);
  226.     Until finished;
  227.   end;  { Main }
  228.  
  229. begin
  230.   Initialise;
  231.   Main;
  232. end.
  233.