[Back to ENCRYPT SWAG index] [Back to Main SWAG index] [Original]

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

[Back to ENCRYPT SWAG index] [Back to Main SWAG index] [Original]