{ *************************************************************************** * * * 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. * * * *************************************************************************** Author: Mattias Gaertner Abstract: Frame for messages - output lines for (compiler) messages. } unit etMessageFrame; {$mode objfpc}{$H+} {$IFDEF EnableOldExtTools}{$Error Wrong}{$ENDIF} {$I ide.inc} interface uses Math, strutils, Classes, SysUtils, UTF8Process, FileProcs, LazFileCache, LazUTF8Classes, LazFileUtils, LazUTF8, AvgLvlTree, LazConfigStorage, SynEdit, SynEditMarks, LResources, Forms, Buttons, ExtCtrls, Controls, LMessages, LCLType, Graphics, LCLIntf, Themes, ImgList, GraphType, Menus, Clipbrd, Dialogs, StdCtrls, IDEExternToolIntf, IDEImagesIntf, MenuIntf, PackageIntf, IDECommands, SrcEditorIntf, IDEDialogs, ProjectIntf, CompOptsIntf, LazarusIDEStrConsts, EnvironmentOpts, HelpFPCMessages, etSrcEditMarks, etQuickFixes, ExtTools, IDEOptionDefs, CompilerOptions; const CustomViewCaption = '------------------------------'; type TMessagesCtrl = class; { TLMsgWndView } TLMsgWndView = class(TLazExtToolView) private FControl: TMessagesCtrl; FFilter: TLMsgViewFilter; fPaintBottom: integer; // only valid if FPaintStamp=Control.FPaintStamp FPaintStamp: int64; fPaintTop: integer; // only valid if FPaintStamp=Control.FPaintStamp FPendingChanges: TETMultiSrcChanges; procedure SetFilter(AValue: TLMsgViewFilter); procedure OnMarksFixed(ListOfTMessageLine: TFPList); // (main thread) called after mlfFixed was added to these messages protected procedure SetToolState(AValue: TLMVToolState); override; procedure FetchAllPending; override; // (main thread) procedure ToolExited; override; // (main thread) public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function LineFits(Line: TMessageLine): boolean; override; // (worker thread) property Control: TMessagesCtrl read FControl; function HasContent: boolean; function GetShownLineCount(WithHeader, WithProgressLine: boolean): integer; procedure RebuildLines; // (main thread) function ApplySrcChanges(Changes: TETSingleSrcChanges): boolean; // true if something changed public // requires Enter/LeaveCriticalSection, write only via main thread property Filter: TLMsgViewFilter read FFilter write SetFilter; property PendingChanges: TETMultiSrcChanges read FPendingChanges;// src changes for messages adding to view end; { TMsgCtrlUrgencyStyle } TMsgCtrlUrgencyStyle = class private FColor: TColor; FControl: TMessagesCtrl; FImageIndex: integer; FTranslated: string; FUrgency: TMessageLineUrgency; procedure SetColor(AValue: TColor); procedure SetImageIndex(AValue: integer); procedure SetTranslated(AValue: string); procedure Changed; public constructor Create(AControl: TMessagesCtrl; TheUrgency: TMessageLineUrgency); function Equals(Obj: TObject): boolean; override; procedure Assign(Src: TMsgCtrlUrgencyStyle); procedure SetValues(TheTranslated: string; TheImageIndex: integer = -1; TheColor: TColor = clDefault); property Control: TMessagesCtrl read FControl; property Urgency: TMessageLineUrgency read FUrgency; property Translated: string read FTranslated write SetTranslated; property ImageIndex: integer read FImageIndex write SetImageIndex default -1; property Color: TColor read FColor write SetColor default clDefault; end; type TOnOpenMessageLine = function(Sender: TObject; Msg: TMessageLine): boolean of object; TMsgCtrlState = ( mcsFocused ); TMsgCtrlStates = set of TMsgCtrlState; TMsgCtrlOption = ( mcoSingleClickOpensFile, // otherwise double click mcoShowStats, // show numbers of errors, warnings and hints in view header line mcoShowTranslated, // show translation (e.g. messages from German message file) mcoShowMessageID, // show message ID mcoShowMsgIcons, mcoAutoOpenFirstError, // when all views stopped, open first error mcoSrcEditPopupSelect, // when user right clicks on gutter mark, // scroll and select message of the quickfixes mcoWndStayOnTop, // use fsStayOnTop mcoAlwaysDrawFocused // draw selected item as focused, even if the window is not ); TMsgCtrlOptions = set of TMsgCtrlOption; const MCDefaultOptions = [mcoShowStats,mcoShowTranslated, mcoAutoOpenFirstError,mcoShowMsgIcons, mcoSrcEditPopupSelect]; type { TMessagesCtrl } TMessagesCtrl = class(TCustomControl) private FActiveFilter: TLMsgViewFilter; FAutoScrollToNewMessage: boolean; FBackgroundColor: TColor; FFilenameStyle: TMsgWndFileNameStyle; FHeaderBackground: array[TLMVToolState] of TColor; FIdleConnected: boolean; FImageChangeLink: TChangeLink; FImages: TCustomImageList; FItemHeight: integer; FOnAllViewsStopped: TNotifyEvent; FOnOpenMessage: TOnOpenMessageLine; FOnOptionsChanged: TNotifyEvent; FOptions: TMsgCtrlOptions; FScrollLeft: integer; FScrollTop: integer; fScrollTopMax: integer; FSearchText: string; FSelectedLine: integer; FSelectedView: TLMsgWndView; FSourceMarks: TETMarks; fUpdateLock: integer; FUpdateTimer: TTimer; fSomeViewsRunning: boolean; fUrgencyStyles: array[TMessageLineUrgency] of TMsgCtrlUrgencyStyle; FAutoHeaderBackground: TColor; procedure CreateSourceMark(MsgLine: TMessageLine; aSynEdit: TSynEdit); procedure CreateSourceMarks(View: TLMsgWndView; StartLineNumber: Integer); function GetActiveFilter: TLMsgViewFilter; inline; function GetHeaderBackground(aToolState: TLMVToolState): TColor; function GetSelectedLine: integer; function GetUrgencyStyles(Urgency: TMessageLineUrgency ): TMsgCtrlUrgencyStyle; function GetViews(Index: integer): TLMsgWndView; procedure OnViewChanged(Sender: TObject); // (main thread) procedure MsgUpdateTimerTimer(Sender: TObject); procedure SetActiveFilter(AValue: TLMsgViewFilter); inline; procedure SetBackgroundColor(AValue: TColor); procedure SetFilenameStyle(AValue: TMsgWndFileNameStyle); procedure SetHeaderBackground(aToolState: TLMVToolState; AValue: TColor); procedure SetIdleConnected(AValue: boolean); procedure SetImages(AValue: TCustomImageList); procedure SetItemHeight(AValue: integer); procedure SetOptions(NewOptions: TMsgCtrlOptions); procedure SetScrollLeft(AValue: integer); procedure SetScrollTop(AValue: integer); procedure SetSearchText(AValue: string); procedure SetSelectedLine(AValue: integer); procedure SetSelectedView(AValue: TLMsgWndView); procedure SetSourceMarks(AValue: TETMarks); procedure SetUrgencyStyles(Urgency: TMessageLineUrgency; AValue: TMsgCtrlUrgencyStyle); procedure SetAutoHeaderBackground(AValue: TColor); procedure WMHScroll(var Msg: TLMScroll); message LM_HSCROLL; procedure WMVScroll(var Msg: TLMScroll); message LM_VSCROLL; procedure WMMouseWheel(var Message: TLMMouseEvent); message LM_MOUSEWHEEL; procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS; procedure WMKillFocus(var Message: TLMKillFocus); message LM_KILLFOCUS; function GetMaxSelectedLine: integer; procedure ImageListChange(Sender: TObject); procedure OnIdle(Sender: TObject; var {%H-}Done: Boolean); procedure OnFilterChanged(Sender: TObject); protected FViews: TFPList;// list of TMessagesViewMap FStates: TMsgCtrlStates; FPaintStamp: int64; fLastSearchStartView: TLMsgWndView; fLastSearchStartLine: integer; fLastLoSearchText: string; // lower case search text procedure FetchNewMessages; procedure FetchNewMessages(View: TLMsgWndView); procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Paint; override; procedure UpdateScrollBar(InvalidateScrollMax: boolean); procedure CreateWnd; override; procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer ); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure DoOnShowHint(HintInfo: PHintInfo); override; procedure DoAllViewsStopped; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure BeginUpdate; procedure EndUpdate; procedure EraseBackground({%H-}DC: HDC); override; procedure ApplyEnvironmentOptions; function UrgencyToStr(Urgency: TMessageLineUrgency): string; // views function ViewCount: integer; inline; property Views[Index: integer]: TLMsgWndView read GetViews; function IndexOfView(View: TLMsgWndView): integer; procedure ClearViews(OnlyFinished: boolean); // deletes/frees all views procedure RemoveView(View: TLMsgWndView); // remove without free function GetView(aCaption: string; CreateIfNotExist: boolean): TLMsgWndView; function GetLineAt(Y: integer; out View: TLMsgWndView; out Line: integer): boolean; function GetLineText(Line: TMessageLine): string; function GetHeaderText(View: TLMsgWndView): string; function FindUnfinishedView: TLMsgWndView; // running or waiting for run function GetLastViewWithContent: TLMsgWndView; // filter property ActiveFilter: TLMsgViewFilter read GetActiveFilter write SetActiveFilter; function Filters: TLMsgViewFilters; inline; // select, search function HasSelection: boolean; procedure Select(View: TLMsgWndView; LineNumber: integer; DoScroll, FullyVisible: boolean); function SearchNext(StartView: TLMsgWndView; StartLine: integer; SkipStart, Downwards: boolean; out View: TLMsgWndView; out LineNumber: integer): boolean; procedure Select(Msg: TMessageLine; DoScroll: boolean); function SelectNextOccurence(Downwards: boolean): boolean; function SelectNextShown(Offset: integer): boolean; function SelectLast(DoScroll, FullyVisible: boolean): boolean; function SelectFirst(DoScroll, FullyVisible: boolean): boolean; function GetSelectedMsg: TMessageLine; function SearchNextUrgent(StartView: TLMsgWndView; StartLine: integer; SkipStart, Downwards: boolean; aMinUrgency: TMessageLineUrgency; WithSrcPos: boolean; out View: TLMsgWndView; out LineNumber: integer): boolean; function SelectFirstUrgentMessage(aMinUrgency: TMessageLineUrgency; WithSrcPos: boolean): boolean; function SelectNextUrgentMessage(aMinUrgency: TMessageLineUrgency; WithSrcPos: boolean; Downwards: boolean): boolean; // scroll function IsLineVisible(View: TLMsgWndView; LineNumber: integer): boolean; function IsLastLineVisible(View: TLMsgWndView): boolean; procedure ScrollToLine(View: TLMsgWndView; LineNumber: integer; FullyVisible: boolean); function GetLineTop(View: TLMsgWndView; LineNumber: integer; Scrolled: boolean): integer; property ScrollLeft: integer read FScrollLeft write SetScrollLeft; property ScrollTop: integer read FScrollTop write SetScrollTop; function ScrollLeftMax: integer; function ScrollTopMax: integer; procedure StoreSelectedAsSearchStart; property AutoScrollToNewMessage: boolean read FAutoScrollToNewMessage write FAutoScrollToNewMessage; // activated when user scrolled to bottom, not an option // file function OpenSelection: boolean; procedure CreateMarksForFile(aSynEdit: TSynEdit; aFilename: string; DeleteOld: boolean); function ApplySrcChanges(Changes: TETSingleSrcChanges): boolean; // true if something changed public // properties property AutoHeaderBackground: TColor read FAutoHeaderBackground write SetAutoHeaderBackground default MsgWndDefAutoHeaderBackground; property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor default MsgWndDefBackgroundColor; property Color default clWindow; property FilenameStyle: TMsgWndFileNameStyle read FFilenameStyle write SetFilenameStyle; property HeaderBackground[aToolState: TLMVToolState]: TColor read GetHeaderBackground write SetHeaderBackground; property IdleConnected: boolean read FIdleConnected write SetIdleConnected; property Images: TCustomImageList read FImages write SetImages; property ItemHeight: integer read FItemHeight write SetItemHeight; property OnAllViewsStopped: TNotifyEvent read FOnAllViewsStopped write FOnAllViewsStopped; property OnOpenMessage: TOnOpenMessageLine read FOnOpenMessage write FOnOpenMessage; Property OnOptionsChanged: TNotifyEvent read FOnOptionsChanged write FOnOptionsChanged; property Options: TMsgCtrlOptions read FOptions write SetOptions default MCDefaultOptions; property SearchText: string read FSearchText write SetSearchText; property SelectedLine: integer read GetSelectedLine write SetSelectedLine; // -1=header line property SelectedView: TLMsgWndView read FSelectedView write SetSelectedView; property ShowHint default true; property SourceMarks: TETMarks read FSourceMarks write SetSourceMarks; property UrgencyStyles[Urgency: TMessageLineUrgency]: TMsgCtrlUrgencyStyle read GetUrgencyStyles write SetUrgencyStyles; end; { TMessagesFrame } TMessagesFrame = class(TFrame) HideSearchSpeedButton: TSpeedButton; MsgCtrlPopupMenu: TPopupMenu; SearchEdit: TEdit; SearchNextSpeedButton: TSpeedButton; SearchPanel: TPanel; SearchPrevSpeedButton: TSpeedButton; procedure AboutToolMenuItemClick(Sender: TObject); procedure AddFilterMenuItemClick(Sender: TObject); procedure ClearFilterMsgTypesMenuItemClick(Sender: TObject); procedure ClearMenuItemClick(Sender: TObject); procedure CopyAllMenuItemClick(Sender: TObject); procedure CopyFilenameMenuItemClick(Sender: TObject); procedure CopyMsgMenuItemClick(Sender: TObject); procedure CopyShownMenuItemClick(Sender: TObject); procedure EditHelpMenuItemClick(Sender: TObject); procedure FileStyleMenuItemClick(Sender: TObject); procedure FindMenuItemClick(Sender: TObject); procedure HelpMenuItemClick(Sender: TObject); procedure FilterHintsWithoutPosMenuItemClick(Sender: TObject); procedure FilterMsgOfTypeMenuItemClick(Sender: TObject); procedure FilterUrgencyMenuItemClick(Sender: TObject); procedure HideSearchSpeedButtonClick(Sender: TObject); procedure MsgCtrlPopupMenuPopup(Sender: TObject); procedure OnSelectFilterClick(Sender: TObject); procedure OpenToolsOptionsMenuItemClick(Sender: TObject); procedure RemoveCompOptHideMsgClick(Sender: TObject); procedure SaveAllToFileMenuItemClick(Sender: TObject); procedure SaveShownToFileMenuItemClick(Sender: TObject); procedure SearchEditChange(Sender: TObject); procedure SearchEditEnter(Sender: TObject); procedure SearchEditExit(Sender: TObject); procedure SearchEditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure SearchNextSpeedButtonClick(Sender: TObject); procedure SearchPrevSpeedButtonClick(Sender: TObject); procedure ShowIDMenuItemClick(Sender: TObject); procedure SrcEditLinesChanged(Sender: TObject); procedure TranslateMenuItemClick(Sender: TObject); procedure RemoveFilterMsgTypeClick(Sender: TObject); procedure WndStayOnTopMenuItemClick(Sender: TObject); private function AllMessagesAsString(const OnlyShown: boolean): String; function GetAboutView: TLMsgWndView; function GetViews(Index: integer): TLMsgWndView; procedure HideSearch; procedure SaveClicked(OnlyShown: boolean); procedure CopyAllClicked(OnlyShown: boolean); procedure CopyMsgToClipboard(OnlyFilename: boolean); function GetMsgPattern(SubTool: string; MsgId: integer; WithUrgency: boolean; MaxLen: integer): string; protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; public MessagesCtrl: TMessagesCtrl; constructor Create(TheOwner: TComponent); override; destructor Destroy; override; procedure ApplyIDEOptions; // Views function ViewCount: integer; property Views[Index: integer]: TLMsgWndView read GetViews; function GetView(aCaption: string; CreateIfNotExist: boolean): TLMsgWndView; function FindUnfinishedView: TLMsgWndView; procedure DeleteView(View: TLMsgWndView); // free view function IndexOfView(View: TLMsgWndView): integer; procedure ClearViews(OnlyFinished: boolean); // deletes/frees all views // source marks procedure CreateMarksForFile(aSynEdit: TSynEdit; aFilename: string; DeleteOld: boolean); procedure ApplySrcChanges(Changes: TETSingleSrcChanges); procedure ApplyMultiSrcChanges(Changes: TETMultiSrcChanges); procedure SourceEditorPopup(MarkLine: TSynEditMarkLine; const LogicalCaretXY: TPoint); procedure SourceEditorHint(MarkLine: TSynEditMarkLine; var HintStr: string); // message lines procedure SelectMsgLine(Msg: TMessageLine; DoScroll: boolean); function SelectFirstUrgentMessage(aMinUrgency: TMessageLineUrgency; WithSrcPos: boolean): boolean; function SelectNextUrgentMessage(aMinUrgency: TMessageLineUrgency; WithSrcPos, Downwards: boolean): boolean; procedure ClearCustomMessages(const ViewCaption: string=''); function AddCustomMessage(TheUrgency: TMessageLineUrgency; Msg: string; aFilename: string = ''; LineNumber: integer = 0; Column: integer = 0; const ViewCaption: string = CustomViewCaption): TMessageLine; // misc function GetDefaultSearchText: string; end; const MessagesMenuRootName = 'Messages'; var MsgFindMenuItem: TIDEMenuCommand; MsgQuickFixMenuSection: TIDEMenuSection; MsgAboutSection: TIDEMenuSection; MsgAboutToolMenuItem: TIDEMenuCommand; MsgOpenToolOptionsMenuItem: TIDEMenuCommand; MsgFilterMsgOfTypeMenuItem: TIDEMenuCommand; MsgRemoveCompOptHideMenuSection: TIDEMenuSection; MsgRemoveMsgTypeFilterMenuSection: TIDEMenuSection; MsgRemoveFilterMsgOneTypeMenuSection: TIDEMenuSection; MsgRemoveFilterAllMsgTypesMenuItem: TIDEMenuCommand; MsgFilterBelowMenuSection: TIDEMenuSection; MsgFilterWarningsMenuItem: TIDEMenuCommand; MsgFilterNotesMenuItem: TIDEMenuCommand; MsgFilterHintsMenuItem: TIDEMenuCommand; MsgFilterVerboseMenuItem: TIDEMenuCommand; MsgFilterDebugMenuItem: TIDEMenuCommand; MsgFilterNoneMenuItem: TIDEMenuCommand; MsgFilterHintsWithoutPosMenuItem: TIDEMenuCommand; MsgFiltersMenuSection: TIDEMenuSection; MsgSelectFilterMenuSection: TIDEMenuSection; MsgAddFilterMenuItem: TIDEMenuCommand; MsgCopyMenuSection: TIDEMenuSection; MsgCopyFilenameMenuItem: TIDEMenuCommand; MsgCopyMsgMenuItem: TIDEMenuCommand; MsgCopyShownMenuItem: TIDEMenuCommand; MsgCopyAllMenuItem: TIDEMenuCommand; MsgSaveToFileMenuSection: TIDEMenuSection; MsgSaveAllToFileMenuItem: TIDEMenuCommand; MsgSaveShownToFileMenuItem: TIDEMenuCommand; MsgHelpMenuItem: TIDEMenuCommand; MsgEditHelpMenuItem: TIDEMenuCommand; MsgClearMenuItem: TIDEMenuCommand; MsgOptionsMenuSection: TIDEMenuSection; MsgWndStayOnTopMenuItem: TIDEMenuCommand; MsgFilenameStyleMenuSection: TIDEMenuSection; MsgFileStyleShortMenuItem: TIDEMenuCommand; MsgFileStyleRelativeMenuItem: TIDEMenuCommand; MsgFileStyleFullMenuItem: TIDEMenuCommand; MsgTranslateMenuItem: TIDEMenuCommand; MsgShowIDMenuItem: TIDEMenuCommand; procedure RegisterStandardMessagesViewMenuItems; implementation procedure RegisterStandardMessagesViewMenuItems; var Parent: TIDEMenuSection; Root: TIDEMenuSection; begin MessagesMenuRoot := RegisterIDEMenuRoot(MessagesMenuRootName); Root:=MessagesMenuRoot; MsgFindMenuItem := RegisterIDEMenuCommand(Root, 'Find', lisFind); MsgQuickFixMenuSection := RegisterIDEMenuSection(Root, 'Quick Fix'); MsgAboutSection:=RegisterIDEMenuSection(Root,'About'); Parent:=MsgAboutSection; Parent.ChildsAsSubMenu:=true; Parent.Caption:=lisAbout; MsgAboutToolMenuItem:=RegisterIDEMenuCommand(Parent, 'About', 'About Tool'); MsgOpenToolOptionsMenuItem:=RegisterIDEMenuCommand(Parent, 'Open Tool Options', 'Open Tool Options'); MsgFilterMsgOfTypeMenuItem:=RegisterIDEMenuCommand(Root,'FilterMsgOfType',''); MsgRemoveCompOptHideMenuSection:=RegisterIDEMenuSection(Root,'RemoveCompOptHideMsg'); Parent:=MsgRemoveCompOptHideMenuSection; Parent.ChildsAsSubMenu:=true; Parent.Caption:=lisRemoveCompilerOptionHideMessage; MsgRemoveMsgTypeFilterMenuSection:=RegisterIDEMenuSection(Root,'RemoveMsgTypeFilters'); Parent:=MsgRemoveMsgTypeFilterMenuSection; Parent.ChildsAsSubMenu:=true; Parent.Caption:=lisRemoveMessageTypeFilter; MsgRemoveFilterMsgOneTypeMenuSection:=RegisterIDEMenuSection(Parent,'RemoveOneMsgTypeFilterSection'); MsgRemoveFilterAllMsgTypesMenuItem:=RegisterIDEMenuCommand(Parent, 'Remove' +' all message type filters', lisRemoveAllMessageTypeFilters); MsgFilterBelowMenuSection:=RegisterIDEMenuSection(Root,'Filter Below Section'); Parent:=MsgFilterBelowMenuSection; Parent.ChildsAsSubMenu:=true; Parent.Caption:=lisFilterNonUrgentMessages; MsgFilterWarningsMenuItem:=RegisterIDEMenuCommand(Parent, 'Filter Warnings', lisFilterWarningsAndBelow); MsgFilterWarningsMenuItem.RadioItem:=true; MsgFilterWarningsMenuItem.GroupIndex:=2; MsgFilterNotesMenuItem:=RegisterIDEMenuCommand(Parent, 'Filter Notes', lisFilterNotesAndBelow); MsgFilterNotesMenuItem.RadioItem:=true; MsgFilterNotesMenuItem.GroupIndex:=2; MsgFilterHintsMenuItem:=RegisterIDEMenuCommand(Parent, 'Filter Hints', lisFilterHintsAndBelow); MsgFilterHintsMenuItem.RadioItem:=true; MsgFilterHintsMenuItem.GroupIndex:=2; MsgFilterVerboseMenuItem:=RegisterIDEMenuCommand(Parent, 'Filter Verbose ' +'Messages', lisFilterVerboseMessagesAndBelow); MsgFilterVerboseMenuItem.RadioItem:=true; MsgFilterVerboseMenuItem.GroupIndex:=2; MsgFilterDebugMenuItem:=RegisterIDEMenuCommand(Parent, 'Filter Debug ' +'Messages', lisFilterDebugMessagesAndBelow); MsgFilterDebugMenuItem.RadioItem:=true; MsgFilterDebugMenuItem.GroupIndex:=2; MsgFilterNoneMenuItem:=RegisterIDEMenuCommand(Parent, 'Filter None, do not' +' filter by urgency', lisFilterNoneDoNotFilterByUrgency); MsgFilterNoneMenuItem.RadioItem:=true; MsgFilterNoneMenuItem.GroupIndex:=2; MsgFilterHintsWithoutPosMenuItem:=RegisterIDEMenuCommand(Root, 'Filter Hints' +' without Source Position', lisFilterHintsWithoutSourcePosition); MsgFiltersMenuSection:=RegisterIDEMenuSection(Root,'Switch Filter Section'); Parent:=MsgFiltersMenuSection; Parent.ChildsAsSubMenu:=true; Parent.Caption:=lisSwitchFilterSettings; MsgSelectFilterMenuSection:=RegisterIDEMenuSection(Parent,'Filters'); MsgAddFilterMenuItem:=RegisterIDEMenuCommand(Parent, 'Add Filter', lisAddFilter); MsgCopyMenuSection:=RegisterIDEMenuSection(Root,'Copy'); Parent:=MsgCopyMenuSection; Parent.ChildsAsSubMenu:=true; Parent.Caption:=lisCopy2; MsgCopyFilenameMenuItem:=RegisterIDEMenuCommand(Parent, 'Filename', lisCopyFileNameToClipboard); MsgCopyMsgMenuItem := RegisterIDEMenuCommand(Parent, 'Selected',lisCopySelectedMessagesToClipboard); MsgCopyShownMenuItem := RegisterIDEMenuCommand(Parent, 'Shown', lisCopyAllShownMessagesToClipboard); MsgCopyAllMenuItem:=RegisterIDEMenuCommand(Parent, 'All', lisCopyAllOriginalMessagesToClipboard); MsgSaveToFileMenuSection:=RegisterIDEMenuSection(Root,'Save'); Parent:=MsgSaveToFileMenuSection; Parent.ChildsAsSubMenu:=true; Parent.Caption:=lisDlgSave; MsgSaveShownToFileMenuItem:=RegisterIDEMenuCommand(Parent, 'Save Shown ' +'Messages to File', lisSaveShownMessagesToFile); MsgSaveAllToFileMenuItem:=RegisterIDEMenuCommand(Parent, 'Save All ' +'Messages to File', lisSaveAllOriginalMessagesToFile); MsgHelpMenuItem := RegisterIDEMenuCommand(Root, 'Help for this message',lisHelp); MsgEditHelpMenuItem := RegisterIDEMenuCommand(Root, 'Edit help for messages',lisEditHelp); MsgClearMenuItem := RegisterIDEMenuCommand(Root, 'Clear', lisClear); MsgOptionsMenuSection:=RegisterIDEMenuSection(Root,'Option Section'); Parent:=MsgOptionsMenuSection; Parent.ChildsAsSubMenu:=true; Parent.Caption:=lisMenuGeneralOptions; MsgWndStayOnTopMenuItem:=RegisterIDEMenuCommand(Parent, 'Window stay on top', lisWindowStaysOnTop); MsgFilenameStyleMenuSection:=RegisterIDEMenuSection(Parent,'Filename Styles'); Parent:=MsgFilenameStyleMenuSection; Parent.ChildsAsSubMenu:=true; Parent.Caption:=lisFilenameStyle; MsgFileStyleShortMenuItem:=RegisterIDEMenuCommand(Parent, 'Short', lisShortNoPath); MsgFileStyleRelativeMenuItem:=RegisterIDEMenuCommand(Parent, 'Relative', lisRelative); MsgFileStyleFullMenuItem:=RegisterIDEMenuCommand(Parent, 'Full', lisFull); Parent:=MsgOptionsMenuSection; MsgTranslateMenuItem:=RegisterIDEMenuCommand(Parent, 'Translate', lisTranslateTheEnglishMessages); MsgShowIDMenuItem:=RegisterIDEMenuCommand(Parent, 'ShowID', lisShowMessageTypeID); end; {$R *.lfm} { TLMsgWndView } procedure TLMsgWndView.OnMarksFixed(ListOfTMessageLine: TFPList); var i: Integer; ViewLine: TMessageLine; j: Integer; WorkerMsg: TMessageLine; begin //debugln(['TLMsgWndView.OnMarksFixed START ',ListOfTMessageLine.Count]); // apply marks to WorkerMessages if Tool<>nil then begin Tool.EnterCriticalSection; try for i:=0 to ListOfTMessageLine.Count-1 do begin ViewLine:=TMessageLine(ListOfTMessageLine[i]); j:=Tool.WorkerMessages.IndexOfOutputIndex(ViewLine.OutputIndex); if j<0 then continue; WorkerMsg:=Tool.WorkerMessages[j]; WorkerMsg.Flags:=ViewLine.Flags; //debugln(['TLMsgWndView.OnMarksFixed j=',j,' ',dbgs(WorkerMsg.Flags),' ',dbgs(Pointer(WorkerMsg)),' WorkerMsg.OutputIndex=',WorkerMsg.OutputIndex,' ViewLine.OutputIndex=',ViewLine.OutputIndex]); end; finally Tool.LeaveCriticalSection; end; end; // delete messages from view for i:=ListOfTMessageLine.Count-1 downto 0 do begin ViewLine:=TMessageLine(ListOfTMessageLine[i]); Lines.Delete(ViewLine); end; ListOfTMessageLine.Clear; // update control Control.UpdateScrollBar(true); Control.Invalidate; end; procedure TLMsgWndView.SetToolState(AValue: TLMVToolState); begin if ToolState=AValue then Exit; inherited; Control.Invalidate; end; procedure TLMsgWndView.SetFilter(AValue: TLMsgViewFilter); begin FFilter.Assign(AValue); end; procedure TLMsgWndView.FetchAllPending; var OldLineCount: Integer; i: Integer; OldUpdateSortedSrcPos: Boolean; MsgLine: TMessageLine; Line: Integer; Col: Integer; begin OldLineCount:=Lines.Count; inherited FetchAllPending; if OldLineCount=Lines.Count then exit; // apply pending src changes OldUpdateSortedSrcPos:=Lines.UpdateSortedSrcPos; if FPendingChanges.Count>0 then begin Lines.UpdateSortedSrcPos:=false; try for i:=OldLineCount to Lines.Count-1 do begin MsgLine:=Lines[i]; //debugln(['TLMsgWndView.FetchAllPending ',i,' ',MsgLine.Msg]); Line:=MsgLine.Line; Col:=MsgLine.Column; FPendingChanges.AdaptCaret(MsgLine.GetFullFilename,Line,Col, mlfLeftToken in MsgLine.Flags); MsgLine.SetSourcePosition(MsgLine.Filename,Line,Col); end; finally Lines.UpdateSortedSrcPos:=OldUpdateSortedSrcPos; end; end; end; procedure TLMsgWndView.ToolExited; var ErrCount: Integer; u: TMessageLineUrgency; MsgLine: TMessageLine; i: Integer; StartLine: Integer; sl: TStringList; begin inherited ToolExited; if Tool.Terminated then begin ToolState:=lmvtsFailed; end else if (ExitStatus<>0) then begin // tool stopped with errors ErrCount:=0; EnterCriticalSection; try for u:=mluError to high(TMessageLineUrgency) do inc(ErrCount,Lines.UrgencyCounts[u]+PendingLines.UrgencyCounts[u]); finally LeaveCriticalSection; end; if ErrCount=0 then begin // parser did not add an error message // => add an error message // add the last 3 lines of output with fatal urgency Tool.EnterCriticalSection; // Note: always lock Tool before View try EnterCriticalSection; try StartLine:=Max(0,Tool.WorkerOutput.Count-100); if PendingLines.Count>0 then StartLine:=Max(StartLine,PendingLines[PendingLines.Count-1].OutputIndex+1); if Lines.Count>0 then StartLine:=Max(StartLine,Lines[Lines.Count-1].OutputIndex+1); for i:=StartLine to Tool.WorkerOutput.Count-1 do begin MsgLine:=PendingLines.CreateLine(-1); MsgLine.Msg:=Tool.WorkerOutput[i]; MsgLine.Urgency:=mluPanic; PendingLines.Add(MsgLine); end; MsgLine:=PendingLines.CreateLine(-1); MsgLine.Urgency:=mluPanic; MsgLine.Msg:=Format( lisToolStoppedWithExitCodeUseContextMenuToGetMoreInfo, [IntToStr( ExitStatus)]); PendingLines.Add(MsgLine); finally LeaveCriticalSection; end; finally Tool.LeaveCriticalSection; end; end; ToolState:=lmvtsFailed; end else if Tool.ErrorMessage<>'' then begin // error executing the tool EnterCriticalSection; try sl:=TStringList.Create; try sl.Text:=Tool.ErrorMessage; for i:=0 to sl.Count-1 do begin if sl[i]='' then continue; MsgLine:=PendingLines.CreateLine(-1); MsgLine.Urgency:=mluPanic; MsgLine.Msg:='internal error: '+sl[i]; PendingLines.Add(MsgLine); end; finally sl.Free; end; finally LeaveCriticalSection; end; ToolState:=lmvtsFailed; end else ToolState:=lmvtsSuccess; end; constructor TLMsgWndView.Create(AOwner: TComponent); begin fMessageLineClass:=TLMsgViewLine; inherited Create(AOwner); Lines.OnMarksFixed:=@OnMarksFixed; FFilter:=TLMsgViewFilter.Create; fPendingChanges:=TETMultiSrcChanges.Create(nil); end; destructor TLMsgWndView.Destroy; begin inherited Destroy; FreeAndNil(FPendingChanges); FreeAndNil(FFilter); end; function TLMsgWndView.LineFits(Line: TMessageLine): boolean; begin if FFilter<>nil then Result:=FFilter.LineFits(Line) else Result:=inherited LineFits(Line); end; function TLMsgWndView.HasContent: boolean; begin Result:=GetShownLineCount(true,true)>0; end; function TLMsgWndView.GetShownLineCount(WithHeader, WithProgressLine: boolean ): integer; begin Result:=Lines.Count; // the header is only shown if there SummaryMsg<>'' or ProgressLine.Msg<>'' or Lines.Count>0 if ProgressLine.Msg<>'' then begin if WithHeader then inc(Result); if WithProgressLine then inc(Result); end else if Caption<>'' then begin if WithHeader then inc(Result); end else if (Result>0) and WithHeader then inc(Result); end; procedure TLMsgWndView.RebuildLines; // called by main thread var i: Integer; SrcMsg: TMessageLine; NewProgressLine: TMessageLine; NewMsg: TMessageLine; Line: Integer; Col: Integer; begin if Tool=nil then exit; Tool.EnterCriticalSection; // lock Tool before View try EnterCriticalSection; try ClearLines; NewProgressLine:=nil; for i:=0 to Tool.WorkerMessages.Count-1 do begin SrcMsg:=Tool.WorkerMessages[i]; //if Pos('"db"',SrcMsg.Msg)>0 then // debugln(['TLMsgWndView.RebuildLines i=',i,' Msg="',SrcMsg.Msg,'" Fits=',LineFits(SrcMsg),' ',dbgs(SrcMsg.Flags),' ',SrcMsg.OutputIndex]); if LineFits(SrcMsg) then begin NewProgressLine:=nil; NewMsg:=Lines.CreateLine(-1); NewMsg.Assign(SrcMsg); // adapt line,col due to src changes Line:=NewMsg.Line; Col:=NewMsg.Column; FPendingChanges.AdaptCaret(NewMsg.GetFullFilename,Line,Col, mlfLeftToken in NewMsg.Flags); NewMsg.SetSourcePosition(NewMsg.Filename,Line,Col); //debugln(['TLMsgWndView.RebuildLines NewMsg=',Lines.Count,'="',NewMsg.Msg,'"']); Lines.Add(NewMsg); end else begin NewProgressLine:=SrcMsg; end; end; FLastWorkerMessageCount:=Tool.WorkerMessages.Count-1; if (NewProgressLine<>nil) and Running then begin ProgressLine.Assign(NewProgressLine); end else if ProgressLine.Msg<>'' then begin ProgressLine.Clear; end; finally LeaveCriticalSection; end; finally Tool.LeaveCriticalSection; end; end; function TLMsgWndView.ApplySrcChanges(Changes: TETSingleSrcChanges): boolean; function ApplyChanges(CurChanges: TETSingleSrcChanges; CurLines: TMessageLines): boolean; var FromY: integer; MaxY: integer; LineDiffBehindMaxY: integer; ToY: Integer; MsgLine: TMessageLine; Line: Integer; Col: Integer; OldUpdateSortedSrcPos: Boolean; begin Result:=false; if CurChanges.First=nil then exit; CurChanges.GetRange(FromY,MaxY,LineDiffBehindMaxY); if LineDiffBehindMaxY=0 then ToY:=MaxY else ToY:=High(Integer); OldUpdateSortedSrcPos:=Lines.UpdateSortedSrcPos; CurLines.UpdateSortedSrcPos:=false; try {if CurLines=Lines then begin debugln(['ApplyChanges MinY=',FromY,' MaxY=',MaxY,' LineDiffBehindMaxY=',LineDiffBehindMaxY]); CurChanges.WriteDebugReport('Changes:'); end;} for MsgLine in CurLines.EnumerateFile(CurChanges.Filename,FromY,ToY) do begin Line:=MsgLine.Line; Col:=MsgLine.Column; if Line>MaxY then inc(Line,LineDiffBehindMaxY) else CurChanges.AdaptCaret(Line,Col,mlfLeftToken in MsgLine.Flags); //if CurLines=Lines then // debugln(['ApplyChanges ',MsgLine.Msg,' Old=',MsgLine.Line,',',MsgLine.Column,' New=',Line,',',Col]); if (Line=MsgLine.Line) and (MsgLine.Column=Col) then continue; MsgLine.SetSourcePosition(MsgLine.Filename,Line,Col); Result:=true; end; finally CurLines.UpdateSortedSrcPos:=OldUpdateSortedSrcPos; end; end; var Queue: TETSingleSrcChanges; Change: TETSrcChange; Node: TAvgLvlTreeNode; aFilename: String; begin Result:=false; //debugln(['TLMsgWndView.ApplySrcChanges START ',Changes.Filename,' ',Changes.First<>nil]); // check if there are changes if Changes.First=nil then exit; aFilename:=Changes.Filename; if aFilename='' then exit; // update visible lines Result:=ApplyChanges(Changes,Lines); // update pending lines if Tool<>nil then begin Tool.EnterCriticalSection; // lock Tool before View try EnterCriticalSection; try Queue:=PendingChanges.GetChanges(aFilename,true); Change:=Changes.First; while Change<>nil do begin Queue.Add(Change.Action,Change.FromPos,Change.ToPos); Change:=Change.Next; end; if not Running then begin // apply all pending changes to Tool.WorkerMessages Node:=PendingChanges.AllChanges.FindLowest; while Node<>nil do begin ApplyChanges(TETSingleSrcChanges(Node.Data),Tool.WorkerMessages); Node:=Node.Successor; end; PendingChanges.Clear; end; finally LeaveCriticalSection; end; finally Tool.LeaveCriticalSection; end; end; end; { TMsgCtrlUrgencyStyle } procedure TMsgCtrlUrgencyStyle.SetColor(AValue: TColor); begin if FColor=AValue then Exit; FColor:=AValue; Changed; end; procedure TMsgCtrlUrgencyStyle.SetImageIndex(AValue: integer); begin if FImageIndex=AValue then Exit; FImageIndex:=AValue; Changed; end; procedure TMsgCtrlUrgencyStyle.SetTranslated(AValue: string); begin if FTranslated=AValue then Exit; FTranslated:=AValue; Changed; end; procedure TMsgCtrlUrgencyStyle.Changed; begin Control.Invalidate; end; constructor TMsgCtrlUrgencyStyle.Create(AControl: TMessagesCtrl; TheUrgency: TMessageLineUrgency); begin FControl:=AControl; fUrgency:=TheUrgency; FImageIndex:=-1; FColor:=clDefault; end; function TMsgCtrlUrgencyStyle.Equals(Obj: TObject): boolean; var Src: TMsgCtrlUrgencyStyle; begin if Obj is TMsgCtrlUrgencyStyle then begin Src:=TMsgCtrlUrgencyStyle(Obj); Result:=(ImageIndex=Src.ImageIndex) and (Color=Src.Color) and (Translated=Src.Translated); end else Result:=inherited Equals(Obj); end; procedure TMsgCtrlUrgencyStyle.Assign(Src: TMsgCtrlUrgencyStyle); begin if Equals(Src) then exit; fImageIndex:=Src.ImageIndex; fColor:=Src.Color; fTranslated:=Src.Translated; Changed; end; procedure TMsgCtrlUrgencyStyle.SetValues(TheTranslated: string; TheImageIndex: integer; TheColor: TColor); begin Translated:=TheTranslated; ImageIndex:=TheImageIndex; Color:=TheColor; end; { TMessagesCtrl } // inline function TMessagesCtrl.ViewCount: integer; begin Result:=FViews.Count; end; // inline function TMessagesCtrl.Filters: TLMsgViewFilters; begin Result:=EnvironmentOptions.MsgViewFilters; end; // inline function TMessagesCtrl.GetActiveFilter: TLMsgViewFilter; begin Result:=Filters.ActiveFilter; end; // inline procedure TMessagesCtrl.SetActiveFilter(AValue: TLMsgViewFilter); begin Filters.ActiveFilter:=AValue; end; function TMessagesCtrl.GetViews(Index: integer): TLMsgWndView; procedure RaiseOutOfBounds; begin raise Exception.Create('TMessagesCtrl.GetViews '+IntToStr(Index)+' out of bounds '+IntToStr(ViewCount)); end; begin if (Index<0) or (Index>=ViewCount) then RaiseOutOfBounds; Result:=TLMsgWndView(FViews[Index]); end; procedure TMessagesCtrl.OnViewChanged(Sender: TObject); var AllViewsStopped: Boolean; i: Integer; begin for i:=0 to ViewCount-1 do begin if Views[i].Running then begin // the views may change many times // reduce the update of the control to a few per second by using a timer fSomeViewsRunning:=true; FUpdateTimer.Enabled:=true; exit; end; end; // no views are running // The variable fSomeViewsRunning contains the last state // if fSomeViewsRunning was true, then all views have stopped AllViewsStopped:=fSomeViewsRunning; fSomeViewsRunning:=false; // no views running => update immediately FetchNewMessages; if AllViewsStopped then DoAllViewsStopped; end; procedure TMessagesCtrl.FetchNewMessages; var i: Integer; begin if csDestroying in ComponentState then exit; BeginUpdate; try for i:=0 to ViewCount-1 do FetchNewMessages(Views[i]); finally EndUpdate; end; UpdateScrollBar(true); end; procedure TMessagesCtrl.FetchNewMessages(View: TLMsgWndView); var OldLineCount: Integer; LastLineWasVisible: Boolean; begin if csDestroying in ComponentState then exit; if IndexOfView(View)<0 then exit; LastLineWasVisible:=IsLastLineVisible(View); //debugln(['TMessagesCtrl.FetchNewMessages START ScrollTop=',ScrollTop,' ScrollTopMax=',ScrollTopMax,' Last=',View.GetShownLineCount(false,true),' LineTop=',GetLineTop(View,View.GetShownLineCount(false,true),true),' IsLastLineVisible=',IsLastLineVisible(View)]); OldLineCount:=View.Lines.Count; if (not View.Running) and LastLineWasVisible then AutoScrollToNewMessage:=true; // this view stoped running -> let other views take over the focus if not View.ApplyPending then exit; CreateSourceMarks(View,OldLineCount); UpdateScrollBar(true); Invalidate; if LastLineWasVisible or AutoScrollToNewMessage then begin // scroll to last line AutoScrollToNewMessage:=false; // avoid switching back and forth between two running Views ScrollToLine(View,View.GetShownLineCount(false,true),true); //debugln(['TMessagesCtrl.FetchNewMessages END ScrollTop=',ScrollTop,' ScrollTopMax=',ScrollTopMax,' Last=',View.GetShownLineCount(false,true),' LineTop=',GetLineTop(View,View.GetShownLineCount(false,true),true),' IsLastLineVisible=',IsLastLineVisible(View)]); end; end; procedure TMessagesCtrl.MsgUpdateTimerTimer(Sender: TObject); begin FUpdateTimer.Enabled:=false; FetchNewMessages; end; procedure TMessagesCtrl.SetBackgroundColor(AValue: TColor); begin if FBackgroundColor=AValue then Exit; FBackgroundColor:=AValue; Invalidate; end; procedure TMessagesCtrl.SetFilenameStyle(AValue: TMsgWndFileNameStyle); begin if FFilenameStyle=AValue then Exit; FFilenameStyle:=AValue; Invalidate; end; procedure TMessagesCtrl.SetHeaderBackground(aToolState: TLMVToolState; AValue: TColor); begin if FHeaderBackground[aToolState]=AValue then exit; FHeaderBackground[aToolState]:=AValue; Invalidate; end; procedure TMessagesCtrl.SetIdleConnected(AValue: boolean); begin if FIdleConnected=AValue then Exit; FIdleConnected:=AValue; if IdleConnected then Application.AddOnIdleHandler(@OnIdle) else Application.RemoveOnIdleHandler(@OnIdle); end; procedure TMessagesCtrl.SetImages(AValue: TCustomImageList); begin if FImages=AValue then Exit; if Images <> nil then Images.UnRegisterChanges(FImageChangeLink); FImages:=AValue; if Images <> nil then begin Images.RegisterChanges(FImageChangeLink); Images.FreeNotification(Self); if ItemHeight[] then Invalidate; if Assigned(OnOptionsChanged) then OnOptionsChanged(Self); end; procedure TMessagesCtrl.SetScrollLeft(AValue: integer); begin AValue:=Max(0,Min(AValue,ScrollLeftMax)); if FScrollLeft=AValue then Exit; FScrollLeft:=AValue; UpdateScrollBar(false); Invalidate; end; procedure TMessagesCtrl.SetScrollTop(AValue: integer); begin AValue:=Max(0,Min(AValue,ScrollTopMax)); if FScrollTop=AValue then Exit; FScrollTop:=AValue; UpdateScrollBar(false); Invalidate; end; procedure TMessagesCtrl.SetSearchText(AValue: string); begin if FSearchText=AValue then Exit; FSearchText:=AValue; IdleConnected:=true; end; procedure TMessagesCtrl.SetSelectedLine(AValue: integer); begin if AValue<-1 then AValue:=-1; if FSelectedLine=AValue then Exit; AValue:=Min(AValue,GetMaxSelectedLine); if FSelectedLine=AValue then Exit; FSelectedLine:=AValue; Invalidate; end; procedure TMessagesCtrl.SetSelectedView(AValue: TLMsgWndView); begin if FSelectedView=AValue then Exit; FSelectedView:=AValue; Invalidate; end; procedure TMessagesCtrl.SetSourceMarks(AValue: TETMarks); begin if FSourceMarks=AValue then Exit; FSourceMarks:=AValue; if SourceMarks<>nil then FreeNotification(SourceMarks); end; procedure TMessagesCtrl.SetUrgencyStyles(Urgency: TMessageLineUrgency; AValue: TMsgCtrlUrgencyStyle); begin fUrgencyStyles[Urgency].Assign(AValue); end; procedure TMessagesCtrl.SetAutoHeaderBackground(AValue: TColor); begin if FAutoHeaderBackground=AValue then Exit; FAutoHeaderBackground:=AValue; Invalidate; end; function TMessagesCtrl.UrgencyToStr(Urgency: TMessageLineUrgency): string; begin if (mcoShowTranslated in Options) and (fUrgencyStyles[Urgency].Translated<>'') then Result:=fUrgencyStyles[Urgency].Translated else Result:=MessageLineUrgencyNames[Urgency]; end; procedure TMessagesCtrl.WMHScroll(var Msg: TLMScroll); begin case Msg.ScrollCode of // Scrolls to start / end of the line SB_TOP: ScrollLeft := 1; SB_BOTTOM: ScrollLeft := ScrollLeftMax; // Scrolls one char left / right SB_LINEDOWN: ScrollLeft := ScrollLeft + 1; SB_LINEUP: ScrollLeft := ScrollLeft - 1; // Scrolls one page of chars left / right SB_PAGEDOWN: ScrollLeft := ScrollLeft + (ClientWidth div 2); SB_PAGEUP: ScrollLeft := ScrollLeft - (ClientHeight div 2); // Scrolls to the current scroll bar position SB_THUMBPOSITION, SB_THUMBTRACK: ScrollLeft := Msg.Pos; end; end; procedure TMessagesCtrl.WMVScroll(var Msg: TLMScroll); begin case Msg.ScrollCode of // Scrolls to start / end of the text SB_TOP: ScrollTop := 0; SB_BOTTOM: ScrollTop := ScrollTopMax; // Scrolls one line up / down SB_LINEDOWN: ScrollTop := ScrollTop + ItemHeight div 2; SB_LINEUP: ScrollTop := ScrollTop - ItemHeight div 2; // Scrolls one page of lines up / down SB_PAGEDOWN: ScrollTop := ScrollTop + ClientHeight - ItemHeight; SB_PAGEUP: ScrollTop := ScrollTop - ClientHeight + ItemHeight; // Scrolls to the current scroll bar position SB_THUMBPOSITION, SB_THUMBTRACK: ScrollTop := Msg.Pos; // Ends scrolling SB_ENDSCROLL: SetCaptureControl(nil); // release scrollbar capture end; end; procedure TMessagesCtrl.WMMouseWheel(var Message: TLMMouseEvent); begin if Mouse.WheelScrollLines=-1 then begin // -1 : scroll by page ScrollTop := ScrollTop - (Message.WheelDelta * (ClientHeight - ItemHeight)) div 120; end else begin // scrolling one line -> scroll half an item, see SB_LINEDOWN and SB_LINEUP // handler in WMVScroll ScrollTop := ScrollTop - (Message.WheelDelta * Mouse.WheelScrollLines*ItemHeight) div 240; end; Message.Result := 1; end; procedure TMessagesCtrl.WMSetFocus(var Message: TLMSetFocus); begin Invalidate; inherited; end; procedure TMessagesCtrl.WMKillFocus(var Message: TLMKillFocus); begin Invalidate; inherited; end; function TMessagesCtrl.GetMaxSelectedLine: integer; var View: TLMsgWndView; begin View:=SelectedView; if View<>nil then Result:=View.GetShownLineCount(false,true)-1 else Result:=-1; end; procedure TMessagesCtrl.ImageListChange(Sender: TObject); begin Invalidate; end; procedure TMessagesCtrl.OnIdle(Sender: TObject; var Done: Boolean); var View: TLMsgWndView; LineNumber: integer; i: Integer; begin //debugln(['TMessagesCtrl.OnIdle fLastLoSearchText=',fLastLoSearchText,' ',UTF8LowerCase(fSearchText)]); for i:=0 to ViewCount-1 do begin View:=Views[i]; if not View.Filter.IsEqual(ActiveFilter) then begin View.EnterCriticalSection; try View.Filter:=ActiveFilter; finally View.LeaveCriticalSection; end; View.RebuildLines; CreateSourceMarks(View,0); UpdateScrollBar(true); Invalidate; end; end; if fLastLoSearchText<>UTF8LowerCase(fSearchText) then begin fLastLoSearchText:=UTF8LowerCase(FSearchText); if SearchNext(fLastSearchStartView,fLastSearchStartLine,false,true, View,LineNumber) then begin //debugln(['TMessagesCtrl.OnIdle search text found ',LineNumber]); Select(View,LineNumber,true,true); end else begin //debugln(['TMessagesCtrl.OnIdle search text not found']); end; Invalidate; end; IdleConnected:=false; end; procedure TMessagesCtrl.OnFilterChanged(Sender: TObject); begin IdleConnected:=true; end; function TMessagesCtrl.GetSelectedLine: integer; var View: TLMsgWndView; begin View:=SelectedView; if View<>nil then begin Result:=FSelectedLine; if Result>=0 then Result:=Min(FSelectedLine,GetMaxSelectedLine); end else begin Result:=-1; end; FSelectedLine:=Result; end; procedure TMessagesCtrl.CreateSourceMarks(View: TLMsgWndView; StartLineNumber: Integer); var i: Integer; begin if SourceMarks=nil then exit; for i:=StartLineNumber to View.Lines.Count-1 do CreateSourceMark(View.Lines[i],nil); end; function TMessagesCtrl.GetHeaderBackground(aToolState: TLMVToolState): TColor; begin Result:=FHeaderBackground[aToolState]; end; procedure TMessagesCtrl.CreateSourceMark(MsgLine: TMessageLine; aSynEdit: TSynEdit); var SourceMark: TETMark; begin if TLMsgViewLine(MsgLine).Mark<>nil then exit; if ord(MsgLine.Urgency)=0) then begin if fLastSearchStartView=AComponent then fLastSearchStartView:=nil; if SelectedView=AComponent then FSelectedView:=nil; RemoveView(TLMsgWndView(AComponent)); end else if AComponent=Images then Images:=nil else if AComponent=SourceMarks then SourceMarks:=nil; end; end; procedure TMessagesCtrl.Paint; var LoSearchText: string; procedure DrawText(ARect: TRect; aTxt: string; IsSelected: boolean; TxtColor: TColor); var Details: TThemedElementDetails; TextRect: TRect; p: SizeInt; LoTxt: String; aLeft: Integer; aRight: Integer; LastP: Integer; begin Canvas.Font.Color:=Font.Color; TextRect:=ARect; TextRect.Right:=TextRect.Left+Canvas.TextWidth(aTxt)+2; if IsSelected then begin if (mcsFocused in FStates) or (mcoAlwaysDrawFocused in Options) then Details := ThemeServices.GetElementDetails(ttItemSelected) else Details := ThemeServices.GetElementDetails(ttItemSelectedNotFocus); ThemeServices.DrawElement(Canvas.Handle, Details, TextRect, nil); TxtColor:=clDefault; end else Details := ThemeServices.GetElementDetails(ttItemNormal); if LoSearchText<>'' then begin LoTxt:=UTF8LowerCase(aTxt); p:=1; LastP:=1; while p<=length(LoTxt) do begin p:=PosEx(LoSearchText,LoTxt,LastP); if p<1 then break; Canvas.Brush.Color:=clHighlight; aLeft:=TextRect.Left+Canvas.TextWidth(copy(ATxt,1,p-1)); aRight:=aLeft+Canvas.TextWidth(copy(ATxt,p,length(LoSearchText))); Canvas.FillRect(aLeft,TextRect.Top+1,aRight,TextRect.Bottom-1); LastP:=p+length(LoSearchText); end; Canvas.Brush.Color:=BackgroundColor; end; if TxtColor=clDefault then ThemeServices.DrawText(Canvas, Details, ATxt, TextRect, DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX, 0) else begin p:=(TextRect.Top+TextRect.Bottom-Canvas.TextHeight('Mg')) div 2; Canvas.Font.Color:=TxtColor; Canvas.TextOut(TextRect.Left+2,p,ATxt); end; end; var i: Integer; View: TLMsgWndView; y: Integer; j: Integer; Line: TMessageLine; Indent: Integer; NodeRect: TRect; ImgIndex: LongInt; IsSelected: Boolean; FirstLineIsNotSelectedMessage: Boolean; SecondLineIsNotSelectedMessage: Boolean; begin if Focused then Include(FStates,mcsFocused) else Exclude(FStates,mcsFocused); //debugln(['TMessagesCtrl.Paint ',Focused,' CanFocus=',CanFocus,' TabStop=',TabStop]); LUIncreaseChangeStamp64(FPaintStamp); // paint background Canvas.Brush.Color:=BackgroundColor; Canvas.FillRect(0,0,ClientWidth,ClientHeight); Indent:=BorderWidth+2; LoSearchText:=fLastLoSearchText; // paint from top to bottom y:=-ScrollTop; for i:=0 to ViewCount-1 do begin if y>ClientHeight then break; View:=Views[i]; if not View.HasContent then continue; View.FPaintStamp:=FPaintStamp; View.fPaintTop:=y; // draw header if (y+ItemHeight>0) and (y-ItemHeight) and (y<=0) then FirstLineIsNotSelectedMessage:=true else if (y>0) and (y<=ItemHeight) then SecondLineIsNotSelectedMessage:=true; end; ImgIndex:=fUrgencyStyles[Line.Urgency].ImageIndex; if (Images<>nil) and (mcoShowMsgIcons in Options) and (ImgIndex>=0) and (ImgIndex paint view header hint NodeRect:=Rect(0,0,ClientWidth,ItemHeight div 2); Canvas.Brush.Color:=HeaderBackground[View.ToolState]; Canvas.Brush.Style:=bsSolid; Canvas.FillRect(NodeRect); NodeRect:=Rect(0,NodeRect.Bottom,ClientWidth,ItemHeight); Canvas.GradientFill(NodeRect,HeaderBackground[View.ToolState], AutoHeaderBackground,gdVertical); Canvas.Pen.Style:=psDash; NodeRect:=Rect(0,0,ClientWidth,ItemHeight); Canvas.Line(NodeRect.Left,NodeRect.Bottom,NodeRect.Right,NodeRect.Bottom); Canvas.Pen.Style:=psSolid; DrawText(NodeRect,'...'+GetHeaderText(View),false,clDefault); Canvas.Brush.Color:=BackgroundColor; end; inc(y,ItemHeight*(View.Lines.Count-j)); // draw progress line if View.ProgressLine.Msg<>'' then begin if (y+ItemHeight>0) and (y ScrollTopMax then ScrollTop := ScrollTopMax; ScrollInfo.nPos := ScrollTop; //debugln(['TMessagesCtrl.UpdateScrollBar ScrollTop=',ScrollTop,' ScrollTopMax=',ScrollTopMax]); ShowScrollBar(Handle, SB_VERT, True); SetScrollInfo(Handle, SB_VERT, ScrollInfo, false); end; procedure TMessagesCtrl.CreateWnd; begin inherited CreateWnd; ItemHeight:=Canvas.TextHeight('Mg')+2; UpdateScrollBar(false); end; procedure TMessagesCtrl.DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); begin inherited DoSetBounds(ALeft, ATop, AWidth, AHeight); UpdateScrollBar(true); end; procedure TMessagesCtrl.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited MouseMove(Shift, X, Y); //Application.HideHint; end; procedure TMessagesCtrl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var View: TLMsgWndView; LineNumber: integer; begin if not Focused and CanFocus then SetFocus; inherited MouseDown(Button, Shift, X, Y); if Button=mbLeft then begin if GetLineAt(Y,View,LineNumber) then begin SelectedView:=View; SelectedLine:=LineNumber; StoreSelectedAsSearchStart; if ((ssDouble in Shift) and (not (mcoSingleClickOpensFile in FOptions))) or ((mcoSingleClickOpensFile in FOptions) and ([ssDouble,ssTriple,ssQuad]*Shift=[])) then OpenSelection; end else begin end; end; end; procedure TMessagesCtrl.KeyDown(var Key: Word; Shift: TShiftState); begin inherited KeyDown(Key, Shift); case Key of VK_DOWN: begin SelectNextShown(+1); Key:=VK_UNKNOWN; end; VK_UP: begin SelectNextShown(-1); Key:=VK_UNKNOWN; end; VK_HOME: begin SelectFirst(true,true); Key:=VK_UNKNOWN; end; VK_END: begin SelectLast(true,true); Key:=VK_UNKNOWN; end; VK_PRIOR: // Page Up begin SelectNextShown(-1-Max(0,ClientHeight div ItemHeight)); Key:=VK_UNKNOWN; end; VK_NEXT: // Page Down begin SelectNextShown(1+Max(0,ClientHeight div ItemHeight)); Key:=VK_UNKNOWN; end; end; end; procedure TMessagesCtrl.DoOnShowHint(HintInfo: PHintInfo); var View: TLMsgWndView; Line: integer; MsgLine: TMessageLine; s: String; begin if GetLineAt(HintInfo^.CursorPos.Y,View,Line) then begin MsgLine:=nil; if Line<0 then s:=GetHeaderText(View) else if Linenil then begin s:=GetLineText(MsgLine); s+=LineEnding+LineEnding; s+=ExternalToolList.GetMsgHint(MsgLine.SubTool,MsgLine.MsgID); end; HintInfo^.HintStr:=s; HintInfo^.ReshowTimeout:=0; HintInfo^.HideTimeout:=5000; end; inherited DoOnShowHint(HintInfo); end; procedure TMessagesCtrl.DoAllViewsStopped; var CurLine: TMessageLine; begin if Assigned(OnAllViewsStopped) then OnAllViewsStopped(Self); if mcoAutoOpenFirstError in Options then begin CurLine:=GetSelectedMsg; if (CurLine<>nil) and (CurLine.Urgency>=mluError) and CurLine.HasSourcePosition then exit; if SelectFirstUrgentMessage(mluError,true) then OpenSelection; end; end; function TMessagesCtrl.SearchNext(StartView: TLMsgWndView; StartLine: integer; SkipStart, Downwards: boolean; out View: TLMsgWndView; out LineNumber: integer ): boolean; var CurView: TLMsgWndView; CurLine: Integer; CurViewLineCnt: integer; Txt: String; function Next: boolean; var i: Integer; begin if Downwards then begin inc(CurLine); if CurLine>=CurViewLineCnt then begin i:=IndexOfView(CurView); repeat inc(i); if i>=ViewCount then exit(false); CurView:=Views[i]; until CurView.HasContent; CurLine:=-1; CurViewLineCnt:=CurView.GetShownLineCount(true,true); end; end else begin dec(CurLine); if CurLine<-1 then begin i:=IndexOfView(CurView); repeat dec(i); if i<0 then exit(false); CurView:=Views[i]; until CurView.HasContent; CurViewLineCnt:=CurView.GetShownLineCount(true,true); CurLine:=CurViewLineCnt-1; end; end; Result:=true; end; begin Result:=false; View:=nil; LineNumber:=-1; if ViewCount=0 then exit; if StartView=nil then begin // use default start if Downwards then begin StartView:=Views[0]; StartLine:=-1; end else begin StartView:=Views[ViewCount-1]; StartLine:=StartView.GetShownLineCount(true,true); end; end; CurView:=StartView; CurLine:=StartLine; CurViewLineCnt:=CurView.GetShownLineCount(true,true); // skip invalid line numbers if CurLine<-1 then begin SkipStart:=false; if Downwards then CurLine:=-1 else if not Next then exit; end else if CurLine>=CurViewLineCnt then begin SkipStart:=false; if Downwards then begin if not Next then exit; end else CurLine:=CurViewLineCnt-1; end; // skip invalid views if not CurView.HasContent then begin SkipStart:=false; if not Next then exit; end; // skip start if SkipStart then if not Next then exit; // search repeat if CurLine<0 then Txt:=GetHeaderText(CurView) else if CurLine0 then begin View:=CurView; LineNumber:=CurLine; exit(true); end; until not Next; end; procedure TMessagesCtrl.Select(Msg: TMessageLine; DoScroll: boolean); begin BeginUpdate; if (Msg=nil) or (Msg.Lines=nil) or (not (Msg.Lines.Owner is TLMsgWndView)) then begin SelectedView:=nil; SelectedLine:=-1; end else begin SelectedView:=TLMsgWndView(Msg.Lines.Owner); SelectedLine:=Msg.Index; if DoScroll then ScrollToLine(SelectedView,SelectedLine,true); end; EndUpdate; end; function TMessagesCtrl.SelectNextOccurence(Downwards: boolean): boolean; var View: TLMsgWndView; LineNumber: integer; begin StoreSelectedAsSearchStart; Result:=SearchNext(SelectedView,SelectedLine,true,Downwards,View,LineNumber); if not Result then exit; Select(View,LineNumber,true,true); end; function TMessagesCtrl.SelectNextShown(Offset: integer): boolean; // returns true if selection changed var View: TLMsgWndView; Line: Integer; i: Integer; begin Result:=false; {$IFDEF VerboseMsgCtrlSelectNextShown} debugln(['TMessagesCtrl.SelectNextShown START']); {$ENDIF} while Offset<>0 do begin {$IFDEF VerboseMsgCtrlSelectNextShown} debugln(['TMessagesCtrl.SelectNextShown LOOP Offset=',Offset,' ViewIndex=',IndexOfView(SelectedView),' Line=',SelectedLine]); {$ENDIF} if SelectedView=nil then begin if Offset>0 then begin SelectFirst(true,true); dec(Offset); end else begin SelectLast(true,true); Inc(Offset); end; Result:=true; end else begin View:=SelectedView; Line:=SelectedLine; if Offset>0 then begin {$IFDEF VerboseMsgCtrlSelectNextShown} debugln(['TMessagesCtrl.SelectNextShown NEXT View.GetShownLineCount(false,true)=',View.GetShownLineCount(false,true),' ',' ViewIndex=',IndexOfView(View),' Line=',Line]); {$ENDIF} inc(Line,Offset); if Line=-1 then Offset:=0 else begin // previous view Offset:=Line+2; i:=IndexOfView(View); repeat dec(i); if i<0 then begin {$IFDEF VerboseMsgCtrlSelectNextShown} debugln(['TMessagesCtrl.SelectNextShown can not go further up']); {$ENDIF} exit; end; View:=Views[i]; until View.HasContent; Line:=View.GetShownLineCount(true,true)-1; end; end; {$IFDEF VerboseMsgCtrlSelectNextShown} debugln(['TMessagesCtrl.SelectNextShown SELECT Offset=',Offset,' ViewIndex=',IndexOfView(View),' Line=',Line]); {$ENDIF} Select(View,Line,true,true); Result:=true; end; end; {$IFDEF VerboseMsgCtrlSelectNextShown} debugln(['TMessagesCtrl.SelectNextShown END ViewIndex=',IndexOfView(SelectedView),' Line=',SelectedLine]); {$ENDIF} end; function TMessagesCtrl.SelectLast(DoScroll, FullyVisible: boolean): boolean; var i: Integer; begin i:=ViewCount-1; while (i>=0) do begin if Views[i].HasContent then begin Select(Views[i],Views[i].GetShownLineCount(true,true)-1,DoScroll,FullyVisible); exit(true); end; dec(i); end; Result:=false; end; function TMessagesCtrl.SelectFirst(DoScroll, FullyVisible: boolean): boolean; var i: Integer; begin i:=0; while (i'') then Result:=View.ProgressLine; end; function TMessagesCtrl.SearchNextUrgent(StartView: TLMsgWndView; StartLine: integer; SkipStart, Downwards: boolean; aMinUrgency: TMessageLineUrgency; WithSrcPos: boolean; out View: TLMsgWndView; out LineNumber: integer): boolean; var CurView: TLMsgWndView; CurLine: Integer; CurViewLineCnt: integer; MsgLine: TMessageLine; function Next: boolean; var i: Integer; begin if Downwards then begin inc(CurLine); if CurLine>=CurViewLineCnt then begin i:=IndexOfView(CurView); repeat inc(i); if i>=ViewCount then exit(false); CurView:=Views[i]; until CurView.HasContent; CurLine:=-1; CurViewLineCnt:=CurView.GetShownLineCount(true,true); end; end else begin dec(CurLine); if CurLine<-1 then begin i:=IndexOfView(CurView); repeat dec(i); if i<0 then exit(false); CurView:=Views[i]; until CurView.HasContent; CurViewLineCnt:=CurView.GetShownLineCount(true,true); CurLine:=CurViewLineCnt-1; end; end; Result:=true; end; begin Result:=false; View:=nil; LineNumber:=-1; if ViewCount=0 then exit; if StartView=nil then begin // use default start if Downwards then begin StartView:=Views[0]; StartLine:=-1; end else begin StartView:=Views[ViewCount-1]; StartLine:=StartView.GetShownLineCount(true,true); end; end; CurView:=StartView; CurLine:=StartLine; CurViewLineCnt:=CurView.GetShownLineCount(true,true); // skip invalid line numbers if CurLine<-1 then begin SkipStart:=false; if Downwards then CurLine:=-1 else if not Next then exit; end else if CurLine>=CurViewLineCnt then begin SkipStart:=false; if Downwards then begin if not Next then exit; end else CurLine:=CurViewLineCnt-1; end; // skip invalid views if not CurView.HasContent then begin SkipStart:=false; if not Next then exit; end; // skip start if SkipStart then if not Next then exit; // search repeat if (CurLine>=0) and (CurLine=aMinUrgency then begin if (not WithSrcPos) or MsgLine.HasSourcePosition then begin View:=CurView; LineNumber:=CurLine; exit(true); end; end; end; until not Next; end; function TMessagesCtrl.SelectFirstUrgentMessage( aMinUrgency: TMessageLineUrgency; WithSrcPos: boolean): boolean; var View: TLMsgWndView; LineNumber: integer; begin Result:=false; if ViewCount=0 then exit; if not SearchNextUrgent(nil,0,false,true,aMinUrgency,WithSrcPos,View,LineNumber) then exit; Select(View,LineNumber,true,true); Result:=true; end; function TMessagesCtrl.SelectNextUrgentMessage( aMinUrgency: TMessageLineUrgency; WithSrcPos: boolean; Downwards: boolean ): boolean; var View: TLMsgWndView; LineNumber: integer; begin Result:=false; if not SearchNextUrgent(SelectedView,SelectedLine,true,Downwards, aMinUrgency,WithSrcPos,View,LineNumber) then exit; Select(View,LineNumber,true,true); Result:=true; end; function TMessagesCtrl.IsLineVisible(View: TLMsgWndView; LineNumber: integer ): boolean; var y: Integer; begin Result:=false; if View=nil then exit; y:=GetLineTop(View,LineNumber,true); if (y+ItemHeight>0) and (y0 then begin Result+='('+IntToStr(Line.Line)+','+IntToStr(Line.Column)+')'; end; if Result<>'' then Result+=' '; // 'error: ' if Line.Urgency<>mluImportant then Result+=UrgencyToStr(Line.Urgency)+': '; // message id if (mcoShowMessageID in Options) and (Line.MsgID<>0) then Result+='('+IntToStr(Line.MsgID)+') '; // message if (mcoShowTranslated in Options) and (Line.TranslatedMsg<>'') then Result+=Line.TranslatedMsg else Result+=Line.Msg; end; function TMessagesCtrl.GetHeaderText(View: TLMsgWndView): string; function GetStats(Lines: TMessageLines): string; var ErrCnt: Integer; WarnCnt: Integer; HintCnt: Integer; c: TMessageLineUrgency; begin Result:=''; ErrCnt:=0; WarnCnt:=0; HintCnt:=0; for c:=Low(Lines.UrgencyCounts) to high(Lines.UrgencyCounts) do begin //debugln(['GetStats cat=',dbgs(c),' count=',Lines.UrgencyCounts[c]]); if c>=mluError then inc(ErrCnt,Lines.UrgencyCounts[c]) else if c=mluWarning then inc(WarnCnt,Lines.UrgencyCounts[c]) else if c in [mluHint,mluNote] then inc(HintCnt,Lines.UrgencyCounts[c]); end; if ErrCnt>0 then Result+=Format(lisErrors2, [IntToStr(ErrCnt)]); if WarnCnt>0 then Result+=Format(lisWarnings, [IntToStr(WarnCnt)]); if HintCnt>0 then Result+=Format(lisHints, [IntToStr(HintCnt)]); end; begin Result:=View.Caption; if Result='' then Result:=lisMenuViewMessages; if View.SummaryMsg<>'' then Result+=': '+View.SummaryMsg; if mcoShowStats in Options then begin Result+=GetStats(View.Lines); end; end; function TMessagesCtrl.FindUnfinishedView: TLMsgWndView; var i: Integer; begin for i:=0 to ViewCount-1 do begin Result:=Views[i]; //debugln(['TMessagesCtrl.FindUnfinishedView ',i,' ',ViewCount,' caption="',Result.Caption,'" Result.Tool=',dbgsname(Result.Tool)]); if not Result.HasFinished then exit; end; Result:=nil; end; function TMessagesCtrl.GetLastViewWithContent: TLMsgWndView; var i: Integer; begin i:=ViewCount-1; while i>=0 do begin Result:=Views[i]; if Result.HasContent then exit; dec(i); end; Result:=nil; end; procedure TMessagesCtrl.Select(View: TLMsgWndView; LineNumber: integer; DoScroll, FullyVisible: boolean); begin BeginUpdate; SelectedView:=View; SelectedLine:=LineNumber; if DoScroll then ScrollToLine(SelectedView,SelectedLine,FullyVisible); EndUpdate; end; procedure TMessagesCtrl.ScrollToLine(View: TLMsgWndView; LineNumber: integer; FullyVisible: boolean); var y: Integer; MinScrollTop: integer; MaxScrollTop: Integer; begin y:=GetLineTop(View,LineNumber,false); if FullyVisible then begin MinScrollTop:=Max(0,y+ItemHeight-ClientHeight); MaxScrollTop:=y; end else begin MinScrollTop:=Max(0,y-1-ClientHeight); MaxScrollTop:=y+ItemHeight-1; end; //debugln(['TMessagesCtrl.ScrollToLine ',LineNumber,' y=',y,' Min=',MinScrollTop,' Max=',MaxScrollTop]); y:=Max(Min(ScrollTop,MaxScrollTop),MinScrollTop); //debugln(['TMessagesCtrl.ScrollToLine y=',y,' ScrollTopMax=',ScrollTopMax]); ScrollTop:=y; end; function TMessagesCtrl.GetLineTop(View: TLMsgWndView; LineNumber: integer; Scrolled: boolean): integer; var i: Integer; CurView: TLMsgWndView; begin Result:=0; if View=nil then exit; for i:=0 to ViewCount-1 do begin CurView:=Views[i]; if CurView=View then break; inc(Result,ItemHeight*CurView.GetShownLineCount(true,true)); end; if LineNumber<0 then begin // header end else if LineNumber=ViewCount then continue; View:=Views[i]; if View.HasFinished then View.Free; end; end else begin while ViewCount>0 do Views[0].Free; end; end; procedure TMessagesCtrl.RemoveView(View: TLMsgWndView); begin if FViews.IndexOf(View)<0 then exit; FViews.Remove(View); View.FControl:=nil; View.OnChanged:=nil; if fLastSearchStartView=View then fLastSearchStartView:=nil; if SelectedView=View then SelectedView:=nil; UpdateScrollBar(true); Invalidate; end; function TMessagesCtrl.GetView(aCaption: string; CreateIfNotExist: boolean ): TLMsgWndView; var i: Integer; begin for i:=0 to ViewCount-1 do begin Result:=Views[i]; if UTF8CompareStr(aCaption,Result.Caption)=0 then exit; end; if not CreateIfNotExist then exit(nil); Result:=TLMsgWndView.Create(Self); Result.FControl:=Self; Result.Caption:=aCaption; Result.Filter.Assign(ActiveFilter); FViews.Add(Result); FreeNotification(Result); Result.OnChanged:=@OnViewChanged; fSomeViewsRunning:=true; end; function TMessagesCtrl.GetLineAt(Y: integer; out View: TLMsgWndView; out Line: integer): boolean; var i: Integer; begin for i:=0 to ViewCount-1 do begin View:=Views[i]; if View.FPaintStamp<>FPaintStamp then continue; if (View.fPaintTop>Y) or (View.fPaintBottom0; // delete old menu items while MsgRemoveCompOptHideMenuSection.Count>Cnt do MsgRemoveCompOptHideMenuSection[Cnt].Free; end; procedure UpdateRemoveMsgTypeFilterItems; var FilterItem: TLMVFilterMsgType; i: Integer; Item: TIDEMenuCommand; Cnt: Integer; begin // create one menuitem per filter item Cnt:=MessagesCtrl.ActiveFilter.FilterMsgTypeCount; MsgRemoveMsgTypeFilterMenuSection.Visible:=Cnt>0; for i:=0 to Cnt-1 do begin if i>=MsgRemoveFilterMsgOneTypeMenuSection.Count then begin Item:=RegisterIDEMenuCommand(MsgRemoveFilterMsgOneTypeMenuSection,'MsgRemoveMsgOfTypeFilter'+IntToStr(i),''); Item.Tag:=i; Item.OnClick:=@RemoveFilterMsgTypeClick; end else Item:=MsgRemoveFilterMsgOneTypeMenuSection.Items[i] as TIDEMenuCommand; FilterItem:=MessagesCtrl.ActiveFilter.FilterMsgTypes[i]; Item.Caption:=GetMsgPattern(FilterItem.SubTool,FilterItem.MsgID,true,40); end; // delete old menu items while MsgRemoveFilterMsgOneTypeMenuSection.Count>Cnt do MsgRemoveFilterMsgOneTypeMenuSection[Cnt].Free; MsgRemoveFilterAllMsgTypesMenuItem.OnClick:=@ClearFilterMsgTypesMenuItemClick; end; procedure UpdateFilterItems; var i: Integer; Filter: TLMsgViewFilter; Item: TIDEMenuCommand; Cnt: Integer; begin Cnt:=MessagesCtrl.Filters.Count; for i:=0 to Cnt-1 do begin Filter:=MessagesCtrl.Filters[i]; if i>=MsgSelectFilterMenuSection.Count then begin Item:=RegisterIDEMenuCommand(MsgSelectFilterMenuSection,'MsgSelectFilter'+IntToStr(i),''); Item.Tag:=i; Item.OnClick:=@OnSelectFilterClick; end else Item:=MsgSelectFilterMenuSection[i] as TIDEMenuCommand; Item.Caption:=Filter.Caption; Item.Checked:=Filter=MessagesCtrl.ActiveFilter; end; // delete old menu items while MsgSelectFilterMenuSection.Count>Cnt do MsgSelectFilterMenuSection[Cnt].Free; MsgAddFilterMenuItem.OnClick:=@AddFilterMenuItemClick; end; procedure UpdateQuickFixes(CurLine: TMessageLine); begin // delete old MsgQuickFixMenuSection.Clear; // create items if CurLine<>nil then begin IDEQuickFixes.SetMsgLines(CurLine); IDEQuickFixes.OnPopupMenu(MsgQuickFixMenuSection); end; MsgQuickFixMenuSection.Visible:=MsgQuickFixMenuSection.Count>0; end; var HasText: Boolean; View: TLMsgWndView; HasFilename: Boolean; LineNumber: Integer; Line: TMessageLine; i: Integer; HasViewContent: Boolean; Running: Boolean; MsgType: String; CanFilterMsgType: Boolean; MinUrgency: TMessageLineUrgency; ToolData: TIDEExternalToolData; ToolOptionsCaption: String; VisibleCnt: Integer; begin MessagesMenuRoot.MenuItem:=MsgCtrlPopupMenu.Items; MessagesMenuRoot.BeginUpdate; try HasText:=false; HasFilename:=false; MsgType:=''; CanFilterMsgType:=false; Line:=nil; HasViewContent:=false; Running:=false; // check all for i:=0 to MessagesCtrl.ViewCount-1 do begin View:=MessagesCtrl.Views[i]; if View.HasContent then HasViewContent:=true; if View.Running then Running:=true; end; MsgFindMenuItem.OnClick:=@FindMenuItemClick; // check selection View:=MessagesCtrl.SelectedView; if View<>nil then begin LineNumber:=MessagesCtrl.SelectedLine; if LineNumber>=0 then begin Line:=View.Lines[LineNumber]; HasFilename:=Line.Filename<>''; HasText:=Line.Msg<>''; if (Line.SubTool<>'') and (Line.MsgID<>0) then begin MsgType:=GetMsgPattern(Line.SubTool,Line.MsgID,true,40); CanFilterMsgType:=ord(Line.Urgency) use last visible View View:=MessagesCtrl.GetLastViewWithContent; end; ToolOptionsCaption:=''; // About if View<>nil then begin MsgAboutToolMenuItem.Caption:=Format(lisAbout2, [View.Caption]); MsgAboutSection.Visible:=true; if View.Tool.Data is TIDEExternalToolData then begin ToolData:=TIDEExternalToolData(View.Tool.Data); if ToolData.Kind=IDEToolCompilePackage then ToolOptionsCaption:=Format(lisCPOpenPackage, [ToolData.ModuleName]); end; end else MsgAboutSection.Visible:=false; MsgAboutToolMenuItem.OnClick:=@AboutToolMenuItemClick; VisibleCnt:=1; MsgOpenToolOptionsMenuItem.Visible:=ToolOptionsCaption<>''; if MsgOpenToolOptionsMenuItem.Visible then inc(VisibleCnt); MsgOpenToolOptionsMenuItem.Caption:=ToolOptionsCaption; MsgOpenToolOptionsMenuItem.OnClick:=@OpenToolsOptionsMenuItemClick; MsgAboutSection.ChildsAsSubMenu:=VisibleCnt>1; // Filtering if CanFilterMsgType then begin MsgFilterMsgOfTypeMenuItem.Caption:=Format(lisFilterAllMessagesOfType, [ MsgType]); MsgFilterMsgOfTypeMenuItem.Visible:=true; end else begin MsgFilterMsgOfTypeMenuItem.Visible:=false; end; MsgFilterMsgOfTypeMenuItem.OnClick:=@FilterMsgOfTypeMenuItemClick; MsgFilterHintsWithoutPosMenuItem.Checked:=MessagesCtrl.ActiveFilter.FilterNotesWithoutPos; MsgFilterHintsWithoutPosMenuItem.OnClick:=@FilterHintsWithoutPosMenuItemClick; MinUrgency:=MessagesCtrl.ActiveFilter.MinUrgency; MsgFilterNoneMenuItem.Checked:=MinUrgency in [mluNone..mluDebug]; MsgFilterNoneMenuItem.OnClick:=@FilterUrgencyMenuItemClick; MsgFilterDebugMenuItem.Checked:=MinUrgency in [mluVerbose3..mluVerbose]; MsgFilterDebugMenuItem.OnClick:=@FilterUrgencyMenuItemClick; MsgFilterVerboseMenuItem.Checked:=MinUrgency=mluHint; MsgFilterVerboseMenuItem.OnClick:=@FilterUrgencyMenuItemClick; MsgFilterHintsMenuItem.Checked:=MinUrgency=mluNote; MsgFilterHintsMenuItem.OnClick:=@FilterUrgencyMenuItemClick; MsgFilterNotesMenuItem.Checked:=MinUrgency in [mluWarning..mluImportant]; MsgFilterNotesMenuItem.OnClick:=@FilterUrgencyMenuItemClick; MsgFilterWarningsMenuItem.Checked:=MinUrgency>=mluError; MsgFilterWarningsMenuItem.OnClick:=@FilterUrgencyMenuItemClick; // Copying MsgCopyMsgMenuItem.Enabled:=HasText; MsgCopyMsgMenuItem.OnClick:=@CopyMsgMenuItemClick; MsgCopyFilenameMenuItem.Enabled:=HasFilename; MsgCopyFilenameMenuItem.OnClick:=@CopyFilenameMenuItemClick; MsgCopyAllMenuItem.Enabled:=not Running; MsgCopyAllMenuItem.OnClick:=@CopyAllMenuItemClick; MsgCopyShownMenuItem.Enabled:=HasViewContent; MsgCopyShownMenuItem.OnClick:=@CopyShownMenuItemClick; // Saving MsgSaveAllToFileMenuItem.Enabled:=not Running; MsgSaveAllToFileMenuItem.OnClick:=@SaveAllToFileMenuItemClick; MsgSaveShownToFileMenuItem.Enabled:=HasViewContent; MsgSaveShownToFileMenuItem.OnClick:=@SaveShownToFileMenuItemClick; MsgHelpMenuItem.Enabled:=HasText; MsgHelpMenuItem.OnClick:=@HelpMenuItemClick; MsgEditHelpMenuItem.OnClick:=@EditHelpMenuItemClick; MsgClearMenuItem.OnClick:=@ClearMenuItemClick; MsgClearMenuItem.Enabled:=View<>nil; // Options MsgWndStayOnTopMenuItem.Checked:=mcoWndStayOnTop in MessagesCtrl.Options; MsgWndStayOnTopMenuItem.OnClick:=@WndStayOnTopMenuItemClick; MsgFileStyleShortMenuItem.Checked:=MessagesCtrl.FilenameStyle=mwfsShort; MsgFileStyleShortMenuItem.OnClick:=@FileStyleMenuItemClick; MsgFileStyleRelativeMenuItem.Checked:=MessagesCtrl.FilenameStyle=mwfsRelative; MsgFileStyleRelativeMenuItem.OnClick:=@FileStyleMenuItemClick; MsgFileStyleFullMenuItem.Checked:=MessagesCtrl.FilenameStyle=mwfsFull; MsgFileStyleFullMenuItem.OnClick:=@FileStyleMenuItemClick; MsgTranslateMenuItem.Checked:=mcoShowTranslated in MessagesCtrl.Options; MsgTranslateMenuItem.OnClick:=@TranslateMenuItemClick; MsgShowIDMenuItem.Checked:=mcoShowMessageID in MessagesCtrl.Options; MsgShowIDMenuItem.OnClick:=@ShowIDMenuItemClick; UpdateRemoveCompOptHideMsgItems; UpdateRemoveMsgTypeFilterItems; UpdateFilterItems; UpdateQuickFixes(Line); finally MessagesMenuRoot.EndUpdate; end; end; procedure TMessagesFrame.OnSelectFilterClick(Sender: TObject); var Filter: TLMsgViewFilter; Item: TIDEMenuCommand; begin Item:=Sender as TIDEMenuCommand; Filter:=MessagesCtrl.Filters.GetFilter(Item.Caption,false); if Filter=nil then exit; MessagesCtrl.ActiveFilter:=Filter; end; procedure TMessagesFrame.OpenToolsOptionsMenuItemClick(Sender: TObject); var View: TLMsgWndView; ToolData: TIDEExternalToolData; begin View:=GetAboutView; if View=nil then exit; ToolData:=TIDEExternalToolData(View.Tool.Data); if not (ToolData is TIDEExternalToolData) then exit; if ToolData.Kind=IDEToolCompilePackage then begin PackageEditingInterface.DoOpenPackageFile(ToolData.Filename, [pofAddToRecent],false); end; end; procedure TMessagesFrame.RemoveCompOptHideMsgClick(Sender: TObject); var Item: TIDEMenuCommand; MsgId: Integer; ToolData: TIDEExternalToolData; IDETool: TObject; CompOpts: TLazCompilerOptions; Pkg: TIDEPackage; begin if not (Sender is TIDEMenuCommand) then exit; Item:=TIDEMenuCommand(Sender); MsgId:=Item.Tag; ToolData:=TIDEExternalToolData(Item.UserTag); IDETool:=ExternalTools.GetIDEObject(ToolData); if IDETool=nil then exit; if IDETool is TLazProject then begin CompOpts:=TLazProject(IDETool).LazCompilerOptions; CompOpts.MessageFlags[MsgID]:=cfvNone; end else if IDETool is TIDEPackage then begin if PackageEditingInterface.DoOpenPackageFile(ToolData.Filename, [pofAddToRecent],false)<>mrOk then exit; Pkg:=PackageEditingInterface.FindPackageWithName(ToolData.ModuleName); if Pkg=nil then exit; CompOpts:=Pkg.LazCompilerOptions; CompOpts.MessageFlags[MsgID]:=cfvNone; end; end; procedure TMessagesFrame.SaveAllToFileMenuItemClick(Sender: TObject); begin SaveClicked(false); end; procedure TMessagesFrame.SaveShownToFileMenuItemClick(Sender: TObject); begin SaveClicked(true); end; procedure TMessagesFrame.SearchEditChange(Sender: TObject); var s: TCaption; begin s:=SearchEdit.Text; if s=GetDefaultSearchText then s:=''; MessagesCtrl.SearchText:=s; end; procedure TMessagesFrame.SearchEditEnter(Sender: TObject); begin if SearchEdit.Text=GetDefaultSearchText then SearchEdit.Text:=''; end; procedure TMessagesFrame.SearchEditExit(Sender: TObject); begin if SearchEdit.Text='' then SearchEdit.Text:=GetDefaultSearchText; end; procedure TMessagesFrame.SearchEditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (Key=VK_ESCAPE) then HideSearch; end; procedure TMessagesFrame.SearchNextSpeedButtonClick(Sender: TObject); begin MessagesCtrl.SelectNextOccurence(true); end; procedure TMessagesFrame.SearchPrevSpeedButtonClick(Sender: TObject); begin MessagesCtrl.SelectNextOccurence(false); end; procedure TMessagesFrame.ShowIDMenuItemClick(Sender: TObject); begin if mcoShowMessageID in MessagesCtrl.Options then MessagesCtrl.Options:=MessagesCtrl.Options-[mcoShowMessageID] else MessagesCtrl.Options:=MessagesCtrl.Options+[mcoShowMessageID]; end; procedure TMessagesFrame.SrcEditLinesChanged(Sender: TObject); begin //debugln(['TMessagesFrame.SrcEditLinesChanged ',DbgSName(Sender)]); if Sender is TETSynPlugin then ApplySrcChanges(TETSynPlugin(Sender).Changes); end; procedure TMessagesFrame.TranslateMenuItemClick(Sender: TObject); begin if mcoShowTranslated in MessagesCtrl.Options then MessagesCtrl.Options:=MessagesCtrl.Options-[mcoShowTranslated] else MessagesCtrl.Options:=MessagesCtrl.Options+[mcoShowTranslated]; EnvironmentOptions.MsgViewShowTranslations:=mcoShowTranslated in MessagesCtrl.Options; end; procedure TMessagesFrame.RemoveFilterMsgTypeClick(Sender: TObject); var i: PtrInt; begin i:=TIDEMenuCommand(Sender).Tag; if i=ord(mluError)) then exit; MessagesCtrl.ActiveFilter.AddFilterMsgType(Line.SubTool,Line.MsgID); end; procedure TMessagesFrame.FilterUrgencyMenuItemClick(Sender: TObject); var MinUrgency: TMessageLineUrgency; begin //debugln(['TMessagesFrame.FilterUrgencyMenuItemClick ',DbgSName(Sender),' ',(Sender as TIDEMenuCommand).Caption,' ',(Sender as TIDEMenuCommand).Checked]); if Sender=MsgFilterWarningsMenuItem then MinUrgency:=mluError else if Sender=MsgFilterNotesMenuItem then MinUrgency:=mluWarning else if Sender=MsgFilterHintsMenuItem then MinUrgency:=mluNote else if Sender=MsgFilterVerboseMenuItem then MinUrgency:=mluHint else if Sender=MsgFilterDebugMenuItem then MinUrgency:=mluVerbose3 else if Sender=MsgFilterNoneMenuItem then MinUrgency:=mluNone; MessagesCtrl.ActiveFilter.MinUrgency:=MinUrgency; //debugln(['TMessagesFrame.FilterUrgencyMenuItemClick ',MessageLineUrgencyNames[MinUrgency]]); end; procedure TMessagesFrame.HideSearchSpeedButtonClick(Sender: TObject); begin HideSearch; end; procedure TMessagesFrame.CopyFilenameMenuItemClick(Sender: TObject); begin CopyMsgToClipboard(true); end; procedure TMessagesFrame.CopyAllMenuItemClick(Sender: TObject); begin CopyAllClicked(false); end; procedure TMessagesFrame.AboutToolMenuItemClick(Sender: TObject); var View: TLMsgWndView; Form: TForm; s: String; Tool: TAbstractExternalTool; Proc: TProcessUTF8; Memo: TMemo; begin View:=GetAboutView; if View=nil then exit; s:=View.Caption+LineEnding; s+=LineEnding; Tool:=View.Tool; if Tool<>nil then begin if Tool.Hint<>'' then s+=Tool.Hint+LineEnding+LineEnding; Proc:=Tool.Process; if Proc<>nil then begin if Proc.Executable<>'' then s+='Executable: '+LineEnding+Proc.Executable+LineEnding+LineEnding; if Proc.CurrentDirectory<>'' then s+='CurrentDirectory: '+LineEnding+Proc.CurrentDirectory+LineEnding+LineEnding; if Proc.Desktop<>'' then s+='Desktop: '+Proc.Desktop+LineEnding; s+='Parameters:'+LineEnding; s+=Proc.Parameters.Text+LineEnding; s+='ProcessID:'+LineEnding+IntToStr(Proc.ProcessID)+LineEnding+LineEnding; if Tool.Terminated then s+='Terminated'+LineEnding+LineEnding else s+='ExitStatus:'+LineEnding+IntToStr(Proc.ExitStatus)+LineEnding+LineEnding; end; if Tool.ErrorMessage<>'' then s+=lisError+Tool.ErrorMessage+LineEnding+LineEnding; end; Form:=TForm.CreateNew(Self); try with Form do begin Name:='AboutExtToolDlg'; Width:=500; Height:=300; Position:=poScreenCenter; Caption:=Format(lisAbout2, [View.Caption]); end; Memo:=TMemo.Create(Form); with Memo do begin Name:='Memo'; Lines.Text:=s; Align:=alClient; WordWrap:=false; ScrollBars:=ssBoth; ReadOnly:=true; Parent:=Form; end; Form.ShowModal; finally Form.Free; end; end; procedure TMessagesFrame.AddFilterMenuItemClick(Sender: TObject); var aCaption: String; i: Integer; NewFilter: TLMsgViewFilter; Filters: TLMsgViewFilters; begin aCaption:=lisFilter; i:=1; Filters:=MessagesCtrl.Filters; while Filters.GetFilter(aCaption+IntToStr(i),false)<>nil do inc(i); if not InputQuery(lisCreateFilter, lisCodeToolsDefsName, aCaption) then exit; aCaption:=UTF8Trim(aCaption,[]); if aCaption='' then exit; if Filters.GetFilter(aCaption,false)<>nil then begin IDEMessageDialog(lisFilterAlreadyExists, Format( lisAFilterWithTheNameAlreadyExists, [aCaption]), mtError, [mbCancel], ''); exit; end; NewFilter:=Filters.GetFilter(aCaption,true); NewFilter.Assign(MessagesCtrl.ActiveFilter); MessagesCtrl.ActiveFilter:=NewFilter; end; procedure TMessagesFrame.ClearFilterMsgTypesMenuItemClick(Sender: TObject); begin MessagesCtrl.ActiveFilter.ClearFilterMsgTypes; end; procedure TMessagesFrame.ClearMenuItemClick(Sender: TObject); begin MessagesCtrl.ClearViews(true); end; function TMessagesFrame.GetViews(Index: integer): TLMsgWndView; begin Result:=MessagesCtrl.Views[Index]; end; procedure TMessagesFrame.HideSearch; begin SearchPanel.Visible:=false; MessagesCtrl.SearchText:=''; SearchEdit.Text:=GetDefaultSearchText; end; procedure TMessagesFrame.SaveClicked(OnlyShown: boolean); var Dlg: TSaveDialog; s: String; Filename: String; fs: TFileStreamUTF8; begin Dlg:=TSaveDialog.Create(nil); try Dlg.Title:=lisSaveMessages; Dlg.FileName:='messages.txt'; Dlg.Options:=Dlg.Options+[ofPathMustExist,ofCreatePrompt]; InitIDEFileDialog(Dlg); if not Dlg.Execute then exit; Filename:=TrimAndExpandFilename(Dlg.FileName); if DirPathExistsCached(Filename) then exit; s:=AllMessagesAsString(OnlyShown); try fs:=TFileStreamUTF8.Create(Filename,fmCreate); try if s<>'' then fs.Write(s[1],length(s)); finally fs.Free; end; except on E: Exception do begin IDEMessageDialog(lisWriteError, Format(lisUnableToWriteFile2, [Filename] ), mtError, [mbCancel]); end; end; finally StoreIDEFileDialog(Dlg); Dlg.Free; end; end; procedure TMessagesFrame.CopyAllClicked(OnlyShown: boolean); var s: String; Msg: String; begin s:=AllMessagesAsString(OnlyShown); if length(s)>1000000 then begin if length(s)<10000 then Msg:=Format(lisByte, [IntToStr(length(s))]) else if Length(s)<10000000 then Msg:=Format(lisKB, [IntToStr(length(s) div 1000)]) else Msg:=Format(lisMB, [IntToStr(length(s) div 1000)]); if IDEMessageDialog(lisCCOWarningCaption, Format( lisThisWillPutALotOfTextOnTheClipboardProceed, [Msg, #13]), mtConfirmation,[mbYes,mbNo])<>mrYes then exit; end; Clipboard.AsText:=s; end; procedure TMessagesFrame.CopyMsgToClipboard(OnlyFilename: boolean); var View: TLMsgWndView; LineNumber: Integer; Txt: String; Line: TMessageLine; begin View:=MessagesCtrl.SelectedView; if View=nil then exit; LineNumber:=MessagesCtrl.SelectedLine; if LineNumber<0 then begin // header if OnlyFilename then exit; Txt:=MessagesCtrl.GetHeaderText(View); end else if LineNumber0) then Result+='('+IntToStr(MsgID)+')'; Pattern:=ExternalToolList.GetMsgPattern(SubTool,MsgID,Urgency); if Pattern<>'' then Result+=' '+Pattern; if WithUrgency and (not (Urgency in [mluNone,mluImportant])) then Result:=MessagesCtrl.UrgencyToStr(Urgency)+': '+Result; if UTF8Length(Result)>MaxLen then Result:=UTF8Copy(Result,1,MaxLen)+'...'; end; procedure TMessagesFrame.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if Operation=opRemove then begin if AComponent=MessagesCtrl then MessagesCtrl:=nil; end; end; constructor TMessagesFrame.Create(TheOwner: TComponent); var ImgIDInfo: Integer; ImgIDHint: Integer; ImgIDNote: Integer; ImgIDWarning: Integer; ImgIDError: Integer; ImgIDFatal: Integer; begin inherited Create(TheOwner); MessagesCtrl:=TMessagesCtrl.Create(Self); ImgIDInfo:=IDEImages.LoadImage(12, 'state12x12_information'); ImgIDHint:=IDEImages.LoadImage(12, 'state12x12_hint'); ImgIDNote:=IDEImages.LoadImage(12, 'state12x12_note'); ImgIDWarning:=IDEImages.LoadImage(12, 'state12x12_warning'); ImgIDError:=IDEImages.LoadImage(12, 'state12x12_error'); ImgIDFatal:=IDEImages.LoadImage(12, 'state12x12_fatal'); with MessagesCtrl do begin Name:='MessagesCtrl'; Align:=alClient; Parent:=Self; UrgencyStyles[mluNone].SetValues('?',ImgIDInfo,clDefault); UrgencyStyles[mluProgress].SetValues(lisPDProgress, ImgIDInfo, clDefault); UrgencyStyles[mluDebug].SetValues(uemDebugWord, ImgIDInfo, clDefault); UrgencyStyles[mluVerbose3].SetValues(lisExtremelyVerbose, ImgIDInfo, clDefault); UrgencyStyles[mluVerbose2].SetValues(lisVeryVerbose, ImgIDInfo, clDefault); UrgencyStyles[mluVerbose].SetValues(lisVerbose, ImgIDInfo, clDefault); UrgencyStyles[mluHint].SetValues(lisHint, ImgIDHint, clDefault); UrgencyStyles[mluNote].SetValues(lisNote, ImgIDNote, clDefault); UrgencyStyles[mluWarning].SetValues(lisCCOWarningCaption, ImgIDWarning, clDefault); UrgencyStyles[mluImportant].SetValues(lisImportant, ImgIDInfo, clDefault); UrgencyStyles[mluError].SetValues(lisCCOErrorCaption, ImgIDError, clDefault ); UrgencyStyles[mluFatal].SetValues(lisFatal, ImgIDFatal, clDefault); UrgencyStyles[mluPanic].SetValues(lisPanic, ImgIDFatal, clDefault); Images:=IDEImages.Images_12; PopupMenu:=MsgCtrlPopupMenu; end; MessagesCtrl.SourceMarks:=ExtToolsMarks; // search SearchPanel.Visible:=false; // by default the search is hidden HideSearchSpeedButton.Hint:=lisHideSearch; HideSearchSpeedButton.LoadGlyphFromResourceName(HInstance, 'debugger_power_grey'); SearchEdit.Text:=GetDefaultSearchText; SearchNextSpeedButton.Hint:=lisFindTheNextOccurenceOfThePhrase; SearchNextSpeedButton.LoadGlyphFromResourceName(HInstance, 'callstack_bottom'); SearchPrevSpeedButton.Hint:=lisFindThePreviousOccurenceOfThePhrase; SearchPrevSpeedButton.LoadGlyphFromResourceName(HInstance, 'callstack_top'); end; destructor TMessagesFrame.Destroy; begin MessagesCtrl.BeginUpdate; ClearViews(false); inherited Destroy; end; procedure TMessagesFrame.ApplyIDEOptions; begin MessagesCtrl.ApplyEnvironmentOptions; end; function TMessagesFrame.ViewCount: integer; begin Result:=MessagesCtrl.ViewCount; end; function TMessagesFrame.GetView(aCaption: string; CreateIfNotExist: boolean ): TLMsgWndView; begin Result:=MessagesCtrl.GetView(aCaption,CreateIfNotExist); end; function TMessagesFrame.FindUnfinishedView: TLMsgWndView; begin Result:=MessagesCtrl.FindUnfinishedView; end; procedure TMessagesFrame.DeleteView(View: TLMsgWndView); begin View.Free; end; function TMessagesFrame.IndexOfView(View: TLMsgWndView): integer; begin Result:=MessagesCtrl.IndexOfView(View); end; procedure TMessagesFrame.ClearViews(OnlyFinished: boolean); begin MessagesCtrl.ClearViews(OnlyFinished); end; procedure TMessagesFrame.CreateMarksForFile(aSynEdit: TSynEdit; aFilename: string; DeleteOld: boolean); begin MessagesCtrl.CreateMarksForFile(aSynEdit,aFilename,DeleteOld); end; procedure TMessagesFrame.ApplySrcChanges(Changes: TETSingleSrcChanges); begin MessagesCtrl.ApplySrcChanges(Changes); end; procedure TMessagesFrame.ApplyMultiSrcChanges(Changes: TETMultiSrcChanges); var Node: TAvgLvlTreeNode; begin for Node in Changes.PendingChanges do ApplySrcChanges(TETSingleSrcChanges(Node.Data)); end; procedure TMessagesFrame.SourceEditorPopup(MarkLine: TSynEditMarkLine; const LogicalCaretXY: TPoint); var i: Integer; CurMark: TETMark; BestMark: TETMark; begin //debugln(['TMessagesFrame.SourceEditorPopup ']); // show quickfixes for the first TETMark in editor line if MarkLine=nil then exit; IDEQuickFixes.ClearLines; BestMark:=nil; for i:=0 to MarkLine.Count-1 do begin CurMark:=TETMark(MarkLine[i]); if not (CurMark is TETMark) then continue; //debugln(['TMessagesFrame.SourceEditorPopup ',CurMark.Line,',',CurMark.Column,' ID=',CurMark.MsgLine.MsgID,' Msg=',CurMark.MsgLine.Msg,' EditorXY=',dbgs(LogicalCaretXY)]); if (BestMark=nil) then BestMark:=CurMark else begin // there are multiple marks in the line if (LogicalCaretXY.Y=MarkLine.LineNum) and (LogicalCaretXY.X=CurMark.Column) then begin // mark at cursor position BestMark:=CurMark; break; end else begin // default: use first in line if CurMark.Columnnil then IDEQuickFixes.AddMsgLine(BestMark.MsgLine); // create items if IDEQuickFixes.Count>0 then begin IDEQuickFixes.OnPopupMenu(SrcEditMenuSectionFirstDynamic); if mcoSrcEditPopupSelect in MessagesCtrl.Options then MessagesCtrl.Select(BestMark.MsgLine,true); end; end; procedure TMessagesFrame.SourceEditorHint(MarkLine: TSynEditMarkLine; var HintStr: string); var i: Integer; CurMark: TETMark; Msg: TMessageLine; CurHint: String; begin if MarkLine=nil then exit; for i:=0 to MarkLine.Count-1 do begin CurMark:=TETMark(MarkLine[i]); if not (CurMark is TETMark) then continue; Msg:=CurMark.MsgLine; CurHint:=MessagesCtrl.UrgencyToStr(Msg.Urgency)+': '+Msg.Msg; if HintStr<>'' then HintStr:=HintStr+LineEnding; HintStr:=HintStr+CurHint; end; end; procedure TMessagesFrame.SelectMsgLine(Msg: TMessageLine; DoScroll: boolean); begin MessagesCtrl.Select(Msg,DoScroll); end; function TMessagesFrame.GetDefaultSearchText: string; begin Result:=lisUDSearch; end; function TMessagesFrame.SelectFirstUrgentMessage( aMinUrgency: TMessageLineUrgency; WithSrcPos: boolean): boolean; begin Result:=MessagesCtrl.SelectFirstUrgentMessage(aMinUrgency,WithSrcPos); end; function TMessagesFrame.SelectNextUrgentMessage( aMinUrgency: TMessageLineUrgency; WithSrcPos, Downwards: boolean): boolean; begin Result:=MessagesCtrl.SelectNextUrgentMessage(aMinUrgency,WithSrcPos,Downwards); end; procedure TMessagesFrame.ClearCustomMessages(const ViewCaption: string); var View: TLMsgWndView; begin View:=GetView(ViewCaption,false); if (View=nil) or (View.Lines.Count=0) then exit; View.Lines.Clear; MessagesCtrl.UpdateScrollBar(true); MessagesCtrl.Invalidate; end; function TMessagesFrame.AddCustomMessage(TheUrgency: TMessageLineUrgency; Msg: string; aFilename: string; LineNumber: integer; Column: integer; const ViewCaption: string): TMessageLine; var View: TLMsgWndView; begin Result:=nil; View:=GetView(ViewCaption,true); View.Running:=false; Result:=View.Lines.CreateLine(-1); Result.Msg:=Msg; Result.Urgency:=TheUrgency; Result.SetSourcePosition(aFilename,LineNumber,Column); View.Lines.Add(Result); MessagesCtrl.UpdateScrollBar(true); MessagesCtrl.Invalidate; end; end.