umsnutils.pas

msn控件 可验证 可接受信息 可发送信息 msn8协议 win32

unit UMsnUtils;
(* 暥帤楍娭楢儐乕僥傿儕僥傿 *)

interface

uses
  Windows, Classes, StrUtils, SysUtils, UIntList;

procedure Split(List: TIntegerList; const S, Delimiter: String; Count: Integer = 0); overload;
procedure Split(List: TStrings; const S, Delimiter: String; Count: Integer = 0); overload;
procedure SplitMimeHeader(List: TStrings; const MimeHeader: String);
function EncodeSpace(const S: String): String;
function UrlEncode(const S: String): String;
function UrlDecode(const S: String): String;
function HexToInt(HexStr: String): Int64;
function MIMEDecode(const S: String): String;
function Jis2Sjis(const JisStr: String): String;
function SplitCommandStr(List: TStringList; const Str: UTF8String): UTF8String;
procedure SplitParamStr(List: TStringList; const Str: UTF8String);
function SS(List: TStringList; Idx: Integer): String;

function DecodeParam(const S: UTF8String): WideString;
function EncodeParam(const S: WideString): UTF8String;
function  WordAt(const Text : string; Position : Integer) : string;


implementation

function SplitCommandStr(List: TStringList; const Str: UTF8String): UTF8String;
var
  P: Integer;
  Temp: UTF8String;
  Delimiter: UTF8String;
  ParamLst: TStringList;
begin
  ParamLst := TStringList.Create;
  List.Clear;
  Delimiter := #13#10;
  Result := '';

  Temp := Str;
  P := Pos(Delimiter, Temp);
  while P <> 0 do
  begin
    Split(ParamLst, Copy(Temp, 1, P - 1), ' ');
    if (SS(ParamLst, 0) = 'MSG') and (StrToIntDef(SS(ParamLst, 3), 0) <> 0) and
       (Length(Temp) < (P + Length(Delimiter) + StrToIntDef(SS(ParamLst, 3), 0)) - 1)then
    begin
      Break;
    end else
    if (SS(ParamLst, 0) = 'MSG') and (StrToIntDef(SS(ParamLst, 3), 0) <> 0) then
    begin
      P := P + Length(Delimiter) + StrToIntDef(SS(ParamLst, 3), 0);
      List.Add(Copy(Temp, 1, P - 1));
      Delete(Temp, 1, P - 1);
    end else
    begin
      List.Add(Copy(Temp, 1, P - 1));
      Delete(Temp, 1, P + Length(Delimiter) - 1);
    end;
    P := Pos(Delimiter, Temp);
  end;
  Result := Temp;
  ParamLst.Free;
end;

procedure SplitParamStr(List: TStringList; const Str: UTF8String);
var
  P: Integer;
  Temp: UTF8String;
begin
  List.Clear;
  Temp := Str;
  P := Pos(#13#10, Temp);
  if P > 0 then  Temp := Copy(Temp, 1, P);
  Split(List, Temp, ' ');
end;

function SS(List: TStringList; Idx: Integer): String;
begin
  Result := '';
  if (Idx >= 0) and (Idx < List.Count) then
    Result := List[Idx];
end;

function UrlDecode(const S: String): String;
var
  I, Len: Integer;
  C: Char;
begin
  Result := '';
  Len := Length(S);
  I := 1;
  while I <= Len do
  begin
    if (I < Len - 1) and (S[I] = '%') then
    begin
      C := Chr(HexToInt(S[I + 1] + S[I + 2]));
      if C <> #0 then
      begin
        Result := Result + C;
        Inc(I, 2);
      end else
        Result := Result + S[I];
    end else
      Result := Result + S[I];
    Inc(I);
  end ;
end;

function EncodeParam(const S: WideString): UTF8String;
function EncodeSpace(const S: String): String;
var
  I, Len: Integer;
begin
  Result := '';
  Len := Length(S);
  for I := 1 to Len do
  begin
    if S[I] = ' ' then
      Result := Result + '%20'
    else if S[I] = #09 then
      Result := Result + '%09'
    else if S[I] = #10 then
      Result := Result + '%10'
    else if S[I] = #13 then
      Result := Result + '%13'
    else if S[I] = '%' then
      Result := Result + '%25'
    else
      Result := Result + S[I];
  end;
end;
begin
  Result := EncodeSpace(UTF8Encode(S));
end;

type
  CharSet = Set of char;

function UTF8ToAnsi(x: string): ansistring;
var
  i: integer;
  b1, b2: byte;
begin
  Result := x;
  i := 1;
  while i <= Length(Result) do begin
    if (ord(Result[i]) and $80) <> 0 then begin
      b1 := ord(Result[i]);
      b2 := ord(Result[i + 1]);
      if (b1 and $F0) <> $C0 then
        Result[i] := #128
      else begin
        Result[i] := Chr((b1 shl 6) or (b2 and $3F));
        Delete(Result, i + 1, 1);
      end;
    end;
    inc(i);
  end;
end;



function AnsiToUtf8(x: ansistring): string;
var
  i: integer;
  b1, b2: byte;
begin
  Result := x;
  for i := Length(Result) downto 1 do
    if Result[i] >= #127 then begin
      b1 := $C0 or (ord(Result[i]) shr 6);
      b2 := $80 or (ord(Result[i]) and $3F);
      Result[i] := chr(b1);
      Insert(chr(b2), Result, i + 1);
    end;
end;


function DecodeParam(const S: UTF8String): WideString;
begin
  Result := UTF8Decode(UrlDecode(S));
end;

Function  ExtractWord(N:Integer;S:String;WordDelims:CharSet):String;
Var
  I,J:Word;
  Count:Integer;
  SLen:Integer;
Begin
  Count := 0;
  I := 1;
  Result := '';
  SLen := Length(S);
  While I <= SLen Do Begin
    //preskoc oddelovace
    While (I <= SLen) And (S[I] In WordDelims) Do Inc(I);
    //neni-li na konci retezce, bude nalezen zacatek slova
    If I <= SLen Then Inc(Count);
    J := I;
    //a zde je konec slova
    While (J <= SLen) And Not(S[J] In WordDelims) Do Inc(J);
    //je-li toto n-te slovo, vloz ho na vystup
    If Count = N Then Begin
      Result := Copy(S,I,J-I);
      Exit
    End;
    I := J;
  End; //while
End;
{解析字符串...取数字符串Text中,第Position处空格前的字符串..}

function  WordAt(const Text : string; Position : Integer) : string;
begin
  Result := ExtractWord(Position, Text, [' ']);
end;


// 暥帤楍傪嬫愗傝暥帤偱暘妱偟偰惍悢抣儕僗僩偵奿擺
procedure Split(List: TIntegerList; const S, Delimiter: String; Count: Integer = 0);
var
  P: Integer;
  Temp: String;
begin
  List.Clear;
  Temp := S;
  P := Pos(Delimiter, Temp);
  while (P <> 0) and ((Count = 0) or (List.Count < Count - 1)) do
  begin
    List.Add(StrToIntDef(Copy(Temp, 1, P - 1), 0));
    Delete(Temp, 1, P + Length(Delimiter) - 1);
    P := Pos(Delimiter, Temp);
  end;
  if Length(Temp) > 0 then
    List.Add(StrToIntDef(Temp, 0));
end;

// 暥帤楍傪嬫愗傝暥帤偱暘妱偟偰暥帤楍儕僗僩偵奿擺
procedure Split(List: TStrings; const S, Delimiter: String; Count: Integer = 0);
var
  P: Integer;
  Temp: String;
begin
  List.Clear;
  Temp := S;
  P := Pos(Delimiter, Temp);
  while (P <> 0) and ((Count = 0) or (List.Count < Count - 1)) do
  begin
    List.Add(Copy(Temp, 1, P - 1));
    Delete(Temp, 1, P + Length(Delimiter) - 1);
    P := Pos(Delimiter, Temp);
  end;
  if Length(Temp) > 0 then
    List.Add(Temp);
end;

// AnsiString 懳墳斉
procedure AnsiSplit(List: TStrings; const Str, Delimiter: String; Count: Integer = 0);
var
  Pos: Integer;
  Temp: String;
begin
  List.Clear;
  Temp := Str;
  Pos := AnsiPos(Delimiter, Temp);
  while (Pos <> 0) and ((Count = 0) or (List.Count < Count - 1)) do
  begin
    List.Add(Copy(Temp, 1, Pos - 1));
    Delete(Temp, 1, Pos + Length(Delimiter) - 1);
    Pos := AnsiPos(Delimiter, Temp);
  end;
  if Length(Temp) > 0 then
    List.Add(Temp);
end;

// Name=Value 宍幃偱奿擺
procedure SplitMimeHeader(List: TStrings; const MimeHeader: String);
var
  I: Integer;
  Temp: TStringList;
begin
  Temp := TStringList.Create;
  Temp.Text := MimeHeader;

  List.Clear;
  for I := 0 to Temp.Count - 1 do
    List.Add(StringReplace(Temp[I], ': ', '=', []));

  Temp.Free;
end;

function EncodeSpace(const S: String): String;
var
  I, Len: Integer;
begin
  Result := '';
  Len := Length(S);
  for I := 1 to Len do
  begin
    if S[I] = ' ' then
      Result := Result + '%20'
    else if S[I] = #09 then
      Result := Result + '%09'
    else if S[I] = #10 then
      Result := Result + '%10'
    else if S[I] = #13 then
      Result := Result + '%13'
    else if S[I] = '%' then
      Result := Result + '%25'
    else
      Result := Result + S[I];
  end;
end;

// url-encode
function UrlEncode(const S: String): String;
var
  I, Len: Integer;
begin
  Result := '';
  Len := Length(S);
  for I := 1 to Len do
  begin
    if not (S[I] in ['0'..'9', 'a'..'z', 'A'..'Z']) then
      Result := Result + '%' + IntToHex(Ord(S[I]), 2)
    else
      Result := Result + S[I];
  end;
end;

//丂url-decode

// 16恑暥帤楍偐傜惍悢宆
function HexToInt(HexStr: String): Int64;
var
  RetVar : Int64;
  I : Byte;
begin
  HexStr := UpperCase(HexStr);
  RetVar := 0;

  for I := 1 to Length(HexStr) do
  begin
    RetVar := RetVar shl 4;
    if HexStr[I] in ['0'..'9'] then
      RetVar := RetVar + (Byte(HexStr[I]) - 48)
    else
      if HexStr[i] in ['A'..'F'] then
        RetVar := RetVar + (Byte(HexStr[I]) - 55)
      else
      begin
        Retvar := 0;
        Break;
      end;
  end;

  Result := RetVar;
end;

const
   Base64 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
   MimeHead = '=?ISO-2022-JP?B?';
   MimeHeadLen = 16;
   MimeTail = '?=';
   MimeTailLen = 2;

// MIME僨僐乕僪
function MIMEDecode(const S: String): String;
var
   I, J: Integer;
   LenIn: Integer;
   AllStr, SubStr: String;
   TmpChr: array[1..4] of Integer;
   C: Byte;
begin
   Result := '';
   AllStr := Copy(S,1,Length(S));
   while True do
   begin
      I := Pos(MimeHead, UpperCase(AllStr));
      J := Pos(MimeTail,           AllStr );
      If (I > 0) and (J > 0) then
      begin
         Result := Result + Copy(AllStr, 1, I - 1);
         SubStr := Copy(AllStr, I + MimeHeadLen, J - (I + MimeHeadLen));
         If (J + MimeTailLen) <= Length(AllStr) then
            AllStr := Copy(AllStr, J + MimeTailLen, Length(AllStr) - (J + MimeTailLen - 1))
         else
            AllStr := '';

         I := Pos('=',SubStr);
         If I > 0 then
            SubStr := Copy(SubStr, 1, I - 1);
         LenIn := (Length(SubStr) + 3) and (not 3);

         J := 1;
         for I := 1 to LenIn do
         begin
            if I <= Length(SubStr) then
               TmpChr[J] := Pos(SubStr[I],base64) - 1
            else
               TmpChr[J] := 0;
            J := J + 1;
            if J > 4 then
            begin
               C := Byte((TmpChr[1] shl 2) or (TmpChr[2] shr 4));
               If C > 0 then Result := Result + AnsiChar(C);
               C := Byte((TmpChr[2] shl 4) or (TmpChr[3] shr 2));
               If C > 0 then Result := Result + AnsiChar(C);
               C := Byte((TmpChr[3] shl 6) or (TmpChr[4]      ));
               If C > 0 then Result := Result + AnsiChar(C);
               J := 1;
            end;
         end;
      end else
      begin
         Result := Result + AllStr;
         Exit;
      end;
   end;
end;

type
   HiLo = array[1..2] of Byte;
   JisInOutSet = array[1..5] of String;

const
   jisKanjiIn: JisInOutSet =
      (#$1b#$24#$40,
       #$1b#$24#$42,
       #$1b#$26#$40#$1b#$24#$42,
       #$1b#$24#$28#$44,
       '');

   jisKanjiOut: JisInOutSet =
      (#$1b#$28#$4a,
       #$1b#$28#$48,
       #$1b#$28#$42,
       #$1b#$28#$49,
       #$1b#$28#$40);

// JIS -> ShiftJIS曄姺
function Jis2Sjis(const JisStr: String): String;
// 撪晹娭悢丗娍帤IN偺敾掕
function isJisKanjiIn(const S: String): Integer;
var
   I: Integer;
begin
   Result := 0;
   for I := 1 to 4 do
   begin
      if LeftStr(S,Length(jisKanjiIn[I])) = jisKanjiIn[I] then
      begin
         Result := Length(jisKanjiIn[I]);
         Exit;
      end;
   end;
end;
// 撪晹娭悢丗娍帤OUT偺敾掕
function isJisKanjiOut(const S: String): Integer;
var
   I: Integer;
begin
   Result := 0;
   for I := 1 to 5 do
   begin
      if LeftStr(S,Length(jisKanjiOut[I])) = jisKanjiOut[I] then
      begin
         Result := Length(jisKanjiOut[I]);
         Exit;
      end;
   end;
end;
// 撪晹娭悢丗1暥帤曄姺
function j2s(const JChr: HiLo): HiLo;
var
   C: HiLo;
begin
   C[1] := JChr[1] - $20;
   C[2] := JChr[2] - $20;
   if (C[1] and 1) <> 0 then
   begin
      C[1] := C[1] + 1;
      C[2] := C[2] + $3F;
      if C[2] >= $7F then
         C[2] := C[2] + 1;
   end else
   begin
      C[2] := C[2] + $9E;
   end;

   C[1] := (C[1] shr 1) or $80;
   if C[1] >= $A0 then
      C[1] := C[1] or $40;
   Result := C;
end;
// 儊僀儞
var
   I, J, K: Integer;
   JChr, SChr: HiLo;
   InKanji: Boolean;
begin
   Result := '';
   InKanji := False;
   I := 1;
   while I <= Length(JisStr) do
   begin
      J := isJisKanjiIn(Copy(JisStr,I,10));
      if J > 0 then
      begin
         InKanji := True;
         I := I + J;
         Continue;
      end;

      K := isJisKanjiOut(Copy(JisStr,I,10));
      if K > 0 then
      begin
         InKanji := False;
         I := I + K;
         Continue;
      end;

      if not InKanji then
      begin
         Result := Result + JisStr[I];
         I := I + 1;
      end else
      begin
         JChr[1] := Byte(JisStr[I  ]);
         JChr[2] := Byte(JisStr[I+1]);
         SChr := j2s(JChr);
         Result := Result + Char(SChr[1]) + Char(SChr[2]);
         I := I + 2;
      end;
   end;
end;

end.