fpbrowser: Adds a module for testing HTTP commands

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2792 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2013-09-16 11:07:57 +00:00
parent 628a8e6b46
commit e4baa63b89
7 changed files with 343 additions and 14 deletions
--- a/applications/fpbrowser/browsermodules.pas
+++ b/applications/fpbrowser/browsermodules.pas
@ -5,10 +5,13 @@ unit browsermodules;
 interface

 uses
-  Classes, SysUtils; 
+  Classes, SysUtils;

 type

+  TBrowserModuleUIElement = (bmueEnabledDisableMenu, bmueCommandsSubmenu);
+  TBrowserModuleUIElements = set of TBrowserModuleUIElement;
+
  { TBrowserModule }

  TBrowserModule = class
@ -16,7 +19,14 @@ type
    ShortDescription: string;
    Activated: Boolean;
    constructor Create; virtual;
+    //
+    function GetModuleUIElements(): TBrowserModuleUIElements; virtual;
+    // For active/disabled modules
    function HandleOnPageLoad(AInput: string; out AOutput: string): Boolean; virtual;
+    // For expansions
+    function GetCommandCount: Integer; virtual;
+    function GetCommandName(AID: Integer): string; virtual;
+    procedure ExecuteCommand(AID: Integer); virtual;
  end;

 procedure RegisterBrowserModule(AModule: TBrowserModule);
@ -52,12 +62,32 @@ begin

 end;

+function TBrowserModule.GetModuleUIElements: TBrowserModuleUIElements;
+begin
+  Result := [bmueEnabledDisableMenu];
+end;
+
 function TBrowserModule.HandleOnPageLoad(AInput: string; out AOutput: string): Boolean;
 begin
  AOutput := '';
  Result := False;
 end;

+function TBrowserModule.GetCommandCount: Integer;
+begin
+  Result := 0;
+end;
+
+function TBrowserModule.GetCommandName(AID: Integer): string;
+begin
+  Result := '';
+end;
+
+procedure TBrowserModule.ExecuteCommand(AID: Integer);
+begin
+
+end;
+
 initialization
  gBrowserModules := TList.Create;
 finalization
--- a/applications/fpbrowser/fpbrowser.dpr
+++ b/applications/fpbrowser/fpbrowser.dpr
@ -25,12 +25,14 @@ uses
 {$ifdef FPBROWSER_TURBOPOWERIPRO}
  viewer_ipro,
 {$endif}
-  browserviewer, mod_braille, browserconstants, dlgconfig, browserconfig;
+  browserviewer, mod_braille, browserconstants, dlgconfig, browserconfig,
+  mod_testhttp;

 begin
  Application.Initialize;
  Application.CreateForm(TformBrowser, formBrowser);
  Application.CreateForm(TSubmitForm, SubmitForm);
  Application.CreateForm(TformConfig, formConfig);
+  Application.CreateForm(TformTestHttp, formTestHttp);
  Application.Run;
 end.
--- a/applications/fpbrowser/fpbrowser.lpi
+++ b/applications/fpbrowser/fpbrowser.lpi
@ -92,7 +92,7 @@
        <PackageName Value="LCL"/>
      </Item5>
    </RequiredPackages>
-    <Units Count="14">
+    <Units Count="15">
      <Unit0>
        <Filename Value="fpbrowser.dpr"/>
        <IsPartOfProject Value="True"/>
@ -174,6 +174,13 @@
        <IsPartOfProject Value="True"/>
        <UnitName Value="browserconfig"/>
      </Unit13>
+      <Unit14>
+        <Filename Value="mod_testhttp.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="formTestHttp"/>
+        <ResourceBaseClass Value="Form"/>
+        <UnitName Value="mod_testhttp"/>
+      </Unit14>
    </Units>
  </ProjectOptions>
  <CompilerOptions>
--- a/applications/fpbrowser/mainform.pas
+++ b/applications/fpbrowser/mainform.pas
@ -123,6 +123,7 @@ type
    procedure InitializeForm();
    procedure UpdateModulesMenu();
    procedure HandleModuleMenuItemClick(Sender: TObject);
+    procedure HandleModuleCommandMenuItemClick(Sender: TObject);
    function  GetCurrentPageLoader: TPageLoader;
    procedure HandlePageChanged(Sender: TObject);
  public
@ -310,9 +311,10 @@ end;

 procedure TformBrowser.UpdateModulesMenu;
 var
-  lItem: TMenuItem;
+  lItem, lSubItem: TMenuItem;
  lModule: TBrowserModule;
-  i: Integer;
+  i, j: Integer;
+  lModuleUIElements: TBrowserModuleUIElements;
 begin
  // First remove any existing modules
  menuToolsModules.Clear;
@ -320,12 +322,36 @@ begin
  // Now add all modules and their state
  for i := 0 to GetBrowserModuleCount() - 1 do
  begin
-    lModule := GetBrowserModule(0);
-    lItem := TMenuItem.Create(nil);
-    lItem.Caption := lModule.ShortDescription;
-    lItem.Checked := lModule.Activated;
-    lItem.OnClick := HandleModuleMenuItemClick;
-    menuToolsModules.Add(lItem);
+    lModule := GetBrowserModule(i);
+
+    lModuleUIElements := lModule.GetModuleUIElements();
+
+    // ----
+    if bmueEnabledDisableMenu in lModuleUIElements then
+    begin
+      lItem := TMenuItem.Create(nil);
+      lItem.Caption := lModule.ShortDescription;
+      lItem.Checked := lModule.Activated;
+      lItem.OnClick := HandleModuleMenuItemClick;
+      menuToolsModules.Add(lItem);
+    end;
+    // ----
+    if bmueCommandsSubmenu in lModuleUIElements then
+    begin
+      lItem := TMenuItem.Create(nil);
+      lItem.Caption := Format('Commands from module %s', [lModule.ShortDescription]);
+
+      for j := 0 to lModule.GetCommandCount()-1 do
+      begin
+        lSubItem := TMenuItem.Create(nil);
+        lSubItem.Caption := lModule.GetCommandName(j);
+        lSubItem.OnClick := HandleModuleCommandMenuItemClick;
+        lSubItem.Tag := PtrInt(lModule);
+        lItem.Add(lSubItem);
+      end;
+
+      menuToolsModules.Add(lItem);
+    end;
  end;
 end;

@ -344,6 +370,18 @@ begin
  lModule.Activated := lNewState;
 end;

+procedure TformBrowser.HandleModuleCommandMenuItemClick(Sender: TObject);
+var
+  lItem: TMenuItem;
+  lCommandNum: Integer;
+  lModule: TBrowserModule;
+begin
+  lItem := Sender as TMenuItem;
+  lModule := TBrowserModule(lItem.Tag);
+  lCommandNum := lItem.Parent.IndexOf(lItem);
+  lModule.ExecuteCommand(lCommandNum);
+end;
+
 function TformBrowser.GetCurrentPageLoader: TPageLoader;
 var
  lViewer: TBrowserViewer;
@ -920,13 +958,13 @@ begin
  Pt1 := Viewer.ScreenToClient(Pt);
  TitleStr := Viewer.TitleAttr;
  if (TitleStr = '') or not PtInRect(Viewer.ClientRect, Pt1)then
-    begin
+  begin
    OldTitle := '';
    CloseAll;
    Exit;
-    end;
+  end;
  if TitleStr <> OldTitle then
-    begin
+  begin
    TimerCount := 0;
    OldTitle := TitleStr;
    HintWindow.ReleaseHandle;
--- a/applications/fpbrowser/mod_testhttp.lfm
+++ b/applications/fpbrowser/mod_testhttp.lfm
@ -0,0 +1,91 @@
+object formTestHttp: TformTestHttp
+  Left = 241
+  Height = 401
+  Top = 145
+  Width = 462
+  Caption = 'formTestHttp'
+  ClientHeight = 401
+  ClientWidth = 462
+  LCLVersion = '1.1'
+  object buttonVideoHEADTest: TButton
+    Left = 8
+    Height = 25
+    Top = 88
+    Width = 195
+    Caption = 'Test HTTP HEAD to Video'
+    OnClick = buttonVideoHEADTestClick
+    TabOrder = 0
+  end
+  object memoTestHttpDebug: TMemo
+    Left = 8
+    Height = 274
+    Top = 120
+    Width = 448
+    Lines.Strings = (
+      'memoTestHttpDebug'
+    )
+    ScrollBars = ssVertical
+    TabOrder = 1
+  end
+  object Label1: TLabel
+    Left = 10
+    Height = 15
+    Top = 11
+    Width = 24
+    Caption = 'URL:'
+    ParentColor = False
+  end
+  object comboURL: TComboBox
+    Left = 40
+    Height = 23
+    Top = 8
+    Width = 416
+    ItemHeight = 15
+    ItemIndex = 0
+    Items.Strings = (
+      'http://file31.content-video.ru/Volume18/mp4/2013/08/20/2013_08_20_RIAMERCEDESmix1_mwyitzcc.0il.mp4'
+    )
+    TabOrder = 2
+    Text = 'http://file31.content-video.ru/Volume18/mp4/2013/08/20/2013_08_20_RIAMERCEDESmix1_mwyitzcc.0il.mp4'
+  end
+  object Label2: TLabel
+    Left = 10
+    Height = 15
+    Top = 36
+    Width = 61
+    Caption = 'User Agent:'
+    ParentColor = False
+  end
+  object comboUserAgent: TComboBox
+    Left = 80
+    Height = 23
+    Top = 32
+    Width = 376
+    ItemHeight = 15
+    ItemIndex = 3
+    Items.Strings = (
+      'FPBrowser/1.0 (Mobile; U; en-GB)'
+      'Opera/9.80 (iPhone; Opera Mini/6.5.1.23995/27.1227; U; pt) Presto/2.8.119 Version/11.10'
+      'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7.12) Gecko/20060101 Firefox/1.0.8'
+      'Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/29.0.1547.66 Safari/537.36'
+    )
+    TabOrder = 3
+    Text = 'Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/29.0.1547.66 Safari/537.36'
+  end
+  object Label3: TLabel
+    Left = 10
+    Height = 15
+    Top = 64
+    Width = 32
+    Caption = 'Proxy:'
+    ParentColor = False
+  end
+  object editProxy: TEdit
+    Left = 81
+    Height = 23
+    Top = 58
+    Width = 168
+    TabOrder = 4
+    Text = 'editProxy'
+  end
+end
--- a/applications/fpbrowser/mod_testhttp.lrs
+++ b/applications/fpbrowser/mod_testhttp.lrs
@ -0,0 +1,32 @@
+{ This is an automatically generated lazarus resource file }
+
+LazarusResources.Add('TformTestHttp','FORMDATA',[
+  'TPF0'#13'TformTestHttp'#12'formTestHttp'#4'Left'#3#241#0#6'Height'#3#145#1#3
+  +'Top'#3#145#0#5'Width'#3#206#1#7'Caption'#6#12'formTestHttp'#12'ClientHeight'
+  +#3#145#1#11'ClientWidth'#3#206#1#10'LCLVersion'#6#3'1.1'#0#7'TButton'#19'but'
+  +'tonVideoHEADTest'#4'Left'#2#8#6'Height'#2#25#3'Top'#2'X'#5'Width'#3#195#0#7
+  +'Caption'#6#23'Test HTTP HEAD to Video'#7'OnClick'#7#24'buttonVideoHEADTestC'
+  +'lick'#8'TabOrder'#2#0#0#0#5'TMemo'#17'memoTestHttpDebug'#4'Left'#2#8#6'Heig'
+  +'ht'#3#18#1#3'Top'#2'x'#5'Width'#3#192#1#13'Lines.Strings'#1#6#17'memoTestHt'
+  +'tpDebug'#0#10'ScrollBars'#7#10'ssVertical'#8'TabOrder'#2#1#0#0#6'TLabel'#6
+  +'Label1'#4'Left'#2#10#6'Height'#2#15#3'Top'#2#11#5'Width'#2#24#7'Caption'#6#4
+  +'URL:'#11'ParentColor'#8#0#0#9'TComboBox'#8'comboURL'#4'Left'#2'('#6'Height'
+  +#2#23#3'Top'#2#8#5'Width'#3#160#1#10'ItemHeight'#2#15#9'ItemIndex'#2#0#13'It'
+  +'ems.Strings'#1#6'bhttp://file31.content-video.ru/Volume18/mp4/2013/08/20/20'
+  +'13_08_20_RIAMERCEDESmix1_mwyitzcc.0il.mp4'#0#8'TabOrder'#2#2#4'Text'#6'bhtt'
+  +'p://file31.content-video.ru/Volume18/mp4/2013/08/20/2013_08_20_RIAMERCEDESm'
+  +'ix1_mwyitzcc.0il.mp4'#0#0#6'TLabel'#6'Label2'#4'Left'#2#10#6'Height'#2#15#3
+  +'Top'#2'$'#5'Width'#2'='#7'Caption'#6#11'User Agent:'#11'ParentColor'#8#0#0#9
+  +'TComboBox'#14'comboUserAgent'#4'Left'#2'P'#6'Height'#2#23#3'Top'#2' '#5'Wid'
+  +'th'#3'x'#1#10'ItemHeight'#2#15#9'ItemIndex'#2#3#13'Items.Strings'#1#6' FPBr'
+  +'owser/1.0 (Mobile; U; en-GB)'#6'WOpera/9.80 (iPhone; Opera Mini/6.5.1.23995'
+  +'/27.1227; U; pt) Presto/2.8.119 Version/11.10'#6'OMozilla/5.0 (X11; U; Linu'
+  +'x i686; en-US; rv:1.7.12) Gecko/20060101 Firefox/1.0.8'#6'lMozilla/5.0 (Win'
+  +'dows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/29.0.1547'
+  +'.66 Safari/537.36'#0#8'TabOrder'#2#3#4'Text'#6'lMozilla/5.0 (Windows NT 6.1'
+  +'; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/29.0.1547.66 Safari/'
+  +'537.36'#0#0#6'TLabel'#6'Label3'#4'Left'#2#10#6'Height'#2#15#3'Top'#2'@'#5'W'
+  +'idth'#2' '#7'Caption'#6#6'Proxy:'#11'ParentColor'#8#0#0#5'TEdit'#9'editProx'
+  +'y'#4'Left'#2'Q'#6'Height'#2#23#3'Top'#2':'#5'Width'#3#168#0#8'TabOrder'#2#4
+  +#4'Text'#6#9'editProxy'#0#0#0
+]);
--- a/applications/fpbrowser/mod_testhttp.pas
+++ b/applications/fpbrowser/mod_testhttp.pas
@ -0,0 +1,129 @@
+unit mod_testhttp;
+
+{$mode delphi}
+
+interface
+
+uses
+  Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
+  StdCtrls,
+  browsermodules, browserconfig;
+
+type
+
+  { TformTestHttp }
+
+  TformTestHttp = class(TForm)
+    buttonVideoHEADTest: TButton;
+    comboUserAgent: TComboBox;
+    comboURL: TComboBox;
+    editProxy: TEdit;
+    Label1: TLabel;
+    Label2: TLabel;
+    Label3: TLabel;
+    memoTestHttpDebug: TMemo;
+    procedure buttonVideoHEADTestClick(Sender: TObject);
+  private
+    { private declarations }
+  public
+    { public declarations }
+  end;
+
+  { TTestHttpBrowserModule }
+
+  TTestHttpBrowserModule = class(TBrowserModule)
+  public
+    constructor Create; override;
+    function GetModuleUIElements(): TBrowserModuleUIElements; override;
+    // For expansions
+    function GetCommandCount: Integer; override;
+    function GetCommandName(AID: Integer): string; override;
+    procedure ExecuteCommand(AID: Integer); override;
+  end;
+
+var
+  formTestHttp: TformTestHttp;
+
+implementation
+
+uses httpsend;
+
+{ TformTestHttp }
+
+procedure TformTestHttp.buttonVideoHEADTestClick(Sender: TObject);
+var
+  Client: THttpSend;
+  ContentsList: TStringList;
+  AURL: string;
+begin
+  AURL := comboURL.Text;
+
+  Client := THttpSend.Create;
+  ContentsList := TStringList.Create;
+  try
+    Client.Headers.Add('Accept:	text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8');
+    Client.Headers.Add('Accept-Language:	en-gb,en;q=0.5');
+    //Client.Headers.Add('Accept-Encoding:	gzip,deflate');
+    Client.Headers.Add('Accept-Charset:	utf-8;q=0.7,*;q=0.7'); // ISO-8859-1,
+    Client.UserAgent := comboUserAgent.Text;
+    if editProxy.Text <> '' then
+    begin
+      Client.ProxyHost := editProxy.Text;
+      Client.ProxyPort := '80';
+    end;
+
+    Client.HttpMethod('GET', AURL);
+
+//    Client.Headers;
+
+    Client.Document.Position := 0;
+    ContentsList.Clear();
+    ContentsList.LoadFromStream(Client.Document);
+    memoTestHttpDebug.Clear();
+    memoTestHttpDebug.Lines.Add(Format('Loading page: %s', [AURL]));
+    memoTestHttpDebug.Lines.Add('');
+    memoTestHttpDebug.Lines.Add('HTTP Headers:');
+    memoTestHttpDebug.Lines.Add('');
+    memoTestHttpDebug.Lines.AddStrings(Client.Headers);
+    memoTestHttpDebug.Lines.Add('');
+  finally
+    ContentsList.Free;
+    Client.Free;
+  end;
+end;
+
+{ TTestHttpBrowserModule }
+
+constructor TTestHttpBrowserModule.Create;
+begin
+  inherited Create;
+
+  ShortDescription := 'HTTP Test';
+end;
+
+function TTestHttpBrowserModule.GetModuleUIElements: TBrowserModuleUIElements;
+begin
+  Result := [bmueCommandsSubmenu];
+end;
+
+function TTestHttpBrowserModule.GetCommandCount: Integer;
+begin
+  Result := 1;
+end;
+
+function TTestHttpBrowserModule.GetCommandName(AID: Integer): string;
+begin
+  Result := 'HTTP Test Dialog';
+end;
+
+procedure TTestHttpBrowserModule.ExecuteCommand(AID: Integer);
+begin
+  formTestHttp.ShowModal();
+end;
+
+initialization
+  {$I mod_testhttp.lrs}
+
+  RegisterBrowserModule(TTestHttpBrowserModule.Create());
+end.
+