diff options
Diffstat (limited to 'src/corelib')
24 files changed, 2246 insertions, 145 deletions
diff --git a/src/corelib/fpg_base.pas b/src/corelib/fpg_base.pas index 504aa9ea..eee90d4a 100644 --- a/src/corelib/fpg_base.pas +++ b/src/corelib/fpg_base.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -90,6 +90,8 @@ type // For providing user feedback. No need to display backtrace information EfpGUIUserFeedbackException = class(EfpGUIException); + TfpgTextEncoding = (encUTF8, encCP437, encCP850, encCP866, encCP1250, encIBMGraph); + const @@ -214,6 +216,13 @@ type PfpgMessageRec = ^TfpgMessageRec; + TfpgMoveEventRec = record + Sender: TObject; + x: TfpgCoord; + y: TfpgCoord; + end; + + TfpgLineStyle = (lsSolid, lsDash, lsDot, lsDashDot, lsDashDotDot); @@ -381,7 +390,7 @@ type procedure DrawPolygon(Points: PPoint; NumPts: Integer; Winding: boolean = False); virtual; procedure DrawPolygon(const Points: array of TPoint); procedure StretchDraw (x, y, w, h: TfpgCoord; ASource: TfpgImageBase); - procedure CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; var ASrcRect: TfpgRect); + procedure CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; var ASrcRect: TfpgRect); virtual; // x,y is the top/left corner of where the text output will start. procedure DrawString(x, y: TfpgCoord; const txt: string); procedure FillRectangle(x, y, w, h: TfpgCoord); overload; @@ -603,6 +612,7 @@ type TFileEntryType = (etFile, etDir); TFileListSortOrder = (soNone, soFileName, soCSFileName, soFileExt, soSize, soTime); TFileModeString = string[9]; + TfpgSearchMode = (smAny, smFiles, smDirs); // A simple data object @@ -642,6 +652,7 @@ type FEntries: TList; FDirectoryName: TfpgString; FFileMask: TfpgString; + FSearchMode: TfpgSearchMode; FShowHidden: boolean; FCurrentSpecialDir: integer; procedure AddEntry(sr: TSearchRec); @@ -664,6 +675,7 @@ type property Entry[i: integer]: TFileEntry read GetEntry; property FileMask: TfpgString read FFileMask write FFileMask; property HasFileMode: boolean read FHasFileMode; + property SearchMode: TfpgSearchMode read FSearchMode write FSearchMode; property ShowHidden: boolean read FShowHidden write FShowHidden; property SpecialDirs: TStringList read FSpecialDirs; end; @@ -766,7 +778,6 @@ function fpgLighter(const AColor: TfpgColor; APercent: Byte = 50): TfpgColor; { Points } -function PtInRect(const ARect: TfpgRect; const APoint: TPoint): Boolean; procedure SortRect(var ARect: TRect); procedure SortRect(var ARect: TfpgRect); procedure SortRect(var left, top, right, bottom: integer); @@ -783,7 +794,7 @@ uses typinfo, process, {$IFDEF GDEBUG} - dbugintf, + fpg_dbugintf, {$ENDIF} dateutils; @@ -1091,14 +1102,6 @@ begin Result := RGBTripleTofpgColor(lColor); end; -function PtInRect(const ARect: TfpgRect; const APoint: TPoint): Boolean; -begin - Result := (APoint.x >= ARect.Left) and - (APoint.y >= ARect.Top) and - (APoint.x <= ARect.Right) and - (APoint.y <= ARect.Bottom); -end; - procedure SortRect(var ARect: TRect); begin with ARect do @@ -2550,7 +2553,11 @@ var p: TProcess; begin Result := False; - if not fpgFileExists(GetHelpViewer) then + if fpgExtractFilePath(GetHelpViewer) = '' then + begin + // do nothing - we are hoping docview is in the system PATH + end + else if not fpgFileExists(GetHelpViewer) then raise EfpGUIUserFeedbackException.Create(rsfailedtofindhelpviewer); p := TProcess.Create(nil); try @@ -2578,7 +2585,11 @@ var p: TProcess; begin Result := False; - if not fpgFileExists(GetHelpViewer) then + if fpgExtractFilePath(GetHelpViewer) = '' then + begin + // do nothing - we are hoping docview is in the system PATH + end + else if not fpgFileExists(GetHelpViewer) then raise EfpGUIUserFeedbackException.Create(rsfailedtofindhelpviewer); p := TProcess.Create(nil); try @@ -2721,7 +2732,7 @@ var e: TFileEntry; begin e := TFileEntry.Create; - e.Name := fpgFromOSEncoding(sr.Name); + e.Name := sr.Name; e.Extension := fpgExtractFileExt(e.Name); e.Size := sr.Size; // e.Attributes := sr.Attr; // this is incorrect and needs to improve! @@ -2791,6 +2802,7 @@ begin FFileMask := '*'; FDirectoryName := ''; FSpecialDirs := TStringList.Create; + FSearchMode := smAny; end; destructor TfpgFileListBase.Destroy; @@ -2837,11 +2849,13 @@ begin // Reported to FPC as bug 9440 in Mantis. if fpgFindFirst(FDirectoryName + AllFilesMask, faAnyFile or $00000080, SearchRec) = 0 then begin - AddEntry(SearchRec); - while fpgFindNext(SearchRec) = 0 do - begin - AddEntry(SearchRec); - end; + repeat + if (FSearchMode=smAny) or + ((FSearchMode=smFiles) and (not HasAttrib(SearchRec.Attr, faDirectory))) or + ((FSearchMode=smDirs) and HasAttrib(SearchRec.Attr, faDirectory)) + then + AddEntry(SearchRec); + until fpgFindNext(SearchRec) <> 0; end; Result:=True; finally @@ -3088,7 +3102,6 @@ end; function TfpgMimeDataBase.Formats: TStrings; var i: integer; - r: TfpgMimeDataItem; s: string; begin if Count = 0 then diff --git a/src/corelib/fpg_dbugintf.pas b/src/corelib/fpg_dbugintf.pas new file mode 100644 index 00000000..8e9d9874 --- /dev/null +++ b/src/corelib/fpg_dbugintf.pas @@ -0,0 +1,337 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2005 by Michael Van Canneyt, member of + the Free Pascal development team + Copyright (C) 2013 by Graeme Geldenhuys + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Originally from the Free Pascal FCL. Since then the code has + diverged and was customised for fpGUI usage. + + This is the Client Interface for the debug server, which is + based on SimpleIPC. +} +unit fpg_dbugintf; + +{$mode objfpc}{$h+} + +interface + +uses + Classes, + fpg_base; + +Type + TDebugLevel = (dlStop, dlInformation, dlWarning, dlError, dlIdentify, dlLive); + +procedure SendBoolean(const Identifier: string; const Value: Boolean); +procedure SendDateTime(const Identifier: string; const Value: TDateTime); +procedure SendInteger(const Identifier: string; const Value: Integer; HexNotation: Boolean = False); +procedure SendPoint(const Identifier: string; const Value: TPoint; const ADbgLevel: TDebugLevel = dlLive); +procedure SendPointer(const Identifier: string; const Value: Pointer); +procedure SendRect(const Identifier: string; const Value: TRect; const ADbgLevel: TDebugLevel = dlInformation); +procedure SendRect(const Identifier: string; const Value: TfpgRect; const ADbgLevel: TDebugLevel = dlInformation); +procedure SendDebugEx(const Msg: string; MType: TDebugLevel); +procedure SendDebug(const Msg: string); +procedure SendMethodEnter(const MethodName: string); +procedure SendMethodExit(const MethodName: string); +procedure SendSeparator; +procedure SendDebugFmt(const Msg: string; const Args: array of const); +procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel; const ATitle: string = ''); + +procedure SetDebuggingEnabled(const AValue : boolean); +function GetDebuggingEnabled : Boolean; + +{ low-level routines } + +Function StartDebugServer : integer; +Function InitDebugClient : Boolean; +Function DebugMessageName(msgType: TDebugLevel) : String; + +Const + SendError : String = ''; + +ResourceString + SProcessID = 'Process %s'; + SEntering = '> Entering '; + SExiting = '< Exiting '; + SSeparator = '>-=-=-=-=-=-=-=-=-=-=-=-=-=-=-<'; + SServerStartFailed = 'Failed to start debugserver. (%s)'; + +implementation + +Uses + SysUtils, + process, + simpleipc, + fpg_dbugmsg; + +const + IndentChars = 2; + +var + DebugClient : TSimpleIPCClient = nil; + MsgBuffer : TMemoryStream = Nil; + ServerID : Integer; + DebugDisabled : Boolean = False; + Indent : Integer = 0; + +function RectToStr(const ARect: TRect): String; +begin + with ARect do + Result := Format('(Left: %d; Top: %d; Right: %d; Bottom: %d)', [Left, Top, Right, Bottom]); +end; + +function fpgRectToStr(const ARect: TfpgRect): String; +begin + with ARect do + Result := Format('(Left: %d; Top: %d; Width: %d; Height: %d)', [Left, Top, Width, Height]); +end; + +function PointToStr(const APoint: TPoint): String; +begin + with APoint do + Result := Format('(X: %d; Y: %d)', [X, Y]); +end; + +procedure WriteMessage(Const Msg : TDebugMessage); +begin + MsgBuffer.Seek(0, soFromBeginning); + WriteDebugMessageToStream(MsgBuffer, Msg); + DebugClient.SendMessage(mtUnknown, MsgBuffer); +end; + +procedure SendDebugMessage(Var Msg : TDebugMessage); +begin + if DebugDisabled then exit; + try + If (DebugClient=Nil) then + if InitDebugClient = false then exit; + if (Indent > 0) then + Msg.Msg := StringOfChar(' ', Indent) + Msg.Msg; + WriteMessage(Msg); + except + On E: Exception do + SendError := E.Message; + end; +end; + +procedure SendBoolean(const Identifier: string; const Value: Boolean); +const + Booleans : Array[Boolean] of string = ('False','True'); +begin + SendDebugFmt('%s = %s',[Identifier,Booleans[value]]); +end; + +procedure SendDateTime(const Identifier: string; const Value: TDateTime); +begin + SendDebugFmt('%s = %s',[Identifier,DateTimeToStr(Value)]); +end; + +procedure SendInteger(const Identifier: string; const Value: Integer; HexNotation: Boolean = False); +const + Msgs : Array[Boolean] of string = ('%s = %d','%s = %x'); +begin + SendDebugFmt(Msgs[HexNotation],[Identifier,Value]); +end; + +procedure SendPoint(const Identifier: string; const Value: TPoint; const ADbgLevel: TDebugLevel); +begin + SendDebugFmtEx('%s = %s',[Identifier, PointToStr(Value)], ADbgLevel); +end; + +procedure SendPointer(const Identifier: string; const Value: Pointer); +begin + SendDebugFmt('%s = %p',[Identifier,Value]); +end; + +procedure SendRect(const Identifier: string; const Value: TRect; const ADbgLevel: TDebugLevel); +begin + SendDebugFmtEx('%s',[RectToStr(Value)], ADbgLevel, Identifier); +end; + +procedure SendRect(const Identifier: string; const Value: TfpgRect; const ADbgLevel: TDebugLevel); +begin + SendDebugFmtEx('%s',[fpgRectToStr(Value)], ADbgLevel, Identifier); +end; + +procedure SendDebugEx(const Msg: string; MType: TDebugLevel); +var + Mesg : TDebugMessage; +begin + Mesg.MsgTimeStamp:=Now; + Mesg.MsgType:=Ord(MTYpe); + Mesg.Msg:=Msg; + SendDebugMessage(Mesg); +end; + +procedure SendDebug(const Msg: string); +var + Mesg : TDebugMessage; +begin + Mesg.MsgTimeStamp:=Now; + Mesg.MsgType:=Ord(dlInformation); + Mesg.Msg:=Msg; + SendDebugMessage(Mesg); +end; + +procedure SendMethodEnter(const MethodName: string); +begin + SendDebug(SEntering+MethodName); + inc(Indent,IndentChars); +end; + +procedure SendMethodExit(const MethodName: string); +begin + Dec(Indent,IndentChars); + If (Indent<0) then + Indent:=0; + SendDebug(SExiting+MethodName); +end; + +procedure SendSeparator; +begin + SendDebug(SSeparator); +end; + +procedure SendDebugFmt(const Msg: string; const Args: array of const); +var + Mesg : TDebugMessage; +begin + Mesg.MsgTimeStamp:=Now; + Mesg.MsgType:= Ord(dlInformation); + Mesg.Msg:=Format(Msg,Args); + SendDebugMessage(Mesg); +end; + +procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel; const ATitle: string); +var + Mesg: TDebugMessage; +begin + Mesg.MsgTimeStamp := Now; + Mesg.MsgType := Ord(mType); + if MType = dlLive then + Mesg.MsgTitle := ATitle + else + Mesg.MsgTitle := ' '; + Mesg.Msg := Format(Msg,Args); + SendDebugMessage(Mesg); +end; + +procedure SetDebuggingEnabled(const AValue: boolean); +begin + DebugDisabled := not AValue; +end; + +function GetDebuggingEnabled: Boolean; +begin + Result := not DebugDisabled; +end; + +function StartDebugServer : Integer; +begin + With TProcess.Create(Nil) do + begin + Try + CommandLine:='dbugsrv'; + Execute; + Result:=ProcessID; + Except On E: Exception do + begin + SendError := Format(SServerStartFailed,[E.Message]); + Result := 0; + end; + end; + Free; + end; +end; + +procedure FreeDebugClient; +var + msg : TDebugMessage; +begin + try + If (DebugClient<>Nil) and + (DebugClient.ServerRunning) then + begin + Msg.MsgType := Ord(dlStop); + Msg.MsgTimeStamp := Now; + Msg.Msg := Format(SProcessID,[ApplicationName]); + WriteMessage(Msg); + end; + if assigned(MsgBuffer) then + FreeAndNil(MsgBuffer); + if assigned(DebugClient) then + FreeAndNil(DebugClient); + except + end; +end; + +function InitDebugClient : Boolean; +var + msg : TDebugMessage; + I : Integer; +begin + Result := False; + DebugClient:=TSimpleIPCClient.Create(Nil); + DebugClient.ServerID:=DebugServerID; + If not DebugClient.ServerRunning then + begin + ServerID:=StartDebugServer; + if ServerID = 0 then + begin + DebugDisabled := True; + FreeAndNil(DebugClient); + Exit; + end + else + DebugDisabled := False; + I:=0; + While (I<10) and not DebugClient.ServerRunning do + begin + Inc(I); + Sleep(100); + end; + end; + try + DebugClient.Connect; + except + FreeAndNil(DebugClient); + DebugDisabled:=True; + Raise; + end; + MsgBuffer := TMemoryStream.Create; + Msg.MsgType := Ord(dlIdentify); + Msg.MsgTimeStamp := Now; + Msg.Msg := Format(SProcessID,[ApplicationName]); + WriteMessage(Msg); + Result := True; +end; + +Function DebugMessageName(msgType : TDebugLevel) : String; +begin + Case MsgType of + dlStop : Result := 'Stop'; + dlInformation : Result := 'Information'; + dlWarning : Result := 'Warning'; + dlError : Result := 'Error'; + dlIdentify : Result := 'Identify'; + dlLive : Result := 'LiveView'; + else + Result := 'Unknown'; + end; +end; + + +finalization + FreeDebugClient; + +end. diff --git a/src/corelib/fpg_dbugmsg.pas b/src/corelib/fpg_dbugmsg.pas new file mode 100644 index 00000000..502b697e --- /dev/null +++ b/src/corelib/fpg_dbugmsg.pas @@ -0,0 +1,95 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2005 by Michael Van Canneyt, member of + the Free Pascal development team + Copyright (C) 2013 by Graeme Geldenhuys + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Originally from the Free Pascal FCL. Since then the code has + diverged and was customised for fpGUI usage. +} +unit fpg_dbugmsg; + +{$mode objfpc}{$h+} + +interface + +uses Classes; + +Const + DebugServerID : String = 'fpgDebugServer'; + +Type + TDebugMessage = record + MsgType : Integer; + MsgTimeStamp : TDateTime; + MsgTitle : string; + Msg : string; + end; + +Procedure ReadDebugMessageFromStream(AStream : TStream; Var Msg : TDebugMessage); +Procedure WriteDebugMessageToStream(AStream : TStream; Const Msg : TDebugMessage); + + +implementation + + +procedure ReadDebugMessageFromStream(AStream : TStream; Var Msg : TDebugMessage); +var + MsgSize: Integer; +begin + MsgSize := 0; + with AStream do + begin + ReadBuffer(Msg.MsgType, SizeOf(Integer)); + ReadBuffer(Msg.MsgTimeStamp, SizeOf(TDateTime)); + + ReadBuffer(MsgSize, SizeOf(Integer)); + SetLength(Msg.MsgTitle, MsgSize); + if (MsgSize<>0) then + ReadBuffer(Msg.MsgTitle[1], MsgSize); + + ReadBuffer(MsgSize, SizeOf(Integer)); + SetLength(Msg.Msg, MsgSize); + if (MsgSize<>0) then + ReadBuffer(Msg.Msg[1], MsgSize); + end; +end; + +procedure WriteDebugMessageToStream(AStream : TStream; Const Msg : TDebugMessage); +var + MsgSize : Integer; + lTitle: string; +begin + with AStream do + begin + WriteBuffer(Msg.MsgType, SizeOf(Integer)); + WriteBuffer(Msg.MsgTimeStamp, SizeOf(TDateTime)); + + MsgSize := Length(Msg.MsgTitle); + if MsgSize = 0 then // fake a title + begin + MsgSize := 1; + lTitle := ' '; + end + else + lTitle := Msg.MsgTitle; + WriteBuffer(MsgSize, SizeOf(Integer)); + WriteBuffer(lTitle[1], MsgSize); + + MsgSize := Length(Msg.Msg); + WriteBuffer(MsgSize, SizeOf(Integer)); + WriteBuffer(Msg.Msg[1], MsgSize); + end; +end; + + +end. diff --git a/src/corelib/fpg_imgfmt_png.pas b/src/corelib/fpg_imgfmt_png.pas index c95150e4..d9683bbe 100644 --- a/src/corelib/fpg_imgfmt_png.pas +++ b/src/corelib/fpg_imgfmt_png.pas @@ -68,6 +68,7 @@ end; function LoadImage_PNG(const AFileName: TfpgString): TfpgImage; var imga: TFPCustomImage; + PNGReader: TFPReaderPNG; begin Result := nil; if not fpgFileExists(AFileName) then @@ -75,7 +76,12 @@ begin imga := TFPMemoryImage.Create(0, 0); try - imga.LoadFromFile(AFileName, TFPReaderPNG.Create); // auto size image + PNGReader := TFPReaderPNG.Create; + try + imga.LoadFromFile(AFileName, PNGReader); // auto size image + finally + PNGReader.Free; + end; except imga := nil; end; diff --git a/src/corelib/fpg_main.pas b/src/corelib/fpg_main.pas index 44ab6a82..2e255923 100644 --- a/src/corelib/fpg_main.pas +++ b/src/corelib/fpg_main.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -47,7 +47,7 @@ type TAnchors = set of TAnchor; TfpgButtonFlags = set of (btfIsEmbedded, btfIsDefault, btfIsPressed, - btfIsSelected, btfHasFocus, btfHasParentColor, btfFlat, btfHover); + btfIsSelected, btfHasFocus, btfHasParentColor, btfFlat, btfHover, btfDisabled); TfpgMenuItemFlags = set of (mifSelected, mifHasFocus, mifSeparator, mifEnabled, mifChecked, mifSubMenu); @@ -78,8 +78,7 @@ type Public event properties: Event Types *******************************************} { Keyboard } - TKeyEvent = procedure(Sender: TObject; AKey: Word; AShift: TShiftState) of object; - TKeyCharEvent = procedure(Sender: TObject; AKeyChar: Char) of object; + TfpgKeyCharEvent = procedure(Sender: TObject; AChar: TfpgChar; var Consumed: boolean) of object; TKeyPressEvent = procedure(Sender: TObject; var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean) of object; { Mouse } TMouseButtonEvent = procedure(Sender: TObject; AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint) of object; @@ -176,8 +175,6 @@ type // As soon as TfpgStyle has moved out of CoreLib, these must go! procedure DrawButtonFace(x, y, w, h: TfpgCoord; AFlags: TfpgButtonFlags); overload; procedure DrawButtonFace(r: TfpgRect; AFlags: TfpgButtonFlags); overload; - procedure DrawControlFrame(x, y, w, h: TfpgCoord); overload; - procedure DrawControlFrame(r: TfpgRect); overload; procedure DrawBevel(x, y, w, h: TfpgCoord; ARaised: Boolean = True); overload; procedure DrawBevel(r: TfpgRect; ARaised: Boolean = True); overload; procedure DrawDirectionArrow(x, y, w, h: TfpgCoord; direction: TArrowDirection); overload; @@ -224,6 +221,12 @@ type function GetSeparatorSize: integer; virtual; { Editbox } procedure DrawEditBox(ACanvas: TfpgCanvas; const r: TfpgRect; const IsEnabled: Boolean; const IsReadOnly: Boolean; const ABackgroundColor: TfpgColor); virtual; + { Combobox } + procedure DrawStaticComboBox(ACanvas: TfpgCanvas; r: TfpgRect; const IsEnabled: Boolean; const IsFocused: Boolean; const IsReadOnly: Boolean; const ABackgroundColor: TfpgColor; const AInternalBtnRect: TfpgRect; const ABtnPressed: Boolean); virtual; + procedure DrawInternalComboBoxButton(ACanvas: TfpgCanvas; r: TfpgRect; const IsEnabled: Boolean; const IsPressed: Boolean); virtual; + { Checkbox } + function GetCheckBoxSize: integer; virtual; + procedure DrawCheckbox(ACanvas: TfpgCanvas; x, y: TfpgCoord; ix, iy: TfpgCoord); virtual; end; @@ -395,10 +398,15 @@ function fpgGetTickCount: DWord; procedure fpgPause(MilliSeconds: Cardinal); // Rectangle, Point & Size routines +function CopyRect(out Dest: TfpgRect; const Src: TfpgRect): Boolean; function InflateRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean; function InflateRect(var Rect: TfpgRect; dx: Integer; dy: Integer): Boolean; +function IntersectRect(out ARect: TfpgRect; const r1, r2: TfpgRect): Boolean; +function IsRectEmpty(const ARect: TfpgRect): Boolean; function OffsetRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean; function OffsetRect(var Rect: TfpgRect; dx: Integer; dy: Integer): Boolean; +function PtInRect(const ARect: TfpgRect; const APoint: TPoint): Boolean; +function UniongRect(out ARect: TfpgRect; const R1, R2: TfpgRect): Boolean; function CenterPoint(const Rect: TRect): TPoint; function CenterPoint(const Rect: TfpgRect): TPoint; function fpgRect(ALeft, ATop, AWidth, AHeight: integer): TfpgRect; @@ -422,11 +430,12 @@ procedure DebugLn(const s1, s2: TfpgString); procedure DebugLn(const s1, s2, s3: TfpgString); procedure DebugLn(const s1, s2, s3, s4: TfpgString); procedure DebugLn(const s1, s2, s3, s4, s5: TfpgString); -function DebugMethodEnter(const s1: TfpgString): IInterface; +function DebugMethodEnter(const s1: TfpgString): IInterface; procedure DebugSeparator; // operator overloading of some useful structures -operator = (a: TRect; b: TRect): boolean; +operator = (const a, b: TRect): boolean; +operator = (const a, b: TfpgRect): boolean; operator = (const ASize1, ASize2: TfpgSize) b: Boolean; operator = (const APoint1, APoint2: TPoint) b: Boolean; operator + (const APoint1, APoint2: TPoint) p: TPoint; @@ -446,7 +455,8 @@ operator - (const APoint: TfpgPoint; i: Integer) p: TfpgPoint; operator - (const ASize: TfpgSize; const APoint: TPoint) s: TfpgSize; operator - (const ASize: TfpgSize; const APoint: TfpgPoint) s: TfpgSize; operator - (const ASize: TfpgSize; i: Integer) s: TfpgSize; -operator = (const AColor1, AColor2: TFPColor) b: Boolean; +operator = (const AColor1, AColor2: TFPColor) b: Boolean; deprecated; +operator = (const AColor1, AColor2: TRGBTriple) b: Boolean; implementation @@ -458,7 +468,7 @@ uses Agg2D, {$endif} {$IFDEF DEBUG} - dbugintf, + fpg_dbugintf, {$ENDIF} fpg_imgfmt_bmp, fpg_stdimages, @@ -472,7 +482,9 @@ uses fpg_imgutils, fpg_stylemanager, fpg_style_win2k, // TODO: This needs to be removed! - fpg_style_motif; // TODO: This needs to be removed! + fpg_style_motif, // TODO: This needs to be removed! + fpg_style_carbon, + fpg_style_plastic; var fpgTimers: TList; @@ -621,6 +633,17 @@ begin until ((Now*MSecsPerDay)-lStart) > MilliSeconds; end; +function CopyRect(out Dest: TfpgRect; const Src: TfpgRect): Boolean; +begin + Dest := Src; + if IsRectEmpty(Dest) then + begin + FillChar(Dest, SizeOf(Dest), 0); + Result := false; + end + else + Result := true; +end; function InflateRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean; begin @@ -653,6 +676,35 @@ begin Result := False; end; +function IntersectRect(out ARect: TfpgRect; const r1, r2: TfpgRect): Boolean; +begin + ARect := r1; + with r2 do + begin + if Left > r1.Left then + ARect.Left := Left; + if Top > r1.Top then + ARect.Top := Top; + if Right < r1.Right then + ARect.Width := ARect.Left + Right; + if Bottom < r1.Bottom then + ARect.Height := ARect.Top + Bottom; + end; + + if IsRectEmpty(ARect) then + begin + FillChar(ARect, SizeOf(ARect), 0); + Result := false; + end + else + Result := true; +end; + +function IsRectEmpty(const ARect: TfpgRect): Boolean; +begin + Result := (ARect.Width <= 0) or (ARect.Height <= 0); +end; + function OffsetRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean; begin if Assigned(@Rect) then @@ -664,10 +716,10 @@ begin inc(Right, dx); inc(Bottom, dy); end; - OffsetRect := True; + Result := True; end else - OffsetRect := False; + Result := False; end; function OffsetRect(var Rect: TfpgRect; dx: Integer; dy: Integer): Boolean; @@ -679,10 +731,42 @@ begin inc(Left, dx); inc(Top, dy); end; - OffsetRect := True; + Result := True; end else - OffsetRect := False; + Result := False; +end; + +function PtInRect(const ARect: TfpgRect; const APoint: TPoint): Boolean; +begin + Result := (APoint.x >= ARect.Left) and + (APoint.y >= ARect.Top) and + (APoint.x <= ARect.Right) and + (APoint.y <= ARect.Bottom); +end; + +function UniongRect(out ARect: TfpgRect; const R1, R2: TfpgRect): Boolean; +begin + ARect := R1; + with R2 do + begin + if Left < R1.Left then + ARect.Left := Left; + if Top < R1.Top then + ARect.Top := Top; + if Right > R1.Right then + ARect.Width := ARect.Left + Right; + if Bottom > R1.Bottom then + ARect.Height := ARect.Top + Bottom; + end; + + if IsRectEmpty(ARect) then + begin + FillChar(ARect, SizeOf(ARect), 0); + Result := false; + end + else + Result := true; end; function CenterPoint(const Rect: TRect): TPoint; @@ -957,15 +1041,20 @@ begin DebugLn('>--------------------------<'); end; -operator = (a: TRect; b: TRect): boolean; +operator = (const a, b: TRect): boolean; begin - if (a.Top = b.Top) - and (a.Left = b.Left) - and (a.Bottom = b.Bottom) - and (a.Right = b.Right) then - Result := True - else - Result := False; + Result := (a.Top = b.Top) and + (a.Left = b.Left) and + (a.Bottom = b.Bottom) and + (a.Right = b.Right); +end; + +operator = (const a, b: TfpgRect): boolean; +begin + Result := (a.Left = b.Left) and + (a.Top = b.Top) and + (a.Width = b.Width) and + (a.Height = b.Height); end; operator = (const ASize1, ASize2: TfpgSize) b: Boolean; @@ -1088,6 +1177,14 @@ begin and (AColor1.Alpha = AColor2.Alpha); end; +operator = (const AColor1, AColor2: TRGBTriple) b: Boolean; +begin + b := (AColor1.Red = AColor2.Red) + and (AColor1.Green = AColor2.Green) + and (AColor1.Blue = AColor2.Blue) + and (AColor1.Alpha = AColor2.Alpha); +end; + { TfpgTimer } constructor TfpgTimer.Create(AInterval: integer); @@ -1791,16 +1888,6 @@ begin DrawButtonFace(r.Left, r.Top, r.Width, r.Height, AFlags); end; -procedure TfpgCanvas.DrawControlFrame(x, y, w, h: TfpgCoord); -begin - fpgStyle.DrawControlFrame(self, x, y, w, h); -end; - -procedure TfpgCanvas.DrawControlFrame(r: TfpgRect); -begin - DrawControlFrame(r.Left, r.Top, r.Width, r.Height); -end; - procedure TfpgCanvas.DrawBevel(x, y, w, h: TfpgCoord; ARaised: Boolean); begin fpgStyle.DrawBevel(self, x, y, w, h, ARaised); @@ -2008,6 +2095,7 @@ begin fpgSetNamedColor(clGridInactiveSel, $FF99A6BF); // same as clInactiveSel fpgSetNamedColor(clGridInactiveSelText, $FF000000); // same as clInactiveSelText fpgSetNamedColor(clSplitterGrabBar, $FF839EFE); // pale blue + fpgSetNamedColor(clHyperLink, clBlue); // Global Font Objects @@ -2368,6 +2456,83 @@ begin ACanvas.FillRectangle(r); end; +procedure TfpgStyle.DrawStaticComboBox(ACanvas: TfpgCanvas; r: TfpgRect; + const IsEnabled: Boolean; const IsFocused: Boolean; const IsReadOnly: Boolean; + const ABackgroundColor: TfpgColor; const AInternalBtnRect: TfpgRect; + const ABtnPressed: Boolean); +var + lr: TfpgRect; +begin + lr := r; + if IsEnabled then + begin + if IsReadOnly then + ACanvas.SetColor(clWindowBackground) + else + ACanvas.SetColor(ABackgroundColor); + end + else + ACanvas.SetColor(clWindowBackground); + + ACanvas.FillRectangle(r); + + if IsFocused then + begin + ACanvas.SetColor(clSelection); + InflateRect(lr, -1, -1); + ACanvas.FillRectangle(lr); + end; + + // paint the fake dropdown button + DrawInternalComboBoxButton(ACanvas, AInternalBtnRect, IsEnabled, ABtnPressed); +end; + +procedure TfpgStyle.DrawInternalComboBoxButton(ACanvas: TfpgCanvas; + r: TfpgRect; const IsEnabled: Boolean; const IsPressed: Boolean); +var + ar: TfpgRect; + btnflags: TfpgButtonFlags; +begin + btnflags := []; + ar := r; + + { The bounding rectangle for the arrow } + ar.Width := 8; + ar.Height := 6; + ar.Left := r.Left + ((r.Width-ar.Width) div 2); + ar.Top := r.Top + ((r.Height-ar.Height) div 2); + + if IsPressed then + begin + Include(btnflags, btfIsPressed); + OffsetRect(ar, 1, 1); + end; + // paint button face + DrawButtonFace(ACanvas, r.Left, r.Top, r.Width, r.Height, btnflags); + if IsEnabled then + ACanvas.SetColor(clText1) + else + ACanvas.SetColor(clShadow1); + + // paint arrow + DrawDirectionArrow(ACanvas, ar.Left, ar.Top, ar.Width, ar.Height, adDown); +end; + +function TfpgStyle.GetCheckBoxSize: integer; +begin + Result := 13; // 13x13 - it is always a rectangle +end; + +procedure TfpgStyle.DrawCheckbox(ACanvas: TfpgCanvas; x, y: TfpgCoord; ix, iy: TfpgCoord); +var + img: TfpgImage; + size: integer; +begin + img := fpgImages.GetImage('sys.checkboxes'); // Do NOT localize - return value is a reference only + size := GetCheckBoxSize; + ACanvas.DrawImagePart(x, y, img, ix, iy, size, size); +end; + { TfpgCaret } diff --git a/src/corelib/fpg_stringutils.pas b/src/corelib/fpg_stringutils.pas index 1acd518e..7930870b 100644 --- a/src/corelib/fpg_stringutils.pas +++ b/src/corelib/fpg_stringutils.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -58,10 +58,13 @@ function fpgTrimR(const AString, ATrim: TfpgString; ACaseSensitive: boolean = f // Encoding conversions function CP437ToUTF8(const s: string): TfpgString; // DOS central europe function CP850ToUTF8(const s: string): TfpgString; // DOS western europe +function CP866ToUTF8(const s: string): TfpgString; // DOS and Windows console's cyrillic +function CP1250ToUTF8(const s: string): TfpgString; // central europe function IBMGraphToUTF8(const s: string): TfpgString; // IBM PC / DOS http://www.unicode.org/Public/MAPPINGS/VENDORS/MISC/IBMGRAPH.TXT function IPFToUTF8(const s: string): TfpgString; // minor replacements to improve DocView output function SingleByteToUTF8(const s: string; const Table: TCharToUTF8Table): TfpgString; +function ConvertTextToUTF8(const AEncoding: TfpgTextEncoding; const AText: AnsiString): TfpgString; implementation @@ -935,6 +938,525 @@ const ); + ArrayCP866ToUTF8 : TCharToUTF8Table = ( + #0, //#0 + #1, //#1 + #2, //#2 + #3, //#3 + #4, //#4 + #5, //#5 + #6, //#6 + #7, //#7 + #8, //#8 + #9, //#9 + #10, //#10 + #11, //#11 + #12, //#12 + #13, //#13 + #14, //#14 + #15, //#15 + #16, //#16 + #17, //#17 + #18, //#18 + #19, //#19 + #20, //#20 + #21, //#21 + #22, //#22 + #23, //#23 + #24, //#24 + #25, //#25 + #26, //#26 + #27, //#27 + #28, //#28 + #29, //#29 + #30, //#30 + #31, //#31 + #32, //#32 + #33, //#33 + #34, //#34 + #35, //#35 + #36, //#36 + #37, //#37 + #38, //#38 + #39, //#39 + #40, //#40 + #41, //#41 + #42, //#42 + #43, //#43 + #44, //#44 + #45, //#45 + #46, //#46 + #47, //#47 + #48, //#48 + #49, //#49 + #50, //#50 + #51, //#51 + #52, //#52 + #53, //#53 + #54, //#54 + #55, //#55 + #56, //#56 + #57, //#57 + #58, //#58 + #59, //#59 + #60, //#60 + #61, //#61 + #62, //#62 + #63, //#63 + #64, //#64 + #65, //#65 + #66, //#66 + #67, //#67 + #68, //#68 + #69, //#69 + #70, //#70 + #71, //#71 + #72, //#72 + #73, //#73 + #74, //#74 + #75, //#75 + #76, //#76 + #77, //#77 + #78, //#78 + #79, //#79 + #80, //#80 + #81, //#81 + #82, //#82 + #83, //#83 + #84, //#84 + #85, //#85 + #86, //#86 + #87, //#87 + #88, //#88 + #89, //#89 + #90, //#90 + #91, //#91 + #92, //#92 + #93, //#93 + #94, //#94 + #95, //#95 + #96, //#96 + #97, //#97 + #98, //#98 + #99, //#99 + #100, //#100 + #101, //#101 + #102, //#102 + #103, //#103 + #104, //#104 + #105, //#105 + #106, //#106 + #107, //#107 + #108, //#108 + #109, //#109 + #110, //#110 + #111, //#111 + #112, //#112 + #113, //#113 + #114, //#114 + #115, //#115 + #116, //#116 + #117, //#117 + #118, //#118 + #119, //#119 + #120, //#120 + #121, //#121 + #122, //#122 + #123, //#123 + #124, //#124 + #125, //#125 + #126, //#126 + #127, //#127 + #208#144, //#128 + #208#145, //#129 + #208#146, //#130 + #208#147, //#131 + #208#148, //#132 + #208#149, //#133 + #208#150, //#134 + #208#151, //#135 + #208#152, //#136 + #208#153, //#137 + #208#154, //#138 + #208#155, //#139 + #208#156, //#140 + #208#157, //#141 + #208#158, //#142 + #208#159, //#143 + #208#160, //#144 + #208#161, //#145 + #208#162, //#146 + #208#163, //#147 + #208#164, //#148 + #208#165, //#149 + #208#166, //#150 + #208#167, //#151 + #208#168, //#152 + #208#169, //#153 + #208#170, //#154 + #208#171, //#155 + #208#172, //#156 + #208#173, //#157 + #208#174, //#158 + #208#175, //#159 + #208#176, //#160 + #208#177, //#161 + #208#178, //#162 + #208#179, //#163 + #208#180, //#164 + #208#181, //#165 + #208#182, //#166 + #208#183, //#167 + #208#184, //#168 + #208#185, //#169 + #208#186, //#170 + #208#187, //#171 + #208#188, //#172 + #208#189, //#173 + #208#190, //#174 + #208#191, //#175 + #226#150#145, //#176 + #226#150#146, //#177 + #226#150#147, //#178 + #226#148#130, //#179 + #226#148#164, //#180 + #226#149#161, //#181 + #226#149#162, //#182 + #226#149#150, //#183 + #226#149#149, //#184 + #226#149#163, //#185 + #226#149#145, //#186 + #226#149#151, //#187 + #226#149#157, //#188 + #226#149#156, //#189 + #226#149#155, //#190 + #226#148#144, //#191 + #226#148#148, //#192 + #226#148#180, //#193 + #226#148#172, //#194 + #226#148#156, //#195 + #226#148#128, //#196 + #226#148#188, //#197 + #226#149#158, //#198 + #226#149#159, //#199 + #226#149#154, //#200 + #226#149#148, //#201 + #226#149#169, //#202 + #226#149#166, //#203 + #226#149#160, //#204 + #226#149#144, //#205 + #226#149#172, //#206 + #226#149#167, //#207 + #226#149#168, //#208 + #226#149#164, //#209 + #226#149#165, //#210 + #226#149#153, //#211 + #226#149#152, //#212 + #226#149#146, //#213 + #226#149#147, //#214 + #226#149#171, //#215 + #226#149#170, //#216 + #226#148#152, //#217 + #226#148#140, //#218 + #226#150#136, //#219 + #226#150#132, //#220 + #226#150#140, //#221 + #226#150#144, //#222 + #226#150#128, //#223 + #209#128, //#224 + #209#129, //#225 + #209#130, //#226 + #209#131, //#227 + #209#132, //#228 + #209#133, //#229 + #209#134, //#230 + #209#135, //#231 + #209#136, //#232 + #209#137, //#233 + #209#138, //#234 + #209#139, //#235 + #209#140, //#236 + #209#141, //#237 + #209#142, //#238 + #209#143, //#239 + #208#129, //#240 + #209#145, //#241 + #208#132, //#242 + #209#148, //#243 + #208#135, //#244 + #209#151, //#245 + #208#142, //#246 + #209#158, //#247 + #194#176, //#248 + #226#136#153, //#249 + #194#183, //#250 + #226#136#154, //#251 + #226#132#150, //#252 + #194#164, //#253 + #226#150#160, //#254 + #194#160 //#255 + ); + + + ArrayCP1250ToUTF8: TCharToUTF8Table = ( + #0, // #0 + #1, // #1 + #2, // #2 + #3, // #3 + #4, // #4 + #5, // #5 + #6, // #6 + #7, // #7 + #8, // #8 + #9, // #9 + #10, // #10 + #11, // #11 + #12, // #12 + #13, // #13 + #14, // #14 + #15, // #15 + #16, // #16 + #17, // #17 + #18, // #18 + #19, // #19 + #20, // #20 + #21, // #21 + #22, // #22 + #23, // #23 + #24, // #24 + #25, // #25 + #26, // #26 + #27, // #27 + #28, // #28 + #29, // #29 + #30, // #30 + #31, // #31 + ' ', // ' ' + '!', // '!' + '"', // '"' + '#', // '#' + '$', // '$' + '%', // '%' + '&', // '&' + '''', // '''' + '(', // '(' + ')', // ')' + '*', // '*' + '+', // '+' + ',', // ',' + '-', // '-' + '.', // '.' + '/', // '/' + '0', // '0' + '1', // '1' + '2', // '2' + '3', // '3' + '4', // '4' + '5', // '5' + '6', // '6' + '7', // '7' + '8', // '8' + '9', // '9' + ':', // ':' + ';', // ';' + '<', // '<' + '=', // '=' + '>', // '>' + '?', // '?' + '@', // '@' + 'A', // 'A' + 'B', // 'B' + 'C', // 'C' + 'D', // 'D' + 'E', // 'E' + 'F', // 'F' + 'G', // 'G' + 'H', // 'H' + 'I', // 'I' + 'J', // 'J' + 'K', // 'K' + 'L', // 'L' + 'M', // 'M' + 'N', // 'N' + 'O', // 'O' + 'P', // 'P' + 'Q', // 'Q' + 'R', // 'R' + 'S', // 'S' + 'T', // 'T' + 'U', // 'U' + 'V', // 'V' + 'W', // 'W' + 'X', // 'X' + 'Y', // 'Y' + 'Z', // 'Z' + '[', // '[' + '\', // '\' + ']', // ']' + '^', // '^' + '_', // '_' + '`', // '`' + 'a', // 'a' + 'b', // 'b' + 'c', // 'c' + 'd', // 'd' + 'e', // 'e' + 'f', // 'f' + 'g', // 'g' + 'h', // 'h' + 'i', // 'i' + 'j', // 'j' + 'k', // 'k' + 'l', // 'l' + 'm', // 'm' + 'n', // 'n' + 'o', // 'o' + 'p', // 'p' + 'q', // 'q' + 'r', // 'r' + 's', // 's' + 't', // 't' + 'u', // 'u' + 'v', // 'v' + 'w', // 'w' + 'x', // 'x' + 'y', // 'y' + 'z', // 'z' + '{', // '{' + '|', // '|' + '}', // '}' + '~', // '~' + #127, // #127 + #226#130#172, // #128 + '', // #129 + #226#128#154, // #130 + '', // #131 + #226#128#158, // #132 + #226#128#166, // #133 + #226#128#160, // #134 + #226#128#161, // #135 + '', // #136 + #226#128#176, // #137 + #197#160, // #138 + #226#128#185, // #139 + #197#154, // #140 + #197#164, // #141 + #197#189, // #142 + #197#185, // #143 + '', // #144 + #226#128#152, // #145 + #226#128#153, // #146 + #226#128#156, // #147 + #226#128#157, // #148 + #226#128#162, // #149 + #226#128#147, // #150 + #226#128#148, // #151 + '', // #152 + #226#132#162, // #153 + #197#161, // #154 + #226#128#186, // #155 + #197#155, // #156 + #197#165, // #157 + #197#190, // #158 + #197#186, // #159 + #194#160, // #160 + #203#135, // #161 + #203#152, // #162 + #197#129, // #163 + #194#164, // #164 + #196#132, // #165 + #194#166, // #166 + #194#167, // #167 + #194#168, // #168 + #194#169, // #169 + #197#158, // #170 + #194#171, // #171 + #194#172, // #172 + #194#173, // #173 + #194#174, // #174 + #197#187, // #175 + #194#176, // #176 + #194#177, // #177 + #203#155, // #178 + #197#130, // #179 + #194#180, // #180 + #194#181, // #181 + #194#182, // #182 + #194#183, // #183 + #194#184, // #184 + #196#133, // #185 + #197#159, // #186 + #194#187, // #187 + #196#189, // #188 + #203#157, // #189 + #196#190, // #190 + #197#188, // #191 + #197#148, // #192 + #195#129, // #193 + #195#130, // #194 + #196#130, // #195 + #195#132, // #196 + #196#185, // #197 + #196#134, // #198 + #195#135, // #199 + #196#140, // #200 + #195#137, // #201 + #196#152, // #202 + #195#139, // #203 + #196#154, // #204 + #195#141, // #205 + #195#142, // #206 + #196#142, // #207 + #196#144, // #208 + #197#131, // #209 + #197#135, // #210 + #195#147, // #211 + #195#148, // #212 + #197#144, // #213 + #195#150, // #214 + #195#151, // #215 + #197#152, // #216 + #197#174, // #217 + #195#154, // #218 + #197#176, // #219 + #195#156, // #220 + #195#157, // #221 + #197#162, // #222 + #195#159, // #223 + #197#149, // #224 + #195#161, // #225 + #195#162, // #226 + #196#131, // #227 + #195#164, // #228 + #196#186, // #229 + #196#135, // #230 + #195#167, // #231 + #196#141, // #232 + #195#169, // #233 + #196#153, // #234 + #195#171, // #235 + #196#155, // #236 + #195#173, // #237 + #195#174, // #238 + #196#143, // #239 + #196#145, // #240 + #197#132, // #241 + #197#136, // #242 + #195#179, // #243 + #195#180, // #244 + #197#145, // #245 + #195#182, // #246 + #195#183, // #247 + #197#153, // #248 + #197#175, // #249 + #195#186, // #250 + #197#177, // #251 + #195#188, // #252 + #195#189, // #253 + #197#163, // #254 + #203#153 // #255 + ); + ArrayIBMGraphToUTF8: TCharToUTF8Table = ( #0, // #0 @@ -1465,6 +1987,16 @@ begin Result := SingleByteToUTF8(s, ArrayCP850ToUTF8); end; +function CP866ToUTF8(const s: string): TfpgString; +begin + Result := SingleByteToUTF8(s, ArrayCP866ToUTF8); +end; + +function CP1250ToUTF8(const s: string): TfpgString; +begin + Result := SingleByteToUTF8(s, ArrayCP1250ToUTF8); +end; + function IBMGraphToUTF8(const s: string): TfpgString; begin Result := SingleByteToUTF8(s, ArrayIBMGraphToUTF8); @@ -1539,6 +2071,19 @@ begin SetLength(Result, PtrUInt(Dest)-PtrUInt(Result)); end; +function ConvertTextToUTF8(const AEncoding: TfpgTextEncoding; const AText: AnsiString): TfpgString; +begin + case AEncoding of + encUTF8: Result := IPFToUTF8(AText); + encCP437: Result := CP437ToUTF8(AText); + encCP850: Result := CP850ToUTF8(AText); + encCP866: Result := CP866ToUTF8(AText); + encIBMGraph: Result := IBMGraphToUTF8(AText); + else + Result := IPFToUTF8(AText); + end; +end; + end. diff --git a/src/corelib/fpg_utils.pas b/src/corelib/fpg_utils.pas index 9d0e907d..9a135d73 100644 --- a/src/corelib/fpg_utils.pas +++ b/src/corelib/fpg_utils.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -51,6 +51,7 @@ function fpgIsBitSet(const AData: integer; const AIndex: integer): boolean; // RTL wrapper filesystem functions with platform independant encoding // These functions are common for all platforms and rely on fpgXXXPlatformEncoding +function fpgApplicationName: TfpgString; function fpgFindFirst(const Path: TfpgString; Attr: longint; out Rslt: TSearchRec): longint; function fpgFindNext(var Rslt: TSearchRec): longint; function fpgGetCurrentDir: TfpgString; @@ -63,7 +64,7 @@ function fpgExtractFileDir(const FileName: TfpgString): TfpgString; function fpgExtractFilePath(const FileName: TfpgString): TfpgString; function fpgExtractFileName(const FileName: TfpgString): TfpgString; function fpgExtractFileExt(const FileName: TfpgString): TfpgString; -function fpgExtractRelativepath(const ABaseName, ADestName: TfpgString): TfpgString; +function fpgExtractRelativePath(const ABaseName, ADestName: TfpgString): TfpgString; function fpgForceDirectories(const ADirectory: TfpgString): Boolean; function fpgChangeFileExt(const FileName, Extension: TfpgString): TfpgString; function fpgGetAppConfigDir(const Global: Boolean): TfpgString; @@ -101,6 +102,11 @@ begin Result := ALine; end; +function fpgApplicationName: TfpgString; +begin + Result := fpgFromOSEncoding(ApplicationName); +end; + function fpgFindFirst(const Path: TfpgString; Attr: longint; out Rslt: TSearchRec): longint; begin Result := FindFirst(fpgToOSEncoding(Path), Attr, Rslt); @@ -165,7 +171,7 @@ begin Result := ExtractFileExt(fpgToOSEncoding(Filename)); end; -function fpgExtractRelativepath(const ABaseName, ADestName: TfpgString): TfpgString; +function fpgExtractRelativePath(const ABaseName, ADestName: TfpgString): TfpgString; begin Result := ExtractRelativepath(fpgToOSEncoding(ABaseName), fpgToOSEncoding(ADestName)); end; diff --git a/src/corelib/fpg_widget.pas b/src/corelib/fpg_widget.pas index ae18ff98..527e2987 100644 --- a/src/corelib/fpg_widget.pas +++ b/src/corelib/fpg_widget.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -52,6 +52,7 @@ type FOnDragLeave: TNotifyEvent; FOnEnter: TNotifyEvent; FOnExit: TNotifyEvent; + FOnKeyChar: TfpgKeyCharEvent; FOnMouseDown: TMouseButtonEvent; FOnMouseEnter: TNotifyEvent; FOnMouseExit: TNotifyEvent; @@ -151,6 +152,7 @@ type property OnDoubleClick: TMouseButtonEvent read FOnDoubleClick write FOnDoubleClick; property OnEnter: TNotifyEvent read FOnEnter write FOnEnter; property OnExit: TNotifyEvent read FOnExit write FOnExit; + property OnKeyChar: TfpgKeyCharEvent read FOnKeyChar write FOnKeyChar; property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress; property OnMouseDown: TMouseButtonEvent read FOnMouseDown write FOnMouseDown; property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; @@ -167,6 +169,7 @@ type destructor Destroy; override; procedure AfterConstruction; override; function InDesigner: boolean; + function IsLoading: boolean; procedure InvokeHelp; virtual; procedure Realign; procedure SetFocus; @@ -438,6 +441,11 @@ begin Result := (FFormDesigner <> nil) end; +function TfpgWidget.IsLoading: boolean; +begin + Result := csLoading in ComponentState; +end; + procedure TfpgWidget.InvokeHelp; begin case HelpType of @@ -955,7 +963,8 @@ end; procedure TfpgWidget.HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: boolean); begin - // descendants will implement this. + if FFocusable and Assigned(OnKeyChar) then + OnKeyChar(self, AText, consumed); end; procedure TfpgWidget.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; @@ -974,8 +983,11 @@ begin if not consumed and (keycode = fpgApplication.HelpKey) and (shiftstate=[]) then begin - InvokeHelp; - consumed := True; + if fpgApplication.HelpFile <> '' then + begin + InvokeHelp; + consumed := True; + end; end; case keycode of diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 196e467a..93d3a9ed 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -40,7 +40,7 @@ uses fpg_base, fpg_impl {$IFDEF DEBUG} - ,dbugintf + ,fpg_dbugintf {$ENDIF DEBUG} ,fpg_OLEDragDrop ; @@ -147,6 +147,7 @@ type public constructor Create(awin: TfpgWindowBase); override; destructor Destroy; override; + procedure CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; var ASrcRect: TfpgRect); override; end; @@ -262,10 +263,13 @@ type TfpgGDIFileList = class(TfpgFileListBase) + private function EncodeAttributesString(attrs: longword): TFileModeString; - constructor Create; override; + protected function InitializeEntry(sr: TSearchRec): TFileEntry; override; procedure PopulateSpecialDirs(const aDirectory: TfpgString); override; + public + constructor Create; override; end; @@ -705,6 +709,7 @@ var wmsg: TMsg; PaintStruct: TPaintStruct; TmpW: widestring; + wheelpos: integer; //------------ procedure SetMinMaxInfo(var MinMaxInfo: TMINMAXINFO); @@ -722,7 +727,7 @@ var dy := 0; IntfWidth := AWidth; IntfHeight := AHeight; - + GetWindowBorderDimensions(w, dx, dy); Inc(IntfWidth, dx); Inc(IntfHeight, dy); @@ -850,7 +855,7 @@ begin msgp.keyboard.keychar := UTF8Encode(tmpW); fpgSendMessage(nil, w, FPGM_KEYCHAR, msgp); end; - + // Allow Alt+F4 and other system key combinations if (uMsg = WM_SYSKEYUP) or (uMsg = WM_SYSKEYDOWN) then Result := Windows.DefWindowProc(hwnd, uMsg, wParam, lParam); @@ -877,7 +882,7 @@ begin begin {$IFDEF DEBUG} if uMsg <> WM_MOUSEMOVE then - writeln('fpGFX/GDI: Found a mouse button event'); + SendDebug('fpGFX/GDI: Found a mouse button event'); {$ENDIF} // msgp.mouse.x := smallint(lParam and $FFFF); // msgp.mouse.y := smallint((lParam and $FFFF0000) shr 16); @@ -962,7 +967,7 @@ begin end; mcode := FPGM_MOUSEDOWN; end; - + WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP: @@ -1000,7 +1005,7 @@ begin WM_LBUTTONDOWN, WM_LBUTTONUP: msgp.mouse.Buttons := MOUSE_LEFT; - + WM_MBUTTONDOWN, WM_MBUTTONUP: msgp.mouse.Buttons := MOUSE_MIDDLE; @@ -1029,8 +1034,8 @@ begin begin if w.FSkipResizeMessage then Exit; - - // note that WM_SIZING allows some control on sizeing + + // note that WM_SIZING allows some control on sizing //writeln('WM_SIZE: wp=',IntToHex(wparam,8), ' lp=',IntToHex(lparam,8)); msgp.rect.Width := smallint(lParam and $FFFF); msgp.rect.Height := smallint((lParam and $FFFF0000) shr 16); @@ -1090,7 +1095,13 @@ begin begin msgp.mouse.x := pt.x; msgp.mouse.y := pt.y; - msgp.mouse.delta := SmallInt(HiWord(wParam)) div -120; + { calculate direction of the mouse wheel } + wheelpos := 0; + dec(wheelpos, SmallInt(HiWord(wParam))); + if wheelpos > 0 then + msgp.mouse.delta := 1 + else + msgp.mouse.delta := -1; i := 0; if (wParam and MK_LBUTTON) <> 0 then @@ -1128,7 +1139,7 @@ begin {$IFDEF DEBUG} SendDebug(w.ClassName + ': WM_TIMECHANGE'); {$ENDIF} - writeln('fpGUI/GDI: ' + w.ClassName + ': WM_TIMECHANGE'); +// writeln('fpGUI/GDI: ' + w.ClassName + ': WM_TIMECHANGE'); fpgResetAllTimers; end; @@ -1248,6 +1259,8 @@ begin end; function TfpgGDIApplication.GetHiddenWindow: HWND; +var + lHandle: TfpgWinHandle; begin if (FHiddenWindow = 0) then begin @@ -1263,8 +1276,12 @@ begin end; Windows.RegisterClass(@HiddenWndClass); + if MainForm <> nil then + lHandle := TfpgGDIWindow(MainForm).FWinHandle + else + lHandle := -1; FHiddenWindow := CreateWindow('FPGHIDDEN', '', - DWORD(WS_POPUP), 0, 0, 0, 0, TfpgGDIWindow(MainForm).FWinHandle, 0, MainInstance, nil); + DWORD(WS_POPUP), 0, 0, 0, 0, lHandle, 0, MainInstance, nil); end; Result := FHiddenWindow; end; @@ -1413,7 +1430,7 @@ var wg: TfpgWidget; begin {$IFDEF DND_DEBUG} - writeln('TfpgGDIWindow.HandleDNDLeave '); + SendDebug('TfpgGDIWindow.HandleDNDLeave '); {$ENDIF} FUserMimeSelection := ''; wg := self as TfpgWidget; @@ -1437,7 +1454,7 @@ var msgp: TfpgMessageParams; begin {$IFDEF DND_DEBUG} - writeln('TfpgGDIWindow.HandleDNDEnter '); + SendDebug('TfpgGDIWindow.HandleDNDEnter '); {$ENDIF} wg := self as TfpgWidget; if wg.AcceptDrops then @@ -1500,7 +1517,7 @@ begin if FDropPos <> PT then begin {$IFDEF DND_DEBUG} - writeln('TfpgGDIWindow.HandleDNDPosition '); + SendDebug('TfpgGDIWindow.HandleDNDPosition '); {$ENDIF} FDropPos.x := PT.x; FDropPos.y := PT.y; @@ -1521,12 +1538,13 @@ var swg: TfpgWidget; { source widget } CF: DWORD; lIsTranslated: Boolean; + lPoint: Windows.Point; begin if not FUserAcceptDrag then exit; {$IFDEF DND_DEBUG} - Writeln('TfpgGDIWindow.HandleDNDDrop'); + SendDebug('TfpgGDIWindow.HandleDNDDrop'); {$ENDIF} wg := self as TfpgWidget; @@ -1546,7 +1564,11 @@ begin swg := uDragSource as TfpgWidget else swg := nil; - wg.OnDragDrop(wg, swg, pt.x, pt.y, data); + // convert mouse screen coordinates to widget coordinates + lPoint.x := pt.x; + lPoint.y := pt.y; + ScreenToClient(wg.WinHandle, lPoint); + wg.OnDragDrop(wg, swg, lPoint.x, lPoint.y, data); uDragSource := nil; end; GlobalUnlock(stgmed.HGLOBAL); @@ -1603,7 +1625,7 @@ begin CurrentWindowHndl := WindowFromPoint(spt); CursorInDifferentWindow := (CurrentWindowHndl <> uLastWindowHndl); - + if CursorInDifferentWindow then begin FillChar(msgp, sizeof(msgp), 0); @@ -1623,7 +1645,7 @@ begin fpgSendMessage(nil, CurrentWindow, FPGM_MOUSEENTER, msgp); end; end; - + uLastWindowHndl := CurrentWindowHndl; end; @@ -1646,18 +1668,18 @@ begin FNonFullscreenRect.Left := 0; if FNonFullscreenRect.Top < 0 then FNonFullscreenRect.Top := 0; - + Left := 0; Top := 0; Width := wapplication.GetScreenWidth; Height := wapplication.GetScreenHeight; - + if aUpdate then UpdateWindowPosition; FWinStyle := WS_POPUP or WS_SYSMENU; FWinStyle := FWinStyle and not(WS_CAPTION or WS_THICKFRAME); - + if aUpdate then begin {$IFDEF CPU64} @@ -1687,7 +1709,7 @@ begin Top := FNonFullscreenRect.Top; Width := FNonFullscreenRect.Width; Height := FNonFullscreenRect.Height; - + if aUpdate then UpdateWindowPosition; end; @@ -1710,7 +1732,7 @@ var begin if FWinHandle > 0 then Exit; //==> - + FSkipResizeMessage := True; FWinStyle := WS_OVERLAPPEDWINDOW; @@ -1766,7 +1788,7 @@ begin FWinStyle := FWinStyle and not (WS_SIZEBOX or WS_MAXIMIZEBOX); FWinStyle := FWinStyle or WS_CLIPCHILDREN or WS_CLIPSIBLINGS; - + if waFullScreen in FWindowAttributes then WindowSetFullscreen(True, False); @@ -2131,6 +2153,27 @@ begin inherited; end; +procedure TfpgGDICanvas.CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; + var ASrcRect: TfpgRect); +var + srcdc: HDC; + destdc: HDC; +begin + if (TfpgWindow(FWindow).WinHandle <= 0) or (TfpgWindow(TfpgGDICanvas(ASrcCanvas).FWindow).WinHandle <= 0) then + begin + debugln(' no winhandle available'); + exit; + end; + + destdc := Windows.GetDC(TfpgWindow(FWindow).WinHandle); + srcdc := Windows.GetDC(TfpgWindow(TfpgGDICanvas(ASrcCanvas).FWindow).WinHandle); + + BitBlt(destdc, ADest_x, ADest_y, ASrcRect.Width, ASrcRect.Height, srcdc, ASrcRect.Left, ASrcRect.Top, SRCCOPY); + + ReleaseDC(TfpgWindow(TfpgGDICanvas(ASrcCanvas).FWindow).WinHandle, srcdc); + ReleaseDC(TfpgWindow(FWindow).WinHandle, destdc); +end; + procedure TfpgGDICanvas.DoBeginDraw(awin: TfpgWindowBase; buffered: boolean); var ARect: TfpgRect; @@ -2199,7 +2242,7 @@ begin DeleteObject(FClipRegion); TryFreeBackBuffer; - + Windows.ReleaseDC(FDrawWindow.FWinHandle, FWingc); FDrawing := False; @@ -2457,7 +2500,7 @@ begin if FBufferBitmap > 0 then DeleteObject(FBufferBitmap); FBufferBitmap := 0; - + if FBufgc > 0 then DeleteDC(FBufgc); FBufgc := 0; @@ -2882,7 +2925,7 @@ var drvs: string; begin FSpecialDirs.Clear; - + // making drive list if Copy(aDirectory, 2, 1) = ':' then begin @@ -3089,7 +3132,11 @@ begin ActiveX.RevokeDragDrop(TfpgWidget(FDropTarget).WinHandle); end; -procedure TimerCallBackProc(window_hwnd : hwnd; msg : DWORD; idEvent: UINT; dwTime: DWORD); stdcall; +{$IF FPC_FULLVERSION<20602} +procedure TimerCallBackProc(hWnd: HWND; uMsg: UINT; idEvent: UINT; dwTime: DWORD); stdcall; +{$ELSE} +procedure TimerCallBackProc(hWnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall; +{$IFEND} begin { idEvent contains the handle to the timer that got triggered } fpgCheckTimers; @@ -3102,7 +3149,6 @@ begin inherited SetEnabled(AValue); if FEnabled then begin -// FHandle := Windows.SetTimer(0, 0, Interval, nil); FHandle := Windows.SetTimer(0, 0, Interval, @TimerCallBackProc); end else @@ -3164,7 +3210,7 @@ initialization GetVersionEx(WinVersion); UnicodeEnabledOS := (WinVersion.dwPlatformID = VER_PLATFORM_WIN32_NT) or (WinVersion.dwPlatformID = VER_PLATFORM_WIN32_CE); - + if SystemParametersInfo(SPI_GETFONTSMOOTHINGTYPE, 0, @FontSmoothingType, 0) and (FontSmoothingType = FE_FONTSMOOTHINGCLEARTYPE) then FontSmoothingType := CLEARTYPE_QUALITY diff --git a/src/corelib/gdi/fpgui_toolkit.lpk b/src/corelib/gdi/fpgui_toolkit.lpk index bf019e5f..f2dc4202 100644 --- a/src/corelib/gdi/fpgui_toolkit.lpk +++ b/src/corelib/gdi/fpgui_toolkit.lpk @@ -1,4 +1,4 @@ -<?xml version="1.0"?> +<?xml version="1.0" encoding="UTF-8"?> <CONFIG> <Package Version="4"> <PathDelim Value="\"/> @@ -31,7 +31,7 @@ <Description Value="fpGUI Toolkit"/> <License Value="LGPL 2 with static linking exception."/> <Version Major="1"/> - <Files Count="98"> + <Files Count="103"> <Item1> <Filename Value="..\stdimages.inc"/> <Type Value="Include"/> @@ -424,8 +424,28 @@ <Filename Value="..\render\software\Agg2D.pas"/> <UnitName Value="Agg2D"/> </Item98> + <Item99> + <Filename Value="..\fpg_dbugintf.pas"/> + <UnitName Value="fpg_dbugintf"/> + </Item99> + <Item100> + <Filename Value="..\fpg_dbugmsg.pas"/> + <UnitName Value="fpg_dbugmsg"/> + </Item100> + <Item101> + <Filename Value="..\..\gui\fpg_style_carbon.pas"/> + <UnitName Value="fpg_style_carbon"/> + </Item101> + <Item102> + <Filename Value="..\..\gui\fpg_style_plastic.pas"/> + <UnitName Value="fpg_style_plastic"/> + </Item102> + <Item103> + <Filename Value="..\..\gui\fpg_style_win8.pas"/> + <UnitName Value="fpg_style_win8"/> + </Item103> </Files> - <LazDoc Paths="../../../docs/xml/corelib;../../../docs/xml/corelib/x11;../../../docs/xml/corelib/gdi;../../../docs/xml/gui"/> + <LazDoc Paths="..\..\..\docs\xml\corelib;..\..\..\docs\xml\corelib\x11;..\..\..\docs\xml\corelib\gdi;..\..\..\docs\xml\gui"/> <RequiredPkgs Count="1"> <Item1> <PackageName Value="FCL"/> diff --git a/src/corelib/gdi/fpgui_toolkit.pas b/src/corelib/gdi/fpgui_toolkit.pas index 05501714..12ac41b9 100644 --- a/src/corelib/gdi/fpgui_toolkit.pas +++ b/src/corelib/gdi/fpgui_toolkit.pas @@ -21,7 +21,8 @@ uses fpg_interface, fpg_editbtn, fpg_imgfmt_jpg, fpg_imgutils, fpg_stylemanager, fpg_style_win2k, fpg_style_motif, fpg_style_clearlooks, fpg_style_bluecurve, fpg_style_bitmap, fpg_readonly, fpg_imgfmt_png, U_Command, U_Pdf, U_Report, - U_ReportImages, U_Visu, fpg_trayicon, Agg2D; + U_ReportImages, U_Visu, fpg_trayicon, Agg2D, fpg_dbugintf, fpg_dbugmsg, + fpg_style_carbon, fpg_style_plastic, fpg_style_win8; implementation diff --git a/src/corelib/predefinedcolors.inc b/src/corelib/predefinedcolors.inc index 130cdd9f..7ad000d4 100644 --- a/src/corelib/predefinedcolors.inc +++ b/src/corelib/predefinedcolors.inc @@ -69,6 +69,7 @@ clGridInactiveSel = TfpgColor(cl_BaseNamedColor + 30); clGridInactiveSelText = TfpgColor(cl_BaseNamedColor + 31); clSplitterGrabBar = TfpgColor(cl_BaseNamedColor + 32); + clHyperLink = TfpgColor(cl_BaseNamedColor + 33); diff --git a/src/corelib/render/software/Agg2D.pas b/src/corelib/render/software/Agg2D.pas index 50a68fb8..229294d2 100644 --- a/src/corelib/render/software/Agg2D.pas +++ b/src/corelib/render/software/Agg2D.pas @@ -400,6 +400,8 @@ type procedure ClearAll(c : TAggColor ); overload; procedure ClearAll(r ,g ,b : byte; a : byte = 255 ); overload; + procedure FillAll(c: TAggColor); overload; + procedure FillAll(r, g, b: byte; a: byte = 255); overload; // Master Rendering Properties procedure BlendMode(m : TAggBlendMode ); overload; @@ -1288,6 +1290,9 @@ begin m_pathTransform.Construct (@m_convCurve ,@m_transform ); m_strokeTransform.Construct(@m_convStroke ,@m_transform ); + m_convDash.remove_all_dashes; + m_convDash.add_dash(600, 0); {$NOTE Find a better way to prevent dash generation } + {$IFDEF AGG2D_USE_FREETYPE } m_fontEngine.Construct; {$ENDIF } @@ -1491,6 +1496,22 @@ begin end; +procedure TAgg2D.FillAll(c: TAggColor); +var + clr: aggclr; +begin + clr.Construct (c ); + m_renBase.fill(@clr ); +end; + +procedure TAgg2D.FillAll(r, g, b: byte; a: byte); +var + clr: TAggColor; +begin + clr.Construct(r, g, b, a); + FillAll(clr); +end; + { CLEARCLIPBOX } procedure TAgg2D.ClearClipBox(c : TAggColor ); var @@ -1517,14 +1538,14 @@ end; { WORLDTOSCREEN } procedure TAgg2D.WorldToScreen(x ,y : PDouble ); begin - m_transform.transform(@m_transform ,double_ptr(x ) ,double_ptr(y ) ); + m_transform.transform(@m_transform, x, y); end; { SCREENTOWORLD } procedure TAgg2D.ScreenToWorld(x ,y : PDouble ); begin - m_transform.inverse_transform(@m_transform ,double_ptr(x ) ,double_ptr(y ) ); + m_transform.inverse_transform(@m_transform, x, y); end; @@ -2649,7 +2670,8 @@ begin m_fontEngine.hinting_(m_textHints ); if cache = AGG_VectorFontCache then - m_fontEngine.height_(height ) + {$NOTE We need to fix this. Translating from font pt to pixels is inaccurate. This is just a temp fix for now. } + m_fontEngine.height_(height * 1.3333 ) // 9pt = ~12px so that is a ratio of 1.3333 else m_fontEngine.height_(worldToScreen(height ) ); {$ENDIF} @@ -3534,18 +3556,29 @@ begin end; procedure TAgg2D.DoSetFontRes(fntres: TfpgFontResourceBase); +{$IFDEF WINDOWS} begin - {$NOTE This is only temporary until I can correctly query font names } - {$IFDEF WINDOWS} + {$IFDEF AGG2D_USE_FREETYPE } + Font('c:\WINNT\Fonts\arial.ttf', 10); + {$ENDIF } + {$IFDEF AGG2D_USE_WINFONTS} Font('Arial', 13); - {$ELSE} - {$IFDEF BSD} - Font('/usr/local/lib/X11/fonts/Liberation/LiberationSans-Regular.ttf', 13); - {$ELSE} - Font('/usr/share/fonts/truetype/ttf-liberation/LiberationSans-Regular.ttf', 13); - {$ENDIF} - {$ENDIF} + {$ENDIF } end; +{$ENDIF} +{$IFDEF UNIX} +var + s: TfpgString; + i: integer; + fnt: TFontCacheItem; + lSize: double; +begin + fnt := FontCacheItemFromFontDesc(TfpgFontResource(fntres).FontDesc, lSize); + i := gFontCache.Find(fnt); + if i > 0 then + Font(gFontCache.Items[i].FileName, lSize, fnt.IsBold, fnt.IsItalic, AGG_VectorFontCache, Deg2Rad(fnt.Angle)); +end; +{$ENDIF} procedure TAgg2D.DoSetTextColor(cl: TfpgColor); var @@ -3555,7 +3588,7 @@ begin c := fpgColorToRGB(cl); t := fpgColorToRGBTriple(c); - FillColor(t.Red, t.Green, t.Blue{, t.Alpha}); + FillColor(t.Red, t.Green, t.Blue, t.Alpha); end; procedure TAgg2D.DoSetColor(cl: TfpgColor); @@ -3566,7 +3599,7 @@ begin c := fpgColorToRGB(cl); t := fpgColorToRGBTriple(c); - LineColor(t.Red, t.Green, t.Blue{, t.Alpha}); + LineColor(t.Red, t.Green, t.Blue, t.Alpha); end; procedure TAgg2D.DoSetLineStyle(awidth: integer; astyle: TfpgLineStyle); @@ -3635,7 +3668,10 @@ end; procedure TAgg2D.DoFillTriangle(x1, y1, x2, y2, x3, y3: TfpgCoord); begin - + LineWidth(1); + FillColor(LineColor); + LineColor(LineColor); + Triangle(x1+0.5, y1+0.5, x2+0.5, y2+0.5, x3+0.5, y3+0.5); end; procedure TAgg2D.DoDrawRectangle(x, y, w, h: TfpgCoord); diff --git a/src/corelib/render/software/agg-demos/Agg2DConsole.dpr b/src/corelib/render/software/agg-demos/Agg2DConsole.dpr new file mode 100644 index 00000000..bc8badbc --- /dev/null +++ b/src/corelib/render/software/agg-demos/Agg2DConsole.dpr @@ -0,0 +1,148 @@ +{ + This is a console application demo. It uses the Agg2D object, + which has a much friendlier API, to do all the drawing. We then + save the image buffer to a JPG, using the fcl-image package, + which comes standard with the Free Pascal Compiler. + +// Paths: ..\;..\svg;..\util;expat-wrap +} +program console_aggpas_2; + +{$mode objfpc}{$H+} + +uses + sysutils, + FPimage, + FPWriteJPEG, + agg_2D, + agg_basics; + +const + ImageWidth = 800; + ImageHeight = 480; + RGBA_Width = 4; + LineCount = 30; + {$IFDEF Unix} + FontFile = '../../arial.ttf'; + {$ENDIF} + {$IFDEF Windows} + FontFile = 'Arial'; + {$ENDIF} + +type + TPainter = class(TObject) + public + procedure HandlePlug; + procedure DrawStuff(agg: Agg2D_ptr); + end; + + +procedure TPainter.HandlePlug; +var + agg: Agg2D_ptr; + buf: array of int8; + image: TFPMemoryImage; + writer: TFPWriterJPEG; + x, y: Integer; + c: TFPColor; + time, totalTime: TDateTime; + function getBufItemAsWord(aDelta: byte): Word; + var + actualY: Integer; + begin + actualY := ImageHeight - y - 1; + result := + Word(buf[x * RGBA_Width + actualY * ImageWidth * RGBA_Width + aDelta] shl 8) + or Word(128); + end; +begin + totalTime := Now; + time := Now; + SetLength(buf, ImageWidth * ImageHeight * RGBA_Width); + New(agg, Construct); + agg^.attach(@(buf[0]), ImageWidth, ImageHeight, ImageWidth * RGBA_Width); + DrawStuff(agg); + Dispose(agg, Destruct); // not necessary to keep it after rendering is finished + time := Now - time; +// Logger.Emit('Draw: time spent: ' + TimeStampToString(time)); + time := Now; + image := TFPMemoryImage.create(ImageWidth, ImageHeight); + for x := 0 to ImageWidth - 1 do + for y := 0 to ImageHeight - 1 do + begin + c.red := getBufItemAsWord(2); + c.green := getBufItemAsWord(1); + c.blue := getBufItemAsWord(0); + c.alpha := getBufItemAsWord(3); + image.Colors[x, y] := c; + end; + time := Now - time; +// WriteLn('Image copy: time spent: ' + DateTimeToString(time)); + time := Now; + writer := TFPWriterJPEG.Create; + writer.CompressionQuality := $FF div 3; // bad quality plz + writer.ProgressiveEncoding := True; + image.SaveToFile('test.jpeg', writer); + image.Free; + writer.Free; + time := Now - time; +// WriteLn('Image encode: time spent: ' + DateTimeToString(time)); + totalTime := Now - totalTime; +// WriteLn('Total time: ' + DateTimeToString(totalTime)); +end; + +procedure TPainter.DrawStuff(agg: Agg2D_ptr); +var + i: Integer; + x, y, px, py, d: Double; +begin + agg^.clearAll(0, 0, 0); + agg^.lineColor(0, 0, 0, 255); + agg^.lineWidth(3); + agg^.rectangle(0, 0, ImageWidth, ImageHeight); + agg^.font(fontfile, 16); + d := ImageWidth / LineCount; + agg^.lineColor(0, 0, 0, 100); + agg^.lineWidth(1); + for i := 1 to LineCount - 1 do + begin + x := i * d; + agg^.line(x, 0, x, ImageHeight); + end; + for i := 1 to trunc(ImageHeight / d) do + begin + y := i * d; + agg^.line(0, y, ImageWidth, y); + end; + x := 0; + y := ImageHeight / 2; + px := x; + py := y; + agg^.lineColor(255, 0, 0, 200); + agg^.fillColor(0, 0, 0, 200); + agg^.lineWidth(3); + for i := 0 to LineCount - 1 do + begin + x := x + d; + y := y + Random(Round(ImageHeight / 3)) - ImageHeight / 6; + if y < 0 then + y := ImageHeight / 6; + if y >= ImageHeight then + y := ImageHeight - ImageHeight / 6; + agg^.line(px, py, x, y); + agg^.text(x, y, char_ptr(IntToStr(i) + ' point'{' шта?'})); + px := x; + py := y; + end; +end; + + +var + p: TPainter; +begin + Randomize; + p := TPainter.Create; + p.HandlePlug; + p.Free; +end. + diff --git a/src/corelib/render/software/agg_2D.pas b/src/corelib/render/software/agg_2D.pas index a6296e2c..45d88e44 100644 --- a/src/corelib/render/software/agg_2D.pas +++ b/src/corelib/render/software/agg_2D.pas @@ -3,11 +3,11 @@ // Based on Anti-Grain Geometry // Copyright (C) 2005 Maxim Shemanarev (http://www.antigrain.com) // -// Agg2D - Version 1.0 Release Milano 3 (AggPas 2.3 RM3) +// Agg2D - Version 1.0 Release Milano 3 (AggPas 2.4 RM3) // Pascal Port By: Milan Marusinec alias Milano // milan@marusinec.sk // http://www.aggpas.org -// Copyright (c) 2007 +// Copyright (c) 2007 - 2008 // // Permission to copy, use, modify, sell and distribute this software // is granted provided this copyright notice appears in all copies. @@ -325,6 +325,8 @@ type procedure clearAll(c : Color ); overload; procedure clearAll(r ,g ,b : unsigned; a : unsigned = 255 ); overload; + procedure FillAll(c: Color); overload; + procedure FillAll(r, g, b: byte; a: byte = 255); overload; procedure clearClipBox(c : Color ); overload; procedure clearClipBox(r ,g ,b : unsigned; a : unsigned = 255 ); overload; @@ -424,7 +426,7 @@ type rxTop ,ryTop : double ); overload; procedure ellipse(cx ,cy ,rx ,ry : double ); - + procedure arc (cx ,cy ,rx ,ry ,start ,sweep : double ); procedure star(cx ,cy ,r1 ,r2 ,startAngle : double; numRays : int ); @@ -932,6 +934,22 @@ begin end; +procedure Agg2D.FillAll(c: Color); +var + clr: aggclr; +begin + clr.Construct (c ); + m_renBase.fill(@clr ); +end; + +procedure Agg2D.FillAll(r, g, b: byte; a: byte); +var + clr: Color; +begin + clr.Construct(r, g, b, a); + FillAll(clr); +end; + { CLEARCLIPBOX } procedure Agg2D.clearClipBox(c : Color ); var diff --git a/src/corelib/render/software/agg_basics.pas b/src/corelib/render/software/agg_basics.pas index cc116cfe..56eb6fba 100644 --- a/src/corelib/render/software/agg_basics.pas +++ b/src/corelib/render/software/agg_basics.pas @@ -357,8 +357,8 @@ type procedure NoP; { These implementations have changed to use FPC's Sar*() functions, so should - now support all platforms with ASM code. At a later date these functions - could be removed completely. } + now support all platforms without the need for ASM code. At a later date these + functions could be removed completely. } function shr_int8 (i ,shift : int8 ) : int8; inline; function shr_int16(i ,shift : int16 ) : int16; inline; function shr_int32(i ,shift : int ) : int; inline; diff --git a/src/corelib/render/software/agg_platform_x11.inc b/src/corelib/render/software/agg_platform_x11.inc index 331b572e..dc5556fa 100644 --- a/src/corelib/render/software/agg_platform_x11.inc +++ b/src/corelib/render/software/agg_platform_x11.inc @@ -18,6 +18,7 @@ {$ifdef uses_implementation} fpg_x11, + fpg_fontcache, {$endif} @@ -27,6 +28,88 @@ type // to get access to protected methods (seeing that FPC doesn't support Friend-classes) TImageHack = class(TfpgImage); +function FontCacheItemFromFontDesc(const desc: string; var asize: double): TFontCacheItem; +var + facename: string; + cp: integer; + c: char; + token: string; + prop, propval: string; + + function NextC: char; + begin + Inc(cp); + if cp > length(desc) then + c := #0 + else + c := desc[cp]; + Result := c; + end; + + procedure NextToken; + begin + token := ''; + while (c <> #0) and (c in [' ', 'a'..'z', 'A'..'Z', '_', '0'..'9', '.']) do + begin + token := token + c; + NextC; + end; + end; + +begin + Result := TFontCacheItem.Create(''); + + cp := 0; + NextC; + NextToken; + + facename := token; + // Add known substites + if lowercase(facename) = 'times' then + facename := 'Times New Roman' + else if lowercase(facename) = 'courier' then + facename := 'Courier New' + else if lowercase(facename) = 'monospace' then + facename := 'Courier New'; + Result.FamilyName := facename; + + if c = '-' then + begin + NextC; + NextToken; + asize := StrToIntDef(token, 0); + end; + + while c = ':' do + begin + NextC; + NextToken; + + prop := UpperCase(token); + propval := ''; + + if c = '=' then + begin + NextC; + NextToken; + propval := UpperCase(token); + end; + + if prop = 'BOLD' then + Result.IsBold := True + else if prop = 'ITALIC' then + Result.IsItalic := True + else if prop = 'ANGLE' then + Result.Angle := StrToFloatDef(propval, 0.0); +// else if prop = 'ANTIALIAS' then +// if propval = 'FALSE' then +// lf.lfQuality := NONANTIALIASED_QUALITY else +// if propval = 'DEFAULT' then +// lf.lfQuality := DEFAULT_QUALITY; + end; +end; + + procedure TAgg2D.DoPutBufferToScreen(x, y, w, h: TfpgCoord); var drawgc: Tgc; diff --git a/src/corelib/render/software/agg_renderer_base.pas b/src/corelib/render/software/agg_renderer_base.pas index 926aebd5..cc2bade4 100644 --- a/src/corelib/render/software/agg_renderer_base.pas +++ b/src/corelib/render/software/agg_renderer_base.pas @@ -79,6 +79,7 @@ type function bounding_ymax : int; virtual; procedure clear(c : aggclr_ptr ); + procedure fill(const c: aggclr_ptr); procedure copy_pixel (x ,y : int; c : aggclr_ptr ); virtual; procedure blend_pixel(x ,y : int; c : aggclr_ptr; cover : int8u ); virtual; @@ -348,6 +349,17 @@ begin end; +procedure renderer_base.fill(const c: aggclr_ptr); +var + y: unsigned; +begin + if (width > 0) and (height > 0) then + begin + for y:=0 to height - 1 do + m_ren.blend_hline(m_ren, 0, y, width, c, cover_mask); + end; +end; + { COPY_PIXEL } procedure renderer_base.copy_pixel(x, y: int; c: aggclr_ptr); begin diff --git a/src/corelib/render/software/fpg_fontcache.pas b/src/corelib/render/software/fpg_fontcache.pas new file mode 100644 index 00000000..15f65e40 --- /dev/null +++ b/src/corelib/render/software/fpg_fontcache.pas @@ -0,0 +1,347 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + This is a homegrown font cache, or font translation system. AggPas + references font files (eg: *.ttf) directly, whereas the rest + of fpGUI doesn't. Under X11 for example, the translation of + 'Aria-12' to the actual *.ttf file will be done by the fontconfig + library. Unfortunately fontconfig doesn't have an API to give + use that *.ttf font file it resolved too. So for AggPas (or rather + the AggPas backend in fpGUI) we had to implement our own + font translation system. +} + +unit fpg_fontcache; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, contnrs, fpg_base; + +type + TFontCacheItem = class(TObject) + private + FAngle: double; + FFamilyName: TfpgString; + FFileName: TfpgString; + FFixedWidth: boolean; + FStyleFlags: Integer; + function GetIsBold: boolean; + function GetIsFixedWidth: boolean; + function GetIsItalic: boolean; + function GetIsRegular: boolean; + procedure SetIsBold(AValue: boolean); + procedure SetIsFixedWidth(AValue: boolean); + procedure SetIsItalic(AValue: boolean); + procedure SetIsRegular(AValue: boolean); + public + constructor Create(const AFilename: TfpgString); + property FileName: TfpgString read FFileName write FFileName; + property FamilyName: TfpgString read FFamilyName write FFamilyName; + property StyleFlags: Integer read FStyleFlags write FStyleFlags; + property IsFixedWidth: boolean read GetIsFixedWidth write SetIsFixedWidth; + property IsRegular: boolean read GetIsRegular write SetIsRegular; + property IsItalic: boolean read GetIsItalic write SetIsItalic; + property IsBold: boolean read GetIsBold write SetIsBold; + { following properties are used by FontCacheItemFromFontDesc() only } + property Angle: double read FAngle write FAngle; + end; + + + TFontCacheList = class(TObject) + private + FList: TObjectList; + procedure SearchForFont(const AFontPath: TfpgString); + function BuildFontCacheItem(const AFontFile: TfpgString): TFontCacheItem; + procedure SetStyleIfExists(var AText: Ansistring; var AStyleFlags: integer; const AStyleName: AnsiString; const AStyleBit: integer); + protected + function GetCount: integer; virtual; + function GetItem(AIndex: Integer): TFontCacheItem; virtual; + procedure SetItem(AIndex: Integer; AValue: TFontCacheItem); virtual; + public + constructor Create; + destructor Destroy; override; + procedure BuildFontCache; + function Add(const AObject: TFontCacheItem): integer; + procedure Clear; + property Count: integer read GetCount; + function IndexOf(const AObject: TFontCacheItem): integer; + function Find(const AFontCacheItem: TFontCacheItem): integer; + property Items[AIndex: Integer]: TFontCacheItem read GetItem write SetItem; default; + end; + + +function gFontCache: TFontCacheList; + +implementation + +uses + fpg_utils, + agg_font_freetype_lib; + +const + FPG_FONT_STYLE_REGULAR = 1 shl 0; { Regular, Plain, Book } + FPG_FONT_STYLE_ITALIC = 1 shl 1; { Itelic } + FPG_FONT_STYLE_BOLD = 1 shl 2; { Bold } + FPG_FONT_STYLE_CONDENSED = 1 shl 3; { Condensed } + FPG_FONT_STYLE_EXTRALIGHT = 1 shl 4; { ExtraLight } + FPG_FONT_STYLE_LIGHT = 1 shl 5; { Light } + FPG_FONT_STYLE_SEMIBOLD = 1 shl 6; { Semibold } + FPG_FONT_STYLE_MEDIUM = 1 shl 7; { Medium } + FPG_FONT_STYLE_BLACK = 1 shl 8; { Black } + FPG_FONT_STYLE_FIXEDWIDTH = 1 shl 9; { Fixedwidth } + +var + m_library: FT_Library_ptr; + uFontCacheList: TFontCacheList; + +function gFontCache: TFontCacheList; +begin + if not Assigned(uFontCacheList) then + begin + uFontCacheList := TFontCacheList.Create; + uFontCacheList.BuildFontCache; + end; + Result := uFontCacheList; +end; + +{ TFontCacheItem } + +function TFontCacheItem.GetIsBold: boolean; +begin + Result := (FStyleFlags and FPG_FONT_STYLE_BOLD) <> 0; +end; + +function TFontCacheItem.GetIsFixedWidth: boolean; +begin + Result := (FStyleFlags and FPG_FONT_STYLE_FIXEDWIDTH) <> 0; +end; + +function TFontCacheItem.GetIsItalic: boolean; +begin + Result := (FStyleFlags and FPG_FONT_STYLE_ITALIC) <> 0; +end; + +function TFontCacheItem.GetIsRegular: boolean; +begin + Result := (FStyleFlags and FPG_FONT_STYLE_REGULAR) <> 0; +end; + +procedure TFontCacheItem.SetIsBold(AValue: boolean); +begin + FStyleFlags := FStyleFlags or FPG_FONT_STYLE_BOLD; +end; + +procedure TFontCacheItem.SetIsFixedWidth(AValue: boolean); +begin + FStyleFlags := FStyleFlags or FPG_FONT_STYLE_FIXEDWIDTH; + FStyleFlags := FStyleFlags and (not FPG_FONT_STYLE_REGULAR); +end; + +procedure TFontCacheItem.SetIsItalic(AValue: boolean); +begin + FStyleFlags := FStyleFlags or FPG_FONT_STYLE_ITALIC; +end; + +procedure TFontCacheItem.SetIsRegular(AValue: boolean); +begin + FStyleFlags := FStyleFlags or FPG_FONT_STYLE_REGULAR; + FStyleFlags := FStyleFlags and (not FPG_FONT_STYLE_FIXEDWIDTH); +end; + +constructor TFontCacheItem.Create(const AFilename: TfpgString); +begin + inherited Create; + FFileName := AFilename; + FStyleFlags := FPG_FONT_STYLE_REGULAR; + FAngle := 0.0; +end; + +{ TFontCacheList } + +procedure TFontCacheList.SearchForFont(const AFontPath: TfpgString); +var + sr: TSearchRec; + lFont: TFontCacheItem; + s: TfpgString; +begin + // The extra 'or' includes Normal attribute files under Windows. faAnyFile doesn't return those. + // Reported to FPC as bug 9440 in Mantis. + if fpgFindFirst(AFontPath + AllFilesMask, faAnyFile or $00000080, sr) = 0 then + begin + repeat + // check if special files to skip + if (sr.Name = '.') or (sr.Name = '..') or (sr.Name = '') then + Continue; + // We got something, so lets continue + s := fpgFromOSEncoding(sr.Name); + if (sr.Attr and faDirectory) <> 0 then // found a directory + SearchForFont(fpgAppendPathDelim(AFontPath + s)) + else + begin // we have a file + if (lowercase(fpgExtractFileExt(s)) = '.ttf') or + (lowercase(fpgExtractFileExt(s)) = '.otf') then + begin + lFont := BuildFontCacheItem(AFontPath + s); + Add(lFont); + end; + end; + until fpgFindNext(sr) <> 0; + end; +end; + +function TFontCacheList.BuildFontCacheItem(const AFontFile: TfpgString): TFontCacheItem; +var + face_ptr: FT_Face_ptr; + s: Ansistring; + i: integer; + flags: integer; +begin + FT_New_Face(m_library, PChar(AFontFile), 0, face_ptr); + Result := TFontCacheItem.Create(AFontFile); + Result.FamilyName := face_ptr^.family_name; + + // extract simple styles first +// if (face_ptr^.face_flags and FT_FACE_FLAG_FIXED_WIDTH) <> 0 then +// Result.StyleFlags := FPG_FONT_STYLE_FIXEDWIDTH; // this should overwrite Regular style + + if (face_ptr^.style_flags and FT_STYLE_FLAG_ITALIC) <> 0 then + Result.StyleFlags := Result.StyleFlags or FPG_FONT_STYLE_ITALIC; + + if (face_ptr^.style_flags and FT_STYLE_FLAG_BOLD) <> 0 then + Result.StyleFlags := Result.StyleFlags or FPG_FONT_STYLE_BOLD; + + // Now to more complex styles stored in StyleName field. eg: 'Condensed Medium' + s := face_ptr^.style_name; + flags := Result.StyleFlags; + SetStyleIfExists(s, flags, 'Condensed', FPG_FONT_STYLE_CONDENSED); + SetStyleIfExists(s, flags, 'ExtraLight', FPG_FONT_STYLE_EXTRALIGHT); + SetStyleIfExists(s, flags, 'Light', FPG_FONT_STYLE_LIGHT); + SetStyleIfExists(s, flags, 'Semibold', FPG_FONT_STYLE_SEMIBOLD); + SetStyleIfExists(s, flags, 'Medium', FPG_FONT_STYLE_MEDIUM); + SetStyleIfExists(s, flags, 'Black', FPG_FONT_STYLE_BLACK); + Result.StyleFlags := flags; + + FT_Done_Face(face_ptr); +end; + +procedure TFontCacheList.SetStyleIfExists(var AText: Ansistring; var AStyleFlags: integer; + const AStyleName: AnsiString; const AStyleBit: integer); +var + i: integer; +begin + i := Pos(AStyleName, AText); + if i > 0 then + begin + AStyleFlags := AStyleFlags or AStyleBit; + Delete(AText, Length(AStyleName), i); + end; +end; + +function TFontCacheList.GetCount: integer; +begin + Result := FList.Count; +end; + +function TFontCacheList.GetItem(AIndex: Integer): TFontCacheItem; +begin + Result := TFontCacheItem(FList.Items[AIndex]); +end; + +procedure TFontCacheList.SetItem(AIndex: Integer; AValue: TFontCacheItem); +begin + FList.Items[AIndex] := AValue; +end; + +constructor TFontCacheList.Create; +begin + inherited Create; + FList := TObjectList.Create; +end; + +destructor TFontCacheList.Destroy; +begin + FList.Free; + inherited Destroy; +end; + +procedure TFontCacheList.BuildFontCache; +var + lPath: TfpgString; + lPathList: TStringList; + i: integer; +begin + try + m_library := nil; + FT_Init_FreeType(m_library); + + lPathList := TStringList.Create; + lPathList.Add('/usr/share/cups/fonts/'); + lPathList.Add('/usr/share/fonts/truetype/'); + lPathList.Add('/usr/local/lib/X11/fonts/'); + lPathList.Add(GetUserDir + '.fonts/'); + for i := 0 to lPathList.Count-1 do + begin + lPath := lPathList[i]; + SearchForFont(lPath); + end; + finally + FT_Done_FreeType(m_library); + m_library := nil; + lPathList.Free; + end; +end; + +function TFontCacheList.Add(const AObject: TFontCacheItem): integer; +begin + Result := FList.Add(AObject); +end; + +procedure TFontCacheList.Clear; +begin + FList.Clear; +end; + +function TFontCacheList.IndexOf(const AObject: TFontCacheItem): integer; +begin + Result := FList.IndexOf(AObject); +end; + +function TFontCacheList.Find(const AFontCacheItem: TFontCacheItem): integer; +var + i: integer; +begin + Result := -1; // nothing found + for i := 0 to Count-1 do + begin + if (Items[i].FamilyName = AFontCacheItem.FamilyName) and + (Items[i].StyleFlags = AFontCacheItem.StyleFlags) then + begin + Result := i; + exit; + end; + end; +end; + + +initialization + uFontCacheList := nil; + +finalization + uFontCacheList.Free; + +end. + diff --git a/src/corelib/render/software/platform/mac/agg_platform_support.pas b/src/corelib/render/software/platform/mac/agg_platform_support.pas index 608b7854..e9886b64 100644 --- a/src/corelib/render/software/platform/mac/agg_platform_support.pas +++ b/src/corelib/render/software/platform/mac/agg_platform_support.pas @@ -92,10 +92,10 @@ type // Possible formats of the rendering buffer. Initially I thought that it's // reasonable to create the buffer and the rendering functions in // accordance with the native pixel format of the system because it -// would have no overhead for pixel format conersion. +// would have no overhead for pixel format conversion. // But eventually I came to a conclusion that having a possibility to // convert pixel formats on demand is a good idea. First, it was X11 where -// there lots of different formats and visuals and it would be great to +// there are lots of different formats and visuals and it would be great to // render everything in, say, RGB-24 and display it automatically without // any additional efforts. The second reason is to have a possibility to // debug renderers for different pixel formats and colorspaces having only diff --git a/src/corelib/x11/fpg_netlayer_x11.pas b/src/corelib/x11/fpg_netlayer_x11.pas index b328378d..eb9207b0 100644 --- a/src/corelib/x11/fpg_netlayer_x11.pas +++ b/src/corelib/x11/fpg_netlayer_x11.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -415,7 +415,7 @@ begin end; if AValue = nmsBoth then Exit; - // now remove properties we dont want + // now remove properties we don't want Msg.data.l[0] := _NET_WM_STATE_REMOVE; Msg.data.l[1] := 0; @@ -690,6 +690,8 @@ var bytes_after: culong; begin Result := False; + if (AWindow = 0) or (AProperty = 0) then + Exit; XGetWindowProperty (FDisplay, AWindow, AProperty, 0, MaxInt, TBool(False), XA_ATOM, @atomtype, @format, @nitems, @bytes_after, @Atoms); diff --git a/src/corelib/x11/fpg_x11.pas b/src/corelib/x11/fpg_x11.pas index 27f59abe..569772ae 100644 --- a/src/corelib/x11/fpg_x11.pas +++ b/src/corelib/x11/fpg_x11.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2011 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -24,7 +24,7 @@ unit fpg_x11; { TODO : Compiz effects: Menu popup with correct window hint. Same for Combo dropdown window. } { TODO : Under Compiz restoring a window position moves the window down/right the width and height - of the window borders. This as something to do with win_gravity = StaticGravity setting. } + of the window borders. This has something to do with win_gravity = StaticGravity setting. } interface @@ -215,6 +215,7 @@ type public constructor Create(awin: TfpgWindowBase); override; destructor Destroy; override; + procedure CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; var ASrcRect: TfpgRect); override; end; @@ -315,6 +316,7 @@ type xia_wm_delete_window: TAtom; xia_wm_state: TAtom; xia_targets: TAtom; + xia_save_targets: TAtom; netlayer: TNETWindowLayer; InputMethod: PXIM; InputContext: PXIC; @@ -322,6 +324,7 @@ type function DoGetFontFaceList: TStringList; override; procedure DoWaitWindowMessage(atimeoutms: integer); override; function MessagesPending: boolean; override; + function GetHelpViewer: TfpgString; override; public constructor Create(const AParams: string); override; destructor Destroy; override; @@ -340,11 +343,17 @@ type TfpgX11Clipboard = class(TfpgClipboardBase) private FWaitingForSelection: Boolean; + FOwnsSelection: Boolean; + procedure SendClipboardToManager; + procedure DoLostSelection; + procedure DoSetTargets(AWin: TWindow; AProperty: TAtom); protected FClipboardText: TfpgString; function DoGetText: TfpgString; override; procedure DoSetText(const AValue: TfpgString); override; procedure InitClipboard; override; + public + destructor Destroy; override; end; @@ -420,6 +429,7 @@ implementation uses baseunix, + unix, {$IFDEF LINUX} users, { For Linux user and group name support. FPC only supports this in Linux. } {$ENDIF} @@ -430,6 +440,7 @@ uses fpg_utils, fpg_form, // for modal event support fpg_cmdlineparams, + fpg_constants, cursorfont, xatom, // used for XA_WM_NAME keysym, @@ -477,20 +488,27 @@ begin Result := Result or ((rgb and $F80000) shr 8); end; +function ConvertTo555Pixel(rgb: longword): word; +begin + Result := (rgb and $F8) shr 3; + Result := Result or ((rgb and $F800) shr 6); + Result := Result or ((rgb and $F80000) shr 9); +end; + function fpgColorToX(col: TfpgColor): longword; var xc: TXColor; c: TfpgColor; begin c := fpgColorToRGB(col); - if xapplication.DisplayDepth >= 24 then Result := c and $FFFFFF { No Alpha channel information } else if xapplication.DisplayDepth = 16 then Result := ConvertTo565Pixel(c) + else if (xapplication.DisplayDepth = 15) then + Result := ConvertTo555Pixel(c) else begin - c := col; xc.blue := (c and $000000FF) shl 8; xc.green := (c and $0000FF00); xc.red := (c and $00FF0000) shr 8; @@ -665,29 +683,93 @@ begin end; // clipboard event +procedure HandleAtom(var e: TXSelectionEvent; const Atom: TAtom; Prop: TAtom); forward; + + +procedure HandleMultiple(var e: TXSelectionEvent); +type + TAtomPair = record + Target: TAtom; + Prop: TAtom; + end; + +var + Atom: TAtom; + Length: culong; + BytesLeft: culong; + Format: DWord; + Data: Pointer; + xia_Atom_Pair: TAtom; + AtomPair: TAtomPair; + i: Integer; + r: cint; +begin + + xia_Atom_Pair := XInternAtom(xapplication.Display, 'ATOM_PAIR', False); + + // find out how much data there is + r := XGetWindowProperty(xapplication.Display, e.requestor, e._property, 0, 0, False, AnyPropertyType, + @Atom, @Format, @Length, @BytesLeft, @Data); + + if (r <> Success) or (Format <> 32) or (Atom <> xia_Atom_Pair) then + Exit; // ==> + + // read one entry at a time + while BytesLeft > 0 do + begin + // read the data + r := XGetWindowProperty(xapplication.Display, e.requestor, e._property, 0, SizeOf(AtomPair), False, AnyPropertyType, + @Atom, @Format, @Length, @BytesLeft, @Data); + + if r <> Success then + Exit; // ==> + + // copy data to our variable + Move(Data^, AtomPair, SizeOf(TAtomPair)); + XFree(Data); + + // process this target in the list; + HandleAtom(e, AtomPair.Target, AtomPair.Prop); + end; +end; + +procedure HandleAtom(var e: TXSelectionEvent; const Atom: TAtom; Prop: TAtom); +begin + if Atom = None then + begin + Exit; // ==> + end; + + if Atom = xapplication.xia_targets then + begin + fpgClipboard.DoSetTargets(e.requestor, Prop); + end + else if Atom = XInternAtom(xapplication.Display, 'MULTIPLE', False) then + begin + // multiple targets + HandleMultiple(e); + end + else// if Atom = XA_STRING then + begin + XChangeProperty(xapplication.Display, e.requestor, Prop, Atom, + 8, PropModeReplace, PByte(@fpgClipboard.FClipboardText[1]), Length(fpgClipboard.FClipboardText)); + end; + //else WriteLn('Unhandled Selection atom: ', XGetAtomName(xapplication.Display, Atom)); +end; + procedure ProcessSelectionRequest(var ev: TXEvent); var e: TXSelectionEvent; - a: TAtom; begin e._type := SelectionNotify; + e.display := ev.xselectionrequest.display; e.requestor := ev.xselectionrequest.requestor; e.selection := ev.xselectionrequest.selection; e.target := ev.xselectionrequest.target; e.time := ev.xselectionrequest.time; e._property := ev.xselectionrequest._property; - if e.target = xapplication.xia_targets then - begin - a := XA_STRING; - XChangeProperty(xapplication.Display, e.requestor, e._property, XA_ATOM, - 32, PropModeReplace, PByte(@a), Sizeof(TAtom)); // I think last parameter is right? - end - else - begin - XChangeProperty(xapplication.Display, e.requestor, e._property, e.target, - 8, PropModeReplace, PByte(@fpgClipboard.FClipboardText[1]), Length(fpgClipboard.FClipboardText)); - end; + HandleAtom(e, e.target, e._property); XSendEvent(xapplication.Display, e.requestor, false, 0, @e ); end; @@ -1396,6 +1478,7 @@ begin // Initialize atoms xia_clipboard := XInternAtom(FDisplay, 'CLIPBOARD', TBool(False)); xia_targets := XInternAtom(FDisplay, 'TARGETS', TBool(False)); + xia_save_targets := XInternAtom(FDisplay, 'SAVE_TARGETS', TBool(False)); xia_motif_wm_hints := XInternAtom(FDisplay, '_MOTIF_WM_HINTS', TBool(False)); xia_wm_protocols := XInternAtom(FDisplay, 'WM_PROTOCOLS', TBool(False)); xia_wm_delete_window := XInternAtom(FDisplay, 'WM_DELETE_WINDOW', TBool(False)); @@ -1433,6 +1516,16 @@ begin fpgCheckTimers; end; +function TfpgX11Application.GetHelpViewer: TfpgString; +begin + Result := inherited GetHelpViewer; + if not fpgFileExists(Result) then + begin + if fpsystem('which ' + FPG_HELPVIEWER) = 0 then + Result := FPG_HELPVIEWER; + end; +end; + function GetParentWindow(wh: TfpgWinHandle; var pw, rw: TfpgWinHandle): boolean; var rootw: TfpgWinHandle; @@ -2045,9 +2138,13 @@ begin X.SelectionClear: begin { TODO : Not sure if I am handling this correctly? } + { We Get this message when another program has declared that + it has ownership of the xia_clipboard selection atom + } if ev.xselectionclear.selection = xia_clipboard then begin fpgClipboard.FClipboardText := ''; + fpgClipboard.DoLostSelection; Exit; end; end; @@ -2300,9 +2397,17 @@ begin if (FWindowType <> wtChild) and (waSizeable in FWindowAttributes) then begin - hints.flags := hints.flags or PMinSize; + hints.flags := hints.flags or PMinSize or PMaxSize; hints.min_width := FMinWidth; hints.min_height := FMinHeight; + if FMaxWidth > 0 then + hints.max_width := FMaxWidth + else + hints.max_width := xapplication.ScreenWidth; + if FMaxHeight > 0 then + hints.max_height := FMaxHeight + else + hints.max_height := xapplication.ScreenHeight; end else begin @@ -2755,6 +2860,13 @@ begin inherited Destroy; end; +procedure TfpgX11Canvas.CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; + var ASrcRect: TfpgRect); +begin + SortRect(ASrcRect); + XCopyArea(xapplication.Display, TfpgX11Canvas(ASrcCanvas).FDrawHandle, FDrawHandle, Fgc, ASrcRect.Left, ASrcRect.Top, ASrcRect.Width, ASrcRect.Height, ADest_x, ADest_y); +end; + procedure TfpgX11Canvas.DoBeginDraw(awin: TfpgWindowBase; buffered: boolean); var x: integer; @@ -2926,7 +3038,8 @@ begin Trunc(64 * a1), Trunc(64 * a2)); end; -procedure TfpgX11Canvas.DoDrawPolygon(Points: fpg_base.PPoint; NumPts: Integer; Winding: boolean); +procedure TfpgX11Canvas.DoDrawPolygon(Points: PPoint; NumPts: Integer; + Winding: boolean); var PointArray: PXPoint; i: integer; @@ -3284,8 +3397,70 @@ end; { TfpgX11Clipboard } +procedure TfpgX11Clipboard.SendClipboardToManager; +var + ClipboardManager: TAtom; + StartTime: DWord; +begin + // if we don't own the clipboard then there is nothing to save + if not FOwnsSelection then + Exit; // ==> + + // check if the manager atom exists + ClipboardManager:= XInternAtom(xapplication.Display, 'CLIPBOARD_MANAGER', False); + if ClipboardManager = None then + Exit; // ==> + + // check if a program has control of the manager atom + if XGetSelectionOwner(xapplication.Display, ClipboardManager) = None then + Exit; // ==> + + // this triggers the manager to request the clipboard contents from us + XConvertSelection(xapplication.Display, + ClipboardManager, + xapplication.xia_save_targets, + None, //XInternAtom(xapplication.Display, 'FPG_CLIPBOARD', True), // 'None' seems to work as the property name + FClipboardWndHandle, + CurrentTime); + + XSync(xapplication.Display, False); + + StartTime := fpgGetTickCount; + // now wait for the manager to get the clipboard + repeat + fpgWaitWindowMessage; + fpgDeliverMessages; + until not FOwnsSelection or ((fpgGetTickCount - StartTime) > 3000); // allow 3 seconds for the clipboard to be read +end; + +procedure TfpgX11Clipboard.DoLostSelection; +begin + FOwnsSelection := False; +end; + +procedure TfpgX11Clipboard.DoSetTargets(AWin: TWindow; AProperty: TAtom); +const + target_count = 3; +var + targets: array[0..target_count-1] of TAtom; +begin + + targets[0] := XA_STRING; + targets[1] := xapplication.xia_targets; + targets[2] := xapplication.xia_save_targets; + //targets[3] := XInternAtom(xapplication.Display, 'UTF8_STRING', True); + //targets[4] := XInternAtom(xapplication.Display, 'MULTIPLE', True); + + // list the types of data we have in the clipboard + XChangeProperty(xapplication.Display, AWin, AProperty, XA_ATOM, 32, + PropModeReplace, @targets[0], target_count); +end; + function TfpgX11Clipboard.DoGetText: TfpgString; begin + if FOwnsSelection then + Exit(FClipboardText); // ==> + XConvertSelection(xapplication.Display, xapplication.xia_clipboard, XA_STRING, xapplication.xia_clipboard, FClipboardWndHandle, 0); @@ -3305,6 +3480,8 @@ begin FClipboardText := AValue; XSetSelectionOwner(xapplication.Display, xapplication.xia_clipboard, FClipboardWndHandle, CurrentTime); + DoSetTargets(FClipboardWndHandle, xapplication.xia_targets); + FOwnsSelection := True; end; procedure TfpgX11Clipboard.InitClipboard; @@ -3314,6 +3491,12 @@ begin xapplication.RootWindow, 10, 10, 10, 10, 0, 0, 0); end; +destructor TfpgX11Clipboard.Destroy; +begin + SendClipboardToManager; + inherited Destroy; +end; + { TfpgX11FileList } function TfpgX11FileList.EncodeModeString(FileMode: longword): TFileModeString; diff --git a/src/corelib/x11/fpgui_toolkit.lpk b/src/corelib/x11/fpgui_toolkit.lpk index ff08daeb..d5ad23c8 100644 --- a/src/corelib/x11/fpgui_toolkit.lpk +++ b/src/corelib/x11/fpgui_toolkit.lpk @@ -1,4 +1,4 @@ -<?xml version="1.0"?> +<?xml version="1.0" encoding="UTF-8"?> <CONFIG> <Package Version="4"> <Name Value="fpgui_toolkit"/> @@ -29,7 +29,7 @@ <Description Value="fpGUI Toolkit"/> <License Value="LGPL 2 with static linking exception."/> <Version Major="1"/> - <Files Count="100"> + <Files Count="106"> <Item1> <Filename Value="../stdimages.inc"/> <Type Value="Include"/> @@ -427,9 +427,33 @@ <UnitName Value="Agg2D"/> </Item99> <Item100> + <Filename Value="../fpg_dbugintf.pas"/> + <UnitName Value="fpg_dbugintf"/> + </Item100> + <Item101> + <Filename Value="../fpg_dbugmsg.pas"/> + <UnitName Value="fpg_dbugmsg"/> + </Item101> + <Item102> + <Filename Value="../render/software/fpg_fontcache.pas"/> + <UnitName Value="fpg_fontcache"/> + </Item102> + <Item103> + <Filename Value="../../gui/fpg_style_carbon.pas"/> + <UnitName Value="fpg_style_carbon"/> + </Item103> + <Item104> + <Filename Value="../../gui/fpg_style_plastic.pas"/> + <UnitName Value="fpg_style_plastic"/> + </Item104> + <Item105> + <Filename Value="../../gui/fpg_style_win8.pas"/> + <UnitName Value="fpg_style_win8"/> + </Item105> + <Item106> <Filename Value="../../gui/fpg_scrollframe.pas"/> <UnitName Value="fpg_scrollframe"/> - </Item100> + </Item106> </Files> <LazDoc Paths="../../../docs/xml/corelib;../../../docs/xml/corelib/x11;../../../docs/xml/corelib/gdi;../../../docs/xml/gui"/> <RequiredPkgs Count="1"> diff --git a/src/corelib/x11/fpgui_toolkit.pas b/src/corelib/x11/fpgui_toolkit.pas index 4f4f92c0..86e456f4 100644 --- a/src/corelib/x11/fpgui_toolkit.pas +++ b/src/corelib/x11/fpgui_toolkit.pas @@ -22,7 +22,8 @@ uses fpg_stylemanager, fpg_style_win2k, fpg_style_motif, fpg_style_clearlooks, fpg_style_bluecurve, fpg_style_bitmap, fpg_readonly, fpg_imgfmt_png, U_Command, U_Pdf, U_Report, U_ReportImages, U_Visu, fpg_trayicon, Agg2D, - fpg_scrollframe; + fpg_dbugintf, fpg_dbugmsg, fpg_fontcache, fpg_style_carbon, + fpg_style_plastic, fpg_style_win8, fpg_scrollframe; implementation |