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.1 - (show annotations) (download) (as text)
Thu Jan 4 13:11:38 2007 UTC (17 years, 3 months ago) by h677
Branch: MAIN
CVS Tags: v1_56_0_715, v1_56_0_707, v1_56_0_705, v1_56_0_704, v1_56_0_703, v1_56_0_702, v1_56_0_701, v1_56_0_700, v1_57_0_723, v1_57_0_725, v1_57_0_726, v1_57_0_727, v1_57_0_720, v1_57_0_722, v1_57_0_728, v1_57_0_729, v1_57_0_719, v1_57_0_718, v1_56_0_716, v1_54_0_687, v1_56_0_710, v1_56_0_711, v1_56_1_717, v1_56_1_716, v1_54_0_688, v1_54_0_689, v1_55_0_692, v1_55_0_693, v1_55_0_696, v1_55_0_697, v1_55_0_694, v1_55_0_695, v1_54_1_691, v1_56_2_724, v1_56_2_722, v1_55_1_697, v1_56_0_714, v1_56_0_712, v1_56_0_713, v1_56_0_721, marged_bRESPOPUP, v1_56_0_706, v1_54_0_690, v1_56_0_709, v1_56_0_708, v1_56_0_699, v1_56_0_698
Branch point for: Bb56, Bb55, bRESPOPUP, bListSU, Bb54
File MIME type: text/x-pascal
移転した板のURLを検索する機能を追加

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 ini := TMemIniFile.Create(GikoSys.GetBoardFileName);
51 ini.ReadSections(sec);
52
53 CategoryComboBox.Clear;
54 CategoryComboBox.Items.BeginUpdate;
55 for i := 0 to sec.Count - 1 do begin
56 CategoryComboBox.Items.Add(sec[i]);
57 end;
58 CategoryComboBox.Items.EndUpdate;
59 CategoryComboBox.ItemIndex := 0;
60
61 ResultMemo.Lines.Clear;
62 end;
63
64 procedure TNewBoardURLForm.SearchButtonClick(Sender: TObject);
65 var
66 i : Integer;
67 value : string;
68 ResStream: TMemoryStream;
69 URLs : TStringList;
70 oldURLs : TStringList;
71 newURLs : TStringList;
72 oldURL, newURL : string;
73 TabURLs : TStringList;
74 begin
75 ResultMemo.Lines.Clear;
76 URLs := TStringList.Create;
77 Screen.Cursor := crHourGlass;
78 SearchButton.Enabled := False;
79 try
80 GetBoardURLs( URLs );
81 if URLs.Count > 0 then begin
82 ResStream := TMemoryStream.Create;
83 oldURLs := TStringList.Create;
84 newURLs := TStringList.Create;
85
86 try
87 TNewBoardDialog.InitHTTPClient(IdHTTP);
88 IdHTTP.Request.Referer := '';
89 IdHTTP.Request.AcceptEncoding := 'gzip';
90
91 IdHTTP.Request.CacheControl := 'no-cache';
92 IdHTTP.Request.CustomHeaders.Add('Pragma: no-cache');
93 IdHTTP.HandleRedirects := false;
94 for i := 0 to URLs.Count - 1 do begin
95 IdAntiFreeze.Active := true;
96 try
97 ResStream.Clear;
98 IdHTTP.Get(URLs[i], ResStream);
99 value := GikoSys.GzipDecompress(ResStream,
100 IdHTTP.Response.ContentEncoding);
101 newURL := GetRedirectURL(value);
102 if (newURL = '') then begin
103 newURL := IdHTTP.Response.Location;
104 end;
105 if (newURL <> '') then begin
106 oldURL := URLs[i];
107 ResultMemo.Lines.Add('URL:' + oldURL + ' -> ' + newURL);
108 if (newURL <> '') then begin
109 oldURLs.Add( oldURL );
110 newURLs.Add( newURL );
111 end;
112 end;
113 except
114 on E: Exception do begin
115 {$IFDEF DEBUG}
116 Writeln(IdHTTP.ResponseText);
117 {$ENDIF}
118 end;
119 end;
120 IdAntiFreeze.Active := false;
121 end;
122
123 if (newURLs.Count > 0) and (oldURLs.Count > 0) then begin
124 ReplaceURLs(oldURLs, newURLs);
125 GikoForm.FavoritesURLReplace(oldURLs, newURLs);
126 GikoForm.RoundListURLReplace(oldURLs, newURLs);
127 GikoForm.TabFileURLReplace(oldURLs, newURLs);
128 ResultMemo.Lines.Add('?????]?????????貼?邸?直???直??');
129
130 TabURLs := TStringList.Create;
131 try
132 GikoDM.GetTabURLs(TabURLs);
133 GikoForm.ReloadBBS;
134 GikoDM.OpenURLs(TabURLs);
135 finally
136 TabURLs.Free;
137 end;
138
139 end else begin
140 ResultMemo.Lines.Add('???]?直?????辿???? ???????邸???長?直??');
141 end;
142 finally
143 ResStream.Clear;
144 ResStream.Free;
145 newURLs.Free;
146 oldURLs.Free;
147 end;
148 end;
149 finally
150 URLs.Free;
151 SearchButton.Enabled := True;
152 Screen.Cursor := crDefault;
153 end;
154 end;
155 function TNewBoardURLForm.GetRedirectURL(const html: string): string;
156 const
157 HEADS = '<head>';
158 HEADE = '</head>';
159 SCRIPT = 'window.location.href="';
160 begin
161 Result := Copy(html, 1,
162 AnsiPos(HEADE, AnsiLowerCase(html)));
163 Result := Copy(Result,
164 AnsiPos(HEADS, AnsiLowerCase(Result)),
165 Length(Result));
166 if AnsiPos(SCRIPT, Result) > 0 then begin
167 Result := Copy(Result, AnsiPos(SCRIPT, Result) + Length(SCRIPT),
168 Length(Result));
169 Result := Copy(Result, 1, AnsiPos('"', Result) - 1);
170 end else begin
171 Result := '';
172 end;
173
174 end;
175 procedure TNewBoardURLForm.GetBoardURLs(urls : TStringList);
176 var
177 ini : TMemIniFile;
178 sec : string;
179 keys : TStringList;
180 i : Integer;
181 begin
182 urls.Clear;
183 urls.BeginUpdate;
184 if CategoryComboBox.ItemIndex <> -1 then begin
185 sec := CategoryComboBox.Items[CategoryComboBox.itemIndex];
186 keys := TStringList.Create;
187 try
188 ini := TMemIniFile.Create(GikoSys.GetBoardFileName);
189 ini.ReadSection(sec, keys);
190 for i := 0 to keys.Count - 1 do begin
191 urls.Add(ini.ReadString(sec, keys[i], ''));
192 end;
193 finally
194 keys.Free;
195 end;
196 end;
197 end;
198 procedure TNewBoardURLForm.ReplaceURLs(oldurls, newurls: TStringList);
199 var
200 txt : TStringList;
201 i : Integer;
202 begin
203 if oldurls.Count > 0 then begin
204 txt := TStringList.Create;
205 txt.LoadFromFile( GikoSys.GetBoardFileName );
206 try
207 for i := 0 to oldurls.Count - 1 do begin
208 MojuUtils.CustomStringReplace(txt, oldurls[i], newurls[i]);
209 end;
210 txt.SaveToFile( GikoSys.GetBoardFileName );
211 finally
212 txt.Free;
213 end;
214 end;
215 end;
216
217 procedure TNewBoardURLForm.IdHTTPRedirect(Sender: TObject;
218 var dest: String; var NumRedirect: Integer; var Handled: Boolean;
219 var VMethod: TIdHTTPMethod);
220 begin
221 {$IFDEF DEBUG}
222 ShowMessage(dest);
223 {$ENDIF}
224 end;
225
226 end.

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