PROGRAM ENCIPHER; { enciphers electronic mail file }
 {$K-}

 {ENCIPHER   Myfile.COM   Myfile.TEL}

 {Version 2.0 1987 February 2 by Roedy Green}

 {Please direct comments for improvement of this public domain program to:}
 {Roedy Green}
 {Canadian Mind Products}
 {#11 - 2856 Sunset Street}
 {Burnaby, BC}
 {CANADA  V5G 1T3}
 {telephone (604) 435-2957}
 {Envoy/Bix id: ROEDY}

 {Change LineLength to n-1 where n is the longest line your Email}
 {can handle not including the CrLf}

 CONST LineLength = 125; {how often to insert Cr Lf Space in After file }

 TYPE charint = -1..255;
         {-1 indicates end of file}
      mystring = STRING[64];
         {variable length strings}
      runint = 0..97;
         {integer used to count repeating chars}
 VAR Before : FILE of CHAR;
        {input file not text so can process past EOF}
     After : TEXT [ 8192 {blocksize} ];
 linepos : -1 .. LineLength;
    {tracks when need to insert Cr Lf in After file}
 CheckSum : integer;
    {16 bit sum of chars in file.  Overflow ignored}
 c  : charint;
    {current char just read from Before file}
 ungotchar : charint;
    {if we have to unget a char it is kept here}
 ungot : BOOLEAN;
    {true if a char is sitting in ungotchar}
 done : BOOLEAN;
    {true if Before file is fully processed}
 Enciphering : BOOLEAN;
    {true if we are enciphering this part of the output}
    {we start enciphering after the ^c after the filename}


PROCEDURE Beep;
     BEGIN {Beep}
     Sound(400);
     Delay(500);
     NoSound
     END; {Beep}

PROCEDURE Die;
     BEGIN {Die}
     Beep;
     {$I-}
     Close (Before);
     Close (After);
     {$I+}
     HALT(1)
     END; {Die}

PROCEDURE unGetIt(c:charint);
 {undoes the GetIt.  allows 1 char lookahead }
     BEGIN {unGetIt}
     ungot := true;
     ungotchar := c
     END; {unGetIt}

 FUNCTION GetIt: charint; {get 1 character from Before file}
    VAR
    achar : char;
  BEGIN {GetIt}
    IF ungot THEN
        BEGIN
            {use recently ungotten char}
            GetIt := ungotchar;
            ungot := FALSE
            END
    ELSE
        BEGIN
        IF EOF(Before) then GetIt := -1 {eof indicator}
        ELSE
            BEGIN
            read(Before,achar);
            GetIt := ord(achar)
            END
    END
  END {GetIt};

PROCEDURE PutIt(c:charint) {emit 1 character to After file};
  BEGIN {PutIt}
        IF Enciphering THEN write(After, char(159-c))
        ELSE write(After, char(c));
        CheckSum := CheckSum + c;
        linepos := linepos - 1;
        IF linepos = 0 THEN
            BEGIN
            {emit Cr Lf space}
            write(After,char(13)); {wont be included in CheckSum}
            write(After,char(10));
            write(After,char(32));
 linepos := LineLength
        END {IF}
  END {PutIt};

PROCEDURE PutMarker; {emit pair ^c - note lower case c}
     {used to delimit sections of the output file}
     BEGIN {PutMarker}
       PutIt(94 {^});
       PutIt(99 {c})
    END {PutMarker};

PROCEDURE PutString(s:mystring); {emit string to After file}
    VAR
    i : runint;
    BEGIN {PutString}
    FOR i := 1 TO Length(s) do
        PutIt(ord(s[i]));
    END {PutString};

FUNCTION CalcRunLength(c:charint): integer;
    {returns count of chars to a max of 96}
    {and advances file pointer past them}
    VAR
    c1 : charint;
    i : runint;
    BEGIN {CalcRunLength}
        i := 0;
        REPEAT
            c1 := GetIt;
            i := i+1
        UNTIL (c1 <> c) OR ( i = 96 );
        unGetIt(c1); {push back first non-matching char}
        CalcRunLength := i
    END {CalcRunLength};


 PROCEDURE Squash(
        c : charint; {run to look for}
     one  : charint; {how to represent single char}
     two  : charint; {how to reresent a pair}
     more : charint  {how to represent run of 3..96}
         );
    {output the representation of a run}
    VAR
    runlength : runint;
    BEGIN {Squash}
    runlength := CalcRunLength(c);
        CASE runlength of
            1: PutIt(one);
            2: PutIt(two);
            else
                BEGIN
                PutIt(more);
                PutIt(runlength+30)
                END
        END {CASE}
    END {Squash};


 PROCEDURE PutHeader;
    {put header on After file containing file name of Before file}
    BEGIN {PutHeader}
    PutMarker;
    CheckSum := 0;
    {nothing prior to this counts in the CheckSum}
    PutString('ENCIPHER');
    PutString(ParamStr(1));
    PutMarker;
    END {PutHeader};


 PROCEDURE PutTrailer;
    {put trailer on After file containing CheckSum}
    {CheckSum first ^c thru ^c just prior to CheckSum}
    VAR Checkstring : STRING[5];
    BEGIN {PutTrailer}
    PutMarker;
    Enciphering := FALSE;
    {want low order 4 digits with leading zeros}
    Str(ABS(CheckSum mod 10000) + 10000 : 5, Checkstring);
    {strip the leading 1}
    PutString(COPY(Checkstring,2,4));
    PutMarker;
    {Emit final Cr Lf}
    write(After,char(13)); {wont be included in CheckSum}
    write(After,char(10))
    END {PutTrailer};

 BEGIN {ENCIPHER}

    if ParamCount <> 2 THEN
        BEGIN
        writeln('Oops! usage:   ENCIPHER   Myfile.COM   Myfile.TEL');
        Die
        END;

    IF Paramstr(1) = ParamStr(2) THEN
       BEGIN
       Writeln
       ('Oops! Cannot have the same name for the input and output files');
       Die
       END;

    Assign (Before, ParamStr(1));
    Assign (After, ParamStr(2));
    {$I-} {ensure no crash on cantopen}
    Reset(Before);
    IF IORESULT <> 0 THEN
       BEGIN
       Writeln('Oops! Cannot find file ',Paramstr(1));
       Die
       END;
    Rewrite(After);
    IF IORESULT <> 0 THEN
       BEGIN
       Writeln('Oops! Cannot create file ',Paramstr(2),
          ' -- probably no such subdirectory');
       Die
       END;
    {$I+}
    WriteLn('Encipher 2.0 creating file ',Paramstr(2));
    linepos := LineLength;
    ungot := false;
    done := false;
    CheckSum := 0;
    Enciphering := FALSE;
    PutHeader;
    Enciphering := TRUE;
            REPEAT
            c := GetIt;
            CASE c of
            -1 : { eof } done := TRUE;
            34, 36, 40..45, 47, 49..58, 61, 63..90, 97..122, 124 :
                BEGIN
                {leave-alone}
                PutIt(c);
                END;
            13: { convert CR LF to ; CR to ^M }
                BEGIN
                c := GetIt;
                IF c = 10 THEN
                    BEGIN
                    PutIt(59 {;})
                    END
                ELSE
                    BEGIN
                    unGetIt(c);
                    PutIt(94 {^});
                    PutIt(77 {M})
                   END {if}
                END;
            1..12, 14..31:
                BEGIN
                {control chars}
                PutIt(94 {^});
                PutIt(c+64);
                END;
                {chars that have special codes for runs}
             0: Squash(c, 92 {\}, 126 {~}, 35 {#});
            32: Squash(c, 38 {&}, 60 {<}, 62 {>});
            48: Squash(c, 48 {0}, 123 {left curly}, 125 {right curly});
           255: Squash(c, 37 {%}, 91 {[}, 93 {]});
            33, 35, 37..39, 59, 60, 62, 91..96, 123, 125, 126:
                BEGIN
                {punctuation that was stolen}
                PutIt(33 {!});
                PutIt(c)
                END;
            46: { . }
                BEGIN
                PutIt(94 {^});
                PutIt(98 {b})
                END;
            128..159 :
                BEGIN
                {control chars with high bit on}
                PutIt(39 {tick});
                PutIt(c-64)
                END;
            161..254 :
                BEGIN
                {chars with high bit on}
                PutIt(96 {grave});
                PutIt(c-128)
                END;
            127:
                BEGIN
                PutIt(94 {^});
                PutIt(96 {grave})
                END;
            160:
                BEGIN
                PutIt(94 {^});
                PutIt(97 {a})
                END
            ELSE {canthappen}
                BEGIN
                writeln('invalid character');
                Die
                END
            END {CASE}
            UNTIL Done;
       PutTrailer;
       Close(Before);
       Close(After)
END {ENCIPHER}.