| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957 |
- {
- Double Commander
- -------------------------------------------------------------------------
- Show file in the text, bin, hex or dec mode
- Copyright (C) 2004 Radek Cervinka ([email protected])
- Copyright (C) 2006-2025 Alexander Koblov ([email protected])
- This program 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 program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>.
- }
- (*
- 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) Selecting text does not work well with composed Unicode characters
- (characters that are composed of multiple Unicode characters).
- c) Drawing/selecting text does not work correctly with RTL (right to left) text.
- d) 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, LCLVersion, LMessages, fgl;
- const
- MaxMemSize = $400000; // 4 Mb
- type
- TViewerControlMode = (vcmBin, vcmHex, vcmText, vcmWrap, vcmBook, vcmDec);
- TDataAccess = (dtMmap, dtNothing);
- TCharSide = (csBefore, csLeft, csRight, csAfter);
- TPtrIntList = specialize TFPGList<PtrInt>;
- TGuessEncodingEvent = function(const s: string): string;
- TFileOpenEvent = function(const FileName: String; Mode: LongWord): System.THandle;
- TCustomCharsPresentation = class;
- TCharToCustomValueTransformProc = function(AChar:AnsiChar;AMaxDigitsCount:integer):AnsiString of object;
- { TCustomCharsPresentation }
- {
- Presentation one char is called Value
- Function for convert char to Value is ChrToValueProc
- }
- TCustomCharsPresentation = class
- public
- ValuesPerLine :integer; // = 16 for Hex by default
- MaxValueDigits :integer; // the max width of present char (255) - 3 symbols
- MaxAddrDigits :integer; // = 8;
- StartOfs :integer; // = OffsetWidth + 2; // ': '
- EndOfs :integer; // = StartOfs + (ValuesPerLine * (ValueMaxDigits+SpaceCount));
- StartAscii :integer; // = StartOfs + (ValuesPerLine * (ValueMaxDigits+SpaceCount)) + 2; // ' '
- SpaceCount :integer; // = 1 - one spacebar between Values
- SeparatorSpace :AnsiString; // spacebar * SpaceCount
- SeparatorChar :AnsiChar; // '|'
- CountSeperate :integer; // insert SeparatorChar after every CountSeperate values
- ChrToValueProc :TCharToCustomValueTransformProc; // procedure which return presentation of one char
- constructor Create(APresentValuesPerLine,ACharMaxPresentWidth,AOffsetWidth,ACountSeparate:integer;AChrToValueProc:TCharToCustomValueTransformProc);
- destructor Destroy();override;
- end;
- type
- // If additional encodings are added they should be also supported by:
- // - GetNextCharAsAscii
- // - GetPrevCharAsAscii
- // - GetNextCharAsUtf8
- // - ConvertToUTF8
- // - UpdateSelection
- TViewerEncoding = (veAutoDetect,
- veUtf8,
- veUtf8bom,
- veAnsi,
- veOem,
- veCp1250,
- veCp1251,
- veCp1252,
- veCp1253,
- veCp1254,
- veCp1255,
- veCp1256,
- veCp1257,
- veCp1258,
- veCp437,
- veCp850,
- veCp852,
- veCp866,
- veCp874,
- veCp932,
- veCp936,
- veCp949,
- veCp950,
- veIso88591,
- veIso88592,
- veKoi8r,
- veKoi8u,
- veKoi8ru,
- 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',
- 'OEM',
- 'CP1250',
- 'CP1251',
- 'CP1252',
- 'CP1253',
- 'CP1254',
- 'CP1255',
- 'CP1256',
- 'CP1257',
- 'CP1258',
- 'CP437',
- 'CP850',
- 'CP852',
- 'CP866',
- 'CP874',
- 'CP932',
- 'CP936',
- 'CP949',
- 'CP950',
- 'ISO-8859-1',
- 'ISO-8859-2',
- 'KOI8-R',
- 'KOI8-U',
- 'KOI8-RU',
- 'UCS-2LE',
- 'UCS-2BE',
- 'UTF-16LE',
- 'UTF-16BE',
- 'UTF-32LE',
- 'UTF-32BE');
- const
- ViewerEncodingOem: TViewerEncodings = [
- veCp437, veCp850, veCp852, veCp866];
- ViewerEncodingMultiByte: TViewerEncodings = [
- veCp932, veCp936, veCp949, veCp950,
- veUtf8, veUtf8bom, veUcs2le, veUcs2be,
- veUtf16le, veUtf16be, veUtf32le, veUtf32be];
- ViewerEncodingDoubleByte: TViewerEncodings = [
- veUcs2le, veUcs2be, veUtf16le, veUtf16be ];
- type
- { TViewerControl }
- TViewerControl = class(TCustomControl)
- protected
- FEncoding: TViewerEncoding;
- FViewerControlMode: TViewerControlMode;
- FFileName: String;
- 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;
- FCaretPos: PtrInt;
- FCaretPoint: TPoint;
- 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;
- FTabSpaces: Integer; // tab width in spaces
- FMaxTextWidth: Integer; // maximum of chars on one line unwrapped text (max 16384)
- FExtraLineSpacing: Integer;
- FLeftMargin: Integer;
- FOnGuessEncoding: TGuessEncodingEvent;
- FOnFileOpen: TFileOpenEvent;
- FCaretVisible: Boolean;
- FShowCaret: Boolean;
- FAutoCopy: Boolean;
- FLastError: String;
- FText: String;
- FHex:TCustomCharsPresentation;
- FDec:TCustomCharsPresentation;
- FCustom:TCustomCharsPresentation;
- 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: TViewerControlMode);
- procedure SetColCount(const AValue: Integer);
- procedure SetMaxTextWidth(const AValue: Integer);
- procedure SetTabSpaces(const AValue: Integer);
- procedure SetShowCaret(AValue: Boolean);
- procedure SetCaretPos(AValue: PtrInt);
- {en
- Returns how many lines (given current FTextHeight) will fit into the window.
- }
- function GetClientHeightInLines(Whole: Boolean = True): 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; const sText: String; StartPos: PtrInt; DataLength: Integer);
- procedure OutBin(x, y: Integer; const sText: String; StartPos: PtrInt; DataLength: Integer);
- procedure OutCustom(x, y: Integer; const sText: String;StartPos: PtrInt; DataLength: Integer); // render one line
- function TransformCustom(var APosition: PtrInt; ALimit: PtrInt; AWithAdditionalData: Boolean = True): String;
- function TransformCustomBlock(var APosition: PtrInt; DataLength: Integer; ASeparatorsOn, AAlignData: Boolean; out AChars: String): String;
- function HexToValueProc(AChar:AnsiChar;AMaxDigitsCount:integer):AnsiString;
- function DecToValueProc(AChar:AnsiChar;AMaxDigitsCount:integer):AnsiString;
- procedure WriteBin;
- procedure WriteText;
- procedure WriteCustom; virtual;
- function TransformText(const sText: String; const Xoffset: Integer): String;
- function TransformBin(var aPosition: PtrInt; aLimit: PtrInt): String;
- function TransformHex(var aPosition: PtrInt; aLimit: PtrInt): AnsiString;virtual;
- procedure AddLineOffset(const iOffset: PtrInt); inline;
- procedure DrawLastError;
- function MapFile(const sFileName: String): Boolean;
- procedure UnMapFile;
- procedure SetFileName(const sFileName: String);
- 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): String;
- procedure ReReadFile;
- {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;
- function GetViewerRect: TRect;
- 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;
- procedure SetText(const AValue: String);
- protected
- procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS;
- procedure WMKillFocus(var Message: TLMKillFocus); message LM_KILLFOCUS;
- procedure FontChanged(Sender: TObject); override;
- 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;
- function DoMouseWheelLeft(Shift: TShiftState; MousePos: TPoint): Boolean; override;
- function DoMouseWheelRight(Shift: TShiftState; MousePos: TPoint): Boolean; override;
- procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double); 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;
- procedure CaretGoHome;
- procedure CaretGoEnd;
- function GetDataAdr: Pointer;
- procedure SelectAll;
- procedure SelectText(AStart, AEnd: PtrInt);
- procedure CopyToClipboard;
- procedure CopyToClipboardF;
- function Selection: String;
- function IsVisible(const aPosition: PtrInt): Boolean; overload;
- procedure MakeVisible(const aPosition: PtrInt);
- function ConvertToUTF8(const sText: AnsiString): String;
- function ConvertFromUTF8(const sText: String): AnsiString;
- function FindUtf8Text(iStartPos: PtrInt; const sSearchText: String;
- bCaseSensitive: Boolean; bSearchBackwards: Boolean): PtrInt;
- procedure ResetEncoding;
- function IsFileOpen: Boolean; inline;
- function DetectEncoding: TViewerEncoding;
- procedure GetSupportedEncodings(List: TStrings);
- property Text: String read FText write SetText;
- property Percent: Integer Read GetPercent Write SetPercent;
- property Position: PtrInt Read FPosition Write SetPosition;
- property FileSize: Int64 Read FFileSize;
- property FileHandle: THandle read FFileHandle;
- property CaretPos: PtrInt Read FCaretPos Write SetCaretPos;
- 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 MaxTextWidth: Integer read FMaxTextWidth write SetMaxTextWidth;
- property TabSpaces: Integer read FTabSpaces write SetTabSpaces;
- property LeftMargin: Integer read FLeftMargin write FLeftMargin;
- property ExtraLineSpacing: Integer read FExtraLineSpacing write FExtraLineSpacing;
- property AutoCopy: Boolean read FAutoCopy write FAutoCopy;
- property OnGuessEncoding: TGuessEncodingEvent Read FOnGuessEncoding Write FOnGuessEncoding;
- property OnFileOpen: TFileOpenEvent read FOnFileOpen write FOnFileOpen;
- published
- property Mode: TViewerControlMode Read FViewerControlMode Write SetViewerMode default vcmWrap;
- property FileName: String Read FFileName Write SetFileName;
- property Encoding: TViewerEncoding Read FEncoding Write SetEncoding default veAutoDetect;
- property OnPositionChanged: TNotifyEvent Read FOnPositionChanged Write FOnPositionChanged;
- property ShowCaret: Boolean read FShowCaret write SetShowCaret;
- property OnClick;
- property OnMouseDown;
- property OnMouseMove;
- property OnMouseUp;
- property OnMouseWheelUp;
- property OnMouseWheelDown;
- property Align;
- property Color;
- property Cursor default crIBeam;
- property Font;
- property ParentColor default False;
- property TabStop default True;
- end;
- procedure Register;
- implementation
- uses
- Math, LCLType, Graphics, Forms, LCLProc, Clipbrd, LConvEncoding,
- DCUnicodeUtils, LCLIntf, LazUTF8, DCOSUtils , DCConvertEncoding
- {$IF LCL_FULLVERSION >= 4990000}
- , LazUTF16
- {$ENDIF}
- {$IF DEFINED(UNIX)}
- , BaseUnix, Unix, DCUnix
- {$ELSEIF DEFINED(WINDOWS)}
- , Windows, DCWindows
- {$ENDIF};
- const
- cBinWidth = 80;
- // These strings must be Ascii only.
- sNonCharacter: string = ' !"#$%&''()*+,-./:;<=>?@[\]^`{|}~'#13#10#9;
- sWhiteSpace : string = ' '#13#10#9#8;
- const
- ASCII_TABLE: array[0..31] of String =
- (
- '.', '☺', '☻', '♥', '♦', '♣', '♠', '•', '◘', '○', '◙', '♂', '♀', '♪', '♫', '☼',
- '►', '◄', '↕', '‼', '¶', '§', '▬', '↨', '↑', '↓', '→', '←', '∟', '↔', '▲', '▼'
- );
- { TCustomCharsPresentation }
- constructor TCustomCharsPresentation.Create(APresentValuesPerLine,
- ACharMaxPresentWidth, AOffsetWidth, ACountSeparate: integer;AChrToValueProc:TCharToCustomValueTransformProc);
- begin
- SpaceCount:=1; // count of spacebars between values, =1
- ValuesPerLine := APresentValuesPerLine; // default for hex: 16 values
- MaxAddrDigits := AOffsetWidth; // = 8 , count of symbols for display caret offset
- StartOfs := AOffsetWidth + 2; // ': '
- MaxValueDigits := ACharMaxPresentWidth; // hex char (FF) - 2 symbols, dec char (255) - 3 symbols
- EndOfs := StartOfs + (ValuesPerLine * (MaxValueDigits+SpaceCount)); // +1 - take in spacebar
- StartAscii := StartOfs + (ValuesPerLine * (MaxValueDigits+SpaceCount)) + 2; // ' '
- SeparatorChar:='|';
- CountSeperate:=ACountSeparate;
- SeparatorSpace:=' ';
- ChrToValueProc:=AChrToValueProc; // method for convert char to Value
- end;
- destructor TCustomCharsPresentation.Destroy;
- begin
- inherited;
- end;
- // ----------------------------------------------------------------------------
- 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;
- FViewerControlMode := vcmText;
- FCustom := nil;
- 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;
- FTabSpaces := 8;
- FLeftMargin := 4;
- FMaxTextWidth := 1024;
- FAutoCopy := True;
- 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;
- FHex:=TCustomCharsPresentation.Create(16,2,8,8,@HexToValueProc);
- FDec:=TCustomCharsPresentation.Create(15,3,8,5,@DecToValueProc); // for set bigger ValuePerLine need to improve method GetEndOfLine
- end;
- destructor TViewerControl.Destroy;
- begin
- FHex.Free;
- FDec.Free;
- FHex:=nil;
- FDec:=nil;
- FCustom:=nil;
- UnMapFile;
- if Assigned(FLineList) then
- FreeAndNil(FLineList);
- inherited Destroy;
- end;
- procedure TViewerControl.DrawLastError;
- var
- AStyle: TTextStyle;
- begin
- AStyle:= Canvas.TextStyle;
- AStyle.Alignment:= taCenter;
- AStyle.Layout:= tlCenter;
- Canvas.Pen.Color := Canvas.Font.Color;
- Canvas.Line(0, 0, ClientWidth - 1, ClientHeight - 1);
- Canvas.Line(0, ClientHeight - 1, ClientWidth - 1, 0);
- Canvas.TextRect(GetViewerRect, 0, 0, FLastError, AStyle);
- end;
- procedure TViewerControl.Paint;
- var
- AText: String;
- begin
- if not IsFileOpen then
- begin
- DrawLastError;
- Exit;
- end;
- if FShowCaret and FCaretVisible then
- begin
- FCaretPoint.X := -1;
- FCaretVisible := not LCLIntf.HideCaret(Handle);
- end;
- 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') + FExtraLineSpacing;
- if FViewerControlMode = vcmBook then
- FTextWidth := ((ClientWidth - (Canvas.TextWidth('W') * FColCount)) div FColCount)
- else begin
- AText := StringOfChar('W', FMaxTextWidth);
- FTextWidth := Canvas.TextFitInfo(AText, GetViewerRect.Width - FLeftMargin);
- end;
- FLineList.Clear;
- case FViewerControlMode of
- vcmBin : WriteBin;
- vcmText: WriteText;
- vcmWrap: WriteText;
- vcmBook: WriteText;
- vcmDec,vcmHex : WriteCustom;
- end;
- if FShowCaret and (FCaretPoint.X > -1) then
- begin
- LCLIntf.SetCaretPos(FCaretPoint.X, FCaretPoint.Y);
- if not FCaretVisible then FCaretVisible:= LCLIntf.ShowCaret(Handle);
- end;
- end;
- procedure TViewerControl.SetViewerMode(Value: TViewerControlMode);
- begin
- if not (csDesigning in ComponentState) then
- begin
- FLineList.Clear; // do not use cache from previous mode
- FViewerControlMode := Value;
- case FViewerControlMode of
- vcmHex: FCustom := FHex;
- vcmDec: FCustom := FDec;
- else
- FCustom := nil;
- end;
- if not IsFileOpen then
- Exit;
- // Take limits into account for selection.
- FBlockBeg := FBlockBeg + (GetDataAdr - FMappedFile);
- FBlockEnd := FBlockEnd + (GetDataAdr - FMappedFile);
- 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
- FViewerControlMode := Value;
- end;
- procedure TViewerControl.SetColCount(const AValue: Integer);
- begin
- if AValue > 0 then FColCount := AValue
- else FColCount := 1;
- end;
- procedure TViewerControl.SetMaxTextWidth(const AValue: Integer);
- begin
- if AValue < 80 then
- FMaxTextWidth := 80
- else if AValue > 16384 then
- FMaxTextWidth := 16384
- else
- FMaxTextWidth:= AValue;
- end;
- procedure TViewerControl.SetTabSpaces(const AValue: Integer);
- begin
- if AValue < 1 then
- FTabSpaces := 1
- else if AValue > 32 then
- FTabSpaces := 32
- else
- FTabSpaces := AValue;
- 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
- if not IsFileOpen then
- Exit(False);
- aPosition := FPosition;
- Result := ScrollPosition(aPosition, iLines);
- if aPosition <> FPosition then
- SetPosition(aPosition);
- end;
- function TViewerControl.HScroll(iSymbols: Integer): Boolean;
- var
- newPos: Integer;
- begin
- if not IsFileOpen then
- Exit(False);
- newPos := FHPosition + iSymbols;
- if newPos < 0 then
- newPos := 0
- else if (newPos > FHLowEnd - FTextWidth) and (FHLowEnd - FTextWidth > 0) then
- newPos := FHLowEnd - FTextWidth;
- if newPos <> FHPosition then
- SetHPosition(newPos);
- Result:= True;
- end;
- function TViewerControl.GetText(const StartPos, Len: PtrInt; const Xoffset: Integer): string;
- begin
- SetString(Result, GetDataAdr + StartPos, Len);
- Result := TransformText(ConvertToUTF8(Result), Xoffset);
- end;
- procedure TViewerControl.SetText(const AValue: String);
- begin
- UnMapFile;
- FText:= AValue;
- FileName:= EmptyStr;
- FFileSize:= Length(FText);
- FMappedFile:= Pointer(FText);
- end;
- function TViewerControl.GetViewerRect: TRect;
- begin
- Result:= GetClientRect;
- if Assigned(FScrollBarHorz) and FScrollBarHorz.Visible then
- Dec(Result.Bottom, FScrollBarHorz.Height);
- if Assigned(FScrollBarVert) and FScrollBarVert.Visible then
- Dec(Result.Right, FScrollBarVert.Width);
- end;
- procedure TViewerControl.WMSetFocus(var Message: TLMSetFocus);
- begin
- if FShowCaret then
- begin
- LCLIntf.CreateCaret(Handle, 0, 2, FTextHeight);
- LCLIntf.ShowCaret(Handle);
- FCaretVisible:= True;
- end;
- end;
- procedure TViewerControl.WMKillFocus(var Message: TLMKillFocus);
- begin
- if FShowCaret then
- begin
- FCaretVisible:= False;
- LCLIntf.DestroyCaret(Handle);
- end;
- end;
- procedure TViewerControl.FontChanged(Sender: TObject);
- begin
- inherited FontChanged(Sender);
- if HandleAllocated then
- begin
- FTextHeight := Canvas.TextHeight('Wg') + FExtraLineSpacing;
- if FShowCaret then LCLIntf.CreateCaret(Handle, 0, 2, FTextHeight);
- end;
- 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, FTabSpaces - Result mod FTabSpaces);
- 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 FViewerControlMode of
- vcmText: MaxLineLength := Result < FMaxTextWidth;
- vcmWrap: MaxLineLength := Result < FTextWidth;
- vcmBook: 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: String; const Xoffset: Integer): String;
- var
- c: AnsiChar;
- i: Integer;
- Dos: Boolean;
- begin
- Result := '';
- Dos:= FEncoding in ViewerEncodingOem;
- for i := 1 to Length(sText) do
- begin
- c := sText[i];
- // Parse only ASCII chars.
- case c of
- #9:
- Result := Result + StringOfChar(' ',
- FTabSpaces - (UTF8Length(Result) + Xoffset) mod FTabSpaces);
- else
- begin
- if c < ' ' then
- begin
- if Dos then
- Result := Result + ASCII_TABLE[Ord(c)]
- else
- Result := Result + ' ';
- end
- else
- Result := Result + c;
- end;
- end;
- end;
- end;
- function TViewerControl.TransformBin(var aPosition: PtrInt; aLimit: PtrInt): String;
- var
- S: String;
- C: AnsiChar;
- P: PAnsiChar;
- Len: Integer;
- I, L: Integer;
- SingleByte: Boolean;
- begin
- Result := EmptyStr;
- if (APosition + cBinWidth) > aLimit then
- Len:= aLimit - APosition
- else begin
- Len:= cBinWidth;
- end;
- SetString(S, PAnsiChar(GetDataAdr) + aPosition, Len);
- SingleByte:= not (FEncoding in ViewerEncodingMultiByte);
- if SingleByte then
- begin
- S:= ConvertToUTF8(S);
- end;
- L:= Length(S);
- P:= PAnsiChar(S);
- for I := 1 to L do
- begin
- C := P^;
- if C < ' ' then
- Result := Result + '.'
- else if SingleByte then
- Result := Result + C
- else if C > #127 then
- Result := Result + '.'
- else begin
- Result := Result + C;
- end;
- Inc(P);
- end;
- Inc(aPosition, Len);
- end;
- function TViewerControl.TransformHex(var aPosition: PtrInt; aLimit: PtrInt): AnsiString;
- begin
- Result:=TransformCustom(aPosition,aLimit);
- end;
- function TViewerControl.TransformCustom(var APosition: PtrInt; ALimit: PtrInt;
- AWithAdditionalData: boolean): String;
- var
- sAscii: string = '';
- sRez : string = '';
- tPos : integer;
- begin
- tPos:=APosition;
- sRez:=TransformCustomBlock(APosition,FCustom.ValuesPerLine,True,True,sAscii);
- // Result := LineFormat(sRez, sStr, aStartOffset) else
- if AWithAdditionalData then
- begin
- sRez := Format('%s: %s', [IntToHex(tPos, FCustom.MaxAddrDigits), sRez]);
- if Length(sRez) < FCustom.ValuesPerLine * (FCustom.SpaceCount+FCustom.MaxValueDigits) then
- sRez := sRez + StringOfChar(' ', FCustom.ValuesPerLine * (FCustom.SpaceCount+FCustom.MaxValueDigits) - Length(sRez));
- sRez := sRez + ' ';
- sRez := sRez + sAscii;
- end;
- Result:=sRez;
- end;
- function TViewerControl.TransformCustomBlock(var APosition: PtrInt;
- DataLength: Integer; ASeparatorsOn, AAlignData: Boolean; out AChars: String): String;
- var
- S: String;
- C: AnsiChar;
- P: PAnsiChar;
- Len: Integer;
- I, L: Integer;
- sEmpty: String;
- iSep: Integer = 1;
- SingleByte: Boolean;
- begin
- Result:= EmptyStr;
- if (APosition + DataLength) > FHighLimit then
- Len:= FHighLimit - APosition
- else begin
- Len:= DataLength;
- end;
- SetString(S, PAnsiChar(GetDataAdr) + aPosition, Len);
- SingleByte:= not (FEncoding in ViewerEncodingMultiByte);
- if SingleByte then
- begin
- S:= ConvertToUTF8(S);
- end;
- L:= Length(S);
- P:= PAnsiChar(S);
- AChars:= EmptyStr;
- for I := 1 to L do
- begin
- C := P^;
- if C < ' ' then
- AChars := AChars + '.'
- else if SingleByte then
- AChars := AChars + C
- else if C > #127 then
- AChars := AChars + '.'
- else begin
- AChars := AChars + C;
- end;
- Inc(P);
- end;
- P:= PAnsiChar(GetDataAdr);
- for I := 0 to Len - 1 do
- begin
- C := P[aPosition];
- Result += FCustom.ChrToValueProc(C, FCustom.MaxValueDigits);
- if (iSep = FCustom.CountSeperate) and ASeparatorsOn and
- (I < (FCustom.ValuesPerLine - 1))then
- begin
- iSep := 0;
- Result += FCustom.SeparatorChar;
- end else
- begin
- Result += FCustom.SeparatorSpace;
- end;
- Inc(aPosition);
- Inc(iSep);
- end;
- if AAlignData then
- begin
- sEmpty := StringOfChar(#32, FCustom.MaxValueDigits);
- while (I < FCustom.ValuesPerLine - 1) do
- begin
- Result += sEmpty + FCustom.SeparatorSpace;
- Inc(I);
- end;
- end;
- end;
- function TViewerControl.DecToValueProc(AChar:AnsiChar;AMaxDigitsCount:integer):AnsiString;
- begin
- Result:= IntToStr(Ord(AChar));
- while Length(Result) < AMaxDigitsCount do
- Result:= '0' + Result;
- end;
- function TViewerControl.HexToValueProc(AChar:AnsiChar;AMaxDigitsCount:integer):AnsiString;
- begin
- Result:=IntToHex(Ord(AChar), AMaxDigitsCount);
- while length(Result)<AMaxDigitsCount do
- Result:=' '+Result;
- end;
- function TViewerControl.GetStartOfLine(aPosition: PtrInt): PtrInt;
- function GetStartOfLineText: PtrInt;
- var
- tmpPos, LineStartPos: PtrInt;
- DataLength: PtrInt;
- prevChar: Cardinal;
- MaxLineLength: Boolean;
- 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);
- DataLength:= 0;
- // 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);
- case prevChar of
- 9:
- Inc(DataLength, FTabSpaces - DataLength mod FTabSpaces);
- else
- Inc(DataLength, 1);
- end;
- case FViewerControlMode of
- vcmText: MaxLineLength := DataLength < FMaxTextWidth;
- vcmWrap: MaxLineLength := DataLength < FTextWidth;
- end;
- if not MaxLineLength then Exit(tmpPos);
- end;
- // Previous end of line not found and there are no more data to check.
- if (not (prevChar in [10, 13])) and (tmpPos <= FLowLimit) then
- Exit(FLowLimit);
- // 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 FViewerControlMode of
- vcmBin:
- Result := GetStartOfLineFixed(cBinWidth);
- vcmHex, vcmDec:
- Result := GetStartOfLineFixed(FCustom.ValuesPerLine);
- vcmText, vcmWrap, vcmBook:
- 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 FViewerControlMode of
- vcmBin:
- Result := GetEndOfLineFixed(cBinWidth);
- vcmHex,vcmDec:
- Result := GetEndOfLineFixed(FCustom.ValuesPerLine);
- vcmText, vcmWrap, vcmBook:
- Result := GetEndOfLineText;
- else
- Result := aPosition;
- end;
- end;
- function TViewerControl.GetStartOfPrevLine(aPosition: PtrInt): PtrInt;
- function GetPrevLineText: PtrInt;
- var
- tmpPos, LineStartPos: PtrInt;
- DataLength: PtrInt;
- prevChar: Cardinal;
- MaxLineLength: Boolean;
- 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);
- DataLength:= 0;
- // 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);
- case prevChar of
- 9:
- Inc(DataLength, FTabSpaces - DataLength mod FTabSpaces);
- else
- Inc(DataLength, 1);
- end;
- case FViewerControlMode of
- vcmText: MaxLineLength := DataLength < FMaxTextWidth;
- vcmWrap: MaxLineLength := DataLength < FTextWidth;
- end;
- if not MaxLineLength then Exit(tmpPos);
- 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 FViewerControlMode of
- vcmBin:
- Result := GetPrevLineFixed(cBinWidth);
- vcmHex,vcmDec:
- Result := GetPrevLineFixed(FCustom.ValuesPerLine);
- vcmText, vcmWrap, vcmBook:
- 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 FViewerControlMode of
- vcmBin:
- Result := GetNextLineFixed(cBinWidth);
- vcmHex,vcmDec:
- Result := GetNextLineFixed(FCustom.ValuesPerLine);
- vcmText, vcmWrap, vcmBook:
- 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.CaretGoHome;
- begin
- HScroll (-FHPosition);
- CaretPos := GetStartOfLine(CaretPos);
- end;
- procedure TViewerControl.CaretGoEnd;
- begin
- if FViewerControlMode in [vcmBin, vcmHex, vcmDec] then
- CaretPos := GetEndOfLine(CaretPos) - 1
- else begin
- CaretPos := GetEndOfLine(CaretPos);
- end;
- if FViewerControlMode = vcmText then
- begin
- if not IsVisible(CaretPos) then
- begin
- if (FVisibleOffset < FHPosition) or
- (FVisibleOffset > FHPosition + FTextWidth) then
- begin
- SetHPosition(FVisibleOffset);
- HScroll(-1);
- end;
- end;
- end;
- end;
- procedure TViewerControl.SetFileName(const sFileName: String);
- 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;
- CaretPos := FLowLimit;
- end;
- end;
- end
- else
- FFileName := sFileName;
- end;
- function TViewerControl.MapFile(const sFileName: String): Boolean;
- function ReadFile: Boolean; inline;
- begin
- FMappedFile := GetMem(FFileSize);
- Result := (FileRead(FFileHandle, FMappedFile^, FFileSize) = FFileSize);
- if not Result then
- begin
- FLastError := mbSysErrorMessage;
- FreeMemAndNil(FMappedFile);
- end;
- FileClose(FFileHandle);
- FFileHandle := 0;
- end;
- {$IFDEF LINUX}
- var
- Sbfs: TStatFS;
- {$ENDIF}
- begin
- Result := False;
- FLastError := EmptyStr;
- if Assigned(FMappedFile) then
- UnMapFile; // if needed
- if Assigned(FOnFileOpen) then
- FFileHandle := FOnFileOpen(sFileName, fmOpenRead or fmShareDenyNone)
- else begin
- FFileHandle := mbFileOpen(sFileName, fmOpenRead or fmShareDenyNone);
- end;
- if FFileHandle = feInvalidHandle then
- begin
- FLastError := mbSysErrorMessage;
- FFileHandle := 0;
- Exit;
- end;
- FFileSize := FileGetSize(FFileHandle);
- if (FFileSize < 0) then
- begin
- FLastError := mbSysErrorMessage;
- FileClose(FFileHandle);
- FFileHandle := 0;
- Exit;
- end;
- {$IFDEF LINUX}
- if (fpFStatFS(FFileHandle, @Sbfs) = 0) then
- begin
- // Special case for PROC_FS and SYS_FS
- if (sbfs.fstype = PROC_SUPER_MAGIC) or (sbfs.fstype = SYSFS_MAGIC) then
- begin
- FMappedFile := GetMem(MaxMemSize - 1);
- FFileSize := FileRead(FFileHandle, FMappedFile^, MaxMemSize - 1);
- Result := (FFileSize >= 0);
- if not Result then
- begin
- FLastError := mbSysErrorMessage;
- FreeMemAndNil(FMappedFile);
- end;
- FileClose(FFileHandle);
- FFileHandle := 0;
- Exit;
- end;
- end;
- {$ENDIF}
- if (FFileSize < MaxMemSize) then
- begin
- Result := ReadFile;
- Exit;
- end;
- {$IFDEF MSWINDOWS}
- FMappingHandle := CreateFileMapping(FFileHandle, nil, PAGE_READONLY, 0, 0, nil);
- if FMappingHandle = 0 then
- begin
- FLastError := mbSysErrorMessage;
- FMappedFile := nil;
- UnMapFile;
- end
- else begin
- FMappedFile := MapViewOfFile(FMappingHandle, FILE_MAP_READ, 0, 0, 0);
- if (FMappedFile = nil) then
- begin
- FLastError := mbSysErrorMessage;
- UnMapFile;
- end;
- end;
- {$ELSE}
- FMappedFile := fpmmap(nil, FFileSize, PROT_READ, MAP_PRIVATE{SHARED}, FFileHandle, 0);
- if FMappedFile = MAP_FAILED then
- begin
- FLastError := mbSysErrorMessage;
- FMappedFile:= nil;
- FileClose(FFileHandle);
- FFileHandle := 0;
- Exit;
- end;
- {$ENDIF}
- Result := Assigned(FMappedFile);
- end;
- procedure TViewerControl.UnMapFile;
- begin
- if FMappedFile = Pointer(FText) then
- begin
- FMappedFile:= nil;
- FText:= EmptyStr;
- end;
- 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;
- {$ELSE}
- if Assigned(FMappedFile) then
- begin
- if fpmunmap(FMappedFile, FFileSize) = -1 then
- DebugLn('Error unmapping file: ', SysErrorMessage(fpgeterrno));
- FMappedFile := nil;
- end;
- {$ENDIF}
- if FFileHandle <> 0 then
- begin
- FileClose(FFileHandle);
- FFileHandle := 0;
- end;
- FFileName := '';
- FFileSize := 0;
- Position := 0;
- FLowLimit := 0;
- FHighLimit := 0;
- FBOMLength := 0;
- FBlockBeg := 0;
- FBlockEnd := 0;
- end;
- procedure TViewerControl.WriteText;
- var
- yIndex, xIndex, w, i: Integer;
- LineStart, iPos: PtrInt;
- CharLenInBytes: Integer;
- DataLength: PtrInt;
- sText: String;
- procedure DrawCaret(X, Y: Integer; LinePos: PtrInt);
- begin
- if FShowCaret and (FCaretPos = LinePos) then
- begin
- FCaretPoint.X:= X;
- FCaretPoint.Y:= Y;
- end;
- end;
- begin
- iPos := FPosition;
- if Mode = vcmBook then
- w := Width div FColCount
- else begin
- w := 0;
- end;
- for xIndex := 0 to FColCount-1 do
- begin
- for yIndex := 0 to GetClientHeightInLines(False) - 1 do
- begin
- if iPos > FHighLimit then
- Break;
- if iPos = FHighLimit then
- begin
- if GetPrevCharAsAscii(iPos, CharLenInBytes) = 10 then
- begin
- DrawCaret(0, yIndex * FTextHeight, iPos);
- end;
- Break;
- end;
- AddLineOffset(iPos);
- LineStart := iPos;
- i := CalcTextLineLength(iPos, FHighLimit, DataLength);
- if i > FHLowEnd then FHLowEnd:= i;
- if DataLength = 0 then
- DrawCaret(0, yIndex * FTextHeight, LineStart)
- else begin
- if (Mode = vcmText) and (FHPosition > 0) then
- begin
- for i:= 1 to FHPosition do
- begin
- GetNextCharAsAscii(LineStart, CharLenInBytes);
- DataLength -= CharLenInBytes;
- LineStart += CharLenInBytes;
- end;
- if (DataLength <= 0) then Continue;
- end;
- sText := GetText(LineStart, DataLength, 0);
- OutText(FLeftMargin + xIndex * w, yIndex * FTextHeight, sText, LineStart, DataLength);
- end;
- end;
- end;
- end;
- procedure TViewerControl.WriteCustom;
- // this method render visible page of text
- var
- yIndex: Integer;
- iPos, LineStart: PtrInt;
- s: string;
- begin
- iPos := FPosition;
- for yIndex := 0 to GetClientHeightInLines(False) - 1 do
- begin
- if iPos >= FHighLimit then
- Break;
- LineStart := iPos;
- AddLineOffset(iPos);
- s := TransformCustom(iPos, FHighLimit); // get line text for render
- if s <> '' then
- OutCustom(FLeftMargin, yIndex * FTextHeight, s, LineStart, iPos - LineStart); // render line to canvas
- end;
- end;
- procedure TViewerControl.WriteBin;
- var
- yIndex: Integer;
- iPos, LineStart: PtrInt;
- s: string;
- begin
- iPos := FPosition;
- for yIndex := 0 to GetClientHeightInLines(False) - 1 do
- begin
- if iPos >= FHighLimit then
- Break;
- LineStart := iPos;
- AddLineOffset(iPos);
- s := TransformBin(iPos, FHighLimit);
- if s <> '' then
- OutBin(FLeftMargin, yIndex * FTextHeight, s, LineStart, iPos - LineStart);
- end;
- end;
- function TViewerControl.GetDataAdr: Pointer;
- begin
- case FViewerControlMode of
- vcmText, vcmWrap, vcmBook:
- 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 (FHPosition > 0) and (FHLowEnd - FTextWidth > 0) then
- FHScrollBarPosition := FHPosition * 100 div (FHLowEnd - FTextWidth)
- else
- FHScrollBarPosition := 0;
- // 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;
- // Double byte text can have only even position
- if (Encoding in ViewerEncodingDoubleByte) and Odd(Value) then
- begin
- Value := Value - 1;
- end;
- // 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
- begin
- // scroll back upwards
- ScrollPosition(Value, -LinesTooMany);
- end;
- FPosition := Value;
- if Assigned(FOnPositionChanged) then
- FOnPositionChanged(Self);
- Invalidate;
- // Set new scroll position.
- if LastLineReached and (Value > 0) 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(Whole: Boolean): Integer;
- begin
- if FTextHeight > 0 then
- begin
- if Whole then
- Result := GetViewerRect.Height div FTextHeight
- else
- Result := Ceil(GetViewerRect.Height / FTextHeight);
- end
- else
- Result := 0;
- end;
- function TViewerControl.GetLinesTillEnd(FromPosition: PtrInt;
- out LastLineReached: Boolean): Integer;
- var
- iPos: PtrInt;
- yIndex: Integer;
- DataLength: PtrInt;
- CharLenInBytes: Integer;
- begin
- Result := 0;
- iPos := FromPosition;
- for yIndex := 0 to GetClientHeightInLines - 1 do
- begin
- if iPos >= FHighLimit then
- Break;
- Inc(Result, 1);
- case Mode of
- vcmBin:
- iPos := iPos + cBinWidth;
- vcmHex,vcmDec:
- iPos := iPos + FCustom.ValuesPerLine;
- vcmText, vcmWrap, vcmBook:
- CalcTextLineLength(iPos, FHighLimit, DataLength);
- end;
- end;
- LastLineReached := (iPos >= FHighLimit);
- if LastLineReached and (FViewerControlMode in [vcmText, vcmWrap, vcmBook]) then
- begin
- if (GetPrevCharAsAscii(FHighLimit, CharLenInBytes) = 10) then
- Inc(Result);
- end;
- end;
- procedure TViewerControl.SetShowCaret(AValue: Boolean);
- begin
- if FShowCaret <> AValue then
- begin
- FShowCaret:= AValue;
- if HandleAllocated then
- begin
- if FShowCaret then
- begin
- LCLIntf.CreateCaret(Handle, 0, 2, FTextHeight);
- LCLIntf.ShowCaret(Handle);
- FCaretVisible:= True;
- Invalidate;
- end
- else begin
- FCaretVisible:= False;
- LCLIntf.HideCaret(Handle);
- LCLIntf.DestroyCaret(Handle);
- end;
- end;
- end;
- end;
- procedure TViewerControl.SetCaretPos(AValue: PtrInt);
- begin
- if FCaretPos <> AValue then
- begin
- FCaretPos := AValue;
- if FShowCaret then Invalidate;
- end;
- 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; const sText: String;
- StartPos: PtrInt; DataLength: Integer);
- var
- pBegLine, pEndLine: PtrInt;
- iBegDrawIndex, iEndDrawIndex: PtrInt;
- begin
- pBegLine := StartPos;
- pEndLine := pBegLine + DataLength;
- Canvas.Font.Color := Font.Color;
- if FShowCaret and (FCaretPos >= pBegLine) and (FCaretPos <= pEndLine) then
- begin
- FCaretPoint.Y:= Y;
- FCaretPoint.X:= X + Canvas.TextWidth(GetText(StartPos, FCaretPos - pBegLine, 0));
- end;
- // Out of selection, draw normal
- if ((FBlockEnd - FBlockBeg) = 0) or ((FBlockBeg < pBegLine) and (FBlockEnd < pBegLine)) or // before
- ((FBlockBeg > pEndLine) and (FBlockEnd > pEndLine)) then // after
- begin
- Canvas.TextOut(x, y, sText);
- Exit;
- end;
- // Get selection start
- if (FBlockBeg <= pBegLine) then
- iBegDrawIndex := pBegLine
- else
- iBegDrawIndex := FBlockBeg;
- // Get selection end
- if (FBlockEnd < pEndLine) then
- iEndDrawIndex := FBlockEnd
- else
- iEndDrawIndex := pEndLine;
- // Text after selection.
- if pEndLine - iEndDrawIndex > 0 then
- Canvas.TextOut(x, y, sText);
- // Text before selection + selected text
- Canvas.Brush.Color := clHighlight;
- Canvas.Font.Color := clHighlightText;
- Canvas.TextOut(X, Y, GetText(StartPos, iEndDrawIndex - pBegLine, 0));
- // Restore previous canvas settings
- Canvas.Brush.Color := Color;
- Canvas.Font.Color := Font.Color;
- // Text before selection
- if iBegDrawIndex - pBegLine > 0 then
- Canvas.TextOut(X, Y, GetText(StartPos, iBegDrawIndex - pBegLine, 0));
- end;
- procedure TViewerControl.OutCustom(x, y: Integer; const sText: String;
- StartPos: PtrInt; DataLength: Integer);
- var
- sTmpText: String;
- pBegLine, pEndLine: PtrInt;
- iBegDrawIndex, iEndDrawIndex: PtrInt;
- begin
- pBegLine := StartPos;
- pEndLine := pBegLine + DataLength;
- Canvas.Font.Color := Font.Color;
- if FShowCaret and (FCaretPos >= pBegLine) and (FCaretPos <= pEndLine) then
- begin
- FCaretPoint.Y:= Y;
- FCaretPoint.X:= X + Canvas.TextWidth(Copy(sText, 1, FCustom.StartAscii + (FCaretPos - pBegLine)));
- end;
- // Out of selection, draw normal
- if ((FBlockEnd - FBlockBeg) = 0) or ((FBlockBeg < pBegLine) and (FBlockEnd <= pBegLine)) or // before
- ((FBlockBeg > pEndLine) and (FBlockEnd > pEndLine)) then // after
- begin
- // Offset + hex part + space between hex and ascii
- sTmpText:= Copy(sText, 1, FCustom.EndOfs) + ' ';
- Canvas.TextOut(x, y, sTmpText);
- x := x + Canvas.TextWidth(sTmpText);
- // Ascii part
- sTmpText := Copy(sText, 1 + FCustom.StartAscii, MaxInt);
- Canvas.TextOut(x, y, sTmpText);
- Exit;
- end;
- // Get selection start
- if (FBlockBeg <= pBegLine) then
- iBegDrawIndex := pBegLine
- else begin
- iBegDrawIndex := FBlockBeg;
- end;
- // Get selection end
- if (FBlockEnd < pEndLine) then
- iEndDrawIndex := FBlockEnd
- else begin
- iEndDrawIndex := pEndLine;
- end;
- // Text after selection (hex part)
- if pEndLine - iEndDrawIndex > 0 then
- begin
- sTmpText := Copy(sText, 1, FCustom.StartOfs + (pEndLine - pBegLine) * (FCustom.MaxValueDigits + FCustom.SpaceCount));
- Canvas.TextOut(x, y, sTmpText);
- end;
- // Text before selection + selected text (hex part)
- sTmpText := Copy(sText, 1, FCustom.StartOfs + (iEndDrawIndex - pBegLine) * (FCustom.MaxValueDigits + FCustom.SpaceCount) - 1);
- Canvas.Brush.Color := clHighlight;
- Canvas.Font.Color := clHighlightText;
- Canvas.TextOut(x, y, sTmpText);
- // Restore previous canvas settings
- Canvas.Brush.Color := Color;
- Canvas.Font.Color := Font.Color;
- // Offset + text before selection (hex part)
- sTmpText := Copy(sText, 1, FCustom.StartOfs + (iBegDrawIndex - pBegLine) * (FCustom.MaxValueDigits + FCustom.SpaceCount));
- Canvas.TextOut(x, y, sTmpText);
- // Offset + hex part + space between hex and ascii
- sTmpText:= Copy(sText, 1, FCustom.EndOfs) + ' ';
- x := x + Canvas.TextWidth(sTmpText);
- // Text after selection (ascii part)
- if pEndLine - iEndDrawIndex > 0 then
- begin
- sTmpText := Copy(sText, FCustom.StartAscii + 1, MaxInt);
- Canvas.TextOut(x, y, sTmpText);
- end;
- // Text before selection + selected text (ascii part)
- if (iEndDrawIndex - pBegLine) = FCustom.ValuesPerLine then
- sTmpText := Copy(sText, 1 + FCustom.StartAscii, MaxInt)
- else begin
- sTmpText := UTF8Copy(sText, 1 + FCustom.StartAscii, iEndDrawIndex - pBegLine);
- end;
- Canvas.Brush.Color := clHighlight;
- Canvas.Font.Color := clHighlightText;
- Canvas.TextOut(x, y, sTmpText);
- // Restore background color
- Canvas.Brush.Color := Color;
- Canvas.Font.Color := Font.Color;
- // Text before selection (ascii part)
- if iBegDrawIndex - pBegLine > 0 then
- begin
- sTmpText := UTF8Copy(sText, 1 + FCustom.StartAscii, iBegDrawIndex - pBegLine);
- Canvas.TextOut(x, y, sTmpText);
- end;
- end;
- procedure TViewerControl.OutBin(x, y: Integer; const sText: String;
- StartPos: PtrInt; DataLength: Integer);
- var
- pBegLine, pEndLine: PtrInt;
- iBegDrawIndex, iEndDrawIndex: PtrInt;
- begin
- pBegLine := StartPos;
- pEndLine := pBegLine + DataLength;
- Canvas.Font.Color := Font.Color;
- if FShowCaret and (FCaretPos >= pBegLine) and (FCaretPos <= pEndLine) then
- begin
- FCaretPoint.Y:= Y;
- FCaretPoint.X:= X + Canvas.TextWidth(Copy(sText, 1, FCaretPos - pBegLine));
- end;
- // Out of selection, draw normal
- if ((FBlockEnd - FBlockBeg) = 0) or ((FBlockBeg < pBegLine) and (FBlockEnd < pBegLine)) or // before
- ((FBlockBeg > pEndLine) and (FBlockEnd > pEndLine)) then //after
- begin
- Canvas.TextOut(x, y, sText);
- Exit;
- end;
- // Get selection start/end.
- if (FBlockBeg <= pBegLine) then
- iBegDrawIndex := pBegLine
- else begin
- iBegDrawIndex := FBlockBeg;
- end;
- if (FBlockEnd < pEndLine) then
- iEndDrawIndex := FBlockEnd
- else begin
- iEndDrawIndex := pEndLine;
- end;
- // Text after selection.
- if pEndLine - iEndDrawIndex > 0 then
- Canvas.TextOut(x, y, sText);
- // Text before selection + selected text
- Canvas.Brush.Color := clHighlight;
- Canvas.Font.Color := clHighlightText;
- // Whole line selected
- if (iEndDrawIndex - pBegLine) = DataLength then
- Canvas.TextOut(X, Y, sText)
- else begin
- Canvas.TextOut(X, Y, UTF8Copy(sText, 1, iEndDrawIndex - pBegLine));
- end;
- // Restore previous canvas settings
- Canvas.Brush.Color := Color;
- Canvas.Font.Color := Font.Color;
- // Text before selection
- if iBegDrawIndex - pBegLine > 0 then
- Canvas.TextOut(X, Y, UTF8Copy(sText, 1, iBegDrawIndex - pBegLine));
- end;
- procedure TViewerControl.AddLineOffset(const iOffset: PtrInt);
- begin
- FLineList.Add(iOffset);
- end;
- procedure TViewerControl.KeyDown(var Key: word; Shift: TShiftState);
- var
- CharLenInBytes: Integer;
- 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_RIGHT:
- begin
- Key := 0;
- HScroll(1);
- end;
- VK_LEFT:
- begin
- Key := 0;
- HScroll(-1);
- end;
- VK_HOME:
- begin
- Key := 0;
- CaretGoHome;
- end;
- VK_END:
- begin
- Key := 0;
- CaretGoEnd;
- 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;
- CaretPos := FLowLimit;
- MakeVisible(FCaretPos)
- end;
- VK_END:
- begin
- Key := 0;
- CaretPos := FHighLimit;
- MakeVisible(FCaretPos);
- 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;
- CharLenInBytes: Integer;
- 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;
- FCaretPos := ClickPos;
- FMouseBlockBeg := ClickPos;
- FMouseBlockSide := CharSide;
- FSelecting := True;
- if CharSide in [csRight, csAfter] then
- begin
- if FViewerControlMode in [vcmDec, vcmHex, vcmBin] then
- CharLenInBytes := 1
- else begin
- GetNextCharAsAscii(FCaretPos, CharLenInBytes);
- end;
- FCaretPos := FCaretPos + CharLenInBytes;
- end;
- 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;
- if FAutoCopy then
- 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
- if FViewerControlMode in [vcmDec, vcmHex, vcmBin] then
- CharLenInBytes := 1
- else begin
- GetNextCharAsAscii(aPosition, CharLenInBytes);
- end;
- 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;
- FCaretPos:= FBlockBeg;
- 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;
- FCaretPos:= FBlockEnd;
- 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;
- FCaretPos:= FBlockEnd;
- 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
- if FAutoCopy then
- 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.DoMouseWheelLeft(Shift: TShiftState; MousePos: TPoint): Boolean;
- begin
- Result:= inherited DoMouseWheelLeft(Shift, MousePos);
- if not Result then
- Result := HScroll(-Mouse.WheelScrollLines);
- end;
- function TViewerControl.DoMouseWheelRight(Shift: TShiftState; MousePos: TPoint): Boolean;
- begin
- Result:= inherited DoMouseWheelRight(Shift, MousePos);
- if not Result then
- Result := HScroll(Mouse.WheelScrollLines);
- end;
- procedure TViewerControl.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double);
- begin
- FScrollBarVert.Width := LCLIntf.GetSystemMetrics(SM_CYVSCROLL);
- FScrollBarHorz.Height := LCLIntf.GetSystemMetrics(SM_CYHSCROLL);
- inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion);
- end;
- function TViewerControl.XYPos2Adr(x, y: Integer; out CharSide: TCharSide): PtrInt;
- var
- yIndex: Integer;
- StartLine, EndLine: PtrInt;
- function XYPos2AdrBin: PtrInt;
- var
- I, J, L: Integer;
- charWidth: Integer;
- textWidth: Integer;
- tmpPosition: PtrInt;
- s, ss, sText: String;
- InvalidCharLen: Integer;
- begin
- J:= 1;
- ss := EmptyStr;
- tmpPosition := StartLine;
- sText := TransformBin(tmpPosition, EndLine);
- L:= Length(sText);
- for I := 1 to L do
- begin
- charWidth:= SafeUTF8NextCharLen(PByte(@sText[J]), (L - J) + 1, InvalidCharLen);
- s:= Copy(sText, J, charWidth);
- Inc(J, charWidth);
- ss := ss + s;
- textWidth := Canvas.TextWidth(ss);
- if textWidth > x then
- begin
- charWidth := Canvas.TextWidth(s);
- if textWidth - charWidth div 2 > x then
- CharSide := csLeft
- else
- CharSide := csRight;
- Exit(StartLine + I - 1); // -1 because we count from 1
- end;
- end;
- CharSide := csBefore;
- Result := EndLine;
- end;
- function XYPos2AdrCustom: PtrInt;
- // | offset part | custom part | native part |
- // | 0000AAAA: | FF AA CC AE | djfjks |
- var
- I, J, L: Integer;
- charWidth: Integer;
- textWidth: Integer;
- tmpPosition: PtrInt;
- InvalidCharLen: Integer;
- ss, sText, sPartialText: String;
- begin
- tmpPosition := StartLine;
- sText := TransformCustom(tmpPosition, EndLine);
- if sText = '' then Exit;
- // Clicked on offset part
- ss := Copy(sText, 1, FCustom.StartOfs);
- textWidth := Canvas.TextWidth(ss);
- if textWidth > x then
- begin
- CharSide := csBefore;
- Exit(StartLine);
- end;
- // Clicked on custom part
- for I := 0 to FCustom.ValuesPerLine - 1 do
- begin
- sPartialText := Copy(sText, 1 + FCustom.StartOfs + I * (FCustom.MaxValueDigits + FCustom.SpaceCount), FCustom.MaxValueDigits);
- ss := ss + sPartialText;
- textWidth := Canvas.TextWidth(ss);
- if textWidth > x then
- begin
- // Check if we're not after end of data.
- if StartLine + I >= EndLine then
- begin
- CharSide := csBefore;
- Exit(EndLine);
- end;
- charWidth := Canvas.TextWidth(sPartialText);
- if textWidth - charWidth div 2 > x then
- CharSide := csLeft
- else
- CharSide := csRight;
- Exit(StartLine + I);
- end;
- // Space after hex number.
- ss := ss + string(sText[1 + FCustom.StartOfs + I * (FCustom.MaxValueDigits + 1) + FCustom.MaxValueDigits]);
- textWidth := Canvas.TextWidth(ss);
- if textWidth > x then
- begin
- CharSide := csAfter;
- Exit(StartLine + I);
- end;
- end;
- // Clicked between hex and ascii.
- sPartialText := Copy(sText, 1 + FCustom.StartOfs, FCustom.StartAscii - FCustom.EndOfs);
- ss := ss + sPartialText;
- textWidth := Canvas.TextWidth(ss);
- if textWidth > x then
- begin
- Exit(-1); // No position.
- end;
- // Clicked on ascii part.
- L:= Length(sText);
- J:= 1 + FCustom.StartAscii;
- for I := 0 to FCustom.ValuesPerLine - 1 do
- begin
- charWidth := SafeUTF8NextCharLen(PByte(@sText[J]), (L - J) + 1, InvalidCharLen);
- sPartialText := Copy(sText, J, charWidth);
- Inc(J, charWidth);
- ss := ss + sPartialText;
- textWidth := Canvas.TextWidth(ss);
- if textWidth > x then
- begin
- // Check if we're not after end of data.
- if StartLine + I >= EndLine then
- begin
- CharSide := csBefore;
- Exit(EndLine);
- end;
- charWidth := Canvas.TextWidth(sPartialText);
- if textWidth - charWidth div 2 > x then
- CharSide := csLeft
- else
- CharSide := csRight;
- Exit(StartLine + I);
- end;
- end;
- CharSide := csBefore;
- Result := EndLine;
- end;
- function XYPos2AdrText: PtrInt;
- var
- i: PtrInt;
- Dos: Boolean;
- charWidth: Integer;
- textWidth: Integer;
- len: Integer = 0;
- CharLenInBytes: Integer;
- s: String;
- ss: String;
- begin
- ss := '';
- i := StartLine;
- Dos:= FEncoding in ViewerEncodingOem;
- 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(' ', FTabSpaces - len mod FTabSpaces);
- len := len + (FTabSpaces - len mod FTabSpaces);
- end
- else
- Inc(len); // Assume there is one character after conversion
- // (otherwise use Inc(len, UTF8Length(s))).
- if (Mode = vcmText) and (len <= FHPosition) then
- begin
- i := i + CharLenInBytes;
- Continue;
- end;
- if (CharLenInBytes = 1) and (s[1] < ' ') then
- begin
- if Dos then
- s := ASCII_TABLE[Ord(s[1])]
- else
- s := ' ';
- end;
- ss := ss + s;
- textWidth := Canvas.TextWidth(ss);
- if textWidth > x then
- begin
- charWidth := Canvas.TextWidth(s);
- if textWidth - charWidth div 2 > x then
- CharSide := csLeft
- else
- CharSide := csRight;
- Exit(i);
- end;
- end;
- i := i + CharLenInBytes;
- end;
- CharSide := csBefore;
- Result := EndLine;
- end;
- begin
- if FLineList.Count = 0 then
- Exit(-1);
- if (x < FLeftMargin) then
- x := 0
- else begin
- x := x - FLeftMargin;
- end;
- 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) and ((Mode <> vcmText) or (FHPosition = 0)) then
- begin
- CharSide := csBefore;
- Exit(StartLine);
- end;
- case Mode of
- vcmBin:
- Result := XYPos2AdrBin;
- vcmHex,vcmDec:
- Result := XYPos2AdrCustom; // XYPos2AdrHex;
- vcmText, vcmWrap, vcmBook:
- 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;
- procedure TViewerControl.CopyToClipboardF;
- var
- s,sText, utf8Text: string;
- len: Integer;
- begin
- len:=FBlockEnd-FBlockBeg;
- if len=0 then exit;
- sText:=TransformCustomBlock(FBlockBeg,len,False,False,s);
- 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.Selection: String;
- const
- MAX_LEN = 512;
- var
- sText: String;
- AIndex: PtrInt;
- ALength: PtrInt;
- CharLenInBytes: Integer;
- begin
- if (FBlockEnd - FBlockBeg) <= 0 then
- Exit(EmptyStr);
- ALength:= FBlockEnd - FBlockBeg;
- if ALength <= MAX_LEN then
- begin
- SetString(sText, GetDataAdr + FBlockBeg, ALength);
- Result := ConvertToUTF8(sText);
- end
- else begin
- Result:= EmptyStr;
- AIndex:= FBlockBeg;
- ALength:= AIndex + MAX_LEN;
- while AIndex < ALength do
- begin
- sText := GetNextCharAsUtf8(AIndex, CharLenInBytes);
- if CharLenInBytes = 0 then
- Break;
- Result:= Result + sText;
- AIndex:= AIndex + CharLenInBytes;
- end;
- end;
- 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 := UTF8CodepointToUnicode(PAnsiChar(GetDataAdr + iPosition), CharLenInBytes);
- end
- else
- CharLenInBytes := 0;
- end;
- veAnsi, veOem,
- veCp1250..veCp874,
- veIso88591,
- veIso88592,
- veKoi8r,
- veKoi8u,
- veKoi8ru:
- 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;
- veCp932, // Unsupported variable-width encodings
- veCp936, // TODO: Add cp932, cp936, cp949, cp950 encoding support
- veCp949,
- veCp950:
- if iPosition < FHighLimit then
- begin
- Result := PByte(GetDataAdr)[iPosition];
- CharLenInBytes := 1;
- 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 := UTF8CodepointToUnicode(PAnsiChar(GetDataAdr + iPosition - CharLenInBytes), CharLenInBytes);
- end
- else
- CharLenInBytes := 0;
- end;
- veAnsi, veOem,
- veCp1250..veCp874,
- veIso88591,
- veIso88592,
- veKoi8r,
- veKoi8u,
- veKoi8ru:
- 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;
- veCp932, // Unsupported variable-width encodings
- veCp936, // TODO: Add cp932, cp936, cp949, cp950 encoding support
- veCp949,
- veCp950:
- if iPosition > FLowLimit then
- begin
- Result := PByte(GetDataAdr + iPosition)[-1];
- CharLenInBytes := 1;
- end
- else
- CharLenInBytes := 0;
- else
- raise Exception.Create('Unsupported viewer encoding');
- end;
- end;
- function TViewerControl.GetNextCharAsUtf8(const iPosition: PtrInt; out CharLenInBytes: Integer): String;
- var
- u1: Word;
- s: string;
- InvalidCharLen: Integer;
- begin
- Result := '';
- case FEncoding of
- veUtf8, veUtf8bom:
- CharLenInBytes := SafeUTF8NextCharLen(GetDataAdr + iPosition,
- FHighLimit - iPosition,
- InvalidCharLen);
- veAnsi, veOem,
- veCp1250..veCp874,
- veIso88591,
- veIso88592,
- veKoi8r,
- veKoi8u,
- veKoi8ru:
- 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;
- veCp932, // Unsupported variable-width encodings
- veCp936, // TODO: Add cp932, cp936, cp949, cp950 encoding support
- veCp949,
- veCp950:
- CharLenInBytes := 1;
- 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): String;
- begin
- if FEncoding = veAutoDetect then
- FEncoding := DetectEncoding; // Force detect encoding.
- case FEncoding of
- veAutoDetect: ;
- veAnsi:
- Result := CeAnsiToUtf8(sText);
- veOem:
- Result := CeOemToUtf8(sText);
- 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: String): AnsiString;
- begin
- if FEncoding = veAutoDetect then
- FEncoding := DetectEncoding; // Force detect encoding.
- case FEncoding of
- veAutoDetect: ;
- veAnsi:
- Result := CeUtf8ToAnsi(sText);
- veOem:
- Result := CeUtf8ToOem(sText);
- 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);
- var
- Offset: Integer;
- LastLine: Boolean;
- begin
- if not IsVisible(aPosition) then
- begin
- SetPosition(aPosition);
- Offset:= GetLinesTillEnd(aPosition, LastLine);
- if (Offset > 4) and (LastLine = False) then Scroll(-4);
- Update;
- if FViewerControlMode = vcmText then
- begin
- if (FVisibleOffset < FHPosition) or
- (FVisibleOffset > FHPosition + FTextWidth) then
- begin
- SetHPosition(FVisibleOffset);
- HScroll(-1);
- end;
- 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 Mode of
- vcmBin, vcmHex:
- begin
- //FScrollBarVert.PageSize :=
- // ((FHighLimit div cHexWidth - GetClientHeightInLines) div 100);
- end
- else
- FScrollBarVert.PageSize := 1;
- end;
- FScrollBarHorz.Visible:= (FViewerControlMode = vcmText);
- 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 = 4096; // take first 4kB 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 FViewerControlMode of
- vcmText, vcmWrap, vcmBook:
- 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, veOem,
- veCp1250..veCp874,
- veIso88591,
- veIso88592,
- veKoi8r,
- veKoi8u,
- veKoi8ru:
- ; // 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;
- veCp932, // Unsupported variable-width encodings
- veCp936, // TODO: Add cp932, cp936, cp949, cp950 encoding support
- veCp949,
- veCp950:
- ;
- 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 FViewerControlMode of
- vcmText, vcmWrap, vcmBook:
- 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: String;
- bCaseSensitive: Boolean; bSearchBackwards: Boolean): PtrInt;
- var
- SearchTextLength: Integer;
- sSearchChars: array of String;
- pCurrentAddr, pEndAddr: PtrInt;
- i, charLen: Integer;
- function sPos2(pAdr: PtrInt):Boolean;
- var
- curChr:String;
- 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 TViewerControl.ResetEncoding;
- begin
- FEncoding:= veAutoDetect;
- end;
- procedure Register;
- begin
- RegisterComponents('SeksiCmd', [TViewerControl]);
- end;
- end.
|