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         Delim: Integer;
 177     body: string;
 178 begin
 179         FSession := TBelibSession.Create;
 180
 181         if Proxy <> '' then begin
 182                 ProxyHostPort := Format('%s:%d', [Proxy, Port]);
 183                 hSession := InternetOpen(BELIB_LOGIN_UA, INTERNET_OPEN_TYPE_PROXY, PChar(ProxyHostPort), '', 0);
 184         end else begin
 185                 hSession := InternetOpen(BELIB_LOGIN_UA, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
 186         end;
 187
 188         if not Assigned(hSession) then
 189                 MakeError(FSession, GetLastError())
 190         else begin
 191                 hConnect := InternetConnect(hSession, BELIB_LOGIN_HOST,
 192                         INTERNET_DEFAULT_HTTP_PORT, nil, nil,
 193                         INTERNET_SERVICE_HTTP, 0, 0);
 194                 if not Assigned(hConnect) then
 195                         MakeError(FSession, GetLastError())
 196                 else begin
 197                         hRequest := HttpOpenRequest(hConnect, 'POST', BELIB_LOGIN_URL,
 198                                 nil, nil, nil,
 199                                 INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_NO_COOKIES or
 200                                 INTERNET_FLAG_NO_UI, 0);
 201                         if not Assigned(hRequest) then
 202                                 MakeError(FSession, GetLastError())
 203                         else begin
 204                                 UserInfo := Format('m=%s&p=%s&submit=%s', [HttpEncode(ID), HttpEncode(Pass), HttpEncode(SJIStoEUC('\93o\98^'))]);
 205                 Header := 'Content-Type: application/x-www-form-urlencoded'#13#10;
 206                                 UserAgent := Format('%s %s', [BELIB_2CH_UA, ClientUA]) + #13#10;
 207                 Header := Header + UserAgent;
 208                                 if not HttpSendRequest(hRequest, PChar(Header), DWORD(-1), PChar(UserInfo), Length(UserInfo)) then
 209                                         MakeError(FSession, GetLastError())
 210                                 else begin
 211                                         if not InternetReadFile(hRequest, @Buf, SizeOf(Buf), cb) then
 212                                                 MakeError(FSession, GetLastError())
 213                                         else if (Pos('cookie', Buf) = 0) or (Pos('"DMDM=', Buf) = 0)
 214                      or (Pos('"MDMD=', Buf) = 0) then
 215                                                 MakeError(FSession, ERROR_INVALID_DATA)
 216                                         else begin
 217                         body := Buf;
 218                         body := EUCtoSJIS(body);    // 2byte\95¶\8e\9a\82Ì\95\94\95ª\82Í\8eg\82í\82È\82¢\82¯\82Ç\94O\82Ì\82½\82ß
 219                         FSession.FDMDM := Copy(body, Pos('"DMDM=', body) + 6, Length(body));
 220                         FSession.FDMDM := Copy(FSession.FDMDM, 1, Pos(';', FSession.FDMDM) - 1);
 221                         FSession.FMDMD := Copy(body, Pos('"MDMD=', body) + 6, Length(body));
 222                         FSession.FMDMD := Copy(FSession.FMDMD, 1, Pos(';', FSession.FMDMD) - 1);
 223                                         end;
 224                                 end;
 225                                 InternetCloseHandle(hRequest);
 226                         end;
 227                         InternetCloseHandle(hConnect);
 228                 end;
 229                 InternetCloseHandle(hSession);
 230         end;
 231 end;
 232 end.
 233