Кодирование стего выравниванием строк пробелами.
program StegoShift;
(***************************************************************)
(* Простая стеганографическая программа, использующая *)
(* раздвижку слов в строке для встраивания стего в *)
(* произвольные тексты. мспользует 2 или 3 параметра, которые *)
(* и определяют выполняемую программой функцию. При этом *)
(* первый из параметров всегда представляет файл-контейнер. *)
(* Если параметров два, стеганограмма извлекается из *)
(* контейнера, а результат записывается в заданный вторым *)
(* параметром файл и в виде эхопечати выводится на экран. *)
(* Если параметров три, то стеганографический текст из *)
(* файла заданного вторым параметром, упрятывается в *)
(* файл-контейнер, заданный первым параметром, а результат *)
(* стеганографического преобразования записывается в файл, *)
(* заданный третьим параметром. Совпадение двух имён файлов *)
(* допускается (трёх - абсурд). *)
(***************************************************************)
type
StringType = string [$FF];
const
TempName = '$$$$$$$$.$$$';
Key1 = $1234;
Key2 = $4567;
var
F, G, H : text;
Line, Head, Tail, Body : StringType;
B, I, K, L, N, LenBody, Z : byte;
C : char;
Tab : array [0..255] of byte;
Count : real;
begin
LowVideo;
if not (ParamCount in [1..3])
then
begin
WriteLn ('Ожидается ввод 2 или 3 параметров:');
WriteLn ('2 - вывод стеганограммы в файл;');
WriteLn ('3 - запись стеганограммы в файл.');
Exit
end;
Assign (F, ParamStr (1));
Reset (F);
Count := 0;
MemW [Dseg : $01FE] := Key1;
MemW [Dseg : $01FC] := Key2;
(*----------------------ВЫВОД СТЕГАНОГРАММЫ В ФАЙЛ---------------------*)
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);
Z := 0;
L := 0;
while not Eof (F)
do
begin
ReadLn (F, Line);
(* 1. Выделяем тело строки *)
while (Line <> '')
and (Line [1] <= ' ')
do Delete (Line, 1, 1);
while (Line <> '')
and (Line [Length (Line)] <= ' ')
do Delete (Line, Length (Line), 1);
(* 2. Заполняем таблицу пробелов *)
FillChar (Tab, SizeOf (Tab), 0);
LenBody := Length (Line);
K := 0;
I := 0;
while I < LenBody
do
begin
while (I < LenBody) and (Line [I] <> ' ')
do I := Succ (I);
if (I < LenBody) and (Line [I] = ' ')
then
begin
K := Succ (K);
N := 0;
while (I < LenBody)
and (Line [I] = ' ')
do
begin
N := Succ (N);
I := Succ (I)
end;
Tab [K] := N
end
end;
if K > 0
then K := Pred (K);
(* 3. Декодируем биты *)
I := 0;
while I < K
do
begin
I := Succ (I);
if Tab [I] > 1
then
begin
Z := Z shr 1;
if Odd (Tab [I])
then Z := Z or $80;
L := Succ (L) mod 8;
if L = 0
then
begin
C := Chr (Z
xor Random (256));
Count := Count + 1;
Write (C);
Write (G, C);
Z := 0
end
end
end;
end;
(* 4. Завершаем работу *)
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
(* 1. мнициализируем таблицу раздвижек *)
FillChar (Tab, SizeOf (Tab), 0);
(* 2. Читаем и разделяем строку на части *)
ReadLn (F, Line);
I := 0;
while (I < Length (Line)) and (Line [Succ (I)] <= ' ')
do I := Succ (I);
Tab [0] := I;
(* начало строки *)
Head := Copy (Line, 1, I);
I := Length (Line);
while (I > 0) and (Line [I] <= ' ')
do I := Pred (I);
(* конец строки *)
Tail := Copy (Line, Succ (I), Length (Line) - I);
(* тело строки *)
Body := Copy (Line, Succ (Tab [0]), I - Tab [0]);
(* 3. Редуцируем тело строки *)
LenBody := Length (Body);
while Pos (' ', Body) > 0
do Delete (Body, Pos (' ', Body), 1);
(* число вставляемых пробелов *)
N := LenBody - Length (Body);
(* 4. Заполняем таблицу раздвижек *)
K := 0;
for I := 1 to Length (Body)
do
if Body [I] = ' '
then
begin
K := Succ (K);
Tab [K] := 1
end;
(* 5. Распределяем значимые (информационные) пробелы *)
I := 1;
while I < K
do
begin
if L = 0
then (* извлекаем очередной байт *)
begin
if Eof (G)
then C := #00
else Read (G, C);
Count := Count + 1;
Z := Ord (C) xor Random (256);
B := Z and 1;
L := 1;
Write (C);
end;
if N > Succ (B)
then (* запас пробелов не исчерпан *)
begin
(* кодируем бит в таблице *)
Tab [I] := Tab [I] + Succ (B);
(* текущий запас пробелов *)
N := N - Succ (B);
(* указываем следующий бит *)
Z := Z shr 1;
B := Z and 1;
(* счётчик записанных битов *)
L := Succ (L) mod 9
end;
I := Succ (I)
end;
(* 6. Монотонно перераспределяем информационные пробелы *)
if K > 2
then (* число пробелов должно возрастать к концу строки *)
begin
I := 0;
while (Tab [Pred (K)] = 1) and (I < K)
do
begin
Move (Tab [1], Tab [2], K - 2);
Tab [1] := 1;
I := Succ (I)
end
end;
(* 7. Распределяем выравнивающие (незначимые) пробелы *)
while N > 1
do
begin
I := K;
while (I > 0) and (N > 1)
do
begin
if (Tab [I] > 1) or (I = K)
then
begin
Tab [I] := Tab [I] + 2;
N := N - 2
end;
I := Pred (I)
end
end;
Tab [K] := Tab [K] + N;
(* 8. Вставляем пробелы в тело строки *)
N := Length (Body);
while (N > 0) and (K > 0)
do
begin
while (N > 0) and (Body [N] <> ' ')
do N := Pred (N);
if (Tab [K] > 0) and (N > 0)
then
for I := 1 to Pred (Tab [K])
do Insert (' ', Body, N);
if K > 0
then K := Pred (K);
if N > 0
then N := Pred (N)
end;
(* 9. Формируем и записываем строку *)
Line := Head + Body + Tail;
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;
if (Count <> 0) and (L <> 0)
then Count := Count - 1;
WriteLn ('Записано ', Count : 0 : 0, ' байт стего...');
Exit
end.
