Кодирование стего двоичными нулями.
program StegoZero;
(***************************************************************)
(* Простая стеганографическая программа для работы с *)
(* текстами основанная на подмене первого пробела в группе из *)
(* двух или более пробелов двоичным нулём. Режим работы *)
(* программы определяется параметрами вызова. Возможны от 1 до *)
(* 3 параметров, из которых первый описывает файл-контейнер. *)
(* Если этот параметр единственный, то проверяется *)
(* наличие стеганограммы в контейнере с выводом результата на *)
(* экран. По сути это режим стеганодетектора. *)
(* Если таких параметров два, стеганограмма извлекается из *)
(* контейнера, а результат записывается в заданный вторым *)
(* параметром файл. *)
(* Наконец, если используются все три параметра, то *)
(* стеганографический текст из файла заданного вторым *)
(* параметром, упрятывается в файл-контейнер, заданный первым *)
(* параметром, а результат стеганографического преобразования *)
(* записывается в файл, заданный третьим параметром. *)
(* Совпадение двух имён файлов допускается (трёх - абсурд). *)
(***************************************************************)
type
StringType = string [$FF];
const
TempName = '$$$$$$$$.$$$';
Key1 = $1234;
Key2 = $4567;
var
F, G, H : text;
Line : StringType;
I, K, L, Z : 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
L := 0;
Z := 0;
while not Eof (F)
do
begin
ReadLn (F, Line);
while (Line <> '')
and (Line [1] <= ' ')
do Delete (Line, 1, 1);
while (Line <> '')
and (Line [Length (Line)] <= ' ')
do Delete (Line, Length (Line), 1);
while Line <> ''
do
begin
while (Line <> '') and (Line [1] > ' ')
do Delete (Line, 1, 1);
if (Length (Line) > 1)
and ((Copy (Line, 1, 2) = #00' ')
or (Copy (Line, 1, 2) = ' '))
then
begin
Z := Z shr 1;
if Line [1] = #00
then Z := Z or $80;
L := Succ (L) mod 8;
if L = 0
then Write (Chr (Z))
end;
while (Line <> '') and (Line [1] <= ' ')
do Delete (Line, 1, 1)
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);
Rewrite (G);
L := 0;
Z := 0;
while not Eof (F)
do
begin
ReadLn (F, Line);
while (Line <> '')
and (Line [1] <= ' ')
do Delete (Line, 1, 1);
while (Line <> '')
and (Line [Length (Line)] <= ' ')
do Delete (Line, Length (Line), 1);
while Line <> ''
do
begin
while (Line <> '') and (Line [1] > ' ')
do Delete (Line, 1, 1);
if (Length (Line) > 1)
and ((Copy (Line, 1, 2) = #00' ')
or (Copy (Line, 1, 2) = ' '))
then
begin
Z := Z shr 1;
if Line [1] = #00
then Z := Z or $80;
L := Succ (L) mod 8;
if L = 0
then
begin
Count := Count + 1;
C := Chr (Z
xor Random (256));
Write (G, C);
Write (C)
end
end;
while (Line <> '') and (Line [1] <= ' ')
do Delete (Line, 1, 1)
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;
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);
L := 0;
while not Eof (F)
do
begin
ReadLn (F, Line);
I := 0; (* последний пробельный символ *)
while (I < Length (Line)) and (Line [Succ (I)] <= ' ')
do I := Succ (I);
K := Length (Line); (* последний непробельный символ *)
while (K > I) and (Line [K] <= ' ')
do K := Pred (K);
while I < K
do
begin
while (I < K) and (Line [Succ (I)] > ' ')
do I := Succ (I);
if (K - I > 2) and (Copy (Line, Succ (I), 2) = ' ')
then
begin
if L = 0
then
begin
if Eof (G)
then C := #00
else Read (G, C);
Z := Ord (C) xor Random (256)
end;
if Z and 1 = 1
then Line [Succ (I)] := #00;
Z := Z shr 1;
L := Succ (L) mod 8;
I := I + 2;
if L = 0
then
begin
Write (C);
Count := Count + 1
end
end;
while (I < K) and (Line [Succ (I)] = ' ')
do I := Succ (I)
end;
WriteLn (H, Line)
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;
WriteLn ('Записано ', Count : 0 : 0, ' байт стего...');
Exit
end.
