Contributor: SWAG SUPPORT TEAM        

(*-----
        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 *)