Листинг 3.

Кодирование стего хвостовыми пробелами.

program StegoBlank;

(***************************************************************)
(*     Простая  стеганографическая   программа,   использующая *)
(* хвостовые пробелы  для  встраивания  стего  в  произвольные *)
(* тексты.  мспользует  от  1  до  3  параметров,  которые   и *)
(* определяют выполняемую программой функцию. При этом  первый *)
(* из параметров всегда представляет файл-контейнер.           *)
(*     Если  этот  параметр   единственный,   то   проверяется *)
(* наличие  стеганограммы   в   файле-контейнере   с   выводом *)
(* результата на экран. По сути это режим стеганодетектора.    *)
(*     Если таких параметров два, стеганограмма извлекается из *)
(* контейнера, а  результат  записывается  в  заданный  вторым *)
(* параметром файл.                                            *)
(*     Наконец,  если  используются  все  три  параметра,   то *)
(* стеганографический  текст   из   файла   заданного   вторым *)
(* параметром, упрятывается в файл-контейнер, заданный  первым *)
(* параметром, а результат стеганографического  преобразования *)
(* записывается   в   файл,   заданный   третьим   параметром. *)
(* Совпадение двух имён файлов допускается (трёх - абсурд).    *)
(***************************************************************)

type
      StringType = string [$FF];

const
      TempName = '$$$$$$$$.$$$';
      Key1     = $1234;
      Key2     = $4567;
      Max      = 240;

var
      F, G, H   : text;
      Flag      : boolean;
      X         : StringType;
      I, K, L   : byte;
      C         : char;
      Count     : real;

begin
      LowVideo;

      if not (ParamCount in [1..3])
      then
           begin
                 WriteLn ('Ожидается от  1 до 3  параметров:');
                 WriteLn ('1 - вывод стеганограммы на экран;');
                 WriteLn ('2 - вывод стеганограммы  в  файл;');
                 WriteLn ('3 - запись стеганограммы в  файл.');
                 Exit
           end;

      Assign (F, ParamStr (1));
      Reset (F);
      Count := 0;

      MemW [Dseg : $01FE] := Key1;
      MemW [Dseg : $01FC] := Key2;

(*---------------------ВЫВОД СТЕГАНОГРАММЫ НА ЭКРАН--------------------*)
      if ParamCount = 1
      then
           begin
                 Flag := False;

                 while not Eof (F)
                 do
                    begin
                          ReadLn (F, X);
                          L := Length (X);

                          if L < Max
                          then
                               begin
                                     while X [L] = ' '
                                     do L := Pred (L);

                                     L := Length (X) - L;

                                     if not Flag
                                     then K := L
                                     else Write (Chr (K or L shl 4));

                                     Flag := not Flag
                               end
                    end;

                 Close (F);

                 if WhereX <> 1
                 then WriteLn;

                 WriteLn ('Ok!');
                 Exit
           end;

(*----------------------ВЫВОД СТЕГАНОГРАММЫ В ФАЙЛ---------------------*)
      if ParamCount = 2
      then
           begin
                 if Pos (':', ParamStr (2)) <> 2
                 then Assign (G, TempName)
                 else Assign (G, Copy (ParamStr (2), 1, 2) + TempName);

                 Assign (G, TempName);

                 Rewrite (G);
                 Flag := False;

                 while not Eof (F)
                 do
                    begin
                          ReadLn (F, X);
                          L := Length (X);

                          if L < Max
                          then
                               begin
                                     while X [L] = ' '

                                     do L := Pred (L);

                                     L := Length (X) - L;

                                     if not Flag
                                     then K := L
                                     else
                                          begin
                                                 C := Chr ((K or L shl 4)
                                                      xor Random (256));
                                                 Write (G, C);
                                                 Write (C);
                                                 Count := Count + 1
                                          end;

                                     Flag := not Flag
                               end
                    end;

                 Close (F);
                 Close (G);
                 Assign (F, ParamStr (2));
(*$I-*)
                 Erase (F);
(*$I+*)
                 I := IoResult;
                 Rename (G, ParamStr (2));

                 if WhereX <> 1
                 then WriteLn;

                 if Flag and (Count <> 0)
                 then Count := Count - 1;

                 WriteLn ('Прочитано ', Count : 0 : 0, ' байт стего...');
                 Exit
           end;

(*----------------------ЗАПмСЬ СТЕГАНОГРАММЫ В ФАЙЛ--------------------*)
      Assign (G, ParamStr (2));

      if Pos (':', ParamStr (3)) <> 2
      then Assign (H, TempName)
      else Assign (H, Copy (ParamStr (3), 1, 2) + TempName);

      Reset   (G);
      Rewrite (H);
      Flag := False;

      while not Eof (F)
      do
         begin
               ReadLn (F, X);

               while X [Length (X)] = ' '
               do X [0] := Pred (X [0]);

               Write (H, X);

               if Length (X) < Max - 15
               then
                    begin
                          if Flag
                          then
                               for I := 1 to K shr $04
                               do Write (H, ' ')
                          else
                               begin
                                     Read (G, C);
                                     Write (C);
                                     Count := Count + 1;
                                     K := Ord (C) xor Random (256);

                                     for I := 1 to K and $0F
                                     do Write (H, ' ')
                               end;

                          Flag := not Flag
                    end;

               WriteLn (H)
         end;

      Close (F);
      Close (G);
      Close (H);
      Assign (F, ParamStr (3));
(*$I-*)
      Erase (F);
(*$I+*)
      I := IoResult;
      Rename (H, ParamStr (3));

      if WhereX <> 1
      then WriteLn;

      if Flag and (Count <> 0)
      then Count := Count - 1;

      WriteLn ('Записано ', Count : 0 : 0, ' байт стего...');
      Exit
end.