NewBoardURL.pas

   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 \90é\8c¾ }
  27     function GetRedirectURL(const html: string): string;
  28     procedure GetBoardURLs(urls : TStringList);
  29     procedure ReplaceURLs(oldurls, newurls: TStringList);
  30   public
  31     { Public \90é\8c¾ }
  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 //! \83R\83\93\83X\83g\83\89\83N\83^
  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 //! \8c\9f\8dõ\83{\83^\83\93\83C\83x\83\93\83g
  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                             // \83\8a\83_\83C\83\8c\83N\83g\82·\82ê\82Î\95K\82¸\88Ú\93]\82Æ\82Í\8cÀ\82ç\82È\82¢
 119                             // \83e\83\8c\83r\94Ô\91g\94Â\82È\82Ç\82Ì\91Î\8dô\8dÅ\8cã\82Ì'/'\82Ü\82Å\82ðURL\82Æ\82·\82é
 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('\94Â\88Ú\93]\90æ\8c\9f\8dõ\82ª\8a®\97¹\82µ\82Ü\82µ\82½');
 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('\88Ú\93]\82µ\82Ä\82¢\82é\94Â\82Í \82 \82è\82Ü\82¹\82ñ\82Å\82µ\82½');
 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.