{ SnowSig - Transform binary data into a random signature.
  Copyright (C) 2001 Peter Gerwinski <peter@gerwinski.de>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
 
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
 
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

}

program SnSg;

uses
  GPC;

const
  { A common encoding is base-64 encoding. But we want to use
    *every* bit plain ASCII allows, so we use this base instead
    of 64. }
  Base = 127 - 33;

type
  TByteArray (n: Integer) = array [1..n] of Byte;
  PByteArray = ^TByteArray;

var
  { Width of lines we are producing or accepting as encoded input }
  Cols: Integer = 72;

  { Number of lines we are producing }
  Lines: Integer = 4;

  { Buffer variables for the unencoded and encoded message }
  Msg, MsgEncoded: PByteArray;

  { Length of the unencoded and encoded message }
  MaxLen, MaxLenEncoded: Integer = 0;

  { Input file name. Default is StdIn. }
  InFileName: TString = '-';

  { Output file name. Default is StdOut. }
  OutFileName: TString = '-';

  { Separator. Default is no separator. }
  Separator: TString = '';

  { This comment is prepended to the encoded message.
    Default is 'http://snsg.org ' (including the blank). }
  Comment: TString = 'http://snsg.org ';

  { Decode. Default is to encode. }
  Decode: Boolean = False;

  { Verbose mode }
  Verbose: Boolean = False;

  { Pad with random bytes. }
  Pad: Boolean = True;

  { Print maximum length of message. }
  PrintMax: Boolean = False;

  { Output an error message and exit. }
  procedure Error (const ErrMsg: String);
  begin
    WriteLn (StdErr, ParamStr (0), ': ', ErrMsg);
    Halt (1)
  end;

  { Output a greeting message. }
  procedure Greeting (var OutFile: Text);
  begin
    WriteLn (OutFile, 'SnowSig 0.4 - Copyright (C) 2001 Peter Gerwinski <peter@gerwinski.de>');
    WriteLn (OutFile, 'This program is free software under the GNU General Public License.');
    WriteLn (OutFile)
  end;

  { Output a help message and exit. }
  procedure Help;
  begin
    Greeting (Output);
    WriteLn ('Usage: ', ParamStr (0), ' [Options] [Input]');
    WriteLn ('Valid options are:');
    WriteLn (' --help     -h              output this help text and exit');
    WriteLn (' --verbose  -v              tell verbosely what is happening');
    WriteLn (' --decode   -d              decode (default: encode)');
    WriteLn (' --output   -o <file>       write output to <file> instead of stdout');
    WriteLn (' --comment  -c <comment>    start with <comment>; default is "http://snsg.org "');
    WriteLn (' --sep      -s              prepend a separator line containing "-- "');
    WriteLn (' --cols     -C <columns>    set number of output columns; default is 72');
    WriteLn (' --lines    -L <lines>      set number of output lines; default is 4');
    WriteLn (' --max      -m              print maximum length of message to stderr');
    WriteLn (' --nopad    -N              do not pad with random bytes (for debugging)');
    Halt (0)
  end;

  { Use GNU GetOpt to parse the command line. }
  procedure ParseOptions;
  const
    LongOptions: array [1..10] of OptionType =
      (('help', NoArgument, nil, 'h'),
       ('verbose', NoArgument, nil, 'v'),
       ('decode', NoArgument, nil, 'd'),
       ('output', RequiredArgument, nil, 'o'),
       ('comment', RequiredArgument, nil, 'c'),
       ('sep', NoArgument, nil, 's'),
       ('cols', RequiredArgument, nil, 'C'),
       ('lines', RequiredArgument, nil, 'L'),
       ('max', NoArgument, nil, 'm'),
       ('nopad', NoArgument, nil, 'N'));
  var
    LongIndex: Integer;
    Ch: Char;

    function GetNumber (const S: String) = Result: Integer;
    var
      Code: Integer;
    begin
      Val (S, Result, Code);
      if Code <> 0 then
        Error ('invalid number')
    end;

  begin
    LongIndex := -1;
    repeat
      Ch := GetOptLong ('', LongOptions, LongIndex, False);
      case Ch of
        'h': Help;
        'v': Verbose := True;
        'd': Decode := True;
        'o': OutFileName := OptionArgument;
        'c': Comment := OptionArgument;
        's': Separator := '-- ';
        'C': Cols := GetNumber (OptionArgument);
        'L': Lines := GetNumber (OptionArgument);
        'm': PrintMax := True;
        'N': Pad := False;
      end
    until Ch = EndOfOptions;
    if FirstNonOption <= ParamCount then
      InFileName := ParamStr (FirstNonOption)
  end;

  { Calculate the maximum length we can put into the output
    and allocate buffers. }
  procedure Init;
  var
    i: Integer;
  begin
    MaxLenEncoded := Lines * Cols - Length (Comment);
    MaxLen := Trunc (Ln (Base) / Ln (2) * MaxLenEncoded / 8);
    if PrintMax then
      WriteLn (StdErr, MaxLen);
    New (Msg, MaxLen);
    for i := 1 to MaxLen do
      Msg^[i] := 0;
    New (MsgEncoded, MaxLenEncoded);
    for i := 1 to MaxLenEncoded do
      MsgEncoded^[i] := 0;
    if Verbose then
      Greeting (StdErr)
  end;

  { Scan the input for an encoded message and decode it. }
  procedure DecodeMessage;
  var
    L: TString;
    i, MsgTotal, InputCols, CommentLength: Integer;
    OutFile: file of Byte;

    function TryStandardComment (const L: String): Boolean;
    var
      p, s: Integer;
    begin
      p := Pos (' ', L);
      if (p = 0) or (p > 42) or (Length (L) - p < 42)
         or (PosFrom (' ', L, p + 1) > 0) then
        TryStandardComment := False
      else
        begin
          s := PosCase ('snsg', L);
          TryStandardComment := (s > 0) and (s <= p - Length ('snsg'))
        end
    end;

    { Check whether `Msg' is big enough and extend it if necessary. }
    procedure CheckMsg (n: Integer);
    var
      NewMsg: PByteArray;
      i: Integer;
    begin
      while n > Msg^.n do
        begin
          New (NewMsg, 2 * Msg^.n);
          for i := 1 to Msg^.n do
            NewMsg^[i] := Msg^[i];
          for i := Msg^.n + 1 to NewMsg^.n do
            NewMsg^[i] := 0;
          Dispose (Msg);
          Msg := NewMsg
        end
    end;

    { Msg := Base * Msg + x }
    procedure DecodeNumber (x: Integer);
    var
      i, y, R: Integer;
    begin
      R := 0;
      i := 1;
      while (i <= MsgTotal) or (R > 0) do
        begin
          y := Base * Msg^[i] + R;
          Msg^[i] := y mod 256;
          R := y div 256;
          Inc (i);
          CheckMsg (i)
        end;
      MsgTotal := Max (MsgTotal, i - 1);
      R := 0;
      i := 1;
      while (i <= MsgTotal) or (R > 0) do
        begin
          if i = 1 then
            y := Msg^[i] + x + R
          else
            y := Msg^[i] + R;
          Msg^[i] := y mod 256;
          R := y div 256;
          if R = 0 then
            i := MsgTotal + 1
          else
            Inc (i);
          CheckMsg (i)
        end;
      MsgTotal := Max (MsgTotal, i - 1)
    end;

    procedure DecodeLine (const L: String);
    var
      i: Integer;
    begin
      for i := 1 to Length (L) do
        DecodeNumber (Ord (L[i]) - 33)
    end;

  begin
    Close (Input);
    Assign (Input, InFileName);
    Reset (Input);
    Close (Output);
    Assign (OutFile, OutFileName);
    ReWrite (OutFile);
    CommentLength := 0;
    while not EOF do
      begin
        ReadLn (L);
        TrimBoth (L);
        InputCols := Length (L);
        if Copy (L, 1, Length (Comment)) = Comment then
          CommentLength := Length (Comment)
        else if TryStandardComment (L) then
          CommentLength := Pos (' ', L)
        else
          CommentLength := 0;
        if CommentLength > 0 then
          begin
            if Verbose then
              begin
                WriteLn (StdErr, 'Found Snow Signature:');
                WriteLn (StdErr, L)
              end;
            Delete (L, 1, CommentLength);
            MsgTotal := 1;
            repeat
              DecodeLine (L);
              if EOF then
                L := ''
              else
                begin
                  ReadLn (L);
                  TrimBoth (L);
                  if Verbose then
                    WriteLn (StdErr, L)
                end
            until Length (L) <> InputCols;
            for i := 1 to MsgTotal do
              Write (OutFile, Msg^[i]);
            if Verbose then
              WriteLn (StdErr)
          end
      end
  end;

  { Read the message into our buffer. If it does not fill the buffer
    pad it using pseudo-random bytes. If it is too long, complain. }
  procedure ReadMessage;
  var
    InFile: file of Byte;
    i: Integer;
  begin
    if Verbose then
      WriteLn (StdErr, 'Please type your message. Give ^D when done.');
    Randomize;
    Close (Input);
    Assign (InFile, InFileName);
    Reset (InFile);
    i := 1;
    while (i <= MaxLen) and not EOF (InFile) do
      begin
        Read (InFile, Msg^[i]);
        Inc (i)
      end;
    if not EOF (InFile) then
      Error ('message too long');
    while i <= MaxLen do
      begin
        if Pad then
          Msg^[i] := Random (256) else
          Msg^[i] := 0;
        Inc (i)
      end;
    Close (InFile)
  end;

  { Take the input as a little-endian base-256 number and encode it
    to a little-endian base-`Base' output:
     - calculate `Msg' modulo `Base' and store it in `MsgEncoded'.
     - divide `Msg' by `Base'
     - loop until `MsgEncoded' is full. }
  procedure EncodeMessage;
  var
    NewMsg, Temp: PByteArray;
    i, j, R: Integer;
  begin
    New (NewMsg, Msg^.n);
    for i := 1 to MaxLen do
      NewMsg^[i] := 0;
    for j := 1 to MaxLenEncoded do
      begin
	R := 0;
	for i := MaxLen downto 1 do
	  begin
	    NewMsg^[i] := (Msg^[i] + R shl 8) div Base;
	    R := (Msg^[i] + R shl 8) mod Base
	  end;
	MsgEncoded^[j] := R;
        Temp := Msg;
        Msg := NewMsg;
        NewMsg := Temp
      end;
    Dispose (NewMsg)
  end;

  { Output `MsgEncoded' in reverse order, i.e. big-endian. }
  procedure WriteMessage;
  var
    l, c, RndCtr: Integer;

    { Get one character of output from the buffer. }
    function RndChr: Char;
    begin
      RndChr := Chr (33 + MsgEncoded^[RndCtr]);
      Dec (RndCtr);
      if RndCtr < 0 then
        Error ('internal error')
    end;

  begin
    Close (Output);
    Assign (Output, OutFileName);
    ReWrite (Output);
    if Separator <> '' then
      WriteLn (Separator);
    Write (Comment);
    RndCtr := MsgEncoded^.n;
    for c := 1 to Cols - Length (Comment) do
      Write (RndChr);
    WriteLn;
    for l := 2 to Lines do
      begin
        for c := 1 to Cols do
          Write (RndChr);
        WriteLn
      end
  end;

begin
  ParseOptions;
  Init;
  if Decode then
    DecodeMessage
  else
    begin
      ReadMessage;
      EncodeMessage;
      WriteMessage
    end
end.