{ $Id$ } { ------------------------------------------- DebuggerBase.pp - Debugger base classes ------------------------------------------- @author(Marc Weustink ) @author(Martin Friebe) This unit contains the base class definitions of the debugger. These classes are only definitions. Implemented debuggers should be derived from these. *************************************************************************** * * * This source is free software; you can redistribute it and/or modify * * it under the terms of the GNU General Public License as published by * * the Free Software Foundation; either version 2 of the License, or * * (at your option) any later version. * * * * This code 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. See the GNU * * General Public License for more details. * * * * A copy of the GNU General Public License is available on the World * * Wide Web at . You can also * * obtain it by writing to the Free Software Foundation, * * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * * * *************************************************************************** } unit DbgIntfDebuggerBase; {$mode objfpc}{$H+} interface uses DbgIntfBaseTypes, DbgIntfMiscClasses, LazClasses, LazLoggerBase, FileUtil, maps, LCLProc, Classes, sysutils, math, contnrs, LazMethodList; const DebuggerIntfVersion = 0; type EDebuggerException = class(Exception); EDBGExceptions = class(EDebuggerException); TDBGCommand = ( dcRun, dcPause, dcStop, dcStepOver, dcStepInto, dcStepOut, dcRunTo, dcJumpto, dcAttach, dcDetach, dcBreak, dcWatch, dcLocal, dcEvaluate, dcModify, dcEnvironment, dcSetStackFrame, dcDisassemble, dcStepOverInstr, dcStepIntoInstr, dcSendConsoleInput ); TDBGCommands = set of TDBGCommand; { Debugger states -------------------------------------------------------------------------- dsNone: The debug object is created, but no instance of an external debugger exists. Initial state, leave with Init, enter with Done dsIdle: The external debugger is started, but no filename (or no other params required to start) were given. dsStop: (Optional) The execution of the target is stopped The external debugger is loaded and ready to (re)start the execution of the target. Breakpoints, watches etc can be defined dsPause: The debugger has paused the target. Target variables can be examined dsInternalPause: Pause, not visible to user. For examble auto continue breakpoint: Allow collection of Snapshot data dsInit: (Optional, Internal) The debugger is about to run dsRun: The target is running. dsError: Something unforseen has happened. A shutdown of the debugger is in most cases needed. -dsDestroying The debugger is about to be destroyed. Should normally happen immediate on calling Release. But the debugger may be in nested calls, and has to exit them first. -------------------------------------------------------------------------- } TDBGState = ( dsNone, dsIdle, dsStop, dsPause, dsInternalPause, dsInit, dsRun, dsError, dsDestroying ); TDBGLocationRec = record Address: TDBGPtr; FuncName: String; SrcFile: String; SrcFullName: String; SrcLine: Integer; end; TDBGExceptionType = ( deInternal, deExternal, deRunError ); TDebuggerDataState = (ddsUnknown, // ddsRequested, ddsEvaluating, // ddsValid, // Got a valid value ddsInvalid, // Does not have a value ddsError // Error, but got some Value to display (e.g. error msg) ); (* TValidState: State for breakpoints *) TValidState = (vsUnknown, vsValid, vsInvalid); TDBGEvaluateFlag = (defNoTypeInfo, // No Typeinfo object will be returned defSimpleTypeInfo, // Returns: Kind (skSimple, skClass, ..); TypeName (but does make no attempt to avoid an alias) defFullTypeInfo, // Get all typeinfo, resolve all anchestors defClassAutoCast // Find real class of instance, and use, instead of declared class of variable ); TDBGEvaluateFlags = set of TDBGEvaluateFlag; { TRunningProcessInfo Used to enumerate running processes. } TRunningProcessInfo = class public PID: Cardinal; ImageName: string; constructor Create(APID: Cardinal; const AImageName: string); end; TRunningProcessInfoList = TObjectList; (* TDebuggerDataMonitor / TDebuggerDataSupplier - TDebuggerDataMonitor used by the IDE to receive/request updates on all data objects - TDebuggerDataSupplier used by the debugger to provide updates on all data objects *) TDebuggerIntf = class; TDebuggerDataSupplier = class; { TDebuggerDataHandler } TDebuggerDataHandler = class private FNotifiedState: TDBGState; FOldState: TDBGState; FUpdateCount: Integer; protected //procedure DoModified; virtual; // user-modified / xml-storable data modified procedure DoStateEnterPause; virtual; procedure DoStateLeavePause; virtual; procedure DoStateLeavePauseClean; virtual; procedure DoStateChangeEx(const AOldState, ANewState: TDBGState); virtual; property NotifiedState: TDBGState read FNotifiedState; // The last state seen by DoStateChange property OldState: TDBGState read FOldState; // The state before last DoStateChange procedure DoBeginUpdate; virtual; procedure DoEndUpdate; virtual; public //destructor Destroy; override; procedure BeginUpdate; procedure EndUpdate; function IsUpdating: Boolean; end; { TDebuggerDataMonitor } TDebuggerDataMonitor = class(TDebuggerDataHandler) private FSupplier: TDebuggerDataSupplier; procedure SetSupplier(const AValue: TDebuggerDataSupplier); protected procedure DoModified; virtual; // user-modified / xml-storable data modified procedure DoNewSupplier; virtual; property Supplier: TDebuggerDataSupplier read FSupplier write SetSupplier; public destructor Destroy; override; end; { TDebuggerDataSupplier } TDebuggerDataSupplier = class(TDebuggerDataHandler) private FDebugger: TDebuggerIntf; FMonitor: TDebuggerDataMonitor; procedure SetMonitor(const AValue: TDebuggerDataMonitor); protected procedure DoNewMonitor; virtual; property Debugger: TDebuggerIntf read FDebugger write FDebugger; protected property Monitor: TDebuggerDataMonitor read FMonitor write SetMonitor; procedure DoStateLeavePauseClean; override; procedure DoStateChange(const AOldState: TDBGState); virtual; property NotifiedState: TDBGState read FNotifiedState; // The last state seen by DoStateChange property OldState: TDBGState read FOldState; // The state before last DoStateChange procedure DoBeginUpdate; override; procedure DoEndUpdate; override; public constructor Create(const ADebugger: TDebuggerIntf); destructor Destroy; override; end; {$region Breakpoints **********************************************************} (******************************************************************************) (** **) (** B R E A K P O I N T S **) (** **) (** Note: This part of the interface may/will still change to the **) (** monitor/supplier concept **) (** **) (******************************************************************************) (******************************************************************************) TDBGBreakPointKind = ( bpkSource, // source breakpoint bpkAddress, // address breakpoint bpkData // data/watchpoint ); TDBGWatchPointScope = ( wpsLocal, wpsGlobal ); TDBGWatchPointKind = ( wpkWrite, wpkRead, wpkReadWrite ); { TBaseBreakPoint } TBaseBreakPoint = class(TRefCountedColectionItem) protected FAddress: TDBGPtr; FWatchData: String; FEnabled: Boolean; FExpression: String; FHitCount: Integer; // Current counter FBreakHitCount: Integer; // The user configurable value FKind: TDBGBreakPointKind; FLine: Integer; FWatchScope: TDBGWatchPointScope; FWatchKind: TDBGWatchPointKind; FSource: String; FValid: TValidState; FInitialEnabled: Boolean; protected procedure AssignLocationTo(Dest: TPersistent); virtual; procedure AssignTo(Dest: TPersistent); override; procedure DoBreakHitCountChange; virtual; procedure DoExpressionChange; virtual; procedure DoEnableChange; virtual; procedure DoHit(const ACount: Integer; var {%H-}AContinue: Boolean); virtual; procedure SetHitCount(const AValue: Integer); procedure DoKindChange; virtual; procedure SetValid(const AValue: TValidState); protected // virtual properties function GetAddress: TDBGPtr; virtual; function GetBreakHitCount: Integer; virtual; function GetEnabled: Boolean; virtual; function GetExpression: String; virtual; function GetHitCount: Integer; virtual; function GetKind: TDBGBreakPointKind; virtual; function GetLine: Integer; virtual; function GetSource: String; virtual; function GetWatchData: String; virtual; function GetWatchScope: TDBGWatchPointScope; virtual; function GetWatchKind: TDBGWatchPointKind; virtual; function GetValid: TValidState; virtual; procedure SetAddress(const AValue: TDBGPtr); virtual; procedure SetBreakHitCount(const AValue: Integer); virtual; procedure SetEnabled(const AValue: Boolean); virtual; procedure SetExpression(const AValue: String); virtual; procedure SetInitialEnabled(const AValue: Boolean); virtual; procedure SetKind(const AValue: TDBGBreakPointKind); virtual; public constructor Create(ACollection: TCollection); override; // PublicProtectedFix ide/debugmanager.pas(867,32) Error: identifier idents no member "SetLocation" property BreakHitCount: Integer read GetBreakHitCount write SetBreakHitCount; property Enabled: Boolean read GetEnabled write SetEnabled; property Expression: String read GetExpression write SetExpression; property HitCount: Integer read GetHitCount; property InitialEnabled: Boolean read FInitialEnabled write SetInitialEnabled; property Kind: TDBGBreakPointKind read GetKind write SetKind; property Valid: TValidState read GetValid; public procedure SetLocation(const ASource: String; const ALine: Integer); virtual; procedure SetWatch(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind); virtual; // bpkAddress property Address: TDBGPtr read GetAddress write SetAddress; // bpkSource // TDBGBreakPoint: Line is the line-number as stored in the debug info // TIDEBreakPoint: Line is the location in the Source (potentially modified Source) property Line: Integer read GetLine; property Source: String read GetSource; // bpkData property WatchData: String read GetWatchData; property WatchScope: TDBGWatchPointScope read GetWatchScope; property WatchKind: TDBGWatchPointKind read GetWatchKind; end; TBaseBreakPointClass = class of TBaseBreakPoint; { TDBGBreakPoint } TDBGBreakPoint = class(TBaseBreakPoint) private FSlave: TBaseBreakPoint; function GetDebugger: TDebuggerIntf; procedure SetSlave(const ASlave : TBaseBreakPoint); protected procedure SetEnabled(const AValue: Boolean); override; procedure DoChanged; override; procedure DoStateChange(const AOldState: TDBGState); virtual; property Debugger: TDebuggerIntf read GetDebugger; public constructor Create(ACollection: TCollection); override; destructor Destroy; override; procedure Hit(var ACanContinue: Boolean); property Slave: TBaseBreakPoint read FSlave write SetSlave; procedure DoLogMessage(const AMessage: String); virtual; procedure DoLogCallStack(const {%H-}Limit: Integer); virtual; procedure DoLogExpression(const {%H-}AnExpression: String); virtual; // implemented in TGDBMIBreakpoint end; TDBGBreakPointClass = class of TDBGBreakPoint; { TBaseBreakPoints } TBaseBreakPoints = class(TCollection) private protected public constructor Create(const ABreakPointClass: TBaseBreakPointClass); destructor Destroy; override; procedure Clear; reintroduce; function Add(const ASource: String; const ALine: Integer): TBaseBreakPoint; overload; function Add(const AAddress: TDBGPtr): TBaseBreakPoint; overload; function Add(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind): TBaseBreakPoint; overload; function Find(const ASource: String; const ALine: Integer): TBaseBreakPoint; overload; function Find(const ASource: String; const ALine: Integer; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; overload; function Find(const AAddress: TDBGPtr): TBaseBreakPoint; overload; function Find(const AAddress: TDBGPtr; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; overload; function Find(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind): TBaseBreakPoint; overload; function Find(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; overload; // no items property needed, it is "overridden" anyhow end; { TDBGBreakPoints } TDBGBreakPoints = class(TBaseBreakPoints) private FDebugger: TDebuggerIntf; // reference to our debugger function GetItem(const AnIndex: Integer): TDBGBreakPoint; procedure SetItem(const AnIndex: Integer; const AValue: TDBGBreakPoint); protected procedure DoStateChange(const AOldState: TDBGState); virtual; property Debugger: TDebuggerIntf read FDebugger write FDebugger; public constructor Create(const ADebugger: TDebuggerIntf; const ABreakPointClass: TDBGBreakPointClass); function Add(const ASource: String; const ALine: Integer): TDBGBreakPoint; overload; function Add(const AAddress: TDBGPtr): TDBGBreakPoint; overload; function Add(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind): TDBGBreakPoint; overload; function Find(const ASource: String; const ALine: Integer): TDBGBreakPoint; overload; function Find(const ASource: String; const ALine: Integer; const AIgnore: TDBGBreakPoint): TDBGBreakPoint; overload; function Find(const AAddress: TDBGPtr): TDBGBreakPoint; overload; function Find(const AAddress: TDBGPtr; const {%H-}AIgnore: TDBGBreakPoint): TDBGBreakPoint; overload; function Find(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind): TDBGBreakPoint; overload; function Find(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind; const AIgnore: TDBGBreakPoint): TDBGBreakPoint; overload; property Items[const AnIndex: Integer]: TDBGBreakPoint read GetItem write SetItem; default; end; {%endregion ^^^^^ Breakpoints ^^^^^ } {$region Debug Info ***********************************************************} (******************************************************************************) (** **) (** D E B U G I N F O R M A T I O N **) (** **) (** Note: This part of the interface may/will still change. **) (** **) (******************************************************************************) (******************************************************************************) TDBGSymbolAttribute = (saRefParam, // var, const, constref passed by reference saInternalPointer, // PointerToObject saArray, saDynArray ); TDBGSymbolAttributes = set of TDBGSymbolAttribute; TDBGFieldLocation = (flPrivate, flProtected, flPublic, flPublished); TDBGFieldFlag = (ffVirtual,ffConstructor,ffDestructor); TDBGFieldFlags = set of TDBGFieldFlag; TDBGType = class; TDBGValue = record AsString: ansistring; case integer of 0: (As8Bits: BYTE); 1: (As16Bits: WORD); 2: (As32Bits: DWORD); 3: (As64Bits: QWORD); 4: (AsSingle: Single); 5: (AsDouble: Double); 6: (AsPointer: Pointer); end; { TDBGField } TDBGField = class(TObject) private FRefCount: Integer; protected FName: String; FFlags: TDBGFieldFlags; FLocation: TDBGFieldLocation; FDBGType: TDBGType; FClassName: String; procedure IncRefCount; procedure DecRefCount; property RefCount: Integer read FRefCount; public constructor Create(const AName: String; ADBGType: TDBGType; ALocation: TDBGFieldLocation; AFlags: TDBGFieldFlags = []; AClassName: String = ''); destructor Destroy; override; property Name: String read FName; property DBGType: TDBGType read FDBGType; property Location: TDBGFieldLocation read FLocation; property Flags: TDBGFieldFlags read FFlags; property ClassName: String read FClassName; // the class in which the field was declared end; { TDBGFields } TDBGFields = class(TObject) private FList: TList; function GetField(const AIndex: Integer): TDBGField; function GetCount: Integer; protected public constructor Create; destructor Destroy; override; property Count: Integer read GetCount; property Items[const AIndex: Integer]: TDBGField read GetField; default; procedure Add(const AField: TDBGField); end; TDBGTypes = class(TObject) private function GetType(const AIndex: Integer): TDBGType; function GetCount: Integer; protected FList: TList; public constructor Create; destructor Destroy; override; property Count: Integer read GetCount; property Items[const AIndex: Integer]: TDBGType read GetType; default; end; { TDBGType } TDBGType = class(TObject) private function GetFields: TDBGFields; protected FAncestor: String; FResult: TDBGType; FResultString: String; FArguments: TDBGTypes; FAttributes: TDBGSymbolAttributes; FFields: TDBGFields; FKind: TDBGSymbolKind; FMembers: TStrings; FTypeName: String; FTypeDeclaration: String; FDBGValue: TDBGValue; FBoundHigh: Integer; FBoundLow: Integer; FLen: Integer; procedure Init; virtual; public Value: TDBGValue; constructor Create(AKind: TDBGSymbolKind; const ATypeName: String); constructor Create(AKind: TDBGSymbolKind; const AArguments: TDBGTypes; AResult: TDBGType = nil); destructor Destroy; override; property Ancestor: String read FAncestor; property Arguments: TDBGTypes read FArguments; property Fields: TDBGFields read GetFields; property Kind: TDBGSymbolKind read FKind; property Attributes: TDBGSymbolAttributes read FAttributes; property TypeName: String read FTypeName; // Name/Alias as in type section. One pascal token, or empty property TypeDeclaration: String read FTypeDeclaration; // Declaration (for array, set, enum, ..) property Members: TStrings read FMembers; // Set & ENUM property Len: Integer read FLen; // Array property BoundLow: Integer read FBoundLow; // Array property BoundHigh: Integer read FBoundHigh; // Array property Result: TDBGType read FResult; end; {%endregion ^^^^^ Debug Info ^^^^^ } {%region Watches ************************************************************** ****************************************************************************** ** ** ** W A T C H E S ** ** ** ****************************************************************************** ******************************************************************************} TWatchDisplayFormat = (wdfDefault, wdfStructure, wdfChar, wdfString, wdfDecimal, wdfUnsigned, wdfFloat, wdfHex, wdfPointer, wdfMemDump ); TWatch = class; TWatchesMonitor = class; { TWatchValue } TWatchValue = class(TFreeNotifyingObject) private FTypeInfo: TDBGType; FValue: String; FValidity: TDebuggerDataState; FWatch: TWatch; procedure SetValidity(AValue: TDebuggerDataState); virtual; procedure SetValue(AValue: String); procedure SetTypeInfo(AValue: TDBGType); function GetWatch: TWatch; protected FDisplayFormat: TWatchDisplayFormat; FEvaluateFlags: TDBGEvaluateFlags; FRepeatCount: Integer; FStackFrame: Integer; FThreadId: Integer; procedure DoDataValidityChanged({%H-}AnOldValidity: TDebuggerDataState); virtual; function GetExpression: String; virtual; function GetTypeInfo: TDBGType; virtual; function GetValue: String; virtual; public constructor Create(AOwnerWatch: TWatch); destructor Destroy; override; procedure Assign(AnOther: TWatchValue); virtual; property DisplayFormat: TWatchDisplayFormat read FDisplayFormat; property EvaluateFlags: TDBGEvaluateFlags read FEvaluateFlags; property RepeatCount: Integer read FRepeatCount; property ThreadId: Integer read FThreadId; property StackFrame: Integer read FStackFrame; property Expression: String read GetExpression; property Watch: TWatch read GetWatch; public property Validity: TDebuggerDataState read FValidity write SetValidity; property Value: String read GetValue write SetValue; property TypeInfo: TDBGType read GetTypeInfo write SetTypeInfo; end; { TWatchValueList } TWatchValueList = class private FList: TList; FWatch: TWatch; function GetEntry(const AThreadId: Integer; const AStackFrame: Integer): TWatchValue; function GetEntryByIdx(AnIndex: integer): TWatchValue; protected function CreateEntry(const {%H-}AThreadId: Integer; const {%H-}AStackFrame: Integer): TWatchValue; virtual; function CopyEntry(AnEntry: TWatchValue): TWatchValue; virtual; public procedure Assign(AnOther: TWatchValueList); constructor Create(AOwnerWatch: TWatch); destructor Destroy; override; procedure Add(AnEntry: TWatchValue); procedure Clear; function Count: Integer; property EntriesByIdx[AnIndex: integer]: TWatchValue read GetEntryByIdx; property Entries[const AThreadId: Integer; const AStackFrame: Integer]: TWatchValue read GetEntry; default; property Watch: TWatch read FWatch; end; { TWatch } TWatch = class(TDelayedUdateItem) private procedure SetDisplayFormat(AValue: TWatchDisplayFormat); procedure SetEnabled(AValue: Boolean); procedure SetEvaluateFlags(AValue: TDBGEvaluateFlags); procedure SetExpression(AValue: String); procedure SetRepeatCount(AValue: Integer); function GetValue(const AThreadId: Integer; const AStackFrame: Integer): TWatchValue; protected FEnabled: Boolean; FEvaluateFlags: TDBGEvaluateFlags; FExpression: String; FDisplayFormat: TWatchDisplayFormat; FRepeatCount: Integer; FValueList: TWatchValueList; procedure DoModified; virtual; // user-storable data: expression, enabled, display-format procedure DoEnableChange; virtual; procedure DoExpressionChange; virtual; procedure DoDisplayFormatChanged; virtual; procedure AssignTo(Dest: TPersistent); override; function CreateValueList: TWatchValueList; virtual; public constructor Create(ACollection: TCollection); override; destructor Destroy; override; procedure ClearValues; virtual; public property Enabled: Boolean read FEnabled write SetEnabled; property Expression: String read FExpression write SetExpression; property DisplayFormat: TWatchDisplayFormat read FDisplayFormat write SetDisplayFormat; property EvaluateFlags: TDBGEvaluateFlags read FEvaluateFlags write SetEvaluateFlags; property RepeatCount: Integer read FRepeatCount write SetRepeatCount; property Values[const AThreadId: Integer; const AStackFrame: Integer]: TWatchValue read GetValue; end; TWatchClass = class of TWatch; { TWatches } TWatches = class(TCollection) protected function GetItemBase(const AnIndex: Integer): TWatch; procedure SetItemBase(const AnIndex: Integer; const AValue: TWatch); function WatchClass: TWatchClass; virtual; public constructor Create; procedure ClearValues; function Find(const AExpression: String): TWatch; property Items[const AnIndex: Integer]: TWatch read GetItemBase write SetItemBase; default; end; { TWatchesSupplier } TWatchesSupplier = class(TDebuggerDataSupplier) private function GetCurrentWatches: TWatches; function GetMonitor: TWatchesMonitor; procedure SetMonitor(AValue: TWatchesMonitor); protected procedure DoStateChange(const AOldState: TDBGState); override; // workaround for state changes during TWatchValue.GetValue procedure InternalRequestData(AWatchValue: TWatchValue); virtual; public constructor Create(const ADebugger: TDebuggerIntf); procedure RequestData(AWatchValue: TWatchValue); property CurrentWatches: TWatches read GetCurrentWatches; property Monitor: TWatchesMonitor read GetMonitor write SetMonitor; end; { TWatchesMonitor } TWatchesMonitor = class(TDebuggerDataMonitor) private FWatches: TWatches; function GetSupplier: TWatchesSupplier; procedure SetSupplier(AValue: TWatchesSupplier); protected function CreateWatches: TWatches; virtual; public constructor Create; destructor Destroy; override; property Watches: TWatches read FWatches; property Supplier: TWatchesSupplier read GetSupplier write SetSupplier; end; {%endregion ^^^^^ Watches ^^^^^ } {%region Locals *************************************************************** ****************************************************************************** ** ** ** L O C A L S ** ** ** ****************************************************************************** ******************************************************************************} // TODO: a more watch-like value object TLocalsMonitor = class; { TLocalsValue } TLocalsValue = class(TDbgEntityValue) private FName: String; FValue: String; protected procedure DoAssign(AnOther: TDbgEntityValue); override; public property Name: String read FName; property Value: String read FValue; end; { TLocals } TLocals = class(TDbgEntityValuesList) private function GetEntry(AnIndex: Integer): TLocalsValue; function GetName(const AnIndex: Integer): String; function GetValue(const AnIndex: Integer): String; protected function CreateEntry: TDbgEntityValue; override; public procedure Add(const AName, AValue: String); procedure SetDataValidity({%H-}AValidity: TDebuggerDataState); virtual; public function Count: Integer;reintroduce; virtual; property Entries[AnIndex: Integer]: TLocalsValue read GetEntry; property Names[const AnIndex: Integer]: String read GetName; property Values[const AnIndex: Integer]: String read GetValue; end; { TLocalsList } TLocalsList = class(TDbgEntitiesThreadStackList) private function GetEntry(AThreadId, AStackFrame: Integer): TLocals; function GetEntryByIdx(AnIndex: Integer): TLocals; protected //function CreateEntry(AThreadId, AStackFrame: Integer): TDbgEntityValuesList; override; public property EntriesByIdx[AnIndex: Integer]: TLocals read GetEntryByIdx; property Entries[AThreadId, AStackFrame: Integer]: TLocals read GetEntry; default; end; { TLocalsSupplier } TLocalsSupplier = class(TDebuggerDataSupplier) private function GetCurrentLocalsList: TLocalsList; function GetMonitor: TLocalsMonitor; procedure SetMonitor(AValue: TLocalsMonitor); protected public procedure RequestData(ALocals: TLocals); virtual; property CurrentLocalsList: TLocalsList read GetCurrentLocalsList; property Monitor: TLocalsMonitor read GetMonitor write SetMonitor; end; { TLocalsMonitor } TLocalsMonitor = class(TDebuggerDataMonitor) private FLocalsList: TLocalsList; function GetSupplier: TLocalsSupplier; procedure SetSupplier(AValue: TLocalsSupplier); protected function CreateLocalsList: TLocalsList; virtual; public constructor Create; destructor Destroy; override; property LocalsList: TLocalsList read FLocalsList; property Supplier: TLocalsSupplier read GetSupplier write SetSupplier; end; {%endregion ^^^^^ Locals ^^^^^ } {%region Line Info ************************************************************ ****************************************************************************** ** ** ** L I N E I N F O ** ** ** ****************************************************************************** ******************************************************************************} TIDELineInfoEvent = procedure(const ASender: TObject; const ASource: String) of object; { TBaseLineInfo } TBaseLineInfo = class(TObject) protected function GetSource(const {%H-}AnIndex: integer): String; virtual; public constructor Create; function Count: Integer; virtual; function GetAddress(const {%H-}AIndex: Integer; const {%H-}ALine: Integer): TDbgPtr; virtual; function GetAddress(const ASource: String; const ALine: Integer): TDbgPtr; function GetInfo({%H-}AAdress: TDbgPtr; out {%H-}ASource, {%H-}ALine, {%H-}AOffset: Integer): Boolean; virtual; function IndexOf(const {%H-}ASource: String): integer; virtual; procedure Request(const {%H-}ASource: String); virtual; procedure Cancel(const {%H-}ASource: String); virtual; public property Sources[const AnIndex: Integer]: String read GetSource; end; { TDBGLineInfo } TDBGLineInfo = class(TBaseLineInfo) private FDebugger: TDebuggerIntf; // reference to our debugger FOnChange: TIDELineInfoEvent; protected procedure Changed(ASource: String); virtual; procedure DoChange(ASource: String); procedure DoStateChange(const {%H-}AOldState: TDBGState); virtual; property Debugger: TDebuggerIntf read FDebugger write FDebugger; public constructor Create(const ADebugger: TDebuggerIntf); property OnChange: TIDELineInfoEvent read FOnChange write FOnChange; end; {%endregion ^^^^^ Line Info ^^^^^ } {%region Register ************************************************************* ****************************************************************************** ** ** ** R E G I S T E R S ** ** ** ****************************************************************************** ******************************************************************************} TRegisterDisplayFormat = (rdDefault, rdHex, rdBinary, rdOctal, rdDecimal, rdRaw); TRegisterDisplayFormats = set of TRegisterDisplayFormat; TRegistersMonitor = class; { TRegisterDisplayValue } TRegisterDisplayValue = class // Only created if ddsValid private FStringValue: String; // default, rdRaw is always in FStringValue FNumValue: QWord; FSize: Integer; // 2, 4 or 8 bytes FFlags: set of (rdvHasNum); // Calculate numeric values. FSupportedDispFormats: TRegisterDisplayFormats; function GetValue(ADispFormat: TRegisterDisplayFormat): String; public procedure Assign(AnOther: TRegisterDisplayValue); procedure SetAsNum(AValue: QWord; ASize: Integer); procedure SetAsText(AValue: String); procedure AddFormats(AFormats: TRegisterDisplayFormats); property SupportedDispFormats: TRegisterDisplayFormats read FSupportedDispFormats; property Value[ADispFormat: TRegisterDisplayFormat]: String read GetValue; end; { TRegisterValue } TRegisterValue = class(TDbgEntityValue) private FDataValidity: TDebuggerDataState; FDisplayFormat: TRegisterDisplayFormat; FModified: Boolean; FName: String; FValues: Array of TRegisterDisplayValue; function GetHasValue: Boolean; function GetHasValueFormat(ADispFormat: TRegisterDisplayFormat): Boolean; function GetValue: String; function GetValueObj: TRegisterDisplayValue; function GetValueObjFormat(ADispFormat: TRegisterDisplayFormat): TRegisterDisplayValue; procedure SetDisplayFormat(AValue: TRegisterDisplayFormat); procedure SetValue(AValue: String); function GetValueObject(ACreateNew: Boolean = False): TRegisterDisplayValue; function GetValueObject(ADispFormat: TRegisterDisplayFormat; ACreateNew: Boolean = False): TRegisterDisplayValue; procedure SetDataValidity(AValidity: TDebuggerDataState); procedure ClearDispValues; protected procedure DoAssign(AnOther: TDbgEntityValue); override; procedure DoDataValidityChanged({%H-}AnOldValidity: TDebuggerDataState); virtual; procedure DoDisplayFormatChanged({%H-}AnOldFormat: TRegisterDisplayFormat); virtual; procedure DoValueNotEvaluated; virtual; public destructor Destroy; override; property Name: String read FName; property Value: String read GetValue write SetValue; property DisplayFormat: TRegisterDisplayFormat read FDisplayFormat write SetDisplayFormat; property Modified: Boolean read FModified write FModified; property DataValidity: TDebuggerDataState read FDataValidity write SetDataValidity; property ValueObj: TRegisterDisplayValue read GetValueObj; // Will create the object for current DispFormat. Only use for setting data. property HasValue: Boolean read GetHasValue; property ValueObjFormat[ADispFormat: TRegisterDisplayFormat]: TRegisterDisplayValue read GetValueObjFormat; // Will create the object for current DispFormat. Only use for setting data. property HasValueFormat[ADispFormat: TRegisterDisplayFormat]: Boolean read GetHasValueFormat; end; { TRegisters } TRegisters = class(TDbgEntityValuesList) private FDataValidity: TDebuggerDataState; function GetEntry(AnIndex: Integer): TRegisterValue; function GetEntryByName(const AName: String): TRegisterValue; procedure SetDataValidity(AValue: TDebuggerDataState); protected function CreateEntry: TDbgEntityValue; override; procedure DoDataValidityChanged({%H-}AnOldValidity: TDebuggerDataState); virtual; public function Count: Integer; reintroduce; virtual; property Entries[AnIndex: Integer]: TRegisterValue read GetEntry; default; property EntriesByName[const AName: String]: TRegisterValue read GetEntryByName; // autocreate property DataValidity: TDebuggerDataState read FDataValidity write SetDataValidity; end; { TRegistersList } TRegistersList = class(TDbgEntitiesThreadStackList) private function GetEntry(AThreadId, AStackFrame: Integer): TRegisters; function GetEntryByIdx(AnIndex: Integer): TRegisters; protected public property EntriesByIdx[AnIndex: Integer]: TRegisters read GetEntryByIdx; property Entries[AThreadId, AStackFrame: Integer]: TRegisters read GetEntry; default; end; { TRegisterSupplier } TRegisterSupplier = class(TDebuggerDataSupplier) private function GetCurrentRegistersList: TRegistersList; function GetMonitor: TRegistersMonitor; procedure SetMonitor(AValue: TRegistersMonitor); protected public procedure RequestData(ARegisters: TRegisters); virtual; property CurrentRegistersList: TRegistersList read GetCurrentRegistersList; property Monitor: TRegistersMonitor read GetMonitor write SetMonitor; end; { TRegistersMonitor } TRegistersMonitor = class(TDebuggerDataMonitor) private FRegistersList: TRegistersList; function GetSupplier: TRegisterSupplier; procedure SetSupplier(AValue: TRegisterSupplier); protected function CreateRegistersList: TRegistersList; virtual; public constructor Create; destructor Destroy; override; property RegistersList: TRegistersList read FRegistersList; property Supplier: TRegisterSupplier read GetSupplier write SetSupplier; end; {%endregion ^^^^^ Register ^^^^^ } {%region Callstack ************************************************************ ****************************************************************************** ** ** ** C A L L S T A C K ** ** ** ****************************************************************************** ****************************************************************************** * The entries for the callstack are created on demand. This way when the * * first entry is needed, it isn't required to create the whole stack * * * * TCallStackEntry needs to stay a readonly object so its data can be shared * ******************************************************************************} TCallStackMonitor = class; { TCallStackEntryBase } TCallStackEntry = class(TObject) private FValidity: TDebuggerDataState; FIndex: Integer; FAddress: TDbgPtr; FFunctionName: String; FLine: Integer; FArguments: TStrings; protected //// for use in TThreadEntry ONLY //function GetThreadId: Integer; virtual; abstract; //function GetThreadName: String; virtual; abstract; //function GetThreadState: String; virtual; abstract; //procedure SetThreadState(AValue: String); virtual; abstract; function GetArgumentCount: Integer; function GetArgumentName(const AnIndex: Integer): String; function GetArgumentValue(const AnIndex: Integer): String; protected property Arguments: TStrings read FArguments; function GetFunctionName: String; virtual; function GetSource: String; virtual; function GetValidity: TDebuggerDataState; virtual; procedure SetValidity(AValue: TDebuggerDataState); virtual; procedure InitFields(const AIndex:Integer; const AnAddress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const ALine: Integer; AValidity: TDebuggerDataState); public constructor Create; function CreateCopy: TCallStackEntry; virtual; destructor Destroy; override; procedure Assign(AnOther: TCallStackEntry); virtual; procedure Init(const AnAddress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const {%H-}AUnitName, {%H-}AClassName, {%H-}AProcName, {%H-}AFunctionArgs: String; const ALine: Integer; AState: TDebuggerDataState = ddsValid); virtual; procedure Init(const AnAddress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const {%H-}FileName, {%H-}FullName: String; const ALine: Integer; AState: TDebuggerDataState = ddsValid); virtual; procedure ClearLocation; virtual; // TODO need a way to call Changed on TCallStack or TThreads // corrently done in SetThreadState function GetFunctionWithArg: String; //function IsCurrent: Boolean; //procedure MakeCurrent; property Address: TDbgPtr read FAddress; property ArgumentCount: Integer read GetArgumentCount; property ArgumentNames[const AnIndex: Integer]: String read GetArgumentName; property ArgumentValues[const AnIndex: Integer]: String read GetArgumentValue; property FunctionName: String read FFunctionName; property Index: Integer read FIndex; property Line: Integer read FLine; property Source: String read GetSource; property Validity: TDebuggerDataState read GetValidity write SetValidity; public //// for use in TThreadEntry ONLY //property ThreadId: Integer read GetThreadId; //property ThreadName: String read GetThreadName; //property ThreadState: String read GetThreadState write SetThreadState; end; { TCallStackBase } TCallStackBase = class(TFreeNotifyingObject) protected FCurrent: Integer; FThreadId: Integer; function GetNewCurrentIndex: Integer; virtual; function GetEntryBase(AIndex: Integer): TCallStackEntry; virtual; abstract; function GetCount: Integer; virtual; procedure SetCount(AValue: Integer); virtual; abstract; function GetCurrent: Integer; virtual; procedure SetCurrent(AValue: Integer); virtual; function GetHighestUnknown: Integer; virtual; function GetLowestUnknown: Integer; virtual; function GetRawEntries: TMap; virtual; abstract; public constructor Create; function CreateCopy: TCallStackBase; virtual; procedure Assign(AnOther: TCallStackBase); virtual; procedure PrepareRange({%H-}AIndex, {%H-}ACount: Integer); virtual; abstract; procedure DoEntriesCreated; virtual; abstract; procedure DoEntriesUpdated; virtual; abstract; procedure SetCountValidity({%H-}AValidity: TDebuggerDataState); virtual; procedure SetHasAtLeastCountInfo({%H-}AValidity: TDebuggerDataState; {%H-}AMinCount: Integer = -1); virtual; procedure SetCurrentValidity({%H-}AValidity: TDebuggerDataState); virtual; function CountLimited(ALimit: Integer): Integer; virtual; abstract; property Count: Integer read GetCount write SetCount; property CurrentIndex: Integer read GetCurrent write SetCurrent; property Entries[AIndex: Integer]: TCallStackEntry read GetEntryBase; property ThreadId: Integer read FThreadId write FThreadId; property NewCurrentIndex: Integer read GetNewCurrentIndex; property RawEntries: TMap read GetRawEntries; property LowestUnknown: Integer read GetLowestUnknown; property HighestUnknown: Integer read GetHighestUnknown; end; { TCallStackListBase } TCallStackList = class private FList: TList; function GetEntry(const AIndex: Integer): TCallStackBase; function GetEntryForThread(const AThreadId: Integer): TCallStackBase; protected function NewEntryForThread(const {%H-}AThreadId: Integer): TCallStackBase; virtual; public constructor Create; destructor Destroy; override; procedure Assign(AnOther: TCallStackList); virtual; procedure Add(ACallStack: TCallStackBase); procedure Clear; virtual; function Count: Integer; virtual; // Count of already requested CallStacks (via ThreadId) property Entries[const AIndex: Integer]: TCallStackBase read GetEntry; default; property EntriesForThreads[const AThreadId: Integer]: TCallStackBase read GetEntryForThread; end; { TCallStackSupplier } TCallStackSupplier = class(TDebuggerDataSupplier) private function GetCurrentCallStackList: TCallStackList; function GetMonitor: TCallStackMonitor; procedure SetMonitor(AValue: TCallStackMonitor); protected //procedure CurrentChanged; procedure Changed; public procedure RequestCount(ACallstack: TCallStackBase); virtual; procedure RequestAtLeastCount(ACallstack: TCallStackBase; {%H-}ARequiredMinCount: Integer); virtual; procedure RequestCurrent(ACallstack: TCallStackBase); virtual; procedure RequestEntries(ACallstack: TCallStackBase); virtual; procedure UpdateCurrentIndex; virtual; property CurrentCallStackList: TCallStackList read GetCurrentCallStackList; property Monitor: TCallStackMonitor read GetMonitor write SetMonitor; end; { TCallStackMonitor } TCallStackMonitor = class(TDebuggerDataMonitor) private FCallStackList: TCallStackList; function GetSupplier: TCallStackSupplier; procedure SetSupplier(AValue: TCallStackSupplier); protected function CreateCallStackList: TCallStackList; virtual; public constructor Create; destructor Destroy; override; property CallStackList: TCallStackList read FCallStackList; property Supplier: TCallStackSupplier read GetSupplier write SetSupplier; end; {%endregion ^^^^^ Callstack ^^^^^ } {%region ***** Disassembler ***** } (******************************************************************************) (******************************************************************************) (** **) (** D I S A S S E M B L E R **) (** **) (******************************************************************************) (******************************************************************************) PDisassemblerEntry = ^TDisassemblerEntry; TDisassemblerEntry = record Addr: TDbgPtr; // Address Dump: String; // Raw Data Statement: String; // Asm FuncName: String; // Function, if avail Offset: Integer; // Byte-Offest in Fonction SrcFileName: String; // SrcFile if avail SrcFileLine: Integer; // Line in SrcFile SrcStatementIndex: SmallInt; // Index of Statement, within list of Stmnt of the same SrcLine SrcStatementCount: SmallInt; // Count of Statements for this SrcLine end; { TBaseDisassembler } TBaseDisassembler = class(TObject) private FBaseAddr: TDbgPtr; FCountAfter: Integer; FCountBefore: Integer; FChangedLockCount: Integer; FIsChanged: Boolean; function GetEntryPtr(AIndex: Integer): PDisassemblerEntry; procedure IndexError(AIndex: Integer); function GetEntry(AIndex: Integer): TDisassemblerEntry; protected function InternalGetEntry({%H-}AIndex: Integer): TDisassemblerEntry; virtual; function InternalGetEntryPtr({%H-}AIndex: Integer): PDisassemblerEntry; virtual; procedure DoChanged; virtual; procedure Changed; procedure LockChanged; procedure UnlockChanged; procedure InternalIncreaseCountBefore(ACount: Integer); procedure InternalIncreaseCountAfter(ACount: Integer); procedure SetCountBefore(ACount: Integer); procedure SetCountAfter(ACount: Integer); procedure SetBaseAddr(AnAddr: TDbgPtr); public constructor Create; destructor Destroy; override; procedure Clear; virtual; // Returns "True", if the range is valid, if not a ChangeNotification will be triggered later function PrepareRange({%H-}AnAddr: TDbgPtr; {%H-}ALinesBefore, {%H-}ALinesAfter: Integer): Boolean; virtual; property BaseAddr: TDbgPtr read FBaseAddr; property CountAfter: Integer read FCountAfter; property CountBefore: Integer read FCountBefore; property Entries[AIndex: Integer]: TDisassemblerEntry read GetEntry; property EntriesPtr[Index: Integer]: PDisassemblerEntry read GetEntryPtr; end; { TDBGDisassemblerEntryRange } TDBGDisassemblerEntryRange = class private FCount: Integer; FEntries: array of TDisassemblerEntry; FLastEntryEndAddr: TDBGPtr; FRangeEndAddr: TDBGPtr; FRangeStartAddr: TDBGPtr; function GetCapacity: Integer; function GetEntry(Index: Integer): TDisassemblerEntry; function GetEntryPtr(Index: Integer): PDisassemblerEntry; procedure SetCapacity(const AValue: Integer); procedure SetCount(const AValue: Integer); public procedure Clear; function Append(const AnEntryPtr: PDisassemblerEntry): Integer; procedure Merge(const AnotherRange: TDBGDisassemblerEntryRange); // Actual addresses on the ranges function FirstAddr: TDbgPtr; function LastAddr: TDbgPtr; function ContainsAddr(const AnAddr: TDbgPtr; IncludeNextAddr: Boolean = False): Boolean; function IndexOfAddr(const AnAddr: TDbgPtr): Integer; function IndexOfAddrWithOffs(const AnAddr: TDbgPtr): Integer; function IndexOfAddrWithOffs(const AnAddr: TDbgPtr; out AOffs: Integer): Integer; property Count: Integer read FCount write SetCount; property Capacity: Integer read GetCapacity write SetCapacity; property Entries[Index: Integer]: TDisassemblerEntry read GetEntry; property EntriesPtr[Index: Integer]: PDisassemblerEntry read GetEntryPtr; // The first address behind last entry property LastEntryEndAddr: TDBGPtr read FLastEntryEndAddr write FLastEntryEndAddr; // The addresses for which the range was requested // The range may bo more, than the entries, if there a gaps that cannot be retrieved. property RangeStartAddr: TDBGPtr read FRangeStartAddr write FRangeStartAddr; property RangeEndAddr: TDBGPtr read FRangeEndAddr write FRangeEndAddr; end; { TDBGDisassemblerEntryMap } TDBGDisassemblerEntryMapMergeEvent = procedure(MergeReceiver, MergeGiver: TDBGDisassemblerEntryRange) of object; { TDBGDisassemblerEntryMapIterator } TDBGDisassemblerEntryMap = class; TDBGDisassemblerEntryMapIterator = class(TMapIterator) public function GetRangeForAddr(AnAddr: TDbgPtr; IncludeNextAddr: Boolean = False): TDBGDisassemblerEntryRange; function NextRange: TDBGDisassemblerEntryRange; function PreviousRange: TDBGDisassemblerEntryRange; end; TDBGDisassemblerEntryMap = class(TMap) private FIterator: TDBGDisassemblerEntryMapIterator; FOnDelete: TNotifyEvent; FOnMerge: TDBGDisassemblerEntryMapMergeEvent; FFreeItemLock: Boolean; protected procedure ReleaseData(ADataPtr: Pointer); override; public constructor Create(AIdType: TMapIdType; ADataSize: Cardinal); destructor Destroy; override; // AddRange, may destroy the object procedure AddRange(const ARange: TDBGDisassemblerEntryRange); // Arange may be freed function GetRangeForAddr(AnAddr: TDbgPtr; IncludeNextAddr: Boolean = False): TDBGDisassemblerEntryRange; property OnDelete: TNotifyEvent read FOnDelete write FOnDelete; property OnMerge: TDBGDisassemblerEntryMapMergeEvent read FOnMerge write FOnMerge; end; { TDBGDisassembler } TDBGDisassembler = class(TBaseDisassembler) private FDebugger: TDebuggerIntf; FOnChange: TNotifyEvent; FEntryRanges: TDBGDisassemblerEntryMap; FCurrentRange: TDBGDisassemblerEntryRange; procedure EntryRangesOnDelete(Sender: TObject); procedure EntryRangesOnMerge(MergeReceiver, MergeGiver: TDBGDisassemblerEntryRange); function FindRange(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; protected procedure DoChanged; override; procedure DoStateChange(const AOldState: TDBGState); virtual; function InternalGetEntry(AIndex: Integer): TDisassemblerEntry; override; function InternalGetEntryPtr(AIndex: Integer): PDisassemblerEntry; override; // PrepareEntries returns True, if it already added some entries function PrepareEntries({%H-}AnAddr: TDbgPtr; {%H-}ALinesBefore, {%H-}ALinesAfter: Integer): boolean; virtual; function HandleRangeWithInvalidAddr(ARange: TDBGDisassemblerEntryRange;{%H-}AnAddr: TDbgPtr; var {%H-}ALinesBefore, {%H-}ALinesAfter: Integer): boolean; virtual; property Debugger: TDebuggerIntf read FDebugger write FDebugger; property EntryRanges: TDBGDisassemblerEntryMap read FEntryRanges; public constructor Create(const ADebugger: TDebuggerIntf); destructor Destroy; override; procedure Clear; override; function PrepareRange(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; override; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; {%endregion ^^^^^ Disassembler ^^^^^ } {%region Threads ************************************************************** ****************************************************************************** ** ** ** T H R E A D S ** ** ** ****************************************************************************** ******************************************************************************} TThreadsMonitor = class; { TThreadEntry } TThreadEntry = class(TObject) private FTopFrame: TCallStackEntry; protected FThreadId: Integer; FThreadName: String; FThreadState: String; procedure SetThreadState(AValue: String); virtual; function CreateStackEntry: TCallStackEntry; virtual; public constructor Create; constructor Create(const AnAdress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const FileName, FullName: String; const ALine: Integer; const AThreadId: Integer; const AThreadName: String; const AThreadState: String; AState: TDebuggerDataState = ddsValid); function CreateCopy: TThreadEntry; virtual; destructor Destroy; override; procedure Assign(AnOther: TThreadEntry); virtual; published property ThreadId: Integer read FThreadId; property ThreadName: String read FThreadName; property ThreadState: String read FThreadState write SetThreadState; property TopFrame: TCallStackEntry read FTopFrame; end; { TThreadsBase } TThreads = class(TObject) private FCurrentThreadId: Integer; FList: TList; function GetEntry(const AnIndex: Integer): TThreadEntry; function GetEntryById(const AnID: Integer): TThreadEntry; protected procedure SetCurrentThreadId(AValue: Integer); virtual; property List: TList read FList; public constructor Create; destructor Destroy; override; procedure Assign(AnOther: TThreads); virtual; function Count: Integer; virtual; procedure Clear; virtual; procedure Add(AThread: TThreadEntry); virtual; procedure Remove(AThread: TThreadEntry); virtual; function CreateEntry(const AnAdress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const FileName, FullName: String; const ALine: Integer; const AThreadId: Integer; const AThreadName: String; const AThreadState: String; AState: TDebuggerDataState = ddsValid): TThreadEntry; virtual; procedure SetValidity({%H-}AValidity: TDebuggerDataState); virtual; property Entries[const AnIndex: Integer]: TThreadEntry read GetEntry; default; property EntryById[const AnID: Integer]: TThreadEntry read GetEntryById; property CurrentThreadId: Integer read FCurrentThreadId write SetCurrentThreadId; end; { TThreadsSupplier } TThreadsSupplier = class(TDebuggerDataSupplier) private function GetCurrentThreads: TThreads; function GetMonitor: TThreadsMonitor; procedure SetMonitor(AValue: TThreadsMonitor); protected procedure DoStateChange(const AOldState: TDBGState); override; procedure DoStateLeavePauseClean; override; procedure DoCleanAfterPause; virtual; public procedure RequestMasterData; virtual; procedure ChangeCurrentThread({%H-}ANewId: Integer); virtual; procedure Changed; // TODO: needed because entries can not notify the monitor property CurrentThreads: TThreads read GetCurrentThreads; property Monitor: TThreadsMonitor read GetMonitor write SetMonitor; end; { TThreadsMonitor } TThreadsMonitor = class(TDebuggerDataMonitor) private FThreads: TThreads; function GetSupplier: TThreadsSupplier; procedure SetSupplier(AValue: TThreadsSupplier); protected function CreateThreads: TThreads; virtual; public constructor Create; destructor Destroy; override; property Threads: TThreads read FThreads; property Supplier: TThreadsSupplier read GetSupplier write SetSupplier; end; {%endregion ^^^^^ Threads ^^^^^ } {%region Signals / Exceptions *************************************************} (******************************************************************************) (** **) (** S I G N A L S and E X C E P T I O N S **) (** **) (******************************************************************************) (******************************************************************************) { TBaseSignal } TBaseSignal = class(TDelayedUdateItem) private FHandledByDebugger: Boolean; FID: Integer; FName: String; FResumeHandled: Boolean; protected procedure AssignTo(Dest: TPersistent); override; procedure SetHandledByDebugger(const AValue: Boolean); virtual; procedure SetID(const AValue: Integer); virtual; procedure SetName(const AValue: String); virtual; procedure SetResumeHandled(const AValue: Boolean); virtual; public constructor Create(ACollection: TCollection); override; property ID: Integer read FID write SetID; property Name: String read FName write SetName; property HandledByDebugger: Boolean read FHandledByDebugger write SetHandledByDebugger; property ResumeHandled: Boolean read FResumeHandled write SetResumeHandled; end; TBaseSignalClass = class of TBaseSignal; { TDBGSignal } TDBGSignal = class(TBaseSignal) private function GetDebugger: TDebuggerIntf; protected property Debugger: TDebuggerIntf read GetDebugger; public end; TDBGSignalClass = class of TDBGSignal; { TBaseSignals } TBaseSignals = class(TCollection) private protected public constructor Create(const AItemClass: TBaseSignalClass); procedure Reset; virtual; function Add(const AName: String; AID: Integer): TBaseSignal; function Find(const AName: String): TBaseSignal; end; { TDBGSignals } TDBGSignals = class(TBaseSignals) private FDebugger: TDebuggerIntf; // reference to our debugger function GetItem(const AIndex: Integer): TDBGSignal; procedure SetItem(const AIndex: Integer; const AValue: TDBGSignal); protected public constructor Create(const ADebugger: TDebuggerIntf; const ASignalClass: TDBGSignalClass); function Add(const AName: String; AID: Integer): TDBGSignal; function Find(const AName: String): TDBGSignal; public property Items[const AIndex: Integer]: TDBGSignal read GetItem write SetItem; default; end; { TBaseException } TBaseException = class(TDelayedUdateItem) private procedure SetEnabled(AValue: Boolean); protected FEnabled: Boolean; FName: String; procedure AssignTo(Dest: TPersistent); override; procedure SetName(const AValue: String); virtual; public constructor Create(ACollection: TCollection); override; public property Name: String read FName write SetName; property Enabled: Boolean read FEnabled write SetEnabled; // ignored if enabled end; TBaseExceptionClass = class of TBaseException; { TDBGException } TDBGException = class(TBaseException) private protected public end; TDBGExceptionClass = class of TDBGException; { TBaseExceptions } TBaseExceptions = class(TCollection) private function GetItem(const AIndex: Integer): TBaseException; procedure SetItem(const AIndex: Integer; AValue: TBaseException); protected FIgnoreAll: Boolean; procedure AssignTo(Dest: TPersistent); override; procedure ClearExceptions; virtual; procedure SetIgnoreAll(const AValue: Boolean); virtual; public constructor Create(const AItemClass: TBaseExceptionClass); destructor Destroy; override; procedure Reset; virtual; function Add(const AName: String): TBaseException; function Find(const AName: String): TBaseException; property IgnoreAll: Boolean read FIgnoreAll write SetIgnoreAll; property Items[const AIndex: Integer]: TBaseException read GetItem write SetItem; default; end; {%endregion ^^^^^ Signals / Exceptions ^^^^^ } (******************************************************************************) (******************************************************************************) (** **) (** D E B U G G E R **) (** **) (******************************************************************************) (******************************************************************************) TDBGEventCategory = ( ecBreakpoint, // Breakpoint hit ecProcess, // Process start, process stop ecThread, // Thread creation, destruction, start, etc. ecModule, // Library load and unload ecOutput, // DebugOutput calls ecWindows, // Windows events ecDebugger); // debugger errors and warnings TDBGEventCategories = set of TDBGEventCategory; TDBGEventType = ( etDefault, // ecBreakpoint category etBreakpointEvaluation, etBreakpointHit, etBreakpointMessage, etBreakpointStackDump, etExceptionRaised, // ecModule category etModuleLoad, etModuleUnload, // ecOutput category etOutputDebugString, // ecProcess category etProcessExit, etProcessStart, // ecThread category etThreadExit, etThreadStart, // ecWindows category etWindowsMessagePosted, etWindowsMessageSent ); TDBGFeedbackType = (ftInformation, ftWarning, ftError); TDBGFeedbackResult = (frOk, frStop); TDBGFeedbackResults = set of TDBGFeedbackResult; TDBGEventNotify = procedure(Sender: TObject; const ACategory: TDBGEventCategory; const AEventType: TDBGEventType; const AText: String) of object; TDebuggerStateChangedEvent = procedure(ADebugger: TDebuggerIntf; AOldState: TDBGState) of object; TDebuggerBreakPointHitEvent = procedure(ADebugger: TDebuggerIntf; ABreakPoint: TBaseBreakPoint; var ACanContinue: Boolean) of object; TDBGOutputEvent = procedure(Sender: TObject; const AText: String) of object; TDBGCurrentLineEvent = procedure(Sender: TObject; const ALocation: TDBGLocationRec) of object; TDBGExceptionEvent = procedure(Sender: TObject; const AExceptionType: TDBGExceptionType; const AExceptionClass: String; const AExceptionLocation: TDBGLocationRec; const AExceptionText: String; out AContinue: Boolean) of object; TDBGFeedbackEvent = function(Sender: TObject; const AText, AInfo: String; AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults ): TDBGFeedbackResult of object; TDebuggerNotifyReason = (dnrDestroy); { TDebuggerProperties } TDebuggerProperties = class(TPersistent) private public constructor Create; virtual; procedure Assign({%H-}Source: TPersistent); override; published end; TDebuggerPropertiesClass= class of TDebuggerProperties; { TDebuggerIntf } TDebuggerIntf = class private FArguments: String; FBreakPoints: TDBGBreakPoints; FDebuggerEnvironment: TStrings; FCurEnvironment: TStrings; FDisassembler: TDBGDisassembler; FEnvironment: TStrings; FErrorStateInfo: String; FErrorStateMessage: String; FExceptions: TBaseExceptions; FExitCode: Integer; FExternalDebugger: String; FFileName: String; FLocals: TLocalsSupplier; FLineInfo: TDBGLineInfo; //FUnitInfoProvider, FInternalUnitInfoProvider: TDebuggerUnitInfoProvider; FOnBeforeState: TDebuggerStateChangedEvent; FOnConsoleOutput: TDBGOutputEvent; FOnFeedback: TDBGFeedbackEvent; FOnIdle: TNotifyEvent; FRegisters: TRegisterSupplier; FShowConsole: Boolean; FSignals: TDBGSignals; FState: TDBGState; FCallStack: TCallStackSupplier; FWatches: TWatchesSupplier; FThreads: TThreadsSupplier; FOnCurrent: TDBGCurrentLineEvent; FOnException: TDBGExceptionEvent; FOnOutput: TDBGOutputEvent; FOnDbgOutput: TDBGOutputEvent; FOnDbgEvent: TDBGEventNotify; FOnState: TDebuggerStateChangedEvent; FOnBreakPointHit: TDebuggerBreakPointHitEvent; FWorkingDir: String; FDestroyNotificationList: array [TDebuggerNotifyReason] of TMethodList; procedure DebuggerEnvironmentChanged(Sender: TObject); procedure EnvironmentChanged(Sender: TObject); //function GetUnitInfoProvider: TDebuggerUnitInfoProvider; function GetState: TDBGState; function ReqCmd(const ACommand: TDBGCommand; const AParams: array of const): Boolean; procedure SetDebuggerEnvironment (const AValue: TStrings ); procedure SetEnvironment(const AValue: TStrings); procedure SetFileName(const AValue: String); protected procedure ResetStateToIdle; virtual; function CreateBreakPoints: TDBGBreakPoints; virtual; function CreateLocals: TLocalsSupplier; virtual; function CreateLineInfo: TDBGLineInfo; virtual; function CreateRegisters: TRegisterSupplier; virtual; function CreateCallStack: TCallStackSupplier; virtual; function CreateDisassembler: TDBGDisassembler; virtual; function CreateWatches: TWatchesSupplier; virtual; function CreateThreads: TThreadsSupplier; virtual; function CreateSignals: TDBGSignals; virtual; procedure DoCurrent(const ALocation: TDBGLocationRec); procedure DoDbgOutput(const AText: String); procedure DoDbgEvent(const ACategory: TDBGEventCategory; const AEventType: TDBGEventType; const AText: String); procedure DoException(const AExceptionType: TDBGExceptionType; const AExceptionClass: String; const AExceptionLocation: TDBGLocationRec; const AExceptionText: String; out AContinue: Boolean); procedure DoOutput(const AText: String); procedure DoBreakpointHit(const ABreakPoint: TBaseBreakPoint; var ACanContinue: Boolean); procedure DoBeforeState(const OldState: TDBGState); virtual; procedure DoState(const OldState: TDBGState); virtual; function ChangeFileName: Boolean; virtual; function GetCommands: TDBGCommands; virtual; function GetSupportedCommands: TDBGCommands; virtual; function GetTargetWidth: Byte; virtual; function GetWaiting: Boolean; virtual; function GetIsIdle: Boolean; virtual; function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; virtual; abstract; // True if succesful procedure SetExitCode(const AValue: Integer); procedure SetState(const AValue: TDBGState); procedure SetErrorState(const AMsg: String; const AInfo: String = ''); procedure DoRelease; virtual; public class function Caption: String; virtual; // The name of the debugger as shown in the debuggeroptions class function ExePaths: String; virtual; // The default locations of the exe class function HasExePath: boolean; virtual; // If the debugger needs to have an exe path // debugger properties class function CreateProperties: TDebuggerProperties; virtual; // Creates debuggerproperties class function GetProperties: TDebuggerProperties; // Get the current properties class procedure SetProperties(const AProperties: TDebuggerProperties); // Set the current properties (* TODO: This method is a workaround for http://bugs.freepascal.org/view.php?id=21834 See main.pp 12188 function TMainIDE.DoInitProjectRun: TModalResult; See debugmanager function TDebugManager.InitDebugger: Boolean; Checks could be performed in SetFileName, invalidating debuggerstate Errors should also be reported by debugger *) class function RequiresLocalExecutable: Boolean; virtual; public constructor Create(const AExternalDebugger: String); virtual; destructor Destroy; override; procedure Init; virtual; // Initializes the debugger procedure Done; virtual; // Kills the debugger procedure Release; // Free/Destroy self procedure Run; // Starts / continues debugging procedure Pause; // Stops running procedure Stop; // quit debugging procedure StepOver; procedure StepInto; procedure StepOverInstr; procedure StepIntoInstr; procedure StepOut; procedure RunTo(const ASource: String; const ALine: Integer); // Executes til a certain point procedure JumpTo(const ASource: String; const ALine: Integer); // No execute, only set exec point procedure Attach(AProcessID: String); procedure Detach; procedure SendConsoleInput(AText: String); function Evaluate(const AExpression: String; var AResult: String; var ATypeInfo: TDBGType; EvalFlags: TDBGEvaluateFlags = []): Boolean; // Evaluates the given expression, returns true if valid function GetProcessList({%H-}AList: TRunningProcessInfoList): boolean; virtual; function Modify(const AExpression, AValue: String): Boolean; // Modifies the given expression, returns true if valid function Disassemble(AAddr: TDbgPtr; ABackward: Boolean; out ANextAddr: TDbgPtr; out ADump, AStatement, AFile: String; out ALine: Integer): Boolean; deprecated; function GetLocation: TDBGLocationRec; virtual; procedure LockCommandProcessing; virtual; procedure UnLockCommandProcessing; virtual; function NeedReset: Boolean; virtual; procedure AddNotifyEvent(AReason: TDebuggerNotifyReason; AnEvent: TNotifyEvent); procedure RemoveNotifyEvent(AReason: TDebuggerNotifyReason; AnEvent: TNotifyEvent); public property Arguments: String read FArguments write FArguments; // Arguments feed to the program property BreakPoints: TDBGBreakPoints read FBreakPoints; // list of all breakpoints property CallStack: TCallStackSupplier read FCallStack; property Disassembler: TDBGDisassembler read FDisassembler; property Commands: TDBGCommands read GetCommands; // All current available commands of the debugger property DebuggerEnvironment: TStrings read FDebuggerEnvironment write SetDebuggerEnvironment; // The environment passed to the debugger process property Environment: TStrings read FEnvironment write SetEnvironment; // The environment passed to the debuggee property Exceptions: TBaseExceptions read FExceptions write FExceptions; // A list of exceptions we should ignore property ExitCode: Integer read FExitCode; property ExternalDebugger: String read FExternalDebugger; // The name of the debugger executable property FileName: String read FFileName write SetFileName; // The name of the exe to be debugged property Locals: TLocalsSupplier read FLocals; // list of all localvars etc property LineInfo: TDBGLineInfo read FLineInfo; // list of all source LineInfo property Registers: TRegisterSupplier read FRegisters; // list of all registers property Signals: TDBGSignals read FSignals; // A list of actions for signals we know property ShowConsole: Boolean read FShowConsole write FShowConsole; // Indicates if the debugger should create a console for the debuggee property State: TDBGState read FState; // The current state of the debugger property SupportedCommands: TDBGCommands read GetSupportedCommands; // All available commands of the debugger property TargetWidth: Byte read GetTargetWidth; // Currently only 32 or 64 property Waiting: Boolean read GetWaiting; // Set when the debugger is wating for a command to complete property Watches: TWatchesSupplier read FWatches; // list of all watches etc property Threads: TThreadsSupplier read FThreads; property WorkingDir: String read FWorkingDir write FWorkingDir; // The working dir of the exe being debugged property IsIdle: Boolean read GetIsIdle; // Nothing queued property ErrorStateMessage: String read FErrorStateMessage; property ErrorStateInfo: String read FErrorStateInfo; //property UnitInfoProvider: TDebuggerUnitInfoProvider // Provided by DebugBoss, to map files to packages or project // read GetUnitInfoProvider write FUnitInfoProvider; // Events property OnCurrent: TDBGCurrentLineEvent read FOnCurrent write FOnCurrent; // Passes info about the current line being debugged property OnDbgOutput: TDBGOutputEvent read FOnDbgOutput write FOnDbgOutput; // Passes all debuggeroutput property OnDbgEvent: TDBGEventNotify read FOnDbgEvent write FOnDbgEvent; // Passes recognized debugger events, like library load or unload property OnException: TDBGExceptionEvent read FOnException write FOnException; // Fires when the debugger received an exeption property OnOutput: TDBGOutputEvent read FOnOutput write FOnOutput; // Passes all output of the debugged target property OnBeforeState: TDebuggerStateChangedEvent read FOnBeforeState write FOnBeforeState; // Fires when the current state of the debugger changes property OnState: TDebuggerStateChangedEvent read FOnState write FOnState; // Fires when the current state of the debugger changes property OnBreakPointHit: TDebuggerBreakPointHitEvent read FOnBreakPointHit write FOnBreakPointHit; // Fires when the program is paused at a breakpoint property OnConsoleOutput: TDBGOutputEvent read FOnConsoleOutput write FOnConsoleOutput; // Passes Application Console Output property OnFeedback: TDBGFeedbackEvent read FOnFeedback write FOnFeedback; property OnIdle: TNotifyEvent read FOnIdle write FOnIdle; // Called if all outstanding requests are processed (queue empty) end; TDebuggerClass = class of TDebuggerIntf; TBaseDebugManagerIntf = class(TComponent) protected function GetDebuggerClass(const AIndex: Integer): TDebuggerClass; function FindDebuggerClass(const Astring: String): TDebuggerClass; public function DebuggerCount: Integer; end; procedure RegisterDebugger(const ADebuggerClass: TDebuggerClass); function dbgs(AState: TDBGState): String; overload; function dbgs(ADataState: TDebuggerDataState): String; overload; function dbgs(AKind: TDBGSymbolKind): String; overload; function dbgs(AnAttribute: TDBGSymbolAttribute): String; overload; function dbgs(AnAttributes: TDBGSymbolAttributes): String; overload; function dbgs(ADisassRange: TDBGDisassemblerEntryRange): String; overload; function dbgs(ACategory: TDBGEventCategory): String; overload; function dbgs(AFlag: TDBGEvaluateFlag): String; overload; function dbgs(AFlags: TDBGEvaluateFlags): String; overload; function dbgs(AName: TDBGCommand): String; overload; var DbgStateChangeCounter: Integer = 0; // workaround for state changes during TWatchValue.GetValue implementation var DBG_STATE, DBG_EVENTS, DBG_STATE_EVENT, DBG_DATA_MONITORS, DBG_VERBOSE, DBG_WARNINGS, DBG_DISASSEMBLER: PLazLoggerLogGroup; const COMMANDMAP: array[TDBGState] of TDBGCommands = ( {dsNone } [], {dsIdle } [dcEnvironment], {dsStop } [dcRun, dcStepOver, dcStepInto, dcStepOverInstr, dcStepIntoInstr, dcAttach, dcBreak, dcWatch, dcEvaluate, dcEnvironment, dcSendConsoleInput], {dsPause} [dcRun, dcStop, dcStepOver, dcStepInto, dcStepOverInstr, dcStepIntoInstr, dcStepOut, dcRunTo, dcJumpto, dcDetach, dcBreak, dcWatch, dcLocal, dcEvaluate, dcModify, dcEnvironment, dcSetStackFrame, dcDisassemble, dcSendConsoleInput], {dsInternalPause} // same as run, so not really used [dcStop, dcBreak, dcWatch, dcEnvironment, dcSendConsoleInput], {dsInit } [], {dsRun } [dcPause, dcStop, dcDetach, dcBreak, dcWatch, dcEnvironment, dcSendConsoleInput], {dsError} [dcStop], {dsDestroying} [] ); var MDebuggerPropertiesList: TStringlist = nil; MDebuggerClasses: TStringList; procedure RegisterDebugger(const ADebuggerClass: TDebuggerClass); begin MDebuggerClasses.AddObject(ADebuggerClass.ClassName, TObject(Pointer(ADebuggerClass))); end; procedure DoFinalization; var n: Integer; begin if MDebuggerPropertiesList <> nil then begin for n := 0 to MDebuggerPropertiesList.Count - 1 do MDebuggerPropertiesList.Objects[n].Free; FreeAndNil(MDebuggerPropertiesList); end; end; function dbgs(AState: TDBGState): String; overload; begin Result := ''; WriteStr(Result, AState); end; function dbgs(ADataState: TDebuggerDataState): String; begin writestr(Result{%H-}, ADataState); end; function dbgs(AKind: TDBGSymbolKind): String; begin writestr(Result{%H-}, AKind); end; function dbgs(AnAttribute: TDBGSymbolAttribute): String; begin writestr(Result{%H-}, AnAttribute); end; function dbgs(AnAttributes: TDBGSymbolAttributes): String; var i: TDBGSymbolAttribute; begin Result:=''; for i := low(TDBGSymbolAttributes) to high(TDBGSymbolAttributes) do if i in AnAttributes then begin if Result <> '' then Result := Result + ', '; Result := Result + dbgs(i); end; if Result <> '' then Result := '[' + Result + ']'; end; function dbgs(ACategory: TDBGEventCategory): String; begin writestr(Result{%H-}, ACategory); end; function dbgs(AFlag: TDBGEvaluateFlag): String; begin Result := ''; WriteStr(Result, AFlag); end; function dbgs(AFlags: TDBGEvaluateFlags): String; var i: TDBGEvaluateFlag; begin Result:=''; for i := low(TDBGEvaluateFlags) to high(TDBGEvaluateFlags) do if i in AFlags then begin if Result <> '' then Result := Result + ', '; Result := Result + dbgs(i); end; Result := '[' + Result + ']'; end; function dbgs(AName: TDBGCommand): String; begin Result := ''; WriteStr(Result, AName); end; function dbgs(ADisassRange: TDBGDisassemblerEntryRange): String; overload; var fo: Integer; begin if (ADisassRange = nil) then begin Result := 'Range(nil)' end else begin if (ADisassRange.Count > 0) then fo := ADisassRange.EntriesPtr[0]^.Offset else fo := 0; {$PUSH}{$RANGECHECKS OFF} with ADisassRange do Result := Format('Range(%u)=[[ Cnt=%d, Capac=%d, [0].Addr=%u, RFirst=%u, [Cnt].Addr=%u, RLast=%u, REnd=%u, FirstOfs=%d ]]', [PtrUInt(ADisassRange), Count, Capacity, FirstAddr, RangeStartAddr, LastAddr, RangeEndAddr, LastEntryEndAddr, fo]); {$POP} end; end; { TThreadEntry } procedure TThreadEntry.SetThreadState(AValue: String); begin if FThreadState = AValue then Exit; FThreadState := AValue; end; function TThreadEntry.CreateStackEntry: TCallStackEntry; begin Result := TCallStackEntry.Create; end; constructor TThreadEntry.Create; begin FTopFrame := CreateStackEntry; inherited Create; end; constructor TThreadEntry.Create(const AnAdress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const FileName, FullName: String; const ALine: Integer; const AThreadId: Integer; const AThreadName: String; const AThreadState: String; AState: TDebuggerDataState); begin Create; TopFrame.Init(AnAdress, AnArguments, AFunctionName, FileName, FullName, ALine, AState); FThreadId := AThreadId; FThreadName := AThreadName; FThreadState := AThreadState; end; function TThreadEntry.CreateCopy: TThreadEntry; begin Result := TThreadEntry.Create; Result.Assign(Self); end; destructor TThreadEntry.Destroy; begin inherited Destroy; FreeAndNil(FTopFrame); end; procedure TThreadEntry.Assign(AnOther: TThreadEntry); begin FTopFrame.Free; FTopFrame := AnOther.TopFrame.CreateCopy; FThreadId := AnOther.FThreadId; FThreadName := AnOther.FThreadName; FThreadState := AnOther.FThreadState; end; { TThreads } function TThreads.GetEntry(const AnIndex: Integer): TThreadEntry; begin if (AnIndex < 0) or (AnIndex >= Count) then exit(nil); Result := TThreadEntry(FList[AnIndex]); end; function TThreads.GetEntryById(const AnID: Integer): TThreadEntry; var i: Integer; begin i := Count - 1; while i >= 0 do begin Result := Entries[i]; if Result.ThreadId = AnID then exit; dec(i); end; Result := nil; end; procedure TThreads.SetCurrentThreadId(AValue: Integer); begin if FCurrentThreadId = AValue then exit; FCurrentThreadId := AValue; end; constructor TThreads.Create; begin FList := TList.Create; end; destructor TThreads.Destroy; begin Clear; FreeAndNil(FList); inherited Destroy; end; procedure TThreads.Assign(AnOther: TThreads); var i: Integer; begin Clear; FCurrentThreadId := AnOther.FCurrentThreadId; for i := 0 to AnOther.FList.Count-1 do FList.Add(TThreadEntry(AnOther.FList[i]).CreateCopy); end; function TThreads.Count: Integer; begin Result := FList.Count; end; procedure TThreads.Clear; begin while FList.Count > 0 do begin TThreadEntry(Flist[0]).Free; FList.Delete(0); end; end; procedure TThreads.Add(AThread: TThreadEntry); begin FList.Add(AThread.CreateCopy); if FList.Count = 1 then FCurrentThreadId := AThread.ThreadId; end; procedure TThreads.Remove(AThread: TThreadEntry); begin FList.Remove(AThread); if FCurrentThreadId = AThread.ThreadId then begin if FList.Count > 0 then FCurrentThreadId := Entries[0].ThreadId else FCurrentThreadId := 0; end; AThread.Free; end; function TThreads.CreateEntry(const AnAdress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const FileName, FullName: String; const ALine: Integer; const AThreadId: Integer; const AThreadName: String; const AThreadState: String; AState: TDebuggerDataState): TThreadEntry; begin Result := TThreadEntry.Create(AnAdress, AnArguments, AFunctionName, FileName, FullName, ALine, AThreadId, AThreadName, AThreadState, AState); end; procedure TThreads.SetValidity(AValidity: TDebuggerDataState); begin // end; { TThreadsMonitor } function TThreadsMonitor.GetSupplier: TThreadsSupplier; begin Result := TThreadsSupplier(inherited Supplier); end; procedure TThreadsMonitor.SetSupplier(AValue: TThreadsSupplier); begin inherited Supplier := AValue; end; function TThreadsMonitor.CreateThreads: TThreads; begin Result := TThreads.Create; end; constructor TThreadsMonitor.Create; begin FThreads := CreateThreads; inherited Create; end; destructor TThreadsMonitor.Destroy; begin inherited Destroy; FreeAndNil(FThreads); end; { TRegistersMonitor } function TRegistersMonitor.GetSupplier: TRegisterSupplier; begin Result := TRegisterSupplier(inherited Supplier); end; procedure TRegistersMonitor.SetSupplier(AValue: TRegisterSupplier); begin inherited Supplier := AValue; end; function TRegistersMonitor.CreateRegistersList: TRegistersList; begin Result := TRegistersList.Create; end; constructor TRegistersMonitor.Create; begin inherited Create; FRegistersList := CreateRegistersList; FRegistersList.AddReference; end; destructor TRegistersMonitor.Destroy; begin inherited Destroy; ReleaseRefAndNil(FRegistersList); end; { TDebuggerDataHandler } procedure TDebuggerDataHandler.DoStateEnterPause; begin // end; procedure TDebuggerDataHandler.DoStateLeavePause; begin // end; procedure TDebuggerDataHandler.DoStateLeavePauseClean; begin // end; procedure TDebuggerDataHandler.DoStateChangeEx(const AOldState, ANewState: TDBGState); begin FNotifiedState := ANewState; FOldState := AOldState; DebugLnEnter(DBG_DATA_MONITORS, [ClassName, ': >>ENTER: ', ClassName, '.DoStateChange New-State=', dbgs(FNotifiedState)]); if FNotifiedState in [dsPause, dsInternalPause] then begin // typical: Clear and reload data if not(AOldState in [dsPause, dsInternalPause] ) then DoStateEnterPause; end else if (AOldState in [dsPause, dsInternalPause, dsNone] ) then begin // dsIdle happens after dsStop if (FNotifiedState in [dsRun, dsInit, dsIdle]) or (AOldState = dsNone) then begin // typical: finalize snapshot and clear data. DoStateLeavePauseClean; end else begin // typical: finalize snapshot // Do *not* clear data. Objects may be in use (e.g. dsError) DoStateLeavePause; end; end else if (AOldState in [dsStop]) and (FNotifiedState = dsIdle) then begin // stopped // typical: finalize snapshot and clear data. DoStateLeavePauseClean; end; DebugLnExit(DBG_DATA_MONITORS, [ClassName, ': < 0, 'TDebuggerDataMonitor.EndUpdate: FUpdateCount > 0'); dec(FUpdateCount); if FUpdateCount = 0 then DoEndUpdate; end; function TDebuggerDataHandler.IsUpdating: Boolean; begin Result := FUpdateCount > 0; end; { TWatchValue } procedure TWatchValue.SetValidity(AValue: TDebuggerDataState); var OldValidity: TDebuggerDataState; begin if FValidity = AValue then exit; //DebugLn(DBG_DATA_MONITORS, ['DebugDataMonitor: TWatchValue.SetValidity: FThreadId=', FThreadId, ' FStackFrame=',FStackFrame, ' Expr=', Expression, ' AValidity=',dbgs(AValue)]); DebugLn(DBG_DATA_MONITORS, ['DebugDataMonitor: TWatchValue.SetValidity: Expr=', Expression, ' AValidity=',dbgs(AValue)]); OldValidity := FValidity; FValidity := AValue; DoDataValidityChanged(OldValidity); end; procedure TWatchValue.SetValue(AValue: String); begin if FValue = AValue then exit; //asser not immutable FValue := AValue; end; procedure TWatchValue.SetTypeInfo(AValue: TDBGType); begin //assert(Self is TCurrentWatchValue, 'TWatchValue.SetTypeInfo'); FreeAndNil(FTypeInfo); FTypeInfo := AValue; end; procedure TWatchValue.DoDataValidityChanged(AnOldValidity: TDebuggerDataState); begin end; function TWatchValue.GetExpression: String; begin Result := FWatch.Expression; end; function TWatchValue.GetTypeInfo: TDBGType; begin Result := FTypeInfo; end; function TWatchValue.GetValue: String; begin Result := FValue; end; constructor TWatchValue.Create(AOwnerWatch: TWatch); begin FWatch := AOwnerWatch; inherited Create; end; function TWatchValue.GetWatch: TWatch; begin Result := FWatch; end; destructor TWatchValue.Destroy; begin inherited Destroy; FreeAndNil(FTypeInfo); end; procedure TWatchValue.Assign(AnOther: TWatchValue); begin FreeAndNil(FTypeInfo); //FTypeInfo := TWatchValue(AnOther).FTypeInfo.cre; FValue := AnOther.FValue; FValidity := AnOther.FValidity; end; { TWatch } procedure TWatch.SetDisplayFormat(AValue: TWatchDisplayFormat); begin if AValue = FDisplayFormat then exit; FDisplayFormat := AValue; DoDisplayFormatChanged; end; procedure TWatch.SetEnabled(AValue: Boolean); begin if FEnabled <> AValue then begin FEnabled := AValue; DoEnableChange; end; end; procedure TWatch.SetEvaluateFlags(AValue: TDBGEvaluateFlags); begin if FEvaluateFlags = AValue then Exit; FEvaluateFlags := AValue; Changed; DoModified; end; procedure TWatch.SetExpression(AValue: String); begin if AValue <> FExpression then begin FExpression := AValue; FValueList.Clear; DoExpressionChange; end; end; procedure TWatch.SetRepeatCount(AValue: Integer); begin if FRepeatCount = AValue then Exit; FRepeatCount := AValue; Changed; DoModified; end; function TWatch.GetValue(const AThreadId: Integer; const AStackFrame: Integer): TWatchValue; begin Result := FValueList[AThreadId, AStackFrame]; end; procedure TWatch.DoModified; begin // end; procedure TWatch.DoEnableChange; begin // end; procedure TWatch.DoExpressionChange; begin // end; procedure TWatch.DoDisplayFormatChanged; begin // end; procedure TWatch.AssignTo(Dest: TPersistent); begin if Dest is TWatch then begin TWatch(Dest).FExpression := FExpression; TWatch(Dest).FEnabled := FEnabled; TWatch(Dest).FDisplayFormat := FDisplayFormat; TWatch(Dest).FRepeatCount := FRepeatCount; TWatch(Dest).FEvaluateFlags := FEvaluateFlags; TWatch(Dest).FValueList.Assign(FValueList); end else inherited; end; function TWatch.CreateValueList: TWatchValueList; begin Result := TWatchValueList.Create(Self); end; constructor TWatch.Create(ACollection: TCollection); begin FEnabled := False; FValueList := CreateValueList; inherited Create(ACollection); end; destructor TWatch.Destroy; begin FValueList.Clear; inherited Destroy; FreeAndNil(FValueList); end; procedure TWatch.ClearValues; begin FValueList.Clear; end; { TWatchValueList } function TWatchValueList.GetEntry(const AThreadId: Integer; const AStackFrame: Integer): TWatchValue; var i: Integer; begin i := FList.Count - 1; while i >= 0 do begin Result := TWatchValue(FList[i]); if (Result.ThreadId = AThreadId) and (Result.StackFrame = AStackFrame) and (Result.DisplayFormat = FWatch.DisplayFormat) and (Result.RepeatCount = FWatch.RepeatCount) and (Result.EvaluateFlags = FWatch.EvaluateFlags) then exit; dec(i); end; Result := CreateEntry(AThreadId, AStackFrame); end; function TWatchValueList.GetEntryByIdx(AnIndex: integer): TWatchValue; begin Result := TWatchValue(FList[AnIndex]); end; function TWatchValueList.CreateEntry(const AThreadId: Integer; const AStackFrame: Integer): TWatchValue; begin Result := nil; end; function TWatchValueList.CopyEntry(AnEntry: TWatchValue): TWatchValue; begin Result := TWatchValue.Create(FWatch); Result.Assign(AnEntry); end; procedure TWatchValueList.Assign(AnOther: TWatchValueList); var i: Integer; begin Clear; for i := 0 to AnOther.FList.Count - 1 do begin FList.Add(CopyEntry(TWatchValue(AnOther.FList[i]))); end; end; constructor TWatchValueList.Create(AOwnerWatch: TWatch); begin assert(AOwnerWatch <> nil, 'TWatchValueList.Create without owner'); FList := TList.Create; FWatch := AOwnerWatch; inherited Create; end; destructor TWatchValueList.Destroy; begin Clear; inherited Destroy; FreeAndNil(FList); end; procedure TWatchValueList.Add(AnEntry: TWatchValue); begin Flist.Add(AnEntry); end; procedure TWatchValueList.Clear; begin while FList.Count > 0 do begin TObject(FList[0]).Free; FList.Delete(0); end; end; function TWatchValueList.Count: Integer; begin Result := FList.Count; end; { TRegisterSupplier } function TRegisterSupplier.GetCurrentRegistersList: TRegistersList; begin Result := nil; if Monitor <> nil then Result := Monitor.RegistersList; end; function TRegisterSupplier.GetMonitor: TRegistersMonitor; begin Result := TRegistersMonitor(inherited Monitor); end; procedure TRegisterSupplier.SetMonitor(AValue: TRegistersMonitor); begin inherited Monitor := AValue; end; procedure TRegisterSupplier.RequestData(ARegisters: TRegisters); begin ARegisters.SetDataValidity(ddsInvalid); end; { TLocalsValue } procedure TLocalsValue.DoAssign(AnOther: TDbgEntityValue); begin inherited DoAssign(AnOther); FName := TLocalsValue(AnOther).FName; FValue := TLocalsValue(AnOther).FValue; end; { TLocalsListBase } function TLocalsList.GetEntry(AThreadId, AStackFrame: Integer): TLocals; begin Result := TLocals(inherited Entries[AThreadId, AStackFrame]); end; function TLocalsList.GetEntryByIdx(AnIndex: Integer): TLocals; begin Result := TLocals(inherited EntriesByIdx[AnIndex]); end; { TLocalsBase } function TLocals.GetEntry(AnIndex: Integer): TLocalsValue; begin Result := TLocalsValue(inherited Entries[AnIndex]); end; function TLocals.GetName(const AnIndex: Integer): String; begin Result := Entries[AnIndex].Name; end; function TLocals.GetValue(const AnIndex: Integer): String; begin Result := Entries[AnIndex].Value; end; function TLocals.CreateEntry: TDbgEntityValue; begin Result := TLocalsValue.Create; end; procedure TLocals.Add(const AName, AValue: String); var v: TLocalsValue; begin assert(not Immutable, 'TLocalsBase.Add Immutable'); v := TLocalsValue(CreateEntry); v.FName := AName; v.FValue := AValue; inherited Add(v); end; procedure TLocals.SetDataValidity(AValidity: TDebuggerDataState); begin // end; function TLocals.Count: Integer; begin Result := inherited Count; end; { TRegisterDisplayValue } function TRegisterDisplayValue.GetValue(ADispFormat: TRegisterDisplayFormat): String; const Digits = '01234567'; function IntToBase(Val, Base: Integer): String; var M: Integer; begin Result := ''; case Base of 2: M := 1; 8: M := 7; end; while Val > 0 do begin Result := Digits[1 + (Val and m)] + Result; Val := Val div Base; end; end; begin Result := ''; if not(ADispFormat in FSupportedDispFormats) then exit; if (ADispFormat in [rdDefault, rdRaw]) or not (rdvHasNum in FFlags) then begin Result := FStringValue; exit; end; case ADispFormat of rdHex: Result := IntToHex(FNumValue, FSize * 2); rdBinary: Result := IntToBase(FNumValue, 2); rdOctal: Result := IntToBase(FNumValue, 8); rdDecimal: Result := IntToStr(FNumValue); end; end; procedure TRegisterDisplayValue.Assign(AnOther: TRegisterDisplayValue); begin FStringValue := AnOther.FStringValue; FNumValue := AnOther.FNumValue; FFlags := AnOther.FFlags; FSize := AnOther.FSize; FSupportedDispFormats := AnOther.FSupportedDispFormats; end; procedure TRegisterDisplayValue.SetAsNum(AValue: QWord; ASize: Integer); begin if FNumValue = AValue then Exit; FNumValue := AValue; FSize := ASize; Include(FFlags, rdvHasNum); end; procedure TRegisterDisplayValue.SetAsText(AValue: String); begin FStringValue := AValue; end; procedure TRegisterDisplayValue.AddFormats(AFormats: TRegisterDisplayFormats); begin FSupportedDispFormats := FSupportedDispFormats + AFormats; end; { TRegisterValue } function TRegisterValue.GetValue: String; var v: TRegisterDisplayValue; begin v := GetValueObject(); if v <> nil then begin Result := v.Value[FDisplayFormat]; exit; end; Result := ''; DoValueNotEvaluated; end; function TRegisterValue.GetHasValue: Boolean; begin Result := GetValueObject <> nil; end; function TRegisterValue.GetHasValueFormat(ADispFormat: TRegisterDisplayFormat): Boolean; begin Result := GetValueObject(ADispFormat) <> nil; end; function TRegisterValue.GetValueObj: TRegisterDisplayValue; begin Result := GetValueObject(True); end; function TRegisterValue.GetValueObjFormat(ADispFormat: TRegisterDisplayFormat): TRegisterDisplayValue; begin Result := GetValueObject(ADispFormat, True); end; procedure TRegisterValue.SetDisplayFormat(AValue: TRegisterDisplayFormat); var Old: TRegisterDisplayFormat; begin assert(not Immutable, 'TRegisterValue.SetDisplayFormat: not Immutable'); if FDisplayFormat = AValue then Exit; Old := FDisplayFormat; FDisplayFormat := AValue; DoDisplayFormatChanged(Old); end; procedure TRegisterValue.SetValue(AValue: String); var v: TRegisterDisplayValue; begin assert(not Immutable, 'TRegisterValue.SetValue: not Immutable'); v := GetValueObject(True); v.FStringValue := AValue; end; function TRegisterValue.GetValueObject(ACreateNew: Boolean): TRegisterDisplayValue; begin Result := GetValueObject(FDisplayFormat, ACreateNew); end; function TRegisterValue.GetValueObject(ADispFormat: TRegisterDisplayFormat; ACreateNew: Boolean): TRegisterDisplayValue; var i: Integer; begin for i := 0 to length(FValues) - 1 do if ADispFormat in FValues[i].SupportedDispFormats then begin Result := FValues[i]; exit; end; if not ACreateNew then begin Result := nil; exit; end; assert(not Immutable, 'TRegisterValue.GetValueObject: not Immutable'); Result := TRegisterDisplayValue.Create; Result.FSupportedDispFormats := [ADispFormat]; i := length(FValues); SetLength(FValues, i + 1); FValues[i] := Result; end; procedure TRegisterValue.SetDataValidity(AValidity: TDebuggerDataState); var Old: TDebuggerDataState; begin assert(not Immutable, 'TRegisterValue.SetDataValidity: not Immutable'); if FDataValidity = AValidity then exit; Old := FDataValidity; FDataValidity := AValidity; DoDataValidityChanged(Old); end; procedure TRegisterValue.ClearDispValues; var i: Integer; begin for i := 0 to Length(FValues) - 1 do FValues[i].Free; FValues := nil; end; procedure TRegisterValue.DoAssign(AnOther: TDbgEntityValue); var i: Integer; begin inherited DoAssign(AnOther); FDataValidity := TRegisterValue(AnOther).FDataValidity; FDisplayFormat := TRegisterValue(AnOther).FDisplayFormat; FName := TRegisterValue(AnOther).FName; SetLength(FValues, length(TRegisterValue(AnOther).FValues)); for i := 0 to length(TRegisterValue(AnOther).FValues) - 1 do begin FValues[i] := TRegisterDisplayValue.Create; FValues[i].Assign(TRegisterValue(AnOther).FValues[i]); end; end; procedure TRegisterValue.DoDataValidityChanged(AnOldValidity: TDebuggerDataState); begin // end; procedure TRegisterValue.DoDisplayFormatChanged(AnOldFormat: TRegisterDisplayFormat); begin // end; procedure TRegisterValue.DoValueNotEvaluated; begin // end; destructor TRegisterValue.Destroy; begin inherited Destroy; ClearDispValues; end; { TRegisters } function TRegisters.GetEntry(AnIndex: Integer): TRegisterValue; begin Result := TRegisterValue(inherited Entries[AnIndex]); end; function TRegisters.GetEntryByName(const AName: String): TRegisterValue; var i: Integer; begin for i := 0 to Count - 1 do begin Result := Entries[i]; if Result.Name = AName then exit; end; assert(not Immutable, 'TRegisters.GetEntryByName: not Immutable'); Result := TRegisterValue(CreateEntry); Result.FName := AName; Add(Result); end; procedure TRegisters.SetDataValidity(AValue: TDebuggerDataState); var Old: TDebuggerDataState; begin assert(not Immutable, 'TRegisters.SetDataValidity: not Immutable'); if FDataValidity = AValue then Exit; Old := FDataValidity; FDataValidity := AValue; DoDataValidityChanged(Old); end; function TRegisters.CreateEntry: TDbgEntityValue; begin assert(not Immutable, 'TRegisters.CreateEntry: not Immutable'); Result := TRegisterValue.Create; end; procedure TRegisters.DoDataValidityChanged(AnOldValidity: TDebuggerDataState); begin // end; function TRegisters.Count: Integer; begin if FDataValidity = ddsValid then Result := inherited Count else Result := 0; end; { TRegistersList } function TRegistersList.GetEntry(AThreadId, AStackFrame: Integer): TRegisters; begin Result := TRegisters(inherited Entries[AThreadId, AStackFrame]); end; function TRegistersList.GetEntryByIdx(AnIndex: Integer): TRegisters; begin Result := TRegisters(inherited EntriesByIdx[AnIndex]); end; { TWatchesBase } function TWatches.GetItemBase(const AnIndex: Integer): TWatch; begin Result := TWatch(inherited Items[AnIndex]); end; procedure TWatches.SetItemBase(const AnIndex: Integer; const AValue: TWatch); begin inherited Items[AnIndex] := AValue; end; function TWatches.WatchClass: TWatchClass; begin Result := TWatch; end; constructor TWatches.Create; begin inherited Create(WatchClass); end; procedure TWatches.ClearValues; var n: Integer; begin for n := 0 to Count - 1 do Items[n].ClearValues; end; function TWatches.Find(const AExpression: String): TWatch; var n: Integer; S: String; begin S := UpperCase(AExpression); for n := 0 to Count - 1 do begin Result := TWatch(GetItem(n)); if UpperCase(Result.Expression) = S then Exit; end; Result := nil; end; { TCallStackBase } function TCallStackBase.GetNewCurrentIndex: Integer; begin Result := 0; end; function TCallStackBase.GetCount: Integer; begin Result := 0; end; function TCallStackBase.GetCurrent: Integer; begin Result := FCurrent; end; procedure TCallStackBase.SetCurrent(AValue: Integer); begin FCurrent := AValue; end; function TCallStackBase.GetHighestUnknown: Integer; begin Result := -1; end; function TCallStackBase.GetLowestUnknown: Integer; begin Result := 0; end; constructor TCallStackBase.Create; begin FThreadId := -1; FCurrent := -1; inherited; end; function TCallStackBase.CreateCopy: TCallStackBase; begin Result := TCallStackBase.Create; Result.Assign(Self); end; procedure TCallStackBase.Assign(AnOther: TCallStackBase); begin ThreadId := AnOther.ThreadId; FCurrent := AnOther.FCurrent; end; procedure TCallStackBase.SetCountValidity(AValidity: TDebuggerDataState); begin // end; procedure TCallStackBase.SetHasAtLeastCountInfo(AValidity: TDebuggerDataState; AMinCount: Integer); begin // end; procedure TCallStackBase.SetCurrentValidity(AValidity: TDebuggerDataState); begin // end; { TRunningProcessInfo } constructor TRunningProcessInfo.Create(APID: Cardinal; const AImageName: string); begin self.PID := APID; self.ImageName := AImageName; end; { TDebuggerDataMonitor } procedure TDebuggerDataMonitor.SetSupplier(const AValue: TDebuggerDataSupplier); begin if FSupplier = AValue then exit; Assert((FSupplier=nil) or (AValue=nil), 'TDebuggerDataMonitor.Supplier already set'); if FSupplier <> nil then FSupplier.Monitor := nil; FSupplier := AValue; if FSupplier <> nil then FSupplier.Monitor:= self; DoNewSupplier; end; procedure TDebuggerDataMonitor.DoModified; begin // end; procedure TDebuggerDataMonitor.DoNewSupplier; begin // end; destructor TDebuggerDataMonitor.Destroy; begin Supplier := nil; inherited Destroy; end; { TDebuggerDataSupplier } procedure TDebuggerDataSupplier.SetMonitor(const AValue: TDebuggerDataMonitor); begin if FMonitor = AValue then exit; Assert((FMonitor=nil) or (AValue=nil), 'TDebuggerDataSupplier.Monitor already set'); FMonitor := AValue; DoNewMonitor; end; procedure TDebuggerDataSupplier.DoNewMonitor; begin // end; procedure TDebuggerDataSupplier.DoStateLeavePauseClean; begin DoStateLeavePause; end; procedure TDebuggerDataSupplier.DoStateChange(const AOldState: TDBGState); begin if (Debugger = nil) then Exit; DoStateChangeEx(AOldState, Debugger.State); if Monitor <> nil then Monitor.DoStateChangeEx(AOldState, FDebugger.State); end; constructor TDebuggerDataSupplier.Create(const ADebugger: TDebuggerIntf); begin FDebugger := ADebugger; inherited Create; end; destructor TDebuggerDataSupplier.Destroy; begin if FMonitor <> nil then FMonitor.Supplier := nil; inherited Destroy; end; procedure TDebuggerDataSupplier.DoBeginUpdate; begin FMonitor.BeginUpdate; end; procedure TDebuggerDataSupplier.DoEndUpdate; begin FMonitor.EndUpdate; end; { =========================================================================== TBaseBreakPoint =========================================================================== } function TBaseBreakPoint.GetAddress: TDBGPtr; begin Result := FAddress; end; function TBaseBreakPoint.GetKind: TDBGBreakPointKind; begin Result := FKind; end; procedure TBaseBreakPoint.SetKind(const AValue: TDBGBreakPointKind); begin if FKind <> AValue then begin FKind := AValue; DoKindChange; end; end; procedure TBaseBreakPoint.SetAddress(const AValue: TDBGPtr); begin if FAddress <> AValue then begin FAddress := AValue; Changed; end; end; function TBaseBreakPoint.GetWatchData: String; begin Result := FWatchData; end; function TBaseBreakPoint.GetWatchScope: TDBGWatchPointScope; begin Result := FWatchScope; end; function TBaseBreakPoint.GetWatchKind: TDBGWatchPointKind; begin Result := FWatchKind; end; procedure TBaseBreakPoint.AssignLocationTo(Dest: TPersistent); var DestBreakPoint: TBaseBreakPoint absolute Dest; begin DestBreakPoint.SetLocation(FSource, FLine); end; procedure TBaseBreakPoint.AssignTo(Dest: TPersistent); var DestBreakPoint: TBaseBreakPoint absolute Dest; begin // updatelock is set in source.assignto if Dest is TBaseBreakPoint then begin DestBreakPoint.SetKind(FKind); DestBreakPoint.SetWatch(FWatchData, FWatchScope, FWatchKind); DestBreakPoint.SetAddress(FAddress); AssignLocationTo(DestBreakPoint); DestBreakPoint.SetBreakHitCount(FBreakHitCount); DestBreakPoint.SetExpression(FExpression); DestBreakPoint.SetEnabled(FEnabled); DestBreakPoint.InitialEnabled := FInitialEnabled; end else inherited; end; constructor TBaseBreakPoint.Create(ACollection: TCollection); begin FAddress := 0; FSource := ''; FLine := -1; FValid := vsUnknown; FEnabled := False; FHitCount := 0; FBreakHitCount := 0; FExpression := ''; FInitialEnabled := False; FKind := bpkSource; inherited Create(ACollection); AddReference; end; procedure TBaseBreakPoint.DoBreakHitCountChange; begin Changed; end; procedure TBaseBreakPoint.DoEnableChange; begin Changed; end; procedure TBaseBreakPoint.DoExpressionChange; begin Changed; end; procedure TBaseBreakPoint.DoHit(const ACount: Integer; var AContinue: Boolean ); begin SetHitCount(ACount); end; function TBaseBreakPoint.GetBreakHitCount: Integer; begin Result := FBreakHitCount; end; function TBaseBreakPoint.GetEnabled: Boolean; begin Result := FEnabled; end; function TBaseBreakPoint.GetExpression: String; begin Result := FExpression; end; function TBaseBreakPoint.GetHitCount: Integer; begin Result := FHitCount; end; function TBaseBreakPoint.GetLine: Integer; begin Result := FLine; end; function TBaseBreakPoint.GetSource: String; begin Result := FSource; end; function TBaseBreakPoint.GetValid: TValidState; begin Result := FValid; end; procedure TBaseBreakPoint.SetBreakHitCount(const AValue: Integer); begin if FBreakHitCount <> AValue then begin FBreakHitCount := AValue; DoBreakHitCountChange; end; end; procedure TBaseBreakPoint.SetEnabled (const AValue: Boolean ); begin if FEnabled <> AValue then begin FEnabled := AValue; DoEnableChange; end; end; procedure TBaseBreakPoint.SetExpression (const AValue: String ); begin if FExpression <> AValue then begin FExpression := AValue; DoExpressionChange; end; end; procedure TBaseBreakPoint.SetHitCount (const AValue: Integer ); begin if FHitCount <> AValue then begin FHitCount := AValue; Changed; end; end; procedure TBaseBreakPoint.DoKindChange; begin Changed; end; procedure TBaseBreakPoint.SetInitialEnabled(const AValue: Boolean); begin if FInitialEnabled=AValue then exit; FInitialEnabled:=AValue; end; procedure TBaseBreakPoint.SetLocation (const ASource: String; const ALine: Integer ); begin if (FSource = ASource) and (FLine = ALine) then exit; FSource := ASource; FLine := ALine; Changed; end; procedure TBaseBreakPoint.SetWatch(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind); begin if (AData = FWatchData) and (AScope = FWatchScope) and (AKind = FWatchKind) then exit; FWatchData := AData; FWatchScope := AScope; FWatchKind := AKind; Changed; end; procedure TBaseBreakPoint.SetValid(const AValue: TValidState ); begin if FValid <> AValue then begin FValid := AValue; Changed; end; end; { =========================================================================== } { TDBGBreakPoint } { =========================================================================== } constructor TDBGBreakPoint.Create (ACollection: TCollection ); begin FSlave := nil; inherited Create(ACollection); end; destructor TDBGBreakPoint.Destroy; var SBP: TBaseBreakPoint; begin SBP := FSlave; FSlave := nil; if SBP <> nil then SBP.DoChanged; // In case UpdateCount 0 inherited Destroy; end; procedure TDBGBreakPoint.Hit(var ACanContinue: Boolean); var cnt: Integer; begin cnt := HitCount + 1; if BreakHitcount > 0 then ACanContinue := cnt < BreakHitcount; DoHit(cnt, ACanContinue); if Assigned(FSlave) then FSlave.DoHit(cnt, ACanContinue); Debugger.DoBreakpointHit(Self, ACanContinue) end; procedure TDBGBreakPoint.DoChanged; begin inherited DoChanged; if FSlave <> nil then FSlave.Changed; end; procedure TDBGBreakPoint.DoStateChange(const AOldState: TDBGState); begin if Debugger.State <> dsStop then Exit; if not (AOldState in [dsIdle, dsNone]) then Exit; BeginUpdate; try SetLocation(FSource, Line); Enabled := InitialEnabled; SetHitCount(0); finally EndUpdate; end; end; procedure TDBGBreakPoint.DoLogMessage(const AMessage: String); begin Debugger.DoDbgEvent(ecBreakpoint, etBreakpointMessage, 'Breakpoint Message: ' + AMessage); end; procedure TDBGBreakPoint.DoLogCallStack(const Limit: Integer); const Spacing = ' '; var CallStack: TCallStackBase; I, Count: Integer; Entry: TCallStackEntry; StackString: String; begin Debugger.SetState(dsInternalPause); CallStack := Debugger.CallStack.CurrentCallStackList.EntriesForThreads[Debugger.Threads.CurrentThreads.CurrentThreadId]; if Limit = 0 then begin Debugger.DoDbgEvent(ecBreakpoint, etBreakpointMessage, 'Breakpoint Call Stack: Log all stack frames'); Count := CallStack.Count; CallStack.PrepareRange(0, Count); end else begin Debugger.DoDbgEvent(ecBreakpoint, etBreakpointMessage, Format('Breakpoint Call Stack: Log %d stack frames', [Limit])); Count := CallStack.CountLimited(Limit); CallStack.PrepareRange(0, Count); end; for I := 0 to Count - 1 do begin Entry := CallStack.Entries[I]; StackString := Spacing + Entry.Source; if Entry.Source = '' then // we do not have a source file => just show an adress StackString := Spacing + ':' + IntToHex(Entry.Address, 8); StackString := StackString + ' ' + Entry.GetFunctionWithArg; if line > 0 then StackString := StackString + ' line ' + IntToStr(Entry.Line); Debugger.DoDbgEvent(ecBreakpoint, etBreakpointStackDump, StackString); end; end; procedure TDBGBreakPoint.DoLogExpression(const AnExpression: String); begin // will be called while Debgger.State = dsRun => can not call Evaluate end; function TDBGBreakPoint.GetDebugger: TDebuggerIntf; begin Result := TDBGBreakPoints(Collection).FDebugger; end; procedure TDBGBreakPoint.SetSlave(const ASlave : TBaseBreakPoint); begin Assert((FSlave = nil) or (ASlave = nil), 'TDBGBreakPoint.SetSlave already has a slave'); FSlave := ASlave; end; procedure TDBGBreakPoint.SetEnabled(const AValue: Boolean); begin if Enabled = AValue then exit; inherited SetEnabled(AValue); // feedback to IDEBreakPoint if FSlave <> nil then FSlave.Enabled := AValue; end; { =========================================================================== } { TBaseBreakPoints } { =========================================================================== } function TBaseBreakPoints.Add(const ASource: String; const ALine: Integer): TBaseBreakPoint; begin Result := TBaseBreakPoint(inherited Add); Result.SetKind(bpkSource); Result.SetLocation(ASource, ALine); end; function TBaseBreakPoints.Add(const AAddress: TDBGPtr): TBaseBreakPoint; begin Result := TBaseBreakPoint(inherited Add); Result.SetKind(bpkAddress); Result.SetAddress(AAddress); end; function TBaseBreakPoints.Add(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind): TBaseBreakPoint; begin Result := TBaseBreakPoint(inherited Add); Result.SetKind(bpkData); Result.SetWatch(AData, AScope, AKind); end; constructor TBaseBreakPoints.Create(const ABreakPointClass: TBaseBreakPointClass); begin inherited Create(ABreakPointClass); end; destructor TBaseBreakPoints.Destroy; begin Clear; inherited Destroy; end; procedure TBaseBreakPoints.Clear; begin while Count > 0 do TBaseBreakPoint(GetItem(0)).ReleaseReference; end; function TBaseBreakPoints.Find(const ASource: String; const ALine: Integer): TBaseBreakPoint; begin Result := Find(ASource, ALine, nil); end; function TBaseBreakPoints.Find(const ASource: String; const ALine: Integer; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; var n: Integer; begin for n := 0 to Count - 1 do begin Result := TBaseBreakPoint(GetItem(n)); if (Result.Kind = bpkSource) and (Result.Line = ALine) and (AIgnore <> Result) and (CompareFilenames(Result.Source, ASource) = 0) then Exit; end; Result := nil; end; function TBaseBreakPoints.Find(const AAddress: TDBGPtr): TBaseBreakPoint; begin Result := Find(AAddress, nil); end; function TBaseBreakPoints.Find(const AAddress: TDBGPtr; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; var n: Integer; begin for n := 0 to Count - 1 do begin Result := TBaseBreakPoint(GetItem(n)); if (Result.Kind = bpkAddress) and (Result.Address = AAddress) and (AIgnore <> Result) then Exit; end; Result := nil; end; function TBaseBreakPoints.Find(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind): TBaseBreakPoint; begin Result := Find(AData, AScope, AKind, nil); end; function TBaseBreakPoints.Find(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; var n: Integer; begin for n := 0 to Count - 1 do begin Result := TBaseBreakPoint(GetItem(n)); if (Result.Kind = bpkData) and (Result.WatchData = AData) and (Result.WatchScope = AScope) and (Result.WatchKind = AKind) and (AIgnore <> Result) then Exit; end; Result := nil; end; { =========================================================================== } { TDBGBreakPoints } { =========================================================================== } function TDBGBreakPoints.Add (const ASource: String; const ALine: Integer ): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited Add(ASource, ALine)); end; function TDBGBreakPoints.Add(const AAddress: TDBGPtr): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited Add(AAddress)); end; function TDBGBreakPoints.Add(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited Add(AData, AScope, AKind)); end; constructor TDBGBreakPoints.Create(const ADebugger: TDebuggerIntf; const ABreakPointClass: TDBGBreakPointClass); begin FDebugger := ADebugger; inherited Create(ABreakPointClass); end; procedure TDBGBreakPoints.DoStateChange(const AOldState: TDBGState); var n: Integer; begin for n := 0 to Count - 1 do GetItem(n).DoStateChange(AOldState); end; function TDBGBreakPoints.Find(const ASource: String; const ALine: Integer): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited Find(Asource, ALine, nil)); end; function TDBGBreakPoints.Find (const ASource: String; const ALine: Integer; const AIgnore: TDBGBreakPoint ): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited Find(ASource, ALine, AIgnore)); end; function TDBGBreakPoints.Find(const AAddress: TDBGPtr): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited Find(AAddress)); end; function TDBGBreakPoints.Find(const AAddress: TDBGPtr; const AIgnore: TDBGBreakPoint): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited Find(AAddress, nil)); end; function TDBGBreakPoints.Find(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited Find(AData, AScope, AKind, nil)); end; function TDBGBreakPoints.Find(const AData: String; const AScope: TDBGWatchPointScope; const AKind: TDBGWatchPointKind; const AIgnore: TDBGBreakPoint): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited Find(AData, AScope, AKind, AIgnore)); end; function TDBGBreakPoints.GetItem (const AnIndex: Integer ): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited GetItem(AnIndex)); end; procedure TDBGBreakPoints.SetItem (const AnIndex: Integer; const AValue: TDBGBreakPoint ); begin inherited SetItem(AnIndex, AValue); end; { TDBGField } procedure TDBGField.IncRefCount; begin inc(FRefCount); end; procedure TDBGField.DecRefCount; begin dec(FRefCount); if FRefCount <= 0 then Self.Free; end; constructor TDBGField.Create(const AName: String; ADBGType: TDBGType; ALocation: TDBGFieldLocation; AFlags: TDBGFieldFlags; AClassName: String = ''); begin inherited Create; FName := AName; FLocation := ALocation; FDBGType := ADBGType; FFlags := AFlags; FRefCount := 0; FClassName := AClassName; end; destructor TDBGField.Destroy; begin FreeAndNil(FDBGType); inherited Destroy; end; { TDBGFields } constructor TDBGFields.Create; begin FList := TList.Create; inherited; end; destructor TDBGFields.Destroy; var n: Integer; begin for n := 0 to Count - 1 do Items[n].DecRefCount; FreeAndNil(FList); inherited; end; procedure TDBGFields.Add(const AField: TDBGField); begin AField.IncRefCount; FList.Add(AField); end; function TDBGFields.GetCount: Integer; begin Result := FList.Count; end; function TDBGFields.GetField(const AIndex: Integer): TDBGField; begin Result := TDBGField(FList[AIndex]); end; { TDBGPTypes } constructor TDBGTypes.Create; begin FList := TList.Create; inherited; end; destructor TDBGTypes.Destroy; var n: Integer; begin for n := 0 to Count - 1 do Items[n].Free; FreeAndNil(FList); inherited; end; function TDBGTypes.GetCount: Integer; begin Result := Flist.Count; end; function TDBGTypes.GetType(const AIndex: Integer): TDBGType; begin Result := TDBGType(FList[AIndex]); end; { TDBGPType } function TDBGType.GetFields: TDBGFields; begin if FFields = nil then FFields := TDBGFields.Create; Result := FFields; end; procedure TDBGType.Init; begin // end; constructor TDBGType.Create(AKind: TDBGSymbolKind; const ATypeName: String); begin FKind := AKind; FTypeName := ATypeName; Init; inherited Create; end; constructor TDBGType.Create(AKind: TDBGSymbolKind; const AArguments: TDBGTypes; AResult: TDBGType); begin FKind := AKind; FArguments := AArguments; FResult := AResult; Init; inherited Create; end; destructor TDBGType.Destroy; begin FreeAndNil(FResult); FreeAndNil(FArguments); FreeAndNil(FFields); FreeAndNil(FMembers); inherited; end; { TWatchesSupplier } procedure TWatchesSupplier.RequestData(AWatchValue: TWatchValue); begin if FNotifiedState in [dsPause, dsInternalPause] then InternalRequestData(AWatchValue) else AWatchValue.SetValidity(ddsInvalid); end; function TWatchesSupplier.GetCurrentWatches: TWatches; begin Result := Nil; if Monitor <> nil then Result := Monitor.Watches; end; function TWatchesSupplier.GetMonitor: TWatchesMonitor; begin Result := TWatchesMonitor(inherited Monitor); end; procedure TWatchesSupplier.SetMonitor(AValue: TWatchesMonitor); begin inherited Monitor := AValue; end; procedure TWatchesSupplier.DoStateChange(const AOldState: TDBGState); begin // workaround for state changes during TWatchValue.GetValue inc(DbgStateChangeCounter); if DbgStateChangeCounter = high(DbgStateChangeCounter) then DbgStateChangeCounter := 0; inherited DoStateChange(AOldState); end; procedure TWatchesSupplier.InternalRequestData(AWatchValue: TWatchValue); begin AWatchValue.SetValidity(ddsInvalid); end; constructor TWatchesSupplier.Create(const ADebugger: TDebuggerIntf); begin inherited Create(ADebugger); FNotifiedState := dsNone; end; { TWatchesMonitor } function TWatchesMonitor.GetSupplier: TWatchesSupplier; begin Result := TWatchesSupplier(inherited Supplier); end; procedure TWatchesMonitor.SetSupplier(AValue: TWatchesSupplier); begin inherited Supplier := AValue; end; function TWatchesMonitor.CreateWatches: TWatches; begin Result := TWatches.Create; end; constructor TWatchesMonitor.Create; begin FWatches := CreateWatches; inherited Create; end; destructor TWatchesMonitor.Destroy; begin inherited Destroy; FreeAndNil(FWatches); end; { TLocalsSupplier } function TLocalsSupplier.GetCurrentLocalsList: TLocalsList; begin Result := nil; if Monitor <> nil then Result := Monitor.LocalsList; end; function TLocalsSupplier.GetMonitor: TLocalsMonitor; begin Result := TLocalsMonitor(inherited Monitor); end; procedure TLocalsSupplier.SetMonitor(AValue: TLocalsMonitor); begin inherited Monitor := AValue; end; procedure TLocalsSupplier.RequestData(ALocals: TLocals); begin ALocals.SetDataValidity(ddsInvalid) end; { TLocalsMonitor } function TLocalsMonitor.GetSupplier: TLocalsSupplier; begin Result := TLocalsSupplier(inherited Supplier); end; procedure TLocalsMonitor.SetSupplier(AValue: TLocalsSupplier); begin inherited Supplier := AValue; end; function TLocalsMonitor.CreateLocalsList: TLocalsList; begin Result := TLocalsList.Create; end; constructor TLocalsMonitor.Create; begin FLocalsList := CreateLocalsList; FLocalsList.AddReference; inherited Create; end; destructor TLocalsMonitor.Destroy; begin inherited Destroy; ReleaseRefAndNil(FLocalsList); end; { TBaseLineInfo } function TBaseLineInfo.GetSource(const AnIndex: integer): String; begin Result := ''; end; function TBaseLineInfo.IndexOf(const ASource: String): integer; begin Result := -1; end; constructor TBaseLineInfo.Create; begin inherited Create; end; function TBaseLineInfo.GetAddress(const AIndex: Integer; const ALine: Integer): TDbgPtr; begin Result := 0; end; function TBaseLineInfo.GetAddress(const ASource: String; const ALine: Integer): TDbgPtr; var idx: Integer; begin idx := IndexOf(ASource); if idx = -1 then Result := 0 else Result := GetAddress(idx, ALine); end; function TBaseLineInfo.GetInfo(AAdress: TDbgPtr; out ASource, ALine, AOffset: Integer): Boolean; begin Result := False; end; procedure TBaseLineInfo.Request(const ASource: String); begin end; procedure TBaseLineInfo.Cancel(const ASource: String); begin end; function TBaseLineInfo.Count: Integer; begin Result := 0; end; { TDBGLineInfo } procedure TDBGLineInfo.Changed(ASource: String); begin DoChange(ASource); end; procedure TDBGLineInfo.DoChange(ASource: String); begin if Assigned(FOnChange) then FOnChange(Self, ASource); end; procedure TDBGLineInfo.DoStateChange(const AOldState: TDBGState); begin end; constructor TDBGLineInfo.Create(const ADebugger: TDebuggerIntf); begin inherited Create; FDebugger := ADebugger; end; { TCallStackEntry } function TCallStackEntry.GetArgumentCount: Integer; begin Result := FArguments.Count; end; function TCallStackEntry.GetArgumentName(const AnIndex: Integer): String; begin Result := FArguments.Names[AnIndex]; end; function TCallStackEntry.GetArgumentValue(const AnIndex: Integer): String; begin Result := FArguments[AnIndex]; Result := GetPart('=', '', Result); end; function TCallStackEntry.GetFunctionName: String; begin Result := FFunctionName; end; function TCallStackEntry.GetSource: String; begin Result := ''; end; function TCallStackEntry.GetValidity: TDebuggerDataState; begin Result := FValidity; end; procedure TCallStackEntry.SetValidity(AValue: TDebuggerDataState); begin FValidity := AValue; end; procedure TCallStackEntry.ClearLocation; begin InitFields(0, 0, nil, '', 0, Validity); if Arguments <> nil then Arguments.Clear; end; procedure TCallStackEntry.InitFields(const AIndex: Integer; const AnAddress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const ALine: Integer; AValidity: TDebuggerDataState); begin FIndex := AIndex; FAddress := AnAddress; if AnArguments <> nil then FArguments.Assign(AnArguments); FFunctionName := AFunctionName; FLine := ALine; FValidity := AValidity; end; constructor TCallStackEntry.Create; begin inherited Create; FArguments := TStringlist.Create; end; function TCallStackEntry.CreateCopy: TCallStackEntry; begin Result := TCallStackEntry.Create; Result.Assign(Self); end; destructor TCallStackEntry.Destroy; begin inherited Destroy; FreeAndNil(FArguments); end; procedure TCallStackEntry.Assign(AnOther: TCallStackEntry); begin FValidity := AnOther.FValidity; FIndex := AnOther.FIndex; FAddress := AnOther.FAddress; FFunctionName := AnOther.FFunctionName; FLine := AnOther.FLine; FArguments.Assign(AnOther.FArguments); end; procedure TCallStackEntry.Init(const AnAddress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const AUnitName, AClassName, AProcName, AFunctionArgs: String; const ALine: Integer; AState: TDebuggerDataState); begin InitFields(FIndex, AnAddress, AnArguments, AFunctionName, ALine, AState); end; procedure TCallStackEntry.Init(const AnAddress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const FileName, FullName: String; const ALine: Integer; AState: TDebuggerDataState); begin InitFields(FIndex, AnAddress, AnArguments, AFunctionName, ALine, AState); end; function TCallStackEntry.GetFunctionWithArg: String; var S: String; m: Integer; begin S := ''; for m := 0 to ArgumentCount - 1 do begin if S <> '' then S := S + ', '; S := S + ArgumentValues[m]; end; if S <> '' then S := '(' + S + ')'; Result := FunctionName + S; end; { TCallStackList } function TCallStackList.GetEntry(const AIndex: Integer): TCallStackBase; begin Result := TCallStackBase(FList[AIndex]); end; function TCallStackList.GetEntryForThread(const AThreadId: Integer): TCallStackBase; var i: Integer; begin i := Count - 1; while (i >= 0) and (TCallStackBase(FList[i]).ThreadId <> AThreadId) do dec(i); if i >= 0 then Result := TCallStackBase(FList[i]) else Result := NewEntryForThread(AThreadId); end; function TCallStackList.NewEntryForThread(const AThreadId: Integer): TCallStackBase; begin Result := nil; end; constructor TCallStackList.Create; begin FList := TList.Create; end; destructor TCallStackList.Destroy; begin inherited Destroy; Clear; FreeAndNil(FList); end; procedure TCallStackList.Assign(AnOther: TCallStackList); var i: Integer; begin Clear; for i := 0 to AnOther.FList.Count-1 do FList.Add(TCallStackBase(AnOther.FList[i]).CreateCopy); end; procedure TCallStackList.Add(ACallStack: TCallStackBase); begin FList.Add(ACallStack); end; procedure TCallStackList.Clear; begin while FList.Count > 0 do begin TObject(FList[0]).Free; FList.Delete(0); end; end; function TCallStackList.Count: Integer; begin Result := FList.Count; end; { TCallStackSupplier } procedure TCallStackSupplier.Changed; begin DebugLn(DBG_DATA_MONITORS, ['DebugDataMonitor: TCallStackSupplier.Changed']); Monitor.DoModified; end; function TCallStackSupplier.GetCurrentCallStackList: TCallStackList; begin Result := nil; if Monitor <> nil then Result := Monitor.CallStackList; end; function TCallStackSupplier.GetMonitor: TCallStackMonitor; begin Result := TCallStackMonitor(inherited Monitor); end; procedure TCallStackSupplier.SetMonitor(AValue: TCallStackMonitor); begin inherited Monitor := AValue; end; procedure TCallStackSupplier.RequestCount(ACallstack: TCallStackBase); begin ACallstack.SetCountValidity(ddsInvalid); end; procedure TCallStackSupplier.RequestAtLeastCount(ACallstack: TCallStackBase; ARequiredMinCount: Integer); begin RequestCount(ACallstack); end; procedure TCallStackSupplier.RequestCurrent(ACallstack: TCallStackBase); begin ACallstack.SetCurrentValidity(ddsInvalid); end; procedure TCallStackSupplier.RequestEntries(ACallstack: TCallStackBase); var e: TCallStackEntry; It: TMapIterator; begin DebugLn(DBG_DATA_MONITORS, ['DebugDataMonitor: TCallStackSupplier.RequestEntries']); It := TMapIterator.Create(ACallstack.RawEntries); if not It.Locate(ACallstack.LowestUnknown ) then if not It.EOM then It.Next; while (not IT.EOM) and (TCallStackEntry(It.DataPtr^).Index < ACallstack.HighestUnknown) do begin e := TCallStackEntry(It.DataPtr^); if e.Validity = ddsRequested then e.Validity := ddsInvalid; It.Next; end; It.Free; if Monitor <> nil then Monitor.DoModified; end; //procedure TCallStackSupplier.CurrentChanged; //begin // DebugLn(DBG_DATA_MONITORS, ['DebugDataMonitor: TCallStackSupplier.CurrentChanged']); // if Monitor <> nil // then Monitor.NotifyCurrent; //end; procedure TCallStackSupplier.UpdateCurrentIndex; begin // end; { TCallStackMonitor } function TCallStackMonitor.GetSupplier: TCallStackSupplier; begin Result := TCallStackSupplier(inherited Supplier); end; procedure TCallStackMonitor.SetSupplier(AValue: TCallStackSupplier); begin inherited Supplier := AValue; end; function TCallStackMonitor.CreateCallStackList: TCallStackList; begin Result := TCallStackList.Create; end; constructor TCallStackMonitor.Create; begin FCallStackList := CreateCallStackList; inherited Create; end; destructor TCallStackMonitor.Destroy; begin inherited Destroy; FreeAndNil(FCallStackList); end; { TThreadsSupplier } procedure TThreadsSupplier.Changed; begin if Monitor <> nil then Monitor.DoModified; end; function TThreadsSupplier.GetCurrentThreads: TThreads; begin Result := nil; if Monitor <> nil then Result := Monitor.Threads; end; function TThreadsSupplier.GetMonitor: TThreadsMonitor; begin Result := TThreadsMonitor(inherited Monitor); end; procedure TThreadsSupplier.SetMonitor(AValue: TThreadsMonitor); begin inherited Monitor := AValue; end; procedure TThreadsSupplier.ChangeCurrentThread(ANewId: Integer); begin // end; procedure TThreadsSupplier.RequestMasterData; begin // end; procedure TThreadsSupplier.DoStateChange(const AOldState: TDBGState); begin if (Debugger.State = dsStop) and (CurrentThreads <> nil) then CurrentThreads.Clear; inherited DoStateChange(AOldState); end; procedure TThreadsSupplier.DoStateLeavePauseClean; begin DoCleanAfterPause; end; procedure TThreadsSupplier.DoCleanAfterPause; begin if CurrentThreads <> nil then CurrentThreads.Clear; if Monitor <> nil then Monitor.DoModified; end; { =========================================================================== } { TBaseSignal } { =========================================================================== } procedure TBaseSignal.AssignTo(Dest: TPersistent); begin if Dest is TBaseSignal then begin TBaseSignal(Dest).Name := FName; TBaseSignal(Dest).ID := FID; TBaseSignal(Dest).HandledByDebugger := FHandledByDebugger; TBaseSignal(Dest).ResumeHandled := FResumeHandled; end else inherited AssignTo(Dest); end; constructor TBaseSignal.Create(ACollection: TCollection); begin FID := 0; FHandledByDebugger := False; FResumeHandled := True; inherited Create(ACollection); end; procedure TBaseSignal.SetHandledByDebugger(const AValue: Boolean); begin if AValue = FHandledByDebugger then Exit; FHandledByDebugger := AValue; Changed; end; procedure TBaseSignal.SetID (const AValue: Integer ); begin if FID = AValue then Exit; FID := AValue; Changed; end; procedure TBaseSignal.SetName (const AValue: String ); begin if FName = AValue then Exit; FName := AValue; Changed; end; procedure TBaseSignal.SetResumeHandled(const AValue: Boolean); begin if FResumeHandled = AValue then Exit; FResumeHandled := AValue; Changed; end; { =========================================================================== } { TDBGSignal } { =========================================================================== } function TDBGSignal.GetDebugger: TDebuggerIntf; begin Result := TDBGSignals(Collection).FDebugger; end; { =========================================================================== } { TBaseSignals } { =========================================================================== } function TBaseSignals.Add (const AName: String; AID: Integer ): TBaseSignal; begin Result := TBaseSignal(inherited Add); Result.BeginUpdate; try Result.Name := AName; Result.ID := AID; finally Result.EndUpdate; end; end; constructor TBaseSignals.Create (const AItemClass: TBaseSignalClass ); begin inherited Create(AItemClass); end; procedure TBaseSignals.Reset; begin Clear; end; function TBaseSignals.Find(const AName: String): TBaseSignal; var n: Integer; S: String; begin S := UpperCase(AName); for n := 0 to Count - 1 do begin Result := TBaseSignal(GetItem(n)); if UpperCase(Result.Name) = S then Exit; end; Result := nil; end; { =========================================================================== } { TDBGSignals } { =========================================================================== } function TDBGSignals.Add(const AName: String; AID: Integer): TDBGSignal; begin Result := TDBGSignal(inherited Add(AName, AID)); end; constructor TDBGSignals.Create(const ADebugger: TDebuggerIntf; const ASignalClass: TDBGSignalClass); begin FDebugger := ADebugger; inherited Create(ASignalClass); end; function TDBGSignals.Find(const AName: String): TDBGSignal; begin Result := TDBGSignal(inherited Find(ANAme)); end; function TDBGSignals.GetItem(const AIndex: Integer): TDBGSignal; begin Result := TDBGSignal(inherited GetItem(AIndex)); end; procedure TDBGSignals.SetItem(const AIndex: Integer; const AValue: TDBGSignal); begin inherited SetItem(AIndex, AValue); end; { =========================================================================== } { TBaseException } { =========================================================================== } procedure TBaseException.SetEnabled(AValue: Boolean); begin if FEnabled = AValue then Exit; FEnabled := AValue; Changed; end; procedure TBaseException.AssignTo(Dest: TPersistent); begin if Dest is TBaseException then begin TBaseException(Dest).Name := FName; end else inherited AssignTo(Dest); end; constructor TBaseException.Create(ACollection: TCollection); begin inherited Create(ACollection); end; procedure TBaseException.SetName(const AValue: String); begin if FName = AValue then exit; if TBaseExceptions(GetOwner).Find(AValue) <> nil then raise EDBGExceptions.Create('Duplicate name: ' + AValue); FName := AValue; Changed; end; { =========================================================================== } { TBaseExceptions } { =========================================================================== } function TBaseExceptions.Add(const AName: String): TBaseException; begin Result := TBaseException(inherited Add); Result.Name := AName; end; constructor TBaseExceptions.Create(const AItemClass: TBaseExceptionClass); begin inherited Create(AItemClass); FIgnoreAll := False; end; destructor TBaseExceptions.Destroy; begin ClearExceptions; inherited Destroy; end; procedure TBaseExceptions.Reset; begin ClearExceptions; FIgnoreAll := False; end; function TBaseExceptions.Find(const AName: String): TBaseException; var n: Integer; S: String; begin S := UpperCase(AName); for n := 0 to Count - 1 do begin Result := TBaseException(GetItem(n)); if UpperCase(Result.Name) = S then Exit; end; Result := nil; end; function TBaseExceptions.GetItem(const AIndex: Integer): TBaseException; begin Result := TBaseException(inherited GetItem(AIndex)); end; procedure TBaseExceptions.SetItem(const AIndex: Integer; AValue: TBaseException); begin inherited SetItem(AIndex, AValue); end; procedure TBaseExceptions.ClearExceptions; begin while Count>0 do TBaseException(GetItem(Count-1)).Free; end; procedure TBaseExceptions.SetIgnoreAll(const AValue: Boolean); begin if FIgnoreAll = AValue then exit; FIgnoreAll := AValue; Changed; end; procedure TBaseExceptions.AssignTo(Dest: TPersistent); begin if Dest is TBaseExceptions then begin TBaseExceptions(Dest).IgnoreAll := IgnoreAll; end else inherited AssignTo(Dest); end; { TBaseDisassembler } procedure TBaseDisassembler.IndexError(AIndex: Integer); begin raise EInvalidOperation.CreateFmt('Index out of range (%d)', [AIndex]); end; function TBaseDisassembler.GetEntryPtr(AIndex: Integer): PDisassemblerEntry; begin if (AIndex < -FCountBefore) or (AIndex >= FCountAfter) then IndexError(Aindex); Result := InternalGetEntryPtr(AIndex); end; function TBaseDisassembler.GetEntry(AIndex: Integer): TDisassemblerEntry; begin if (AIndex < -FCountBefore) or (AIndex >= FCountAfter) then IndexError(Aindex); Result := InternalGetEntry(AIndex); end; function TBaseDisassembler.InternalGetEntry(AIndex: Integer): TDisassemblerEntry; begin Result.Addr := 0; Result.Offset := 0; Result.SrcFileLine := 0; Result.SrcStatementIndex := 0; Result.SrcStatementCount := 0; end; function TBaseDisassembler.InternalGetEntryPtr(AIndex: Integer): PDisassemblerEntry; begin Result := nil; end; procedure TBaseDisassembler.DoChanged; begin // nothing end; procedure TBaseDisassembler.Changed; begin if FChangedLockCount > 0 then begin FIsChanged := True; exit; end; FIsChanged := False; DoChanged; end; procedure TBaseDisassembler.LockChanged; begin inc(FChangedLockCount); end; procedure TBaseDisassembler.UnlockChanged; begin dec(FChangedLockCount); if FIsChanged and (FChangedLockCount = 0) then Changed; end; procedure TBaseDisassembler.InternalIncreaseCountBefore(ACount: Integer); begin // increase count withou change notification if ACount < FCountBefore then begin debugln(DBG_DISASSEMBLER, ['WARNING: TBaseDisassembler.InternalIncreaseCountBefore will decrease was ', FCountBefore , ' new=',ACount]); SetCountBefore(ACount); end else FCountBefore := ACount; end; procedure TBaseDisassembler.InternalIncreaseCountAfter(ACount: Integer); begin // increase count withou change notification if ACount < FCountAfter then begin debugln(DBG_DISASSEMBLER, ['WARNING: TBaseDisassembler.InternalIncreaseCountAfter will decrease was ', FCountAfter , ' new=',ACount]); SetCountAfter(ACount) end else FCountAfter := ACount; end; procedure TBaseDisassembler.SetCountBefore(ACount: Integer); begin if FCountBefore = ACount then exit; FCountBefore := ACount; Changed; end; procedure TBaseDisassembler.SetCountAfter(ACount: Integer); begin if FCountAfter = ACount then exit; FCountAfter := ACount; Changed; end; procedure TBaseDisassembler.SetBaseAddr(AnAddr: TDbgPtr); begin if FBaseAddr = AnAddr then exit; FBaseAddr := AnAddr; Changed; end; constructor TBaseDisassembler.Create; begin Clear; FChangedLockCount := 0; end; destructor TBaseDisassembler.Destroy; begin inherited Destroy; Clear; end; procedure TBaseDisassembler.Clear; begin FCountAfter := 0; FCountBefore := 0; FBaseAddr := 0; end; function TBaseDisassembler.PrepareRange(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; begin Result := False; end; { TDBGDisassemblerEntryRange } function TDBGDisassemblerEntryRange.GetEntry(Index: Integer): TDisassemblerEntry; begin if (Index < 0) or (Index >= FCount) then raise Exception.Create('Illegal Index'); Result := FEntries[Index]; end; function TDBGDisassemblerEntryRange.GetCapacity: Integer; begin Result := length(FEntries); end; function TDBGDisassemblerEntryRange.GetEntryPtr(Index: Integer): PDisassemblerEntry; begin if (Index < 0) or (Index >= FCount) then raise Exception.Create('Illegal Index'); Result := @FEntries[Index]; end; procedure TDBGDisassemblerEntryRange.SetCapacity(const AValue: Integer); begin SetLength(FEntries, AValue); if FCount >= AValue then FCount := AValue - 1; end; procedure TDBGDisassemblerEntryRange.SetCount(const AValue: Integer); begin if FCount = AValue then exit; if AValue >= Capacity then Capacity := AValue + Max(20, AValue div 4); FCount := AValue; end; procedure TDBGDisassemblerEntryRange.Clear; begin SetCapacity(0); FCount := 0; end; function TDBGDisassemblerEntryRange.Append(const AnEntryPtr: PDisassemblerEntry): Integer; begin if FCount >= Capacity then Capacity := FCount + Max(20, FCount div 4); FEntries[FCount] := AnEntryPtr^; Result := FCount; inc(FCount); end; procedure TDBGDisassemblerEntryRange.Merge(const AnotherRange: TDBGDisassemblerEntryRange); var i, j: Integer; a: TDBGPtr; begin if AnotherRange.RangeStartAddr < RangeStartAddr then begin // merge before i := AnotherRange.Count - 1; a := FirstAddr; while (i >= 0) and (AnotherRange.EntriesPtr[i]^.Addr >= a) do dec(i); inc(i); debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassemblerEntryRange.Merge: Merged to START: Other=', dbgs(AnotherRange), ' To other index=', i, ' INTO self=', dbgs(self) ]); if Capacity < Count + i then Capacity := Count + i; for j := Count-1 downto 0 do FEntries[j+i] := FEntries[j]; for j := 0 to i - 1 do FEntries[j] := AnotherRange.FEntries[j]; FCount := FCount + i; FRangeStartAddr := AnotherRange.FRangeStartAddr; end else begin // merge after a:= LastAddr; i := 0; while (i < AnotherRange.Count) and (AnotherRange.EntriesPtr[i]^.Addr <= a) do inc(i); debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassemblerEntryRange.Merge to END: Other=', dbgs(AnotherRange), ' From other index=', i, ' INTO self=', dbgs(self) ]); if Capacity < Count + AnotherRange.Count - i then Capacity := Count + AnotherRange.Count - i; for j := 0 to AnotherRange.Count - i - 1 do FEntries[Count + j] := AnotherRange.FEntries[i + j]; FCount := FCount + AnotherRange.Count - i; FRangeEndAddr := AnotherRange.FRangeEndAddr; FLastEntryEndAddr := AnotherRange.FLastEntryEndAddr; end; debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassemblerEntryRange.Merge AFTER MERGE: ', dbgs(self) ]); end; function TDBGDisassemblerEntryRange.FirstAddr: TDbgPtr; begin if FCount = 0 then exit(0); Result := FEntries[0].Addr; end; function TDBGDisassemblerEntryRange.LastAddr: TDbgPtr; begin if FCount = 0 then exit(0); Result := FEntries[FCount-1].Addr; end; function TDBGDisassemblerEntryRange.ContainsAddr(const AnAddr: TDbgPtr; IncludeNextAddr: Boolean = False): Boolean; begin if IncludeNextAddr then Result := (AnAddr >= RangeStartAddr) and (AnAddr <= RangeEndAddr) else Result := (AnAddr >= RangeStartAddr) and (AnAddr < RangeEndAddr); end; function TDBGDisassemblerEntryRange.IndexOfAddr(const AnAddr: TDbgPtr): Integer; begin Result := FCount - 1; while Result >= 0 do begin if FEntries[Result].Addr = AnAddr then exit; dec(Result); end; end; function TDBGDisassemblerEntryRange.IndexOfAddrWithOffs(const AnAddr: TDbgPtr): Integer; var O: Integer; begin Result := IndexOfAddrWithOffs(AnAddr, O); end; function TDBGDisassemblerEntryRange.IndexOfAddrWithOffs(const AnAddr: TDbgPtr; out AOffs: Integer): Integer; begin Result := FCount - 1; while Result >= 0 do begin if FEntries[Result].Addr <= AnAddr then break; dec(Result); end; If Result < 0 then AOffs := 0 else AOffs := AnAddr - FEntries[Result].Addr; end; { TDBGDisassemblerEntryMapIterator } function TDBGDisassemblerEntryMapIterator.GetRangeForAddr(AnAddr: TDbgPtr; IncludeNextAddr: Boolean): TDBGDisassemblerEntryRange; begin Result := nil; if not Locate(AnAddr) then if not BOM then Previous; if BOM then exit; GetData(Result); if not Result.ContainsAddr(AnAddr, IncludeNextAddr) then Result := nil; end; function TDBGDisassemblerEntryMapIterator.NextRange: TDBGDisassemblerEntryRange; begin Result := nil; if EOM then exit; Next; if not EOM then GetData(Result); end; function TDBGDisassemblerEntryMapIterator.PreviousRange: TDBGDisassemblerEntryRange; begin Result := nil; if BOM then exit; Previous; if not BOM then GetData(Result); end; { TDBGDisassemblerEntryMap } procedure TDBGDisassemblerEntryMap.ReleaseData(ADataPtr: Pointer); type PDBGDisassemblerEntryRange = ^TDBGDisassemblerEntryRange; begin if FFreeItemLock then exit; if Assigned(FOnDelete) then FOnDelete(PDBGDisassemblerEntryRange(ADataPtr)^); PDBGDisassemblerEntryRange(ADataPtr)^.Free; end; constructor TDBGDisassemblerEntryMap.Create(AIdType: TMapIdType; ADataSize: Cardinal); begin inherited; FIterator := TDBGDisassemblerEntryMapIterator.Create(Self); end; destructor TDBGDisassemblerEntryMap.Destroy; begin FreeAndNil(FIterator); inherited Destroy; end; procedure TDBGDisassemblerEntryMap.AddRange(const ARange: TDBGDisassemblerEntryRange); var MergeRng, MergeRng2: TDBGDisassemblerEntryRange; OldId: TDBGPtr; begin debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassemblerEntryMap.AddRange ', dbgs(ARange), ' to map with count=', Count ]); if ARange.Count = 0 then begin ARange.Free; exit; end; MergeRng := GetRangeForAddr(ARange.RangeStartAddr, True); if MergeRng <> nil then begin // merge to end ( ARange.RangeStartAddr >= MergeRng.RangeStartAddr ) // MergeRng keeps it's ID; MergeRng.Merge(ARange); if assigned(FOnMerge) then FOnMerge(MergeRng, ARange); ARange.Free; MergeRng2 := GetRangeForAddr(MergeRng.RangeEndAddr, True); if (MergeRng2 <> nil) and (MergeRng2 <> MergeRng) then begin // MergeRng is located before MergeRng2 // MergeRng2 merges to end of MergeRng ( No ID changes ) MergeRng.Merge(MergeRng2); if assigned(FOnMerge) then FOnMerge(MergeRng, MergeRng2); Delete(MergeRng2.RangeStartAddr); end; exit; end; MergeRng := GetRangeForAddr(ARange.RangeEndAddr, True); if MergeRng <> nil then begin // merge to start ( ARange.RangeEndAddr is in MergeRng ) if MergeRng.ContainsAddr(ARange.RangeStartAddr) then begin debugln(['ERROR: New Range is completely inside existing ', dbgs(MergeRng)]); exit; end; // MergeRng changes ID OldId := MergeRng.RangeStartAddr; MergeRng.Merge(ARange); if assigned(FOnMerge) then FOnMerge(ARange, MergeRng); FFreeItemLock := True; // prevent destruction of MergeRng Delete(OldId); FFreeItemLock := False; Add(MergeRng.RangeStartAddr, MergeRng); ARange.Free; exit; end; Add(ARange.RangeStartAddr, ARange); end; function TDBGDisassemblerEntryMap.GetRangeForAddr(AnAddr: TDbgPtr; IncludeNextAddr: Boolean = False): TDBGDisassemblerEntryRange; begin Result := FIterator.GetRangeForAddr(AnAddr, IncludeNextAddr); end; { TDBGDisassembler } procedure TDBGDisassembler.EntryRangesOnDelete(Sender: TObject); begin if FCurrentRange <> Sender then exit; LockChanged; FCurrentRange := nil; SetBaseAddr(0); SetCountBefore(0); SetCountAfter(0); UnlockChanged; end; procedure TDBGDisassembler.EntryRangesOnMerge(MergeReceiver, MergeGiver: TDBGDisassemblerEntryRange); var i: LongInt; lb, la: Integer; begin // no need to call changed, will be done by whoever triggered this if FCurrentRange = MergeGiver then FCurrentRange := MergeReceiver; if FCurrentRange = MergeReceiver then begin i := FCurrentRange.IndexOfAddrWithOffs(BaseAddr); if i >= 0 then begin InternalIncreaseCountBefore(i); InternalIncreaseCountAfter(FCurrentRange.Count - 1 - i); exit; end else if FCurrentRange.ContainsAddr(BaseAddr) then begin debugln(DBG_DISASSEMBLER, ['WARNING: TDBGDisassembler.OnMerge: Address at odd offset ',BaseAddr, ' before=',CountBefore, ' after=', CountAfter]); lb := CountBefore; la := CountAfter; if HandleRangeWithInvalidAddr(FCurrentRange, BaseAddr, lb, la) then begin InternalIncreaseCountBefore(lb); InternalIncreaseCountAfter(la); exit; end; end; LockChanged; SetBaseAddr(0); SetCountBefore(0); SetCountAfter(0); UnlockChanged; end; end; function TDBGDisassembler.FindRange(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; var i: LongInt; NewRange: TDBGDisassemblerEntryRange; begin LockChanged; try Result := False; NewRange := FEntryRanges.GetRangeForAddr(AnAddr); if (NewRange <> nil) and ( (NewRange.RangeStartAddr > AnAddr) or (NewRange.RangeEndAddr < AnAddr) ) then NewRange := nil; if NewRange = nil then begin debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.FindRange: Address not found ', AnAddr, ' wanted-before=',ALinesBefore,' wanted-after=',ALinesAfter,' in map with count=', FEntryRanges.Count ]); exit; end; i := NewRange.IndexOfAddr(AnAddr); if i < 0 then begin // address at incorrect offset Result := HandleRangeWithInvalidAddr(NewRange, AnAddr, ALinesBefore, ALinesAfter); debugln(DBG_DISASSEMBLER, ['WARNING: TDBGDisassembler.FindRange: Address at odd offset ',AnAddr,' Result=', dbgs(result), ' before=',CountBefore, ' after=', CountAfter, ' wanted-before=',ALinesBefore,' wanted-after=',ALinesAfter,' in map with count=', FEntryRanges.Count]); if Result then begin FCurrentRange := NewRange; SetBaseAddr(AnAddr); SetCountBefore(ALinesBefore); SetCountAfter(ALinesAfter); end; exit; end; FCurrentRange := NewRange; SetBaseAddr(AnAddr); SetCountBefore(i); SetCountAfter(NewRange.Count - 1 - i); Result := (i >= ALinesBefore) and (CountAfter >= ALinesAfter); debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.FindRange: Address found ',AnAddr,' Result=', dbgs(result), ' before=',CountBefore, ' after=', CountAfter, ' wanted-before=',ALinesBefore,' wanted-after=',ALinesAfter,' in map with count=', FEntryRanges.Count]); finally UnlockChanged; end; end; procedure TDBGDisassembler.DoChanged; begin inherited DoChanged; if assigned(FOnChange) then FOnChange(Self); end; procedure TDBGDisassembler.Clear; begin debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.Clear: map had count=', FEntryRanges.Count ]); FCurrentRange := nil; FEntryRanges.Clear; inherited Clear; Changed; end; procedure TDBGDisassembler.DoStateChange(const AOldState: TDBGState); begin if FDebugger.State = dsPause then begin Changed; end else begin if (AOldState = dsPause) or (AOldState = dsNone) { Force clear on initialisation } then Clear; end; end; function TDBGDisassembler.InternalGetEntry(AIndex: Integer): TDisassemblerEntry; begin Result := FCurrentRange.Entries[AIndex + CountBefore]; end; function TDBGDisassembler.InternalGetEntryPtr(AIndex: Integer): PDisassemblerEntry; begin Result := FCurrentRange.EntriesPtr[AIndex + CountBefore]; end; function TDBGDisassembler.PrepareEntries(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): boolean; begin Result := False; end; function TDBGDisassembler.HandleRangeWithInvalidAddr(ARange: TDBGDisassemblerEntryRange; AnAddr: TDbgPtr; var ALinesBefore, ALinesAfter: Integer): boolean; begin Result := False; if ARange <> nil then FEntryRanges.Delete(ARange.RangeStartAddr); end; constructor TDBGDisassembler.Create(const ADebugger: TDebuggerIntf); begin FDebugger := ADebugger; FEntryRanges := TDBGDisassemblerEntryMap.Create(itu8, SizeOf(TDBGDisassemblerEntryRange)); FEntryRanges.OnDelete := @EntryRangesOnDelete; FEntryRanges.OnMerge := @EntryRangesOnMerge; inherited Create; end; destructor TDBGDisassembler.Destroy; begin inherited Destroy; FEntryRanges.OnDelete := nil; Clear; FreeAndNil(FEntryRanges); end; function TDBGDisassembler.PrepareRange(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; begin Result := False; if (Debugger = nil) or (Debugger.State <> dsPause) or (AnAddr = 0) then exit; if (ALinesBefore < 0) or (ALinesAfter < 0) then raise Exception.Create('invalid PrepareRange request'); // Do not LockChange, if FindRange changes something, then notification must be send to syncronize counts on IDE-object Result:= FindRange(AnAddr, ALinesBefore, ALinesAfter); if result then debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.PrepareRange found existing data Addr=', AnAddr,' before=', ALinesBefore, ' After=', ALinesAfter ]); if Result then exit; if result then debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.PrepareRange calling PrepareEntries Addr=', AnAddr,' before=', ALinesBefore, ' After=', ALinesAfter ]); if PrepareEntries(AnAddr, ALinesBefore, ALinesAfter) then Result:= FindRange(AnAddr, ALinesBefore, ALinesAfter); if result then debugln(DBG_DISASSEMBLER, ['INFO: TDBGDisassembler.PrepareRange found data AFTER PrepareEntries Addr=', AnAddr,' before=', ALinesBefore, ' After=', ALinesAfter ]); end; (******************************************************************************) (******************************************************************************) (** **) (** D E B U G G E R **) (** **) (******************************************************************************) (******************************************************************************) { TDebuggerProperties } constructor TDebuggerProperties.Create; begin // end; procedure TDebuggerProperties.Assign(Source: TPersistent); begin // end; { =========================================================================== } { TDebuggerIntf } { =========================================================================== } class function TDebuggerIntf.Caption: String; begin Result := 'No caption set'; end; function TDebuggerIntf.ChangeFileName: Boolean; begin Result := True; end; constructor TDebuggerIntf.Create(const AExternalDebugger: String); var list: TStringList; nr: TDebuggerNotifyReason; begin inherited Create; for nr := low(TDebuggerNotifyReason) to high(TDebuggerNotifyReason) do FDestroyNotificationList[nr] := TMethodList.Create; FOnState := nil; FOnCurrent := nil; FOnOutput := nil; FOnDbgOutput := nil; FState := dsNone; FArguments := ''; FFilename := ''; FExternalDebugger := AExternalDebugger; list := TStringList.Create; list.OnChange := @DebuggerEnvironmentChanged; FDebuggerEnvironment := list; list := TStringList.Create; list.OnChange := @EnvironmentChanged; FEnvironment := list; FCurEnvironment := TStringList.Create; //FInternalUnitInfoProvider := TDebuggerUnitInfoProvider.Create; FBreakPoints := CreateBreakPoints; FLocals := CreateLocals; FLineInfo := CreateLineInfo; FRegisters := CreateRegisters; FCallStack := CreateCallStack; FDisassembler := CreateDisassembler; FWatches := CreateWatches; FThreads := CreateThreads; FSignals := CreateSignals; FExitCode := 0; end; function TDebuggerIntf.CreateBreakPoints: TDBGBreakPoints; begin Result := TDBGBreakPoints.Create(Self, TDBGBreakPoint); end; function TDebuggerIntf.CreateCallStack: TCallStackSupplier; begin Result := TCallStackSupplier.Create(Self); end; function TDebuggerIntf.CreateDisassembler: TDBGDisassembler; begin Result := TDBGDisassembler.Create(Self); end; function TDebuggerIntf.CreateLocals: TLocalsSupplier; begin Result := TLocalsSupplier.Create(Self); end; function TDebuggerIntf.CreateLineInfo: TDBGLineInfo; begin Result := TDBGLineInfo.Create(Self); end; class function TDebuggerIntf.CreateProperties: TDebuggerProperties; begin Result := TDebuggerProperties.Create; end; function TDebuggerIntf.CreateRegisters: TRegisterSupplier; begin Result := TRegisterSupplier.Create(Self); end; function TDebuggerIntf.CreateSignals: TDBGSignals; begin Result := TDBGSignals.Create(Self, TDBGSignal); end; function TDebuggerIntf.CreateWatches: TWatchesSupplier; begin Result := TWatchesSupplier.Create(Self); end; function TDebuggerIntf.CreateThreads: TThreadsSupplier; begin Result := TThreadsSupplier.Create(Self); end; procedure TDebuggerIntf.DebuggerEnvironmentChanged (Sender: TObject ); begin end; destructor TDebuggerIntf.Destroy; var nr: TDebuggerNotifyReason; begin FDestroyNotificationList[dnrDestroy].CallNotifyEvents(Self); for nr := low(TDebuggerNotifyReason) to high(TDebuggerNotifyReason) do FreeAndNil(FDestroyNotificationList[nr]); // don't call events FOnState := nil; FOnCurrent := nil; FOnOutput := nil; FOnDbgOutput := nil; if FState <> dsNone then Done; FBreakPoints.Debugger := nil; FLocals.Debugger := nil; FLineInfo.Debugger := nil; FRegisters.Debugger := nil; FCallStack.Debugger := nil; FDisassembler.Debugger := nil; FWatches.Debugger := nil; FThreads.Debugger := nil; //FreeAndNil(FInternalUnitInfoProvider); FreeAndNil(FBreakPoints); FreeAndNil(FLocals); FreeAndNil(FLineInfo); FreeAndNil(FRegisters); FreeAndNil(FCallStack); FreeAndNil(FDisassembler); FreeAndNil(FWatches); FreeAndNil(FThreads); FreeAndNil(FDebuggerEnvironment); FreeAndNil(FEnvironment); FreeAndNil(FCurEnvironment); FreeAndNil(FSignals); inherited; end; function TDebuggerIntf.Disassemble(AAddr: TDbgPtr; ABackward: Boolean; out ANextAddr: TDbgPtr; out ADump, AStatement, AFile: String; out ALine: Integer): Boolean; begin Result := ReqCmd(dcDisassemble, [AAddr, ABackward, @ANextAddr, @ADump, @AStatement, @AFile, @ALine]); end; function TDebuggerIntf.GetLocation: TDBGLocationRec; begin Result.Address := 0; Result.SrcLine := 0; end; procedure TDebuggerIntf.LockCommandProcessing; begin // nothing end; procedure TDebuggerIntf.UnLockCommandProcessing; begin // nothing end; function TDebuggerIntf.NeedReset: Boolean; begin Result := False; end; procedure TDebuggerIntf.AddNotifyEvent(AReason: TDebuggerNotifyReason; AnEvent: TNotifyEvent); begin FDestroyNotificationList[AReason].Add(TMethod(AnEvent)); end; procedure TDebuggerIntf.RemoveNotifyEvent(AReason: TDebuggerNotifyReason; AnEvent: TNotifyEvent); begin FDestroyNotificationList[AReason].Remove(TMethod(AnEvent)); end; procedure TDebuggerIntf.Done; begin SetState(dsNone); FEnvironment.Clear; FCurEnvironment.Clear; end; procedure TDebuggerIntf.Release; begin if Self <> nil then Self.DoRelease; end; procedure TDebuggerIntf.DoCurrent(const ALocation: TDBGLocationRec); begin DebugLnEnter(DBG_EVENTS, ['DebugEvent: Enter >> DoCurrent (Location) >> State=', dbgs(FState)]); if Assigned(FOnCurrent) then FOnCurrent(Self, ALocation); DebugLnExit(DBG_EVENTS, ['DebugEvent: Exit << DoCurrent (Location) <<']); end; procedure TDebuggerIntf.DoDbgOutput(const AText: String); begin // WriteLN(' [TDebuggerIntf] ', AText); if Assigned(FOnDbgOutput) then FOnDbgOutput(Self, AText); end; procedure TDebuggerIntf.DoDbgEvent(const ACategory: TDBGEventCategory; const AEventType: TDBGEventType; const AText: String); begin DebugLnEnter(DBG_EVENTS, ['DebugEvent: Enter >> DoDbgEvent >> State=', dbgs(FState), ' Category=', dbgs(ACategory)]); if Assigned(FOnDbgEvent) then FOnDbgEvent(Self, ACategory, AEventType, AText); DebugLnExit(DBG_EVENTS, ['DebugEvent: Exit << DoDbgEvent <<']); end; procedure TDebuggerIntf.DoException(const AExceptionType: TDBGExceptionType; const AExceptionClass: String; const AExceptionLocation: TDBGLocationRec; const AExceptionText: String; out AContinue: Boolean); begin DebugLnEnter(DBG_EVENTS, ['DebugEvent: Enter >> DoException >> State=', dbgs(FState)]); if AExceptionType = deInternal then DoDbgEvent(ecDebugger, etExceptionRaised, Format('Exception class "%s" at $%.' + IntToStr(TargetWidth div 4) + 'x with message "%s"', [AExceptionClass, AExceptionLocation.Address, AExceptionText])); if Assigned(FOnException) then FOnException(Self, AExceptionType, AExceptionClass, AExceptionLocation, AExceptionText, AContinue) else AContinue := True; DebugLnExit(DBG_EVENTS, ['DebugEvent: Exit << DoException <<']); end; procedure TDebuggerIntf.DoOutput(const AText: String); begin if Assigned(FOnOutput) then FOnOutput(Self, AText); end; procedure TDebuggerIntf.DoBreakpointHit(const ABreakPoint: TBaseBreakPoint; var ACanContinue: Boolean); begin DebugLnEnter(DBG_EVENTS, ['DebugEvent: Enter >> DoBreakpointHit << State=', dbgs(FState)]); if Assigned(FOnBreakpointHit) then FOnBreakpointHit(Self, ABreakPoint, ACanContinue); DebugLnExit(DBG_EVENTS, ['DebugEvent: Exit >> DoBreakpointHit <<']); end; procedure TDebuggerIntf.DoBeforeState(const OldState: TDBGState); begin DebugLnEnter(DBG_STATE_EVENT, ['DebugEvent: Enter >> DoBeforeState << State=', dbgs(FState)]); if Assigned(FOnBeforeState) then FOnBeforeState(Self, OldState); DebugLnExit(DBG_STATE_EVENT, ['DebugEvent: Exit >> DoBeforeState <<']); end; procedure TDebuggerIntf.DoState(const OldState: TDBGState); begin DebugLnEnter(DBG_STATE_EVENT, ['DebugEvent: Enter >> DoState << State=', dbgs(FState)]); if Assigned(FOnState) then FOnState(Self, OldState); DebugLnExit(DBG_STATE_EVENT, ['DebugEvent: Exit >> DoState <<']); end; procedure TDebuggerIntf.EnvironmentChanged(Sender: TObject); var n, idx: integer; S: String; Env: TStringList; begin // Createe local copy if FState <> dsNone then begin Env := TStringList.Create; try Env.Assign(Environment); // Check for nonexisting and unchanged vars for n := 0 to FCurEnvironment.Count - 1 do begin S := FCurEnvironment[n]; idx := Env.IndexOfName(GetPart([], ['='], S, False, False)); if idx = -1 then ReqCmd(dcEnvironment, [S, False]) else begin if Env[idx] = S then Env.Delete(idx); end; end; // Set the remaining for n := 0 to Env.Count - 1 do begin S := Env[n]; //Skip functions etc. if Pos('=()', S) <> 0 then Continue; ReqCmd(dcEnvironment, [S, True]); end; finally Env.Free; end; end; FCurEnvironment.Assign(FEnvironment); end; //function TDebuggerIntf.GetUnitInfoProvider: TDebuggerUnitInfoProvider; //begin // Result := FUnitInfoProvider; // if Result = nil then // Result := FInternalUnitInfoProvider; //end; function TDebuggerIntf.GetIsIdle: Boolean; begin Result := False; end; function TDebuggerIntf.Evaluate(const AExpression: String; var AResult: String; var ATypeInfo: TDBGType; EvalFlags: TDBGEvaluateFlags = []): Boolean; begin FreeAndNIL(ATypeInfo); Result := ReqCmd(dcEvaluate, [AExpression, @AResult, @ATypeInfo, Integer(EvalFlags)]); end; function TDebuggerIntf.GetProcessList(AList: TRunningProcessInfoList): boolean; begin result := false; end; class function TDebuggerIntf.ExePaths: String; begin Result := ''; end; class function TDebuggerIntf.HasExePath: boolean; begin Result := true; // most debugger are external and have an exe path end; function TDebuggerIntf.GetCommands: TDBGCommands; begin Result := COMMANDMAP[State] * GetSupportedCommands; end; class function TDebuggerIntf.GetProperties: TDebuggerProperties; var idx: Integer; begin if MDebuggerPropertiesList = nil then MDebuggerPropertiesList := TStringList.Create; idx := MDebuggerPropertiesList.IndexOf(ClassName); if idx = -1 then begin Result := CreateProperties; MDebuggerPropertiesList.AddObject(ClassName, Result) end else begin Result := TDebuggerProperties(MDebuggerPropertiesList.Objects[idx]); end; end; function TDebuggerIntf.GetState: TDBGState; begin Result := FState; end; function TDebuggerIntf.GetSupportedCommands: TDBGCommands; begin Result := []; end; function TDebuggerIntf.GetTargetWidth: Byte; begin Result := SizeOf(PtrInt)*8; end; function TDebuggerIntf.GetWaiting: Boolean; begin Result := False; end; procedure TDebuggerIntf.Init; begin FExitCode := 0; FErrorStateMessage := ''; FErrorStateInfo := ''; SetState(dsIdle); end; procedure TDebuggerIntf.JumpTo(const ASource: String; const ALine: Integer); begin ReqCmd(dcJumpTo, [ASource, ALine]); end; procedure TDebuggerIntf.Attach(AProcessID: String); begin if State = dsIdle then SetState(dsStop); // Needed, because no filename was set ReqCmd(dcAttach, [AProcessID]); end; procedure TDebuggerIntf.Detach; begin ReqCmd(dcDetach, []); end; procedure TDebuggerIntf.SendConsoleInput(AText: String); begin ReqCmd(dcSendConsoleInput, [AText]); end; function TDebuggerIntf.Modify(const AExpression, AValue: String): Boolean; begin Result := ReqCmd(dcModify, [AExpression, AValue]); end; procedure TDebuggerIntf.Pause; begin ReqCmd(dcPause, []); end; function TDebuggerIntf.ReqCmd(const ACommand: TDBGCommand; const AParams: array of const): Boolean; begin if FState = dsNone then Init; if ACommand in Commands then begin Result := RequestCommand(ACommand, AParams); if not Result then begin DebugLn(DBG_WARNINGS, 'TDebuggerIntf.ReqCmd failed: ',dbgs(ACommand)); end; end else begin DebugLn(DBG_WARNINGS, 'TDebuggerIntf.ReqCmd Command not supported: ', dbgs(ACommand),' ClassName=',ClassName); Result := False; end; end; procedure TDebuggerIntf.Run; begin ReqCmd(dcRun, []); end; procedure TDebuggerIntf.RunTo(const ASource: String; const ALine: Integer); begin ReqCmd(dcRunTo, [ASource, ALine]); end; procedure TDebuggerIntf.SetDebuggerEnvironment (const AValue: TStrings ); begin FDebuggerEnvironment.Assign(AValue); end; procedure TDebuggerIntf.SetEnvironment(const AValue: TStrings); begin FEnvironment.Assign(AValue); end; procedure TDebuggerIntf.SetExitCode(const AValue: Integer); begin FExitCode := AValue; end; procedure TDebuggerIntf.SetFileName(const AValue: String); begin if FFileName <> AValue then begin DebugLn(DBG_VERBOSE, '[TDebuggerIntf.SetFileName] "', AValue, '"'); if FState in [dsRun, dsPause] then begin Stop; // check if stopped if FState <> dsStop then SetState(dsError); end; if FState = dsStop then begin // Reset state FFileName := ''; ResetStateToIdle; ChangeFileName; end; FFileName := AValue; // TODO: Why? if (FFilename <> '') and (FState = dsIdle) and ChangeFileName then SetState(dsStop); end else if FileName = '' then ResetStateToIdle; end; procedure TDebuggerIntf.ResetStateToIdle; begin SetState(dsIdle); end; class procedure TDebuggerIntf.SetProperties(const AProperties: TDebuggerProperties); var Props: TDebuggerProperties; begin if AProperties = nil then Exit; Props := GetProperties; if Props = AProperties then Exit; if Props = nil then Exit; // they weren't created ? Props.Assign(AProperties); end; class function TDebuggerIntf.RequiresLocalExecutable: Boolean; begin Result := True; end; procedure TDebuggerIntf.SetState(const AValue: TDBGState); var OldState: TDBGState; begin // dsDestroying is final, do not unset if FState = dsDestroying then exit; // dsDestroying must be silent. The ide believes the debugger is gone already if AValue = dsDestroying then begin FState := AValue; exit; end; if AValue <> FState then begin DebugLnEnter(DBG_STATE, ['DebuggerState: Setting to ', dbgs(AValue),', from ', dbgs(FState)]); OldState := FState; FState := AValue; LockCommandProcessing; try DoBeforeState(OldState); try FThreads.DoStateChange(OldState); FCallStack.DoStateChange(OldState); FBreakpoints.DoStateChange(OldState); FLocals.DoStateChange(OldState); FLineInfo.DoStateChange(OldState); FRegisters.DoStateChange(OldState); FDisassembler.DoStateChange(OldState); FWatches.DoStateChange(OldState); finally DoState(OldState); end; finally UnLockCommandProcessing; DebugLnExit(DBG_STATE, ['DebuggerState: Finished ', dbgs(AValue)]); end; end; end; procedure TDebuggerIntf.SetErrorState(const AMsg: String; const AInfo: String = ''); begin if FErrorStateMessage = '' then FErrorStateMessage := AMsg; if FErrorStateInfo = '' then FErrorStateInfo := AInfo; SetState(dsError); end; procedure TDebuggerIntf.DoRelease; begin Self.Free; end; procedure TDebuggerIntf.StepInto; begin if ReqCmd(dcStepInto, []) then exit; DebugLn(DBG_WARNINGS, 'TDebuggerIntf.StepInto Class=',ClassName,' failed.'); end; procedure TDebuggerIntf.StepOverInstr; begin if ReqCmd(dcStepOverInstr, []) then exit; DebugLn(DBG_WARNINGS, 'TDebuggerIntf.StepOverInstr Class=',ClassName,' failed.'); end; procedure TDebuggerIntf.StepIntoInstr; begin if ReqCmd(dcStepIntoInstr, []) then exit; DebugLn(DBG_WARNINGS, 'TDebuggerIntf.StepIntoInstr Class=',ClassName,' failed.'); end; procedure TDebuggerIntf.StepOut; begin if ReqCmd(dcStepOut, []) then exit; DebugLn(DBG_WARNINGS, 'TDebuggerIntf.StepOut Class=', ClassName, ' failed.'); end; procedure TDebuggerIntf.StepOver; begin if ReqCmd(dcStepOver, []) then exit; DebugLn(DBG_WARNINGS, 'TDebuggerIntf.StepOver Class=',ClassName,' failed.'); end; procedure TDebuggerIntf.Stop; begin if ReqCmd(dcStop,[]) then exit; DebugLn(DBG_WARNINGS, 'TDebuggerIntf.Stop Class=',ClassName,' failed.'); end; function TBaseDebugManagerIntf.DebuggerCount: Integer; begin Result := MDebuggerClasses.Count; end; function TBaseDebugManagerIntf.FindDebuggerClass(const AString: String): TDebuggerClass; var idx: Integer; begin idx := MDebuggerClasses.IndexOf(AString); if idx = -1 then Result := nil else Result := TDebuggerClass(MDebuggerClasses.Objects[idx]); end; function TBaseDebugManagerIntf.GetDebuggerClass(const AIndex: Integer): TDebuggerClass; begin Result := TDebuggerClass(MDebuggerClasses.Objects[AIndex]); end; initialization MDebuggerPropertiesList := nil; {$IFDEF DBG_STATE} {$DEFINE DBG_STATE_EVENT} {$ENDIF} {$IFDEF DBG_EVENTS} {$DEFINE DBG_STATE_EVENT} {$ENDIF} DBG_VERBOSE := DebugLogger.FindOrRegisterLogGroup('DBG_VERBOSE' {$IFDEF DBG_VERBOSE} , True {$ENDIF} ); DBG_WARNINGS := DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS' {$IFDEF DBG_WARNINGS} , True {$ENDIF} ); DBG_STATE := DebugLogger.FindOrRegisterLogGroup('DBG_STATE' {$IFDEF DBG_STATE} , True {$ENDIF} ); DBG_EVENTS := DebugLogger.FindOrRegisterLogGroup('DBG_EVENTS' {$IFDEF DBG_EVENTS} , True {$ENDIF} ); DBG_STATE_EVENT := DebugLogger.FindOrRegisterLogGroup('DBG_STATE_EVENT' {$IFDEF DBG_STATE_EVENT} , True {$ENDIF} ); DBG_DATA_MONITORS := DebugLogger.FindOrRegisterLogGroup('DBG_DATA_MONITORS' {$IFDEF DBG_DATA_MONITORS} , True {$ENDIF} ); DBG_DISASSEMBLER := DebugLogger.FindOrRegisterLogGroup('DBG_DISASSEMBLER' {$IFDEF DBG_DISASSEMBLER} , True {$ENDIF} ); MDebuggerClasses := TStringList.Create; MDebuggerClasses.Sorted := True; MDebuggerClasses.Duplicates := dupError; finalization DoFinalization; FreeAndNil(MDebuggerClasses); end.