www.pudn.com > POLL_SRC.rar > HTTPutil.pas

unit HTTPutil; 
 
interface 
 
uses 
  StrUtils, Classes, SysUtils, Forms, Registry, Windows, IniFiles, StdCtrls, ComCtrls,  
  CPUid, AES,  
  Dialogs; 
 
const 
  MY_USER_AGENT            =       'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; Alexa Toolbar; mxie; .NET CLR 1.1.4322)'; 
 
  LSTB_MAX_LINE            =       500; 
 
  RD_ST_CN = '{'; 
  RD_ED_CN = '}'; 
  RD_ST_EN = '('; 
  RD_ED_EN = ')'; 
 
  DT_CN : array[0..31] of String[3] =(' - ',' 8 ',' @ ',' * ', 
                                      ' _ ',' + ',' = ',' ^ ', 
                                      ' : ',' . ',' ! ',' 0 ', 
                                      ' I ',' o ',' O ',' U ', 
                                      ' X ',' x ',' v ',' V ', 
                                      ' M ',' m ',' T ',' Y ', 
                                      ' A ',' H ',' # ',' % ', 
                                      ' ~ ',' < ',' > ',' ? ' 
                                      ); 
  DT_NM : array[0..9] of String[2] = ('０','１','２','３', 
                                      '４','５','６','７', 
                                      '８','９'); 
  DT_EN : array[0..25] of String[2] = ('ａ','ｂ','ｃ','ｄ', 
                                      'ｅ','ｆ','ｇ','ｈ', 
                                      'ｉ','ｊ','ｋ','ｌ', 
                                      'ｍ','ｎ','ｏ','ｐ', 
                                      'ｑ','ｒ','ｓ','ｔ', 
                                      'ｕ','ｖ','ｗ','ｘ', 
                                      'ｙ','ｚ' 
                                      ); 
 
  procedure RemoveEnter(var s : string); 
  procedure GetIniSecStrings(Ini : TiniFile; Sec : String; Strs : TStrings); 
  function MsgBox(Info: String; Style: integer): integer; 
  function GetValByName(S,Sub: string) : string; 
  function ExtractHtmlTagValues(const HtmlText: string; TagName, AttribName: string; var Values: TStringList): integer; 
  function URLEncode(const msg : String) : String; 
  function UrlDecode(const EncodedStr: String): String; 
  Function HexToInt(Hex :String):Int64; 
 
  function GetHexCPUid : string; 
  function ClearRegCode : boolean; 
  function ReadRegCode : boolean; 
  function WriteRegCode : boolean; 
  procedure CheckRegCode(Code : string); 
 
  function GetRndDisTurbStrs(Content : String; Strs : TStringList; Cn : boolean) : String ; 
  function GenRndDisturb(Str : String; Cn : boolean): String; 
  function AnaUserLine(Line,User,RpStr : String) : String ; 
  function DisTurbContent(Content : String):String; 
  function FormatStrNum(Num : Integer; Len : Byte): String; 
  procedure GetColumnFromLstV(LstV : TListView; Sl : TStringList; idx : Byte); 
  function LStrDiv(Str,Spl : string): string; 
  function RStrDiv(Str,Spl : string): string; 
  function ExStrSeg(Str,Spl : string; Idx : Integer): string; 
  function GenRndUSR(Prefix,Tail : string; Len : Byte): string; 
  function BoolToStr(b : boolean): string; 
  function IsNum(s : string): boolean; 
  function GetLinkTextByURL(HTML,URL : string):string; 
 
  procedure AddLstBPro(ListBox : TListBox; str : String; Insert : boolean; MaxLine : Integer); 
  procedure AddLstVitemPro(LstV : TListView; Subs : TStringList; Data: Pointer=nil); 
  procedure ChkLstV(LstV : TListView; Chk : Boolean); 
  procedure RfhLstV(LstV : TListView); 
 
implementation 
 
uses 
  Define; 
 
procedure RemoveEnter(var s : string); 
var 
  i : integer; 
  DelOne : boolean; 
begin 
  Repeat 
    DelOne := false; 
    for i:=1 to length(s)-1 do 
    if (Ord(s[i]) = $0d) and (Ord(s[i+1]) = $0a) then 
    begin 
      Delete(s,i,2); 
      DelOne := true; 
      break; 
    end; 
  Until not DelOne; 
end; 
 
procedure GetIniSecStrings(Ini : TiniFile; Sec : String; Strs : TStrings); 
var 
  i,j : Integer; 
  Keys : TStringList; 
  Value : String; 
begin 
  Strs.Clear; 
  Keys := TStringList.Create; 
  Ini.ReadSection(Sec,Keys); 
  for i:=0 to Keys.Count-1 do 
  begin 
    Value := Ini.ReadString(Sec,Keys[i],''); 
    Strs.Add(Value); 
  end; 
  Keys.Free; 
end; 
 
function MsgBox(Info: String; Style: integer): integer; 
begin 
  with Application do 
  begin 
    NormalizeTopMosts; 
    Result := MessageBox(PChar(Info), '信息提示',Style); 
    RestoreTopMosts; 
  end; 
end; 
 
function GetValByName(S, Sub: string) : string; 
var 
  EleS,EleE,iPos: Integer; 
  ELeStr,ValSt: String; 
  St,Ct : Integer; 
  function FindEleRange(str: string ; front : boolean; posi : integer): Integer; 
  var 
    i: integer; 
  begin 
    if Front then 
    begin 
      for i:=posi-1 downto 1 do 
      if Str[i]='<' then 
      begin 
        Result := i; 
        break; 
      end; 
    end else begin 
      for i := posi+1 to length(Str) do 
      if Str[i]='>' then 
      begin 
        Result := i; 
        break; 
      end; 
    end; 
  end; 
  function FindEnd (str : string; posi : integer) : Integer; 
  var 
    i: integer; 
  begin 
    for i:=posi to length(str) do 
    begin 
      if (str[i] ='"') or (str[i] ='''') or (str[i] =' ') then 
      begin 
        result := i-1; 
        break; 
      end; 
    end; 
  end; 
begin 
  iPos := Pos('name="'+lowercase(Sub)+'"',lowercase(S)); 
  if iPos = 0 then iPos := Pos('name='+lowercase(Sub),lowercase(S)); 
  if iPos = 0 then iPos := Pos('name='''+lowercase(Sub)+'''',lowercase(S)); 
  if iPos = 0 then exit; 
  EleS := FindEleRange(S,TRUE,iPos); 
  EleE := FindEleRange(S,FALSE,iPos); 
  EleStr := Copy(S,EleS,EleE-EleS+1); 
  ValSt := 'value="'; 
  iPos := Pos(ValSt,EleStr); 
  if iPos = 0 then 
  begin 
    ValSt := 'value='''; 
    iPos := Pos(ValSt,EleStr); 
  end; 
  if iPos = 0 then 
  begin 
    ValSt := 'value='; 
    iPos := Pos(ValSt,EleStr); 
  end; 
  St := iPos+length(ValSt); 
  Ct := FindEnd(EleStr,St)-St+1; 
  Result := Copy(EleStr,St,Ct); 
end; 
 
 
function ExtractHtmlTagValues(const HtmlText: string; TagName, AttribName: string; var Values: TStringList): integer; 
 
function FindFirstCharAfterSpace(const Line: string; StartPos: integer): Integer; 
var i: integer;  
begin  
  Result := -1;  
  for i := StartPos to Length(Line) do  
  begin  
    if (Line[i] <> ' ') then  
    begin  
      Result := i;  
      exit;  
    end;  
  end;  
end;  
 
function FindFirstSpaceAfterChars(const Line: string; StartPos: integer): Integer;  
begin  
  Result := PosEx(' ', Line, StartPos); 
end;  
 
function FindFirstSpaceBeforeChars(const Line: string; StartPos: integer): Integer; 
var i: integer;  
begin  
  Result := 1;  
  for i := StartPos downto 1 do  
  begin  
    if (Line[i] = ' ') then  
    begin  
      Result := i;  
      exit;  
    end;  
  end;  
end;  
 
var InnerTag: string;  
    LastPos, LastInnerPos: Integer;  
    SPos, LPos, RPos: Integer;  
    AttribValue: string;  
    ClosingChar: char;  
    TempAttribName: string;  
begin  
  Result := 0; 
  LastPos := 1; 
  while (true) do 
  begin 
    // find outer tags '<' & '>' 
    LPos := PosEx('<', HtmlText, LastPos); 
    if (LPos <= 0) then break; 
    RPos := PosEx('>', HtmlText, LPos+1); 
    if (RPos <= 0) then 
      LastPos := LPos + 1 
    else 
      LastPos := RPos + 1;  
 
    // get inner tag  
    InnerTag := Copy(HtmlText, LPos+1, RPos-LPos-1);  
    InnerTag := Trim(InnerTag); // remove spaces  
    if (Length(InnerTag) < Length(TagName)) then continue;  
 
    // check tag name  
    if (SameText(Copy(InnerTag, 1, Length(TagName)), TagName)) then  
    begin  
      // found tag  
      AttribValue := '';  
      LastInnerPos := Length(TagName)+1;  
      while (LastInnerPos < Length(InnerTag)) do  
      begin  
        // find first '=' after LastInnerPos  
        RPos := PosEx('=', InnerTag, LastInnerPos);  
        if (RPos <= 0) then break;  
 
        // this way you can check for multiple attrib names and not a specific attrib  
        SPos := FindFirstSpaceBeforeChars(InnerTag, RPos);  
        TempAttribName := Trim(Copy(InnerTag, SPos, RPos-SPos));  
        if (true) then  
        begin  
          // found correct tag  
          LPos := FindFirstCharAfterSpace(InnerTag, RPos+1);  
          if (LPos <= 0) then  
          begin  
            LastInnerPos := RPos + 1;  
            continue;  
          end;  
          LPos := FindFirstCharAfterSpace(InnerTag, LPos); // get to first char after '='  
          if (LPos <= 0) then continue;  
          if ((InnerTag[LPos] <> '"') and (InnerTag[LPos] <> '''')) then  
          begin  
            // AttribValue is not between '"' or ''' so get it  
            RPos := FindFirstSpaceAfterChars(InnerTag, LPos+1);  
            if (RPos <= 0) then  
              AttribValue := Copy(InnerTag, LPos, Length(InnerTag)-LPos+1)  
            else  
              AttribValue := Copy(InnerTag, LPos, RPos-LPos+1);  
          end  
          else  
          begin  
            // get url between '"' or '''  
            ClosingChar := InnerTag[LPos];  
            RPos := PosEx(ClosingChar, InnerTag, LPos+1);  
            if (RPos <= 0) then  
              AttribValue := Copy(InnerTag, LPos+1, Length(InnerTag)-LPos-1)  
            else  
              AttribValue := Copy(InnerTag, LPos+1, RPos-LPos-1)  
          end;  
 
          if (SameText(TempAttribName, AttribName)) and (AttribValue <> '') then  
          begin  
            Values.Add(AttribValue); 
            inc(Result);  
          end;  
        end;  
 
        if (RPos <= 0) then  
          LastInnerPos := Length(InnerTag)  
        else  
          LastInnerPos := RPos+1;  
      end;  
    end;  
  end;  
end; 
 
function URLEncode(const msg : String) : String; 
var 
    I : Integer; 
begin 
    Result := ''; 
    for I := 1 to Length(msg) do begin 
        if msg[I] = ' ' then 
            Result := Result + '+' 
        else if msg[I] in ['a'..'z', 'A'..'Z', '0'..'9'] then 
            Result := Result + msg[I] 
        else 
            Result := Result + '%' + IntToHex(ord(msg[I]), 2); 
    end; 
end; 
 
 
function UrlDecode(const EncodedStr: String): String; 
var 
  I: Integer; 
begin 
  Result := ''; 
  if Length(EncodedStr) > 0 then 
  begin 
    I := 1; 
    while I <= Length(EncodedStr) do 
    begin 
      if EncodedStr[I] = '%' then 
        begin 
          Result := Result + Chr(HexToInt(EncodedStr[I+1] 
                                       + EncodedStr[I+2])); 
          I := Succ(Succ(I)); 
        end 
      else if EncodedStr[I] = '+' then 
        Result := Result + ' ' 
      else 
        Result := Result + EncodedStr[I]; 
 
      I := Succ(I); 
    end; 
  end; 
end; 
 
Function HexToInt(Hex :String):Int64; 
Var Sum : Int64; 
    I,L : Integer; 
Begin 
L := Length(Hex); 
Sum := 0; 
For I := 1 to L Do 
   Begin 
   Sum := Sum * 16; 
   If ( Ord(Hex[I]) >= Ord('0')) and (Ord(Hex[I]) <= Ord('9')) then 
      Sum := Sum + Ord(Hex[I]) - Ord('0') 
   else If ( Ord(Hex[I]) >= Ord('A') ) and (Ord(Hex[I]) <= Ord('F')) then 
      Sum := Sum + Ord(Hex[I]) - Ord('A') + 10 
   else If ( Ord(Hex[I]) >= Ord('a') ) and ( Ord(Hex[I]) <= Ord('f')) then 
      Sum := Sum + Ord(Hex[I]) - Ord('a') + 10 
   else 
      Begin 
      Sum := -1; 
      break; 
      End; 
   End; 
Result := Sum; 
End; 
 
procedure AddLstBPro(ListBox : TListBox; str : string; Insert : boolean; MaxLine : Integer); 
var 
  Ct : Integer; 
begin 
  with ListBox do 
  begin 
    Ct := Count; 
    if InSert then 
    begin 
      if Ct > MaxLine then 
      Items.Delete(Ct-1); 
      Items.Insert(0,str); 
    end else begin 
      if Ct > MaxLine then 
      Items.Delete(0); 
      Items.Add(str); 
    end; 
  end; 
end; 
 
procedure AddLstVitemPro(LstV : TListView; Subs : TStringList; Data: Pointer=nil); 
var 
  item : TListItem; 
begin 
  with LstV do 
  begin 
    //Items.BeginUpdate; 
    item := items.Add; 
    item.Caption := IntToStr(items.Count); 
    item.SubItems.Assign(Subs); 
    if Data <> nil then 
    item.Data := Data; 
    //Items.EndUpdate; 
  end; 
end; 
 
function GetHexCPUid: string; 
var 
  i : Byte; 
  Id : TCPUID; 
begin 
  Id := GetCPUID; 
  Result := ''; 
  for i:=low(Id) to High(Id) do 
  Result := Result + IntToHex(Id[i],8); 
end; 
 
function ClearRegCode : boolean; 
var 
  ARegistry : TRegistry; 
begin 
  Result := True; 
  ARegistry := TRegistry.Create; 
  with ARegistry do 
  begin 
    try 
      RootKey:=HKEY_LOCAL_MACHINE; 
      try 
        if OpenKey('Software\MicroSoft\Windows\CurrentVersion\'+PRODUCT_NAME,false) then 
          WriteString('RegCode',''); 
      except 
        Result := False; 
      end; 
    finally 
      Free; 
    end; 
  end; 
end; 
 
function ReadRegCode : boolean; 
var 
  ARegistry : TRegistry; 
begin 
  Result := True; 
  ARegistry := TRegistry.Create; 
  with ARegistry do 
  begin 
    try 
      RootKey:=HKEY_LOCAL_MACHINE; 
      try 
        if OpenKey('Software\MicroSoft\Windows\CurrentVersion\'+PRODUCT_NAME,false) then 
          strRegCode:=ReadString('RegCode'); 
      except 
        Result := False; 
      end; 
    finally 
      Free; 
    end; 
  end; 
end; 
 
function WriteRegCode: boolean; 
var 
  ARegistry : TRegistry; 
begin 
  Result := True; 
  ARegistry := TRegistry.Create; 
  with ARegistry do 
  begin 
    try 
      RootKey:=HKEY_LOCAL_MACHINE; 
      try 
        if OpenKey('Software\MicroSoft\Windows\CurrentVersion\'+PRODUCT_NAME,True) then 
          WriteString('RegCode',EncryptString(GetHexCPUid,REG_KEY)); 
      except 
        Result := False; 
      end; 
    finally 
      Free; 
    end; 
  end; 
end; 
 
procedure CheckRegCode(Code : string); 
begin 
  bIsReg := EncryptString(GetHexCPUid,REG_KEY) = Code; 
end; 
 
//取得发贴内容中所有需要智能扰码的词组 
function GetRndDisTurbStrs(Content : String; Strs : TStringList; Cn : boolean) : String ; 
var 
  iPos: integer; 
  RD_ED,RD_ST : Char; 
begin 
  Strs.Clear; 
  if Cn then 
  begin 
    RD_ED := RD_ED_CN; 
    RD_ST := RD_ST_CN; 
  end else begin 
    RD_ED := RD_ED_EN; 
    RD_ST := RD_ST_EN; 
  end; 
  Repeat 
    iPos := Pos(RD_ST,Content); 
    if iPos > 0 then 
    begin 
      Delete(Content,1,iPos); 
      iPos := Pos(RD_ED,Content); 
      if iPos > 0 then 
      begin 
        Strs.Add(Copy(Content,1,iPos-1)); 
        Delete(Content,1,iPos); 
      end; 
    end 
  Until iPos = 0; 
end; 
 
//生成扰码词组 
function GenRndDisturb(Str : String; Cn : boolean): String; 
var 
  i : integer; 
  InsertStep : Byte; 
  sl : TStringList; 
  c : Char; 
begin 
  Str := Copy(Str,2,Length(Str)-2); 
  Result := ''; 
  if Cn then InsertStep :=2 
  else InsertStep := 1; 
  sl := TStringList.Create; 
  for i:=1 to Length(Str)div InsertStep do 
  sl.Add(Copy(Str,(i-1)*InsertStep+1,InsertStep)); 
  if Cn then 
  begin 
    for i:=0 to Sl.Count-1 do 
    Result := Result + DT_CN[Random(High(DT_CN))]+Sl[i]; 
    Result := Result + DT_CN[Random(High(DT_CN))]; 
  end else begin 
    for i:=0 to Sl.Count-1 do 
    begin 
      c := Sl[i][1]; 
      if Random(2)=1 then 
      if c in ['0'..'9'] then 
      begin 
        Sl[i] := DT_NM[StrToInt(c)]; 
      end else if c in ['a'..'z'] then 
      begin 
        Sl[i] := DT_EN[Ord(c)-97]; 
      end else if c in ['A'..'Z'] then 
      begin 
        Sl[i] := DT_EN[Ord(c)-65]; 
      end else 
        case c of 
        '.': Sl[i]:= '．'; 
        ':': Sl[i]:= '：'; 
        '/': Sl[i]:= '／'; 
        '@': Sl[i]:= '＠'; 
        end; 
    end; 
    for i:=0 to Sl.Count-1 do 
    Result := Result + Sl[i]; 
  end; 
  SL.Free; 
end; 
 
function AnaUserLine(Line,User,RpStr : String) : String ; 
var 
  iPos: integer; 
  Sub,StringI : String; 
begin 
  StringI := Line; 
  Repeat 
    iPos := Pos(RpStr,StringI); 
    if iPos > 0 then 
    begin 
      Sub := Sub + Copy(StringI,1,iPos-1) + User; 
      StringI := Copy(StringI,iPos+length(RpStr),length(StringI)); 
    end 
  Until iPos = 0; 
  Result := Sub + StringI; 
end; 
 
function NewSectionName(pre: String ; len: integer) : String; 
var 
  i : integer; 
  Temp : String; 
begin 
  Randomize; 
  Result := '1'; 
  for i:=1 to len do 
  Result := Result + '0'; 
  Result := IntToStr(Random(StrToInt(Result))); 
  for i:=1 to len-length(Result) do 
  Temp := '0'+ Temp; 
  Result := pre + Temp + Result; 
end; 
 
function DisTurbContent(Content : String):String; 
var 
  Words : TStringList; 
  i : Integer; 
  Word : String; 
  Debug : String; 
begin 
  Content := AnaUserLine(Content,NewSectionName('',5),'[random]'); 
  Words := TStringList.Create; 
  GetRndDisTurbStrs(Content,Words,True); 
  Debug := Words.Text; 
  for i:=0 to Words.Count-1 do 
  begin 
    Word := RD_ST_CN+Words[i]+RD_ED_CN; 
    Content := AnaUserLine(Content,GenRndDisturb(Word,true),Word); 
  end; 
  GetRndDisTurbStrs(Content,Words,False); 
  for i:=0 to Words.Count-1 do 
  begin 
    Word := RD_ST_EN+Words[i]+RD_ED_EN; 
    Content := AnaUserLine(Content,GenRndDisturb(Word,False),Word); 
  end; 
  Words.Free; 
  Result := Content; 
end; 
 
function FormatStrNum(Num : Integer; Len : Byte): String; 
var 
  i,ct : Byte; 
  Zeros,sNum : String; 
begin 
  sNum := IntToStr(Num); 
  ct := Len - Length(sNum); 
  if ct > 0 then 
    for i:=1 to ct do 
      Zeros := Zeros + '0'; 
  Result := Zeros + IntToStr(Num); 
end; 
 
procedure GetColumnFromLstV(LstV : TListView; Sl : TStringList; idx : Byte); 
var 
  i : Byte; 
begin 
  with LstV do 
  for i:=0 to Items.Count-1 do 
  Sl.Add(Items[i].SubItems[idx]); 
end; 
 
function LStrDiv(Str,Spl : string): string; 
var 
  iPos : Integer; 
begin 
  iPos := Pos(Spl,Str); 
  if iPos>0 then 
  Result := Copy(Str,1,iPos-1); 
end; 
 
function RStrDiv(Str,Spl : string): string; 
var 
  iPos : Integer; 
begin 
  iPos := Pos(Spl,Str); 
  if iPos>0 then 
  begin 
    Delete(Str,1,iPos+Length(Spl)-1); 
    Result := Str; 
  end; 
end; 
 
function ExStrSeg(Str,Spl : string; Idx : Integer): string; 
var 
  Values : TStringList; 
begin 
  Values := TStringList.Create; 
  ExtractStrings([Spl[1]],[],PChar(Str),Values); 
  if Values.Count >= Idx then 
  Result := Values[Idx-1]; 
  Values.Free; 
end; 
 
function GenRndUSR(Prefix,Tail : string; Len : Byte): string; 
var 
  i : Byte; 
begin 
  Result := ''; 
  Randomize; 
  for i:=1 to Len do 
  Result := Result + chr(Random(26)+97); 
  Result := Prefix + Result + Tail; 
end; 
 
function BoolToStr(b : boolean): string; 
begin 
  if b then Result := '成功' else 
  Result := '失败'; 
end; 
 
function IsNum(s : string): boolean; 
var 
  i : Byte; 
begin 
  Result := true; 
  for i:=1 to length(s) do 
  result := result and (Ord(s[i]) in [48..57]); 
end; 
 
function GetLinkTextByURL(HTML,URL : string):string; 
var 
  iPos : Integer; 
begin 
  iPos := Pos(URL,HTML); 
  if iPos > 0 then 
  begin 
    Delete(HTML,1,iPos); 
    iPos := Pos('>',HTML); 
    if iPos>0 then 
    begin 
      Delete(HTML,1,iPos); 
      iPos := Pos('<',HTML); 
      if iPos>0 then 
      Result := Trim(Copy(HTML,1,iPos-1)); 
    end; 
  end; 
end; 
 
procedure ChkLstV(LstV : TListView; Chk : Boolean); 
var 
  i: Integer; 
begin 
  for i:=0 to LstV.Items.Count-1 do 
  LstV.Items[i].Checked := Chk; 
end; 
 
procedure RfhLstV(LstV : TListView); 
var 
  i : Integer; 
begin 
  for i:=0 to LstV.Items.Count-1 do 
  LstV.Items[i].Caption := IntToStr(i+1); 
end; 
 
 
end.