Develop and Download Open Source Software

Browse CVS Repository

Annotation of /gikonavigoeson/gikonavi/NewBoardURL.pas

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


Revision 1.5 - (hide 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 h677 1.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 h677 1.2 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 h677 1.1
63 h677 1.2 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 h677 1.1 end;
74     end;
75 h677 1.3 //! ?????{?^???C?x???g
76 h677 1.1 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 h677 1.5 IdAntiFreeze.Active := true;
107 h677 1.1 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 h677 1.4 // ???_?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 h677 1.1 oldURL := URLs[i];
124 h677 1.4 if (oldURL <> newURL) then begin
125     ResultMemo.Lines.Add('URL:' + oldURL + ' -> ' + newURL);
126 h677 1.1 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 h677 1.5 IdAntiFreeze.Active := false;
139 h677 1.1 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 h677 1.2 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 h677 1.1 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