Советы по Delphi
       

Битное кодирование/декодирование I


Привожу нетестированный код. Автор: Arne de Bruijn.

{ 64-битное декодирование файлов }
{ Arne de Bruijn }
uses dos;
var
Base64:array[43..122] of byte;var
T:text;Chars:set of char;S:string;K,I,J:word;Buf:pointer;DShift:integer;F:file;B,B1:byte;Decode:array[0..63] of byte;Shift2:byte;Size,W:word;beginFillChar(Base64,SizeOf(Base64),255);J:=0;for I:=65 to 90 dobeginBase64[I]:=J;Inc(J);end;for I:=97 to 122 dobeginBase64[I]:=J;Inc(J);end;for I:=48 to 57 dobeginBase64[I]:=J;Inc(J);end;Base64[43]:=J; Inc(J);Base64[47]:=J; Inc(J);if ParamCount=0 thenbeginWriteLn('UNBASE64 <mime-файл> [<выходной файл>]');Halt(1);end;S:=ParamStr(1);assign(T,S);GetMem(Buf,32768);SetTextBuf(T,Buf^,32768);{$I-} reset(T); {$I+}if IOResult<>0 thenbeginWriteLn('Ошибка считывания ',S);Halt(1);end;if ParamCount>=2 thenS:=ParamStr(2)elsebegin write('Расположение:'); ReadLn(S); end;assign(F,S);{$I-} rewrite(F,1); {$I+}if IOResult<>0 thenbeginWriteLn('Ошибка создания ',S);Halt(1);end;while not eof(T) dobeginReadLn(T,S);if (S<>'') and (pos(' ',S)=0) and (S[1]>=#43) and (S[1]<=#122) and(Base64[byte(S[1])]<>255) thenbeginFillChar(Decode,SizeOf(Decode),0);DShift:=0;J:=0; Shift2:=1;Size:=255;B:=0;for I:=1 to Length(S) dobegincase S[I] of#43..#122:B1:=Base64[Ord(S[I])];elseB1:=255;end;if B1=255 thenif S[I]='=' thenbeginB1:=0; if Size=255 then Size:=J;endelseWriteLn('Ошибка символа:',S[I],' (',Ord(S[I]),')');if DShift and 7=0 thenbeginDecode[J]:=byte(B1 shl 2);DShift:=2;endelsebeginDecode[J]:=Decode[J] or Hi(word(B1) shl (DShift+2));Decode[J+1]:=Lo(word(B1) shl (DShift+2));Inc(J);Inc(DShift,2);end;end;if Size=255 then Size:=J;BlockWrite(F,Decode,Size);end;end;Close(F);close(T);end.
[000074]


Пришло от читателя письмо:

Хочу предложить еще одну реализацию алгоритма декодирования base64. Код проверен, работает без глюков. .

С удовольствием публикую данный код:



Const
Base64Table='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function Base64Decode(cStr:string):string;
var ResStr:string;
DecStr:string;RecodeLine : array [1..76] of byte;f1,f2 : word;l:integer;beginl :=length(cStr);ResStr:='';for f1:=1 to l doif cStr[f1]='=' then RecodeLine[f1]:=0else RecodeLine[f1]:=pos(cStr[f1],Base64Table)-1;f1:=1;while f1<length(cStr) dobeginDecStr:=chr(byte(RecodeLine[f1] shl 2)+RecodeLine[f1+1] shr 4)+chr(byte(RecodeLine[f1+1] shl 4)+RecodeLine[f1+2] shr 2)+chr(byte(RecodeLine[f1+2] shl 6)+RecodeLine[f1+3]);ResStr:=ResStr+DecStr;inc(f1,4);end;Base64Decode:=ResStr;end;
[000782]



Содержание раздела