Added webkit 3 example (gtk3)

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2499 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2012-08-27 04:02:15 +00:00
parent 82be41c270
commit 73e98925b3
2 changed files with 258 additions and 0 deletions
--- a/bindings/gtk3/examples/webkit/webkittest.lpi
+++ b/bindings/gtk3/examples/webkit/webkittest.lpi
@@ -0,0 +1,78 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="webkittest"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="Gtk3Pkg"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="webkittest.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="webkittest"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="webkittest"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Other>
+      <CompilerMessages>
+        <MsgFileName Value=""/>
+      </CompilerMessages>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>
--- a/bindings/gtk3/examples/webkit/webkittest.lpr
+++ b/bindings/gtk3/examples/webkit/webkittest.lpr
@@ -0,0 +1,180 @@
+program GtkLauncher;
+
+{$mode objfpc}{$H+}
+
+{ This is a FPC port/modification of the original source from:
+  http://trac.webkit.org/browser/trunk/WebKitTools/GtkLauncher/main.c
+
+  Found @ http://freepascal-bits.blogspot.com/2009/10/webkit-experimenting.html
+
+  - Tested on Linux only.
+  - Depends on the libwebkit[-dev] package (which is not installed by default
+    at least on Ubuntu).
+  - You must include the protocol specifier when entering an uri in the address
+    edit box, eg. 'http://google.com' and not just 'google.com' as you can
+    in most real browsers.
+
+/*
+ * Copyright (C) 2006, 2007 Apple Inc.
+ * Copyright (C) 2007 Alp Toker <alp@atoker.com>
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ *    notice, this list of conditions and the following disclaimer in the
+ *    documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY APPLE COMPUTER, INC. ``AS IS'' AND ANY
+ * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+ * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL APPLE COMPUTER, INC. OR
+ * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+ * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY
+ * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+}
+
+uses
+  gtk3, glib2, gobject2, math, webkit3;
+
+var
+  load_progress: gint = 0;
+  main_statusbar: PGtkStatusbar = nil;
+  main_title: pgchar = nil;
+  main_window: PGtkWidget = nil;
+  status_context_id: guint = 0;
+  uri_entry: PGtkWidget = nil;
+  web_view: PWebKitWebView = nil;
+
+procedure activate_uri_entry_cb(entry: PGtkWidget; data: gpointer); cdecl;
+var uri: Pgchar;
+begin
+  uri := PGtkEntry(entry)^.get_text;
+  assert(assigned(uri));
+  web_view^.load_uri(uri);
+  //web_view_open(web_view, uri);
+end;
+
+procedure update_title (window: PGtkWindow);
+var
+  string_: PGString;
+  title: Pgchar;
+begin
+  string_ := g_string_new(main_title);
+  g_string_append(string_, ' - FPC WebKit/Gtk Launcher');
+  if load_progress < 100 then
+    g_string_append_printf(string_, ' (%d%%)', [load_progress]);
+  title := g_string_free(string_, false);
+  gtk_window_set_title(window, title);
+  g_free(title);
+end;
+
+procedure link_hover_cb(page: PWebKitWebView; const title: pgchar; const link: pgchar; data: gpointer); cdecl;
+begin
+  gtk_statusbar_pop(main_statusbar, status_context_id);
+  if assigned(link) then
+    gtk_statusbar_push(main_statusbar, status_context_id, link);
+end;
+
+procedure title_change_cb(web_view: PWebKitWebView; web_frame: PWebKitWebFrame; const title: pgchar; data: gpointer); cdecl;
+begin
+  if assigned(main_title) then
+    g_free(main_title);
+  main_title := g_strdup(title);
+  update_title(PGtkWindow(main_window));
+end;
+
+procedure progress_change_cb(page: PWebKitWebView; progress: gint; data: gpointer); cdecl;
+begin
+  load_progress := progress;
+  update_title(PGtkWindow(main_window));
+end;
+
+procedure destroy_cb(widget: pGtkWidget; data: gpointer); cdecl;
+begin
+  gtk_main_quit;
+end;
+
+procedure go_back_cb(widget: PGtkWidget; data: gpointer); cdecl;
+begin
+  web_view^.go_back;
+end;
+
+procedure go_forward_cb(widget: PGtkWidget; data: gpointer); cdecl;
+begin
+  web_view^.go_forward;
+end;
+
+function create_browser: PGtkWidget;
+begin
+  result := gtk_scrolled_window_new(nil, nil);
+  gtk_scrolled_window_set_policy(PGtkScrolledWindow(result), GTK_POLICY_AUTOMATIC, GTK_POLICY_AUTOMATIC);
+
+  web_view := TWebKitWebView.new;
+  PGtkContainer(result)^.add(web_view);
+  g_signal_connect_data(web_view, 'title-changed', TGCallback(@title_change_cb), web_view, nil, 0);
+  g_signal_connect_data(web_view, 'load-progress-changed', TGCallback(@progress_change_cb), web_view, nil, 0);
+  g_signal_connect_data(web_view, 'hovering-over-link', TGCallback(@link_hover_cb), web_view, nil, 0);
+end;
+
+function create_statusbar: PGtkWidget;
+begin
+  main_statusbar := TGtkStatusbar.new;
+  status_context_id := gtk_statusbar_get_context_id(main_statusbar, 'Link Hover');
+  result := PGtkWidget(main_statusbar);
+end;
+
+function create_toolbar: PGtkWidget;
+var item: PGtkToolItem;
+begin
+  result := gtk_toolbar_new;
+  gtk_orientable_set_orientation(PGtkOrientable(result), GTK_ORIENTATION_HORIZONTAL);
+  gtk_toolbar_set_style(PGtkToolbar(result), GTK_TOOLBAR_BOTH_HORIZ);
+  item := gtk_tool_button_new_from_stock(STOCK_GO_BACK);
+  g_signal_connect_data(PGObject(item), 'clicked', TGCallback(@go_back_cb), nil, nil, 0);
+  gtk_toolbar_insert(PGtkToolbar(result), item, -1);
+  item := gtk_tool_button_new_from_stock(STOCK_GO_FORWARD);
+  g_signal_connect_data(PGObject(item), 'clicked', TGCallback(@go_forward_cb), nil, nil, 0);
+  gtk_toolbar_insert(PGtkToolbar(result), item, -1);
+  item := gtk_tool_item_new;
+  gtk_tool_item_set_expand(item, true);
+  uri_entry := gtk_entry_new;
+  gtk_container_add(PGtkContainer(item), uri_entry);
+  g_signal_connect_data(PGObject(uri_entry), 'activate', TGCallback(@activate_uri_entry_cb), nil, nil, 0);
+  gtk_toolbar_insert(PGtkToolbar(result), item, -1);
+  item := gtk_tool_button_new_from_stock(STOCK_OK);
+  g_signal_connect_object(PGObject(item), 'clicked', TGCallback(@activate_uri_entry_cb), gpointer(uri_entry), G_CONNECT_SWAPPED);
+  gtk_toolbar_insert(PGtkToolbar(result), item, -1);
+end;
+
+function create_window: PGtkWidget;
+begin
+  result := gtk_window_new(GTK_WINDOW_TOPLEVEL);
+  gtk_window_set_default_size(PGtkWindow(result), 800, 600);
+  gtk_widget_set_name(result, 'FPC GtkLauncher');
+  g_signal_connect_data(result, 'destroy', TGCallback(@destroy_cb), nil, nil, 0);
+end;
+
+var vbox: PGtkWidget;
+
+begin
+  SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, exOverflow, exUnderflow, exPrecision]);
+  gtk_init(@argc,@argv);
+  vbox := TGtkBox.new(GTK_ORIENTATION_VERTICAL, 0);
+  gtk_box_pack_start(PGtkBox(vbox), create_toolbar, false, false, 0);
+  gtk_box_pack_start(PGtkBox(vbox), create_browser, true, true, 0);
+  gtk_box_pack_start(PGtkBox(vbox), create_statusbar, false, false, 0);
+  main_window := create_window;
+  gtk_container_add(PGtkContainer(main_window), vbox);
+  web_view^.load_uri('http://www.lazarus.freepascal.org');
+  gtk_widget_grab_focus(PGtkWidget(web_view));
+  gtk_widget_show_all(main_window);
+  gtk_main;
+end.