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.4 - (hide annotations) (download) (as text)
Mon Oct 13 11:11:19 2008 UTC (15 years, 6 months ago) by h677
Branch: MAIN
CVS Tags: v1_59_0_773, v1_59_0_775, v1_59_0_774, v1_59_0_777, v1_59_0_776, v1_59_0_778, v1_60_0_788, v1_60_0_781, v1_60_0_782, v1_60_0_784, v1_60_0_786, v1_60_0_787, v1_59_1_778, v1_60_0_780, v1_60_0_779, v1_60_0_783, v1_59_2_785
Branch point for: Bb59
Changes since 1.3: +7 -2 lines
File MIME type: text/x-pascal
テレビ番組欄板のようにリダイレクトでトップページに遷移する板対策

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     for i := 0 to URLs.Count - 1 do begin
107     IdAntiFreeze.Active := true;
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     IdAntiFreeze.Active := false;
138     end;
139    
140     if (newURLs.Count > 0) and (oldURLs.Count > 0) then begin
141     ReplaceURLs(oldURLs, newURLs);
142     GikoForm.FavoritesURLReplace(oldURLs, newURLs);
143     GikoForm.RoundListURLReplace(oldURLs, newURLs);
144     GikoForm.TabFileURLReplace(oldURLs, newURLs);
145     ResultMemo.Lines.Add('?????]?????????貼?邸?直???直??');
146    
147     TabURLs := TStringList.Create;
148     try
149     GikoDM.GetTabURLs(TabURLs);
150     GikoForm.ReloadBBS;
151     GikoDM.OpenURLs(TabURLs);
152     finally
153     TabURLs.Free;
154     end;
155    
156     end else begin
157     ResultMemo.Lines.Add('???]?直?????辿???? ???????邸???長?直??');
158     end;
159     finally
160     ResStream.Clear;
161     ResStream.Free;
162     newURLs.Free;
163     oldURLs.Free;
164     end;
165     end;
166     finally
167     URLs.Free;
168     SearchButton.Enabled := True;
169     Screen.Cursor := crDefault;
170     end;
171     end;
172     function TNewBoardURLForm.GetRedirectURL(const html: string): string;
173     const
174     HEADS = '<head>';
175     HEADE = '</head>';
176     SCRIPT = 'window.location.href="';
177     begin
178     Result := Copy(html, 1,
179     AnsiPos(HEADE, AnsiLowerCase(html)));
180     Result := Copy(Result,
181     AnsiPos(HEADS, AnsiLowerCase(Result)),
182     Length(Result));
183     if AnsiPos(SCRIPT, Result) > 0 then begin
184     Result := Copy(Result, AnsiPos(SCRIPT, Result) + Length(SCRIPT),
185     Length(Result));
186     Result := Copy(Result, 1, AnsiPos('"', Result) - 1);
187     end else begin
188     Result := '';
189     end;
190    
191     end;
192     procedure TNewBoardURLForm.GetBoardURLs(urls : TStringList);
193     var
194     ini : TMemIniFile;
195     sec : string;
196     keys : TStringList;
197     i : Integer;
198     begin
199     urls.Clear;
200     urls.BeginUpdate;
201     if CategoryComboBox.ItemIndex <> -1 then begin
202     sec := CategoryComboBox.Items[CategoryComboBox.itemIndex];
203     keys := TStringList.Create;
204     try
205     ini := TMemIniFile.Create(GikoSys.GetBoardFileName);
206 h677 1.2 try
207     ini.ReadSection(sec, keys);
208     for i := 0 to keys.Count - 1 do begin
209     urls.Add(ini.ReadString(sec, keys[i], ''));
210     end;
211     finally
212     ini.Free;
213 h677 1.1 end;
214     finally
215     keys.Free;
216     end;
217     end;
218     end;
219     procedure TNewBoardURLForm.ReplaceURLs(oldurls, newurls: TStringList);
220     var
221     txt : TStringList;
222     i : Integer;
223     begin
224     if oldurls.Count > 0 then begin
225     txt := TStringList.Create;
226     txt.LoadFromFile( GikoSys.GetBoardFileName );
227     try
228     for i := 0 to oldurls.Count - 1 do begin
229     MojuUtils.CustomStringReplace(txt, oldurls[i], newurls[i]);
230     end;
231     txt.SaveToFile( GikoSys.GetBoardFileName );
232     finally
233     txt.Free;
234     end;
235     end;
236     end;
237    
238     procedure TNewBoardURLForm.IdHTTPRedirect(Sender: TObject;
239     var dest: String; var NumRedirect: Integer; var Handled: Boolean;
240     var VMethod: TIdHTTPMethod);
241     begin
242     {$IFDEF DEBUG}
243     ShowMessage(dest);
244     {$ENDIF}
245     end;
246    
247     end.

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