Belib.pas

   1 { Dolib\82ð\83R\83s\81[\82µ\82ÄBE\83\8d\83O\83C\83\93\83Z\83b\83V\83\87\83\93\8aÇ\97\9d\82ð\8dì\90¬ }
   2 unit Belib;
   3
   4 {$IOCHECKS ON}
   5
   6 interface
   7
   8 uses
   9         Windows, SysUtils, WinInet, YofUtils, Y_TextConverter;
  10
  11 type
  12         TBelibSession = class(TObject)
  13         private
  14                 FMDMD: string;
  15                 FDMDM: string;
  16                 FErrorCode: Integer;
  17                 FErrorString: string;
  18         public
  19                 property MDMD: string read FMDMD write FMDMD;
  20         property DMDM: string read FDMDM write FDMDM;
  21                 property ErrorCode: Integer read FErrorCode write FErrorCode;
  22                 property ErrorString: string read FErrorString write FErrorString;
  23         end;
  24
  25         TBelib  = class(TObject)
  26         private
  27                 FSession : TBelibSession;
  28                 FConnected: boolean;
  29                 FProxyPort: integer;
  30                 FUserName: string;
  31                 FPassword: string;
  32                 FProxyAddress: string;
  33                 FClientUA: string;
  34                 function GetMDMD : string;
  35                 function GetDMDM : string;
  36                 function GetErrorCode: integer;
  37                 function GetErrorMsg: string;
  38                 procedure MakeError(Session: TBelibSession; Error: DWORD);
  39                 procedure BELIB_LOGIN(Proxy: string; Port: Integer; ID: string; Pass: string);
  40         public
  41                 constructor Create;
  42                 destructor  Destroy; override;
  43                 function  Connect: boolean;
  44                 function  Disconnect: boolean;
  45                 property  ProxyAddress: string  read  FProxyAddress write FProxyAddress;
  46                 property  ProxyPort: integer  read  FProxyPort  write FProxyPort;
  47                 property  UserName: string  read  FUserName write FUserName;
  48                 property  Password: string  read  FPassword write FPassword;
  49                 property  ClientUA: string  read  FClientUA write FClientUA;
  50                 property  Connected: boolean  read  FConnected;
  51                 property  MDMD: string read  GetMDMD;
  52                 property  DMDM: string read  GetDMDM;
  53                 property  ErrorCode: integer read  GetErrorCode;
  54                 property  ErrorMsg: string  read  GetErrorMsg;
  55         end;
  56
  57 implementation
  58 const
  59         BELIB_LOGIN_UA      = 'BELIB/1.00';
  60         BELIB_LOGIN_HOST    = 'be.2ch.net';
  61         BELIB_LOGIN_URL     = '/test/login.php';
  62         BELIB_2CH_UA        = 'X-2ch-UA:';
  63         BELIB_ENOMEM_STRING = '\83\81\83\82\83\8a\82ª\91«\82è\82Ü\82¹\82ñ\81B';
  64         BELIB_LOGIN_ERROR   = 'ERROR:';
  65 // http:///\81@
  66
  67 { TBelib }
  68
  69 constructor TBelib.Create;
  70 begin
  71         FSession   := nil;
  72         FConnected := False;
  73 end;
  74
  75 destructor TBelib.Destroy;
  76 begin
  77         if Connected then
  78                 Disconnect;
  79         inherited;
  80 end;
  81
  82 function TBelib.Connect: boolean;
  83 begin
  84         Result := False;
  85         if not Connected then begin
  86                 BELIB_LOGIN(FProxyAddress, FProxyPort, FUserName, FPassword);
  87                 FConnected  :=  True;
  88                 if (Length(MDMD)=0) and (Length(DMDM)=0) then  begin
  89                         Disconnect;
  90                         Result      :=  False;
  91                 end else if ErrorCode <> 0 then begin
  92                         Disconnect;
  93                         Result := False;
  94                 end else begin
  95                         Result := True;
  96 //                      Result      :=  (ErrorCode = 0);
  97                 end;
  98         end;
  99 end;
 100
 101 function TBelib.Disconnect: boolean;
 102 begin
 103         Result := True;
 104   if FSession <> nil then
 105     FreeAndNil(FSession);
 106   FConnected := False;
 107 end;
 108
 109 function TBelib.GetMDMD : string;
 110 begin
 111         if Connected then
 112                 Result := FSession.FMDMD
 113         else
 114                 Result := '';
 115 end;
 116
 117 function TBelib.GetDMDM : string;
 118 begin
 119         if Connected then
 120                 Result := FSession.FDMDM
 121         else
 122                 Result := '';
 123 end;
 124
 125
 126 function TBelib.GetErrorMsg: string;
 127 begin
 128         if Connected then
 129                 Result := FSession.FErrorString
 130         else
 131     Result  :=  'Error: \83\81\81[\83\8b\83A\83h\83\8c\83X\82©\83p\83X\83\8f\81[\83h\82ª\90³\82µ\82\82 \82è\82Ü\82¹\82ñ\81B';
 132 end;
 133
 134 function TBelib.GetErrorCode: integer;
 135 begin
 136         if Connected then
 137                 Result := FSession.ErrorCode
 138         else
 139                 Result := 0;
 140 end;
 141
 142 procedure TBelib.MakeError(Session: TBelibSession; Error: DWORD);
 143 var
 144         Buf: array[0..4096] of Char;
 145 begin
 146         Session.ErrorCode := Error;
 147         if Error = ERROR_NOT_ENOUGH_MEMORY then
 148                 Session.ErrorString := BELIB_ENOMEM_STRING
 149         else begin
 150                 FillChar(Buf, SizeOf(Buf), #0);
 151                 FormatMessage({FORMAT_MESSAGE_ALLOCATE_BUFFER or}
 152                         FORMAT_MESSAGE_IGNORE_INSERTS or
 153                         FORMAT_MESSAGE_FROM_SYSTEM or
 154                         FORMAT_MESSAGE_FROM_HMODULE,
 155                         Pointer(GetModuleHandle('wininet')), Error,
 156                         (((Word(SUBLANG_DEFAULT)) shl 10) or Word(LANG_NEUTRAL)),       //Delphi\82ÉMAKELANGID\83}\83N\83\8d\82ª\96³\82©\82Á\82½\82Ì\81B(\81L¥\83Ö¥`)¼®ÎÞ°Ý
 157 //                      MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
 158                         Buf, SizeOf(Buf), nil);
 159                 Session.ErrorString := Buf;
 160         end;
 161 end;
 162
 163 {DOLIB\82ð\8eQ\8dl\82É\82µ\82Ä\82Ü\82·
 164 }
 165 procedure TBelib.BELIB_LOGIN(Proxy: string; Port: Integer; ID: string; Pass: string);
 166 var
 167         hSession: HINTERNET;
 168         hConnect: HINTERNET;
 169         hRequest: HINTERNET;
 170         ProxyHostPort: string;
 171         Buf: array[0..4096] of Char;
 172         UserInfo: string;
 173         UserAgent: string;
 174     Header: string;
 175         cb: DWORD;
 176         Index: DWORD;
 177 //      Delim: Integer;
 178     body: string;
 179 begin
 180         FSession := TBelibSession.Create;
 181
 182         if Proxy <> '' then begin
 183                 ProxyHostPort := Format('%s:%d', [Proxy, Port]);
 184                 hSession := InternetOpen(BELIB_LOGIN_UA, INTERNET_OPEN_TYPE_PROXY, PChar(ProxyHostPort), '', 0);
 185         end else begin
 186                 hSession := InternetOpen(BELIB_LOGIN_UA, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
 187         end;
 188
 189         if not Assigned(hSession) then
 190                 MakeError(FSession, GetLastError())
 191         else begin
 192                 hConnect := InternetConnect(hSession, BELIB_LOGIN_HOST,
 193                         INTERNET_DEFAULT_HTTP_PORT, nil, nil,
 194                         INTERNET_SERVICE_HTTP, 0, 0);
 195                 if not Assigned(hConnect) then
 196                         MakeError(FSession, GetLastError())
 197                 else begin
 198                         hRequest := HttpOpenRequest(hConnect, 'POST', BELIB_LOGIN_URL,
 199                                 nil, nil, nil,
 200                                 INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_NO_COOKIES or
 201                                 INTERNET_FLAG_NO_UI, 0);
 202                         if not Assigned(hRequest) then
 203                                 MakeError(FSession, GetLastError())
 204                         else begin
 205                                 UserInfo := Format('m=%s&p=%s', [HttpEncode(ID), HttpEncode(Pass)]);
 206                 Header := 'Content-Type: application/x-www-form-urlencoded'#13#10;
 207                                 UserAgent := Format('%s %s', [BELIB_2CH_UA, ClientUA]) + #13#10;
 208                 Header := Header + UserAgent;
 209                                 if not HttpSendRequest(hRequest, PChar(Header), DWORD(-1), PChar(UserInfo), Length(UserInfo)) then
 210                                         MakeError(FSession, GetLastError())
 211                                 else begin
 212                     cb := Sizeof(Buf);
 213                     Index := 0;
 214                     ZeroMemory(@Buf, cb);
 215                     if not HttpQueryInfo(hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, @Buf, cb, Index) then
 216                                         MakeError(FSession, GetLastError())
 217                                         else if (Pos('Set-Cookie:', Buf) = 0) or (Pos('DMDM=', Buf) = 0)
 218                      or (Pos('MDMD=', Buf) = 0) then begin
 219                                                 MakeError(FSession, ERROR_INVALID_DATA);
 220                     end
 221                                         else begin
 222                         body := Buf;
 223                         FSession.FDMDM := Copy(body, Pos('DMDM=', body) + 5, Length(body));
 224                         FSession.FDMDM := Copy(FSession.FDMDM, 1, Pos(';', FSession.FDMDM) - 1);
 225                         FSession.FMDMD := Copy(body, Pos('MDMD=', body) + 5, Length(body));
 226                         FSession.FMDMD := Copy(FSession.FMDMD, 1, Pos(';', FSession.FMDMD) - 1);
 227                                         end;
 228                                 end;
 229                                 InternetCloseHandle(hRequest);
 230                         end;
 231                         InternetCloseHandle(hConnect);
 232                 end;
 233                 InternetCloseHandle(hSession);
 234         end;
 235 end;
 236 end.
 237