pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

Added gobject inheritance demo

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2501 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
drewski207
2012-08-29 04:04:36 +00:00
parent 5413d54eb4
commit 7973be2612
3 changed files with 257 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

125
bindings/gtk3/examples/inheritance/gtk3mybutton.pas Normal file
View File

@ -0,0 +1,125 @@
unit gtk3mybutton;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, GLib2, GObject2, Gtk3;
type
{ TMyButton }
TObjectProcedure = procedure of object;
PMyButton = ^TMyButton;
TMyButton = object(TGtkButton)
private
FOnClicked: TObjectProcedure;
saved_caption: String;
function OnTimer: GBoolean; cdecl;
procedure clicked;
procedure init;
public
function get_type: TGType; static;
function new: PMyButton; static;
procedure QuitProgram;
property OnClicked: TObjectProcedure read FOnClicked write FOnClicked;
end;
{ TMyButtonClass }
PMyButtonClass = ^TMyButtonClass;
TMyButtonClass = object(TGtkButtonClass)
origclicked: procedure(button: PGtkButton); cdecl;
procedure init;
end;
implementation
var
MY_BUTTON_TYPE: TGType = 0;
{ TMyButtonClass }
procedure TMyButtonClass.init;
begin
origclicked := clicked;
Pointer(clicked) := @TMyButton.clicked;
end;
{ TMyButton }
function TMyButton.OnTimer: GBoolean; cdecl;
var
klass: PMyButtonClass;
begin
Result := False;
label_ := PChar(saved_caption);
saved_caption:='';
if Assigned(FOnClicked) then
FOnClicked;
klass := PMyButtonClass(g_type_instance.g_class);
if Assigned(klass^.origclicked) then
klass^.origclicked(@self);
end;
procedure TMyButton.clicked;
begin
// we'll add a delay and update the text. the timer calls the inherited method.
g_timeout_add(3000, TGSourceFunc(@TMyButton.OnTimer), @Self);
saved_caption:=label_;
label_ := 'Wait for it...';
end;
procedure TMyButton.init;
begin
end;
function TMyButton.get_type: TGType;
var
Info: TGTypeInfo;
begin
if MY_BUTTON_TYPE = 0 then
begin
Info.class_size:=SizeOf(TMyButtonClass);
Info.base_init:= nil;
Info.base_finalize:=nil;
Info.class_init:= TGClassInitFunc(@TMyButtonClass.init);
Info.class_finalize:=nil;
Info.class_data:=nil;
Info.instance_size:=SizeOf(TMyButton);
Info.n_preallocs:=0;
Info.instance_init:=TGInstanceInitFunc(@TMyButton.init);
Info.value_table:=nil;
MY_BUTTON_TYPE := g_type_register_static(gtk_button_get_type, 'MyButton', @Info, 0);
end;
Result := MY_BUTTON_TYPE;
end;
function TMyButton.new: PMyButton;
begin
Result := PMyButton(g_object_new(TMyButton.get_type, nil, []));
end;
procedure TMyButton.QuitProgram;
begin
gtk_main_quit;
end;
end.

83
bindings/gtk3/examples/inheritance/inheritancedemo.lpi Normal file
View File

@ -0,0 +1,83 @@
<?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="inheritancedemo"/>
<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="2">
<Unit0>
<Filename Value="inheritancedemo.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="inheritancedemo"/>
</Unit0>
<Unit1>
<Filename Value="gtk3mybutton.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="gtk3mybutton"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="inheritancedemo"/>
</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>

49
bindings/gtk3/examples/inheritance/inheritancedemo.lpr Normal file
View File

@ -0,0 +1,49 @@
program inheritancedemo;
{$mode objfpc}{$H+}
uses
Classes, Gtk3,GObject2,GLib2, Math, gtk3mybutton;
// these procedures are signal handlers. they are called when a signal is emitted
procedure Gtk_Window_Destroy(Sender: PGtkWidget; user_data: gpointer); cdecl;
begin
if gtk_main_level > 0 then
gtk_main_quit;
end;
procedure Button_Click(Sender: PGtkWidget; user_data: gpointer); cdecl;
begin
gtk_main_quit;
end;
procedure CreateWidgets;
var
Win: PGtkWindow;
Button: PMyButton;
begin
// first create window
Win := TGtkWindow.new(GTK_WINDOW_TOPLEVEL);
Win^.set_title('Hello World!');
Win^.set_size_request(300,200);
//then create a button and add it to the window
Button := TMyButton.new;
Button^.label_:='Quit';
Button^.tooltip_text:='Don''t click me unless you want to!';
Win^.add(PGtkWidget(Button));
// now connect signals
g_signal_connect_data(Win, 'destroy', TGCallback(@Gtk_Window_Destroy), nil, nil, 0);
//g_signal_connect_data(Button, 'clicked', TGCallback(@Button_Click), nil, nil, 0);
Button^.OnClicked:=@Button^.QuitProgram;
Win^.show_all;
end;
begin
SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, exOverflow, exUnderflow, exPrecision]);
gtk_init(@argc, @argv);
CreateWidgets;
gtk_main;
end.