Develop and Download Open Source Software

Browse CVS Repository

Annotation of /gikonavigoeson/gikonavi/Belib.pas

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


Revision 1.1 - (hide annotations) (download) (as text)
Tue Feb 22 13:37:51 2011 UTC (13 years, 1 month ago) by h677
Branch: MAIN
CVS Tags: v1_62_0_809, v1_62_0_812, v1_62_0_810, v1_62_0_811
File MIME type: text/x-pascal
Beのログインに対応
Folder.iniに冒険の書が記録されている場合削除する処理を追加

1 h677 1.1 { Dolib???潟???若????E???違?ゃ?潟?祉???激?с?括?????篏??? }
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 = '?<?≪????莇潟???障??????';
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: ?<?若???≪?????鴻?????鴻???若????罩c????????障??????';
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??AKELANGID?????????<???c??????(卒鐔ハ?鐔?)鐔種舟鐓??鐔逸?
157     // MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
158     Buf, SizeOf(Buf), nil);
159     Session.ErrorString := Buf;
160     end;
161     end;
162    
163     {DOLIB?????????????障??
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('?脂??#39;))]);
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     FSession.FDMDM := Copy(body, Pos('"DMDM=', body) + 6, Length(body));
219     FSession.FDMDM := Copy(FSession.FDMDM, 1, Pos(';', FSession.FDMDM) - 1);
220     FSession.FMDMD := Copy(body, Pos('"MDMD=', body) + 6, Length(body));
221     FSession.FMDMD := Copy(FSession.FMDMD, 1, Pos(';', FSession.FMDMD) - 1);
222     end;
223     end;
224     InternetCloseHandle(hRequest);
225     end;
226     InternetCloseHandle(hConnect);
227     end;
228     InternetCloseHandle(hSession);
229     end;
230     end;
231     end.
232    

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