Develop and Download Open Source Software

Browse CVS Repository

Contents of /gikonavigoeson/gikonavi/Belib.pas

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.2 - (show annotations) (download) (as text)
Thu Mar 3 15:17:19 2011 UTC (13 years, 1 month ago) by h677
Branch: MAIN
CVS Tags: v1_62_1_813, v1_63_0_818, v1_63_0_817, v1_63_0_816, v1_63_0_815, v1_63_1_819, HEAD
Branch point for: Bb62, Bb63
Changes since 1.1: +1 -0 lines
File MIME type: text/x-pascal
asciiホホー隍キ、ォクォ、ニ、ハ、、、ア、ノ。「Euc2JIS、ケ、?隍ヲ、ヒス、タオ

1 { Dolib繧偵さ繝斐?縺励※BE繝ュ繧ー繧、繝ウ繧サ繝?す繝ァ繝ウ邂。逅?r菴懈? }
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 = '繝。繝「繝ェ縺瑚カウ繧翫∪縺帙s縲?#39;;
64 BELIB_LOGIN_ERROR = 'ERROR:';
65 // http:///縲?
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: 繝。繝シ繝ォ繧「繝峨Ξ繧ケ縺九ヱ繧ケ繝ッ繝シ繝峨′豁」縺励¥縺ゅj縺セ縺帙s縲?#39;;
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縺ォMAKELANGID繝槭け繝ュ縺檎┌縺九▲縺溘?縲?ツエ?・マ会ス・`)?シ?ョ?趣セ橸スー??/span>
157 // MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
158 Buf, SizeOf(Buf), nil);
159 Session.ErrorString := Buf;
160 end;
161 end;
162
163 {DOLIB繧貞盾閠?↓縺励※縺セ縺?/span>
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('逋サ骭イ'))]);
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譁?ュ励?驛ィ蛻??菴ソ繧上↑縺?¢縺ゥ蠢オ縺ョ縺溘a
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

Back to OSDN">Back to OSDN
ViewVC Help
Powered by ViewVC 1.1.26