(*----- Program : CODE/DECODE File : Code.Pas Version : 1.2 Author(s) : Mark Midgley Date (Started) : April 11, 1990 Date (Finished) : , 1990 Comment(s) : -----*) Program Code_and_DeCode; {$IFDEF DEBUG} {$D+} (* Turn Debugging Info **ON** *) {$L+} (* Turn Local Symbols **ON** *) {$R+} (* Turn Range Checking **ON** *) {$S+} (* Turn Stack Checking **ON** *) {$ELSE} {$D-} (* Turn Debugging Info **OFF** *) {$L-} (* Turn Local Symbols **OFF** *) {$R-} (* Turn Range Checking **OFF** *) {$S-} (* Turn Stack Checking **OFF** *) {$ENDIF} Uses Crt, Dos; Const BufSize = 512; Version = '1.3'; MaxError = 7; Type EDMode = (EnCrypt,EnCryptPass,DeCrypt); String79 = String[79]; FilePaths = Array [1..2] Of String79; Errors = 1..(MaxError - 1); Procedure WriteXY( X,Y : Byte; S : String79 ); Begin (* WriteXY *) GotoXY(X,Y); Write(S); End; (* WriteXY *) Function UpStr( S : String ) : String; Var X : Byte; Begin (* UpStr *) For X := 1 To Length(S) Do S[x] := (UpCase(S[x]) ); UpStr := S; End; (* UpStr *) Procedure Center( Y : Byte; S : String; OverWriteMode : Errors ); Var X : Byte; Begin (* Center *) GotoXY(1,Y); Case (OverWriteMode) of 1 : For X := 2 To 78 Do WriteXY(X,WhereY,' '); 2 : ClrEOL; End; (* Case *) X := ((79 - Length(S)) Div 2); If (X <= 0) Then X := 1; WriteXY(X,Y,S); End; (* Center *) Procedure OutError( S : String79; X,OWM : Errors ); Var T : String79; Begin (* OutError *) GotoXY(1, WhereY); Case ( X ) Of 1 : T := ('Incorrect Number of parameters.'); 2 : T := ('Input file "'+ S +'" not found.'); 3 : T := ('Input and Output files conflict.'); 4 : T := ('User Aborted!'); 5 : T := ('Input file "'+ S +'" is corrupted!'); 6 : If (T = '') Then T := ('DOS Input/Output Failure.') Else T := S; End; (* Case *) TextColor(LightRed); Center(WhereY,T,OWM); TextColor(LightGray); If (OWM = 1) Then WriteLn; WriteLn; Halt(x); End; (* OutError *) Procedure HelpScreen( FullScreen : Boolean ); Begin (* HelpScreen *) TextColor(LightGray); GotoXY(1,WhereY); WriteLn(' USAGE: CODE [/D|/E|/P] INPUT_FILE OUTPUT_FILE'); WriteLn(' Options are: /D Decode File.'); WriteLn(' /E Encode File.'); WriteLn(' /P Encode with Password.'); If (Not FullScreen) Then Halt(MaxError); WriteLn; WriteLn('Description:'); WriteLn; WriteLn(' CODE encrypts a DOS file to garbage using a randomly generated seed'); WriteLn(' and then back again. For more protection, the password option can be used.'); WriteLn(' Note: With no option, CODE defaults to encode "/E"; Input and Output files'); WriteLn(' must be different; the "/P" option will prompt for the password and echo'); WriteLn(' dots; Code does not allow wildcards; Pressing ESCape during operation will'); WriteLn(' abort. The author does not guarantee the reliability of this program and'); WriteLn(' is not responsible for any data lost. If you appreciate this program in any'); WriteLn(' way or value its use then please send $5.00 - $20.00 to:'); WriteLn; TextColor(White); WriteLn(' Mark "Zing" Midgley'); WriteLn(' 843 East 300 South'); WriteLn(' Bountiful Ut, 84010'); TextColor(LightGray); Halt(MaxError); End; (* HelpScreen *) Function Shrink( P : PathStr ) : String79; Var D : DirStr; N : NameStr; E : ExtStr; Begin (* Shrink *) FSplit(P,D,N,E); Shrink := N + E; End; (* Shrink *) Procedure GraphIt( Var F1, F2 : File; Var OldX : Byte; Hour, Min, Sec, Sec100 : Word; BoxSetUp : Boolean ); Var F1Size, F2Size : LongInt; Percent, X, NewX : Byte; H, M, S, S100 : Word; A, B, C, D, Temp : String79; Begin (* GraphIt *) If (BoxSetUp) Then Begin Percent := 0; OldX := 3; GotoXY(1,WhereY); WriteLn('ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»'); WriteLn('º º'); WriteLn('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ'); GotoXY(3,WhereY - 2); End Else Begin GetTime(H,M,S,S100); If (Sec100 <= S100) Then Dec(S100,Sec100) Else Begin S100 := (S100 + 100 - Sec100); If (S > 0) Then Dec(S); End; If (Sec <= S) Then Dec(S,Sec) Else Begin S := (S + 60 - Sec); If (M > 0) Then Dec(M); End; If (Min <= M) Then Dec(M,Min) Else Begin M := (M + 60 - Min); If (H > 0) Then Dec(H); End; If (Hour <= H) Then Dec(H,Hour) Else H := (H + 12 - Hour); Str(H,A); Str(M,B); Str(S,C); Str(S100,D); Case (S100) of 0..9 : D := ('0' + D); End; (* Case *) If (M > 0) Then Case (S) of 0..9 : C := ('0' + C); End; (* Case *) If (H > 0) Then Case (M) of 0..9 : B := ('0' + B); End; (* Case *) If (H = 0) Then Begin If (M = 0) Then Temp := (Concat(C,'.',D,' sec') ) Else Temp := (Concat(B,' min ',C,'.',D,' sec') ); End Else If (H = 1) Then Temp := (Concat(A,' hr ',B,' min ',C,'.',D,' sec') ) Else Temp := (Concat(A,' hrs ',B,' min ',C,'.',D,' sec') ); F1Size := FileSize(F1); F2Size := FileSize(F2); If (F2Size <= F1Size) Then Percent := ((F2Size * 100) Div F1Size ) Else Percent := 100; NewX := (((Percent * 76) Div 100) + 2); If (NewX < 3) Then NewX := 3; For X := OldX To NewX Do WriteXY(X,WhereY,#176); OldX := NewX; Center(WhereY + 1,(#181 + ' ' + Temp + ' ' + #198),3); GotoXY(NewX,WhereY - 1); End; End; (* GraphIt *) Procedure Rm( FileName : String79 ); Var F : File; Begin (* Rm *) If (FileName = '') Then Exit; Assign(F,FileName); Erase(F); End; (* Rm *) Procedure GetStr( Var S : String79; Prompt,FName : String79; Show : Boolean ); Var Max, Min : Byte; A : Char; X : Byte; Begin (* GetStr *) If (FName = '') Then Begin Max := 54; Min := 0 End Else Begin Max := 25; Min := 3 End; TextColor(LightGray); WriteXY(1,WhereY,Prompt); Repeat GotoXY(Length(Prompt) + 1,WhereY); ClrEOL; If (Show) Then WriteXY(Length(Prompt) + 1,WhereY,S) Else For X := 1 To Length(S) Do Write(#249); A := (ReadKey); Case ( A ) of #32..#126 : If (Length(S) < Max) Then S := S + A Else Begin Sound(100); Delay(12); NoSound; End; #8 : If (Length(S) > 0) Then Delete(S,(Length(S) ), 1); #0 : A := ReadKey; #27: Begin Rm(FName); OutError('',4,2); End; End; (* Case *) Until (A = #13) And (Length(S) >= Min); End; (* GetStr *) Function RealFile( St : String79; OWM : Errors ) : Boolean; Var Error : Word; F : File; Begin (* RealFile *) RealFile := False; Assign(F,St); {$I-} (* Turn Input/Output-Checking Switch Off *) Reset(F); (* Open file. *) Error := IOResult; {$I+} (* Turn Input/Output-Checking Switch On *) If (Error = 0) Then (* File exists. *) Begin RealFile := True; Close(F); End Else {*} Case (Error) Of 152 : OutError('Drive Not Ready.',6,OWM); 3 : OutError('Invalid Drive specification.',6,OWM); (* 5 : Directory *) End; (* Case *) End; (* RealFile *) Procedure CheckError( FileName, Msg : String79 ); Var Error : Word; Begin (* CheckError *) Error := IOResult; If (Error <> 0) Then Begin If (Error <> 152) And (Error <> 3) Then Rm(FileName) Else Msg := ('Drive Not Ready.'); OutError(Msg,6,1); End; End; (* CheckError *) Procedure CheckAbort( FileName : String79 ); Begin (* CheckAbort *) If (KeyPressed) Then If (ReadKey = #27) Then Begin Rm(FileName); OutError('',4,1); End; End; (* CheckAbort *) (*---- Procedure Encode(); Author(s) : Mark Midgley Louis Zirkel Comments : Cool Man... ----*) Procedure EnCode( _File : FilePaths; Protect : Boolean ); Var Seed, PI, Y, OldX : Byte; I, Increment : Integer; Buf : Array [1..BufSize] of Char; Hour, Min, Sec, Sec100, Status : Word; Temp, Pass : String79; F1, F2 : File; Begin (* EnCode *) Pass := ''; {$I-} Assign(F1, _File[1]); (* input file *) Assign(F2, _File[2]); (* output file *) Reset(F1,1); CheckError('','Couldn''t open input file.'); ReWrite(F2,1); CheckError(_File[2],'Couldn''t create output file.'); Randomize; If (Protect) Then Begin GetStr(Pass,'(3 Char min, 25 Char max) Enter Password: ',_File[2],False); Buf[1] := Chr(Random(127) ); BlockWrite(F2,Buf[1],SizeOf(Buf[1]),Status); CheckError(_File[2],'Couldn''t write to output file.'); End Else Begin Buf[1] := Chr(Random(127) + 127); BlockWrite(F2,Buf[1],SizeOf(Buf[1]),Status); CheckError(_File[2],'Couldn''t write to output file.'); End; Seed := Ord(Buf[1]); Increment := 1; PI := 1; Y := 127; TextColor(LightGray); ClrEOL; GetTime(Hour,Min,Sec,Sec100); GraphIt(F1,F2,OldX,Hour,Min,Sec,Sec100,True); Repeat BlockRead(F1, Buf, BufSize, Status); CheckError(_File[2],'Couldn''t read input file.'); CheckAbort(_File[2]); GraphIt(F1,F2,OldX,Hour,Min,Sec,Sec100,False); For I := 1 To BufSize Do Begin If (Protect) Then Begin Buf[I] := Char(Byte(Buf[I]) XOR Byte(Pass[PI])); If (PI = Length(Pass)) Then Increment := -1; If (PI = 1) Then Increment := 1; Inc(PI,Increment); End Else Begin Buf[I] := Char(Byte(Buf[I]) XOR Y); End; End; BlockWrite(F2, Buf, Status); CheckError(_File[2],'Couldn''t write to output file.'); Until (Status < BufSize); Close(F1); CheckError(_File[2],'Couldn''t close input file.'); Close(F2); CheckError(_File[2],'Couldn''t close output file.'); {$I+} (* Successful Encryption *) TextColor(LightGray); Temp := (Shrink(_File[1]) +' Encoded to '+ Shrink(_File[2])); If (Protect) Then Temp := (Temp + ' with Password.'); Center(WhereY,Temp,1); GotoXY(1,WhereY + 1); WriteLn; End; (* EnCode *) (*---- Procedure DeCode(); Author(s) : Mark Midgley Louis Zirkel Comments : Cool Man... ----*) Procedure DeCode( _File : FilePaths ); Var Seed, PI, Y, OldX : Byte; I, Increment : Integer; Buf : Array [1..BufSize] of Char; Hour, Min, Sec, Sec100, Status : Word; Temp, Pass : String79; F1, F2 : File; Begin (* DeCode *) Pass := ''; {$I-} Assign(F1, _File[1]); Assign(F2, _File[2]); Reset(F1,1); CheckError('','Couldn''t open input file.'); ReWrite(F2,1); CheckError(_File[2],'Couldn''t create output file.'); BlockRead(F1,Buf[1],SizeOf(Buf[1]),Status); CheckError(_File[2],'Couldn''t read input file.'); Seed := Ord(Buf[1]); If (Buf[1] < #127) Then (* There's a Password *) GetStr(Pass,'Enter Password: ',_File[2],False); Increment := 1; PI := 1; Y := 127; TextColor(LightGray); ClrEOL; GetTime(Hour,Min,Sec,Sec100); GraphIt(F1,F2,OldX,Hour,Min,Sec,Sec100,True); Repeat BlockRead(F1, Buf, BufSize, Status); CheckError(_File[2],'Couldn''t read input file.'); GraphIt(F1,F2,OldX,Hour,Min,Sec,Sec100,False); CheckAbort(_File[2]); For I := 1 To BufSize Do Begin If (Pass <> '') Then (* There's a Password *) Begin Buf[I] := Char(Byte(Buf[I]) XOR Byte(Pass[PI])); If (PI = Length(Pass)) Then Increment := -1; If (PI = 1) Then Increment := 1; Inc(PI,Increment); End Else Begin Buf[I] := Char(Byte(Buf[I]) XOR Y); End; End; BlockWrite(F2, Buf, Status); CheckError(_File[2],'Couldn''t write to output file.'); Until (Status < BufSize); Close(F1); CheckError(_File[2],'Couldn''t close input file.'); Close(F2); CheckError(_File[2],'Couldn''t close output file.'); {$I+} (* Successful Decryption *) Center(WhereY,Shrink(_File[1]) +' Decoded to '+ Shrink(_File[2]),1); GotoXY(1,WhereY + 1); WriteLn; End; (* DeCode *) Procedure CheckParameters; Var _File : FilePaths; Temp : String79; Mode : EDMode; OkMode, Input1, Input2 : Boolean; X : Byte; Begin (* CheckParameters *) For X := 1 To 2 Do _File[x] := ''; Mode := EnCrypt; OkMode := False; X := 1; While (X <= ParamCount) Do Begin Temp := (UpStr(ParamStr(x) ) ); If (Pos('?',Temp) > 0) or (Pos('*',Temp) > 0) Then HelpScreen(True); If ((Temp[1] = '/') or (Temp[1] = '-')) And (Length(Temp) = 2) And (Not OkMode) Then Begin Case (Temp[2]) of 'E' : Begin Mode := EnCrypt; OkMode := True; End; 'D' : Begin Mode := DeCrypt; OkMode := True; End; 'P' : Begin Mode := EnCryptPass; OkMode := True; End; 'H', '?' : HelpScreen(True); Else OkMode := False; End; (* Case *) End Else Begin If (_File[1] = '') Then _File[1] := Temp Else If (_File[2] = '') Then _File[2] := Temp; End; Inc(x); End; If (_File[1] = '') Then Begin GetStr(_File[1],'Enter Input Path/File : ','',True); Input1 := True; _File[1] := (UpStr(_File[1]) ); End Else Input1 := False; If (_File[2] = '') Then Begin GetStr(_File[2],'Enter Output Path/File : ','',True); Input2 := True; _File[2] := (UpStr(_File[2]) ); End Else Input2 := False; If (Pos('?',_File[1]+_File[2]) > 0) or (Pos('*',_File[1]+_File[2]) > 0) Then HelpScreen(True); If (Not OkMode) And ((Input1) or (Input2)) And (_File[1] <> '') And (_File[2] <> '') Then Begin WriteXY(1,WhereY,'[E]ncode, Encode with [P]assword, or [D]ecode? '); ClrEOL; Case (UpCase(ReadKey) ) of 'E' : Mode := EnCrypt; 'D' : Mode := DeCrypt; 'P' : Mode := EnCryptPass; #27 : OutError('',4,2); End; (* Case *) End Else If (_File[1] = '') or (_File[2] = '') Then HelpScreen(False); If ((ParamCount < 2) or (ParamCount > 3)) And (_File[1] = '') And (_File[2] = '') Then OutError('',1,2); If (Not(RealFile(_File[1],2) ) ) Then OutError(Shrink(_File[1]),2,2); If (RealFile(_File[2],2) ) Then Begin If (FExpand(_File[1]) = FExpand(_File[2]) ) Then OutError('',3,2); TextColor(Red); WriteXY(1,WhereY,'Warning! "'); TextColor(LightRed); Write(Shrink(_File[2]) ); TextColor(Red); Write('" already exists...Replace ([Y],N)? '); ClrEOL; Case (UpCase(ReadKey) ) Of 'N',#27 : OutError('',4,2); End; (* Case *) End; If (Mode = EnCryptPass) Then EnCode(_File,True); If (Mode = EnCrypt) Then EnCode(_File,False); If (Mode = DeCrypt) Then DeCode(_File); End; (* CheckParameters *) Procedure Main; Begin (* Main *) CheckBreak := False; TextColor(LightGray); WriteLn; ClrEOL; WriteXY(12,WhereY,'DOS file Encrypter v' + Version + ' by '); TextColor(LightBlue); Write('Zing Merway'); TextColor(LightGray); WriteLn(' CODE/h for Help.'); WriteLn; CheckParameters; End; (* Main *) Begin (* Code *) Main; End. (* Code *)