Develop and Download Open Source Software

Browse CVS Repository

Contents of /gikonavigoeson/gikonavi/NewBoardURL.pas

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


Revision 1.5 - (show annotations) (download) (as text)
Sat Apr 18 04:28:21 2009 UTC (15 years ago) by h677
Branch: MAIN
CVS Tags: v1_63_1_819, v1_62_0_812, v1_60_0_789, v1_61_0_796, v1_61_0_797, v1_61_0_795, v1_61_0_798, v1_61_0_799, v1_63_0_818, v1_63_0_817, v1_63_0_816, v1_63_0_815, v1_62_0_805, v1_62_0_804, v1_62_0_807, v1_62_0_806, v1_62_0_803, v1_62_0_802, v1_62_0_809, v1_62_0_810, v1_62_0_811, v1_60_1_793, v1_62_1_813, v1_61_0_800, v1_60_0_793, v1_60_0_792, v1_60_0_791, v1_60_0_790, v1_60_2_794, v1_61_1_801, HEAD
Branch point for: Bb62, Bb63, Bb60, Bb61
Changes since 1.4: +2 -3 lines
File MIME type: text/x-pascal
IdAntiFreezeの呼び出しをループの外に追い出した。

1 unit NewBoardURL;
2
3 interface
4
5 uses
6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
7 Dialogs, IdAntiFreezeBase, IdAntiFreeze, IdBaseComponent, IdComponent,
8 IdTCPConnection, IdTCPClient, IdHTTP, StdCtrls,
9 BoardGroup;
10
11 type
12 TNewBoardURLForm = class(TForm)
13 CategoryComboBox: TComboBox;
14 CategoryLabel: TLabel;
15 IdHTTP: TIdHTTP;
16 IdAntiFreeze: TIdAntiFreeze;
17 SearchButton: TButton;
18 ResultMemo: TMemo;
19 CloseButton: TButton;
20 procedure FormCreate(Sender: TObject);
21 procedure SearchButtonClick(Sender: TObject);
22 procedure IdHTTPRedirect(Sender: TObject; var dest: String;
23 var NumRedirect: Integer; var Handled: Boolean;
24 var VMethod: TIdHTTPMethod);
25 private
26 { Private ?辿?転 }
27 function GetRedirectURL(const html: string): string;
28 procedure GetBoardURLs(urls : TStringList);
29 procedure ReplaceURLs(oldurls, newurls: TStringList);
30 public
31 { Public ?辿?転 }
32 end;
33
34 var
35 NewBoardURLForm: TNewBoardURLForm;
36
37 implementation
38
39 uses
40 GikoSystem, NewBoard, Giko, IniFiles, MojuUtils, GikoDataModule;
41 {$R *.dfm}
42 //! ?R???X?g???N?^
43 procedure TNewBoardURLForm.FormCreate(Sender: TObject);
44 var
45 i : Integer;
46 ini : TMemIniFile;
47 sec : TStringList;
48 begin
49 sec := TStringList.Create;
50 try
51 ini := TMemIniFile.Create(GikoSys.GetBoardFileName);
52 try
53 ini.ReadSections(sec);
54
55 CategoryComboBox.Clear;
56 CategoryComboBox.Items.BeginUpdate;
57 for i := 0 to sec.Count - 1 do begin
58 CategoryComboBox.Items.Add(sec[i]);
59 end;
60 CategoryComboBox.Items.EndUpdate;
61 CategoryComboBox.ItemIndex := 0;
62
63 ResultMemo.Lines.Clear;
64 finally
65 if ini <> nil then begin
66 ini.Free;
67 end;
68 end;
69 finally
70 if sec <> nil then begin
71 sec.Free;
72 end;
73 end;
74 end;
75 //! ?????{?^???C?x???g
76 procedure TNewBoardURLForm.SearchButtonClick(Sender: TObject);
77 var
78 i : Integer;
79 value : string;
80 ResStream: TMemoryStream;
81 URLs : TStringList;
82 oldURLs : TStringList;
83 newURLs : TStringList;
84 oldURL, newURL : string;
85 TabURLs : TStringList;
86 begin
87 ResultMemo.Lines.Clear;
88 URLs := TStringList.Create;
89 Screen.Cursor := crHourGlass;
90 SearchButton.Enabled := False;
91 try
92 GetBoardURLs( URLs );
93 if URLs.Count > 0 then begin
94 ResStream := TMemoryStream.Create;
95 oldURLs := TStringList.Create;
96 newURLs := TStringList.Create;
97
98 try
99 TNewBoardDialog.InitHTTPClient(IdHTTP);
100 IdHTTP.Request.Referer := '';
101 IdHTTP.Request.AcceptEncoding := 'gzip';
102
103 IdHTTP.Request.CacheControl := 'no-cache';
104 IdHTTP.Request.CustomHeaders.Add('Pragma: no-cache');
105 IdHTTP.HandleRedirects := false;
106 IdAntiFreeze.Active := true;
107 for i := 0 to URLs.Count - 1 do begin
108 try
109 ResStream.Clear;
110 IdHTTP.Get(URLs[i], ResStream);
111 value := GikoSys.GzipDecompress(ResStream,
112 IdHTTP.Response.ContentEncoding);
113 newURL := GetRedirectURL(value);
114 if (newURL = '') then begin
115 newURL := IdHTTP.Response.Location;
116 end;
117 if (newURL <> '') then begin
118 // ???_?C???N?g???????K?存???]???????巽????
119 // ?e???r???g???????????担?長????'/'???長??URL?????辿
120 if (Length(newURL) <> LastDelimiter('/', newURL)) then begin
121 newURL := Copy(newURL, 1, LastDelimiter('/', newURL));
122 end;
123 oldURL := URLs[i];
124 if (oldURL <> newURL) then begin
125 ResultMemo.Lines.Add('URL:' + oldURL + ' -> ' + newURL);
126 oldURLs.Add( oldURL );
127 newURLs.Add( newURL );
128 end;
129 end;
130 except
131 on E: Exception do begin
132 {$IFDEF DEBUG}
133 Writeln(IdHTTP.ResponseText);
134 {$ENDIF}
135 end;
136 end;
137 end;
138 IdAntiFreeze.Active := false;
139 if (newURLs.Count > 0) and (oldURLs.Count > 0) then begin
140 ReplaceURLs(oldURLs, newURLs);
141 GikoForm.FavoritesURLReplace(oldURLs, newURLs);
142 GikoForm.RoundListURLReplace(oldURLs, newURLs);
143 GikoForm.TabFileURLReplace(oldURLs, newURLs);
144 ResultMemo.Lines.Add('?????]?????????貼?邸?直???直??');
145
146 TabURLs := TStringList.Create;
147 try
148 GikoDM.GetTabURLs(TabURLs);
149 GikoForm.ReloadBBS;
150 GikoDM.OpenURLs(TabURLs);
151 finally
152 TabURLs.Free;
153 end;
154
155 end else begin
156 ResultMemo.Lines.Add('???]?直?????辿???? ???????邸???長?直??');
157 end;
158 finally
159 ResStream.Clear;
160 ResStream.Free;
161 newURLs.Free;
162 oldURLs.Free;
163 end;
164 end;
165 finally
166 URLs.Free;
167 SearchButton.Enabled := True;
168 Screen.Cursor := crDefault;
169 end;
170 end;
171 function TNewBoardURLForm.GetRedirectURL(const html: string): string;
172 const
173 HEADS = '<head>';
174 HEADE = '</head>';
175 SCRIPT = 'window.location.href="';
176 begin
177 Result := Copy(html, 1,
178 AnsiPos(HEADE, AnsiLowerCase(html)));
179 Result := Copy(Result,
180 AnsiPos(HEADS, AnsiLowerCase(Result)),
181 Length(Result));
182 if AnsiPos(SCRIPT, Result) > 0 then begin
183 Result := Copy(Result, AnsiPos(SCRIPT, Result) + Length(SCRIPT),
184 Length(Result));
185 Result := Copy(Result, 1, AnsiPos('"', Result) - 1);
186 end else begin
187 Result := '';
188 end;
189
190 end;
191 procedure TNewBoardURLForm.GetBoardURLs(urls : TStringList);
192 var
193 ini : TMemIniFile;
194 sec : string;
195 keys : TStringList;
196 i : Integer;
197 begin
198 urls.Clear;
199 urls.BeginUpdate;
200 if CategoryComboBox.ItemIndex <> -1 then begin
201 sec := CategoryComboBox.Items[CategoryComboBox.itemIndex];
202 keys := TStringList.Create;
203 try
204 ini := TMemIniFile.Create(GikoSys.GetBoardFileName);
205 try
206 ini.ReadSection(sec, keys);
207 for i := 0 to keys.Count - 1 do begin
208 urls.Add(ini.ReadString(sec, keys[i], ''));
209 end;
210 finally
211 ini.Free;
212 end;
213 finally
214 keys.Free;
215 end;
216 end;
217 end;
218 procedure TNewBoardURLForm.ReplaceURLs(oldurls, newurls: TStringList);
219 var
220 txt : TStringList;
221 i : Integer;
222 begin
223 if oldurls.Count > 0 then begin
224 txt := TStringList.Create;
225 txt.LoadFromFile( GikoSys.GetBoardFileName );
226 try
227 for i := 0 to oldurls.Count - 1 do begin
228 MojuUtils.CustomStringReplace(txt, oldurls[i], newurls[i]);
229 end;
230 txt.SaveToFile( GikoSys.GetBoardFileName );
231 finally
232 txt.Free;
233 end;
234 end;
235 end;
236
237 procedure TNewBoardURLForm.IdHTTPRedirect(Sender: TObject;
238 var dest: String; var NumRedirect: Integer; var Handled: Boolean;
239 var VMethod: TIdHTTPMethod);
240 begin
241 {$IFDEF DEBUG}
242 ShowMessage(dest);
243 {$ENDIF}
244 end;
245
246 end.

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