mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-19 05:19:25 +02:00
various fixes for carbon
git-svn-id: trunk@8428 -
This commit is contained in:
mattias
parent
154222a21b
commit
ce294c63d5
16
Makefile
16
Makefile
@ -1,8 +1,8 @@
|
||||
#
|
||||
# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/09/23]
|
||||
# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/11/15]
|
||||
#
|
||||
default: all
|
||||
MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-emx i386-watcom i386-netwlibc i386-wince m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos powerpc-linux powerpc-netbsd powerpc-macos powerpc-darwin powerpc-morphos sparc-linux sparc-netbsd sparc-solaris x86_64-linux x86_64-freebsd x86_64-win64 arm-linux arm-wince
|
||||
MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-emx i386-watcom i386-netwlibc i386-wince m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos powerpc-linux powerpc-netbsd powerpc-macos powerpc-darwin powerpc-morphos sparc-linux sparc-netbsd sparc-solaris x86_64-linux x86_64-freebsd x86_64-win64 arm-linux arm-wince powerpc64-linux
|
||||
BSDs = freebsd netbsd openbsd darwin
|
||||
UNIXs = linux $(BSDs) solaris qnx
|
||||
LIMIT83fs = go32v2 os2 emx watcom
|
||||
@ -345,6 +345,9 @@ endif
|
||||
ifeq ($(FULL_TARGET),arm-wince)
|
||||
override TARGET_DIRS+=lcl components packager/registration ideintf designer packager
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),powerpc64-linux)
|
||||
override TARGET_UNITS+=runtimetypeinfocontrols.pas
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),i386-linux)
|
||||
override TARGET_PROGRAMS+=lazarus startlazarus
|
||||
endif
|
||||
@ -453,6 +456,9 @@ endif
|
||||
ifeq ($(FULL_TARGET),arm-wince)
|
||||
override TARGET_PROGRAMS+=lazarus startlazarus
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),powerpc64-linux)
|
||||
override CLEAN_FILES+=$(wildcard $(COMPILER_UNITTARGETDIR)/*$(OEXT)) $(wildcard $(COMPILER_UNITTARGETDIR)/*$(PPUEXT)) $(wildcard $(COMPILER_UNITTARGETDIR)/*$(RSTEXT)) $(wildcard *$(OEXT)) $(wildcard *$(PPUEXT)) $(wildcard *$(RSTEXT))
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),i386-linux)
|
||||
override TARGET_EXAMPLEDIRS+=examples
|
||||
endif
|
||||
@ -561,6 +567,9 @@ endif
|
||||
ifeq ($(FULL_TARGET),arm-wince)
|
||||
override TARGET_EXAMPLEDIRS+=examples
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),powerpc64-linux)
|
||||
override COMPILER_OPTIONS+=-gl
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),i386-linux)
|
||||
override CLEAN_FILES+=$(wildcard *$(OEXT)) $(wildcard *$(PPUEXT)) $(wildcard *$(RSTEXT))
|
||||
endif
|
||||
@ -3344,6 +3353,9 @@ packager:
|
||||
$(MAKE) -C packager all
|
||||
.PHONY: packager_all packager_debug packager_smart packager_release packager_units packager_examples packager_shared packager_install packager_sourceinstall packager_exampleinstall packager_distinstall packager_zipinstall packager_zipsourceinstall packager_zipexampleinstall packager_zipdistinstall packager_clean packager_distclean packager_cleanall packager_info packager_makefiles packager
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),powerpc64-linux)
|
||||
override COMPILER_UNITDIR+=../../ideintf/units/$(CPU_TARGET)-$(OS_TARGET)/ ../../lcl/units/$(CPU_TARGET)-$(OS_TARGET)/ ../../lcl/units/$(CPU_TARGET)-$(OS_TARGET)/$(LCL_PLATFORM)/ ../../packager/units/$(CPU_TARGET)-$(OS_TARGET)/ ./
|
||||
endif
|
||||
ifeq ($(FULL_TARGET),i386-linux)
|
||||
TARGET_EXAMPLEDIRS_EXAMPLES=1
|
||||
endif
|
||||
|
||||
@ -20,8 +20,9 @@ unit GLCarbonAGLContext;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LCLProc, LCLType, gl,
|
||||
FPCMacOSAll, InterfaceBase, CarbonInt,
|
||||
Classes, SysUtils, LCLProc, LCLType, gl, Forms,
|
||||
FPCMacOSAll, CarbonInt, AGL, CarbonProc, CarbonDef, CarbonPrivate,
|
||||
CarbonUtils,
|
||||
Controls;
|
||||
|
||||
procedure LOpenGLViewport(Left, Top, Width, Height: integer);
|
||||
@ -31,38 +32,137 @@ function LOpenGLCreateContext(AWinControl: TWinControl;
|
||||
SharedControl: TWinControl; AttrList: PInteger): HWND;
|
||||
|
||||
const
|
||||
DefaultOpenGLContextInitAttrList: array [0..10] of LongInt = (
|
||||
GDK_GL_RGBA,
|
||||
GDK_GL_RED_SIZE, 1,
|
||||
GDK_GL_GREEN_SIZE, 1,
|
||||
GDK_GL_BLUE_SIZE, 1,
|
||||
GDK_GL_DEPTH_SIZE, 1,
|
||||
GDK_GL_DOUBLEBUFFER,
|
||||
GDK_GL_None
|
||||
DefaultOpenGLContextInitAttrList: array [0..5] of LongInt = (
|
||||
AGL_WINDOW,
|
||||
AGL_RGBA,
|
||||
AGL_NO_RECOVERY,
|
||||
AGL_DOUBLEBUFFER,
|
||||
AGL_SINGLE_RENDERER,
|
||||
AGL_NONE
|
||||
);
|
||||
|
||||
type
|
||||
TAGLControlInfo = record
|
||||
Control: ControlRef;
|
||||
AGLContext: TAGLContext;
|
||||
end;
|
||||
PAGLControlInfo = ^TAGLControlInfo;
|
||||
|
||||
var
|
||||
AGLControlInfo_FOURCC: FourCharCode;
|
||||
|
||||
function CreateAGLControlInfo(Control: ControlRef; AGLContext: TAGLContext
|
||||
): PAGLControlInfo;
|
||||
function GetAGLControlInfo(Control: ControlRef): PAGLControlInfo;
|
||||
procedure FreeAGLControlInfo(Control: ControlRef);
|
||||
function GetAGLContext(Control: ControlRef): TAGLContext;
|
||||
|
||||
implementation
|
||||
|
||||
procedure LOpenGLViewport(Left, Top, Width, Height: integer);
|
||||
begin
|
||||
|
||||
glViewport(Left,Top,Width,Height);
|
||||
end;
|
||||
|
||||
procedure LOpenGLSwapBuffers(Handle: HWND);
|
||||
var
|
||||
AGLContext: TAGLContext;
|
||||
begin
|
||||
|
||||
AGLContext:=GetAGLContext(ControlRef(Handle));
|
||||
aglSwapBuffers(AGLContext);
|
||||
end;
|
||||
|
||||
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
||||
var
|
||||
AGLContext: TAGLContext;
|
||||
begin
|
||||
|
||||
AGLContext:=GetAGLContext(ControlRef(Handle));
|
||||
Result:=aglSetCurrentContext(aglContext)<>0;
|
||||
end;
|
||||
|
||||
function LOpenGLCreateContext(AWinControl: TWinControl;
|
||||
SharedControl: TWinControl; AttrList: PInteger): HWND;
|
||||
var
|
||||
disp: GDHandle;
|
||||
aglPixFmt: TAGLPixelFormat;
|
||||
aglContext: TAGLContext;
|
||||
ACarbonWindow: WindowRef;
|
||||
CFString: CFStringRef;
|
||||
Control: ControlRef;
|
||||
R: FPCMacOSAll.Rect;
|
||||
Info: PWidgetInfo;
|
||||
WSPrivate: TClass;
|
||||
ParentWindow: WindowPtr;
|
||||
begin
|
||||
if AWinControl.Parent=nil then
|
||||
RaiseGDBException('GLCarbonAGLContext.LOpenGLCreateContext no parent');
|
||||
ParentWindow:=WindowRef(AWinControl.Parent.Handle);
|
||||
|
||||
// create a dummy control
|
||||
R:=GetCarbonRect(AWinControl.BoundsRect);
|
||||
Control:=nil;
|
||||
CFString := CFStringCreateWithCString(nil, Pointer(PChar('SubControl')),
|
||||
kCFStringEncodingUTF8);
|
||||
if CreatePushButtonControl(ParentWindow, R, CFString, Control) <> noErr
|
||||
then
|
||||
debugln('CreatePushButtonControl failed');
|
||||
CFRelease(Pointer(CFString));
|
||||
|
||||
// create LCL WidgetInfo
|
||||
Result:=HWnd(Control);
|
||||
Info := CreateWidgetInfo(Control, AWinControl);
|
||||
WSPrivate:=nil;
|
||||
TCarbonPrivateHandleClass(WSPrivate).RegisterEvents(Info);
|
||||
|
||||
// create the AGL context
|
||||
disp := GetMainDevice ();
|
||||
aglPixFmt := aglChoosePixelFormat (@disp, 1, AttrList);
|
||||
aglContext := aglCreateContext (aglPixFmt, NIL);
|
||||
aglDestroyPixelFormat(aglPixFmt);
|
||||
|
||||
// use the carbon window.
|
||||
// TODO: find a way to use only the control for the context
|
||||
ACarbonWindow:=WindowRef(GetParentForm(AWinControl).Handle);
|
||||
aglSetDrawable(aglContext,GetWindowPort(ACarbonWindow));
|
||||
|
||||
AGLControlInfo_FOURCC := MakeFourCC('ACI ');
|
||||
|
||||
CreateAGLControlInfo(Control,AGLContext);
|
||||
end;
|
||||
|
||||
function CreateAGLControlInfo(Control: ControlRef; AGLContext: TAGLContext
|
||||
): PAGLControlInfo;
|
||||
begin
|
||||
New(Result);
|
||||
FillChar(Result^, SizeOf(Result^), 0);
|
||||
Result^.Control:=Control;
|
||||
Result^.AGLContext:=AGLContext;
|
||||
|
||||
SetControlProperty(Control, LAZARUS_FOURCC, AGLControlInfo_FOURCC,
|
||||
SizeOf(Result), @Result);
|
||||
end;
|
||||
|
||||
function GetAGLControlInfo(Control: ControlRef): PAGLControlInfo;
|
||||
var
|
||||
m: LongWord;
|
||||
begin
|
||||
GetControlProperty(Control, LAZARUS_FOURCC, AGLControlInfo_FOURCC,
|
||||
SizeOf(Result), @m, @Result);
|
||||
end;
|
||||
|
||||
procedure FreeAGLControlInfo(Control: ControlRef);
|
||||
var
|
||||
Info: PAGLControlInfo;
|
||||
begin
|
||||
Info:=GetAGLControlInfo(Control);
|
||||
if Info=nil then exit;
|
||||
RemoveControlProperty(Control, LAZARUS_FOURCC, AGLControlInfo_FOURCC);
|
||||
System.FreeMem(Info);
|
||||
end;
|
||||
|
||||
function GetAGLContext(Control: ControlRef): TAGLContext;
|
||||
begin
|
||||
Result:=GetAGLControlInfo(Control)^.AGLContext;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -14,7 +14,7 @@
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Files Count="3">
|
||||
<Files Count="4">
|
||||
<Item1>
|
||||
<Filename Value="openglcontext.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
@ -30,6 +30,11 @@
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="GLCarbonAGLContext"/>
|
||||
</Item3>
|
||||
<Item4>
|
||||
<Filename Value="agl.pp"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="agl"/>
|
||||
</Item4>
|
||||
</Files>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<RequiredPkgs Count="2">
|
||||
|
||||
@ -18,7 +18,7 @@
|
||||
- gtk with glx : fully
|
||||
- gtk2 with glx : todo
|
||||
- carbon with agl : todo
|
||||
- windows with ? : todo
|
||||
- windows with wgl: todo
|
||||
}
|
||||
unit OpenGLContext;
|
||||
|
||||
|
||||
@ -729,7 +729,8 @@ begin
|
||||
{$ENDIF}
|
||||
end;
|
||||
{$IFDEF SYN_LAZARUS}
|
||||
//debugln('TheFontStock.InternalCreateFont A ',FBaseFontName);
|
||||
//debugln('TheFontStock.InternalCreateFont ------------------------------');
|
||||
//debugln('TheFontStock.InternalCreateFont A ',FBaseFontName,' ',dbgs(AStyle));
|
||||
Result := CreateFontIndirectEx(FBaseLF,FBaseFontName);
|
||||
{$ELSE}
|
||||
Result := CreateFontIndirect(FBaseLF);
|
||||
@ -833,7 +834,11 @@ begin
|
||||
{$ELSE}
|
||||
ASSERT(SizeOf(TFontStyles) = 1);
|
||||
{$ENDIF}
|
||||
{$IFDEF SYN_LAZARUS}
|
||||
idx := integer(Value);
|
||||
{$ELSE}
|
||||
idx := PByte(@Value)^;
|
||||
{$ENDIF}
|
||||
ASSERT(idx <= High(TheStockFontPatterns));
|
||||
|
||||
UseFontHandles;
|
||||
@ -1129,7 +1134,11 @@ procedure TheTextDrawer2.SetStyle(Value: TFontStyles);
|
||||
var
|
||||
idx: Integer;
|
||||
begin
|
||||
{$IFDEF SYN_LAZARUS}
|
||||
idx := integer(Value);
|
||||
{$ELSE}
|
||||
idx := PByte(@Value)^;
|
||||
{$ENDIF}
|
||||
if FFonts[idx] <> 0 then
|
||||
begin
|
||||
FCrntFont := FFonts[idx];
|
||||
|
||||
@ -331,9 +331,10 @@ function CodeMakroProcedureName(const Parameter: string;
|
||||
InteractiveValue: TPersistent; SrcEdit: TSourceEditorInterface; var Value,
|
||||
ErrorMsg: string): boolean;
|
||||
begin
|
||||
Result:=CodeMakroProcedureName(
|
||||
Result:=CodeMakroProcedureHead(
|
||||
'WithoutParamList,WithoutBrackets,WithoutSemicolon',
|
||||
InteractiveValue,SrcEdit,Value,ErrorMsg);
|
||||
debugln('CodeMakroProcedureName ',Value);
|
||||
end;
|
||||
|
||||
procedure RegisterStandardCodeTemplatesMenuItems;
|
||||
@ -390,7 +391,7 @@ begin
|
||||
@CodeMakroProcedureHead,nil);
|
||||
RegisterCodeMacro('ProcedureName','insert procedure name',
|
||||
'Insert name of current procedure',
|
||||
@CodeMakroProcedureHead,nil);
|
||||
@CodeMakroProcedureName,nil);
|
||||
end;
|
||||
|
||||
{ TCodeTemplateEditForm }
|
||||
|
||||
@ -1221,6 +1221,8 @@ begin
|
||||
OutFilename:=TargetFilename
|
||||
else
|
||||
OutFilename:=lowercase(ExtractFileNameOnly(MainSourceFileName));
|
||||
debugln('TBaseCompilerOptions.CreateTargetFilename MainSourceFileName=',MainSourceFileName,' OutFilename=',OutFilename,' TargetFilename=',TargetFilename);
|
||||
|
||||
Result:=AppendPathDelim(UnitOutDir)+OutFilename;
|
||||
end;
|
||||
Result:=TrimFilename(Result);
|
||||
|
||||
@ -7258,7 +7258,8 @@ begin
|
||||
end;
|
||||
|
||||
// execute compilation tool 'Before'
|
||||
ToolBefore:=TProjectCompilationToolOptions(Project1.CompilerOptions.ExecuteBefore);
|
||||
ToolBefore:=TProjectCompilationToolOptions(
|
||||
Project1.CompilerOptions.ExecuteBefore);
|
||||
if (AReason in ToolBefore.CompileReasons) then begin
|
||||
Result:=DoExecuteCompilationTool(Project1.CompilerOptions.ExecuteBefore,
|
||||
Project1.ProjectDirectory,
|
||||
|
||||
@ -1375,10 +1375,29 @@ const
|
||||
(***************************************************************************
|
||||
***************************************************************************)
|
||||
|
||||
function DbgS(const Style: TFontStyles): string; overload;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
function DbgS(const Style: TFontStyles): string;
|
||||
|
||||
procedure Add(const s: string);
|
||||
begin
|
||||
if Result<>'' then Result:=Result+',';
|
||||
Result:=Result+s;
|
||||
end;
|
||||
|
||||
begin
|
||||
Result:='';
|
||||
if fsBold in Style then Add('fsBold');
|
||||
if fsItalic in Style then Add('fsItalic');
|
||||
if fsStrikeOut in Style then Add('fsStrikeOut');
|
||||
if fsUnderline in Style then Add('fsUnderline');
|
||||
Result:='['+Result+']';
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterClasses([TBitmap,TPixmap,TPortableNetworkGraphic,TPortableAnyMapGraphic,TPicture,
|
||||
|
||||
@ -30,7 +30,7 @@ unit CarbonProc;
|
||||
interface
|
||||
|
||||
uses
|
||||
FPCMacOSAll,
|
||||
FPCMacOSAll, Classes,
|
||||
LCLProc, LCLClasses, Controls, LMessages, Forms, Avl_Tree, SysUtils,
|
||||
CarbonDef;
|
||||
|
||||
@ -43,7 +43,10 @@ function DeliverMessage(ATarget: TObject; var AMessage): Integer;
|
||||
function RegisterEventHandler(AHandler: TCarbonWSEventHandlerProc): EventHandlerUPP;
|
||||
procedure UnRegisterEventHandler(AHandler: TCarbonWSEventHandlerProc);
|
||||
|
||||
function Dbgs(const ARect: FPCMacOSAll.Rect): string;
|
||||
function GetCarbonRect(Left, Top, Width, Height: Integer): FPCMacOSAll.Rect;
|
||||
function GetCarbonRect(const ARect: TRect): FPCMacOSAll.Rect;
|
||||
|
||||
function Dbgs(const ARect: FPCMacOSAll.Rect): string; overload;
|
||||
|
||||
implementation
|
||||
|
||||
@ -216,6 +219,22 @@ begin
|
||||
UPPTree.Delete(node);
|
||||
end;
|
||||
|
||||
function GetCarbonRect(Left, Top, Width, Height: Integer): FPCMacOSAll.Rect;
|
||||
begin
|
||||
Result.left:=Left;
|
||||
Result.top:=Top;
|
||||
Result.right:=Left+Width;
|
||||
Result.bottom:=Top+Height;
|
||||
end;
|
||||
|
||||
function GetCarbonRect(const ARect: TRect): FPCMacOSAll.Rect;
|
||||
begin
|
||||
Result.left:=ARect.Left;
|
||||
Result.top:=ARect.Top;
|
||||
Result.right:=ARect.Right;
|
||||
Result.bottom:=ARect.Bottom;
|
||||
end;
|
||||
|
||||
function Dbgs(const ARect: FPCMacOSAll.Rect): string;
|
||||
begin
|
||||
Result:=IntToStr(ARect.left)+','+IntToStr(ARect.top)
|
||||
|
||||
@ -75,16 +75,14 @@ var
|
||||
//Button: TCustomButton;
|
||||
Control: ControlRef;
|
||||
CFString: CFStringRef;
|
||||
R: Rect;
|
||||
R: FPCMacOSAll.Rect;
|
||||
Info: PWidgetInfo;
|
||||
begin
|
||||
Result := 0;
|
||||
//Button := AWinControl as TCustomButton;
|
||||
|
||||
R.Left := AParams.X;
|
||||
R.Top := AParams.Y;
|
||||
R.Right := AParams.X + AParams.Width;
|
||||
R.Bottom := AParams.Y + AParams.Height;
|
||||
R:=GetCarbonRect(AParams.X,AParams.Y,
|
||||
AParams.X + AParams.Width,AParams.Y + AParams.Height);
|
||||
|
||||
CFString := CFStringCreateWithCString(nil, Pointer(AParams.Caption),
|
||||
DEFAULT_CFSTRING_ENCODING);
|
||||
|
||||
@ -30,7 +30,7 @@ uses
|
||||
// libs
|
||||
FPCMacOSAll, CarbonUtils, CarbonExtra, Classes,
|
||||
// LCL
|
||||
Controls, LCLType, LMessages, LCLProc,
|
||||
Forms, Controls, LCLType, LMessages, LCLProc,
|
||||
// widgetset
|
||||
WSControls, WSLCLClasses, WSProc,
|
||||
// interface
|
||||
@ -83,6 +83,7 @@ type
|
||||
private
|
||||
protected
|
||||
public
|
||||
class function CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle; override;
|
||||
end;
|
||||
|
||||
{ TCarbonWSImageList }
|
||||
@ -133,17 +134,31 @@ class procedure TCarbonWSWinControl.SetBounds(const AWinControl: TWinControl;
|
||||
const ALeft, ATop, AWidth, AHeight: Integer);
|
||||
var
|
||||
NewBounds: FPCMacOSAll.Rect;
|
||||
//OldBounds: FPCMacOSAll.Rect;
|
||||
begin
|
||||
if not WSCheckHandleAllocated(AWinControl, 'GetText') then Exit;
|
||||
if not WSCheckHandleAllocated(AWinControl, 'SetBounds') then Exit;
|
||||
|
||||
NewBounds.left:=AWinControl.Left;
|
||||
NewBounds.top:=AWinControl.Top;
|
||||
NewBounds.right:=AWinControl.Left+AWinControl.Width;
|
||||
NewBounds.bottom:=AWinControl.Top+AWinControl.Height;
|
||||
DebugLn('TCarbonWSWinControl.SetBounds ',dbgsName(AWinControl),' NewBounds=',dbgs(NewBounds));
|
||||
if SetWindowBounds(WindowRef(AWinControl.Handle),kWindowStructureRgn,NewBounds)
|
||||
<> NoErr then begin
|
||||
DebugLn('TCarbonWSWinControl.SetBounds ',dbgsName(AWinControl),' failed');
|
||||
if AWinControl is TCustomForm then begin
|
||||
if SetWindowBounds(WindowRef(AWinControl.Handle),kWindowStructureRgn,NewBounds)
|
||||
<> NoErr then begin
|
||||
DebugLn('TCarbonWSWinControl.SetBounds ',dbgsName(AWinControl),' failed');
|
||||
end;
|
||||
end else begin
|
||||
//GetControlBounds(ControlRef(AWinControl.Handle),OldBounds);
|
||||
//debugln('TCarbonWSWinControl.SetBounds OldBounds=',dbgs(OldBounds));
|
||||
SetControlBounds(ControlRef(AWinControl.Handle),NewBounds);
|
||||
{if AWinControl.Parent<>nil then begin
|
||||
dec(OldBounds.Left,10);
|
||||
dec(OldBounds.Top,10);
|
||||
inc(OldBounds.right,10);
|
||||
inc(OldBounds.bottom,10);
|
||||
InvalWindowRect(WindowRef(AWinControl.Parent.Handle),OldBounds);
|
||||
end;}
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -198,6 +213,36 @@ begin
|
||||
ARect.Bottom := ARect.Top + Trunc(AHIRect.size.height);
|
||||
end;
|
||||
|
||||
{ TCarbonWSCustomControl }
|
||||
|
||||
function TCarbonWSCustomControl.CreateHandle(const AWinControl: TWinControl;
|
||||
const AParams: TCreateParams): TLCLIntfHandle;
|
||||
var
|
||||
//Button: TCustomButton;
|
||||
Control: ControlRef;
|
||||
CFString: CFStringRef;
|
||||
R: FPCMacOSAll.Rect;
|
||||
Info: PWidgetInfo;
|
||||
begin
|
||||
Result := 0;
|
||||
//Button := AWinControl as TCustomButton;
|
||||
|
||||
R:=GetCarbonRect(AParams.X,AParams.Y,
|
||||
AParams.X + AParams.Width,AParams.Y + AParams.Height);
|
||||
|
||||
CFString := CFStringCreateWithCString(nil, Pointer(AParams.Caption),
|
||||
DEFAULT_CFSTRING_ENCODING);
|
||||
if CreatePushButtonControl(WindowRef(AParams.WndParent), R,
|
||||
CFString, Control) = noErr
|
||||
then
|
||||
Result := TLCLIntfHandle(Control);
|
||||
CFRelease(Pointer(CFString));
|
||||
if Result = 0 then Exit;
|
||||
|
||||
Info := CreateWidgetInfo(Control, AWinControl);
|
||||
TCarbonPrivateHandleClass(WSPrivate).RegisterEvents(Info);
|
||||
end;
|
||||
|
||||
initialization
|
||||
|
||||
////////////////////////////////////////////////////
|
||||
@ -210,7 +255,7 @@ initialization
|
||||
// RegisterWSComponent(TControl, TCarbonWSControl);
|
||||
RegisterWSComponent(TWinControl, TCarbonWSWinControl, TCarbonPrivateHiView);
|
||||
// RegisterWSComponent(TGraphicControl, TCarbonWSGraphicControl);
|
||||
// RegisterWSComponent(TCustomControl, TCarbonWSCustomControl);
|
||||
RegisterWSComponent(TCustomControl, TCarbonWSCustomControl);
|
||||
// RegisterWSComponent(TImageList, TCarbonWSImageList);
|
||||
////////////////////////////////////////////////////
|
||||
|
||||
|
||||
@ -128,6 +128,8 @@ var
|
||||
NewBounds: FPCMacOSAll.Rect;
|
||||
Info: PWidgetInfo;
|
||||
NewWindowClass: Integer;
|
||||
MinSize: HISize;
|
||||
MaxSize: HISize;
|
||||
begin
|
||||
Result := 0;
|
||||
|
||||
@ -157,6 +159,16 @@ begin
|
||||
|
||||
Info := CreateWidgetInfo(Window, AWinControl);
|
||||
TCarbonPrivateHandleClass(WSPrivate).RegisterEvents(Info);
|
||||
|
||||
MinSize.width:=AWinControl.Constraints.EffectiveMinWidth;
|
||||
MinSize.height:=AWinControl.Constraints.EffectiveMinHeight;
|
||||
MaxSize.width:=AWinControl.Constraints.EffectiveMaxWidth;
|
||||
MaxSize.height:=AWinControl.Constraints.EffectiveMaxHeight;
|
||||
if MaxSize.width<=0 then
|
||||
MaxSize.width:=10000;
|
||||
if MaxSize.height<=0 then
|
||||
MaxSize.height:=10000;
|
||||
SetWindowResizeLimits(Window,@MinSize,@MaxSize);
|
||||
|
||||
// The window was created hidden so show it.
|
||||
ShowWindow(Window);
|
||||
|
||||
@ -1594,6 +1594,7 @@ var
|
||||
FileName : string;
|
||||
Files: TStringList;
|
||||
CurFilename: string;
|
||||
//SelectedFont: PGdkFont;
|
||||
|
||||
function CheckOpenedFilename(const AFilename: string): boolean;
|
||||
begin
|
||||
@ -1709,6 +1710,10 @@ begin
|
||||
Assert(False, 'Trace:Pressed OK in FontDialog');
|
||||
FontName := gtk_font_selection_dialog_get_font_name(
|
||||
pgtkfontselectiondialog(FPointer));
|
||||
//debugln('gtkDialogOKclickedCB FontName=',FontName);
|
||||
//SelectedFont:=gdk_font_load(PChar(FontName));
|
||||
//debugln('gtkDialogOKclickedCB ',dbgs(SelectedFont));
|
||||
|
||||
// extract basic font attributes from the font name in XLFD format
|
||||
ALogFont:=XLFDNameToLogFont(FontName);
|
||||
TFontDialog(theDialog).Font.Assign(ALogFont);
|
||||
|
||||
@ -1275,6 +1275,8 @@ begin
|
||||
Result:=0;
|
||||
end;
|
||||
{$Else}
|
||||
|
||||
{off $DEFINE VerboseFonts}
|
||||
var
|
||||
GdiObject: PGdiObject;
|
||||
FontNameRegistry, Foundry, FamilyName, WeightName,
|
||||
@ -1320,8 +1322,7 @@ var
|
||||
CharSetRegistry, CharSetCoding
|
||||
]);}
|
||||
|
||||
//DebugLn(' Trying "',S,'"');
|
||||
DebugLn(' Trying Font "',S,'"');
|
||||
//DebugLn(' Trying Font "',S,'"');
|
||||
result := LoadFontXLFD(S);
|
||||
end;
|
||||
|
||||
@ -1335,6 +1336,7 @@ var
|
||||
Tail := '-'+SetwidthName+'-'+AddStyleName+'-'+PixelSize
|
||||
+'-'+PointSize+'-'+ResolutionX+'-'+ResolutionY+'-'+Spacing
|
||||
+'-'+AverageWidth+'-'+CharSetRegistry+'-'+CharSetCoding;
|
||||
//debugln('LoadFontExCharset Head=',Head,' Tail=',Tail);
|
||||
for i:=0 to WeightList.Count-1 do begin
|
||||
aSlant := Slant;
|
||||
repeat
|
||||
@ -1347,6 +1349,7 @@ var
|
||||
break;
|
||||
until false;
|
||||
end;
|
||||
//debugln('LoadFontExCharset END');
|
||||
end;
|
||||
|
||||
function LoadFontEx: boolean;
|
||||
@ -1354,6 +1357,7 @@ var
|
||||
j: integer;
|
||||
begin
|
||||
Result := false;
|
||||
//debugln('LoadFontEx START CharSetRegistry=',CharSetRegistry);
|
||||
if CharSetRegistry<>'*' then
|
||||
result := LoadFontExCharset
|
||||
else
|
||||
@ -1367,6 +1371,7 @@ var
|
||||
if result then
|
||||
break;
|
||||
end;
|
||||
//debugln('LoadFontEx END');
|
||||
end;
|
||||
|
||||
procedure LoadDefaultFont;
|
||||
@ -1649,7 +1654,7 @@ begin
|
||||
// next checks are fall over
|
||||
|
||||
{$IFDEF VerboseFonts}
|
||||
write('CreateFontIndirect->');
|
||||
debugln('TGtkWidgetSet.CreateFontIndirectEx ');
|
||||
{$ENDIF}
|
||||
{
|
||||
if LoadFont then exit;
|
||||
@ -1658,11 +1663,23 @@ begin
|
||||
WeightName := '*';
|
||||
if LoadFont then exit;
|
||||
}
|
||||
// try one height lower
|
||||
// try one height smaller
|
||||
{$IFDEF VerboseFonts}
|
||||
debugln('TGtkWidgetSet.CreateFontIndirectEx try one height smaller');
|
||||
{$ENDIF}
|
||||
PixelSize := IntToStr(Abs(LogFont.lfHeight)-1);
|
||||
// Since we use pixelsize, it isn't allowed to give a value here
|
||||
PointSize := '*';
|
||||
|
||||
// Use the default
|
||||
ResolutionX := '*';
|
||||
ResolutionY := '*';
|
||||
if LoadFont then exit;
|
||||
|
||||
// try one height higher
|
||||
// try one height bigger
|
||||
{$IFDEF VerboseFonts}
|
||||
debugln('TGtkWidgetSet.CreateFontIndirectEx try one height bigger');
|
||||
{$ENDIF}
|
||||
PixelSize := IntToStr(Abs(LogFont.lfHeight)+1);
|
||||
if LoadFont then exit;
|
||||
|
||||
@ -1670,6 +1687,9 @@ begin
|
||||
|
||||
// try instead of mono spaced -> character cell spaced
|
||||
if (Spacing='m') then begin
|
||||
{$IFDEF VerboseFonts}
|
||||
debugln('TGtkWidgetSet.CreateFontIndirectEx try instead of mono spaced -> character cell spaced');
|
||||
{$ENDIF}
|
||||
Spacing:='c';
|
||||
if LoadFont then exit;
|
||||
end;
|
||||
@ -1686,11 +1706,17 @@ begin
|
||||
}
|
||||
// try all spacings
|
||||
if spacing<>'*' then begin
|
||||
{$IFDEF VerboseFonts}
|
||||
debugln('TGtkWidgetSet.CreateFontIndirectEx try all spacings');
|
||||
{$ENDIF}
|
||||
Spacing := '*';
|
||||
if LoadFont then exit;
|
||||
end;
|
||||
|
||||
if charSetCoding<>'*' then begin
|
||||
{$IFDEF VerboseFonts}
|
||||
debugln('TGtkWidgetSet.CreateFontIndirectEx try all charsets');
|
||||
{$ENDIF}
|
||||
charsetCoding := '*';
|
||||
charSetRegistry:= '*';
|
||||
if LoadFont then exit;
|
||||
@ -1698,6 +1724,9 @@ begin
|
||||
|
||||
if (Foundry<>'*') then begin
|
||||
// try all Families
|
||||
{$IFDEF VerboseFonts}
|
||||
debugln('TGtkWidgetSet.CreateFontIndirectEx try all families');
|
||||
{$ENDIF}
|
||||
PixelSize := IntToStr(Abs(LogFont.lfHeight));
|
||||
FamilyName := '*';
|
||||
if LoadFont then exit;
|
||||
|
||||
@ -147,24 +147,24 @@ procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10: string);
|
||||
procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11: string);
|
||||
procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12: string);
|
||||
|
||||
function DbgS(const c: cardinal): string;
|
||||
function DbgS(const i: longint): string;
|
||||
function DbgS(const i: int64): string;
|
||||
function DbgS(const r: TRect): string;
|
||||
function DbgS(const p: TPoint): string;
|
||||
function DbgS(const p: pointer): string;
|
||||
function DbgS(const e: extended): string;
|
||||
function DbgS(const b: boolean): string;
|
||||
function DbgSName(const p: TObject): string;
|
||||
function DbgSName(const p: TClass): string;
|
||||
function DbgStr(const StringWithSpecialChars: string): string;
|
||||
function DbgWideStr(const StringWithSpecialChars: widestring): string;
|
||||
function dbgMemRange(P: PByte; Count: integer; Width: integer = 0): string;
|
||||
function dbgMemStream(MemStream: TCustomMemoryStream; Count: integer): string;
|
||||
function dbgObjMem(AnObject: TObject): string;
|
||||
function DbgS(const c: cardinal): string; overload;
|
||||
function DbgS(const i: longint): string; overload;
|
||||
function DbgS(const i: int64): string; overload;
|
||||
function DbgS(const r: TRect): string; overload;
|
||||
function DbgS(const p: TPoint): string; overload;
|
||||
function DbgS(const p: pointer): string; overload;
|
||||
function DbgS(const e: extended): string; overload;
|
||||
function DbgS(const b: boolean): string; overload;
|
||||
function DbgSName(const p: TObject): string; overload;
|
||||
function DbgSName(const p: TClass): string; overload;
|
||||
function DbgStr(const StringWithSpecialChars: string): string; overload;
|
||||
function DbgWideStr(const StringWithSpecialChars: widestring): string; overload;
|
||||
function dbgMemRange(P: PByte; Count: integer; Width: integer = 0): string; overload;
|
||||
function dbgMemStream(MemStream: TCustomMemoryStream; Count: integer): string; overload;
|
||||
function dbgObjMem(AnObject: TObject): string; overload;
|
||||
|
||||
function DbgS(const i1,i2,i3,i4: integer): string;
|
||||
function DbgS(const Shift: TShiftState): string;
|
||||
function DbgS(const i1,i2,i3,i4: integer): string; overload;
|
||||
function DbgS(const Shift: TShiftState): string; overload;
|
||||
|
||||
// some string manipulation functions
|
||||
function StripLN(const ALine: String): String;
|
||||
@ -831,6 +831,7 @@ end;
|
||||
procedure InitializeDebugOutput;
|
||||
var
|
||||
DebugFileName: string;
|
||||
|
||||
function GetDebugFileName: string;
|
||||
const
|
||||
DebugLogStart = '--debug-log=';
|
||||
@ -855,6 +856,7 @@ var
|
||||
if (length(result)>0) then
|
||||
Result := ExpandFileName(Result);
|
||||
end;
|
||||
|
||||
begin
|
||||
DebugFileName := GetDebugFileName;
|
||||
if (length(DebugFileName)>0) and
|
||||
|
||||
Loading…
Reference in New Issue
Block a user