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 //! \83f\83X\83g\83\89\83N\83^
  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                 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                             oldURL := URLs[i];
 119                             ResultMemo.Lines.Add('URL:' + oldURL + ' -> ' + newURL);
 120                             if (newURL <> '') then begin
 121                                 oldURLs.Add( oldURL );
 122                                 newURLs.Add( newURL );
 123                             end;
 124                         end;
 125                     except
 126                         on E: Exception do begin
 127                             {$IFDEF DEBUG}
 128                             Writeln(IdHTTP.ResponseText);
 129                             {$ENDIF}
 130                         end;
 131                     end;
 132                     IdAntiFreeze.Active := false;
 133                 end;
 134
 135                 if (newURLs.Count > 0) and (oldURLs.Count > 0) then begin
 136                     ReplaceURLs(oldURLs, newURLs);
 137                     GikoForm.FavoritesURLReplace(oldURLs, newURLs);
 138                     GikoForm.RoundListURLReplace(oldURLs, newURLs);
 139                     GikoForm.TabFileURLReplace(oldURLs, newURLs);
 140                     ResultMemo.Lines.Add('\94Â\88Ú\93]\90æ\8c\9f\8dõ\82ª\8a®\97¹\82µ\82Ü\82µ\82½');
 141
 142                     TabURLs := TStringList.Create;
 143                     try
 144                         GikoDM.GetTabURLs(TabURLs);
 145                         GikoForm.ReloadBBS;
 146                         GikoDM.OpenURLs(TabURLs);
 147                     finally
 148                         TabURLs.Free;
 149                     end;
 150
 151                 end else begin
 152                     ResultMemo.Lines.Add('\88Ú\93]\82µ\82Ä\82¢\82é\94Â\82Í \82 \82è\82Ü\82¹\82ñ\82Å\82µ\82½');
 153                 end;
 154             finally
 155                 ResStream.Clear;
 156                 ResStream.Free;
 157                 newURLs.Free;
 158                 oldURLs.Free;
 159             end;
 160         end;
 161     finally
 162         URLs.Free;
 163         SearchButton.Enabled := True;
 164         Screen.Cursor := crDefault;
 165     end;
 166 end;
 167 function TNewBoardURLForm.GetRedirectURL(const html: string): string;
 168 const
 169     HEADS = '<head>';
 170     HEADE = '</head>';
 171     SCRIPT = 'window.location.href="';
 172 begin
 173     Result := Copy(html, 1,
 174         AnsiPos(HEADE, AnsiLowerCase(html)));
 175     Result := Copy(Result,
 176         AnsiPos(HEADS, AnsiLowerCase(Result)),
 177         Length(Result));
 178     if AnsiPos(SCRIPT, Result) > 0 then begin
 179         Result := Copy(Result, AnsiPos(SCRIPT, Result) + Length(SCRIPT),
 180             Length(Result));
 181         Result := Copy(Result, 1, AnsiPos('"', Result) - 1);
 182     end else begin
 183         Result := '';
 184     end;
 185
 186 end;
 187 procedure TNewBoardURLForm.GetBoardURLs(urls : TStringList);
 188 var
 189     ini : TMemIniFile;
 190     sec : string;
 191     keys : TStringList;
 192     i : Integer;
 193 begin
 194     urls.Clear;
 195     urls.BeginUpdate;
 196     if CategoryComboBox.ItemIndex <> -1 then begin
 197         sec := CategoryComboBox.Items[CategoryComboBox.itemIndex];
 198         keys := TStringList.Create;
 199         try
 200             ini := TMemIniFile.Create(GikoSys.GetBoardFileName);
 201             try
 202                 ini.ReadSection(sec, keys);
 203                 for i := 0 to keys.Count - 1 do begin
 204                     urls.Add(ini.ReadString(sec, keys[i], ''));
 205                 end;
 206             finally
 207                 ini.Free;
 208             end;
 209         finally
 210             keys.Free;
 211         end;
 212     end;
 213 end;
 214 procedure TNewBoardURLForm.ReplaceURLs(oldurls, newurls: TStringList);
 215 var
 216     txt : TStringList;
 217     i : Integer;
 218 begin
 219     if oldurls.Count > 0 then begin
 220         txt := TStringList.Create;
 221         txt.LoadFromFile( GikoSys.GetBoardFileName );
 222         try
 223             for i := 0 to oldurls.Count - 1 do begin
 224                 MojuUtils.CustomStringReplace(txt, oldurls[i], newurls[i]);
 225             end;
 226             txt.SaveToFile( GikoSys.GetBoardFileName );
 227         finally
 228             txt.Free;
 229         end;
 230     end;
 231 end;
 232
 233 procedure TNewBoardURLForm.IdHTTPRedirect(Sender: TObject;
 234   var dest: String; var NumRedirect: Integer; var Handled: Boolean;
 235   var VMethod: TIdHTTPMethod);
 236 begin
 237     {$IFDEF DEBUG}
 238     ShowMessage(dest);
 239     {$ENDIF}
 240 end;
 241
 242 end.