{ $Id$ } { ---------------------------------------- Debugger.pp - Debugger base classes ---------------------------------------- @created(Wed Feb 25st WET 2001) @author(Marc Weustink ) 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 Debugger; {$mode objfpc}{$H+} {$IFDEF linux} {$DEFINE DBG_ENABLE_TERMINAL} {$ENDIF} interface uses Classes, SysUtils, Laz_XMLCfg, math, LCLProc, IDEProcs, DebugUtils, maps; type // datatype pointing to data on the target TDBGPtr = type QWord; TDBGLocationRec = record Address: TDBGPtr; FuncName: String; SrcFile: String; SrcFullName: String; SrcLine: Integer; end; TDBGCommand = ( dcRun, dcPause, dcStop, dcStepOver, dcStepInto, dcStepOut, dcRunTo, dcJumpto, dcBreak, dcWatch, dcLocal, dcEvaluate, dcModify, dcEnvironment, dcSetStackFrame, dcDisassemble, dcStepOverInstr, dcStepIntoInstr, dcSendConsoleInput ); TDBGCommands = set of TDBGCommand; TDBGState = ( dsNone, dsIdle, dsStop, dsPause, dsInit, dsRun, dsError, dsDestroying ); TDBGExceptionType = ( deInternal, deExternal, deRunError ); { 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 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. -------------------------------------------------------------------------- } 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 ); TDBGEvaluateFlags = set of TDBGEvaluateFlag; const // dcRunCommands = [dcRun,dcStepInto,dcStepOver,dcRunTo]; // dsRunStates = [dsRun]; XMLBreakPointsNode = 'BreakPoints'; XMLBreakPointGroupsNode = 'BreakPointGroups'; XMLWatchesNode = 'Watches'; XMLExceptionsNode = 'Exceptions'; type EDebuggerException = class(Exception); EDBGExceptions = class(EDebuggerException); type { ---------------------------------------------------------
TDebuggerNotification is a reference counted baseclass for handling notifications for locals, watches, breakpoints etc.
---------------------------------------------------------} TDebuggerNotification = class(TObject) private FRefCount: Integer; public procedure AddReference; constructor Create; destructor Destroy; override; procedure ReleaseReference; end; TDebuggerChangeNotification = class(TDebuggerNotification) private FOnChange: TNotifyEvent; public property OnChange: TNotifyEvent read FOnChange write FOnChange; end; { TDebuggerNotificationList } TDebuggerNotificationList = class(TObject) private FList: TList; function GetItem(AIndex: Integer): TDebuggerNotification; protected function NextDownIndex(var Index: integer): boolean; public constructor Create; destructor Destroy; override; procedure Add(const ANotification: TDebuggerNotification); procedure Remove(const ANotification: TDebuggerNotification); function Count: Integer; procedure Clear; property Items[AIndex: Integer]: TDebuggerNotification read GetItem; default; end; { TDebuggerChangeNotificationList } TDebuggerChangeNotificationList = class(TDebuggerNotificationList) private function GetItem(AIndex: Integer): TDebuggerChangeNotification; reintroduce; public procedure NotifyChange(Sender: TObject); property Items[AIndex: Integer]: TDebuggerChangeNotification read GetItem; default; end; TIDEBreakPoints = class; TIDEBreakPointGroup = class; TIDEBreakPointGroups = class; TIDEWatches = class; TIDELocals = class; TIDELineInfo = class; TDebugger = class; TOnSaveFilenameToConfig = procedure(var Filename: string) of object; TOnLoadFilenameFromConfig = procedure(var Filename: string) of object; TOnGetGroupByName = function(const GroupName: string): TIDEBreakPointGroup of object; (******************************************************************************) (******************************************************************************) (** **) (** B R E A K P O I N T S **) (** **) (******************************************************************************) (******************************************************************************) { TIDEBreakPoint } // The TBaseBreakpoint family is the common ancestor for the "public" available // TIDEBreakPoint through the DebugBoss as well as the "private" TDBGBreakPoint // used by the debugboss itself. // The BreakPointGroups are no longer part of the debugger, but they are now // managed by the debugboss. TIDEBreakPointAction = ( bpaStop, bpaEnableGroup, bpaDisableGroup ); TIDEBreakPointActions = set of TIDEBreakPointAction; { TBaseBreakPoint } TBaseBreakPoint = class(TDelayedUdateItem) private FEnabled: Boolean; FExpression: String; FHitCount: Integer; FBreakHitCount: Integer; FLine: Integer; 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 AContinue: Boolean); virtual; procedure SetHitCount(const AValue: Integer); procedure SetValid(const AValue: TValidState); protected // virtual properties function GetBreakHitCount: Integer; virtual; function GetEnabled: Boolean; virtual; function GetExpression: String; virtual; function GetHitCount: Integer; virtual; function GetLine: Integer; virtual; function GetSource: String; virtual; function GetValid: TValidState; 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; public constructor Create(ACollection: TCollection); override; procedure SetLocation(const ASource: String; const ALine: Integer); virtual;// 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; // 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; property Valid: TValidState read GetValid; end; TBaseBreakPointClass = class of TBaseBreakPoint; TIDEBreakPoint = class(TBaseBreakPoint) private FAutoContinueTime: Cardinal; FActions: TIDEBreakPointActions; FDisableGroupList: TList; FEnableGroupList: TList; FGroup: TIDEBreakPointGroup; FLoading: Boolean; protected procedure AssignTo(Dest: TPersistent); override; procedure DisableGroups; procedure DoActionChange; virtual; procedure DoHit(const ACount: Integer; var AContinue: Boolean); override; procedure EnableGroups; procedure RemoveFromGroupList(const AGroup: TIDEBreakPointGroup; const AGroupList: TList); procedure ClearGroupList(const AGroupList: TList); procedure ClearAllGroupLists; protected // virtual properties function GetActions: TIDEBreakPointActions; virtual; function GetGroup: TIDEBreakPointGroup; virtual; function GetAutoContinueTime: Cardinal; virtual; procedure SetActions(const AValue: TIDEBreakPointActions); virtual; procedure SetGroup(const AValue: TIDEBreakPointGroup); virtual; procedure SetAutoContinueTime(const AValue: Cardinal); virtual; public constructor Create(ACollection: TCollection); override; destructor Destroy; override; procedure AddDisableGroup(const AGroup: TIDEBreakPointGroup); procedure AddEnableGroup(const AGroup: TIDEBreakPointGroup); procedure RemoveDisableGroup(const AGroup: TIDEBreakPointGroup); procedure RemoveEnableGroup(const AGroup: TIDEBreakPointGroup); procedure LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string; const OnLoadFilename: TOnLoadFilenameFromConfig; const OnGetGroup: TOnGetGroupByName); virtual; procedure SaveToXMLConfig(const AConfig: TXMLConfig; const APath: string; const OnSaveFilename: TOnSaveFilenameToConfig); virtual; public property Actions: TIDEBreakPointActions read GetActions write SetActions; property AutoContinueTime: Cardinal read GetAutoContinueTime write SetAutoContinueTime; property Group: TIDEBreakPointGroup read GetGroup write SetGroup; property Loading: Boolean read FLoading; end; TIDEBreakPointClass = class of TIDEBreakPoint; { TDBGBreakPoint } TDBGBreakPoint = class(TBaseBreakPoint) private FSlave: TBaseBreakPoint; function GetDebugger: TDebugger; procedure SetSlave(const ASlave : TBaseBreakPoint); protected procedure DoChanged; override; procedure DoStateChange(const AOldState: TDBGState); virtual; property Debugger: TDebugger read GetDebugger; public constructor Create(ACollection: TCollection); override; destructor Destroy; override; procedure Hit(var ACanContinue: Boolean); property Slave: TBaseBreakPoint read FSlave write SetSlave; end; TDBGBreakPointClass = class of TDBGBreakPoint; { TIDEBreakPoints } TIDEBreakPointsEvent = procedure(const ASender: TIDEBreakPoints; const ABreakpoint: TIDEBreakPoint) of object; TIDEBreakPointsNotification = class(TDebuggerNotification) private FOnAdd: TIDEBreakPointsEvent; FOnUpdate: TIDEBreakPointsEvent;//Item will be nil in case all items need to be updated FOnRemove: TIDEBreakPointsEvent; public property OnAdd: TIDEBreakPointsEvent read FOnAdd write FOnAdd; property OnUpdate: TIDEBreakPointsEvent read FOnUpdate write FOnUpdate; property OnRemove: TIDEBreakPointsEvent read FOnRemove write FonRemove; end; TBaseBreakPoints = class(TCollection) private protected public constructor Create(const ABreakPointClass: TBaseBreakPointClass); function Add(const ASource: String; const ALine: Integer): TBaseBreakPoint; function Find(const ASource: String; const ALine: Integer): TBaseBreakPoint; overload; function Find(const ASource: String; const ALine: Integer; const AIgnore: TBaseBreakPoint): TBaseBreakPoint; overload; // no items property needed, it is "overridden" anyhow end; TIDEBreakPoints = class(TBaseBreakPoints) private FNotificationList: TList; function GetItem(const AnIndex: Integer): TIDEBreakPoint; procedure SetItem(const AnIndex: Integer; const AValue: TIDEBreakPoint); protected procedure NotifyAdd(const ABreakPoint: TIDEBreakPoint); virtual; // called when a breakpoint is added procedure NotifyRemove(const ABreakpoint: TIDEBreakPoint); virtual; // called by breakpoint when destructed procedure Update(Item: TCollectionItem); override; public constructor Create(const ABreakPointClass: TIDEBreakPointClass); destructor Destroy; override; function Add(const ASource: String; const ALine: Integer): TIDEBreakPoint; function Find(const ASource: String; const ALine: Integer): TIDEBreakPoint; overload; function Find(const ASource: String; const ALine: Integer; const AIgnore: TIDEBreakPoint): TIDEBreakPoint; overload; procedure AddNotification(const ANotification: TIDEBreakPointsNotification); procedure RemoveNotification(const ANotification: TIDEBreakPointsNotification); procedure LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string; const OnLoadFilename: TOnLoadFilenameFromConfig; const OnGetGroup: TOnGetGroupByName); virtual; procedure SaveToXMLConfig(XMLConfig: TXMLConfig; const Path: string; const OnSaveFilename: TOnSaveFilenameToConfig); virtual; public property Items[const AnIndex: Integer]: TIDEBreakPoint read GetItem write SetItem; default; end; TDBGBreakPoints = class(TBaseBreakPoints) private FDebugger: TDebugger; // 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: TDebugger read FDebugger; public function Add(const ASource: String; const ALine: Integer): TDBGBreakPoint; constructor Create(const ADebugger: TDebugger; const ABreakPointClass: TDBGBreakPointClass); function Find(const ASource: String; const ALine: Integer): TDBGBreakPoint; overload; function Find(const ASource: String; const ALine: Integer; const AIgnore: TDBGBreakPoint): TDBGBreakPoint; overload; property Items[const AnIndex: Integer]: TDBGBreakPoint read GetItem write SetItem; default; end; { TIDEBreakPointGroup } TIDEBreakPointGroup = class(TCollectionItem) private FEnabled: Boolean; FInitialEnabled: Boolean; FName: String; FBreakpoints: TList;// A list of breakpoints that member FReferences: TList; // A list of breakpoints that refer to us through En/disable group function GetBreakpoint(const AIndex: Integer): TIDEBreakPoint; procedure SetEnabled(const AValue: Boolean); procedure SetInitialEnabled(const AValue: Boolean); procedure SetName(const AValue: String); protected procedure AssignTo(Dest: TPersistent); override; procedure AddReference(const ABreakPoint: TIDEBreakPoint); procedure RemoveReference(const ABreakPoint: TIDEBreakPoint); public function Add(const ABreakPoint: TIDEBreakPoint): Integer; function Count: Integer; constructor Create(ACollection: TCollection); override; procedure Delete(const AIndex: Integer); destructor Destroy; override; function Remove(const ABreakPoint: TIDEBreakPoint): Integer; procedure LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string); virtual; procedure SaveToXMLConfig(XMLConfig: TXMLConfig; const Path: string); virtual; public property Breakpoints[const AIndex: Integer]: TIDEBreakPoint read GetBreakpoint; property Enabled: Boolean read FEnabled write SetEnabled; property InitialEnabled: Boolean read FInitialEnabled write SetInitialEnabled; property Name: String read FName write SetName; end; { TIDEBreakPointGroups } TIDEBreakPointGroups = class(TCollection) private function GetItem(const AnIndex: Integer): TIDEBreakPointGroup; procedure SetItem(const AnIndex: Integer; const AValue: TIDEBreakPointGroup); protected public constructor Create; procedure LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string); virtual; procedure SaveToXMLConfig(XMLConfig: TXMLConfig; const Path: string); virtual; function GetGroupByName(const GroupName: string): TIDEBreakPointGroup; function FindGroupByName(const GroupName: string; Ignore: TIDEBreakPointGroup): TIDEBreakPointGroup; function IndexOfGroupWithName(const GroupName: string; Ignore : TIDEBreakPointGroup): integer; procedure InitTargetStart; virtual; // procedure Regroup(SrcGroups: TIDEBreakPointGroups; // SrcBreakPoints, DestBreakPoints: TIDEBreakPoints); public property Items[const AnIndex: Integer]: TIDEBreakPointGroup read GetItem write SetItem; default; end; (******************************************************************************) (******************************************************************************) (** **) (** D E B U G I N F O R M A T I O N **) (** **) (******************************************************************************) (******************************************************************************) type TDBGSymbolKind = (skClass, skRecord, skEnum, skSet, skProcedure, skFunction, skSimple, skPointer, skVariant); TDBGSymbolAttribute = (saRefParam, // var, const, constref passed by reference saInternalPointer // PointerToObject ); 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) protected FAncestor: String; FResult: TDBGType; FResultString: String; FArguments: TDBGTypes; FAttributes: TDBGSymbolAttributes; FFields: TDBGFields; FKind: TDBGSymbolKind; FMembers: TStrings; FTypeName: String; FTypeDeclaration: String; FDBGValue: TDBGValue; 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 FFields; 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; property Result: TDBGType read FResult; end; {%region Watches ************************************************************** ****************************************************************************** ** ** ** W A T C H E S ** ** ** ****************************************************************************** ******************************************************************************} TWatchDisplayFormat = (wdfDefault, wdfStructure, wdfChar, wdfString, wdfDecimal, wdfUnsigned, wdfFloat, wdfHex, wdfPointer, wdfMemDump ); TRegisterDisplayFormat = (rdDefault, rdHex, rdBinary, rdOctal, rdDecimal, rdRaw ); const TWatchDisplayFormatNames: array [TWatchDisplayFormat] of string = ('wdfDefault', 'wdfStructure', 'wdfChar', 'wdfString', 'wdfDecimal', 'wdfUnsigned', 'wdfFloat', 'wdfHex', 'wdfPointer', 'wdfMemDump' ); type { TBaseWatch } TBaseWatch = class(TDelayedUdateItem) private FEnabled: Boolean; FExpression: String; FDisplayFormat: TWatchDisplayFormat; FValid: TValidState; function GetEnabled: Boolean; protected procedure AssignTo(Dest: TPersistent); override; procedure DoEnableChange; virtual; procedure DoExpressionChange; virtual; procedure DoDisplayFormatChanged; virtual; procedure SetValid(const AValue: TValidState); protected // virtual properties function GetExpression: String; virtual; function GetDisplayFormat: TWatchDisplayFormat; virtual; function GetValid: TValidState; virtual; function GetValue: String; virtual; function GetTypeInfo: TDBGType; virtual; procedure SetEnabled(const AValue: Boolean); virtual; procedure SetExpression(const AValue: String); virtual; procedure SetDisplayFormat(const AValue: TWatchDisplayFormat); virtual; public constructor Create(ACollection: TCollection); override; public property Enabled: Boolean read GetEnabled write SetEnabled; property Expression: String read GetExpression write SetExpression; property DisplayFormat: TWatchDisplayFormat read GetDisplayFormat write SetDisplayFormat; property Valid: TValidState read GetValid; property Value: String read GetValue; property TypeInfo: TDBGType read GetTypeInfo; end; TBaseWatchClass = class of TBaseWatch; TIDEWatch = class(TBaseWatch) private protected public constructor Create(ACollection: TCollection); override; destructor Destroy; override; procedure LoadFromXMLConfig(const AConfig: TXMLConfig; const APath: string); virtual; procedure SaveToXMLConfig(const AConfig: TXMLConfig; const APath: string); virtual; end; TIDEWatchClass = class of TIDEWatch; { TDBGWatch } TDBGWatch = class(TBaseWatch) private FSlave: TBaseWatch; function GetDebugger: TDebugger; procedure SetSlave(const ASlave : TBaseWatch); protected procedure DoChanged; override; procedure DoChange; virtual; procedure DoStateChange(const AOldState: TDBGState); virtual; property Debugger: TDebugger read GetDebugger; public constructor Create(ACollection: TCollection); override; destructor Destroy; override; property Slave: TBaseWatch read FSlave write SetSlave; end; TDBGWatchClass = class of TDBGWatch; { TBaseWatches } TIDEWatchesEvent = procedure(const ASender: TIDEWatches; const AWatch: TIDEWatch) of object; TIDEWatchesNotification = class(TDebuggerNotification) private FOnAdd: TIDEWatchesEvent; FOnUpdate: TIDEWatchesEvent;//Item will be nil in case all items need to be updated FOnRemove: TIDEWatchesEvent; public property OnAdd: TIDEWatchesEvent read FOnAdd write FOnAdd; property OnUpdate: TIDEWatchesEvent read FOnUpdate write FOnUpdate; property OnRemove: TIDEWatchesEvent read FOnRemove write FonRemove; end; TBaseWatches = class(TCollection) private protected public constructor Create(const AWatchClass: TBaseWatchClass); function Add(const AExpression: String): TBaseWatch; function Find(const AExpression: String): TBaseWatch; // no items property needed, it is "overridden" anyhow end; TIDEWatches = class(TBaseWatches) private FNotificationList: TList; function GetItem(const AnIndex: Integer): TIDEWatch; procedure SetItem(const AnIndex: Integer; const AValue: TIDEWatch); protected procedure NotifyAdd(const AWatch: TIDEWatch); virtual; // called when a watch is added procedure NotifyRemove(const AWatch: TIDEWatch); virtual; // called by watch when destructed procedure Update(Item: TCollectionItem); override; public constructor Create(const AWatchClass: TIDEWatchClass); destructor Destroy; override; // Watch function Add(const AExpression: String): TIDEWatch; function Find(const AExpression: String): TIDEWatch; // IDE procedure AddNotification(const ANotification: TIDEWatchesNotification); procedure RemoveNotification(const ANotification: TIDEWatchesNotification); procedure LoadFromXMLConfig(const AConfig: TXMLConfig; const APath: string); virtual; procedure SaveToXMLConfig(const AConfig: TXMLConfig; const APath: string); virtual; public property Items[const AnIndex: Integer]: TIDEWatch read GetItem write SetItem; default; end; { TDBGWatches } TDBGWatches = class(TBaseWatches) private FDebugger: TDebugger; // reference to our debugger FOnChange: TNotifyEvent; function GetItem(const AnIndex: Integer): TDBGWatch; procedure SetItem(const AnIndex: Integer; const AValue: TDBGWatch); protected procedure DoStateChange(const AOldState: TDBGState); virtual; procedure Update(Item: TCollectionItem); override; property Debugger: TDebugger read FDebugger; public constructor Create(const ADebugger: TDebugger; const AWatchClass: TDBGWatchClass); // Watch function Add(const AExpression: String): TDBGWatch; function Find(const AExpression: String): TDBGWatch; public property Items[const AnIndex: Integer]: TDBGWatch read GetItem write SetItem; default; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; {%endregion ^^^^^ Watches ^^^^^ } {%region Locals *************************************************************** ****************************************************************************** ** ** ** L O C A L S ** ** ** ****************************************************************************** ******************************************************************************} { TBaseLocals } TBaseLocals = class(TObject) private protected function GetName(const AnIndex: Integer): String; virtual; function GetValue(const AnIndex: Integer): String; virtual; public constructor Create; function Count: Integer; virtual; public property Names[const AnIndex: Integer]: String read GetName; property Values[const AnIndex: Integer]: String read GetValue; end; { TIDELocals } TIDELocalsNotification = class(TDebuggerNotification) private FOnChange: TNotifyEvent; public property OnChange: TNotifyEvent read FOnChange write FOnChange; end; TIDELocals = class(TBaseLocals) private FNotificationList: TList; protected procedure NotifyChange; public constructor Create; destructor Destroy; override; procedure AddNotification(const ANotification: TIDELocalsNotification); procedure RemoveNotification(const ANotification: TIDELocalsNotification); end; { TDBGLocals } TDBGLocals = class(TBaseLocals) private FDebugger: TDebugger; // reference to our debugger FOnChange: TNotifyEvent; protected procedure Changed; virtual; procedure DoChange; procedure DoStateChange(const AOldState: TDBGState); virtual; function GetCount: Integer; virtual; property Debugger: TDebugger read FDebugger; public function Count: Integer; override; constructor Create(const ADebugger: TDebugger); property OnChange: TNotifyEvent read FOnChange write FOnChange; 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 AnIndex: integer): String; virtual; public constructor Create; function Count: Integer; virtual; function GetAddress(const AIndex: Integer; const ALine: Integer): TDbgPtr; virtual; function GetAddress(const ASource: String; const ALine: Integer): TDbgPtr; function GetInfo(AAdress: TDbgPtr; out ASource, ALine, AOffset: Integer): Boolean; virtual; function IndexOf(const ASource: String): integer; virtual; procedure Request(const ASource: String); virtual; public property Sources[const AnIndex: Integer]: String read GetSource; end; { TIDELineInfo } TIDELineInfoNotification = class(TDebuggerNotification) private FOnChange: TIDELineInfoEvent; public property OnChange: TIDELineInfoEvent read FOnChange write FOnChange; end; TIDELineInfo = class(TBaseLineInfo) private FNotificationList: TList; protected procedure NotifyChange(ASource: String); public constructor Create; destructor Destroy; override; procedure AddNotification(const ANotification: TIDELineInfoNotification); procedure RemoveNotification(const ANotification: TIDELineInfoNotification); end; { TDBGLineInfo } TDBGLineInfo = class(TBaseLineInfo) private FDebugger: TDebugger; // reference to our debugger FOnChange: TIDELineInfoEvent; protected procedure Changed(ASource: String); virtual; procedure DoChange(ASource: String); procedure DoStateChange(const AOldState: TDBGState); virtual; property Debugger: TDebugger read FDebugger; public constructor Create(const ADebugger: TDebugger); property OnChange: TIDELineInfoEvent read FOnChange write FOnChange; end; {%endregion ^^^^^ Line Info ^^^^^ } {%region Register ************************************************************* ****************************************************************************** ** ** ** R E G I S T E R S ** ** ** ****************************************************************************** ******************************************************************************} { TBaseRegisters } TBaseRegisters = class(TObject) protected FUpdateCount: Integer; function GetModified(const AnIndex: Integer): Boolean; virtual; function GetName(const AnIndex: Integer): String; virtual; function GetValue(const AnIndex: Integer): String; virtual; function GetFormat(const AnIndex: Integer): TRegisterDisplayFormat; virtual; procedure SetFormat(const AnIndex: Integer; const AValue: TRegisterDisplayFormat); virtual; procedure ChangeUpdating; virtual; function Updating: Boolean; public constructor Create; function Count: Integer; virtual; public procedure BeginUpdate; procedure EndUpdate; property Modified[const AnIndex: Integer]: Boolean read GetModified; property Names[const AnIndex: Integer]: String read GetName; property Values[const AnIndex: Integer]: String read GetValue; property Formats[const AnIndex: Integer]: TRegisterDisplayFormat read GetFormat write SetFormat; end; { TIDERegisters } TIDERegistersNotification = class(TDebuggerNotification) private FOnChange: TNotifyEvent; public property OnChange: TNotifyEvent read FOnChange write FOnChange; end; TIDERegisters = class(TBaseRegisters) private FNotificationList: TList; protected procedure NotifyChange; public constructor Create; destructor Destroy; override; procedure AddNotification(const ANotification: TIDERegistersNotification); procedure RemoveNotification(const ANotification: TIDERegistersNotification); end; { TDBGRegisters } TDBGRegisters = class(TBaseRegisters) private FDebugger: TDebugger; // reference to our debugger FOnChange: TNotifyEvent; FChanged: Boolean; protected procedure Changed; virtual; procedure DoChange; procedure DoStateChange(const AOldState: TDBGState); virtual; function GetCount: Integer; virtual; procedure SetFormat(const AnIndex: Integer; const AValue: TRegisterDisplayFormat); override; procedure ChangeUpdating; override; property Debugger: TDebugger read FDebugger; public function Count: Integer; override; constructor Create(const ADebugger: TDebugger); property OnChange: TNotifyEvent read FOnChange write FOnChange; 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 * ******************************************************************************} TBaseCallStack = class; { TCallStackEntry } TCallStackEntryState = (cseValid, cseRequested, cseInvalid); TCallStackEntry = class(TObject) private FOwner: TBaseCallStack; FIndex: Integer; FAdress: TDbgPtr; FFunctionName: String; FLine: Integer; FArguments: TStrings; FSource: String; FFullFileName: String; FState: TCallStackEntryState; function GetArgumentCount: Integer; function GetArgumentName(const AnIndex: Integer): String; function GetArgumentValue(const AnIndex: Integer): String; function GetCurrent: Boolean; function GetFullFileName: String; function GetFunctionName: String; function GetSource: String; procedure SetCurrent(const AValue: Boolean); public constructor Create(const AIndex:Integer; const AnAdress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const ASource: String; const AFullFileName: String; const ALine: Integer; AState: TCallStackEntryState = cseValid); constructor CreateCopy(const ASource: TCallStackEntry); destructor Destroy; override; function GetFunctionWithArg: String; property Address: TDbgPtr read FAdress; property ArgumentCount: Integer read GetArgumentCount; property ArgumentNames[const AnIndex: Integer]: String read GetArgumentName; property ArgumentValues[const AnIndex: Integer]: String read GetArgumentValue; property Current: Boolean read GetCurrent write SetCurrent; property FunctionName: String read GetFunctionName; property Index: Integer read FIndex; property Line: Integer read FLine; property Source: String read GetSource; property FullFileName: String read GetFullFileName; property State: TCallStackEntryState read FState write FState; end; { TBaseCallStack } TBaseCallStack = class(TObject) private FCount: Integer; function IndexError(AIndex: Integer): TCallStackEntry; function GetEntry(AIndex: Integer): TCallStackEntry; protected function CheckCount: Boolean; virtual; procedure Clear; virtual; function GetCurrent: TCallStackEntry; virtual; function InternalGetEntry(AIndex: Integer): TCallStackEntry; virtual; procedure SetCurrent(AValue: TCallStackEntry); virtual; procedure SetCount(ACount: Integer); virtual; public function Count: Integer; destructor Destroy; override; procedure PrepareRange(AIndex, ACount: Integer); virtual; property Current: TCallStackEntry read GetCurrent write SetCurrent; property Entries[AIndex: Integer]: TCallStackEntry read GetEntry; end; { TIDECallStackNotification } TIDECallStackNotification = class(TDebuggerNotification) private FOnChange: TNotifyEvent; FOnCurrent: TNotifyEvent; public property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnCurrent: TNotifyEvent read FOnCurrent write FOnCurrent; end; { TIDECallStack } TIDECallStack = class(TBaseCallStack) private FNotificationList: TList; protected procedure NotifyChange; procedure NotifyCurrent; public constructor Create; destructor Destroy; override; procedure AddNotification(const ANotification: TIDECallStackNotification); procedure RemoveNotification(const ANotification: TIDECallStackNotification); end; { TDBGCallStack } TDBGCallStack = class(TBaseCallStack) private FDebugger: TDebugger; // reference to our debugger FEntries: TMap; // list of created entries FOldState: TDBGState; FOnChange: TNotifyEvent; FOnClear: TNotifyEvent; FOnCurrent: TNotifyEvent; protected function CreateStackEntry(AIndex: Integer): TCallStackEntry; virtual; procedure CurrentChanged; procedure Changed; function CheckCount: Boolean; override; procedure Clear; override; procedure DoStateChange(const AOldState: TDBGState); virtual; function InternalGetEntry(AIndex: Integer): TCallStackEntry; override; procedure InternalSetEntry(AIndex: Integer; AEntry: TCallStackEntry); procedure PrepareEntries(AStartIndex, AEndIndex: Integer); virtual; property Debugger: TDebugger read FDebugger; public constructor Create(const ADebugger: TDebugger); destructor Destroy; override; public procedure PrepareRange(AIndex, ACount: Integer); override; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnClear: TNotifyEvent read FOnClear write FOnClear; property OnCurrent: TNotifyEvent read FOnCurrent write FOnCurrent; 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 avai; 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; function IndexError(AIndex: Integer): TCallStackEntry; function GetEntry(AIndex: Integer): TDisassemblerEntry; protected function InternalGetEntry(AIndex: Integer): TDisassemblerEntry; virtual; function InternalGetEntryPtr(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(AnAddr: TDbgPtr; ALinesBefore, 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; { TIDEDisassemblerNotification } TIDEDisassemblerNotification = class(TDebuggerNotification) private FOnChange: TNotifyEvent; public property OnChange: TNotifyEvent read FOnChange write FOnChange; end; TIDEDisassembler = class(TBaseDisassembler) private FNotificationList: TList; protected procedure DoChanged; override; public constructor Create; destructor Destroy; override; procedure AddNotification(const ANotification: TIDEDisassemblerNotification); procedure RemoveNotification(const ANotification: TIDEDisassemblerNotification); 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); 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; 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); 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: TDebugger; 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(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): boolean; virtual; function HandleRangeWithInvalidAddr(ARange: TDBGDisassemblerEntryRange;AnAddr: TDbgPtr; var ALinesBefore, ALinesAfter: Integer): boolean; virtual; property Debugger: TDebugger read FDebugger; property EntryRanges: TDBGDisassemblerEntryMap read FEntryRanges; public constructor Create(const ADebugger: TDebugger); 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 ** ** ** ****************************************************************************** ******************************************************************************} { TIDEThreadsNotification } TIDEThreadsNotification = class(TDebuggerChangeNotification) end; { TDBGThreadEntry } TDBGThreadEntry = class(TCallStackEntry) private FThreadId: Integer; FThreadName: String; FThreadState: String; public constructor Create(const AIndex:Integer; const AnAdress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const ASource: String; const AFullFileName: String; const ALine: Integer; const AThreadId: Integer; const AThreadName: String; const AThreadState: String; AState: TCallStackEntryState = cseValid); constructor CreateCopy(const ASource: TDBGThreadEntry); property ThreadId: Integer read FThreadId; property ThreadName: String read FThreadName; property ThreadState: String read FThreadState; end; { TBaseThreads } TBaseThreads = class(TObject) private FCurrentThreadId: Integer; FList: TList; function GetEntry(const AnIndex: Integer): TDBGThreadEntry; procedure SetCurrentThreadId(const AValue: Integer); virtual; protected procedure Assign(AOther: TBaseThreads); public constructor Create; destructor Destroy; override; function Count: Integer; virtual; procedure Clear; procedure Add(AThread: TDBGThreadEntry); property Entries[const AnIndex: Integer]: TDBGThreadEntry read GetEntry; default; property CurrentThreadId: Integer read FCurrentThreadId write SetCurrentThreadId; end; TDBGThreads = class; TIDEThreads = class(TBaseThreads) private FNotificationList: TDebuggerChangeNotificationList; FMaster: TDBGThreads; FDataValid: Boolean; procedure SetMaster(const AValue: TDBGThreads); protected procedure MasterDestroyed; procedure Changed; procedure InvalidateData; procedure ValidateData; public constructor Create; destructor Destroy; override; function Count: Integer; override; procedure AddNotification(const ANotification: TIDEThreadsNotification); procedure RemoveNotification(const ANotification: TIDEThreadsNotification); procedure ChangeCurrentThread(ANewId: Integer); property Master: TDBGThreads read FMaster write SetMaster; end; { TDBGThreads } TDBGThreads = class(TObject) private FSlave: TIDEThreads; FDebugger: TDebugger; procedure SetSlave(const AValue: TIDEThreads); protected procedure ChangeCurrentThread(ANewId: Integer); virtual; abstract; procedure RequestMasterData; virtual; abstract; procedure Changed; procedure Finished; property Debugger: TDebugger read FDebugger write FDebugger; public constructor Create(const ADebugger: TDebugger); destructor Destroy; override; procedure DoStateChange(const AOldState: TDBGState); virtual; property Slave: TIDEThreads read FSlave write SetSlave; end; {%endregion ^^^^^ Threads ^^^^^ } (******************************************************************************) (******************************************************************************) (** **) (** 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: TDebugger; protected property Debugger: TDebugger read GetDebugger; public end; TDBGSignalClass = class of TDBGSignal; TIDESignal = class(TBaseSignal) private protected public procedure LoadFromXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); procedure SaveToXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); end; { TBaseSignals } TBaseSignals = class(TCollection) private function Add(const AName: String; AID: Integer): TBaseSignal; function Find(const AName: String): TBaseSignal; protected public constructor Create(const AItemClass: TBaseSignalClass); procedure Reset; virtual; end; { TDBGSignals } TDBGSignals = class(TBaseSignals) private FDebugger: TDebugger; // reference to our debugger function GetItem(const AIndex: Integer): TDBGSignal; procedure SetItem(const AIndex: Integer; const AValue: TDBGSignal); protected public constructor Create(const ADebugger: TDebugger; 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; { TIDESignals } TIDESignals = class(TBaseSignals) private function GetItem(const AIndex: Integer): TIDESignal; procedure SetItem(const AIndex: Integer; const AValue: TIDESignal); protected public function Add(const AName: String; AID: Integer): TIDESignal; function Find(const AName: String): TIDESignal; public procedure LoadFromXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); procedure SaveToXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); property Items[const AIndex: Integer]: TIDESignal read GetItem write SetItem; default; end; { TBaseException } TBaseException = class(TDelayedUdateItem) private FName: String; protected procedure AssignTo(Dest: TPersistent); override; procedure SetName(const AValue: String); virtual; public constructor Create(ACollection: TCollection); override; procedure LoadFromXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); virtual; procedure SaveToXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); virtual; public property Name: String read FName write SetName; end; TBaseExceptionClass = class of TBaseException; { TDBGException } TDBGException = class(TBaseException) private protected public end; TDBGExceptionClass = class of TDBGException; { TIDEException } TIDEException = class(TBaseException) private FEnabled: Boolean; procedure SetEnabled(const AValue: Boolean); protected public constructor Create(ACollection: TCollection); override; procedure LoadFromXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); override; procedure SaveToXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); override; property Enabled: Boolean read FEnabled write SetEnabled; end; { TBaseExceptions } TBaseExceptions = class(TCollection) private FIgnoreAll: Boolean; function Add(const AName: String): TBaseException; function Find(const AName: String): TBaseException; protected 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; property IgnoreAll: Boolean read FIgnoreAll write SetIgnoreAll; end; { TDBGExceptions } TDBGExceptions = class(TBaseExceptions) private FDebugger: TDebugger; // reference to our debugger function GetItem(const AIndex: Integer): TDBGException; procedure SetItem(const AIndex: Integer; const AValue: TDBGException); protected public constructor Create(const ADebugger: TDebugger; const AExceptionClass: TDBGExceptionClass); function Add(const AName: String): TDBGException; function Find(const AName: String): TDBGException; public property Items[const AIndex: Integer]: TDBGException read GetItem write SetItem; default; end; { TIDEExceptions } TIDEExceptions = class(TBaseExceptions) private function GetItem(const AIndex: Integer): TIDEException; procedure SetItem(const AIndex: Integer; const AValue: TIDEException); protected public function Add(const AName: String): TIDEException; function Find(const AName: String): TIDEException; public procedure LoadFromXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); procedure SaveToXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); property Items[const AIndex: Integer]: TIDEException read GetItem write SetItem; default; end; (******************************************************************************) (******************************************************************************) (** **) (** D E B U G G E R **) (** **) (******************************************************************************) (******************************************************************************) { TDebugger } TDBGEventCategory = ( ecBreakpoint, // Breakpoint hit ecProcess, ecThread, // Thread creation, destruction, start, etc. ecModule, // Library load and unload ecOutput, // DebugOutput calls ecWindow, ecDebugger); // debugger errors and warnings TDBGEventCategories = set of TDBGEventCategory; TDBGFeedbackType = (ftWarning, ftError); TDBGFeedbackResult = (frOk, frStop); TDBGFeedbackResults = set of TDBGFeedbackResult; TDBGEventNotify = procedure(Sender: TObject; const ACategory: TDBGEventCategory; const AText: String) of object; TDebuggerStateChangedEvent = procedure(ADebugger: TDebugger; AOldState: TDBGState) of object; TDebuggerBreakPointHitEvent = procedure(ADebugger: TDebugger; 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 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(Source: TPersistent); override; published end; TDebuggerPropertiesClass= class of TDebuggerProperties; TDebugger = class(TObject) private FArguments: String; FBreakPoints: TDBGBreakPoints; FDebuggerEnvironment: TStrings; FCurEnvironment: TStrings; FDisassembler: TDBGDisassembler; FEnvironment: TStrings; FExceptions: TDBGExceptions; FExitCode: Integer; FExternalDebugger: String; //FExceptions: TDBGExceptions; FFileName: String; FLocals: TDBGLocals; FLineInfo: TDBGLineInfo; FOnConsoleOutput: TDBGOutputEvent; FOnFeedback: TDBGFeedbackEvent; FRegisters: TDBGRegisters; FShowConsole: Boolean; FSignals: TDBGSignals; FState: TDBGState; FCallStack: TDBGCallStack; FWatches: TDBGWatches; FThreads: TDBGThreads; 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 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 function CreateBreakPoints: TDBGBreakPoints; virtual; function CreateLocals: TDBGLocals; virtual; function CreateLineInfo: TDBGLineInfo; virtual; function CreateRegisters: TDBGRegisters; virtual; function CreateCallStack: TDBGCallStack; virtual; function CreateDisassembler: TDBGDisassembler; virtual; function CreateWatches: TDBGWatches; virtual; function CreateThreads: TDBGThreads; virtual; function CreateSignals: TDBGSignals; virtual; function CreateExceptions: TDBGExceptions; virtual; procedure DoCurrent(const ALocation: TDBGLocationRec); procedure DoDbgOutput(const AText: String); procedure DoDbgEvent(const ACategory: TDBGEventCategory; const AText: String); procedure DoException(const AExceptionType: TDBGExceptionType; const AExceptionClass: String; const AExceptionText: String; out AContinue: Boolean); procedure DoOutput(const AText: String); procedure DoBreakpointHit(const ABreakPoint: TBaseBreakPoint; var ACanContinue: Boolean); procedure DoState(const OldState: TDBGState); virtual; function ChangeFileName: Boolean; virtual; function GetCommands: TDBGCommands; function GetSupportedCommands: TDBGCommands; virtual; function GetTargetWidth: Byte; virtual; function GetWaiting: 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 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 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 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 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; procedure LockCommandProcessing; virtual; procedure UnLockCommandProcessing; 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: TDBGCallStack 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: TDBGExceptions read 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: TDBGLocals read FLocals; // list of all localvars etc property LineInfo: TDBGLineInfo read FLineInfo; // list of all source LineInfo property Registers: TDBGRegisters 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: TDBGWatches read FWatches; // list of all watches etc property Threads: TDBGThreads read FThreads; property WorkingDir: String read FWorkingDir write FWorkingDir; // The working dir of the exe being debugged // 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 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; end; TDebuggerClass = class of TDebugger; const DBGCommandNames: array[TDBGCommand] of string = ( 'Run', 'Pause', 'Stop', 'StepOver', 'StepInto', 'StepOut', 'RunTo', 'Jumpto', 'Break', 'Watch', 'Local', 'Evaluate', 'Modify', 'Environment', 'SetStackFrame', 'Disassemble', 'StepOverInstr', 'StepIntoInstr', 'SendConsoleInput' ); DBGStateNames: array[TDBGState] of string = ( 'None', 'Idle', 'Stop', 'Pause', 'Init', 'Run', 'Error', 'Destroying' ); DBGBreakPointActionNames: array[TIDEBreakPointAction] of string = ( 'Stop', 'EnableGroup', 'DisableGroup' ); function DBGCommandNameToCommand(const s: string): TDBGCommand; function DBGStateNameToState(const s: string): TDBGState; function DBGBreakPointActionNameToAction(const s: string): TIDEBreakPointAction; function dbgs(AState: TDBGState): String; overload; function dbgs(ADisassRange: TDBGDisassemblerEntryRange): String; overload; function HasConsoleSupport: Boolean; (******************************************************************************) (******************************************************************************) (******************************************************************************) (******************************************************************************) implementation const COMMANDMAP: array[TDBGState] of TDBGCommands = ( {dsNone } [], {dsIdle } [dcEnvironment], {dsStop } [dcRun, dcStepOver, dcStepInto, dcStepOverInstr, dcStepIntoInstr, dcStepOut, dcRunTo, dcJumpto, dcBreak, dcWatch, dcEvaluate, dcEnvironment, dcSendConsoleInput], {dsPause} [dcRun, dcStop, dcStepOver, dcStepInto, dcStepOverInstr, dcStepIntoInstr, dcStepOut, dcRunTo, dcJumpto, dcBreak, dcWatch, dcLocal, dcEvaluate, dcModify, dcEnvironment, dcSetStackFrame, dcDisassemble, dcSendConsoleInput], {dsInit } [], {dsRun } [dcPause, dcStop, dcBreak, dcWatch, dcEnvironment, dcSendConsoleInput], {dsError} [dcStop], {dsDestroying} [] ); var MDebuggerPropertiesList: TStringlist; function dbgs(AState: TDBGState): String; overload; begin Result := DBGStateNames[AState]; 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; with ADisassRange do Result := Format('Range(%u)=[[ Cnt=%d, Capac=%d, First=%u, RFirst=%u, Last=%u, RLast=%u, REnd=%u, FirstOfs=%d ]]', [PtrUInt(ADisassRange), Count, Capacity, FirstAddr, RangeStartAddr, LastAddr, RangeEndAddr, LastEntryEndAddr, fo]); end; end; function HasConsoleSupport: Boolean; begin {$IFDEF DBG_ENABLE_TERMINAL} Result := True; {$ELSE} Result := False; {$ENDIF} end; function DBGCommandNameToCommand(const s: string): TDBGCommand; begin for Result:=Low(TDBGCommand) to High(TDBGCommand) do if AnsiCompareText(s,DBGCommandNames[Result])=0 then exit; Result:=dcStop; end; function DBGStateNameToState(const s: string): TDBGState; begin for Result:=Low(TDBGState) to High(TDBGState) do if AnsiCompareText(s,DBGStateNames[Result])=0 then exit; Result:=dsNone; end; function DBGBreakPointActionNameToAction(const s: string): TIDEBreakPointAction; begin for Result:=Low(TIDEBreakPointAction) to High(TIDEBreakPointAction) do if AnsiCompareText(s,DBGBreakPointActionNames[Result])=0 then exit; Result:=bpaStop; end; { TDBGThreads } procedure TDBGThreads.SetSlave(const AValue: TIDEThreads); begin if FSlave = AValue then exit; Assert((FSlave=nil) or (AValue=nil), 'TDBGThreads.Slave already set'); FSlave := AValue; end; procedure TDBGThreads.Changed; begin If Slave <> nil then Slave.InvalidateData; end; procedure TDBGThreads.Finished; begin If Slave <> nil then Slave.ValidateData; end; constructor TDBGThreads.Create(const ADebugger: TDebugger); begin FSlave := nil; FDebugger := ADebugger; end; destructor TDBGThreads.Destroy; begin inherited Destroy; if FSlave <> nil then FSlave.MasterDestroyed; end; procedure TDBGThreads.DoStateChange(const AOldState: TDBGState); begin // end; { TIDEThreads } procedure TIDEThreads.SetMaster(const AValue: TDBGThreads); begin if FMaster = AValue then exit; Assert((FMaster=nil) or (AValue=nil), 'TIDEThreads.Master already set'); if FMaster <> nil then FMaster.Slave := nil; FMaster := AValue; if FMaster <> nil then FMaster.Slave := self; InvalidateData; end; procedure TIDEThreads.MasterDestroyed; begin Master := nil; end; procedure TIDEThreads.InvalidateData; begin FDataValid := False; Changed; end; procedure TIDEThreads.ValidateData; begin FDataValid := True; Changed; end; procedure TIDEThreads.Changed; begin FNotificationList.NotifyChange(Self); end; constructor TIDEThreads.Create; begin inherited; FNotificationList := TDebuggerChangeNotificationList.Create; end; destructor TIDEThreads.Destroy; begin inherited Destroy; FNotificationList.Clear; Master := nil; FreeAndNil(FNotificationList); end; function TIDEThreads.Count: Integer; begin if (not FDataValid) and (FMaster <> nil) then FMaster.RequestMasterData; if FDataValid then Result := inherited Count else Result := 0; end; procedure TIDEThreads.AddNotification(const ANotification: TIDEThreadsNotification); begin FNotificationList.Add(ANotification); end; procedure TIDEThreads.RemoveNotification(const ANotification: TIDEThreadsNotification); begin FNotificationList.Remove(ANotification); end; procedure TIDEThreads.ChangeCurrentThread(ANewId: Integer); begin if FMaster <> nil then FMaster.ChangeCurrentThread(ANewId); end; { TDebuggerChangeNotificationList } function TDebuggerChangeNotificationList.GetItem(AIndex: Integer): TDebuggerChangeNotification; begin Result := TDebuggerChangeNotification(FList[AIndex]); end; procedure TDebuggerChangeNotificationList.NotifyChange(Sender: TObject); var i: LongInt; begin i := Count; while NextDownIndex(i) do if Assigned(Items[i]) then Items[i].OnChange(Sender); end; { TDebuggerNotificationList } function TDebuggerNotificationList.GetItem(AIndex: Integer): TDebuggerNotification; begin Result := TDebuggerNotification(FList[AIndex]); end; function TDebuggerNotificationList.NextDownIndex(var Index: integer): boolean; begin dec(Index); if (Index >= FList.Count) then Index := FList.Count-1; Result := Index >= 0; end; function TDebuggerNotificationList.Count: Integer; begin Result := FList.Count; end; procedure TDebuggerNotificationList.Clear; begin while Count > 0 do Remove(Items[0]); end; constructor TDebuggerNotificationList.Create; begin FList := TList.Create; end; destructor TDebuggerNotificationList.Destroy; begin inherited Destroy; Clear; FreeAndNil(FList); end; procedure TDebuggerNotificationList.Add(const ANotification: TDebuggerNotification); begin FList.Add(ANotification); ANotification.AddReference; end; procedure TDebuggerNotificationList.Remove(const ANotification: TDebuggerNotification); begin ANotification.ReleaseReference; FList.Remove(ANotification); end; { TDBGThreadEntry } constructor TDBGThreadEntry.Create(const AIndex: Integer; const AnAdress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const ASource: String; const AFullFileName: String; const ALine: Integer; const AThreadId: Integer; const AThreadName: String; const AThreadState: String; AState: TCallStackEntryState); begin inherited Create(AIndex, AnAdress, AnArguments, AFunctionName, ASource, AFullFileName, ALine, AState); FThreadId := AThreadId; FThreadName := AThreadName; FThreadState := AThreadState; end; constructor TDBGThreadEntry.CreateCopy(const ASource: TDBGThreadEntry); begin inherited CreateCopy(ASource); FThreadId := ASource.FThreadId; FThreadName := ASource.FThreadName; FThreadState := ASource.FThreadState; end; { TBaseThreads } function TBaseThreads.GetEntry(const AnIndex: Integer): TDBGThreadEntry; begin if (AnIndex < 0) or (AnIndex >= Count) then exit(nil); Result := TDBGThreadEntry(FList[AnIndex]); end; procedure TBaseThreads.SetCurrentThreadId(const AValue: Integer); begin if FCurrentThreadId = AValue then exit; FCurrentThreadId := AValue; end; procedure TBaseThreads.Assign(AOther: TBaseThreads); var i: Integer; begin Clear; for i := 0 to AOther.FList.Count-1 do FList.Add(TDBGThreadEntry.CreateCopy(TDBGThreadEntry(AOther.FList[i]))); end; constructor TBaseThreads.Create; begin FList := TList.Create; end; destructor TBaseThreads.Destroy; begin Clear; FreeAndNil(FList); inherited Destroy; end; function TBaseThreads.Count: Integer; begin Result := FList.Count; end; procedure TBaseThreads.Clear; begin while FList.Count > 0 do begin TDBGThreadEntry(Flist[0]).Free; FList.Delete(0); end; end; procedure TBaseThreads.Add(AThread: TDBGThreadEntry); begin FList.Add(TDBGThreadEntry.CreateCopy(AThread)); end; { TDebuggerProperties } constructor TDebuggerProperties.Create; begin // end; procedure TDebuggerProperties.Assign(Source: TPersistent); begin // end; { =========================================================================== } { TDebuggerNotification } { =========================================================================== } procedure TDebuggerNotification.AddReference; begin Inc(FRefcount); end; constructor TDebuggerNotification.Create; begin FRefCount := 0; inherited; end; destructor TDebuggerNotification.Destroy; begin Assert(FRefcount = 0, 'Destroying referenced object'); inherited; end; procedure TDebuggerNotification.ReleaseReference; begin Dec(FRefCount); if FRefCount = 0 then Free; end; (******************************************************************************) (******************************************************************************) (** **) (** D E B U G G E R **) (** **) (******************************************************************************) (******************************************************************************) { =========================================================================== } { TDebugger } { =========================================================================== } class function TDebugger.Caption: String; begin Result := 'No caption set'; end; function TDebugger.ChangeFileName: Boolean; begin Result := True; end; constructor TDebugger.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.Sorted := True; list.Duplicates := dupIgnore; list.OnChange := @DebuggerEnvironmentChanged; FDebuggerEnvironment := list; list := TStringList.Create; list.Sorted := True; list.Duplicates := dupIgnore; list.OnChange := @EnvironmentChanged; FEnvironment := list; FCurEnvironment := TStringList.Create; FBreakPoints := CreateBreakPoints; FLocals := CreateLocals; FLineInfo := CreateLineInfo; FRegisters := CreateRegisters; FCallStack := CreateCallStack; FDisassembler := CreateDisassembler; FWatches := CreateWatches; FThreads := CreateThreads; FExceptions := CreateExceptions; FSignals := CreateSignals; FExitCode := 0; end; function TDebugger.CreateBreakPoints: TDBGBreakPoints; begin Result := TDBGBreakPoints.Create(Self, TDBGBreakPoint); end; function TDebugger.CreateCallStack: TDBGCallStack; begin Result := TDBGCallStack.Create(Self); end; function TDebugger.CreateDisassembler: TDBGDisassembler; begin Result := TDBGDisassembler.Create(Self); end; function TDebugger.CreateExceptions: TDBGExceptions; begin Result := TDBGExceptions.Create(Self, TDBGException); end; function TDebugger.CreateLocals: TDBGLocals; begin Result := TDBGLocals.Create(Self); end; function TDebugger.CreateLineInfo: TDBGLineInfo; begin Result := TDBGLineInfo.Create(Self); end; class function TDebugger.CreateProperties: TDebuggerProperties; begin Result := TDebuggerProperties.Create; end; function TDebugger.CreateRegisters: TDBGRegisters; begin Result := TDBGRegisters.Create(Self); end; function TDebugger.CreateSignals: TDBGSignals; begin Result := TDBGSignals.Create(Self, TDBGSignal); end; function TDebugger.CreateWatches: TDBGWatches; begin Result := TDBGWatches.Create(Self, TDBGWatch); end; function TDebugger.CreateThreads: TDBGThreads; begin Result := nil; end; procedure TDebugger.DebuggerEnvironmentChanged (Sender: TObject ); begin end; destructor TDebugger.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.FDebugger := nil; FLocals.FDebugger := nil; FLineInfo.FDebugger := nil; FRegisters.FDebugger := nil; FCallStack.FDebugger := nil; FDisassembler.FDebugger := nil; FWatches.FDebugger := nil; FThreads.Debugger := nil; FreeAndNil(FExceptions); 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 TDebugger.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; procedure TDebugger.LockCommandProcessing; begin // nothing end; procedure TDebugger.UnLockCommandProcessing; begin // nothing end; procedure TDebugger.AddNotifyEvent(AReason: TDebuggerNotifyReason; AnEvent: TNotifyEvent); begin FDestroyNotificationList[AReason].Add(TMethod(AnEvent)); end; procedure TDebugger.RemoveNotifyEvent(AReason: TDebuggerNotifyReason; AnEvent: TNotifyEvent); begin FDestroyNotificationList[AReason].Remove(TMethod(AnEvent)); end; procedure TDebugger.Done; begin SetState(dsNone); FEnvironment.Clear; FCurEnvironment.Clear; end; procedure TDebugger.Release; begin if Self <> nil then Self.DoRelease; end; procedure TDebugger.DoCurrent(const ALocation: TDBGLocationRec); begin if Assigned(FOnCurrent) then FOnCurrent(Self, ALocation); end; procedure TDebugger.DoDbgOutput(const AText: String); begin // WriteLN(' [TDebugger] ', AText); if Assigned(FOnDbgOutput) then FOnDbgOutput(Self, AText); end; procedure TDebugger.DoDbgEvent(const ACategory: TDBGEventCategory; const AText: String); begin if Assigned(FOnDbgEvent) then FOnDbgEvent(Self, ACategory, AText); end; procedure TDebugger.DoException(const AExceptionType: TDBGExceptionType; const AExceptionClass: String; const AExceptionText: String; out AContinue: Boolean); begin if Assigned(FOnException) then FOnException(Self, AExceptionType, AExceptionClass, AExceptionText, AContinue) else AContinue := True; end; procedure TDebugger.DoOutput(const AText: String); begin if Assigned(FOnOutput) then FOnOutput(Self, AText); end; procedure TDebugger.DoBreakpointHit(const ABreakPoint: TBaseBreakPoint; var ACanContinue: Boolean); begin if Assigned(FOnBreakpointHit) then FOnBreakpointHit(Self, ABreakPoint, ACanContinue); end; procedure TDebugger.DoState(const OldState: TDBGState); begin if Assigned(FOnState) then FOnState(Self, OldState); end; procedure TDebugger.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 TDebugger.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; class function TDebugger.ExePaths: String; begin Result := ''; end; class function TDebugger.HasExePath: boolean; begin Result := true; // most debugger are external and have an exe path end; function TDebugger.GetCommands: TDBGCommands; begin Result := COMMANDMAP[State] * GetSupportedCommands; end; class function TDebugger.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 TDebugger.GetState: TDBGState; begin Result := FState; end; function TDebugger.GetSupportedCommands: TDBGCommands; begin Result := []; end; function TDebugger.GetTargetWidth: Byte; begin Result := SizeOf(PtrInt)*8; end; function TDebugger.GetWaiting: Boolean; begin Result := False; end; procedure TDebugger.Init; begin FExitCode := 0; SetState(dsIdle); end; procedure TDebugger.JumpTo(const ASource: String; const ALine: Integer); begin ReqCmd(dcJumpTo, [ASource, ALine]); end; procedure TDebugger.SendConsoleInput(AText: String); begin ReqCmd(dcSendConsoleInput, [AText]); end; function TDebugger.Modify(const AExpression, AValue: String): Boolean; begin Result := ReqCmd(dcModify, [AExpression, AValue]); end; procedure TDebugger.Pause; begin ReqCmd(dcPause, []); end; function TDebugger.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('TDebugger.ReqCmd failed: ',DBGCommandNames[ACommand]); end; end else begin DebugLn('TDebugger.ReqCmd Command not supported: ', DBGCommandNames[ACommand],' ClassName=',ClassName); Result := False; end; end; procedure TDebugger.Run; begin ReqCmd(dcRun, []); end; procedure TDebugger.RunTo(const ASource: String; const ALine: Integer); begin ReqCmd(dcRunTo, [ASource, ALine]); end; procedure TDebugger.SetDebuggerEnvironment (const AValue: TStrings ); begin FDebuggerEnvironment.Assign(AValue); end; procedure TDebugger.SetEnvironment(const AValue: TStrings); begin FEnvironment.Assign(AValue); end; procedure TDebugger.SetExitCode(const AValue: Integer); begin FExitCode := AValue; end; procedure TDebugger.SetFileName(const AValue: String); begin if FFileName <> AValue then begin DebugLn('[TDebugger.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 := ''; SetState(dsIdle); ChangeFileName; end; FFileName := AValue; if (FFilename <> '') and (FState = dsIdle) and ChangeFileName then SetState(dsStop); end; end; class procedure TDebugger.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; procedure TDebugger.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 OldState := FState; FState := AValue; FThreads.DoStateChange(OldState); FBreakpoints.DoStateChange(OldState); FLocals.DoStateChange(OldState); FLineInfo.DoStateChange(OldState); FRegisters.DoStateChange(OldState); FCallStack.DoStateChange(OldState); FDisassembler.DoStateChange(OldState); FWatches.DoStateChange(OldState); DoState(OldState); end; end; procedure TDebugger.DoRelease; begin Self.Free; end; procedure TDebugger.StepInto; begin if ReqCmd(dcStepInto, []) then exit; DebugLn('TDebugger.StepInto Class=',ClassName,' failed.'); end; procedure TDebugger.StepOverInstr; begin if ReqCmd(dcStepOverInstr, []) then exit; DebugLn('TDebugger.StepOverInstr Class=',ClassName,' failed.'); end; procedure TDebugger.StepIntoInstr; begin if ReqCmd(dcStepIntoInstr, []) then exit; DebugLn('TDebugger.StepIntoInstr Class=',ClassName,' failed.'); end; procedure TDebugger.StepOut; begin if ReqCmd(dcStepOut, []) then exit; DebugLn('TDebugger.StepOut Class=', ClassName, ' failed.'); end; procedure TDebugger.StepOver; begin if ReqCmd(dcStepOver, []) then exit; DebugLn('TDebugger.StepOver Class=',ClassName,' failed.'); end; procedure TDebugger.Stop; begin if ReqCmd(dcStop,[]) then exit; DebugLn('TDebugger.Stop Class=',ClassName,' failed.'); end; (******************************************************************************) (******************************************************************************) (** **) (** B R E A K P O I N T S **) (** **) (******************************************************************************) (******************************************************************************) { =========================================================================== TBaseBreakPoint =========================================================================== } 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 AssignLocationTo(DestBreakPoint); DestBreakPoint.SetBreakHitCount(FBreakHitCount); DestBreakPoint.SetExpression(FExpression); DestBreakPoint.SetEnabled(FEnabled); DestBreakPoint.InitialEnabled := FInitialEnabled; end else inherited; end; constructor TBaseBreakPoint.Create(ACollection: TCollection); begin FSource := ''; FLine := -1; FValid := vsUnknown; FEnabled := False; FHitCount := 0; FBreakHitCount := 0; FExpression := ''; FInitialEnabled := False; inherited Create(ACollection); 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.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.SetValid(const AValue: TValidState ); begin if FValid <> AValue then begin FValid := AValue; Changed; end; end; { =========================================================================== } { TIDEBreakPoint } { =========================================================================== } procedure TIDEBreakPoint.AddDisableGroup(const AGroup: TIDEBreakPointGroup); begin if AGroup = nil then Exit; FDisableGroupList.Add(AGroup); AGroup.AddReference(Self); Changed; end; procedure TIDEBreakPoint.AddEnableGroup(const AGroup: TIDEBreakPointGroup); begin if AGroup = nil then Exit; FEnableGroupList.Add(AGroup); AGroup.AddReference(Self); Changed; end; function TIDEBreakPoint.GetAutoContinueTime: Cardinal; begin Result := FAutoContinueTime; end; procedure TIDEBreakPoint.SetAutoContinueTime(const AValue: Cardinal); begin if FAutoContinueTime = AValue then Exit; FAutoContinueTime := AValue; Changed; end; procedure TIDEBreakPoint.AssignTo(Dest: TPersistent); begin inherited; if Dest is TIDEBreakPoint then begin TIDEBreakPoint(Dest).Actions := FActions; TIDEBreakPoint(Dest).AutoContinueTime := FAutoContinueTime; end; end; procedure TIDEBreakPoint.ClearAllGroupLists; begin ClearGroupList(FDisableGroupList); ClearGroupList(FEnableGroupList); end; procedure TIDEBreakPoint.ClearGroupList(const AGroupList: TList); var i: Integer; AGroup: TIDEBreakPointGroup; begin for i:=0 to AGroupList.Count-1 do begin AGroup:=TIDEBreakPointGroup(AGroupList[i]); AGroup.RemoveReference(Self); end; AGroupList.Clear; end; constructor TIDEBreakPoint.Create(ACollection: TCollection); begin inherited Create(ACollection); FGroup := nil; FActions := [bpaStop]; FDisableGroupList := TList.Create; FEnableGroupList := TList.Create; end; destructor TIDEBreakPoint.Destroy; begin if (TIDEBreakPoints(Collection) <> nil) then TIDEBreakPoints(Collection).NotifyRemove(Self); if FGroup <> nil then FGroup.Remove(Self); ClearAllGroupLists; inherited; FreeAndNil(FDisableGroupList); FreeAndNil(FEnableGroupList); end; procedure TIDEBreakPoint.DisableGroups; var n: Integer; begin for n := 0 to FDisableGroupList.Count - 1 do TIDEBreakPointGroup(FDisableGroupList[n]).Enabled := False; end; procedure TIDEBreakPoint.DoActionChange; begin Changed; end; procedure TIDEBreakPoint.DoHit (const ACount: Integer; var AContinue: Boolean ); begin inherited DoHit(ACount, AContinue); if bpaEnableGroup in Actions then EnableGroups; if bpaDisableGroup in Actions then DisableGroups; end; procedure TIDEBreakPoint.EnableGroups; var n: Integer; begin for n := 0 to FDisableGroupList.Count - 1 do TIDEBreakPointGroup(FDisableGroupList[n]).Enabled := True; end; function TIDEBreakPoint.GetActions: TIDEBreakPointActions; begin Result := FActions; end; function TIDEBreakPoint.GetGroup: TIDEBreakPointGroup; begin Result := FGroup; end; procedure TIDEBreakPoint.LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string; const OnLoadFilename: TOnLoadFilenameFromConfig; const OnGetGroup: TOnGetGroupByName); procedure LoadGroupList(GroupList: TList; const ListPath: string); var i: Integer; CurGroup: TIDEBreakPointGroup; NewCount: Integer; GroupName: String; begin ClearGroupList(GroupList); NewCount:=XMLConfig.GetValue(ListPath+'Count',0); for i:=0 to NewCount-1 do begin GroupName:=XMLConfig.GetValue(ListPath+'Group'+IntToStr(i+1)+'/Name',''); if GroupName='' then continue; CurGroup:=OnGetGroup(GroupName); if CurGroup=nil then continue; if GroupList=FDisableGroupList then AddDisableGroup(CurGroup) else if GroupList=FEnableGroupList then AddEnableGroup(CurGroup); end; end; var Filename: String; GroupName: String; NewActions: TIDEBreakPointActions; CurAction: TIDEBreakPointAction; begin FLoading:=true; try GroupName:=XMLConfig.GetValue(Path+'Group/Name',''); Group:=OnGetGroup(GroupName); Expression:=XMLConfig.GetValue(Path+'Expression/Value',''); AutoContinueTime:=XMLConfig.GetValue(Path+'AutoContinueTime/Value',0); BreakHitCount := XMLConfig.GetValue(Path+'BreakHitCount/Value',0); Filename:=XMLConfig.GetValue(Path+'Source/Value',''); if Assigned(OnLoadFilename) then OnLoadFilename(Filename); FSource:=Filename; InitialEnabled:=XMLConfig.GetValue(Path+'InitialEnabled/Value',true); Enabled:=FInitialEnabled; FLine:=XMLConfig.GetValue(Path+'Line/Value',-1); NewActions:=[]; for CurAction:=Low(TIDEBreakPointAction) to High(TIDEBreakPointAction) do if XMLConfig.GetValue( Path+'Actions/'+DBGBreakPointActionNames[CurAction], CurAction in [bpaStop]) then Include(NewActions,CurAction); Actions:=NewActions; LoadGroupList(FDisableGroupList,Path+'DisableGroups/'); LoadGroupList(FEnableGroupList,Path+'EnableGroups/'); finally FLoading:=false; end; end; procedure TIDEBreakPoint.RemoveDisableGroup(const AGroup: TIDEBreakPointGroup); begin RemoveFromGroupList(AGroup,FDisableGroupList); end; procedure TIDEBreakPoint.RemoveEnableGroup(const AGroup: TIDEBreakPointGroup); begin RemoveFromGroupList(AGroup,FEnableGroupList); end; procedure TIDEBreakPoint.RemoveFromGroupList(const AGroup: TIDEBreakPointGroup; const AGroupList: TList); begin if (AGroup = nil) then Exit; AGroupList.Remove(AGroup); AGroup.RemoveReference(Self); end; procedure TIDEBreakPoint.SaveToXMLConfig(const AConfig: TXMLConfig; const APath: string; const OnSaveFilename: TOnSaveFilenameToConfig); procedure SaveGroupList(const AList: TList; const AListPath: string); var i: Integer; CurGroup: TIDEBreakPointGroup; begin AConfig.SetDeleteValue(AListPath + 'Count', AList.Count,0); for i := 0 to AList.Count - 1 do begin CurGroup := TIDEBreakPointGroup(AList[i]); AConfig.SetDeleteValue(Format('$%sGroup%d/Name', [AListPath, i+1]), CurGroup.Name, ''); end; end; var Filename: String; CurAction: TIDEBreakPointAction; begin if Group <> nil then AConfig.SetDeleteValue(APath+'Group/Name',Group.Name,''); AConfig.SetDeleteValue(APath+'Expression/Value',Expression,''); AConfig.SetDeleteValue(APath+'AutoContinueTime/Value',AutoContinueTime,0); AConfig.SetDeleteValue(APath+'BreakHitCount/Value',BreakHitCount,0); Filename := Source; if Assigned(OnSaveFilename) then OnSaveFilename(Filename); AConfig.SetDeleteValue(APath+'Source/Value',Filename,''); AConfig.SetDeleteValue(APath+'InitialEnabled/Value',InitialEnabled,true); AConfig.SetDeleteValue(APath+'Line/Value',Line,-1); for CurAction := Low(TIDEBreakPointAction) to High(TIDEBreakPointAction) do begin AConfig.SetDeleteValue( APath+'Actions/'+DBGBreakPointActionNames[CurAction], CurAction in Actions, CurAction in [bpaStop]); end; SaveGroupList(FDisableGroupList, APath + 'DisableGroups/'); SaveGroupList(FEnableGroupList, APath + 'EnableGroups/'); end; procedure TIDEBreakPoint.SetActions(const AValue: TIDEBreakPointActions); begin if FActions <> AValue then begin FActions := AValue; DoActionChange; end; end; procedure TIDEBreakPoint.SetGroup(const AValue: TIDEBreakPointGroup); var Grp: TIDEBreakPointGroup; begin if FGroup <> AValue then begin if FGroup <> nil then begin Grp := FGroup; FGroup := nil; // avoid second entrance Grp.Remove(Self); end; FGroup := AValue; if FGroup <> nil then begin FGroup.Add(Self); end; Changed; end; end; (* procedure TIDEBreakPoint.CopyGroupList(SrcGroupList, DestGroupList: TList; DestGroups: TIDEBreakPointGroups); var i: Integer; CurGroup: TIDEBreakPointGroup; NewGroup: TIDEBreakPointGroup; begin ClearGroupList(DestGroupList); for i:=0 to SrcGroupList.Count-1 do begin CurGroup:=TIDEBreakPointGroup(SrcGroupList[i]); NewGroup:=DestGroups.GetGroupByName(CurGroup.Name); DestGroupList.Add(NewGroup); end; end; procedure TIDEBreakPoint.CopyAllGroupLists(SrcBreakPoint: TIDEBreakPoint; DestGroups: TIDEBreakPointGroups); begin CopyGroupList(SrcBreakPoint.FEnableGroupList,FEnableGroupList,DestGroups); CopyGroupList(SrcBreakPoint.FDisableGroupList,FDisableGroupList,DestGroups); 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); 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; function TDBGBreakPoint.GetDebugger: TDebugger; 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; { =========================================================================== } { TIDEBreakPoints } { =========================================================================== } function TIDEBreakPoints.Add(const ASource: String; const ALine: Integer): TIDEBreakPoint; begin Result := TIDEBreakPoint(inherited Add(ASource, ALine)); NotifyAdd(Result); end; procedure TIDEBreakPoints.AddNotification( const ANotification: TIDEBreakPointsNotification); begin FNotificationList.Add(ANotification); ANotification.AddReference; end; constructor TIDEBreakPoints.Create(const ABreakPointClass: TIDEBreakPointClass); begin FNotificationList := TList.Create; inherited Create(ABreakPointClass); end; destructor TIDEBreakPoints.Destroy; var n: Integer; begin for n := FNotificationList.Count - 1 downto 0 do TDebuggerNotification(FNotificationList[n]).ReleaseReference; inherited; FreeAndNil(FNotificationList); end; function TIDEBreakPoints.Find(const ASource: String; const ALine: Integer): TIDEBreakPoint; begin Result := TIDEBreakPoint(inherited Find(ASource, ALine, nil)); end; function TIDEBreakPoints.Find(const ASource: String; const ALine: Integer; const AIgnore: TIDEBreakPoint): TIDEBreakPoint; begin Result := TIDEBreakPoint(inherited Find(ASource, ALine, AIgnore)); end; function TIDEBreakPoints.GetItem(const AnIndex: Integer): TIDEBreakPoint; begin Result := TIDEBreakPoint(inherited GetItem(AnIndex)); end; procedure TIDEBreakPoints.NotifyAdd(const ABreakPoint: TIDEBreakPoint); var n: Integer; Notification: TIDEBreakPointsNotification; begin for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDEBreakPointsNotification(FNotificationList[n]); if Assigned(Notification.FOnAdd) then Notification.FOnAdd(Self, ABreakPoint); end; end; procedure TIDEBreakPoints.NotifyRemove(const ABreakpoint: TIDEBreakPoint); var n: Integer; Notification: TIDEBreakPointsNotification; begin for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDEBreakPointsNotification(FNotificationList[n]); if Assigned(Notification.FOnRemove) then Notification.FOnRemove(Self, ABreakpoint); end; end; procedure TIDEBreakPoints.RemoveNotification( const ANotification: TIDEBreakPointsNotification); begin FNotificationList.Remove(ANotification); ANotification.ReleaseReference; end; procedure TIDEBreakPoints.LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string; const OnLoadFilename: TOnLoadFilenameFromConfig; const OnGetGroup: TOnGetGroupByName); var NewCount: Integer; i: Integer; LoadBreakPoint: TIDEBreakPoint; BreakPoint: TIDEBreakPoint; begin Clear; NewCount:=XMLConfig.GetValue(Path+'Count',0); for i:=0 to NewCount-1 do begin LoadBreakPoint := TIDEBreakPoint.Create(nil); LoadBreakPoint.LoadFromXMLConfig(XMLConfig, Path+'Item'+IntToStr(i+1)+'/',OnLoadFilename,OnGetGroup); BreakPoint := Find(LoadBreakPoint.Source, LoadBreakPoint.Line, LoadBreakPoint); if BreakPoint = nil then BreakPoint := Add(LoadBreakPoint.Source, LoadBreakPoint.Line); BreakPoint.Assign(LoadBreakPoint); FreeAndNil(LoadBreakPoint) end; end; procedure TIDEBreakPoints.SaveToXMLConfig(XMLConfig: TXMLConfig; const Path: string; const OnSaveFilename: TOnSaveFilenameToConfig); var Cnt: Integer; i: Integer; CurBreakPoint: TIDEBreakPoint; begin Cnt:=Count; XMLConfig.SetDeleteValue(Path+'Count',Cnt,0); for i:=0 to Cnt-1 do begin CurBreakPoint:=Items[i]; CurBreakPoint.SaveToXMLConfig(XMLConfig, Path+'Item'+IntToStr(i+1)+'/',OnSaveFilename); end; end; procedure TIDEBreakPoints.SetItem(const AnIndex: Integer; const AValue: TIDEBreakPoint); begin inherited SetItem(AnIndex, AValue); end; procedure TIDEBreakPoints.Update(Item: TCollectionItem); var n: Integer; Notification: TIDEBreakPointsNotification; begin // Note: Item will be nil in case all items need to be updated for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDEBreakPointsNotification(FNotificationList[n]); if Assigned(Notification.FOnUpdate) then Notification.FOnUpdate(Self, TIDEBreakPoint(Item)); end; end; { =========================================================================== } { TDBGBreakPoints } { =========================================================================== } function TDBGBreakPoints.Add (const ASource: String; const ALine: Integer ): TDBGBreakPoint; begin Result := TDBGBreakPoint(inherited Add(ASource, ALine)); end; constructor TDBGBreakPoints.Create (const ADebugger: TDebugger; 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.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; { =========================================================================== } { TBaseBreakPoints } { =========================================================================== } function TBaseBreakPoints.Add(const ASource: String; const ALine: Integer): TBaseBreakPoint; begin Result := TBaseBreakPoint(inherited Add); Result.SetLocation(ASource, ALine); end; constructor TBaseBreakPoints.Create(const ABreakPointClass: TBaseBreakPointClass); begin inherited Create(ABreakPointClass); 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.Line = ALine) and (AIgnore <> Result) and (CompareFilenames(Result.Source, ASource) = 0) then Exit; end; Result := nil; end; { =========================================================================== } { TIDEBreakPointGroup } { =========================================================================== } function TIDEBreakPointGroup.Add(const ABreakPoint: TIDEBreakPoint): Integer; begin Result := FBreakpoints.IndexOf(ABreakPoint); //avoid dups if Result = -1 then begin Result := FBreakpoints.Add(ABreakPoint); ABreakpoint.Group := Self; end; end; procedure TIDEBreakPointGroup.AddReference(const ABreakPoint: TIDEBreakPoint); begin FReferences.Add(ABreakPoint); end; function TIDEBreakPointGroup.Count: Integer; begin Result := FBreakpoints.Count; end; constructor TIDEBreakPointGroup.Create(ACollection: TCollection); begin inherited Create(ACollection); FBreakpoints := TList.Create; FReferences := TList.Create; FEnabled := True; end; procedure TIDEBreakPointGroup.Delete(const AIndex: Integer); begin Remove(TIDEBreakPoint(FBreakPoints[AIndex])); end; destructor TIDEBreakPointGroup.Destroy; var n: Integer; begin for n := FBreakpoints.Count - 1 downto 0 do TIDEBreakPoint(FBreakpoints[n]).Group := nil; for n := FReferences.Count - 1 downto 0 do TIDEBreakPoint(FReferences[n]).RemoveDisableGroup(Self); for n := FReferences.Count - 1 downto 0 do TIDEBreakPoint(FReferences[n]).RemoveEnableGroup(Self); inherited Destroy; FreeAndNil(FBreakpoints); FreeAndNil(FReferences); end; function TIDEBreakPointGroup.GetBreakpoint(const AIndex: Integer): TIDEBreakPoint; begin Result := TIDEBreakPoint(FBreakPoints[AIndex]); end; function TIDEBreakPointGroup.Remove(const ABreakPoint: TIDEBreakPoint): Integer; begin Result := FBreakpoints.Remove(ABreakPoint); if ABreakpoint.Group = Self then ABreakpoint.Group := nil; end; procedure TIDEBreakPointGroup.LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string); begin Name:=XMLConfig.GetValue(Path+'Name/Value',''); // the breakpoints of this group are not loaded here. // They are loaded by the TIDEBreakPoints object. InitialEnabled:=XMLConfig.GetValue(Path+'InitialEnabled/Value',true); FEnabled:=InitialEnabled; end; procedure TIDEBreakPointGroup.SaveToXMLConfig(XMLConfig: TXMLConfig; const Path: string); begin XMLConfig.SetDeleteValue(Path+'Name/Value',Name,''); // the breakpoints of this group are not saved here. // They are saved by the TIDEBreakPoints object. XMLConfig.SetDeleteValue(Path+'InitialEnabled/Value',InitialEnabled,true); end; procedure TIDEBreakPointGroup.RemoveReference(const ABreakPoint: TIDEBreakPoint); begin FReferences.Remove(ABreakPoint); end; procedure TIDEBreakPointGroup.SetEnabled(const AValue: Boolean); var n: Integer; begin if FEnabled <> AValue then begin FEnabled := AValue; for n := 0 to FBreakPoints.Count - 1 do TIDEBreakPoint(FBreakPoints[n]).Enabled := FEnabled; end; end; procedure TIDEBreakPointGroup.SetInitialEnabled(const AValue: Boolean); begin if FInitialEnabled=AValue then exit; FInitialEnabled:=AValue; end; procedure TIDEBreakPointGroup.SetName(const AValue: String); begin FName := AValue; end; procedure TIDEBreakPointGroup.AssignTo(Dest: TPersistent); var DestGroup: TIDEBreakPointGroup; begin if Dest is TIDEBreakPointGroup then begin DestGroup:=TIDEBreakPointGroup(Dest); DestGroup.Name:=Name; DestGroup.InitialEnabled:=InitialEnabled; DestGroup.Enabled:=Enabled; end else inherited AssignTo(Dest); end; { =========================================================================== } { TIDEBreakPointGroups } { =========================================================================== } constructor TIDEBreakPointGroups.Create; begin inherited Create(TIDEBreakPointGroup); end; procedure TIDEBreakPointGroups.LoadFromXMLConfig(XMLConfig: TXMLConfig; const Path: string); var NewCount: integer; NewGroup: TIDEBreakPointGroup; i: Integer; OldGroup: TIDEBreakPointGroup; begin Clear; NewCount:=XMLConfig.GetValue(Path+'Count',0); for i:=0 to NewCount-1 do begin NewGroup:=TIDEBreakPointGroup(inherited Add); NewGroup.LoadFromXMLConfig(XMLConfig, Path+'Item'+IntToStr(i+1)+'/'); OldGroup:=FindGroupByName(NewGroup.Name,NewGroup); if OldGroup<>nil then NewGroup.Free; end; end; procedure TIDEBreakPointGroups.SaveToXMLConfig(XMLConfig: TXMLConfig; const Path: string); var Cnt: Integer; CurGroup: TIDEBreakPointGroup; i: Integer; begin Cnt:=Count; XMLConfig.SetDeleteValue(Path+'Count',Cnt,0); for i:=0 to Cnt-1 do begin CurGroup:=Items[i]; CurGroup.SaveToXMLConfig(XMLConfig, Path+'Item'+IntToStr(i+1)+'/'); end; end; function TIDEBreakPointGroups.GetGroupByName(const GroupName: string ): TIDEBreakPointGroup; begin Result:=FindGroupByName(GroupName,nil); end; function TIDEBreakPointGroups.FindGroupByName(const GroupName: string; Ignore: TIDEBreakPointGroup): TIDEBreakPointGroup; var i: Integer; begin i:=Count-1; while i>=0 do begin Result:=Items[i]; if (AnsiCompareText(Result.Name,GroupName)=0) and (Ignore<>Result) then exit; dec(i); end; Result:=nil; end; function TIDEBreakPointGroups.IndexOfGroupWithName(const GroupName: string; Ignore : TIDEBreakPointGroup): integer; begin Result:=Count-1; while (Result>=0) and ((AnsiCompareText(Items[Result].Name,GroupName)<>0) or (Items[Result]=Ignore)) do dec(Result); end; procedure TIDEBreakPointGroups.InitTargetStart; var i: Integer; begin for i:=0 to Count-1 do Items[i].Enabled:=Items[i].InitialEnabled; end; function TIDEBreakPointGroups.GetItem(const AnIndex: Integer ): TIDEBreakPointGroup; begin Result := TIDEBreakPointGroup(inherited GetItem(AnIndex)); end; procedure TIDEBreakPointGroups.SetItem(const AnIndex: Integer; const AValue: TIDEBreakPointGroup); begin inherited SetItem(AnIndex, AValue); end; (******************************************************************************) (******************************************************************************) (** **) (** D E B U G I N F O R M A T I O N **) (** **) (******************************************************************************) (******************************************************************************) { 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; { TDBGPType } 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; { 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; (******************************************************************************) (******************************************************************************) (** **) (** W A T C H E S **) (** **) (******************************************************************************) (******************************************************************************) { =========================================================================== } { TBaseWatch } { =========================================================================== } procedure TBaseWatch.AssignTo(Dest: TPersistent); begin if Dest is TBaseWatch then begin TBaseWatch(Dest).SetExpression(FExpression); TBaseWatch(Dest).SetEnabled(FEnabled); TBaseWatch(Dest).SetDisplayFormat(FDisplayFormat); end else inherited; end; constructor TBaseWatch.Create(ACollection: TCollection); begin FEnabled := False; FValid := vsUnknown; inherited Create(ACollection); end; procedure TBaseWatch.DoEnableChange; begin Changed; end; procedure TBaseWatch.DoExpressionChange; begin Changed; end; procedure TBaseWatch.DoDisplayFormatChanged; begin Changed; end; function TBaseWatch.GetEnabled: Boolean; begin Result := FEnabled; end; function TBaseWatch.GetDisplayFormat: TWatchDisplayFormat; begin Result := FDisplayFormat; end; procedure TBaseWatch.SetDisplayFormat(const AValue: TWatchDisplayFormat); begin if AValue = FDisplayFormat then exit; FDisplayFormat := AValue; DoDisplayFormatChanged; end; function TBaseWatch.GetExpression: String; begin Result := FExpression; end; function TBaseWatch.GetValid: TValidState; begin Result := FValid; end; function TBaseWatch.GetValue: String; begin if not Enabled then Result := '' else begin case Valid of vsValid: Result := ''; vsInvalid: Result := ''; else {vsUnknown:}Result := ''; end; end; end; function TBaseWatch.GetTypeInfo: TDBGType; begin Result:=nil; end; procedure TBaseWatch.SetEnabled(const AValue: Boolean); begin if FEnabled <> AValue then begin FEnabled := AValue; DoEnableChange; end; end; procedure TBaseWatch.SetExpression(const AValue: String); begin if AValue <> FExpression then begin FExpression := AValue; DoExpressionChange; end; end; procedure TBaseWatch.SetValid(const AValue: TValidState); begin if FValid <> AValue then begin FValid := AValue; Changed; end; end; { =========================================================================== } { TIDEWatch } { =========================================================================== } constructor TIDEWatch.Create(ACollection: TCollection); begin inherited Create(ACollection); end; destructor TIDEWatch.Destroy; begin if (TIDEWatches(Collection) <> nil) then TIDEWatches(Collection).NotifyRemove(Self); inherited Destroy; end; procedure TIDEWatch.LoadFromXMLConfig(const AConfig: TXMLConfig; const APath: string); var i: Integer; begin Expression := AConfig.GetValue(APath + 'Expression/Value', ''); Enabled := AConfig.GetValue(APath + 'Enabled/Value', true); i := StringCase (AConfig.GetValue(APath + 'DisplayStyle/Value', TWatchDisplayFormatNames[wdfDefault]), TWatchDisplayFormatNames); if i >= 0 then DisplayFormat := TWatchDisplayFormat(i) else DisplayFormat := wdfDefault; end; procedure TIDEWatch.SaveToXMLConfig(const AConfig: TXMLConfig; const APath: string); begin AConfig.SetDeleteValue(APath + 'Expression/Value', Expression, ''); AConfig.SetDeleteValue(APath + 'Enabled/Value', Enabled, true); AConfig.SetDeleteValue(APath + 'DisplayStyle/Value', TWatchDisplayFormatNames[DisplayFormat], TWatchDisplayFormatNames[wdfDefault]); end; { =========================================================================== } { TDBGWatch } { =========================================================================== } constructor TDBGWatch.Create(ACollection: TCollection); begin FSlave := nil; inherited Create(ACollection); end; destructor TDBGWatch.Destroy; var SW: TBaseWatch; begin SW := FSlave; FSlave := nil; if SW <> nil then SW.DoChanged; // in case UpDateCount was 0 inherited Destroy; end; procedure TDBGWatch.DoChanged; begin inherited DoChanged; if FSlave <> nil then FSlave.Changed; end; procedure TDBGWatch.DoChange; begin end; procedure TDBGWatch.DoStateChange(const AOldState: TDBGState); begin end; function TDBGWatch.GetDebugger: TDebugger; begin Result := TDBGWatches(Collection).FDebugger; end; procedure TDBGWatch.SetSlave(const ASlave : TBaseWatch); begin Assert((FSlave = nil) or (ASlave = nil), 'TDBGWatch.SetSlave already has a slave'); FSlave := ASlave; end; { =========================================================================== } { TBaseWatches } { =========================================================================== } function TBaseWatches.Add(const AExpression: String): TBaseWatch; begin Result := TBaseWatch(inherited Add); Result.Expression := AExpression; end; constructor TBaseWatches.Create(const AWatchClass: TBaseWatchClass); begin inherited Create(AWatchClass); end; function TBaseWatches.Find(const AExpression: String): TBaseWatch; var n: Integer; S: String; begin S := UpperCase(AExpression); for n := 0 to Count - 1 do begin Result := TBaseWatch(GetItem(n)); if UpperCase(Result.Expression) = S then Exit; end; Result := nil; end; { =========================================================================== } { TIDEWatches } { =========================================================================== } function TIDEWatches.Add(const AExpression: String): TIDEWatch; begin // if this is modified, then also update LoadFromXMLConfig Result := TIDEWatch(inherited Add(AExpression)); NotifyAdd(Result); end; procedure TIDEWatches.AddNotification(const ANotification: TIDEWatchesNotification); begin FNotificationList.Add(ANotification); ANotification.AddReference; end; constructor TIDEWatches.Create(const AWatchClass: TIDEWatchClass); begin FNotificationList := TList.Create; inherited Create(AWatchClass); end; destructor TIDEWatches.Destroy; var n: Integer; begin for n := FNotificationList.Count - 1 downto 0 do TDebuggerNotification(FNotificationList[n]).ReleaseReference; inherited; FreeAndNil(FNotificationList); end; function TIDEWatches.Find(const AExpression: String): TIDEWatch; begin Result := TIDEWatch(inherited Find(AExpression)); end; function TIDEWatches.GetItem(const AnIndex: Integer): TIDEWatch; begin Result := TIDEWatch(inherited GetItem(AnIndex)); end; procedure TIDEWatches.LoadFromXMLConfig(const AConfig: TXMLConfig; const APath: string); var NewCount: Integer; i: Integer; Watch: TIDEWatch; begin Clear; NewCount := AConfig.GetValue(APath + 'Count', 0); for i := 0 to NewCount-1 do begin // Call inherited Add, so NotifyAdd can be send, after the Watch was loaded Watch := TIDEWatch(inherited Add('')); Watch.LoadFromXMLConfig(AConfig, Format('%sItem%d/', [APath, i + 1])); NotifyAdd(Watch); end; end; procedure TIDEWatches.NotifyAdd(const AWatch: TIDEWatch); var n: Integer; Notification: TIDEWatchesNotification; begin for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDEWatchesNotification(FNotificationList[n]); if Assigned(Notification.FOnAdd) then Notification.FOnAdd(Self, AWatch); end; end; procedure TIDEWatches.NotifyRemove(const AWatch: TIDEWatch); var n: Integer; Notification: TIDEWatchesNotification; begin for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDEWatchesNotification(FNotificationList[n]); if Assigned(Notification.FOnRemove) then Notification.FOnRemove(Self, AWatch); end; end; procedure TIDEWatches.RemoveNotification(const ANotification: TIDEWatchesNotification); begin FNotificationList.Remove(ANotification); ANotification.ReleaseReference; end; procedure TIDEWatches.SaveToXMLConfig(const AConfig: TXMLConfig; const APath: string); var Cnt: Integer; i: Integer; Watch: TIDEWatch; begin Cnt := Count; AConfig.SetDeleteValue(APath + 'Count', Cnt, 0); for i := 0 to Cnt - 1 do begin Watch := Items[i]; Watch.SaveToXMLConfig(AConfig, Format('%sItem%d/', [APath, i + 1])); end; end; procedure TIDEWatches.SetItem(const AnIndex: Integer; const AValue: TIDEWatch); begin inherited SetItem(AnIndex, AValue); end; procedure TIDEWatches.Update(Item: TCollectionItem); var n, m, c: Integer; Notification: TIDEWatchesNotification; begin // Note: Item will be nil in case all items need to be updated for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDEWatchesNotification(FNotificationList[n]); if not Assigned(Notification.FOnUpdate) then Continue; if Item = nil then begin m := 0; c := Count; while m < c do begin; Notification.FOnUpdate(Self, Items[m]); if c <> Count then begin m := Max(0, m - Max(0, Count - c)); c := Count; end; inc(m); end; end else begin Notification.FOnUpdate(Self, TIDEWatch(Item)); end; end; end; { =========================================================================== } { TDBGWatches } { =========================================================================== } function TDBGWatches.Add(const AExpression: String): TDBGWatch; begin Result := TDBGWatch(inherited Add(AExpression)); end; constructor TDBGWatches.Create(const ADebugger: TDebugger; const AWatchClass: TDBGWatchClass); begin FDebugger := ADebugger; inherited Create(AWatchClass); end; procedure TDBGWatches.DoStateChange(const AOldState: TDBGState); var n: Integer; begin for n := 0 to Count - 1 do GetItem(n).DoStateChange(AOldState); end; function TDBGWatches.Find(const AExpression: String): TDBGWatch; begin Result := TDBGWatch(inherited Find(AExpression)); end; function TDBGWatches.GetItem(const AnIndex: Integer): TDBGWatch; begin Result := TDBGWatch(inherited GetItem(AnIndex)); end; procedure TDBGWatches.SetItem(const AnIndex: Integer; const AValue: TDBGWatch); begin inherited SetItem(AnIndex, AValue); end; procedure TDBGWatches.Update(Item: TCollectionItem); begin inherited Update(Item); // notyfy only if collection is changed if (Item = nil) and Assigned(FOnChange) then FOnChange(Self); end; (******************************************************************************) (******************************************************************************) (** **) (** L O C A L S **) (** **) (******************************************************************************) (******************************************************************************) { =========================================================================== } { TBaseLocals } { =========================================================================== } function TBaseLocals.Count: Integer; begin Result := 0; end; constructor TBaseLocals.Create; begin inherited Create; end; function TBaseLocals.GetName(const AnIndex: Integer): String; begin Result := ''; end; function TBaseLocals.GetValue(const AnIndex: Integer): String; begin Result := ''; end; { =========================================================================== } { TIDELocals } { =========================================================================== } procedure TIDELocals.AddNotification(const ANotification: TIDELocalsNotification); begin FNotificationList.Add(ANotification); ANotification.AddReference; end; constructor TIDELocals.Create; begin FNotificationList := TList.Create; inherited Create; end; destructor TIDELocals.Destroy; var n: Integer; begin for n := FNotificationList.Count - 1 downto 0 do TDebuggerNotification(FNotificationList[n]).ReleaseReference; inherited; FreeAndNil(FNotificationList); end; procedure TIDELocals.NotifyChange; var n: Integer; Notification: TIDELocalsNotification; begin for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDELocalsNotification(FNotificationList[n]); if Assigned(Notification.FOnChange) then Notification.FOnChange(Self); end; end; procedure TIDELocals.RemoveNotification(const ANotification: TIDELocalsNotification); begin FNotificationList.Remove(ANotification); ANotification.ReleaseReference; end; { =========================================================================== } { TDBGLocals } { =========================================================================== } function TDBGLocals.Count: Integer; begin if (FDebugger <> nil) and (FDebugger.State = dsPause) then Result := GetCount else Result := 0; end; constructor TDBGLocals.Create(const ADebugger: TDebugger); begin inherited Create; FDebugger := ADebugger; end; procedure TDBGLocals.DoChange; begin if Assigned(FOnChange) then FOnChange(Self); end; procedure TDBGLocals.DoStateChange(const AOldState: TDBGState); begin end; procedure TDBGLocals.Changed; begin DoChange; end; function TDBGLocals.GetCount: Integer; begin Result := 0; end; (******************************************************************************) (******************************************************************************) (** **) (** R E G I S T E R S **) (** **) (******************************************************************************) (******************************************************************************) { =========================================================================== } { TBaseRegisters } { =========================================================================== } function TBaseRegisters.Count: Integer; begin Result := 0; end; procedure TBaseRegisters.BeginUpdate; begin inc(FUpdateCount); if FUpdateCount = 1 then ChangeUpdating; end; procedure TBaseRegisters.EndUpdate; begin dec(FUpdateCount); if FUpdateCount = 0 then ChangeUpdating; end; constructor TBaseRegisters.Create; begin inherited Create; end; function TBaseRegisters.GetFormat(const AnIndex: Integer): TRegisterDisplayFormat; begin Result := rdDefault; end; procedure TBaseRegisters.SetFormat(const AnIndex: Integer; const AValue: TRegisterDisplayFormat); begin // end; procedure TBaseRegisters.ChangeUpdating; begin // end; function TBaseRegisters.Updating: Boolean; begin Result := FUpdateCount <> 0; end; function TBaseRegisters.GetModified(const AnIndex: Integer): Boolean; begin Result := False; end; function TBaseRegisters.GetName(const AnIndex: Integer): String; begin Result := ''; end; function TBaseRegisters.GetValue(const AnIndex: Integer): String; begin Result := ''; end; { =========================================================================== } { TIDERegisters } { =========================================================================== } procedure TIDERegisters.AddNotification(const ANotification: TIDERegistersNotification); begin FNotificationList.Add(ANotification); ANotification.AddReference; end; constructor TIDERegisters.Create; begin FNotificationList := TList.Create; inherited Create; end; destructor TIDERegisters.Destroy; var n: Integer; begin for n := FNotificationList.Count - 1 downto 0 do TDebuggerNotification(FNotificationList[n]).ReleaseReference; inherited; FreeAndNil(FNotificationList); end; procedure TIDERegisters.NotifyChange; var n: Integer; Notification: TIDERegistersNotification; begin for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDERegistersNotification(FNotificationList[n]); if Assigned(Notification.FOnChange) then Notification.FOnChange(Self); end; end; procedure TIDERegisters.RemoveNotification(const ANotification: TIDERegistersNotification); begin FNotificationList.Remove(ANotification); ANotification.ReleaseReference; end; { =========================================================================== } { TDBGRegisters } { =========================================================================== } function TDBGRegisters.Count: Integer; begin if (FDebugger <> nil) and (FDebugger.State = dsPause) then Result := GetCount else Result := 0; end; constructor TDBGRegisters.Create(const ADebugger: TDebugger); begin FChanged := False; inherited Create; FDebugger := ADebugger; end; procedure TDBGRegisters.DoChange; begin if Updating then begin FChanged := True; exit; end; FChanged := False; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDBGRegisters.DoStateChange(const AOldState: TDBGState); begin end; procedure TDBGRegisters.Changed; begin DoChange; end; function TDBGRegisters.GetCount: Integer; begin Result := 0; end; procedure TDBGRegisters.SetFormat(const AnIndex: Integer; const AValue: TRegisterDisplayFormat); begin inherited SetFormat(AnIndex, AValue); Changed; end; procedure TDBGRegisters.ChangeUpdating; begin inherited ChangeUpdating; if (not Updating) and FChanged then DoChange; end; (******************************************************************************) (******************************************************************************) (** **) (** C A L L S T A C K **) (** **) (******************************************************************************) (******************************************************************************) { =========================================================================== } { TDBGCallStackEntry } { =========================================================================== } constructor TCallStackEntry.Create(const AIndex: Integer; const AnAdress: TDbgPtr; const AnArguments: TStrings; const AFunctionName: String; const ASource: String; const AFullFileName: String; const ALine: Integer; AState: TCallStackEntryState = cseValid); begin inherited Create; FIndex := AIndex; FAdress := AnAdress; FArguments := TStringlist.Create; if AnArguments <> nil then FArguments.Assign(AnArguments); FFunctionName := AFunctionName; FSource := ASource; FFullFileName := AFullFileName; FLine := ALine; FState := AState; end; constructor TCallStackEntry.CreateCopy(const ASource: TCallStackEntry); begin Create(ASource.FIndex, ASource.FAdress, ASource.FArguments, ASource.FFunctionName, ASource.FSource, ASource.FFullFileName, ASource.FLine, ASource.FState); end; destructor TCallStackEntry.Destroy; begin inherited; FreeAndNil(FArguments); 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; 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.GetCurrent: Boolean; begin Result := (FOwner <> nil) and (FOwner.GetCurrent = Self) end; function TCallStackEntry.GetFullFileName: String; begin if FState = cseValid then Result := FFullFileName else Result := ''; end; function TCallStackEntry.GetFunctionName: String; begin case FState of cseValid: Result := FFunctionName; cseRequested: Result := ''; cseInvalid: Result := ''; end; end; function TCallStackEntry.GetSource: String; begin if FState = cseValid then Result := FSource else Result := ''; end; procedure TCallStackEntry.SetCurrent(const AValue: Boolean); begin if FOwner = nil then Exit; if GetCurrent = AValue then Exit; if AValue then FOwner.SetCurrent(self) else FOwner.SetCurrent(nil); end; { =========================================================================== } { TBaseCallStack } { =========================================================================== } function TBaseCallStack.CheckCount: Boolean; begin Result := False; end; procedure TBaseCallStack.Clear; begin FCount := -1; end; function TBaseCallStack.Count: Integer; begin if (FCount = -1) and not CheckCount then Result := 0 else Result := FCount; end; destructor TBaseCallStack.Destroy; begin Clear; inherited Destroy; end; function TBaseCallStack.GetCurrent: TCallStackEntry; begin Result := nil; end; function TBaseCallStack.GetEntry(AIndex: Integer): TCallStackEntry; begin if (AIndex < 0) or (AIndex >= Count) then IndexError(Aindex); Result := InternalGetEntry(AIndex); end; function TBaseCallStack.IndexError(AIndex: Integer): TCallStackEntry; begin Result:=nil; raise EInvalidOperation.CreateFmt('Index out of range (%d)', [AIndex]); end; function TBaseCallStack.InternalGetEntry(AIndex: Integer): TCallStackEntry; begin Result := nil; end; procedure TBaseCallStack.PrepareRange(AIndex, ACount: Integer); begin end; procedure TBaseCallStack.SetCount(ACount: Integer); procedure Error; begin raise EInvalidOperation.CreateFmt('Illegal count (%d < 0)', [ACount]); end; begin if ACount < 0 then Error; FCount := ACount; end; procedure TBaseCallStack.SetCurrent(AValue: TCallStackEntry); begin end; { =========================================================================== } { TIDECallStack } { =========================================================================== } procedure TIDECallStack.AddNotification(const ANotification: TIDECallStackNotification); begin FNotificationList.Add(ANotification); ANotification.AddReference; end; constructor TIDECallStack.Create; begin FNotificationList := TList.Create; inherited Create; end; destructor TIDECallStack.Destroy; var n: Integer; begin for n := FNotificationList.Count - 1 downto 0 do TDebuggerNotification(FNotificationList[n]).ReleaseReference; inherited; FreeAndNil(FNotificationList); end; procedure TIDECallStack.NotifyChange; var n: Integer; Notification: TIDECallStackNotification; begin for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDECallStackNotification(FNotificationList[n]); if Assigned(Notification.FOnChange) then Notification.FOnChange(Self); end; end; procedure TIDECallStack.NotifyCurrent; var n: Integer; Notification: TIDECallStackNotification; begin for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDECallStackNotification(FNotificationList[n]); if Assigned(Notification.FOnCurrent) then Notification.FOnCurrent(Self); end; end; procedure TIDECallStack.RemoveNotification(const ANotification: TIDECallStackNotification); begin FNotificationList.Remove(ANotification); ANotification.ReleaseReference; end; { =========================================================================== } { TDBGCallStack } { =========================================================================== } procedure TDBGCallStack.Changed; begin if Assigned(FOnChange) then FOnChange(Self); end; function TDBGCallStack.CheckCount: Boolean; begin Result := (FDebugger <> nil) and (FDebugger.State = dsPause); if Result then SetCount(0); end; procedure TDBGCallStack.Clear; var Iterator: TMapIterator; begin Iterator:= TMapIterator.Create(FEntries); while not Iterator.EOM do begin TObject(Iterator.DataPtr^).Free; Iterator.Next; end; Iterator.Free; FEntries.Clear; inherited Clear; end; constructor TDBGCallStack.Create(const ADebugger: TDebugger); begin FDebugger := ADebugger; FOldState := FDebugger.State; FEntries:= TMap.Create(its4, SizeOf(TCallStackEntry)); inherited Create; end; function TDBGCallStack.CreateStackEntry(AIndex: Integer): TCallStackEntry; begin Result := nil; end; procedure TDBGCallStack.CurrentChanged; begin if Assigned(FOnCurrent) then FOnCurrent(Self); end; destructor TDBGCallStack.Destroy; begin inherited Destroy; FreeAndNil(FEntries); end; procedure TDBGCallStack.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 begin Clear; if Assigned(FOnClear) then FOnClear(Self); end; end; end; function TDBGCallStack.InternalGetEntry(AIndex: Integer): TCallStackEntry; begin Result := nil; if FEntries.GetData(AIndex, Result) then Exit; Result := CreateStackEntry(AIndex); if Result = nil then Exit; FEntries.Add(AIndex, Result); Result.FOwner := Self; end; procedure TDBGCallStack.InternalSetEntry(AIndex: Integer; AEntry: TCallStackEntry); var Dummy: TCallStackEntry; begin if FEntries.GetData(AIndex, Dummy) then begin //debugln(['TDBGCallStack.InternalSetEntry: replacing existing entry ', Dummy.Line]); FEntries.Delete(AIndex); Dummy.Free; end; AEntry.FOwner := Self; FEntries.Add(AIndex, AEntry); end; procedure TDBGCallStack.PrepareEntries(AStartIndex, AEndIndex: Integer); begin end; procedure TDBGCallStack.PrepareRange(AIndex, ACount: Integer); var It: TMapIterator; EndIndex: Integer; begin It := TMapIterator.Create(FEntries); if It.Locate(AIndex) then repeat // start searching for the first unavailable Inc(AIndex); Dec(ACount); It.Next; until It.EOM or (ACount <= 0) or (TCallStackEntry(It.DataPtr^).Index <> AIndex); if ACount > 1 then begin EndIndex := AIndex + ACount - 1; if It.Locate(EndIndex) then repeat // start searching for the last unavailable Dec(EndIndex); Dec(ACount); It.Previous; until It.BOM or (ACount <= 0) or (TCallStackEntry(It.DataPtr^).Index <> EndIndex); end; It.Free; if ACount <= 0 then Exit; PrepareEntries(AIndex, ACount); end; (******************************************************************************) (******************************************************************************) (** **) (** S I G N A L S and E X C E P T I O N S **) (** **) (******************************************************************************) (******************************************************************************) { =========================================================================== } { 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: TDebugger; begin Result := TDBGSignals(Collection).FDebugger; end; { =========================================================================== } { TIDESignal } { =========================================================================== } procedure TIDESignal.LoadFromXMLConfig (const AXMLConfig: TXMLConfig; const APath: string ); begin // TODO end; procedure TIDESignal.SaveToXMLConfig (const AXMLConfig: TXMLConfig; const APath: string ); begin // TODO 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: TDebugger; 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; { =========================================================================== } { TIDESignals } { =========================================================================== } function TIDESignals.Add(const AName: String; AID: Integer): TIDESignal; begin Result := TIDESignal(inherited Add(AName, AID)); end; function TIDESignals.Find(const AName: String): TIDESignal; begin Result := TIDESignal(inherited Find(AName)); end; function TIDESignals.GetItem(const AIndex: Integer): TIDESignal; begin Result := TIDESignal(inherited GetItem(AIndex)); end; procedure TIDESignals.LoadFromXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); begin // TODO end; procedure TIDESignals.SaveToXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); begin // TODO end; procedure TIDESignals.SetItem(const AIndex: Integer; const AValue: TIDESignal); begin inherited SetItem(AIndex, AValue); end; { =========================================================================== } { TBaseException } { =========================================================================== } 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.LoadFromXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); begin FName:=AXMLConfig.GetValue(APath+'Name/Value',''); end; procedure TBaseException.SaveToXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); begin AXMLConfig.SetDeleteValue(APath+'Name/Value',FName,''); 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; { =========================================================================== } { TIDEException } { =========================================================================== } constructor TIDEException.Create (ACollection: TCollection ); begin FEnabled := True; inherited Create(ACollection); end; procedure TIDEException.LoadFromXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); begin inherited LoadFromXMLConfig(AXMLConfig, APath); FEnabled:=AXMLConfig.GetValue(APath+'Enabled/Value',true); end; procedure TIDEException.SaveToXMLConfig(const AXMLConfig: TXMLConfig; const APath: string); begin inherited SaveToXMLConfig(AXMLConfig, APath); AXMLConfig.SetDeleteValue(APath+'Enabled/Value',FEnabled,true); end; procedure TIDEException.SetEnabled(const AValue: Boolean); begin if FEnabled = AValue then Exit; FEnabled := 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; 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; { =========================================================================== } { TDBGExceptions } { =========================================================================== } function TDBGExceptions.Add(const AName: String): TDBGException; begin Result := TDBGException(inherited Add(AName)); end; constructor TDBGExceptions.Create(const ADebugger: TDebugger; const AExceptionClass: TDBGExceptionClass); begin FDebugger := ADebugger; inherited Create(AExceptionClass); end; function TDBGExceptions.Find(const AName: String): TDBGException; begin Result := TDBGException(inherited Find(AName)); end; function TDBGExceptions.GetItem(const AIndex: Integer): TDBGException; begin Result := TDBGException(inherited GetItem(AIndex)); end; procedure TDBGExceptions.SetItem(const AIndex: Integer; const AValue: TDBGException); begin inherited SetItem(AIndex, AValue); end; { =========================================================================== } { TIDEExceptions } { =========================================================================== } function TIDEExceptions.Add(const AName: String): TIDEException; begin Result := TIDEException(inherited Add(AName)); end; function TIDEExceptions.Find(const AName: String): TIDEException; begin Result := TIDEException(inherited Find(AName)); end; function TIDEExceptions.GetItem(const AIndex: Integer): TIDEException; begin Result := TIDEException(inherited GetItem(AIndex)); end; procedure TIDEExceptions.LoadFromXMLConfig (const AXMLConfig: TXMLConfig; const APath: string); var NewCount: Integer; i: Integer; IDEException: TIDEException; begin Clear; NewCount := AXMLConfig.GetValue(APath + 'Count', 0); FIgnoreAll := AXMLConfig.GetValue(APath + 'IgnoreAll', False); for i := 0 to NewCount-1 do begin IDEException := TIDEException(inherited Add('')); IDEException.LoadFromXMLConfig(AXMLConfig, Format('%sItem%d/', [APath, i + 1])); end; end; procedure TIDEExceptions.SaveToXMLConfig (const AXMLConfig: TXMLConfig; const APath: string); var Cnt: Integer; i: Integer; IDEException: TIDEException; begin Cnt := Count; AXMLConfig.SetDeleteValue(APath + 'Count', Cnt, 0); AXMLConfig.SetDeleteValue(APath + 'IgnoreAll', IgnoreAll, False); for i := 0 to Cnt - 1 do begin IDEException := Items[i]; IDEException.SaveToXMLConfig(AXMLConfig, Format('%sItem%d/', [APath, i + 1])); end; end; procedure TIDEExceptions.SetItem(const AIndex: Integer; const AValue: TIDEException); begin inherited SetItem(Aindex, AValue); 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; { 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; function TBaseLineInfo.Count: Integer; begin Result := 0; end; { TIDELineInfo } procedure TIDELineInfo.NotifyChange(ASource: String); var n: Integer; Notification: TIDELineInfoNotification; begin for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDELineInfoNotification(FNotificationList[n]); if Assigned(Notification.FOnChange) then Notification.FOnChange(Self, ASource); end; end; constructor TIDELineInfo.Create; begin FNotificationList := TList.Create; inherited Create; end; destructor TIDELineInfo.Destroy; var n: Integer; begin for n := FNotificationList.Count - 1 downto 0 do TDebuggerNotification(FNotificationList[n]).ReleaseReference; inherited; FreeAndNil(FNotificationList); end; procedure TIDELineInfo.AddNotification(const ANotification: TIDELineInfoNotification); begin FNotificationList.Add(ANotification); ANotification.AddReference; end; procedure TIDELineInfo.RemoveNotification(const ANotification: TIDELineInfoNotification); begin if FNotificationList.IndexOf(ANotification) >= 0 then begin FNotificationList.Remove(ANotification); ANotification.ReleaseReference; end; 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: TDebugger); begin inherited Create; FDebugger := ADebugger; end; { TBaseDisassembler } function TBaseDisassembler.IndexError(AIndex: Integer): TCallStackEntry; begin Result:=nil; 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 {$IFDEF DBG_VERBOSE} debugln(['WARNING: TBaseDisassembler.InternalIncreaseCountBefore will decrease was ', FCountBefore , ' new=',ACount]); {$ENDIF} SetCountBefore(ACount); end else FCountBefore := ACount; end; procedure TBaseDisassembler.InternalIncreaseCountAfter(ACount: Integer); begin // increase count withou change notification if ACount < FCountAfter then begin {$IFDEF DBG_VERBOSE} debugln(['WARNING: TBaseDisassembler.InternalIncreaseCountAfter will decrease was ', FCountAfter , ' new=',ACount]); {$ENDIF} 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; { TIDEDisassembler } procedure TIDEDisassembler.DoChanged; var n: Integer; Notification: TIDEDisassemblerNotification; begin for n := 0 to FNotificationList.Count - 1 do begin Notification := TIDEDisassemblerNotification(FNotificationList[n]); if Assigned(Notification.FOnChange) then Notification.FOnChange(Self); end; end; constructor TIDEDisassembler.Create; begin FNotificationList := TList.Create; inherited Create; end; destructor TIDEDisassembler.Destroy; var n: Integer; begin for n := FNotificationList.Count - 1 downto 0 do TDebuggerNotification(FNotificationList[n]).ReleaseReference; inherited; FreeAndNil(FNotificationList); end; procedure TIDEDisassembler.AddNotification(const ANotification: TIDEDisassemblerNotification); begin FNotificationList.Add(ANotification); ANotification.AddReference; end; procedure TIDEDisassembler.RemoveNotification(const ANotification: TIDEDisassemblerNotification); begin FNotificationList.Remove(ANotification); ANotification.ReleaseReference; 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.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; while (i >= 0) and (AnotherRange.EntriesPtr[i]^.Addr >= RangeStartAddr) do dec(i); inc(i); {$IFDEF DBG_VERBOSE} debugln(['INFO: TDBGDisassemblerEntryRange.Merge: Merged to START: Other=', dbgs(AnotherRange), ' To other index=', i, ' INTO self=', dbgs(self) ]); {$ENDIF} 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:= RangeEndAddr; if LastAddr > a then a := LastAddr; i := 0; while (i < AnotherRange.Count) and (AnotherRange.EntriesPtr[i]^.Addr <= a) do inc(i); {$IFDEF DBG_VERBOSE} debugln(['INFO: TDBGDisassemblerEntryRange.Merge to END: Other=', dbgs(AnotherRange), ' From other index=', i, ' INTO self=', dbgs(self) ]); {$ENDIF} 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; {$IFDEF DBG_VERBOSE} debugln(['INFO: TDBGDisassemblerEntryRange.Merge AFTER MERGE: ', dbgs(self) ]); {$ENDIF} 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; 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 {$IFDEF DBG_VERBOSE} debugln(['INFO: TDBGDisassemblerEntryMap.AddRange ', dbgs(ARange), ' to map with count=', Count ]); {$ENDIF} 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 {$IFDEF DBG_VERBOSE} debugln(['WARNING: TDBGDisassembler.OnMerge: Address at odd offset ',BaseAddr, ' before=',CountBefore, ' after=', CountAfter]); {$ENDIF} 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 {$IFDEF DBG_VERBOSE} debugln(['INFO: TDBGDisassembler.FindRange: Address not found ', AnAddr, ' wanted-before=',ALinesBefore,' wanted-after=',ALinesAfter,' in map with count=', FEntryRanges.Count ]); {$ENDIF} exit; end; i := NewRange.IndexOfAddr(AnAddr); if i < 0 then begin // address at incorrect offset Result := HandleRangeWithInvalidAddr(NewRange, AnAddr, ALinesBefore, ALinesAfter); {$IFDEF DBG_VERBOSE} debugln(['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]); {$ENDIF} 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); {$IFDEF DBG_VERBOSE} debugln(['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]); {$ENDIF} finally UnlockChanged; end; end; procedure TDBGDisassembler.DoChanged; begin inherited DoChanged; if assigned(FOnChange) then FOnChange(Self); end; procedure TDBGDisassembler.Clear; begin {$IFDEF DBG_VERBOSE} debugln(['INFO: TDBGDisassembler.Clear: map had count=', FEntryRanges.Count ]); {$ENDIF} 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: TDebugger); 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); {$IFDEF DBG_VERBOSE} if result then debugln(['INFO: TDBGDisassembler.PrepareRange found existing data Addr=', AnAddr,' before=', ALinesBefore, ' After=', ALinesAfter ]); {$ENDIF} if Result then exit; {$IFDEF DBG_VERBOSE} if result then debugln(['INFO: TDBGDisassembler.PrepareRange calling PrepareEntries Addr=', AnAddr,' before=', ALinesBefore, ' After=', ALinesAfter ]); {$ENDIF} if PrepareEntries(AnAddr, ALinesBefore, ALinesAfter) then Result:= FindRange(AnAddr, ALinesBefore, ALinesAfter); {$IFDEF DBG_VERBOSE} if result then debugln(['INFO: TDBGDisassembler.PrepareRange found data AFTER PrepareEntries Addr=', AnAddr,' before=', ALinesBefore, ' After=', ALinesAfter ]); {$ENDIF} end; initialization MDebuggerPropertiesList := nil; finalization DoFinalization; end.