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     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('\94Â\88Ú\93]\90æ\8c\9f\8dõ\82ª\8a®\97¹\82µ\82Ü\82µ\82½');
 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('\88Ú\93]\82µ\82Ä\82¢\82é\94Â\82Í \82 \82è\82Ü\82¹\82ñ\82Å\82µ\82½');
 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.