{ Component ViewerControl (Free Pascal) show file in text (wraped or not) or bin or hex mode This is part of Seksi Commander To searching use uFindMmap, to movement call Upxxxx, Downxxxx, or set Position Realised under GNU GPL 2 author Radek Cervinka (radek.cervinka@centrum.cz) changes: 5.7. (RC) - selecting text with mouse - CopyToclipBoard, SelectAll ?.6. - LoadFromStdIn and loading first 64Kb of files with size=0 :) (/proc fs ..) 17.6. (RC) - mapfile (in error set FMappedFile=nil) - writetext TABs fixed (tab is replaced by 9 spaces) - set correct position for modes hex, bin (SetPosition) 21.7 - wrap text on 80 character lines works better now (by Radek Polak) - problems with function UpLine for specific lines: (lines of 80(=cTextWidth) character ended with ENTER (=#10) 6.2. (RC) - ported to fpc for linux (CustomControl and gtk) 7.2. (RC) - use temp to new implementation of LoadFromStdIn (and mmap temp file) - faster drawing of text (I hope) contributors: Copyright (C) 2006-2013 Alexander Koblov (alexx2000@mail.ru) TODO: a) File mapping blocks writing into file by other processes. Either: + Open small text files by reading them all into memory (done). - Add optional custom loading/caching portions of file in memory and only reading from file when neccessary. b) Searching in Unicode encodings and case-insensitive searching. c) Selecting text does not work well with composed Unicode characters (characters that are composed of multiple Unicode characters). d) Drawing/selecting text does not work correctly with RTL (right to left) text. e) FTextHeight is unreliable with complex unicode characters. It should be calculated based on currently displayed text (get max from each line's height). } unit ViewerControl; {$mode objfpc}{$H+} interface uses SysUtils, Classes, Controls, StdCtrls, fgl; const MaxMemSize = $400000; // 4 Mb type TViewerMode = (vmBin, vmHex, vmText, vmWrap, vmBook); TDataAccess = (dtMmap, dtNothing); TCharSide = (csBefore, csLeft, csRight, csAfter); TPtrIntList = specialize TFPGList; TGuessEncodingEvent = function(const s: string): string; type // If additional encodings are added they should be also supported by: // - GetNextCharAsAscii // - GetPrevCharAsAscii // - GetNextCharAsUtf8 // - ConvertToUTF8 // - UpdateSelection TViewerEncoding = (veAutoDetect, veUtf8, veUtf8bom, veAnsi, veCp1250, veCp1251, veCp1252, veCp1253, veCp1254, veCp1255, veCp1256, veCp1257, veCp1258, veCp437, veCp850, veCp852, veCp866, veCp874, veCp932, veCp936, veCp949, veCp950, veIso88591, veIso88592, veKoi8, veUcs2le, veUcs2be, veUtf16le, veUtf16be, veUtf32le, // = ucs4le veUtf32be); // = ucs4be TViewerEncodings = set of TViewerEncoding; const ViewerEncodingsNames: array [TViewerEncoding] of string = ('Auto-detect', 'UTF-8', 'UTF-8BOM', 'Ansi', 'CP1250', 'CP1251', 'CP1252', 'CP1253', 'CP1254', 'CP1255', 'CP1256', 'CP1257', 'CP1258', 'CP437', 'CP850', 'CP852', 'CP866', 'CP874', 'CP932', 'CP936', 'CP949', 'CP950', 'ISO-8859-1', 'ISO-8859-2', 'KOI-8', 'UCS-2LE', 'UCS-2BE', 'UTF-16LE', 'UTF-16BE', 'UTF-32LE', 'UTF-32BE'); const ViewerEncodingMultiByte: TViewerEncodings = [ veUtf8, veUtf8bom, veUcs2le, veUcs2be, veUtf16le, veUtf16be, veUtf32le, veUtf32be]; type { TViewerControl } TViewerControl = class(TCustomControl) protected FEncoding: TViewerEncoding; FViewerMode: TViewerMode; FFileName: UTF8String; FFileHandle: THandle; FFileSize: Int64; FMappingHandle: THandle; FMappedFile: Pointer; FPosition: PtrInt; FHPosition: Integer; // Tab for text during horizontal scroll FHLowEnd: Integer; // End for HPosition (string with max char) FVisibleOffset: PtrInt; // Offset in symbols for current line (see IsVisible and MakeVisible) FLowLimit: PtrInt; // Lowest possible value for Position FHighLimit: PtrInt; // Position cannot reach this value FBOMLength: Integer; FLineList: TPtrIntList; FBlockBeg: PtrInt; FBlockEnd: PtrInt; FMouseBlockBeg: PtrInt; FMouseBlockSide: TCharSide; FSelecting: Boolean; FTextWidth: Integer; // max char count or width in window FTextHeight: Integer; // measured values of font, rec calc at font changed FScrollBarVert: TScrollBar; FScrollBarHorz: TScrollBar; FOnPositionChanged: TNotifyEvent; FUpdateScrollBarPos: Boolean; // used to block updating of scrollbar FScrollBarPosition: Integer; // for updating vertical scrollbar based on Position FHScrollBarPosition: Integer; // for updating horizontal scrollbar based on HPosition FColCount: Integer; FOnGuessEncoding: TGuessEncodingEvent; function GetPercent: Integer; procedure SetPercent(const AValue: Integer); procedure SetBlockBegin(const AValue: PtrInt); procedure SetBlockEnd(const AValue: PtrInt); procedure SetPosition(Value: PtrInt); virtual; procedure SetHPosition(Value: Integer); procedure SetPosition(Value: PtrInt; Force: Boolean); overload; procedure SetHPosition(Value: Integer; Force: Boolean); overload; procedure SetEncoding(AEncoding: TViewerEncoding); function GetEncodingName: string; procedure SetEncodingName(AEncodingName: string); procedure SetViewerMode(Value: TViewerMode); procedure SetColCount(const AValue: Integer); {en Returns how many lines (given current FTextHeight) will fit into the window. } function GetClientHeightInLines: Integer; inline; {en Calculates how many lines can be displayed from given position. @param(FromPosition Position from which to check. It should point to a start of a line.) @param(LastLineReached If it is set to @true when the function returns, then the last line of text was reached when scanning. This means that there are no more lines to be displayed other than the ones scanned from FromPosition. In other words: SetPosition(GetStartOfNextLine(FromPosition)) will be one line too many and will be scrolled back.) } function GetLinesTillEnd(FromPosition: PtrInt; out LastLineReached: Boolean): Integer; function GetBomLength: Integer; procedure UpdateLimits; {en @param(iStartPos Should point to start of a line. It is increased by the amount of parsed data (with line endings).) @param(aLimit Position which cannot be reached while reading from file.) @param(DataLength It is length in bytes of parsed data without any line endings. iStartPos is moved beyond the line endings though.) } function CalcTextLineLength(var iStartPos: PtrInt; const aLimit: Int64; out DataLength: PtrInt): Integer; function GetStartOfLine(aPosition: PtrInt): PtrInt; function GetEndOfLine(aPosition: PtrInt): PtrInt; function GetStartOfPrevLine(aPosition: PtrInt): PtrInt; function GetStartOfNextLine(aPosition: PtrInt): PtrInt; {en Changes the value of aPosition to X lines back or forward. @param(aPosition File position to change.) @param(iLines Nr of lines to scroll. If positive the position is increased by iLines lines, if negative the position is decreased by -iLines lines.) } function ScrollPosition(var aPosition: PtrInt; iLines: Integer): Boolean; {en Calculates (x,y) cursor position to a position within file. @param(x Client X coordinate of mouse cursor.) @param(y Client Y coordinate of mouse cursor.) @param(CharSide To which side of a character at returned position the (x,y) points to. Only valid if returned position is not -1.) @returns(Position in file to which (x,y) points to, based on what is currently displayed. Returns -1 if (x,y) doesn't point to any position (outside of the text for example).) } function XYPos2Adr(x, y: Integer; out CharSide: TCharSide): PtrInt; procedure OutText(x, y: Integer; StartPos: PtrInt; DataLength: Integer); procedure OutHex(x, y: Integer; sText: string; StartPos: PtrInt; DataLength: Integer); procedure OutBin(x, y: Integer; sText: string; StartPos: PtrInt; DataLength: Integer); procedure WriteText; procedure WriteHex; virtual; procedure WriteBin; function TransformText(const sText: UTF8String; const Xoffset: Integer): UTF8String; function TransformHex(var aPosition: PtrInt; aLimit: PtrInt): AnsiString; function TransformBin(var aPosition: PtrInt; aLimit: PtrInt): AnsiString; procedure AddLineOffset(iOffset: PtrInt); inline; function MapFile(const sFileName: UTF8String): Boolean; procedure UnMapFile; procedure SetFileName(const sFileName: UTF8String); procedure UpdateScrollbars; procedure ViewerResize(Sender: TObject); {en Returns next unicode character from the file, depending on Encoding. It is a faster version, which does as little conversion as possible, but only Ascii values are guaranteed to be valid (0-127). Other unicode values may/may not be valid, so shouldn't be tested. This function is used for reading pure ascii characters such as line endings, tabs, white spaces, etc. } function GetNextCharAsAscii(const iPosition: PtrInt; out CharLenInBytes: Integer): Cardinal; function GetPrevCharAsAscii(const iPosition: PtrInt; out CharLenInBytes: Integer): Cardinal; {en Retrieve next character from the file depending on encoding and automatically convert it to UTF-8. If CharLenInBytes is greater than 0 but the result is an empty string then it's possible there was no appropriate UTF-8 character for the next character of the current encoding. } function GetNextCharAsUtf8(const iPosition: PtrInt; out CharLenInBytes: Integer): UTF8String; procedure ReReadFile; function IsFileOpen: Boolean; inline; {en Searches for an ASCII character. @param(aPosition Position from where the search starts.) @param(aMaxBytes How many bytes are available for reading.) @param(AsciiChars The function searches for any character that this string contains.) @param(bFindNotIn If @true searches for first character not included in AsciiChars. If @false searches for first character included in AsciiChars.) } function FindAsciiSetForward(aPosition, aMaxBytes: PtrInt; const AsciiChars: String; bFindNotIn: Boolean): PtrInt; {en Same as FindForward but it searches backwards from pAdr. aMaxBytes must be number of available bytes for reading backwards from pAdr. } function FindAsciiSetBackward(aPosition, aMaxBytes: PtrInt; const AsciiChars: String; bFindNotIn: Boolean): PtrInt; {en Checks if current selection is still valid given current viewer mode and encoding. For example checks if selection is not in the middle of a unicode character. } procedure UpdateSelection; procedure ScrollBarVertScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); procedure ScrollBarHorzScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); function GetText(const StartPos, Len: PtrInt; const Xoffset: Integer): string; protected procedure KeyDown(var Key: word; Shift: TShiftState); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override; function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; {en Scrolls the displayed text in the window. @param(iLines Nr of lines to scroll. If positive the text is scrolled downwards, if negative the text is scrolled upwards.) @returns(@true if the text was scrolled.) } function Scroll(iLines: Integer): Boolean; function HScroll(iSymbols: Integer): Boolean; procedure PageUp; procedure PageDown; procedure GoHome; procedure GoEnd; procedure HPageUp; procedure HPageDown; procedure HGoHome; procedure HGoEnd; function GetDataAdr: Pointer; procedure SelectAll; procedure SelectText(AStart, AEnd: PtrInt); procedure CopyToClipboard; function IsVisible(const aPosition: PtrInt): Boolean; overload; procedure MakeVisible(const aPosition: PtrInt); function ConvertToUTF8(const sText: AnsiString): UTF8String; function ConvertFromUTF8(const sText: UTF8String): AnsiString; function FindUtf8Text(iStartPos: PtrInt; const sSearchText: UTF8String; bCaseSensitive: Boolean; bSearchBackwards: Boolean): PtrInt; function DetectEncoding: TViewerEncoding; procedure GetSupportedEncodings(List: TStrings); property Percent: Integer Read GetPercent Write SetPercent; property Position: PtrInt Read FPosition Write SetPosition; property FileSize: Int64 Read FFileSize; property SelectionStart: PtrInt Read FBlockBeg Write SetBlockBegin; property SelectionEnd: PtrInt Read FBlockEnd Write SetBlockEnd; property EncodingName: string Read GetEncodingName Write SetEncodingName; property ColCount: Integer Read FColCount Write SetColCount; property OnGuessEncoding: TGuessEncodingEvent Read FOnGuessEncoding Write FOnGuessEncoding; published property ViewerMode: TViewerMode Read FViewerMode Write SetViewerMode default vmWrap; property FileName: UTF8String Read FFileName Write SetFileName; property Encoding: TViewerEncoding Read FEncoding Write SetEncoding default veAutoDetect; property OnPositionChanged: TNotifyEvent Read FOnPositionChanged Write FOnPositionChanged; property OnClick; property OnMouseDown; property OnMouseMove; property OnMouseUp; property Align; property Color; property Cursor default crIBeam; property Font; property ParentColor default False; property TabStop default True; end; procedure Register; implementation uses LCLType, LCLVersion, Graphics, Forms, LCLProc, Clipbrd, LConvEncoding, UnicodeUtils, LCLIntf {$IF DEFINED(UNIX)} , BaseUnix, Unix {$ELSEIF DEFINED(WINDOWS)} , Windows {$ENDIF}; const //cTextWidth = 80; // wrap on 80 chars cBinWidth = 80; cMaxTextWidth = 65535; // maximum of chars on one line unwrapped text cHexWidth = 16; cTabSpaces = 8; // tab stop - allow to set in settings cHexOffsetWidth = 8; cHexStartHex = cHexOffsetWidth + 2; // ': ' cHexEndHex = cHexStartHex + (cHexWidth * 3); cHexStartAscii = cHexStartHex + (cHexWidth * 3) + 2; // ' ' // These strings must be Ascii only. sNonCharacter: string = ' !"#$%&''()*+,-./:;<=>?@[\]^`{|}~'#13#10#9; sWhiteSpace : string = ' '#13#10#9#8; // ---------------------------------------------------------------------------- constructor TViewerControl.Create(AOwner: TComponent); begin inherited Create(AOwner); Cursor := crIBeam; ParentColor := False; DoubleBuffered := True; ControlStyle := ControlStyle + [csTripleClicks, csOpaque]; TabStop := True; // so that it can get keyboard focus FEncoding := veAutoDetect; FViewerMode := vmText; FFileName := ''; FMappedFile := nil; FFileHandle := 0; FMappingHandle := 0; FPosition := 0; FHPosition := 0; FHLowEnd := 0; FLowLimit := 0; FHighLimit := 0; FBOMLength := 0; FTextHeight := 14; // dummy value FColCount := 1; FLineList := TPtrIntList.Create; FScrollBarVert := TScrollBar.Create(Self); FScrollBarVert.Parent := Self; FScrollBarVert.Kind := sbVertical; FScrollBarVert.Align := alRight; FScrollBarVert.OnScroll := @ScrollBarVertScroll; FScrollBarVert.TabStop := False; FScrollBarVert.PageSize := 0; FScrollBarHorz := TScrollBar.Create(Self); FScrollBarHorz.Parent := Self; FScrollBarHorz.Kind := sbHorizontal; FScrollBarHorz.Align := alBottom; FScrollBarHorz.OnScroll := @ScrollBarHorzScroll; FScrollBarHorz.TabStop := False; FScrollBarHorz.PageSize := 0; FUpdateScrollBarPos := True; FScrollBarPosition := 0; FHScrollBarPosition := 0; FOnPositionChanged := nil; FOnGuessEncoding := nil; OnResize := @ViewerResize; end; destructor TViewerControl.Destroy; begin UnMapFile; if Assigned(FLineList) then FreeAndNil(FLineList); inherited Destroy; end; procedure TViewerControl.Paint; begin if not IsFileOpen then Exit; Canvas.Font := Self.Font; Canvas.Brush.Color := Self.Color; {$IF DEFINED(LCLQT) and (LCL_FULLVERSION < 093100)} Canvas.Brush.Style := bsSolid; Canvas.FillRect(ClientRect); {$ENDIF} Canvas.Brush.Style := bsClear; FTextHeight := Canvas.TextHeight('Wg') + 2; if FViewerMode = vmBook then FTextWidth := ((ClientWidth - (Canvas.TextWidth('W') * FColCount)) div FColCount) else FTextWidth := ClientWidth div Canvas.TextWidth('W') - 2; FLineList.Clear; case FViewerMode of vmBin : WriteBin; vmHex : WriteHex; vmText: WriteText; vmWrap: WriteText; vmBook: WriteText; end; end; procedure TViewerControl.SetViewerMode(Value: TViewerMode); begin if not (csDesigning in ComponentState) then begin FLineList.Clear; // do not use cache from previous mode // Take limits into account for selection. FBlockBeg := FBlockBeg + (GetDataAdr - FMappedFile); FBlockEnd := FBlockEnd + (GetDataAdr - FMappedFile); FViewerMode := Value; FHPosition := 0; FBOMLength := GetBomLength; UpdateLimits; // Take limits into account for selection. FBlockBeg := FBlockBeg - (GetDataAdr - FMappedFile); FBlockEnd := FBlockEnd - (GetDataAdr - FMappedFile); UpdateSelection; // Force recalculating position. SetPosition(FPosition, True); SetHPosition(FHPosition, True); UpdateScrollbars; Invalidate; end else FViewerMode := Value; end; procedure TViewerControl.SetColCount(const AValue: Integer); begin if AValue > 0 then FColCount := AValue else FColCount := 1; end; function TViewerControl.ScrollPosition(var aPosition: PtrInt; iLines: Integer): Boolean; var i: Integer; NewPos: PtrInt; begin Result := False; NewPos := aPosition; if iLines < 0 then for i := 1 to -iLines do NewPos := GetStartOfPrevLine(NewPos) else for i := 1 to iLines do NewPos := GetStartOfNextLine(NewPos); Result := aPosition <> NewPos; aPosition := NewPos; end; function TViewerControl.Scroll(iLines: Integer): Boolean; var aPosition: PtrInt; begin aPosition := FPosition; Result := ScrollPosition(aPosition, iLines); if aPosition <> FPosition then SetPosition(aPosition); end; function TViewerControl.HScroll(iSymbols: Integer): Boolean; var newPos: integer; begin newPos := FHPosition; if (FHLowEnd - FTextWidth) > 0 then begin newPos := newPos+ iSymbols; if newPos < 0 then newPos := 0; if newPos > FHLowEnd-FTextWidth then newPos := FHLowEnd-FTextWidth; end; if newPos <> FHPosition then SetHPosition(newPos); end; function TViewerControl.GetText(const StartPos, Len: PtrInt; const Xoffset: Integer): string; begin SetString(Result, GetDataAdr + StartPos, Len); Result := TransformText(ConvertToUTF8(Result), Xoffset); end; function TViewerControl.CalcTextLineLength(var iStartPos: PtrInt; const aLimit: Int64; out DataLength: PtrInt): Integer; var MaxLineLength: Boolean; CharLenInBytes: Integer; OldPos, LastSpacePos: PtrInt; LastSpaceResult: Integer; begin Result := 0; DataLength := 0; LastSpacePos := -1; MaxLineLength := True; OldPos := iStartPos; while MaxLineLength and (iStartPos < aLimit) do begin case GetNextCharAsAscii(iStartPos, CharLenInBytes) of 9: // tab Inc(Result, cTabSpaces - Result mod cTabSpaces); 10: // stroka begin DataLength := iStartPos - OldPos; iStartPos := iStartPos + CharLenInBytes; Exit; end; 13: // karetka begin DataLength := iStartPos - OldPos; iStartPos := iStartPos + CharLenInBytes; // Move after possible #10. if (iStartPos < aLimit) and (GetNextCharAsAscii(iStartPos, CharLenInBytes) = 10) then Inc(iStartPos, CharLenInBytes); Exit; end; 32, 33, 40, 41, 44, 45, 46, 47, 92, 58, 59, 63, 91, 93: //probel begin Inc(Result, 1); LastSpacePos := iStartPos + CharLenInBytes; LastSpaceResult := Result; end; else Inc(Result, 1); end; if CharLenInBytes = 0 then // End of data or invalid character. break; iStartPos := iStartPos + CharLenInBytes; DataLength := iStartPos - OldPos; case FViewerMode of vmText: MaxLineLength := Result < cMaxTextWidth; vmWrap: MaxLineLength := Result < FTextWidth; vmBook: MaxLineLength := Canvas.TextWidth(GetText(OldPos, DataLength, 0)) < FTextWidth; else Exit; end; end; if (not MaxLineLength) and (LastSpacePos <> -1) then begin iStartPos := LastSpacePos; Result := LastSpaceResult; DataLength := iStartPos - OldPos; end; end; function TViewerControl.TransformText(const sText: UTF8String; const Xoffset: Integer): UTF8String; var c: AnsiChar; i: Integer; begin Result := ''; for i := 1 to Length(sText) do begin c := sText[i]; // Parse only ASCII chars. case c of #9: Result := Result + StringOfChar(' ', cTabSpaces - (UTF8Length(Result) + Xoffset) mod cTabSpaces); else begin {if c < ' ' then Result := Result + ' ' else} Result := Result + c; end; end; end; end; function TViewerControl.TransformHex(var aPosition: PtrInt; aLimit: PtrInt): AnsiString; function LineFormat(const sHex, sAscii: AnsiString; iOffset: PtrInt): AnsiString; begin Result := Format('%s: %s', [IntToHex(iOffset, cHexOffsetWidth), sHex]); if Length(sHex) < cHexWidth * 3 then Result := Result + StringOfChar(' ', cHexWidth * 3 - Length(sHex)); Result := Result + ' '; Result := Result + sAscii; end; var c: AnsiChar; i: Integer; sStr: string = ''; sHex: string = ''; aStartOffset: PtrInt; begin if aPosition >= aLimit then Exit(''); aStartOffset := aPosition; for i := 0 to cHexWidth - 1 do begin if aPosition >= aLimit then Break; c := PAnsiChar(GetDataAdr)[aPosition]; if c < ' ' then sStr := sStr + '.' else if c > #127 then sStr := sStr + '.' else sStr := sStr + c; sHex := sHex + IntToHex(Ord(c), 2); if ((i and 7) = 7) and (i <> cHexWidth - 1) then sHex := sHex + '|' else sHex := sHex + ' '; Inc(aPosition); end; Result := LineFormat(sHex, sStr, aStartOffset) end; function TViewerControl.TransformBin(var aPosition: PtrInt; aLimit: PtrInt): AnsiString; var c: AnsiChar; i: Integer; begin Result := ''; for i := 0 to cBinWidth - 1 do begin if aPosition >= aLimit then Break; c := PAnsiChar(GetDataAdr)[aPosition]; if c < ' ' then Result := Result + '.' else if c > #127 then Result := Result + '.' else Result := Result + c; Inc(aPosition); end; end; function TViewerControl.GetStartOfLine(aPosition: PtrInt): PtrInt; function GetStartOfLineText: PtrInt; var tmpPos, LineStartPos: PtrInt; DataLength: PtrInt; prevChar: Cardinal; CharLenInBytes: Integer; begin prevChar := GetPrevCharAsAscii(aPosition, CharLenInBytes); if CharLenInBytes = 0 then Exit(aPosition); // Check if this already is not a start of line (if previous char is #10). if prevChar = 10 then Exit(aPosition); tmpPos := aPosition - CharLenInBytes; if tmpPos <= FLowLimit then Exit(FLowLimit); // Check if we're not in the middle of line ending // (previous char is #13, current char is #10). if (prevChar = 13) and (GetNextCharAsAscii(aPosition, CharLenInBytes) = 10) then begin prevChar := GetPrevCharAsAscii(tmpPos, CharLenInBytes); if CharLenInBytes = 0 then Exit(aPosition); Dec(tmpPos, CharLenInBytes); end; if tmpPos <= FLowLimit then Exit(FLowLimit); // Search for real start of line. while (not (prevChar in [10, 13])) and (tmpPos > FLowLimit) do begin prevChar := GetPrevCharAsAscii(tmpPos, CharLenInBytes); if CharLenInBytes = 0 then Break; Dec(tmpPos, CharLenInBytes); end; // Move forward to first non-line ending character. Inc(tmpPos, CharLenInBytes); // Search for start of real line or wrapped line. while True do begin LineStartPos := tmpPos; CalcTextLineLength(tmpPos, FHighLimit, DataLength); if tmpPos = aPosition then begin if aPosition < FHighLimit then Exit(aPosition) // aPosition is already at start of a line else Exit(LineStartPos); // aPosition points to end of file so return start of this line end else if tmpPos > aPosition then Exit(LineStartPos); // Found start of line end; end; function GetStartOfLineFixed(aFixedWidth: Integer): PtrInt; begin Result := aPosition - (aPosition mod aFixedWidth); end; var i: Integer; begin if aPosition <= FLowLimit then Exit(FLowLimit) else if aPosition >= FHighLimit then aPosition := FHighLimit; // search from the end of the file // Speedup for currently displayed positions. if (FLineList.Count > 0) and (aPosition >= FLineList.Items[0]) and (aPosition <= FLineList.Items[FLineList.Count - 1]) then begin for i := FLineList.Count - 1 downto 0 do if FLineList.Items[i] <= aPosition then Exit(FLineList.Items[i]); end; case FViewerMode of vmBin: Result := GetStartOfLineFixed(cBinWidth); vmHex: Result := GetStartOfLineFixed(cHexWidth); vmText, vmWrap, vmBook: Result := GetStartOfLineText; else Result := aPosition; end; end; function TViewerControl.GetEndOfLine(aPosition: PtrInt): PtrInt; function GetEndOfLineText: PtrInt; var tmpPos: PtrInt; DataLength: PtrInt; begin Result := GetStartOfLine(aPosition); tmpPos := Result; CalcTextLineLength(tmpPos, FHighLimit, DataLength); Result := Result + DataLength; if Result < aPosition then Result := aPosition; end; function GetEndOfLineFixed(aFixedWidth: Integer): PtrInt; begin Result := aPosition - (aPosition mod aFixedWidth) + aFixedWidth; end; begin case FViewerMode of vmBin: Result := GetEndOfLineFixed(cBinWidth); vmHex: Result := GetEndOfLineFixed(cHexWidth); vmText, vmWrap, vmBook: Result := GetEndOfLineText; else Result := aPosition; end; end; function TViewerControl.GetStartOfPrevLine(aPosition: PtrInt): PtrInt; function GetPrevLineText: PtrInt; var tmpPos, LineStartPos: PtrInt; DataLength: PtrInt; prevChar: Cardinal; CharLenInBytes: Integer; begin prevChar := GetPrevCharAsAscii(aPosition, CharLenInBytes); if CharLenInBytes = 0 then Exit(aPosition); tmpPos := aPosition - CharLenInBytes; // start search from previous character if tmpPos <= FLowLimit then Exit(FLowLimit); // Check if we're not in the middle of line ending // (previous char is #13, current char is #10). if (prevChar = 13) and (GetNextCharAsAscii(aPosition, CharLenInBytes) = 10) then begin prevChar := GetPrevCharAsAscii(tmpPos, CharLenInBytes); if CharLenInBytes = 0 then Exit(aPosition); Dec(tmpPos, CharLenInBytes); end else begin // Bypass possible end of previous line. if prevChar = 10 then begin prevChar := GetPrevCharAsAscii(tmpPos, CharLenInBytes); if CharLenInBytes = 0 then Exit(aPosition); Dec(tmpPos, CharLenInBytes); end; if prevChar = 13 then begin prevChar := GetPrevCharAsAscii(tmpPos, CharLenInBytes); if CharLenInBytes = 0 then Exit(aPosition); Dec(tmpPos, CharLenInBytes); end; end; if tmpPos <= FLowLimit then Exit(FLowLimit); // Search for real start of line. while (not (prevChar in [10, 13])) and (tmpPos > FLowLimit) do begin prevChar := GetPrevCharAsAscii(tmpPos, CharLenInBytes); if CharLenInBytes = 0 then Break; Dec(tmpPos, CharLenInBytes); end; // Move forward to first non-line ending character. Inc(tmpPos, CharLenInBytes); // Search for start of real line or wrapped line. while True do begin LineStartPos := tmpPos; CalcTextLineLength(tmpPos, aPosition, DataLength); if tmpPos >= aPosition then Exit(LineStartPos); // Found start of line end; end; function GetPrevLineFixed(aFixedWidth: Integer): PtrInt; begin Result := aPosition - (aPosition mod aFixedWidth); if Result >= aFixedWidth then Result := Result - aFixedWidth; end; var i: Integer; begin if aPosition <= FLowLimit then Exit(FLowLimit) else if aPosition >= FHighLimit then aPosition := FHighLimit; // search from the end of the file // Speedup for currently displayed positions. if (FLineList.Count > 0) and (aPosition >= FLineList.Items[0]) and (aPosition <= FLineList.Items[FLineList.Count - 1]) then begin for i := FLineList.Count - 1 downto 0 do if FLineList.Items[i] < aPosition then Exit(FLineList.Items[i]); end; case FViewerMode of vmBin: Result := GetPrevLineFixed(cBinWidth); vmHex: Result := GetPrevLineFixed(cHexWidth); vmText, vmWrap, vmBook: Result := GetPrevLineText; else Result := aPosition; end; end; function TViewerControl.GetStartOfNextLine(aPosition: PtrInt): PtrInt; function GetNextLineText: PtrInt; var tmpPos: PtrInt; DataLength: PtrInt; prevChar: Cardinal; CharLenInBytes: Integer; begin tmpPos := aPosition; // This might not be a real start of line (it may be start of wrapped line). // Search for start of line. while (tmpPos > FLowLimit) do begin prevChar := GetPrevCharAsAscii(tmpPos, CharLenInBytes); if CharLenInBytes = 0 then Break; if (prevChar in [10, 13]) then Break else Dec(tmpPos, CharLenInBytes); end; // Now we know we are at the start of a line, search the start of next line. while True do begin CalcTextLineLength(tmpPos, FHighLimit, DataLength); if tmpPos >= aPosition then Exit(tmpPos); // Found start of line end; end; function GetNextLineFixed(aFixedWidth: Integer): PtrInt; begin Result := aPosition - (aPosition mod aFixedWidth); if Result + aFixedWidth < FHighLimit then Result := Result + aFixedWidth; end; var i: Integer; begin if aPosition < FLowLimit then aPosition := FLowLimit // search from the start of the file else if aPosition >= FHighLimit then aPosition := FHighLimit; // search from the end of the file // Speedup for currently displayed positions. if (FLineList.Count > 0) and (aPosition >= FLineList.Items[0]) and (aPosition <= FLineList.Items[FLineList.Count - 1]) then begin for i := 0 to FLineList.Count - 1 do if FLineList.Items[i] > aPosition then Exit(FLineList.Items[i]); end; case FViewerMode of vmBin: Result := GetNextLineFixed(cBinWidth); vmHex: Result := GetNextLineFixed(cHexWidth); vmText, vmWrap, vmBook: Result := GetNextLineText; else Result := aPosition; end; end; procedure TViewerControl.PageUp; var H: Integer; begin H := GetClientHeightInLines * FColCount - 1; if H <= 0 then H := 1; Scroll(-H); end; procedure TViewerControl.HPageUp; var H: Integer; begin H := FHPosition - FTextWidth; if H <= 0 then H := FHPosition else H:= FTextWidth; HScroll(-H); end; procedure TViewerControl.PageDown; var H: Integer; begin H := GetClientHeightInLines * FColCount - 1; if H <= 0 then H := 1; Scroll(H); end; procedure TViewerControl.HPageDown; var H: Integer; begin H := FHLowEnd - FHPosition; if H > FTextWidth then H := FTextWidth ; HScroll(H); end; procedure TViewerControl.GoHome; begin Position := FLowLimit; end; procedure TViewerControl.GoEnd; begin Position := FHighLimit; end; procedure TViewerControl.HGoHome; begin HScroll (-FHPosition); end; procedure TViewerControl.HGoEnd; begin HScroll (FHLowEnd-FHPosition); end; procedure TViewerControl.SetFileName(const sFileName: UTF8String); begin if not (csDesigning in ComponentState) then begin UnMapFile; if sFileName <> '' then begin if MapFile(sFileName) then begin FFileName := sFileName; // Detect encoding if needed. if FEncoding = veAutoDetect then FEncoding := DetectEncoding; ReReadFile; end; end; end else FFileName := sFileName; end; function TViewerControl.MapFile(const sFileName: UTF8String): Boolean; function ReadFile: Boolean; inline; begin FMappedFile := GetMem(FFileSize); Result := (FileRead(FFileHandle, FMappedFile^, FFileSize) = FFileSize); FileClose(FFileHandle); FFileHandle := 0; end; {$IFDEF MSWINDOWS} var wFileName: WideString; begin Result := False; if Assigned(FMappedFile) then UnMapFile; // if needed wFileName := UTF8Decode(sFileName); FFileHandle := CreateFileW(PWChar(wFileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if FFileHandle = INVALID_HANDLE_VALUE then begin FFileHandle := 0; Exit; end; FFileSize := GetFileSize(FFileHandle, nil); if (FFileSize < MaxMemSize) then begin Result := ReadFile; Exit; end; FMappingHandle := CreateFileMapping(FFileHandle, nil, PAGE_READONLY, 0, 0, nil); if FMappingHandle <> 0 then FMappedFile := MapViewOfFile(FMappingHandle, FILE_MAP_READ, 0, 0, 0) else begin FMappedFile := nil; FileClose(FFileHandle); FFileHandle := 0; Exit; end; Result := True; end; {$ELSE} var StatBuf: Stat; begin Result := False; if Assigned(FMappedFile) then UnMapFile; // if needed FFileHandle := fpOpen(PChar(sFileName), O_RDONLY); if FFileHandle = feInvalidHandle then begin FFileHandle := 0; Exit; end; if fpFStat(FFileHandle, StatBuf) <> 0 then begin fpClose(FFileHandle); FFileHandle := 0; Exit; end; FFileSize := StatBuf.st_size; if (FFileSize < MaxMemSize) then begin Result := ReadFile; Exit; end; FMappedFile := fpmmap(nil, FFileSize, PROT_READ, MAP_PRIVATE{SHARED}, FFileHandle, 0); if FMappedFile = MAP_FAILED then begin FMappedFile:= nil; fpClose(FFileHandle); FFileHandle := 0; Exit; end; Result:= True; end; {$ENDIF} procedure TViewerControl.UnMapFile; begin if (FFileSize < MaxMemSize) then begin if Assigned(FMappedFile) then begin FreeMem(FMappedFile); FMappedFile := nil; end; end; {$IFDEF MSWINDOWS} if Assigned(FMappedFile) then begin UnmapViewOfFile(FMappedFile); FMappedFile := nil; end; if FMappingHandle <> 0 then begin CloseHandle(FMappingHandle); FMappingHandle := 0; end; if FFileHandle <> 0 then begin FileClose(FFileHandle); FFileHandle := 0; end; {$ELSE} if Assigned(FMappedFile) then begin if fpmunmap(FMappedFile, FFileSize) = -1 then DebugLn('Error unmapping file: ', SysErrorMessage(fpgeterrno)); FMappedFile := nil; end; if FFileHandle <> 0 then begin fpClose(FFileHandle); FFileHandle := 0; end; {$ENDIF} FFileName := ''; FFileSize := 0; Position := 0; FLowLimit := 0; FHighLimit := 0; FBOMLength := 0; FBlockBeg := 0; FBlockEnd := 0; end; procedure TViewerControl.WriteText; var yIndex, xIndex, w, scrollTab, i: Integer; LineStart, iPos: PtrInt; DataLength: PtrInt; begin iPos := FPosition; if ViewerMode = vmBook then w := Width div FColCount else w := 0; if (ViewerMode = vmText) and (FHPosition>0) then scrollTab := -FHPosition * Canvas.TextWidth('W') else scrollTab :=0; for xIndex := 0 to FColCount-1 do begin for yIndex := 0 to GetClientHeightInLines - 1 do begin if iPos >= FHighLimit then Break; AddLineOffset(iPos); LineStart := iPos; i := CalcTextLineLength(iPos, FHighLimit, DataLength); if i > FHLowEnd then FHLowEnd:=i; if DataLength > 0 then OutText(scrollTab+xIndex*w, yIndex * FTextHeight, LineStart, DataLength) end; end; end; procedure TViewerControl.WriteHex; var yIndex: Integer; iPos, LineStart: PtrInt; s: string; begin iPos := FPosition; for yIndex := 0 to GetClientHeightInLines - 1 do begin if iPos >= FHighLimit then Break; LineStart := iPos; AddLineOffset(iPos); s := TransformHex(iPos, FHighLimit); if s <> '' then OutHex(0, yIndex * FTextHeight, s, LineStart, iPos - LineStart); end; end; procedure TViewerControl.WriteBin; var yIndex: Integer; iPos, LineStart: PtrInt; s: string; begin iPos := FPosition; for yIndex := 0 to GetClientHeightInLines - 1 do begin if iPos >= FHighLimit then Break; LineStart := iPos; AddLineOffset(iPos); s := TransformBin(iPos, FHighLimit); if s <> '' then OutBin(0, yIndex * FTextHeight, s, LineStart, iPos - LineStart); end; end; function TViewerControl.GetDataAdr: Pointer; begin case FViewerMode of vmText, vmWrap, vmBook: Result := FMappedFile + FBOMLength; else Result := FMappedFile; end; end; procedure TViewerControl.SetPosition(Value: PtrInt); begin SetPosition(Value, False); end; procedure TViewerControl.SetHPosition(Value: Integer); begin SetHPosition(Value, False); end; procedure TViewerControl.SetHPosition(Value: Integer; Force: Boolean); begin if not IsFileOpen then Exit; FHPosition := Value; // Set new scroll position. if (FHLowEnd - FTextWidth) > 0 then begin if FHPosition > 0 then FHScrollBarPosition := FHPosition * 100 div (FHLowEnd - FTextWidth) else FHScrollBarPosition := 0; end; // Update scrollbar position. if FUpdateScrollBarPos then begin if FScrollBarHorz.Position <> FHScrollBarPosition then begin // Workaround for bug: http://bugs.freepascal.org/view.php?id=23815 {$IF DEFINED(LCLQT) and (LCL_FULLVERSION < 1010000)} FScrollBarHorz.OnScroll := nil; FScrollBarHorz.Position := FHScrollBarPosition; Application.ProcessMessages; // Skip message FScrollBarHorz.OnScroll := @ScrollBarHorzScroll; {$ELSE} FScrollBarHorz.Position := FHScrollBarPosition; {$ENDIF} end; end; // else the scrollbar position will be updated in ScrollBarVertScroll Invalidate; end; procedure TViewerControl.SetPosition(Value: PtrInt; Force: Boolean); var LinesTooMany: Integer; LastLineReached: Boolean; begin if not IsFileOpen then Exit; // Speedup if total nr of lines is less then nr of lines that can be displayed. if (FPosition = FLowLimit) and // only if already at the top (FLineList.Count > 0) and (FLineList.Count < GetClientHeightInLines) then Value := FLowLimit else // Boundary checks are done in GetStartOfLine. Value := GetStartOfLine(Value); if (Value <> FPosition) or Force then begin // Don't allow empty lines at the bottom of the control. LinesTooMany := GetClientHeightInLines - GetLinesTillEnd(Value, LastLineReached); if LinesTooMany > 0 then ScrollPosition(Value, -LinesTooMany); // scroll back upwards FPosition := Value; if Assigned(FOnPositionChanged) then FOnPositionChanged(Self); Invalidate; // Set new scroll position. if LastLineReached then FScrollBarPosition := 100 else FScrollBarPosition := Percent; end; // Update scrollbar position. if FUpdateScrollBarPos then begin if FScrollBarVert.Position <> FScrollBarPosition then begin // Workaround for bug: http://bugs.freepascal.org/view.php?id=23815 {$IF DEFINED(LCLQT) and (LCL_FULLVERSION < 1010000)} FScrollBarVert.OnScroll := nil; FScrollBarVert.Position := FScrollBarPosition; Application.ProcessMessages; // Skip message FScrollBarVert.OnScroll := @ScrollBarVertScroll; {$ELSE} FScrollBarVert.Position := FScrollBarPosition; {$ENDIF} end; end; // else the scrollbar position will be updated in ScrollBarVertScroll end; procedure TViewerControl.SetEncoding(AEncoding: TViewerEncoding); begin if not (csDesigning in ComponentState) then begin if AEncoding = veAutoDetect then FEncoding := DetectEncoding else FEncoding := AEncoding; ReReadFile; end else FEncoding := AEncoding; end; function TViewerControl.GetEncodingName: string; begin Result := ViewerEncodingsNames[FEncoding]; end; procedure TViewerControl.SetEncodingName(AEncodingName: string); var i: TViewerEncoding; begin for i := Low(TViewerEncoding) to High(TViewerEncoding) do if NormalizeEncoding(ViewerEncodingsNames[i]) = NormalizeEncoding(AEncodingName) then begin SetEncoding(i); break; end; end; function TViewerControl.GetClientHeightInLines: Integer; begin if FViewerMode <> vmText then Result:= 0 else // Take horizontal scrollbar into account Result:= GetSystemMetrics(SM_CYHSCROLL); if FTextHeight > 0 then Result := (ClientRect.Bottom - ClientRect.Top - Result) div FTextHeight // or Self.Height div FTextHeight? else Result := 0; end; function TViewerControl.GetLinesTillEnd(FromPosition: PtrInt; out LastLineReached: Boolean): Integer; var yIndex: Integer; iPos: PtrInt; DataLength: PtrInt; begin Result := 0; iPos := FromPosition; for yIndex := 0 to GetClientHeightInLines - 1 do begin if iPos >= FHighLimit then Break; Inc(Result, 1); case ViewerMode of vmBin: iPos := iPos + cBinWidth; vmHex: iPos := iPos + cHexWidth; vmText, vmWrap, vmBook: CalcTextLineLength(iPos, FHighLimit, DataLength); end; end; LastLineReached := (iPos >= FHighLimit); end; function TViewerControl.GetPercent: Integer; begin if FHighLimit - FLowLimit > 0 then Result := (Int64(FPosition - FLowLimit) * 100) div Int64(FHighLimit - FLowLimit) else Result := 0; end; procedure TViewerControl.SetPercent(const AValue: Integer); begin if FHighLimit - FLowLimit > 0 then Position := Int64(AValue) * (Int64(FHighLimit - FLowLimit) div 100) + FLowLimit else Position := 0; end; procedure TViewerControl.SetBlockBegin(const AValue: PtrInt); begin if (AValue >= FLowLimit) and (AValue < FHighLimit) then begin if FBlockEnd < AValue then FBlockEnd := AValue; FBlockBeg := AValue; Invalidate; end; end; procedure TViewerControl.SetBlockEnd(const AValue: PtrInt); begin if (AValue >= FLowLimit) and (AValue < FHighLimit) then begin if FBlockBeg > AValue then FBlockBeg := AValue; FBlockEnd := AValue; Invalidate; end; end; procedure TViewerControl.OutText(x, y: Integer; StartPos: PtrInt; DataLength: Integer); var pBegLine, pEndLine: PtrInt; iBegDrawIndex, iEndDrawIndex: PtrInt; xOffset: Integer; sText: string; begin pBegLine := StartPos; pEndLine := pBegLine + DataLength; if ((FBlockEnd - FBlockBeg) = 0) or ((FBlockBeg < pBegLine) and (FBlockEnd < pBegLine)) or // before ((FBlockBeg > pEndLine) and (FBlockEnd > pEndLine)) then //after begin // out of selection, draw normal Canvas.Font.Color := Font.Color; Canvas.TextOut(x, y, GetText(StartPos, DataLength, 0)); Exit; end; // Get selection start/end. if (FBlockBeg <= pBegLine) then iBegDrawIndex := pBegLine else iBegDrawIndex := FBlockBeg; if (FBlockEnd < pEndLine) then iEndDrawIndex := FBlockEnd else iEndDrawIndex := pEndLine; xOffset := 0; // Text before selection. if iBegDrawIndex - pBegLine > 0 then begin sText := GetText(StartPos, iBegDrawIndex - pBegLine, xOffset); Canvas.Font.Color := Font.Color; Canvas.TextOut(x, y, sText); x := x + Canvas.TextWidth(sText); xOffset := xOffset + UTF8Length(sText); end; // Selected text. sText := GetText(StartPos + iBegDrawIndex - pBegLine, iEndDrawIndex - iBegDrawIndex, xOffset); Canvas.Brush.Color := clHighlight; Canvas.Font.Color := clHighlightText; // Cannot simply draw text with brush with TextOut // because it differs between widgetsets. Canvas.Brush.Style := bsSolid; Canvas.FillRect(Bounds(x, y, Canvas.TextWidth(sText), FTextHeight)); Canvas.Brush.Style := bsClear; // Or use TextRect instead of TextOut with Opaque = True. //ts := Canvas.TextStyle; //ts.Opaque := True; //ts.Clipping := True; //Canvas.TextRect(Bounds(X, Y, Canvas.TextWidth(sText), FTextHeight), X, Y, sText, ts); Canvas.TextOut(x, y, sText); x := x + Canvas.TextWidth(sText); xOffset := xOffset + UTF8Length(sText); // restore previous canvas settings Canvas.Brush.Color := Color; Canvas.Font.Color := Font.Color; // Text after selection. if pEndLine - iEndDrawIndex > 0 then begin sText := GetText(StartPos + iEndDrawIndex - pBegLine, pEndLine - iEndDrawIndex, xOffset); Canvas.TextOut(x, y, sText); end; end; procedure TViewerControl.OutHex(x, y: Integer; sText: string; StartPos: PtrInt; DataLength: Integer); var pBegLine, pEndLine: PtrInt; iBegDrawIndex, iEndDrawIndex: PtrInt; sNextText: String = ''; sTmpText: String; begin pBegLine := StartPos; pEndLine := pBegLine + DataLength; if ((FBlockEnd - FBlockBeg) = 0) or ((FBlockBeg < pBegLine) and (FBlockEnd <= pBegLine)) or // before ((FBlockBeg > pEndLine) and (FBlockEnd > pEndLine)) then //after begin // out of selection, draw normal Canvas.Font.Color := Font.Color; Canvas.TextOut(x, y, sText); Exit; end; // Get selection start/end. if (FBlockBeg <= pBegLine) then iBegDrawIndex := pBegLine else iBegDrawIndex := FBlockBeg; if (FBlockEnd < pEndLine) then iEndDrawIndex := FBlockEnd else iEndDrawIndex := pEndLine; // Text before selection (offset and hex part). sTmpText := Copy(sText, 1, cHexStartHex + (iBegDrawIndex - pBegLine) * 3); Canvas.Font.Color := Font.Color; Canvas.TextOut(x, y, sTmpText); x := x + Canvas.TextWidth(sTmpText); // Selected text (hex part). sTmpText := Copy(sText, 1 + cHexStartHex + (iBegDrawIndex - pBegLine) * 3, (iEndDrawIndex - iBegDrawIndex) * 3); // Move last character from selection to not selected text. sNextText := Copy(sTmpText, Length(sTmpText), 1); Delete(sTmpText, Length(sTmpText), 1); Canvas.Brush.Color := clHighlight; Canvas.Font.Color := clHighlightText; Canvas.Brush.Style := bsSolid; Canvas.FillRect(Bounds(x, y, Canvas.TextWidth(sTmpText), FTextHeight)); Canvas.Brush.Style := bsClear; Canvas.TextOut(x, y, sTmpText); x := x + Canvas.TextWidth(sTmpText); // restore previous canvas settings Canvas.Brush.Color := Color; Canvas.Font.Color := Font.Color; // Text after selection (hex part). if pEndLine - iEndDrawIndex > 0 then begin sTmpText := sNextText + Copy(sText, 1 + cHexStartHex + (iEndDrawIndex - pBegLine) * 3, (pEndLine - iEndDrawIndex) * 3); sNextText := ''; Canvas.TextOut(x, y, sTmpText); x := x + Canvas.TextWidth(sTmpText); end; // Space after hex if data doesn't span full line. if DataLength < cHexWidth then sNextText := sNextText + Copy(sText, 1 + cHexStartHex + DataLength * 3, (cHexWidth - DataLength) * 3); // Space between hex and ascii. sTmpText := sNextText + ' '; Canvas.TextOut(x, y, sTmpText); x := x + Canvas.TextWidth(sTmpText); // Text before selection (ascii part). if iBegDrawIndex - pBegLine > 0 then begin sTmpText := Copy(sText, 1 + cHexStartAscii, iBegDrawIndex - pBegLine); Canvas.TextOut(x, y, sTmpText); x := x + Canvas.TextWidth(sTmpText); end; // Selected text (ascii part). sTmpText := Copy(sText, 1 + cHexStartAscii + iBegDrawIndex - pBegLine, iEndDrawIndex - iBegDrawIndex); Canvas.Brush.Color := clHighlight; Canvas.Font.Color := clHighlightText; Canvas.Brush.Style := bsSolid; Canvas.FillRect(Bounds(x, y, Canvas.TextWidth(sTmpText), FTextHeight)); Canvas.Brush.Style := bsClear; Canvas.TextOut(x, y, sTmpText); x := x + Canvas.TextWidth(sTmpText); // restore background color Canvas.Brush.Color := Color; Canvas.Font.Color := Font.Color; // Text after selection. if pEndLine - iEndDrawIndex > 0 then begin sTmpText := Copy(sText, 1 + cHexStartAscii + iEndDrawIndex - pBegLine, pEndLine - iEndDrawIndex); Canvas.TextOut(x, y, sTmpText); end; end; procedure TViewerControl.OutBin(x, y: Integer; sText: string; StartPos: PtrInt; DataLength: Integer); var pBegLine, pEndLine: PtrInt; iBegDrawIndex, iEndDrawIndex: PtrInt; sTmpText: String; begin pBegLine := StartPos; pEndLine := pBegLine + DataLength; if ((FBlockEnd - FBlockBeg) = 0) or ((FBlockBeg < pBegLine) and (FBlockEnd < pBegLine)) or // before ((FBlockBeg > pEndLine) and (FBlockEnd > pEndLine)) then //after begin // out of selection, draw normal Canvas.Font.Color := Font.Color; Canvas.TextOut(x, y, sText); Exit; end; // Get selection start/end. if (FBlockBeg <= pBegLine) then iBegDrawIndex := pBegLine else iBegDrawIndex := FBlockBeg; if (FBlockEnd < pEndLine) then iEndDrawIndex := FBlockEnd else iEndDrawIndex := pEndLine; // Text before selection. if iBegDrawIndex - pBegLine > 0 then begin sTmpText := Copy(sText, 1, iBegDrawIndex - pBegLine); Canvas.Font.Color := Font.Color; Canvas.TextOut(x, y, sTmpText); x := x + Canvas.TextWidth(sTmpText); end; // Selected text. sTmpText := Copy(sText, 1 + iBegDrawIndex - pBegLine, iEndDrawIndex - iBegDrawIndex); Canvas.Brush.Color := clHighlight; Canvas.Font.Color := clHighlightText; Canvas.Brush.Style := bsSolid; Canvas.FillRect(Bounds(x, y, Canvas.TextWidth(sTmpText), FTextHeight)); Canvas.Brush.Style := bsClear; Canvas.TextOut(x, y, sTmpText); x := x + Canvas.TextWidth(sTmpText); // restore previous canvas settings Canvas.Brush.Color := Color; Canvas.Font.Color := Font.Color; // Text after selection. if pEndLine - iEndDrawIndex > 0 then begin sTmpText := Copy(sText, 1 + iEndDrawIndex - pBegLine, pEndLine - iEndDrawIndex); Canvas.TextOut(x, y, sTmpText); end; end; procedure TViewerControl.AddLineOffset(iOffset: PtrInt); begin FLineList.Add(iOffset); end; procedure TViewerControl.KeyDown(var Key: word; Shift: TShiftState); begin if Shift = [] then begin case Key of VK_DOWN: begin Key := 0; Scroll(1); end; VK_UP: begin Key := 0; Scroll(-1); end; VK_HOME: begin Key := 0; GoHome; end; VK_END: begin Key := 0; GoEnd; end; VK_PRIOR: begin Key := 0; PageUp; end; VK_NEXT: begin Key := 0; PageDown; end; else inherited KeyDown(Key, Shift); end; end else if Shift = [ssCtrl] then begin case Key of VK_HOME: begin Key := 0; GoHome; end; VK_END: begin Key := 0; GoEnd; end; else inherited KeyDown(Key, Shift); end; end else inherited KeyDown(Key, Shift); end; function TViewerControl.FindAsciiSetForward(aPosition, aMaxBytes: PtrInt; const AsciiChars: String; bFindNotIn: Boolean): PtrInt; var i: Integer; found: Boolean; u: Cardinal; CharLenInBytes: Integer; begin Result := -1; while aMaxBytes > 0 do begin u := GetNextCharAsAscii(aPosition, CharLenInBytes); if CharLenInBytes = 0 then Exit; if not bFindNotIn then begin for i := 1 to Length(AsciiChars) do if u = ord(AsciiChars[i]) then Exit(aPosition); end else begin found := False; for i := 1 to Length(AsciiChars) do if u = ord(AsciiChars[i]) then begin found := True; break; end; if not found then Exit(aPosition); end; Inc(aPosition, CharLenInBytes); Dec(aMaxBytes, CharLenInBytes); end; end; function TViewerControl.FindAsciiSetBackward(aPosition, aMaxBytes: PtrInt; const AsciiChars: String; bFindNotIn: Boolean): PtrInt; var i: Integer; found: Boolean; u: Cardinal; CharLenInBytes: Integer; begin Result := -1; while aMaxBytes > 0 do begin u := GetPrevCharAsAscii(aPosition, CharLenInBytes); if CharLenInBytes = 0 then Exit; if not bFindNotIn then begin for i := 1 to Length(AsciiChars) do if u = ord(AsciiChars[i]) then Exit(aPosition); end else begin found := False; for i := 1 to Length(AsciiChars) do if u = ord(AsciiChars[i]) then begin found := True; break; end; if not found then Exit(aPosition); end; Dec(aPosition, CharLenInBytes); Dec(aMaxBytes, CharLenInBytes); end; end; procedure TViewerControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var LineBegin, LineEnd: PtrInt; ClickPos: PtrInt; CharSide: TCharSide; begin inherited; SetFocus; if not IsFileOpen then Exit; case Button of mbLeft: begin if Shift * [ssDouble, ssTriple] = [] then begin // Single click. ClickPos := XYPos2Adr(x, y, CharSide); if ClickPos <> -1 then begin FBlockBeg := ClickPos; FBlockEnd := ClickPos; FMouseBlockBeg := ClickPos; FMouseBlockSide := CharSide; FSelecting := True; Invalidate; end else FSelecting := False; end else // if double click or triple click begin FSelecting := False; LineBegin := GetStartOfLine(FMouseBlockBeg); LineEnd := GetEndOfLine(FMouseBlockBeg); if ssDouble in Shift then begin // Select word with double-click. FBlockBeg := FindAsciiSetBackward(FMouseBlockBeg, FMouseBlockBeg - LineBegin, sNonCharacter, False); FBlockEnd := FindAsciiSetForward(FMouseBlockBeg, LineEnd - FMouseBlockBeg, sNonCharacter, False); end else if ssTriple in Shift then begin // Select line with triple-click. FBlockBeg := FindAsciiSetForward(LineBegin, LineEnd - LineBegin, sWhiteSpace, True); FBlockEnd := FindAsciiSetBackward(LineEnd, LineEnd - LineBegin, sWhiteSpace, True); end; if FBlockBeg = -1 then FBlockBeg := LineBegin; if FBlockEnd = -1 then FBlockEnd := LineEnd; if FBlockBeg > FBlockEnd then FBlockEnd := FBlockBeg; CopyToClipboard; Invalidate; end; end; // mbLeft end; // case end; procedure TViewerControl.MouseMove(Shift: TShiftState; X, Y: Integer); procedure MoveOneChar(var aPosition: PtrInt); var CharLenInBytes: Integer; begin GetNextCharAsAscii(aPosition, CharLenInBytes); aPosition := aPosition + CharLenInBytes; end; procedure MoveOneCharByMouseSide(var aPosition: PtrInt); begin if FMouseBlockSide in [csRight, csAfter] then MoveOneChar(aPosition); end; var ClickPos: PtrInt; CharSide: TCharSide; begin inherited; if FSelecting then begin if y < FTextHeight then Scroll(-3) else if y > ClientHeight - FTextHeight then Scroll(3); ClickPos := XYPos2Adr(x, y, CharSide); if ClickPos <> -1 then begin if ClickPos < FMouseBlockBeg then begin // Got a new beginning. FBlockBeg := ClickPos; FBlockEnd := FMouseBlockBeg; // Move end beyond last character. MoveOneCharByMouseSide(FBlockEnd); // When selecting from right to left, the current selected side must be // either csLeft or csBefore, otherwise current position is not included. if not (CharSide in [csLeft, csBefore]) then begin // Current position should not be included in selection. // Move beginning after first character. MoveOneChar(FBlockBeg); end; end else if ClickPos > FMouseBlockBeg then begin // Got a new end. FBlockBeg := FMouseBlockBeg; FBlockEnd := ClickPos; // Move beginning after first character. MoveOneCharByMouseSide(FBlockBeg); // When selecting from left to right, the current selected side must be // either csRight or csAfter, otherwise current position is not included. if CharSide in [csRight, csAfter] then begin // Current position should be included in selection. // Move end beyond last character. MoveOneChar(FBlockEnd); end; end else if FMouseBlockSide <> CharSide then begin // Same position but changed side of the character. FBlockBeg := FMouseBlockBeg; FBlockEnd := FMouseBlockBeg; if ((FMouseBlockSide in [csBefore, csLeft]) and (CharSide in [csRight, csAfter])) or ((FMouseBlockSide in [csRight, csAfter]) and (CharSide in [csBefore, csLeft])) then begin // Move end beyond last character. MoveOneChar(FBlockEnd); end; end else begin FBlockBeg := FMouseBlockBeg; FBlockEnd := FMouseBlockBeg; end; Invalidate; end; end; end; procedure TViewerControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; if FSelecting and (Button = mbLeft) and (Shift * [ssDouble, ssTriple] = []) then begin CopyToClipboard; FSelecting := False; end; end; function TViewerControl.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; begin Result := inherited; if not Result then Result := Scroll(Mouse.WheelScrollLines); end; function TViewerControl.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; begin Result := inherited; if not Result then Result := Scroll(-Mouse.WheelScrollLines); end; function TViewerControl.XYPos2Adr(x, y: Integer; out CharSide: TCharSide): PtrInt; var yIndex: Integer; StartLine, EndLine: PtrInt; function XYPos2AdrBin: PtrInt; var i: Integer; px: Integer = 0; charWidth: Integer; sText: String; tmpPosition: PtrInt; begin tmpPosition := StartLine; sText := TransformBin(tmpPosition, EndLine); for i := 1 to Length(sText) do begin charWidth := Canvas.TextWidth(string(sText[i])); if px + charWidth > x then begin if px + charWidth div 2 > x then CharSide := csLeft else CharSide := csRight; Exit(StartLine + i - 1); // -1 because we count from 1 end; px := px + charWidth; end; CharSide := csBefore; Result := EndLine; end; function XYPos2AdrHex: PtrInt; var i: Integer; px: Integer = 0; charWidth: Integer; sText, sPartialText: String; tmpPosition: PtrInt; begin tmpPosition := StartLine; sText := TransformHex(tmpPosition, EndLine); // Clicked on offset. sPartialText := Copy(sText, 1, cHexStartHex); charWidth := Canvas.TextWidth(sPartialText); px := px + charWidth; if px > x then begin CharSide := csBefore; Exit(StartLine); end; // Clicked on hex part. for i := 0 to cHexWidth - 1 do begin sPartialText := Copy(sText, 1 + cHexStartHex + i * 3, 2); charWidth := Canvas.TextWidth(sPartialText); if px + charWidth > x then begin // Check if we're not after end of data. if StartLine + i >= EndLine then begin CharSide := csBefore; Exit(EndLine); end; if px + charWidth div 2 > x then CharSide := csLeft else CharSide := csRight; Exit(StartLine + i); end; // Space after hex number. charWidth := charWidth + Canvas.TextWidth(string(sText[1 + cHexStartHex + i * 3 + 2])); if px + charWidth > x then begin CharSide := csAfter; Exit(StartLine + i); end; px := px + charWidth; end; // Clicked between hex and ascii. sPartialText := Copy(sText, 1 + cHexEndHex, cHexStartAscii - cHexEndHex); charWidth := Canvas.TextWidth(sPartialText); if px + charWidth > x then begin Exit(-1); // No position. end; px := px + charWidth; // Clicked on ascii part. for i := 0 to cHexWidth - 1 do begin charWidth := Canvas.TextWidth(string(sText[1 + cHexStartAscii + i])); if px + charWidth > x then begin // Check if we're not after end of data. if StartLine + i >= EndLine then begin CharSide := csBefore; Exit(EndLine); end; if px + charWidth div 2 > x then CharSide := csLeft else CharSide := csRight; Exit(StartLine + i); end; px := px + charWidth; end; CharSide := csBefore; Result := EndLine; end; function XYPos2AdrText: PtrInt; var i: Integer; px: Integer = 0; charWidth: Integer; len: Integer = 0; CharLenInBytes: Integer; s: UTF8String; begin i := StartLine; while i < EndLine do begin s := GetNextCharAsUtf8(i, CharLenInBytes); if CharLenInBytes = 0 then Break; // Check if the conversion to UTF-8 was successful. if Length(s) > 0 then begin if s = #9 then begin s := StringOfChar(' ', cTabSpaces - len mod cTabSpaces); len := len + (cTabSpaces - len mod cTabSpaces); end else Inc(len); // Assume there is one character after conversion // (otherwise use Inc(len, UTF8Length(s))). if len <= FHPosition then begin i := i + CharLenInBytes; Continue; end; charWidth := Canvas.TextWidth(s); if px + charWidth > x then begin if px + charWidth div 2 > x then CharSide := csLeft else CharSide := csRight; Exit(i); end; px := px + charWidth; end; i := i + CharLenInBytes; end; CharSide := csBefore; Result := EndLine; end; begin if FLineList.Count = 0 then Exit(-1); yIndex := y div FTextHeight; if yIndex >= FLineList.Count then yIndex := FLineList.Count - 1; if yIndex < 0 then yIndex := 0; // Get position of first character of the line. StartLine := FLineList.Items[yIndex]; // Get position of last character of the line. EndLine := GetEndOfLine(StartLine); if x = 0 then begin CharSide := csBefore; Exit(StartLine); end; case ViewerMode of vmBin: Result := XYPos2AdrBin; vmHex: Result := XYPos2AdrHex; vmText, vmWrap, vmBook: Result := XYPos2AdrText; else raise Exception.Create('Invalid viewer mode'); end; end; procedure TViewerControl.SelectAll; begin SelectText(FLowLimit, FHighLimit); end; procedure TViewerControl.SelectText(AStart, AEnd: PtrInt); begin if AStart < FLowLimit then AStart := FLowLimit; if AEnd > FHighLimit then AEnd := FHighLimit; if AStart <= AEnd then begin FBlockBeg := AStart; FBlockEnd := AEnd; Invalidate; end; end; procedure TViewerControl.CopyToClipboard; var sText, utf8Text: string; begin if (FBlockEnd - FBlockBeg) <= 0 then Exit; if (FBlockEnd - FBlockBeg) > 1024 * 1024 then // Max 1 MB to clipboard Exit; SetString(sText, GetDataAdr + FBlockBeg, FBlockEnd - FBlockBeg); utf8Text := ConvertToUTF8(sText); {$IFDEF LCLGTK2} // Workaround for Lazarus bug #0021453. LCL adds trailing zero to clipboard in Clipboard.AsText. Clipboard.Clear; Clipboard.AddFormat(PredefinedClipboardFormat(pcfText), utf8Text[1], Length(utf8Text)); {$ELSE} Clipboard.AsText := utf8Text; {$ENDIF} end; function TViewerControl.GetNextCharAsAscii(const iPosition: PtrInt; out CharLenInBytes: Integer): Cardinal; var u1, u2: Word; InvalidCharLen: Integer; begin Result := 0; case FEncoding of veUtf8, veUtf8bom: begin if iPosition < FHighLimit then begin CharLenInBytes := SafeUTF8NextCharLen(GetDataAdr + iPosition, FHighLimit - iPosition, InvalidCharLen); // It's enough to only return Ascii. if CharLenInBytes = 1 then Result := PByte(GetDataAdr)[iPosition]; // Full conversion: // Result := UTF8CharacterToUnicode(PAnsiChar(GetDataAdr + iPosition), CharLenInBytes); end else CharLenInBytes := 0; end; veAnsi, veCp1250..veCp950, veIso88591, veIso88592, veKoi8: if iPosition < FHighLimit then begin Result := PByte(GetDataAdr)[iPosition]; CharLenInBytes := 1; end else CharLenInBytes := 0; veUcs2be: if iPosition + SizeOf(Word) - 1 < FHighLimit then begin Result := BEtoN(PWord(GetDataAdr + iPosition)[0]); CharLenInBytes := SizeOf(Word); end else CharLenInBytes := 0; veUcs2le: if iPosition + SizeOf(Word) - 1 < FHighLimit then begin Result := LEtoN(PWord(GetDataAdr + iPosition)[0]); CharLenInBytes := SizeOf(Word); end else CharLenInBytes := 0; veUtf16be: if iPosition + SizeOf(Word) - 1 < FHighLimit then begin u1 := BEtoN(PWord(GetDataAdr + iPosition)[0]); CharLenInBytes := UTF16CharacterLength(@u1); if CharLenInBytes = 1 then begin Result := u1; end else if iPosition + SizeOf(Word) * CharLenInBytes - 1 < FHighLimit then begin u2 := BEtoN(PWord(GetDataAdr + iPosition)[1]); Result := utf16PairToUnicode(u1, u2); end; CharLenInBytes := CharLenInBytes * SizeOf(Word); end else CharLenInBytes := 0; veUtf16le: if iPosition + SizeOf(Word) - 1 < FHighLimit then begin u1 := LEtoN(PWord(GetDataAdr + iPosition)[0]); CharLenInBytes := UTF16CharacterLength(@u1); if CharLenInBytes = 1 then begin Result := u1; end else if iPosition + SizeOf(Word) * CharLenInBytes - 1 < FHighLimit then begin u2 := LEtoN(PWord(GetDataAdr + iPosition)[1]); Result := utf16PairToUnicode(u1, u2); end else CharLenInBytes := 0; CharLenInBytes := CharLenInBytes * SizeOf(Word); end else CharLenInBytes := 0; veUtf32be: if iPosition + SizeOf(LongWord) - 1 < FHighLimit then begin Result := BEtoN(PLongWord(GetDataAdr + iPosition)[0]); CharLenInBytes := SizeOf(LongWord); end else CharLenInBytes := 0; veUtf32le: if iPosition + SizeOf(LongWord) - 1 < FHighLimit then begin Result := LEtoN(PLongWord(GetDataAdr + iPosition)[0]); CharLenInBytes := SizeOf(LongWord); end else CharLenInBytes := 0; else raise Exception.Create('Unsupported viewer encoding'); end; end; function TViewerControl.GetPrevCharAsAscii(const iPosition: PtrInt; out CharLenInBytes: Integer): Cardinal; var u1, u2: Word; InvalidCharLen: Integer; begin Result := 0; case FEncoding of veUtf8, veUtf8bom: begin if iPosition > FLowLimit then begin CharLenInBytes := SafeUTF8PrevCharLen(GetDataAdr + iPosition, iPosition - FLowLimit, InvalidCharLen); // It's enough to only return Ascii. if CharLenInBytes = 1 then Result := PByte(GetDataAdr)[iPosition - 1]; // Full conversion: // Result := UTF8CharacterToUnicode(PAnsiChar(GetDataAdr + iPosition - CharLenInBytes), CharLenInBytes); end else CharLenInBytes := 0; end; veAnsi, veCp1250..veCp950, veIso88591, veIso88592, veKoi8: if iPosition > FLowLimit then begin Result := PByte(GetDataAdr + iPosition)[-1]; CharLenInBytes := 1; end else CharLenInBytes := 0; veUcs2be: if iPosition >= FLowLimit + SizeOf(Word) then begin Result := BEtoN(PWord(GetDataAdr + iPosition)[-1]); CharLenInBytes := SizeOf(Word); end else CharLenInBytes := 0; veUcs2le: if iPosition >= FLowLimit + SizeOf(Word) then begin Result := LEtoN(PWord(GetDataAdr + iPosition)[-1]); CharLenInBytes := SizeOf(Word); end else CharLenInBytes := 0; veUtf16be: if iPosition >= FLowLimit + SizeOf(Word) then begin u1 := BEtoN(PWord(GetDataAdr + iPosition)[-1]); CharLenInBytes := UTF16CharacterLength(@u1); if CharLenInBytes = 1 then begin Result := u1; end else if iPosition >= FLowLimit + SizeOf(Word) * CharLenInBytes then begin u2 := BEtoN(PWord(GetDataAdr + iPosition)[-2]); // u2 is the first, u1 is the second value of the pair Result := utf16PairToUnicode(u2, u1); end; CharLenInBytes := CharLenInBytes * SizeOf(Word); end else CharLenInBytes := 0; veUtf16le: if iPosition >= FLowLimit + SizeOf(Word) then begin u1 := LEtoN(PWord(GetDataAdr + iPosition)[-1]); CharLenInBytes := UTF16CharacterLength(@u1); if CharLenInBytes = 1 then begin Result := u1; end else if iPosition >= FLowLimit + SizeOf(Word) * CharLenInBytes then begin u2 := LEtoN(PWord(GetDataAdr + iPosition)[-2]); // u2 is the first, u1 is the second value of the pair Result := utf16PairToUnicode(u2, u1); end; CharLenInBytes := CharLenInBytes * SizeOf(Word); end else CharLenInBytes := 0; veUtf32be: if iPosition >= FLowLimit + SizeOf(LongWord) then begin Result := BEtoN(PLongWord(GetDataAdr + iPosition)[-1]); CharLenInBytes := SizeOf(LongWord); end else CharLenInBytes := 0; veUtf32le: if iPosition >= FLowLimit + SizeOf(LongWord) then begin Result := LEtoN(PLongWord(GetDataAdr + iPosition)[-1]); CharLenInBytes := SizeOf(LongWord); end else CharLenInBytes := 0; else raise Exception.Create('Unsupported viewer encoding'); end; end; function TViewerControl.GetNextCharAsUtf8(const iPosition: PtrInt; out CharLenInBytes: Integer): UTF8String; var u1: Word; s: string; InvalidCharLen: Integer; begin Result := ''; case FEncoding of veUtf8, veUtf8bom: CharLenInBytes := SafeUTF8NextCharLen(GetDataAdr + iPosition, FHighLimit - iPosition, InvalidCharLen); veAnsi, veCp1250..veCp950, veIso88591, veIso88592, veKoi8: CharLenInBytes := 1; veUcs2be, veUcs2le: CharLenInBytes := 2; veUtf16be: if iPosition + SizeOf(Word) - 1 < FHighLimit then begin u1 := BEtoN(PWord(GetDataAdr + iPosition)[0]); CharLenInBytes := UTF16CharacterLength(@u1) * SizeOf(Word); end else CharLenInBytes := 0; veUtf16le: if iPosition + SizeOf(Word) - 1 < FHighLimit then begin u1 := LEtoN(PWord(GetDataAdr + iPosition)[0]); CharLenInBytes := UTF16CharacterLength(@u1) * SizeOf(Word); end else CharLenInBytes := 0; veUtf32be, veUtf32le: CharLenInBytes := 4; else raise Exception.Create('Unsupported viewer encoding'); end; if (CharLenInBytes > 0) and (iPosition + CharLenInBytes - 1 < FHighLimit) then begin SetString(s, GetDataAdr + iPosition, CharLenInBytes); Result := ConvertToUTF8(s); end else Result := ''; end; function TViewerControl.ConvertToUTF8(const sText: AnsiString): UTF8String; begin if FEncoding = veAutoDetect then FEncoding := DetectEncoding; // Force detect encoding. case FEncoding of veAutoDetect: ; veUtf8, veUtf8bom: Result := Utf8ReplaceBroken(sText); veUtf16be: Result := Utf16BEToUtf8(sText); veUtf16le: Result := Utf16LEToUtf8(sText); veUtf32be: Result := Utf32BEToUtf8(sText); veUtf32le: Result := Utf32LEToUtf8(sText); else Result := LConvEncoding.ConvertEncoding(sText, ViewerEncodingsNames[FEncoding], EncodingUTF8); end; end; function TViewerControl.ConvertFromUTF8(const sText: UTF8String): AnsiString; begin if FEncoding = veAutoDetect then FEncoding := DetectEncoding; // Force detect encoding. case FEncoding of veAutoDetect: ; veUtf8, veUtf8bom: Result := sText; veUtf16be: Result := Utf8ToUtf16BE(sText); veUtf16le: Result := Utf8ToUtf16LE(sText); veUtf32be: Result := '';//Utf8ToUtf32BE(sText); veUtf32le: Result := '';//Utf8ToUtf32LE(sText); else Result := LConvEncoding.ConvertEncoding(sText, EncodingUTF8, ViewerEncodingsNames[FEncoding]); end; end; function TViewerControl.IsVisible(const aPosition: PtrInt): Boolean; var StartPos: PtrInt; CharLenInBytes: Integer; begin if IsFileOpen and (FLineList.Count > 0) then begin FVisibleOffset:= 0; StartPos:= GetStartOfLine(aPosition); // Calculate horizontal offset in symbols while (StartPos < aPosition) do begin GetNextCharAsAscii(StartPos, CharLenInBytes); Inc(StartPos, CharLenInBytes); Inc(FVisibleOffset); end; Result := (aPosition >= FLineList.Items[0]) and (aPosition <= FLineList.Items[FLineList.Count - 1]) and (FVisibleOffset >= FHPosition) and (FVisibleOffset <= FHPosition + FTextWidth); end else Result := False; end; procedure TViewerControl.MakeVisible(const aPosition: PtrInt); begin if not IsVisible(aPosition) then begin SetPosition(aPosition); Scroll(-4); Update; if (FVisibleOffset < FHPosition) or (FVisibleOffset > FHPosition + FTextWidth) then begin SetHPosition(FVisibleOffset); HScroll(-1); end; end; end; procedure TViewerControl.ScrollBarVertScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); begin FUpdateScrollBarPos := False; case ScrollCode of scLineUp: Scroll(-1); scLineDown: Scroll(1); scPageUp: PageUp; scPageDown: PageDown; scTop: GoHome; scBottom: GoEnd; scTrack, scPosition: begin // This check helps avoiding loops if changing ScrollPos below // triggers another scPosition message. if (ScrollCode = scTrack) or (ScrollPos <> FScrollBarPosition) then begin if ScrollPos = 0 then GoHome else if ScrollPos = 100 then GoEnd else Percent := ScrollPos; end; end; scEndScroll: begin end; end; ScrollPos := FScrollBarPosition; FUpdateScrollBarPos := True; end; procedure TViewerControl.ScrollBarHorzScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); begin FUpdateScrollBarPos := False; case ScrollCode of scLineUp: HScroll(-1); scLineDown: HScroll(1); scPageUp: HPageUp; scPageDown: HPageDown; scTop: HGoHome; scBottom: HGoEnd; scTrack, scPosition: begin // This check helps avoiding loops if changing ScrollPos below // triggers another scPosition message. if (ScrollCode = scTrack) or (ScrollPos <> FHScrollBarPosition) then begin if ScrollPos = 0 then HGoHome else if ScrollPos = 100 then HGoEnd else HScroll((FHLowEnd - FTextWidth) * ScrollPos div 100 - FHPosition); end; end; scEndScroll: begin end; end; ScrollPos := FHScrollBarPosition; FUpdateScrollBarPos := True; end; procedure TViewerControl.UpdateScrollbars; begin FScrollBarVert.LargeChange := GetClientHeightInLines - 1; case ViewerMode of vmBin, vmHex: begin //FScrollBarVert.PageSize := // ((FHighLimit div cHexWidth - GetClientHeightInLines) div 100); end else FScrollBarVert.PageSize := 1; end; FScrollBarHorz.Visible:= (FViewerMode = vmText); end; procedure TViewerControl.ViewerResize(Sender: TObject); begin UpdateScrollbars; // Force recalculating position. SetPosition(FPosition); SetHPosition(FHPosition); end; procedure TViewerControl.ReReadFile; begin FBlockBeg := 0; FBlockEnd := 0; FBOMLength := GetBomLength; UpdateLimits; UpdateScrollbars; Invalidate; end; function TViewerControl.IsFileOpen: Boolean; begin Result := Assigned(FMappedFile); end; function TViewerControl.DetectEncoding: TViewerEncoding; var DetectStringLength: Integer = 2048; // take first 2kB of the file to detect encoding DetectString: String; DetectedEncodingName: String; Enc: TViewerEncoding; begin if IsFileOpen then begin // Default to Ansi in case encoding cannot be detected or is unsupported. Result := veAnsi; if FFileSize < DetectStringLength then DetectStringLength := FFileSize; SetString(DetectString, PAnsiChar(FMappedFile), DetectStringLength); if Assigned(FOnGuessEncoding) then DetectedEncodingName := FOnGuessEncoding(DetectString) else DetectedEncodingName := LConvEncoding.GuessEncoding(DetectString); if DetectedEncodingName <> '' then begin DetectedEncodingName := NormalizeEncoding(DetectedEncodingName); // Map UCS-2 to UTF-16. if DetectedEncodingName = 'ucs2le' then DetectedEncodingName := 'utf16le' else if DetectedEncodingName = 'ucs2be' then DetectedEncodingName := 'utf16be'; for Enc := Low(TViewerEncoding) to High(TViewerEncoding) do begin if NormalizeEncoding(ViewerEncodingsNames[Enc]) = DetectedEncodingName then begin Result := Enc; break; end; end; end; end else Result := veAutoDetect; end; procedure TViewerControl.GetSupportedEncodings(List: TStrings); var Enc: TViewerEncoding; begin for Enc := Low(TViewerEncoding) to High(TViewerEncoding) do List.Add(ViewerEncodingsNames[Enc]); end; function TViewerControl.GetBomLength: Integer; begin Result := 0; case FEncoding of veUtf8, veUtf8bom: if (FFileSize >= 3) and (PByte(FMappedFile)[0] = $EF) and (PByte(FMappedFile)[1] = $BB) and (PByte(FMappedFile)[2] = $BF) then begin Result := 3; end; veUcs2be, veUtf16be: if (FFileSize >= 2) and (PByte(FMappedFile)[0] = $FE) and (PByte(FMappedFile)[1] = $FF) then begin Result := 2; end; veUcs2le, veUtf16le: if (FFileSize >= 2) and (PByte(FMappedFile)[0] = $FF) and (PByte(FMappedFile)[1] = $FE) then begin Result := 2; end; veUtf32be: if (FFileSize >= 4) and (PByte(FMappedFile)[0] = $00) and (PByte(FMappedFile)[1] = $00) and (PByte(FMappedFile)[2] = $FE) and (PByte(FMappedFile)[3] = $FF) then begin Result := 4; end; veUtf32le: if (FFileSize >= 4) and (PByte(FMappedFile)[0] = $00) and (PByte(FMappedFile)[1] = $00) and (PByte(FMappedFile)[2] = $FF) and (PByte(FMappedFile)[3] = $FE) then begin Result := 4; end; end; end; procedure TViewerControl.UpdateLimits; begin if FEncoding = veAutoDetect then FEncoding := DetectEncoding; FBOMLength := GetBomLength; case FViewerMode of vmText, vmWrap, vmBook: begin FLowLimit := 0; FHighLimit := FFileSize - FBOMLength; end; else begin FLowLimit := 0; FHighLimit := FFileSize; end; end; end; procedure TViewerControl.UpdateSelection; procedure Check(var aPosition: PtrInt; Backwards: Boolean); var CharStart: Pointer; begin case FEncoding of veUtf8, veUtf8bom: begin if not Backwards then begin CharStart := SafeUTF8NextCharStart(GetDataAdr + aPosition, FHighLimit - aPosition); if Assigned(CharStart) then aPosition := CharStart - GetDataAdr else aPosition := 0; end else begin CharStart := SafeUTF8PrevCharEnd(GetDataAdr + aPosition, aPosition - FLowLimit); if Assigned(CharStart) then aPosition := CharStart - GetDataAdr else aPosition := 0; end; end; veAnsi, veCp1250..veCp950, veIso88591, veIso88592, veKoi8: ; // any position allowed veUcs2be, veUcs2le: aPosition := ((aPosition - FLowLimit) and not 1) + FLowLimit; veUtf16be, veUtf16le: // todo: check if not in the middle of utf-16 character aPosition := ((aPosition - FLowLimit) and not 1) + FLowLimit; veUtf32be, veUtf32le: aPosition := ((aPosition - FLowLimit) and not 3) + FLowLimit; else raise Exception.Create('Unsupported viewer encoding'); end; end; begin if (FBlockBeg < FLowLimit) or (FBlockBeg >= FHighLimit) or (FBlockEnd < FLowLimit) or (FBlockEnd >= FHighLimit) then begin FBlockBeg := FLowLimit; FBlockEnd := FLowLimit; end else begin case FViewerMode of vmText, vmWrap, vmBook: begin Check(FBlockBeg, False); Check(FBlockEnd, True); if (FBlockBeg < FLowLimit) or (FBlockBeg >= FHighLimit) or (FBlockEnd < FLowLimit) or (FBlockEnd >= FHighLimit) or (FBlockEnd < FBlockBeg) then begin FBlockBeg := FLowLimit; FBlockEnd := FLowLimit; end; end; // In non-text modes any selection is valid. end; end; end; function TViewerControl.FindUtf8Text(iStartPos: PtrInt; const sSearchText: UTF8String; bCaseSensitive: Boolean; bSearchBackwards: Boolean): PtrInt; var SearchTextLength: Integer; sSearchChars: array of UTF8String; pCurrentAddr, pEndAddr: PtrInt; i, charLen: Integer; function sPos2(pAdr: PtrInt):Boolean; var curChr:UTF8String; i, charLen: Integer; begin Result := False; for i := 0 to SearchTextLength-1 do begin curChr:=GetNextCharAsUtf8(pAdr,charLen); case bCaseSensitive of False: if UTF8UpperCase(curChr) <> UTF8UpperCase(sSearchChars[i]) then Exit; True : if curChr <> sSearchChars[i] then Exit; end; if charLen>0 then pAdr:=pAdr+charLen else Inc(pAdr); end; Result:=True; end; begin Result := PtrInt(-1); SearchTextLength := UTF8Length(sSearchText); if (SearchTextLength <= 0) then Exit; setLength(sSearchChars,SearchTextLength); for i:=1 to SearchTextLength do sSearchChars[i-1]:=UTF8Copy(sSearchText,i,1); pCurrentAddr := iStartPos; pEndAddr := FHighLimit - Length(ConvertFromUTF8(sSearchText)); if bSearchBackwards and (pCurrentAddr > pEndAddr) then // Move to the first possible position for searching backwards. pCurrentAddr := pEndAddr; if (pEndAddr < 0) or (pCurrentAddr < 0) or (pCurrentAddr > pEndAddr) then Exit; while True do begin if (pCurrentAddr > pEndAddr) or (pCurrentAddr < 0) then Exit; if sPos2(pCurrentAddr) then begin Result := pCurrentAddr; Exit; end; case bSearchBackwards of False: begin GetNextCharAsUtf8(pCurrentAddr,charLen); if charLen>0 then pCurrentAddr:=pCurrentAddr+charLen else Inc(pCurrentAddr); end; True : Dec(pCurrentAddr); end; end; end; procedure Register; begin RegisterComponents('SeksiCmd', [TViewerControl]); end; end.