Develop and Download Open Source Software

Browse CVS Repository

Contents of /gikonavigoeson/gikonavi/Dolib.pas

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


Revision 1.1 - (show annotations) (download) (as text)
Sat Aug 9 13:50:40 2003 UTC (20 years, 8 months ago) by hi_
Branch: MAIN
Branch point for: hi
File MIME type: text/x-pascal
Initial revision

1 {*******************************************************}
2 { }
3 { DOLIB API Interface Unit }
4 { }
5 { 2002 Monazilla Project }
6 { Dax mailto:daxmonazilla@yahoo.co.jp }
7 { (ヒ)mailto:gikonavi@ice.dti2.ne.jp }
8 {********************************************************
9
10 Updates:
11
12 2002/03/02 ログインエラーを検出するように修正したかも。
13 2002/03/02 DOLIB.dllを使わないようにした。
14 2002/02/27 バグ修正 (GetVersionはコネクトしてなくても取得可能にした)
15 2002/01/22 DOLIB 1.00C対応。
16 以下のプロパティを追加。
17 - Session ......... セッションのポインタを返します、多分使わない。
18 - SessionID ....... セッションIDを返します。
19 - Version ......... DOLIBのバージョンを返します。
20 - UserAgent ....... UA用の文字列 Monazilla/x.xx を返します。
21 - ErrorCode ....... エラーコードを返します。
22 - ErrorMsg ........ エラーメッセージを返します。
23 2002/01/20 Disconnect後に Connectedプロパティを戻してなかった。
24 2002/01/19 DOLIB 1.00B対応。データ取得に成功!
25 2002/01/18 DOLIB 1.00対応。しかしエラーしか返って来ない、、
26 2002/01/18 ghanyan氏の助言により動作する。感謝!
27 2002/01/09 DOLIB 0.01用に作成開始。でも動かないのでほっとく。
28 }
29 unit Dolib;
30
31 {$IOCHECKS ON}
32
33 interface
34
35 uses
36 Windows, SysUtils, WinInet;
37
38 type
39 TDolibSession = class(TObject)
40 private
41 FSessionID: string;
42 FErrorCode: Integer;
43 FErrorString: string;
44 FUserAgent: string;
45 public
46 property SessionID: string read FSessionID write FSessionID;
47 property ErrorCode: Integer read FErrorCode write FErrorCode;
48 property ErrorString: string read FErrorString write FErrorString;
49 property UserAgent: string read FUserAgent write FUserAgent;
50 end;
51
52 TDolib = class(TObject)
53 private
54 FSession : TDolibSession;
55 FConnected: boolean;
56 FProxyPort: integer;
57 FUserName: string;
58 FPassword: string;
59 FProxyAddress: string;
60 FClientUA: string;
61 function GetSessionID: string;
62 function GetVersion: string;
63 function GetUserAgent: string;
64 function GetErrorCode: integer;
65 function GetErrorMsg: string;
66 procedure MakeError(Session: TDolibSession; Error: DWORD);
67 procedure DOLIB_LOGIN(Proxy: string; Port: Integer; ID: string; Pass: string);
68 public
69 constructor Create;
70 destructor Destroy; override;
71 function Connect: boolean;
72 function Disconnect: boolean;
73 property ProxyAddress: string read FProxyAddress write FProxyAddress;
74 property ProxyPort: integer read FProxyPort write FProxyPort;
75 property UserName: string read FUserName write FUserName;
76 property Password: string read FPassword write FPassword;
77 property ClientUA: string read FClientUA write FClientUA;
78 property Connected: boolean read FConnected;
79 property SessionID: string read GetSessionID;
80 property Version: string read GetVersion;
81 property UserAgent: string read GetUserAgent;
82 property ErrorCode: integer read GetErrorCode;
83 property ErrorMsg: string read GetErrorMsg;
84 end;
85
86 implementation
87 const
88 DOLIB_VERSION = $10000;
89 DOLIB_LOGIN_UA = 'DOLIB/1.00';
90 DOLIB_LOGIN_HOST = 'tiger2.he.net';
91 DOLIB_LOGIN_URL = '/~tora3n2c/futen.cgi';
92 DOLIB_2CH_UA = 'X-2ch-UA:';
93 // DOLIB_2CH_UA = 'X-2ch-UA: gikoNavi/1.00'#13#10;
94 DOLIB_ENOMEM_STRING = 'メモリが足りません。';
95 DOLIB_LOGIN_ERROR = 'ERROR:';
96
97 { TDolib }
98
99 constructor TDolib.Create;
100 begin
101 FSession := nil;
102 FConnected := False;
103 end;
104
105 destructor TDolib.Destroy;
106 begin
107 if Connected then
108 Disconnect;
109 inherited;
110 end;
111
112 function TDolib.Connect: boolean;
113 begin
114 Result := False;
115 if not Connected then begin
116 DOLIB_LOGIN(FProxyAddress, FProxyPort, FUserName, FPassword);
117 FConnected := True;
118 if (AnsiPos(DOLIB_LOGIN_ERROR, SessionID) = 1) then begin
119 Disconnect;
120 Result := False;
121 end else if ErrorCode <> 0 then begin
122 Disconnect;
123 Result := False;
124 end else begin
125 Result := True;
126 // Result := (ErrorCode = 0);
127 end;
128 end;
129 end;
130
131 function TDolib.Disconnect: boolean;
132 begin
133 Result := True;
134 if FSession <> nil then
135 FreeAndNil(FSession);
136 FConnected := False;
137 end;
138
139 function TDolib.GetVersion: string;
140 var
141 v : DWORD;
142 mj, mn : integer;
143 begin
144 v := DOLIB_VERSION;
145 mj := v shr 16;
146 mn := v and $ffff;
147 Result := Format('%d.%.2d', [mj, mn]);
148 end;
149
150 function TDolib.GetSessionID: string;
151 begin
152 if Connected then
153 Result := FSession.FSessionID
154 else
155 Result := '';
156 end;
157
158 function TDolib.GetUserAgent: string;
159 begin
160 if Connected then
161 Result := FSession.FUserAgent
162 else
163 Result := '';
164 end;
165
166 function TDolib.GetErrorMsg: string;
167 begin
168 if Connected then
169 Result := FSession.FErrorString
170 else
171 Result := 'Error: IDかパスワードが正しくありません。';
172 end;
173
174 function TDolib.GetErrorCode: integer;
175 begin
176 if Connected then
177 Result := FSession.ErrorCode
178 else
179 Result := 0;
180 end;
181
182 procedure TDolib.MakeError(Session: TDolibSession; Error: DWORD);
183 var
184 Buf: array[0..4096] of Char;
185 begin
186 Session.ErrorCode := Error;
187 if Error = ERROR_NOT_ENOUGH_MEMORY then
188 Session.ErrorString := DOLIB_ENOMEM_STRING
189 else begin
190 FillChar(Buf, SizeOf(Buf), #0);
191 FormatMessage({FORMAT_MESSAGE_ALLOCATE_BUFFER or}
192 FORMAT_MESSAGE_IGNORE_INSERTS or
193 FORMAT_MESSAGE_FROM_SYSTEM or
194 FORMAT_MESSAGE_FROM_HMODULE,
195 Pointer(GetModuleHandle('wininet')), Error,
196 (((Word(SUBLANG_DEFAULT)) shl 10) or Word(LANG_NEUTRAL)), //DelphiにMAKELANGIDマクロが無かったの。(´・ω・`)ショボーン
197 // MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
198 Buf, SizeOf(Buf), nil);
199 Session.ErrorString := Buf;
200 end;
201 end;
202
203 {参考URL
204 kage作者さんのDOLIBクローンソース(大変おいしゅうございました)
205 http://members.jcom.home.ne.jp/monazilla/document/wininetdel.html
206 http://support.microsoft.com/default.aspx?scid=kb;EN-US;q168151
207 http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/wininet/wininet.asp
208 http://homepage1.nifty.com/~suzuki/delphi/wininet.html
209 }
210 procedure TDolib.DOLIB_LOGIN(Proxy: string; Port: Integer; ID: string; Pass: string);
211 var
212 hSession: HINTERNET;
213 hConnect: HINTERNET;
214 hRequest: HINTERNET;
215 ProxyHostPort: string;
216 Buf: array[0..4096] of Char;
217 UserInfo: string;
218 UserAgent: string;
219 cb: DWORD;
220 Delim: Integer;
221 begin
222 FSession := TDolibSession.Create;
223
224 if Proxy <> '' then begin
225 ProxyHostPort := Format('%s:%d', [Proxy, Port]);
226 hSession := InternetOpen(DOLIB_LOGIN_UA, INTERNET_OPEN_TYPE_PROXY, PChar(ProxyHostPort), '', 0);
227 end else begin
228 hSession := InternetOpen(DOLIB_LOGIN_UA, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
229 end;
230
231 if not Assigned(hSession) then
232 MakeError(FSession, GetLastError())
233 else begin
234 hConnect := InternetConnect(hSession, DOLIB_LOGIN_HOST,
235 INTERNET_DEFAULT_HTTPS_PORT, nil, nil,
236 INTERNET_SERVICE_HTTP, INTERNET_FLAG_SECURE, 0);
237 if not Assigned(hConnect) then
238 MakeError(FSession, GetLastError())
239 else begin
240 hRequest := HttpOpenRequest(hConnect, 'POST', DOLIB_LOGIN_URL,
241 nil, nil, nil,
242 INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_NO_COOKIES or
243 INTERNET_FLAG_NO_UI or INTERNET_FLAG_SECURE, 0);
244 if not Assigned(hRequest) then
245 MakeError(FSession, GetLastError())
246 else begin
247 UserInfo := Format('ID=%s&PW=%s', [ID, Pass]);
248 UserAgent := Format('%s %s', [DOLIB_2CH_UA, ClientUA]) + #13#10;
249 if not HttpSendRequest(hRequest, PChar(UserAgent), DWORD(-1), PChar(UserInfo), Length(UserInfo)) then
250 MakeError(FSession, GetLastError())
251 else begin
252 if not InternetReadFile(hRequest, @Buf, SizeOf(Buf), cb) then
253 MakeError(FSession, GetLastError())
254 else if (cb < 11) or (Pos('SESSION-ID=', Buf) <> 1) then
255 MakeError(FSession, ERROR_INVALID_DATA)
256 else begin
257 if Buf[cb - 1] = #10 then
258 Buf[cb - 1] := #0;
259 FSession.SessionID := Copy(Buf, 12, cb);
260 if FSession.SessionID = '' then
261 MakeError(FSession, ERROR_NOT_ENOUGH_MEMORY);
262 Delim := Pos(':', Buf);
263 if Delim = 0 then
264 MakeError(FSession, ERROR_INVALID_DATA)
265 else begin
266 FSession.UserAgent := Copy(Buf, 12, Delim - 12);
267 if FSession.UserAgent = '' then
268 MakeError(FSession, ERROR_NOT_ENOUGH_MEMORY);
269 end;
270 end;
271 end;
272 InternetCloseHandle(hRequest);
273 end;
274 InternetCloseHandle(hConnect);
275 end;
276 InternetCloseHandle(hSession);
277 end;
278 end;
279
280 end.
281

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