diff options
119 files changed, 25405 insertions, 19273 deletions
diff --git a/packages/fv/examples/testapp.lpi b/packages/fv/examples/testapp.lpi index 2b5b3736e7..b381fabf6b 100644 --- a/packages/fv/examples/testapp.lpi +++ b/packages/fv/examples/testapp.lpi @@ -1,59 +1,191 @@ -<?xml version="1.0"?> +<?xml version="1.0" encoding="UTF-8"?> <CONFIG> <ProjectOptions> + <Version Value="11"/> <PathDelim Value="\"/> - <Version Value="5"/> <General> <Flags> <MainUnitHasUsesSectionForAllUnits Value="False"/> <MainUnitHasCreateFormStatements Value="False"/> <MainUnitHasTitleStatement Value="False"/> + <LRSInOutputDirectory Value="False"/> </Flags> <MainUnit Value="0"/> - <IconPath Value="./"/> - <TargetFileExt Value=".exe"/> - <ActiveEditorIndexAtStart Value="0"/> </General> - <LazDoc Paths=""/> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> <PublishOptions> <Version Value="2"/> - <IgnoreBinaries Value="False"/> - <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> - <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> </PublishOptions> <RunParams> <local> - <FormatVersion Value="1"/> - <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> </local> + <FormatVersion Value="2"/> + <Modes Count="1"> + <Mode0 Name="default"> + <local> + <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> + </local> + </Mode0> + </Modes> </RunParams> - <Units Count="1"> + <Units Count="7"> <Unit0> <Filename Value="testapp.pas"/> <IsPartOfProject Value="True"/> - <UnitName Value="testapp"/> - <CursorPos X="1" Y="1"/> - <TopLine Value="1"/> - <EditorIndex Value="0"/> - <UsageCount Value="20"/> - <Loaded Value="True"/> + <EditorIndex Value="-1"/> + <TopLine Value="22"/> + <CursorPos Y="37"/> + <UsageCount Value="21"/> + <LoadedDesigner Value="True"/> </Unit0> + <Unit1> + <Filename Value="..\src\fvcommon.pas"/> + <UnitName Value="FVCommon"/> + <EditorIndex Value="2"/> + <CursorPos X="11"/> + <UsageCount Value="11"/> + <Loaded Value="True"/> + </Unit1> + <Unit2> + <Filename Value="..\src\udrivers.pas"/> + <UnitName Value="UDrivers"/> + <EditorIndex Value="-1"/> + <CursorPos X="10" Y="2"/> + <UsageCount Value="10"/> + </Unit2> + <Unit3> + <Filename Value="..\src\drivers.inc"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="4"/> + <TopLine Value="336"/> + <CursorPos X="51" Y="363"/> + <UsageCount Value="11"/> + <Loaded Value="True"/> + </Unit3> + <Unit4> + <Filename Value="..\src\uvalidate.pas"/> + <UnitName Value="UValidate"/> + <CursorPos X="8" Y="2"/> + <UsageCount Value="11"/> + <Loaded Value="True"/> + </Unit4> + <Unit5> + <Filename Value="..\src\validate.inc"/> + <EditorIndex Value="1"/> + <TopLine Value="65"/> + <CursorPos X="35" Y="77"/> + <UsageCount Value="11"/> + <Loaded Value="True"/> + </Unit5> + <Unit6> + <Filename Value="..\src\fvcommon.inc"/> + <EditorIndex Value="3"/> + <TopLine Value="129"/> + <CursorPos X="19" Y="149"/> + <UsageCount Value="11"/> + <Loaded Value="True"/> + </Unit6> </Units> - <JumpHistory Count="0" HistoryIndex="-1"/> + <JumpHistory Count="21" HistoryIndex="20"> + <Position1> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="339" Column="19" TopLine="312"/> + </Position1> + <Position2> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="341" Column="18" TopLine="314"/> + </Position2> + <Position3> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="343" Column="19" TopLine="316"/> + </Position3> + <Position4> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="261" Column="19" TopLine="245"/> + </Position4> + <Position5> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="262" TopLine="245"/> + </Position5> + <Position6> + <Filename Value="..\src\drivers.inc"/> + </Position6> + <Position7> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="262" Column="28" TopLine="235"/> + </Position7> + <Position8> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="351" TopLine="332"/> + </Position8> + <Position9> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="361" TopLine="334"/> + </Position9> + <Position10> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="370" TopLine="343"/> + </Position10> + <Position11> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="388" Column="47" TopLine="361"/> + </Position11> + <Position12> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="945" Column="41" TopLine="929"/> + </Position12> + <Position13> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="970" Column="54" TopLine="957"/> + </Position13> + <Position14> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="997" Column="55" TopLine="988"/> + </Position14> + <Position15> + <Filename Value="..\src\uvalidate.pas"/> + <Caret Line="2" Column="8"/> + </Position15> + <Position16> + <Filename Value="..\src\validate.inc"/> + <Caret Line="126" Column="26" TopLine="115"/> + </Position16> + <Position17> + <Filename Value="..\src\validate.inc"/> + </Position17> + <Position18> + <Filename Value="..\src\validate.inc"/> + <Caret Line="67" Column="24" TopLine="49"/> + </Position18> + <Position19> + <Filename Value="..\src\validate.inc"/> + <Caret Line="77" Column="35" TopLine="65"/> + </Position19> + <Position20> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="1086" Column="51" TopLine="1075"/> + </Position20> + <Position21> + <Filename Value="..\src\drivers.inc"/> + <Caret Line="110" TopLine="83"/> + </Position21> + </JumpHistory> </ProjectOptions> <CompilerOptions> - <Version Value="5"/> + <Version Value="11"/> <PathDelim Value="\"/> <SearchPaths> <IncludeFiles Value="..\src"/> - <OtherUnitFiles Value="..\"/> + <OtherUnitFiles Value=".."/> </SearchPaths> - <CodeGeneration> - <Generate Value="Faster"/> - </CodeGeneration> - <Other> - <CompilerPath Value="$(CompPath)"/> - </Other> + <Parsing> + <SyntaxOptions> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> </CompilerOptions> <Debugging> <Exceptions Count="2"> diff --git a/packages/fv/examples/testuapp.lpi b/packages/fv/examples/testuapp.lpi new file mode 100644 index 0000000000..3c76e1fe0f --- /dev/null +++ b/packages/fv/examples/testuapp.lpi @@ -0,0 +1,71 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="11"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + <MainUnitHasScaledStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="testuapp"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="testuapp.pas"/> + <IsPartOfProject Value="True"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="testuapp"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir);../../rtl-console/src/inc"/> + <OtherUnitFiles Value="../src;../../rtl-console/src/unix;../../rtl-extra/src/inc;../../rtl-unicode/src/inc"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <CodeGeneration> + <Checks> + <IOChecks Value="True"/> + <RangeChecks Value="True"/> + <OverflowChecks Value="True"/> + <StackChecks Value="True"/> + </Checks> + <VerifyObjMethodCallValidity Value="True"/> + <Optimizations> + <OptimizationLevel Value="0"/> + </Optimizations> + </CodeGeneration> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/fv/examples/testuapp.pas b/packages/fv/examples/testuapp.pas new file mode 100644 index 0000000000..4cb9b901f3 --- /dev/null +++ b/packages/fv/examples/testuapp.pas @@ -0,0 +1,170 @@ +program testuapp; + +{$codepage UTF8} + +uses + Objects, UDrivers, UViews, UMenus, UDialogs, UApp, UMsgBox, UInpLong, UTabs, SysUtils; + +const + cmOrderNew = 200; + cmOrderWin = 201; + cmOrderSave = 202; + cmOrderCancel = 203; + cmOrderNext = 204; + cmOrderPrev = 205; + cmClipShow = 210; + cmAbout = 220; + cmFindOrderWindow = 1002; + cmWindow3 = 1003; + cmOptionsVideo = 1502; + cmOptionsSave = 1503; + cmOptionsLoad = 1504; + +type + + { TMyUnicodeApp } + + TMyUnicodeApp = object(TApplication) + P3 : PGroup; + procedure HandleEvent(var Event : TEvent);virtual; + procedure InitMenuBar; virtual; + procedure InitStatusLine; virtual; + procedure Window3; + procedure ShowAboutBox; + end; + +var + MyUnicodeApp: TMyUnicodeApp; + +{ TMyUnicodeApp } + +procedure TMyUnicodeApp.HandleEvent(var Event: TEvent); +begin + inherited HandleEvent(Event); + if Event.What = evCommand then + begin + case Event.Command of + cmWindow3: + Window3; + cmAbout: + ShowAboutBox; + else + Exit; + end; + end; + ClearEvent(Event); +end; + +procedure TMyUnicodeApp.InitMenuBar; +var + R: TRect; +begin + GetExtent(R); + R.B.Y := R.A.Y + 1; + MenuBar := new (PMenuBar, Init(R, NewMenu( + NewSubMenu('打开', hcNoContext, NewMenu(NewItem('~Ð~ов打теÑÑ‚ по пъÌÑ‚Ñ', 'Еф2', kbF2, cmNew, hcNew, + NewItem('~O~pen', '💩', kbF3, cmOpen, hcOpen, + NewLine( + NewItem('E~x~it', 'ÑŠÌÑŠÌÑŠÌ打', kbAltX, cmQuit, hcNoContext, nil))))), + NewSubMenu('~E~dit', hcNoContext, NewMenu( + NewItem('Window ~3~','',kbNoKey,cmWindow3,hcNoContext,nil)), + NewSubMenu('~O~rders', hcNoContext, {NewMenu(GetOrdersMenuItems(nil))}nil, + NewSubMenu('O~p~tions', hcNoContext, {NewMenu(GetOptionsMenuItems(nil))}nil, + NewSubMenu('~W~indow', hcNoContext, {NewMenu(GetWindowMenuItems(nil))}nil, + NewSubMenu('~H~elp', hcNoContext, NewMenu(NewItem('~A~bout...','',kbNoKey,cmAbout,hcNoContext, + nil)), nil))))))))); +end; + +procedure TMyUnicodeApp.InitStatusLine; +var + R: TRect; +begin + GetExtent(R); + R.A.Y := R.B.Y - 1; + new(StatusLine, Init(R, + NewStatusDef(0, $EFFF, + NewStatusKey('~F1~ По пъÌÑ‚Ñ', kbF1, cmHelp, + NewStatusKey('~F2~ 打开', kbF2, cmOpen, + NewStatusKey('~F3~ ОтварÑне', kbF3, cmOpen, + NewStatusKey('~F4~ ÎÎος', kbF4, cmNew, + NewStatusKey('~Alt+F3~ ZavÅ™Ãt', kbAltF3, cmClose, + NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit, + nil)))))), + NewStatusDef($F000, $FFFF, + NewStatusKey('~F6~ Next', kbF6, cmOrderNext, + NewStatusKey('~Shift+F6~ Pref', kbShiftF6, cmOrderPrev, + nil)),nil)))); +end; + +procedure TMyUnicodeApp.Window3; +VAR R: TRect; P: PGroup; B: PScrollBar; + List: PUnicodeStringCollection; Lb: PListBox; +begin + { Create a basic dialog box. In it are buttons, } + { list boxes, scrollbars, inputlines, checkboxes } + R.Assign(32, 2, 77, 18); { Assign screen area } + P := New(PDialog, Init(R, '테스트 대화 ìƒìž')); { Create dialog } + If (P <> Nil) Then Begin { Dialog valid } + R.Assign(5, 5, 20, 7); { Allocate area } + P^.Insert(New(PCheckBoxes, Init(R, + NewSItem('Test', + NewSITem('Item 2', Nil))))); { Insert check box } + R.Assign(5, 2, 20, 3); { Assign area } + + B := New(PScrollBar, Init(R)); { Insert scroll bar } + If (B <> Nil) Then Begin { Scrollbar valid } + B^.SetRange(0, 100); { Set scrollbar range } + B^.SetValue(50); { Set position } + P^.Insert(B); { Insert scrollbar } + End; + R.Assign(5, 10, 20, 11); { Assign area } + + P^.Insert(New(PInputLine, Init(R, 60))); { Create input line } + R.Assign(5, 13, 20, 14); { Assign area } + + P^.Insert(New(PInputLine, Init(R, 60))); { Create input line } + R.Assign(40, 8, 41, 14); { Assign area } + + B := New(PScrollBar, Init(R)); { Create scrollbar } + P^.Insert(B); { Insert scrollbar } + R.Assign(25, 8, 40, 14); { Assign area } + + Lb := New(PListBox, Init(R, 1, B)); { Create listbox } + P^.Insert(Lb); { Insert listbox } + List := New(PUnicodeStringCollection, Init(10, 5)); { Create string list } + List^.AtInsert(0, 'Зебра'); { Insert text } + List^.AtInsert(1, '林檎'); { Insert text } + List^.AtInsert(2, 'Third'); { Insert text } + List^.AtInsert(3, 'Peach'); { Insert text } + List^.AtInsert(4, 'ЗаÌек'); { Insert text } + List^.AtInsert(5, 'Item six'); { Insert text } + List^.AtInsert(6, 'Jaguar'); { Insert text } + List^.AtInsert(7, 'Melon'); { Insert text } + List^.AtInsert(8, 'Ninth'); { Insert text } + List^.AtInsert(9, 'Last item'); { Insert text } + Lb^.Newlist(List); { Give list to listbox } + R.Assign(30, 2, 40, 4); { Assign area } + + P^.Insert(New(PButton, Init(R, '好的', 100, bfGrabFocus)));{ Create okay button } + R.Assign(30, 15, 40, 17); { Assign area } + + Desktop^.Insert(P); { Insert dialog } + P3:=P; + End; +end; + +procedure TMyUnicodeApp.ShowAboutBox; +begin + MessageBox(#3'Free Vision TUI Framework'#13 + + #3'Test/Demo Application'#13+ + #3'Мога да Ñм Ñтъкло, то не ми вреди.'#13+ + #3'我能åžä¸‹çŽ»ç’ƒè€Œä¸ä¼¤èº«ä½“。', + nil, mfInformation or mfOKButton); +end; + +begin + MyUnicodeApp.Init; + MyUnicodeApp.Run; + MyUnicodeApp.Done; +end. + diff --git a/packages/fv/examples/testuapp_windows.lpi b/packages/fv/examples/testuapp_windows.lpi new file mode 100644 index 0000000000..393df51b4f --- /dev/null +++ b/packages/fv/examples/testuapp_windows.lpi @@ -0,0 +1,71 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="11"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + <MainUnitHasScaledStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="testuapp"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="testuapp.pas"/> + <IsPartOfProject Value="True"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="testuapp"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir);../../rtl-console/src/inc"/> + <OtherUnitFiles Value="../src;../../rtl-console/src/win;../../rtl-extra/src/inc;../../rtl-unicode/src/inc"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <CodeGeneration> + <Checks> + <IOChecks Value="True"/> + <RangeChecks Value="True"/> + <OverflowChecks Value="True"/> + <StackChecks Value="True"/> + </Checks> + <VerifyObjMethodCallValidity Value="True"/> + <Optimizations> + <OptimizationLevel Value="0"/> + </Optimizations> + </CodeGeneration> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/fv/fpmake.pp b/packages/fv/fpmake.pp index c89722ed4e..edbbf1c782 100644 --- a/packages/fv/fpmake.pp +++ b/packages/fv/fpmake.pp @@ -29,6 +29,7 @@ begin P.IncludePath.Add('src'); P.Dependencies.add('rtl-console'); P.Dependencies.add('rtl-extra'); + P.Dependencies.add('rtl-unicode'); P.Dependencies.add('morphunits',[morphos]); P.Dependencies.add('arosunits',[aros]); if Defaults.CPU=m68k then @@ -39,6 +40,7 @@ begin T:=P.Targets.AddUnit('app.pas'); with T.Dependencies do begin + AddInclude('app.inc'); AddInclude('platform.inc'); AddUnit('fvcommon'); AddUnit('drivers'); @@ -50,6 +52,21 @@ begin AddUnit('fvconsts'); end; T.ResourceStrings := True; + T:=P.Targets.AddUnit('uapp.pas'); + with T.Dependencies do + begin + AddInclude('app.inc'); + AddInclude('platform.inc'); + AddUnit('ufvcommon'); + AddUnit('udrivers'); + AddUnit('uviews'); + AddUnit('umenus'); + AddUnit('uhistlist'); + AddUnit('udialogs'); + AddUnit('umsgbox'); + AddUnit('fvconsts'); + end; + T.ResourceStrings := True; T:=P.Targets.AddUnit('asciitab.pas'); with T.Dependencies do begin @@ -99,6 +116,7 @@ begin T:=P.Targets.AddUnit('dialogs.pas'); with T.Dependencies do begin + AddInclude('dialogs.inc'); AddInclude('platform.inc'); AddUnit('fvcommon'); AddUnit('fvconsts'); @@ -109,14 +127,38 @@ begin AddUnit('histlist'); end; T.ResourceStrings := True; + T:=P.Targets.AddUnit('udialogs.pas'); + with T.Dependencies do + begin + AddInclude('dialogs.inc'); + AddInclude('platform.inc'); + AddUnit('ufvcommon'); + AddUnit('fvconsts'); + AddUnit('udrivers'); + AddUnit('uviews'); + AddUnit('uvalidate'); + AddUnit('uapp'); + AddUnit('uhistlist'); + end; + T.ResourceStrings := True; T:=P.Targets.AddUnit('drivers.pas'); with T.Dependencies do begin + AddInclude('drivers.inc'); AddInclude('platform.inc'); AddUnit('sysmsg'); AddUnit('fvcommon'); AddUnit('fvconsts'); end; + T:=P.Targets.AddUnit('udrivers.pas'); + with T.Dependencies do + begin + AddInclude('drivers.inc'); + AddInclude('platform.inc'); + AddUnit('sysmsg'); + AddUnit('ufvcommon'); + AddUnit('fvconsts'); + end; T:=P.Targets.AddUnit('editors.pas'); with T.Dependencies do begin @@ -134,6 +176,13 @@ begin T:=P.Targets.AddUnit('fvcommon.pas'); with T.Dependencies do begin + AddInclude('fvcommon.inc'); + AddInclude('platform.inc'); + end; + T:=P.Targets.AddUnit('ufvcommon.pas'); + with T.Dependencies do + begin + AddInclude('fvcommon.inc'); AddInclude('platform.inc'); end; T:=P.Targets.AddUnit('fvconsts.pas'); @@ -150,17 +199,39 @@ begin T:=P.Targets.AddUnit('histlist.pas'); with T.Dependencies do begin + AddInclude('histlist.inc'); AddInclude('platform.inc'); AddUnit('fvcommon'); end; + T:=P.Targets.AddUnit('uhistlist.pas'); + with T.Dependencies do + begin + AddInclude('histlist.inc'); + AddInclude('platform.inc'); + AddUnit('ufvcommon'); + end; T:=P.Targets.AddUnit('inplong.pas'); with T.Dependencies do begin + AddInclude('inplong.inc'); AddInclude('platform.inc'); AddUnit('drivers'); AddUnit('views'); AddUnit('dialogs'); AddUnit('msgbox'); + AddUnit('fvcommon'); + AddUnit('fvconsts'); + end; + T:=P.Targets.AddUnit('uinplong.pas'); + with T.Dependencies do + begin + AddInclude('inplong.inc'); + AddInclude('platform.inc'); + AddUnit('udrivers'); + AddUnit('uviews'); + AddUnit('udialogs'); + AddUnit('umsgbox'); + AddUnit('ufvcommon'); AddUnit('fvconsts'); end; T:=P.Targets.AddUnit('memory.pas'); @@ -172,27 +243,61 @@ begin T:=P.Targets.AddUnit('menus.pas'); with T.Dependencies do begin + AddInclude('menus.inc'); AddInclude('platform.inc'); AddUnit('drivers'); AddUnit('views'); + AddUnit('fvcommon'); + AddUnit('fvconsts'); + end; + T:=P.Targets.AddUnit('umenus.pas'); + with T.Dependencies do + begin + AddInclude('menus.inc'); + AddInclude('platform.inc'); + AddUnit('udrivers'); + AddUnit('uviews'); + AddUnit('ufvcommon'); AddUnit('fvconsts'); end; T:=P.Targets.AddUnit('msgbox.pas'); with T.Dependencies do begin + AddInclude('msgbox.inc'); AddInclude('platform.inc'); AddUnit('dialogs'); AddUnit('drivers'); AddUnit('views'); AddUnit('app'); + AddUnit('fvcommon'); + end; + T.ResourceStrings := True; + T:=P.Targets.AddUnit('umsgbox.pas'); + with T.Dependencies do + begin + AddInclude('msgbox.inc'); + AddInclude('platform.inc'); + AddUnit('udialogs'); + AddUnit('udrivers'); + AddUnit('uviews'); + AddUnit('uapp'); + AddUnit('ufvcommon'); end; T.ResourceStrings := True; T:=P.Targets.AddUnit('outline.pas'); with T.Dependencies do begin + AddInclude('outline.inc'); AddUnit('drivers'); AddUnit('views'); end; + T:=P.Targets.AddUnit('uoutline.pas'); + with T.Dependencies do + begin + AddInclude('outline.inc'); + AddUnit('udrivers'); + AddUnit('uviews'); + end; T:=P.Targets.AddUnit('statuses.pas'); with T.Dependencies do begin @@ -229,6 +334,7 @@ begin T:=P.Targets.AddUnit('tabs.pas'); with T.Dependencies do begin + AddInclude('tabs.inc'); AddInclude('platform.inc'); AddUnit('drivers'); AddUnit('views'); @@ -236,9 +342,21 @@ begin AddUnit('fvcommon'); AddUnit('dialogs'); end; + T:=P.Targets.AddUnit('utabs.pas'); + with T.Dependencies do + begin + AddInclude('tabs.inc'); + AddInclude('platform.inc'); + AddUnit('udrivers'); + AddUnit('uviews'); + AddUnit('fvconsts'); + AddUnit('ufvcommon'); + AddUnit('udialogs'); + end; T:=P.Targets.AddUnit('timeddlg.pas'); with T.Dependencies do begin + AddInclude('timeddlg.inc'); AddInclude('platform.inc'); AddUnit('dialogs'); AddUnit('fvconsts'); @@ -247,6 +365,18 @@ begin AddUnit('app'); AddUnit('msgbox'); end; + T:=P.Targets.AddUnit('utimeddlg.pas'); + with T.Dependencies do + begin + AddInclude('timeddlg.inc'); + AddInclude('platform.inc'); + AddUnit('udialogs'); + AddUnit('fvconsts'); + AddUnit('udrivers'); + AddUnit('uviews'); + AddUnit('uapp'); + AddUnit('umsgbox'); + end; T:=P.Targets.AddUnit('time.pas'); with T.Dependencies do begin @@ -255,19 +385,39 @@ begin T:=P.Targets.AddUnit('validate.pas'); with T.Dependencies do begin + AddInclude('validate.inc'); AddInclude('platform.inc'); AddUnit('fvcommon'); AddUnit('fvconsts'); AddUnit('msgbox'); end; + T:=P.Targets.AddUnit('uvalidate.pas'); + with T.Dependencies do + begin + AddInclude('validate.inc'); + AddInclude('platform.inc'); + AddUnit('ufvcommon'); + AddUnit('fvconsts'); + AddUnit('umsgbox'); + end; T:=P.Targets.AddUnit('views.pas'); with T.Dependencies do begin + AddInclude('views.inc'); AddInclude('platform.inc'); AddUnit('fvcommon'); AddUnit('drivers'); AddUnit('fvconsts'); end; + T:=P.Targets.AddUnit('uviews.pas'); + with T.Dependencies do + begin + AddInclude('views.inc'); + AddInclude('platform.inc'); + AddUnit('ufvcommon'); + AddUnit('udrivers'); + AddUnit('fvconsts'); + end; P.ExamplePath.Add('examples'); P.ExamplePath.Add('src'); P.Targets.AddExampleProgram('examples/testapp.pas'); diff --git a/packages/fv/src/app.inc b/packages/fv/src/app.inc new file mode 100644 index 0000000000..831c22c5ea --- /dev/null +++ b/packages/fv/src/app.inc @@ -0,0 +1,1300 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of APP.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@starwon.com.au - backup e-mail addr } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} + +{$ifdef FV_UNICODE} +UNIT UApp; +{$else FV_UNICODE} +UNIT App; +{$endif FV_UNICODE} + +{2.0 compatibility} +{$ifdef VER2_0} + {$macro on} + {$define resourcestring := const} +{$endif} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES + {$IFDEF OS_WINDOWS} { WIN/NT CODE } + Windows, { Standard units } + {$ENDIF} + + {$IFDEF OS_OS2} { OS2 CODE } + {$IFDEF PPC_FPC} + Os2Def, DosCalls, PmWin, { Standard units } + {$ELSE} + Os2Def, Os2Base, OS2PmApi, { Standard units } + {$ENDIF} + {$ENDIF} + Dos, + Video, +{$ifdef FV_UNICODE} + UFVCommon, {Memory,} { GFV standard units } +{$else FV_UNICODE} + FVCommon, {Memory,} { GFV standard units } +{$endif FV_UNICODE} + Objects, +{$ifdef FV_UNICODE} + UDrivers, UViews, UMenus, UHistList, UDialogs, Umsgbox, +{$else FV_UNICODE} + Drivers, Views, Menus, HistList, Dialogs, msgbox, +{$endif FV_UNICODE} + fvconsts; + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ STANDARD APPLICATION COMMAND CONSTANTS } +{---------------------------------------------------------------------------} +CONST + cmNew = 30; { Open new file } + cmOpen = 31; { Open a file } + cmSave = 32; { Save current } + cmSaveAs = 33; { Save current as } + cmSaveAll = 34; { Save all files } + cmChangeDir = 35; { Change directories } + cmDosShell = 36; { Dos shell } + cmCloseAll = 37; { Close all windows } + +{---------------------------------------------------------------------------} +{ TApplication PALETTE ENTRIES } +{---------------------------------------------------------------------------} +CONST + apColor = 0; { Coloured app } + apBlackWhite = 1; { B&W application } + apMonochrome = 2; { Monochrome app } + +{---------------------------------------------------------------------------} +{ TBackGround PALETTES } +{---------------------------------------------------------------------------} +CONST + CBackground = #1; { Background colour } + +{---------------------------------------------------------------------------} +{ TApplication PALETTES } +{---------------------------------------------------------------------------} +CONST + { Turbo Vision 1.0 Color Palettes } + + CColor = + #$81#$70#$78#$74#$20#$28#$24#$17#$1F#$1A#$31#$31#$1E#$71#$1F + + #$37#$3F#$3A#$13#$13#$3E#$21#$3F#$70#$7F#$7A#$13#$13#$70#$7F#$7E + + #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 + + #$3F#$3E#$1F#$2F#$1A#$20#$72#$31#$31#$30#$2F#$3E#$31#$13#$38#$00; + + CBlackWhite = + #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$0F + + #$07#$0F#$07#$70#$70#$07#$70#$0F#$70#$7F#$7F#$70#$07#$70#$07#$0F + + #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 + + #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00; + + CMonochrome = + #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 + + #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 + + #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + + #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00; + + { Turbo Vision 2.0 Color Palettes } + + CAppColor = + #$71#$70#$78#$74#$20#$28#$24#$17#$1F#$1A#$31#$31#$1E#$71#$1F + + #$37#$3F#$3A#$13#$13#$3E#$21#$3F#$70#$7F#$7A#$13#$13#$70#$7F#$7E + + #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 + + #$3F#$3E#$1F#$2F#$1A#$20#$72#$31#$31#$30#$2F#$3E#$31#$13#$38#$00 + + #$17#$1F#$1A#$71#$71#$1E#$17#$1F#$1E#$20#$2B#$2F#$78#$2E#$10#$30 + + #$3F#$3E#$70#$2F#$7A#$20#$12#$31#$31#$30#$2F#$3E#$31#$13#$38#$00 + + #$37#$3F#$3A#$13#$13#$3E#$30#$3F#$3E#$20#$2B#$2F#$78#$2E#$30#$70 + + #$7F#$7E#$1F#$2F#$1A#$20#$32#$31#$71#$70#$2F#$7E#$71#$13#$38#$00; + + CAppBlackWhite = + #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$0F + + #$07#$0F#$07#$70#$70#$07#$70#$0F#$70#$7F#$7F#$70#$07#$70#$07#$0F + + #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 + + #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00 + + #$07#$0F#$0F#$07#$70#$07#$07#$0F#$0F#$70#$78#$7F#$08#$7F#$08#$70 + + #$7F#$7F#$7F#$0F#$70#$70#$07#$70#$70#$70#$07#$7F#$70#$07#$78#$00 + + #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 + + #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00; + + CAppMonochrome = + #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 + + #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 + + #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + + #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00 + + #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + + #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00 + + #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + + #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00; + +{---------------------------------------------------------------------------} +{ STANDRARD HELP CONTEXT CONSTANTS } +{---------------------------------------------------------------------------} +CONST +{ Note: range $FF00 - $FFFF of help contexts are reserved by Borland } + hcNew = $FF01; { New file help } + hcOpen = $FF02; { Open file help } + hcSave = $FF03; { Save file help } + hcSaveAs = $FF04; { Save file as help } + hcSaveAll = $FF05; { Save all files help } + hcChangeDir = $FF06; { Change dir help } + hcDosShell = $FF07; { Dos shell help } + hcExit = $FF08; { Exit program help } + + hcUndo = $FF10; { Clipboard undo help } + hcCut = $FF11; { Clipboard cut help } + hcCopy = $FF12; { Clipboard copy help } + hcPaste = $FF13; { Clipboard paste help } + hcClear = $FF14; { Clipboard clear help } + + hcTile = $FF20; { Desktop tile help } + hcCascade = $FF21; { Desktop cascade help } + hcCloseAll = $FF22; { Desktop close all } + hcResize = $FF23; { Window resize help } + hcZoom = $FF24; { Window zoom help } + hcNext = $FF25; { Window next help } + hcPrev = $FF26; { Window previous help } + hcClose = $FF27; { Window close help } + +{***************************************************************************} +{ PUBLIC OBJECT DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TBackGround OBJECT - BACKGROUND OBJECT } +{---------------------------------------------------------------------------} +TYPE + TBackGround = OBJECT (TView) + Pattern: Sw_ExtendedGraphemeCluster; { Background pattern } + CONSTRUCTOR Init (Var Bounds: TRect; const APattern: Sw_ExtendedGraphemeCluster); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Store (Var S: TStream); + END; + PBackGround = ^TBackGround; + +{---------------------------------------------------------------------------} +{ TDeskTop OBJECT - DESKTOP OBJECT } +{---------------------------------------------------------------------------} +TYPE + TDeskTop = OBJECT (TGroup) + Background : PBackground; { Background view } + TileColumnsFirst: Boolean; { Tile direction } + CONSTRUCTOR Init (Var Bounds: TRect); + CONSTRUCTOR Load (Var S: TStream); + PROCEDURE TileError; Virtual; + PROCEDURE InitBackGround; Virtual; + PROCEDURE Tile (Var R: TRect); + PROCEDURE Store (Var S: TStream); + PROCEDURE Cascade (Var R: TRect); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PDeskTop = ^TDeskTop; + +{---------------------------------------------------------------------------} +{ TProgram OBJECT - PROGRAM ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TProgram = OBJECT (TGroup) + CONSTRUCTOR Init; + DESTRUCTOR Done; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION CanMoveFocus: Boolean; + FUNCTION ValidView (P: PView): PView; + FUNCTION InsertWindow (P: PWindow): PWindow; + FUNCTION ExecuteDialog (P: PDialog; Data: Pointer): Word; + PROCEDURE Run; Virtual; + PROCEDURE Idle; Virtual; + PROCEDURE InitScreen; Virtual; +{ procedure DoneScreen; virtual;} + PROCEDURE InitDeskTop; Virtual; + PROCEDURE OutOfMemory; Virtual; + PROCEDURE InitMenuBar; Virtual; + PROCEDURE InitStatusLine; Virtual; + PROCEDURE SetScreenMode (Mode: Word); + PROCEDURE SetScreenVideoMode(const Mode: TVideoMode); + PROCEDURE PutEvent (Var Event: TEvent); Virtual; + PROCEDURE GetEvent (Var Event: TEvent); Virtual; + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PProgram = ^TProgram; + +{---------------------------------------------------------------------------} +{ TApplication OBJECT - APPLICATION OBJECT } +{---------------------------------------------------------------------------} +TYPE + TApplication = OBJECT (TProgram) + CONSTRUCTOR Init; + DESTRUCTOR Done; Virtual; + PROCEDURE Tile; + PROCEDURE Cascade; + PROCEDURE DosShell; + PROCEDURE GetTileRect (Var R: TRect); Virtual; + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + procedure WriteShellMsg; virtual; + END; + PApplication = ^TApplication; { Application ptr } + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STANDARD MENU AND STATUS LINES ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-StdStatusKeys------------------------------------------------------ +Returns a pointer to a linked list of commonly used status line keys. +The default status line for TApplication uses StdStatusKeys as its +complete list of status keys. +22Oct99 LdB +---------------------------------------------------------------------} +FUNCTION StdStatusKeys (Next: PStatusItem): PStatusItem; + +{-StdFileMenuItems--------------------------------------------------- +Returns a pointer to a list of menu items for a standard File menu. +The standard File menu items are New, Open, Save, Save As, Save All, +Change Dir, OS Shell, and Exit. +22Oct99 LdB +---------------------------------------------------------------------} +FUNCTION StdFileMenuItems (Next: PMenuItem): PMenuItem; + +{-StdEditMenuItems--------------------------------------------------- +Returns a pointer to a list of menu items for a standard Edit menu. +The standard Edit menu items are Undo, Cut, Copy, Paste, and Clear. +22Oct99 LdB +---------------------------------------------------------------------} +FUNCTION StdEditMenuItems (Next: PMenuItem): PMenuItem; + +{-StdWindowMenuItems------------------------------------------------- +Returns a pointer to a list of menu items for a standard Window menu. +The standard Window menu items are Tile, Cascade, Close All, +Size/Move, Zoom, Next, Previous, and Close. +22Oct99 LdB +---------------------------------------------------------------------} +FUNCTION StdWindowMenuItems (Next: PMenuItem): PMenuItem; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{-RegisterApp-------------------------------------------------------- +Calls RegisterType for each of the object types defined in this unit. +22oct99 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterApp; + +{***************************************************************************} +{ OBJECT REGISTRATION } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TBackGround STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RBackGround: TStreamRec = ( + ObjType: idBackground; { Register id = 30 } + VmtLink: TypeOf(TBackGround); + Load: @TBackGround.Load; { Object load method } + Store: @TBackGround.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TDeskTop STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RDeskTop: TStreamRec = ( + ObjType: idDesktop; { Register id = 31 } + VmtLink: TypeOf(TDeskTop); + Load: @TDeskTop.Load; { Object load method } + Store: @TDeskTop.Store { Object store method } + ); + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED PUBLIC VARIABLES } +{---------------------------------------------------------------------------} +CONST + AppPalette: SmallInt = apColor; { Application colour } + Desktop: PDeskTop = Nil; { Desktop object } + MenuBar: PMenuView = Nil; { Application menu } + StatusLine: PStatusLine = Nil; { App status line } + Application : PApplication = Nil; { Application object } + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +uses Mouse{,Resource}; + +resourcestring sVideoFailed='Video initialization failed.'; + sTypeExitOnReturn='Type EXIT to return...'; + + +{***************************************************************************} +{ PRIVATE DEFINED CONSTANTS } +{***************************************************************************} + +{***************************************************************************} +{ PRIVATE INITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED PRIVATE VARIABLES } +{---------------------------------------------------------------------------} +CONST Pending: TEvent = (What: evNothing); { Pending event } + +{---------------------------------------------------------------------------} +{ Tileable -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION Tileable (P: PView): Boolean; +BEGIN + Tileable := (P^.Options AND ofTileable <> 0) AND { View is tileable } + (P^.State AND sfVisible <> 0); { View is visible } +END; + +{---------------------------------------------------------------------------} +{ ISqr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION ISqr (X: Sw_Integer): Sw_Integer; +VAR I: Sw_Integer; +BEGIN + I := 0; { Set value to zero } + Repeat + Inc(I); { Inc value } + Until (I * I > X); { Repeat till Sqr > X } + ISqr := I - 1; { Return result } +END; + +{---------------------------------------------------------------------------} +{ MostEqualDivisors -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE MostEqualDivisors (N: SmallInt; Var X, Y: SmallInt; FavorY: Boolean); +VAR I: SmallInt; +BEGIN + I := ISqr(N); { Int square of N } + If ((N MOD I) <> 0) Then { Initial guess } + If ((N MOD (I+1)) = 0) Then Inc(I); { Add one row/column } + If (I < (N DIV I)) Then I := N DIV I; { In first page } + If FavorY Then Begin { Horz preferred } + X := N DIV I; { Calc x position } + Y := I; { Set y position } + End Else Begin { Vert preferred } + Y := N DIV I; { Calc y position } + X := I; { Set x position } + End; +END; + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{--TBackGround--------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TBackGround.Init (Var Bounds: TRect; const APattern: Sw_ExtendedGraphemeCluster); +BEGIN + Inherited Init(Bounds); { Call ancestor } + GrowMode := gfGrowHiX + gfGrowHiY; { Set grow modes } + Pattern := APattern; { Hold pattern } +END; + +{--TBackGround--------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TBackGround.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } +{$ifdef FV_UNICODE} + Pattern := S.ReadUnicodeString; { Read pattern data } +{$else FV_UNICODE} + S.Read(Pattern, SizeOf(Pattern)); { Read pattern data } +{$endif FV_UNICODE} +END; + +{--TBackGround--------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TBackGround.GetPalette: PPalette; +CONST P: String[Length(CBackGround)] = CbackGround; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TBackGround--------------------------------------------------------------} +{ DrawBackground -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBackground.Draw; +VAR B: TDrawBuffer; +BEGIN + MoveChar(B, Pattern, GetColor($01), Size.X); { Fill draw buffer } + WriteLine(0, 0, Size.X, Size.Y, B); { Draw to area } +END; + +{--TBackGround--------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBackGround.Store (Var S: TStream); +BEGIN + TView.Store(S); { TView store called } +{$ifdef FV_UNICODE} + S.WriteUnicodeString(Pattern); { Write pattern data } +{$else FV_UNICODE} + S.Write(Pattern, SizeOf(Pattern)); { Write pattern data } +{$endif FV_UNICODE} +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TDesktop OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TDesktop-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TDesktop.Init (Var Bounds: Objects.TRect); +BEGIN + Inherited Init(Bounds); { Call ancestor } + GrowMode := gfGrowHiX + gfGrowHiY; { Set growmode } + InitBackground; { Create background } + If (Background <> Nil) Then Insert(Background); { Insert background } +END; + +{--TDesktop-----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TDesktop.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + GetSubViewPtr(S, Background); { Load background } + S.Read(TileColumnsFirst, SizeOf(TileColumnsFirst));{ Read data } +END; + +{--TDesktop-----------------------------------------------------------------} +{ TileError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDeskTop.TileError; +BEGIN { Abstract method } +END; + +{--TDesktop-----------------------------------------------------------------} +{ InitBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDesktop.InitBackground; +{$ifdef FV_UNICODE} +CONST Ch = #$2591; +{$else FV_UNICODE} +CONST Ch = #176; +{$endif FV_UNICODE} +VAR R: TRect; +BEGIN + GetExtent(R); { Get desktop extents } + BackGround := New(PBackground, Init(R, Ch)); { Insert a background } +END; + +{--TDesktop-----------------------------------------------------------------} +{ Tile -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDeskTop.Tile (Var R: TRect); +VAR NumCols, NumRows, NumTileable, LeftOver, TileNum: SmallInt; + + FUNCTION DividerLoc (Lo, Hi, Num, Pos: SmallInt): SmallInt; + BEGIN + DividerLoc := LongInt( LongInt(Hi - Lo) * Pos) + DIV Num + Lo; { Calc position } + END; + + PROCEDURE DoCountTileable (P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} + BEGIN + If Tileable(P) Then Inc(NumTileable); { Count tileable views } + END; + + PROCEDURE CalcTileRect (Pos: SmallInt; Var NR: TRect); + VAR X, Y, D: SmallInt; + BEGIN + D := (NumCols - LeftOver) * NumRows; { Calc d value } + If (Pos<D) Then Begin + X := Pos DIV NumRows; Y := Pos MOD NumRows; { Calc positions } + End Else Begin + X := (Pos - D) div (NumRows + 1) + + (NumCols - LeftOver); { Calc x position } + Y := (Pos - D) mod (NumRows + 1); { Calc y position } + End; + NR.A.X := DividerLoc(R.A.X, R.B.X, NumCols, X); { Top left x position } + NR.B.X := DividerLoc(R.A.X, R.B.X, NumCols, X+1);{ Right x position } + If (Pos >= D) Then Begin + NR.A.Y := DividerLoc(R.A.Y, R.B.Y,NumRows+1,Y);{ Top y position } + NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows+1, + Y+1); { Bottom y position } + End Else Begin + NR.A.Y := DividerLoc(R.A.Y, R.B.Y,NumRows,Y); { Top y position } + NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows, + Y+1); { Bottom y position } + End; + END; + + PROCEDURE DoTile(P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} + VAR PState: Word; R: TRect; + BEGIN + If Tileable(P) Then Begin + CalcTileRect(TileNum, R); { Calc tileable area } + PState := P^.State; { Hold view state } + P^.State := P^.State AND NOT sfVisible; { Temp not visible } + P^.Locate(R); { Locate view } + P^.State := PState; { Restore view state } + Dec(TileNum); { One less to tile } + End; + END; + +BEGIN + NumTileable := 0; { Zero tileable count } + ForEach(TCallbackProcParam(@DoCountTileable)); { Count tileable views } + If (NumTileable>0) Then Begin + MostEqualDivisors(NumTileable, NumCols, NumRows, + NOT TileColumnsFirst); { Do pre calcs } + If ((R.B.X - R.A.X) DIV NumCols = 0) OR + ((R.B.Y - R.A.Y) DIV NumRows = 0) Then TileError { Can't tile } + Else Begin + LeftOver := NumTileable MOD NumCols; { Left over count } + TileNum := NumTileable-1; { Tileable views } + ForEach(TCallbackProcParam(@DoTile)); { Tile each view } + DrawView; { Now redraw } + End; + End; +END; + +{--TDesktop-----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDesktop.Store (Var S: TStream); +BEGIN + TGroup.Store(S); { Call group store } + PutSubViewPtr(S, Background); { Store background } + S.Write(TileColumnsFirst,SizeOf(TileColumnsFirst));{ Write data } +END; + +{--TDesktop-----------------------------------------------------------------} +{ Cascade -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDeskTop.Cascade (Var R: TRect); +VAR CascadeNum: SmallInt; LastView: PView; Min, Max: TPoint; + + PROCEDURE DoCount (P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} + BEGIN + If Tileable(P) Then Begin + Inc(CascadeNum); LastView := P; { Count cascadable } + End; + END; + + PROCEDURE DoCascade (P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} + VAR PState: Word; NR: TRect; + BEGIN + If Tileable(P) AND (CascadeNum >= 0) Then Begin { View cascadable } + NR.Copy(R); { Copy rect area } + Inc(NR.A.X, CascadeNum); { Inc x position } + Inc(NR.A.Y, CascadeNum); { Inc y position } + PState := P^.State; { Hold view state } + P^.State := P^.State AND NOT sfVisible; { Temp stop draw } + P^.Locate(NR); { Locate the view } + P^.State := PState; { Now allow draws } + Dec(CascadeNum); { Dec count } + End; + END; + +BEGIN + CascadeNum := 0; { Zero cascade count } + ForEach(TCallbackProcParam(@DoCount)); { Count cascadable } + If (CascadeNum>0) Then Begin + LastView^.SizeLimits(Min, Max); { Check size limits } + If (Min.X > R.B.X - R.A.X - CascadeNum) OR + (Min.Y > R.B.Y - R.A.Y - CascadeNum) Then + TileError Else Begin { Check for error } + Dec(CascadeNum); { One less view } + ForEach(TCallbackProcParam(@DoCascade)); { Cascade view } + DrawView; { Redraw now } + End; + End; +END; + +{--TDesktop-----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDesktop.HandleEvent (Var Event: TEvent); +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evCommand) Then Begin + Case Event.Command of { Command event } + cmNext: FocusNext(False); { Focus next view } + cmPrev: If (BackGround <> Nil) Then Begin + If Valid(cmReleasedFocus) Then + Current^.PutInFrontOf(Background); { Focus last view } + End Else FocusNext(True); { Focus prior view } + Else Exit; + End; + ClearEvent(Event); { Clear the event } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TProgram OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + + +{--TProgram-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TProgram.Init; +VAR R: TRect; +BEGIN + R.Assign(0, 0, ScreenWidth, ScreenHeight); { Full screen area } + Inherited Init(R); { Call ancestor } + Application := PApplication(@Self); { Set application ptr } + InitScreen; { Initialize screen } + State := sfVisible + sfSelected + sfFocused + + sfModal + sfExposed; { Deafult states } + Options := 0; { No options set } + Size.X := ScreenWidth; { Set x size value } + Size.Y := ScreenHeight; { Set y size value } + InitStatusLine; { Create status line } + InitMenuBar; { Create a bar menu } + InitDesktop; { Create desktop } + If (Desktop <> Nil) Then Insert(Desktop); { Insert desktop } + If (StatusLine <> Nil) Then Insert(StatusLine); { Insert status line } + If (MenuBar <> Nil) Then Insert(MenuBar); { Insert menu bar } +END; + +{--TProgram-----------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TProgram.Done; +BEGIN + { Do not free the Buffer of Video Unit } +{$ifdef FV_UNICODE} + If Buffer = UViews.PVideoBuf(EnhancedVideoBuf) then + Buffer:=nil; +{$else FV_UNICODE} + If Buffer = Views.PVideoBuf(VideoBuf) then + Buffer:=nil; +{$endif FV_UNICODE} + If (Desktop <> Nil) Then Dispose(Desktop, Done); { Destroy desktop } + If (MenuBar <> Nil) Then Dispose(MenuBar, Done); { Destroy menu bar } + If (StatusLine <> Nil) Then + Dispose(StatusLine, Done); { Destroy status line } + Application := Nil; { Clear application } + Inherited Done; { Call ancestor } +END; + +{--TProgram-----------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TProgram.GetPalette: PPalette; +CONST P: Array[apColor..apMonochrome] Of String = (CAppColor, CAppBlackWhite, + CAppMonochrome); +BEGIN + GetPalette := @P[AppPalette]; { Return palette } +END; + +{--TProgram-----------------------------------------------------------------} +{ CanMoveFocus -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TProgram.CanMoveFocus: Boolean; +BEGIN + If (Desktop <> Nil) Then { Valid desktop view } + CanMovefocus := DeskTop^.Valid(cmReleasedFocus) { Check focus move } + Else CanMoveFocus := True; { No desktop who cares! } +END; + +{--TProgram-----------------------------------------------------------------} +{ ValidView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TProgram.ValidView (P: PView): PView; +BEGIN + ValidView := Nil; { Preset failure } + If (P <> Nil) Then Begin +(* + If LowMemory Then Begin { Check memroy } + Dispose(P, Done); { Dispose view } + OutOfMemory; { Call out of memory } + Exit; { Now exit } + End; +*) + If NOT P^.Valid(cmValid) Then Begin { Check view valid } + Dispose(P, Done); { Dipose view } + Exit; { Now exit } + End; + ValidView := P; { Return view } + End; +END; + +{--TProgram-----------------------------------------------------------------} +{ InsertWindow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TProgram.InsertWindow (P: PWindow): PWindow; +BEGIN + InsertWindow := Nil; { Preset failure } + If (ValidView(P) <> Nil) Then { Check view valid } + If (CanMoveFocus) AND (Desktop <> Nil) { Can we move focus } + Then Begin + Desktop^.Insert(P); { Insert window } + InsertWindow := P; { Return view ptr } + End Else Dispose(P, Done); { Dispose view } +END; + +{--TProgram-----------------------------------------------------------------} +{ ExecuteDialog -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TProgram.ExecuteDialog (P: PDialog; Data: Pointer): Word; +VAR ExecResult: Word; +BEGIN + ExecuteDialog := cmCancel; { Preset cancel } + If (ValidView(P) <> Nil) Then Begin { Check view valid } + If (Data <> Nil) Then P^.SetData(Data^); { Set data } + If (P <> Nil) Then P^.SelectDefaultView; { Select default } + ExecResult := Desktop^.ExecView(P); { Execute view } + If (ExecResult <> cmCancel) AND (Data <> Nil) + Then P^.GetData(Data^); { Get data back } + Dispose(P, Done); { Dispose of dialog } + ExecuteDialog := ExecResult; { Return result } + End; +END; + +{--TProgram-----------------------------------------------------------------} +{ Run -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.Run; +BEGIN + Execute; { Call execute } +END; + +{--TProgram-----------------------------------------------------------------} +{ Idle -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.Idle; +BEGIN + If (StatusLine <> Nil) Then StatusLine^.Update; { Update statusline } + If CommandSetChanged Then Begin { Check command change } + Message(@Self, evBroadcast, cmCommandSetChanged, + Nil); { Send message } + CommandSetChanged := False; { Clear flag } + End; + GiveUpTimeSlice; +END; + +{--TProgram-----------------------------------------------------------------} +{ InitScreen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.InitScreen; + +{Initscreen is passive only, i.e. it detects the video size and capabilities + after initalization. Active video initalization is the task of Tapplication.} + +BEGIN + { the orginal code can't be used here because of the limited + video unit capabilities, the mono modus can't be handled + } +{$ifdef FV_UNICODE} + UDrivers.DetectVideo; +{$else FV_UNICODE} + Drivers.DetectVideo; +{$endif FV_UNICODE} +{ ScreenMode.Row may be 0 if there's no console on startup } + if ScreenMode.Row = 0 then + begin + ShadowSize.X := 2; + AppPalette := apColor; + end + else + begin + if (ScreenMode.Col div ScreenMode.Row<2) then + ShadowSize.X := 1 + else + ShadowSize.X := 2; + if ScreenMode.color then + AppPalette := apColor + else + AppPalette := apBlackWhite; + end; + ShadowSize.Y := 1; + ShowMarkers := False; +{$ifdef FV_UNICODE} + Buffer := UViews.PVideoBuf(EnhancedVideoBuf); +{$else FV_UNICODE} + Buffer := Views.PVideoBuf(VideoBuf); +{$endif FV_UNICODE} +END; + + +{procedure TProgram.DoneScreen; +begin + Drivers.DoneVideo; + Buffer:=nil; +end;} + + +{--TProgram-----------------------------------------------------------------} +{ InitDeskTop -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.InitDesktop; +VAR R: TRect; +BEGIN + GetExtent(R); { Get view extent } + If (MenuBar <> Nil) Then Inc(R.A.Y); { Adjust top down } + If (StatusLine <> Nil) Then Dec(R.B.Y); { Adjust bottom up } + DeskTop := New(PDesktop, Init(R)); { Create desktop } +END; + +{--TProgram-----------------------------------------------------------------} +{ OutOfMemory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.OutOfMemory; +BEGIN { Abstract method } +END; + +{--TProgram-----------------------------------------------------------------} +{ InitMenuBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.InitMenuBar; +VAR R: TRect; +BEGIN + GetExtent(R); { Get view extents } + R.B.Y := R.A.Y + 1; { One line high } + MenuBar := New(PMenuBar, Init(R, Nil)); { Create menu bar } +END; + +{--TProgram-----------------------------------------------------------------} +{ InitStatusLine -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.InitStatusLine; +VAR R: TRect; +BEGIN + GetExtent(R); { Get view extents } + R.A.Y := R.B.Y - 1; { One line high } + New(StatusLine, Init(R, + NewStatusDef(0, $FFFF, + NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit, + StdStatusKeys(Nil)), Nil))); { Default status line } +END; + +{--TProgram-----------------------------------------------------------------} +{ SetScreenMode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.SetScreenMode (Mode: Word); +var + R: TRect; +begin + HideMouse; +{ DoneMemory;} +{ InitMemory;} + InitScreen; +{$ifdef FV_UNICODE} + Buffer := UViews.PVideoBuf(EnhancedVideoBuf); +{$else FV_UNICODE} + Buffer := Views.PVideoBuf(VideoBuf); +{$endif FV_UNICODE} + R.Assign(0, 0, ScreenWidth, ScreenHeight); + ChangeBounds(R); + ShowMouse; +end; + +procedure TProgram.SetScreenVideoMode(const Mode: TVideoMode); +var + R: TRect; +begin + hidemouse; +{ DoneMouse; + DoneMemory;} + ScreenMode:=Mode; +{ InitMouse; + InitMemory;} +{ InitScreen; + Warning: InitScreen calls DetectVideo which + resets ScreenMode to old value, call it after + video mode was changed instead of before } + Video.SetVideoMode(Mode); + + { Update ScreenMode to new value } + InitScreen; + ScreenWidth:=Video.ScreenWidth; + ScreenHeight:=Video.ScreenHeight; +{$ifdef FV_UNICODE} + Buffer := UViews.PVideoBuf(EnhancedVideoBuf); +{$else FV_UNICODE} + Buffer := Views.PVideoBuf(VideoBuf); +{$endif FV_UNICODE} + R.Assign(0, 0, ScreenWidth, ScreenHeight); + ChangeBounds(R); + ShowMouse; +end; + +{--TProgram-----------------------------------------------------------------} +{ PutEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.PutEvent (Var Event: TEvent); +BEGIN + Pending := Event; { Set pending event } +END; + +{--TProgram-----------------------------------------------------------------} +{ GetEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.GetEvent (Var Event: TEvent); +BEGIN + Event.What := evNothing; + If (Event.What = evNothing) Then Begin + If (Pending.What <> evNothing) Then Begin { Pending event } + Event := Pending; { Load pending event } + Pending.What := evNothing; { Clear pending event } + End Else Begin + NextQueuedEvent(Event); { Next queued event } + If (Event.What = evNothing) Then Begin + GetKeyEvent(Event); { Fetch key event } + If (Event.What = evKeyDown) then + Begin + if Event.keyCode = kbAltF12 then + ReDraw; + End; + If (Event.What = evNothing) Then Begin { No mouse event } +{$ifdef FV_UNICODE} + UDrivers.GetMouseEvent(Event); { Load mouse event } +{$else FV_UNICODE} + Drivers.GetMouseEvent(Event); { Load mouse event } +{$endif FV_UNICODE} + If (Event.What = evNothing) Then + begin +{$IFNDEF HASAMIGA} + { due to isses with the event handling in FV itself, + we skip this here, and let the IDE to handle it + directly on Amiga-like systems. The FV itself cannot + handle the System Events anyway. (KB) } +{$ifdef FV_UNICODE} + UDrivers.GetSystemEvent(Event); { Load system event } +{$else FV_UNICODE} + Drivers.GetSystemEvent(Event); { Load system event } +{$endif FV_UNICODE} + If (Event.What = evNothing) Then +{$ENDIF} + Idle; { Idle if no event } + end; + End; + End; + End; + End; +END; + +{--TProgram-----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.HandleEvent (Var Event: TEvent); +VAR C: Char; +BEGIN + If (Event.What = evKeyDown) Then Begin { Key press event } + C := GetAltChar(Event.KeyCode); { Get alt char code } + If (C >= '1') AND (C <= '9') Then + If (Message(Desktop, evBroadCast, cmSelectWindowNum, + Pointer(Byte(C) - $30)) <> Nil) { Select window } + Then ClearEvent(Event); { Clear event } + End; + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evCommand) AND { Command event } + (Event.Command = cmQuit) Then Begin { Quit command } + EndModal(cmQuit); { Endmodal operation } + ClearEvent(Event); { Clear event } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TApplication OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TApplication-------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TApplication.Init; + +BEGIN +{ InitMemory;} { Start memory up } +{ if not(InitResource) then + begin + writeln('Fatal: Can''t init resources'); + halt(1); + end;} + initkeyboard; +{$ifdef FV_UNICODE} + if not UDrivers.InitVideo then { Start video up } +{$else FV_UNICODE} + if not Drivers.InitVideo then { Start video up } +{$endif FV_UNICODE} + begin + donekeyboard; + writeln(sVideoFailed); + halt(1); + end; +{$ifdef FV_UNICODE} + UDrivers.InitEvents; { Start event drive } + UDrivers.InitSysError; { Start system error } +{$else FV_UNICODE} + Drivers.InitEvents; { Start event drive } + Drivers.InitSysError; { Start system error } +{$endif FV_UNICODE} + InitHistory; { Start history up } + Inherited Init; { Call ancestor } + InitMsgBox; + { init mouse and cursor } + Video.SetCursorType(crHidden); + Mouse.SetMouseXY(1,1); +END; + +{--TApplication-------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TApplication.Done; +BEGIN + Inherited Done; { Call ancestor } + DoneHistory; { Close history } +{$ifdef FV_UNICODE} + UDrivers.DoneSysError; { Close system error } + UDrivers.DoneEvents; { Close event drive } + Udrivers.donevideo; +{$else FV_UNICODE} + Drivers.DoneSysError; { Close system error } + Drivers.DoneEvents; { Close event drive } + drivers.donevideo; +{$endif FV_UNICODE} +{ DoneMemory;} { Close memory } + donekeyboard; +{ DoneResource;} +END; + +{--TApplication-------------------------------------------------------------} +{ Tile -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TApplication.Tile; +VAR R: TRect; +BEGIN + GetTileRect(R); { Tileable area } + If (Desktop <> Nil) Then Desktop^.Tile(R); { Tile desktop } +END; + +{--TApplication-------------------------------------------------------------} +{ Cascade -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TApplication.Cascade; +VAR R: TRect; +BEGIN + GetTileRect(R); { Cascade area } + If (Desktop <> Nil) Then Desktop^.Cascade(R); { Cascade desktop } +END; + +{--TApplication-------------------------------------------------------------} +{ DosShell -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TApplication.DosShell; + +{$ifdef unix} +var s:string; +{$endif} + +BEGIN { Compatability only } + DoneSysError; + DoneEvents; +{$ifdef FV_UNICODE} + udrivers.donevideo; + udrivers.donekeyboard; +{$else FV_UNICODE} + drivers.donevideo; + drivers.donekeyboard; +{$endif FV_UNICODE} +{ DoneDosMem;} + WriteShellMsg; +{$ifdef Unix} + s:=getenv('SHELL'); + if s='' then + s:='/bin/sh'; + exec(s,''); +{$else} + SwapVectors; + Exec(GetEnv('COMSPEC'), ''); + SwapVectors; +{$endif} +{ InitDosMem;} +{$ifdef FV_UNICODE} + udrivers.initkeyboard; + udrivers.initvideo; +{$else FV_UNICODE} + drivers.initkeyboard; + drivers.initvideo; +{$endif FV_UNICODE} + Video.SetCursorType(crHidden); + InitScreen; + InitEvents; + InitSysError; + Redraw; +END; + +{--TApplication-------------------------------------------------------------} +{ GetTileRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TApplication.GetTileRect (Var R: TRect); +BEGIN + If (DeskTop <> Nil) Then Desktop^.GetExtent(R) { Desktop extents } + Else GetExtent(R); { Our extents } +END; + +{--TApplication-------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TApplication.HandleEvent (Var Event: TEvent); +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evCommand) Then Begin + Case Event.Command Of + cmTile: Tile; { Tile request } + cmCascade: Cascade; { Cascade request } + cmDosShell: DosShell; { DOS shell request } + Else Exit; { Unhandled exit } + End; + ClearEvent(Event); { Clear the event } + End; +END; + +procedure TApplication.WriteShellMsg; + +begin + writeln(sTypeExitOnReturn); +end; + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STANDARD MENU AND STATUS LINES ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ StdStatusKeys -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION StdStatusKeys (Next: PStatusItem): PStatusItem; +BEGIN + StdStatusKeys := + NewStatusKey('', kbAltX, cmQuit, + NewStatusKey('', kbF10, cmMenu, + NewStatusKey('', kbAltF3, cmClose, + NewStatusKey('', kbF5, cmZoom, + NewStatusKey('', kbCtrlF5, cmResize, + NewStatusKey('', kbF6, cmNext, + NewStatusKey('', kbShiftF6, cmPrev, + Next))))))); +END; + +{---------------------------------------------------------------------------} +{ StdFileMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION StdFileMenuItems (Next: PMenuItem): PMenuItem; +BEGIN + StdFileMenuItems := + NewItem('~N~ew', '', kbNoKey, cmNew, hcNew, + NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcOpen, + NewItem('~S~ave', 'F2', kbF2, cmSave, hcSave, + NewItem('S~a~ve as...', '', kbNoKey, cmSaveAs, hcSaveAs, + NewItem('Save a~l~l', '', kbNoKey, cmSaveAll, hcSaveAll, + NewLine( + NewItem('~C~hange dir...', '', kbNoKey, cmChangeDir, hcChangeDir, + NewItem('OS shell', '', kbNoKey, cmDosShell, hcDosShell, + NewItem('E~x~it', 'Alt+X', kbAltX, cmQuit, hcExit, + Next))))))))); +END; + +{---------------------------------------------------------------------------} +{ StdEditMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION StdEditMenuItems (Next: PMenuItem): PMenuItem; +BEGIN + StdEditMenuItems := + NewItem('~U~ndo', '', kbAltBack, cmUndo, hcUndo, + NewLine( + NewItem('Cu~t~', 'Shift+Del', kbShiftDel, cmCut, hcCut, + NewItem('~C~opy', 'Ctrl+Ins', kbCtrlIns, cmCopy, hcCopy, + NewItem('~P~aste', 'Shift+Ins', kbShiftIns, cmPaste, hcPaste, + NewItem('C~l~ear', 'Ctrl+Del', kbCtrlDel, cmClear, hcClear, + Next)))))); +END; + +{---------------------------------------------------------------------------} +{ StdWindowMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION StdWindowMenuItems (Next: PMenuItem): PMenuItem; +BEGIN + StdWindowMenuItems := + NewItem('~T~ile', '', kbNoKey, cmTile, hcTile, + NewItem('C~a~scade', '', kbNoKey, cmCascade, hcCascade, + NewItem('Cl~o~se all', '', kbNoKey, cmCloseAll, hcCloseAll, + NewLine( + NewItem('~S~ize/Move','Ctrl+F5', kbCtrlF5, cmResize, hcResize, + NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcZoom, + NewItem('~N~ext', 'F6', kbF6, cmNext, hcNext, + NewItem('~P~revious', 'Shift+F6', kbShiftF6, cmPrev, hcPrev, + NewItem('~C~lose', 'Alt+F3', kbAltF3, cmClose, hcClose, + Next))))))))); +END; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ RegisterApp -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterApp; +BEGIN + RegisterType(RBackground); { Register background } + RegisterType(RDesktop); { Register desktop } +END; + +END. diff --git a/packages/fv/src/app.pas b/packages/fv/src/app.pas index d6c63400a2..526fd5302f 100644 --- a/packages/fv/src/app.pas +++ b/packages/fv/src/app.pas @@ -1,1221 +1 @@ -{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} -{ } -{ System independent GRAPHICAL clone of APP.PAS } -{ } -{ Interface Copyright (c) 1992 Borland International } -{ } -{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } -{ ldeboer@attglobal.net - primary e-mail addr } -{ ldeboer@starwon.com.au - backup e-mail addr } -{ } -{****************[ THIS CODE IS FREEWARE ]*****************} -{ } -{ This sourcecode is released for the purpose to } -{ promote the pascal language on all platforms. You may } -{ redistribute it and/or modify with the following } -{ DISCLAIMER. } -{ } -{ This SOURCE CODE is distributed "AS IS" WITHOUT } -{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } -{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } -{ } -{*****************[ SUPPORTED PLATFORMS ]******************} -{ } -{ Only Free Pascal Compiler supported } -{ } -{**********************************************************} - -UNIT App; - -{2.0 compatibility} -{$ifdef VER2_0} - {$macro on} - {$define resourcestring := const} -{$endif} - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - INTERFACE -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{====Include file to sort compiler platform out =====================} -{$I platform.inc} -{====================================================================} - -{==== Compiler directives ===========================================} - -{$X+} { Extended syntax is ok } -{$R-} { Disable range checking } -{$S-} { Disable Stack Checking } -{$I-} { Disable IO Checking } -{$Q-} { Disable Overflow Checking } -{$V-} { Turn off strict VAR strings } -{====================================================================} - -USES - {$IFDEF OS_WINDOWS} { WIN/NT CODE } - Windows, { Standard units } - {$ENDIF} - - {$IFDEF OS_OS2} { OS2 CODE } - {$IFDEF PPC_FPC} - Os2Def, DosCalls, PmWin, { Standard units } - {$ELSE} - Os2Def, Os2Base, OS2PmApi, { Standard units } - {$ENDIF} - {$ENDIF} - Dos, - Video, - FVCommon, {Memory,} { GFV standard units } - Objects, Drivers, Views, Menus, HistList, Dialogs, - msgbox, fvconsts; - -{***************************************************************************} -{ PUBLIC CONSTANTS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ STANDARD APPLICATION COMMAND CONSTANTS } -{---------------------------------------------------------------------------} -CONST - cmNew = 30; { Open new file } - cmOpen = 31; { Open a file } - cmSave = 32; { Save current } - cmSaveAs = 33; { Save current as } - cmSaveAll = 34; { Save all files } - cmChangeDir = 35; { Change directories } - cmDosShell = 36; { Dos shell } - cmCloseAll = 37; { Close all windows } - -{---------------------------------------------------------------------------} -{ TApplication PALETTE ENTRIES } -{---------------------------------------------------------------------------} -CONST - apColor = 0; { Coloured app } - apBlackWhite = 1; { B&W application } - apMonochrome = 2; { Monochrome app } - -{---------------------------------------------------------------------------} -{ TBackGround PALETTES } -{---------------------------------------------------------------------------} -CONST - CBackground = #1; { Background colour } - -{---------------------------------------------------------------------------} -{ TApplication PALETTES } -{---------------------------------------------------------------------------} -CONST - { Turbo Vision 1.0 Color Palettes } - - CColor = - #$81#$70#$78#$74#$20#$28#$24#$17#$1F#$1A#$31#$31#$1E#$71#$1F + - #$37#$3F#$3A#$13#$13#$3E#$21#$3F#$70#$7F#$7A#$13#$13#$70#$7F#$7E + - #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 + - #$3F#$3E#$1F#$2F#$1A#$20#$72#$31#$31#$30#$2F#$3E#$31#$13#$38#$00; - - CBlackWhite = - #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$0F + - #$07#$0F#$07#$70#$70#$07#$70#$0F#$70#$7F#$7F#$70#$07#$70#$07#$0F + - #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 + - #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00; - - CMonochrome = - #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 + - #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 + - #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + - #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00; - - { Turbo Vision 2.0 Color Palettes } - - CAppColor = - #$71#$70#$78#$74#$20#$28#$24#$17#$1F#$1A#$31#$31#$1E#$71#$1F + - #$37#$3F#$3A#$13#$13#$3E#$21#$3F#$70#$7F#$7A#$13#$13#$70#$7F#$7E + - #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 + - #$3F#$3E#$1F#$2F#$1A#$20#$72#$31#$31#$30#$2F#$3E#$31#$13#$38#$00 + - #$17#$1F#$1A#$71#$71#$1E#$17#$1F#$1E#$20#$2B#$2F#$78#$2E#$10#$30 + - #$3F#$3E#$70#$2F#$7A#$20#$12#$31#$31#$30#$2F#$3E#$31#$13#$38#$00 + - #$37#$3F#$3A#$13#$13#$3E#$30#$3F#$3E#$20#$2B#$2F#$78#$2E#$30#$70 + - #$7F#$7E#$1F#$2F#$1A#$20#$32#$31#$71#$70#$2F#$7E#$71#$13#$38#$00; - - CAppBlackWhite = - #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$0F + - #$07#$0F#$07#$70#$70#$07#$70#$0F#$70#$7F#$7F#$70#$07#$70#$07#$0F + - #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 + - #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00 + - #$07#$0F#$0F#$07#$70#$07#$07#$0F#$0F#$70#$78#$7F#$08#$7F#$08#$70 + - #$7F#$7F#$7F#$0F#$70#$70#$07#$70#$70#$70#$07#$7F#$70#$07#$78#$00 + - #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 + - #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00; - - CAppMonochrome = - #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 + - #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 + - #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + - #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00 + - #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + - #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00 + - #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + - #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00; - -{---------------------------------------------------------------------------} -{ STANDRARD HELP CONTEXT CONSTANTS } -{---------------------------------------------------------------------------} -CONST -{ Note: range $FF00 - $FFFF of help contexts are reserved by Borland } - hcNew = $FF01; { New file help } - hcOpen = $FF02; { Open file help } - hcSave = $FF03; { Save file help } - hcSaveAs = $FF04; { Save file as help } - hcSaveAll = $FF05; { Save all files help } - hcChangeDir = $FF06; { Change dir help } - hcDosShell = $FF07; { Dos shell help } - hcExit = $FF08; { Exit program help } - - hcUndo = $FF10; { Clipboard undo help } - hcCut = $FF11; { Clipboard cut help } - hcCopy = $FF12; { Clipboard copy help } - hcPaste = $FF13; { Clipboard paste help } - hcClear = $FF14; { Clipboard clear help } - - hcTile = $FF20; { Desktop tile help } - hcCascade = $FF21; { Desktop cascade help } - hcCloseAll = $FF22; { Desktop close all } - hcResize = $FF23; { Window resize help } - hcZoom = $FF24; { Window zoom help } - hcNext = $FF25; { Window next help } - hcPrev = $FF26; { Window previous help } - hcClose = $FF27; { Window close help } - -{***************************************************************************} -{ PUBLIC OBJECT DEFINITIONS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TBackGround OBJECT - BACKGROUND OBJECT } -{---------------------------------------------------------------------------} -TYPE - TBackGround = OBJECT (TView) - Pattern: Char; { Background pattern } - CONSTRUCTOR Init (Var Bounds: TRect; APattern: Char); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION GetPalette: PPalette; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE Store (Var S: TStream); - END; - PBackGround = ^TBackGround; - -{---------------------------------------------------------------------------} -{ TDeskTop OBJECT - DESKTOP OBJECT } -{---------------------------------------------------------------------------} -TYPE - TDeskTop = OBJECT (TGroup) - Background : PBackground; { Background view } - TileColumnsFirst: Boolean; { Tile direction } - CONSTRUCTOR Init (Var Bounds: TRect); - CONSTRUCTOR Load (Var S: TStream); - PROCEDURE TileError; Virtual; - PROCEDURE InitBackGround; Virtual; - PROCEDURE Tile (Var R: TRect); - PROCEDURE Store (Var S: TStream); - PROCEDURE Cascade (Var R: TRect); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - END; - PDeskTop = ^TDeskTop; - -{---------------------------------------------------------------------------} -{ TProgram OBJECT - PROGRAM ANCESTOR OBJECT } -{---------------------------------------------------------------------------} -TYPE - TProgram = OBJECT (TGroup) - CONSTRUCTOR Init; - DESTRUCTOR Done; Virtual; - FUNCTION GetPalette: PPalette; Virtual; - FUNCTION CanMoveFocus: Boolean; - FUNCTION ValidView (P: PView): PView; - FUNCTION InsertWindow (P: PWindow): PWindow; - FUNCTION ExecuteDialog (P: PDialog; Data: Pointer): Word; - PROCEDURE Run; Virtual; - PROCEDURE Idle; Virtual; - PROCEDURE InitScreen; Virtual; -{ procedure DoneScreen; virtual;} - PROCEDURE InitDeskTop; Virtual; - PROCEDURE OutOfMemory; Virtual; - PROCEDURE InitMenuBar; Virtual; - PROCEDURE InitStatusLine; Virtual; - PROCEDURE SetScreenMode (Mode: Word); - PROCEDURE SetScreenVideoMode(const Mode: TVideoMode); - PROCEDURE PutEvent (Var Event: TEvent); Virtual; - PROCEDURE GetEvent (Var Event: TEvent); Virtual; - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - END; - PProgram = ^TProgram; - -{---------------------------------------------------------------------------} -{ TApplication OBJECT - APPLICATION OBJECT } -{---------------------------------------------------------------------------} -TYPE - TApplication = OBJECT (TProgram) - CONSTRUCTOR Init; - DESTRUCTOR Done; Virtual; - PROCEDURE Tile; - PROCEDURE Cascade; - PROCEDURE DosShell; - PROCEDURE GetTileRect (Var R: TRect); Virtual; - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - procedure WriteShellMsg; virtual; - END; - PApplication = ^TApplication; { Application ptr } - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ STANDARD MENU AND STATUS LINES ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-StdStatusKeys------------------------------------------------------ -Returns a pointer to a linked list of commonly used status line keys. -The default status line for TApplication uses StdStatusKeys as its -complete list of status keys. -22Oct99 LdB ----------------------------------------------------------------------} -FUNCTION StdStatusKeys (Next: PStatusItem): PStatusItem; - -{-StdFileMenuItems--------------------------------------------------- -Returns a pointer to a list of menu items for a standard File menu. -The standard File menu items are New, Open, Save, Save As, Save All, -Change Dir, OS Shell, and Exit. -22Oct99 LdB ----------------------------------------------------------------------} -FUNCTION StdFileMenuItems (Next: PMenuItem): PMenuItem; - -{-StdEditMenuItems--------------------------------------------------- -Returns a pointer to a list of menu items for a standard Edit menu. -The standard Edit menu items are Undo, Cut, Copy, Paste, and Clear. -22Oct99 LdB ----------------------------------------------------------------------} -FUNCTION StdEditMenuItems (Next: PMenuItem): PMenuItem; - -{-StdWindowMenuItems------------------------------------------------- -Returns a pointer to a list of menu items for a standard Window menu. -The standard Window menu items are Tile, Cascade, Close All, -Size/Move, Zoom, Next, Previous, and Close. -22Oct99 LdB ----------------------------------------------------------------------} -FUNCTION StdWindowMenuItems (Next: PMenuItem): PMenuItem; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ OBJECT REGISTER ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{-RegisterApp-------------------------------------------------------- -Calls RegisterType for each of the object types defined in this unit. -22oct99 LdB ----------------------------------------------------------------------} -PROCEDURE RegisterApp; - -{***************************************************************************} -{ OBJECT REGISTRATION } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TBackGround STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RBackGround: TStreamRec = ( - ObjType: idBackground; { Register id = 30 } - VmtLink: TypeOf(TBackGround); - Load: @TBackGround.Load; { Object load method } - Store: @TBackGround.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TDeskTop STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RDeskTop: TStreamRec = ( - ObjType: idDesktop; { Register id = 31 } - VmtLink: TypeOf(TDeskTop); - Load: @TDeskTop.Load; { Object load method } - Store: @TDeskTop.Store { Object store method } - ); - -{***************************************************************************} -{ INITIALIZED PUBLIC VARIABLES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ INITIALIZED PUBLIC VARIABLES } -{---------------------------------------------------------------------------} -CONST - AppPalette: Integer = apColor; { Application colour } - Desktop: PDeskTop = Nil; { Desktop object } - MenuBar: PMenuView = Nil; { Application menu } - StatusLine: PStatusLine = Nil; { App status line } - Application : PApplication = Nil; { Application object } - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IMPLEMENTATION -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -uses Mouse{,Resource}; - -resourcestring sVideoFailed='Video initialization failed.'; - sTypeExitOnReturn='Type EXIT to return...'; - - -{***************************************************************************} -{ PRIVATE DEFINED CONSTANTS } -{***************************************************************************} - -{***************************************************************************} -{ PRIVATE INITIALIZED VARIABLES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ INITIALIZED PRIVATE VARIABLES } -{---------------------------------------------------------------------------} -CONST Pending: TEvent = (What: evNothing); { Pending event } - -{---------------------------------------------------------------------------} -{ Tileable -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION Tileable (P: PView): Boolean; -BEGIN - Tileable := (P^.Options AND ofTileable <> 0) AND { View is tileable } - (P^.State AND sfVisible <> 0); { View is visible } -END; - -{---------------------------------------------------------------------------} -{ ISqr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION ISqr (X: Sw_Integer): Sw_Integer; -VAR I: Sw_Integer; -BEGIN - I := 0; { Set value to zero } - Repeat - Inc(I); { Inc value } - Until (I * I > X); { Repeat till Sqr > X } - ISqr := I - 1; { Return result } -END; - -{---------------------------------------------------------------------------} -{ MostEqualDivisors -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE MostEqualDivisors (N: Integer; Var X, Y: Integer; FavorY: Boolean); -VAR I: Integer; -BEGIN - I := ISqr(N); { Int square of N } - If ((N MOD I) <> 0) Then { Initial guess } - If ((N MOD (I+1)) = 0) Then Inc(I); { Add one row/column } - If (I < (N DIV I)) Then I := N DIV I; { In first page } - If FavorY Then Begin { Horz preferred } - X := N DIV I; { Calc x position } - Y := I; { Set y position } - End Else Begin { Vert preferred } - Y := N DIV I; { Calc y position } - X := I; { Set x position } - End; -END; - -{***************************************************************************} -{ OBJECT METHODS } -{***************************************************************************} - -{--TBackGround--------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TBackGround.Init (Var Bounds: TRect; APattern: Char); -BEGIN - Inherited Init(Bounds); { Call ancestor } - GrowMode := gfGrowHiX + gfGrowHiY; { Set grow modes } - Pattern := APattern; { Hold pattern } -END; - -{--TBackGround--------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TBackGround.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - S.Read(Pattern, SizeOf(Pattern)); { Read pattern data } -END; - -{--TBackGround--------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TBackGround.GetPalette: PPalette; -CONST P: String[Length(CBackGround)] = CbackGround; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Return palette } -END; - -{--TBackGround--------------------------------------------------------------} -{ DrawBackground -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TBackground.Draw; -VAR B: TDrawBuffer; -BEGIN - MoveChar(B, Pattern, GetColor($01), Size.X); { Fill draw buffer } - WriteLine(0, 0, Size.X, Size.Y, B); { Draw to area } -END; - -{--TBackGround--------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TBackGround.Store (Var S: TStream); -BEGIN - TView.Store(S); { TView store called } - S.Write(Pattern, SizeOf(Pattern)); { Write pattern data } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TDesktop OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TDesktop-----------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TDesktop.Init (Var Bounds: Objects.TRect); -BEGIN - Inherited Init(Bounds); { Call ancestor } - GrowMode := gfGrowHiX + gfGrowHiY; { Set growmode } - InitBackground; { Create background } - If (Background <> Nil) Then Insert(Background); { Insert background } -END; - -{--TDesktop-----------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TDesktop.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - GetSubViewPtr(S, Background); { Load background } - S.Read(TileColumnsFirst, SizeOf(TileColumnsFirst));{ Read data } -END; - -{--TDesktop-----------------------------------------------------------------} -{ TileError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TDeskTop.TileError; -BEGIN { Abstract method } -END; - -{--TDesktop-----------------------------------------------------------------} -{ InitBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TDesktop.InitBackground; -CONST Ch: Char = #176; -VAR R: TRect; -BEGIN - GetExtent(R); { Get desktop extents } - BackGround := New(PBackground, Init(R, Ch)); { Insert a background } -END; - -{--TDesktop-----------------------------------------------------------------} -{ Tile -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TDeskTop.Tile (Var R: TRect); -VAR NumCols, NumRows, NumTileable, LeftOver, TileNum: Integer; - - FUNCTION DividerLoc (Lo, Hi, Num, Pos: Integer): Integer; - BEGIN - DividerLoc := LongInt( LongInt(Hi - Lo) * Pos) - DIV Num + Lo; { Calc position } - END; - - PROCEDURE DoCountTileable (P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} - BEGIN - If Tileable(P) Then Inc(NumTileable); { Count tileable views } - END; - - PROCEDURE CalcTileRect (Pos: Integer; Var NR: TRect); - VAR X, Y, D: Integer; - BEGIN - D := (NumCols - LeftOver) * NumRows; { Calc d value } - If (Pos<D) Then Begin - X := Pos DIV NumRows; Y := Pos MOD NumRows; { Calc positions } - End Else Begin - X := (Pos - D) div (NumRows + 1) + - (NumCols - LeftOver); { Calc x position } - Y := (Pos - D) mod (NumRows + 1); { Calc y position } - End; - NR.A.X := DividerLoc(R.A.X, R.B.X, NumCols, X); { Top left x position } - NR.B.X := DividerLoc(R.A.X, R.B.X, NumCols, X+1);{ Right x position } - If (Pos >= D) Then Begin - NR.A.Y := DividerLoc(R.A.Y, R.B.Y,NumRows+1,Y);{ Top y position } - NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows+1, - Y+1); { Bottom y position } - End Else Begin - NR.A.Y := DividerLoc(R.A.Y, R.B.Y,NumRows,Y); { Top y position } - NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows, - Y+1); { Bottom y position } - End; - END; - - PROCEDURE DoTile(P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} - VAR PState: Word; R: TRect; - BEGIN - If Tileable(P) Then Begin - CalcTileRect(TileNum, R); { Calc tileable area } - PState := P^.State; { Hold view state } - P^.State := P^.State AND NOT sfVisible; { Temp not visible } - P^.Locate(R); { Locate view } - P^.State := PState; { Restore view state } - Dec(TileNum); { One less to tile } - End; - END; - -BEGIN - NumTileable := 0; { Zero tileable count } - ForEach(TCallbackProcParam(@DoCountTileable)); { Count tileable views } - If (NumTileable>0) Then Begin - MostEqualDivisors(NumTileable, NumCols, NumRows, - NOT TileColumnsFirst); { Do pre calcs } - If ((R.B.X - R.A.X) DIV NumCols = 0) OR - ((R.B.Y - R.A.Y) DIV NumRows = 0) Then TileError { Can't tile } - Else Begin - LeftOver := NumTileable MOD NumCols; { Left over count } - TileNum := NumTileable-1; { Tileable views } - ForEach(TCallbackProcParam(@DoTile)); { Tile each view } - DrawView; { Now redraw } - End; - End; -END; - -{--TDesktop-----------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TDesktop.Store (Var S: TStream); -BEGIN - TGroup.Store(S); { Call group store } - PutSubViewPtr(S, Background); { Store background } - S.Write(TileColumnsFirst,SizeOf(TileColumnsFirst));{ Write data } -END; - -{--TDesktop-----------------------------------------------------------------} -{ Cascade -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TDeskTop.Cascade (Var R: TRect); -VAR CascadeNum: Integer; LastView: PView; Min, Max: TPoint; - - PROCEDURE DoCount (P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} - BEGIN - If Tileable(P) Then Begin - Inc(CascadeNum); LastView := P; { Count cascadable } - End; - END; - - PROCEDURE DoCascade (P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} - VAR PState: Word; NR: TRect; - BEGIN - If Tileable(P) AND (CascadeNum >= 0) Then Begin { View cascadable } - NR.Copy(R); { Copy rect area } - Inc(NR.A.X, CascadeNum); { Inc x position } - Inc(NR.A.Y, CascadeNum); { Inc y position } - PState := P^.State; { Hold view state } - P^.State := P^.State AND NOT sfVisible; { Temp stop draw } - P^.Locate(NR); { Locate the view } - P^.State := PState; { Now allow draws } - Dec(CascadeNum); { Dec count } - End; - END; - -BEGIN - CascadeNum := 0; { Zero cascade count } - ForEach(TCallbackProcParam(@DoCount)); { Count cascadable } - If (CascadeNum>0) Then Begin - LastView^.SizeLimits(Min, Max); { Check size limits } - If (Min.X > R.B.X - R.A.X - CascadeNum) OR - (Min.Y > R.B.Y - R.A.Y - CascadeNum) Then - TileError Else Begin { Check for error } - Dec(CascadeNum); { One less view } - ForEach(TCallbackProcParam(@DoCascade)); { Cascade view } - DrawView; { Redraw now } - End; - End; -END; - -{--TDesktop-----------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TDesktop.HandleEvent (Var Event: TEvent); -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - If (Event.What = evCommand) Then Begin - Case Event.Command of { Command event } - cmNext: FocusNext(False); { Focus next view } - cmPrev: If (BackGround <> Nil) Then Begin - If Valid(cmReleasedFocus) Then - Current^.PutInFrontOf(Background); { Focus last view } - End Else FocusNext(True); { Focus prior view } - Else Exit; - End; - ClearEvent(Event); { Clear the event } - End; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TProgram OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - - -{--TProgram-----------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TProgram.Init; -VAR R: TRect; -BEGIN - R.Assign(0, 0, ScreenWidth, ScreenHeight); { Full screen area } - Inherited Init(R); { Call ancestor } - Application := PApplication(@Self); { Set application ptr } - InitScreen; { Initialize screen } - State := sfVisible + sfSelected + sfFocused + - sfModal + sfExposed; { Deafult states } - Options := 0; { No options set } - Size.X := ScreenWidth; { Set x size value } - Size.Y := ScreenHeight; { Set y size value } - InitStatusLine; { Create status line } - InitMenuBar; { Create a bar menu } - InitDesktop; { Create desktop } - If (Desktop <> Nil) Then Insert(Desktop); { Insert desktop } - If (StatusLine <> Nil) Then Insert(StatusLine); { Insert status line } - If (MenuBar <> Nil) Then Insert(MenuBar); { Insert menu bar } -END; - -{--TProgram-----------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TProgram.Done; -BEGIN - { Do not free the Buffer of Video Unit } - If Buffer = Views.PVideoBuf(VideoBuf) then - Buffer:=nil; - If (Desktop <> Nil) Then Dispose(Desktop, Done); { Destroy desktop } - If (MenuBar <> Nil) Then Dispose(MenuBar, Done); { Destroy menu bar } - If (StatusLine <> Nil) Then - Dispose(StatusLine, Done); { Destroy status line } - Application := Nil; { Clear application } - Inherited Done; { Call ancestor } -END; - -{--TProgram-----------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TProgram.GetPalette: PPalette; -CONST P: Array[apColor..apMonochrome] Of String = (CAppColor, CAppBlackWhite, - CAppMonochrome); -BEGIN - GetPalette := @P[AppPalette]; { Return palette } -END; - -{--TProgram-----------------------------------------------------------------} -{ CanMoveFocus -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TProgram.CanMoveFocus: Boolean; -BEGIN - If (Desktop <> Nil) Then { Valid desktop view } - CanMovefocus := DeskTop^.Valid(cmReleasedFocus) { Check focus move } - Else CanMoveFocus := True; { No desktop who cares! } -END; - -{--TProgram-----------------------------------------------------------------} -{ ValidView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TProgram.ValidView (P: PView): PView; -BEGIN - ValidView := Nil; { Preset failure } - If (P <> Nil) Then Begin -(* - If LowMemory Then Begin { Check memroy } - Dispose(P, Done); { Dispose view } - OutOfMemory; { Call out of memory } - Exit; { Now exit } - End; -*) - If NOT P^.Valid(cmValid) Then Begin { Check view valid } - Dispose(P, Done); { Dipose view } - Exit; { Now exit } - End; - ValidView := P; { Return view } - End; -END; - -{--TProgram-----------------------------------------------------------------} -{ InsertWindow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TProgram.InsertWindow (P: PWindow): PWindow; -BEGIN - InsertWindow := Nil; { Preset failure } - If (ValidView(P) <> Nil) Then { Check view valid } - If (CanMoveFocus) AND (Desktop <> Nil) { Can we move focus } - Then Begin - Desktop^.Insert(P); { Insert window } - InsertWindow := P; { Return view ptr } - End Else Dispose(P, Done); { Dispose view } -END; - -{--TProgram-----------------------------------------------------------------} -{ ExecuteDialog -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TProgram.ExecuteDialog (P: PDialog; Data: Pointer): Word; -VAR ExecResult: Word; -BEGIN - ExecuteDialog := cmCancel; { Preset cancel } - If (ValidView(P) <> Nil) Then Begin { Check view valid } - If (Data <> Nil) Then P^.SetData(Data^); { Set data } - If (P <> Nil) Then P^.SelectDefaultView; { Select default } - ExecResult := Desktop^.ExecView(P); { Execute view } - If (ExecResult <> cmCancel) AND (Data <> Nil) - Then P^.GetData(Data^); { Get data back } - Dispose(P, Done); { Dispose of dialog } - ExecuteDialog := ExecResult; { Return result } - End; -END; - -{--TProgram-----------------------------------------------------------------} -{ Run -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.Run; -BEGIN - Execute; { Call execute } -END; - -{--TProgram-----------------------------------------------------------------} -{ Idle -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.Idle; -BEGIN - If (StatusLine <> Nil) Then StatusLine^.Update; { Update statusline } - If CommandSetChanged Then Begin { Check command change } - Message(@Self, evBroadcast, cmCommandSetChanged, - Nil); { Send message } - CommandSetChanged := False; { Clear flag } - End; - GiveUpTimeSlice; -END; - -{--TProgram-----------------------------------------------------------------} -{ InitScreen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.InitScreen; - -{Initscreen is passive only, i.e. it detects the video size and capabilities - after initalization. Active video initalization is the task of Tapplication.} - -BEGIN - { the orginal code can't be used here because of the limited - video unit capabilities, the mono modus can't be handled - } - Drivers.DetectVideo; -{ ScreenMode.Row may be 0 if there's no console on startup } - if ScreenMode.Row = 0 then - begin - ShadowSize.X := 2; - AppPalette := apColor; - end - else - begin - if (ScreenMode.Col div ScreenMode.Row<2) then - ShadowSize.X := 1 - else - ShadowSize.X := 2; - if ScreenMode.color then - AppPalette := apColor - else - AppPalette := apBlackWhite; - end; - ShadowSize.Y := 1; - ShowMarkers := False; - Buffer := Views.PVideoBuf(VideoBuf); -END; - - -{procedure TProgram.DoneScreen; -begin - Drivers.DoneVideo; - Buffer:=nil; -end;} - - -{--TProgram-----------------------------------------------------------------} -{ InitDeskTop -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.InitDesktop; -VAR R: TRect; -BEGIN - GetExtent(R); { Get view extent } - If (MenuBar <> Nil) Then Inc(R.A.Y); { Adjust top down } - If (StatusLine <> Nil) Then Dec(R.B.Y); { Adjust bottom up } - DeskTop := New(PDesktop, Init(R)); { Create desktop } -END; - -{--TProgram-----------------------------------------------------------------} -{ OutOfMemory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.OutOfMemory; -BEGIN { Abstract method } -END; - -{--TProgram-----------------------------------------------------------------} -{ InitMenuBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.InitMenuBar; -VAR R: TRect; -BEGIN - GetExtent(R); { Get view extents } - R.B.Y := R.A.Y + 1; { One line high } - MenuBar := New(PMenuBar, Init(R, Nil)); { Create menu bar } -END; - -{--TProgram-----------------------------------------------------------------} -{ InitStatusLine -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.InitStatusLine; -VAR R: TRect; -BEGIN - GetExtent(R); { Get view extents } - R.A.Y := R.B.Y - 1; { One line high } - New(StatusLine, Init(R, - NewStatusDef(0, $FFFF, - NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit, - StdStatusKeys(Nil)), Nil))); { Default status line } -END; - -{--TProgram-----------------------------------------------------------------} -{ SetScreenMode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.SetScreenMode (Mode: Word); -var - R: TRect; -begin - HideMouse; -{ DoneMemory;} -{ InitMemory;} - InitScreen; - Buffer := Views.PVideoBuf(VideoBuf); - R.Assign(0, 0, ScreenWidth, ScreenHeight); - ChangeBounds(R); - ShowMouse; -end; - -procedure TProgram.SetScreenVideoMode(const Mode: TVideoMode); -var - R: TRect; -begin - hidemouse; -{ DoneMouse; - DoneMemory;} - ScreenMode:=Mode; -{ InitMouse; - InitMemory;} -{ InitScreen; - Warning: InitScreen calls DetectVideo which - resets ScreenMode to old value, call it after - video mode was changed instead of before } - Video.SetVideoMode(Mode); - - { Update ScreenMode to new value } - InitScreen; - ScreenWidth:=Video.ScreenWidth; - ScreenHeight:=Video.ScreenHeight; - Buffer := Views.PVideoBuf(VideoBuf); - R.Assign(0, 0, ScreenWidth, ScreenHeight); - ChangeBounds(R); - ShowMouse; -end; - -{--TProgram-----------------------------------------------------------------} -{ PutEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.PutEvent (Var Event: TEvent); -BEGIN - Pending := Event; { Set pending event } -END; - -{--TProgram-----------------------------------------------------------------} -{ GetEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.GetEvent (Var Event: TEvent); -BEGIN - Event.What := evNothing; - If (Event.What = evNothing) Then Begin - If (Pending.What <> evNothing) Then Begin { Pending event } - Event := Pending; { Load pending event } - Pending.What := evNothing; { Clear pending event } - End Else Begin - NextQueuedEvent(Event); { Next queued event } - If (Event.What = evNothing) Then Begin - GetKeyEvent(Event); { Fetch key event } - If (Event.What = evKeyDown) then - Begin - if Event.keyCode = kbAltF12 then - ReDraw; - End; - If (Event.What = evNothing) Then Begin { No mouse event } - Drivers.GetMouseEvent(Event); { Load mouse event } - If (Event.What = evNothing) Then - begin -{$IFNDEF HASAMIGA} - { due to isses with the event handling in FV itself, - we skip this here, and let the IDE to handle it - directly on Amiga-like systems. The FV itself cannot - handle the System Events anyway. (KB) } - Drivers.GetSystemEvent(Event); { Load system event } - If (Event.What = evNothing) Then -{$ENDIF} - Idle; { Idle if no event } - end; - End; - End; - End; - End; -END; - -{--TProgram-----------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TProgram.HandleEvent (Var Event: TEvent); -VAR C: Char; -BEGIN - If (Event.What = evKeyDown) Then Begin { Key press event } - C := GetAltChar(Event.KeyCode); { Get alt char code } - If (C >= '1') AND (C <= '9') Then - If (Message(Desktop, evBroadCast, cmSelectWindowNum, - Pointer(Byte(C) - $30)) <> Nil) { Select window } - Then ClearEvent(Event); { Clear event } - End; - Inherited HandleEvent(Event); { Call ancestor } - If (Event.What = evCommand) AND { Command event } - (Event.Command = cmQuit) Then Begin { Quit command } - EndModal(cmQuit); { Endmodal operation } - ClearEvent(Event); { Clear event } - End; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TApplication OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TApplication-------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TApplication.Init; - -BEGIN -{ InitMemory;} { Start memory up } -{ if not(InitResource) then - begin - writeln('Fatal: Can''t init resources'); - halt(1); - end;} - initkeyboard; - if not Drivers.InitVideo then { Start video up } - begin - donekeyboard; - writeln(sVideoFailed); - halt(1); - end; - Drivers.InitEvents; { Start event drive } - Drivers.InitSysError; { Start system error } - InitHistory; { Start history up } - Inherited Init; { Call ancestor } - InitMsgBox; - { init mouse and cursor } - Video.SetCursorType(crHidden); - Mouse.SetMouseXY(1,1); -END; - -{--TApplication-------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TApplication.Done; -BEGIN - Inherited Done; { Call ancestor } - DoneHistory; { Close history } - Drivers.DoneSysError; { Close system error } - Drivers.DoneEvents; { Close event drive } - drivers.donevideo; -{ DoneMemory;} { Close memory } - donekeyboard; -{ DoneResource;} -END; - -{--TApplication-------------------------------------------------------------} -{ Tile -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TApplication.Tile; -VAR R: TRect; -BEGIN - GetTileRect(R); { Tileable area } - If (Desktop <> Nil) Then Desktop^.Tile(R); { Tile desktop } -END; - -{--TApplication-------------------------------------------------------------} -{ Cascade -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TApplication.Cascade; -VAR R: TRect; -BEGIN - GetTileRect(R); { Cascade area } - If (Desktop <> Nil) Then Desktop^.Cascade(R); { Cascade desktop } -END; - -{--TApplication-------------------------------------------------------------} -{ DosShell -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TApplication.DosShell; - -{$ifdef unix} -var s:string; -{$endif} - -BEGIN { Compatability only } - DoneSysError; - DoneEvents; - drivers.donevideo; - drivers.donekeyboard; -{ DoneDosMem;} - WriteShellMsg; -{$ifdef Unix} - s:=getenv('SHELL'); - if s='' then - s:='/bin/sh'; - exec(s,''); -{$else} - SwapVectors; - Exec(GetEnv('COMSPEC'), ''); - SwapVectors; -{$endif} -{ InitDosMem;} - drivers.initkeyboard; - drivers.initvideo; - Video.SetCursorType(crHidden); - InitScreen; - InitEvents; - InitSysError; - Redraw; -END; - -{--TApplication-------------------------------------------------------------} -{ GetTileRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TApplication.GetTileRect (Var R: TRect); -BEGIN - If (DeskTop <> Nil) Then Desktop^.GetExtent(R) { Desktop extents } - Else GetExtent(R); { Our extents } -END; - -{--TApplication-------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TApplication.HandleEvent (Var Event: TEvent); -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - If (Event.What = evCommand) Then Begin - Case Event.Command Of - cmTile: Tile; { Tile request } - cmCascade: Cascade; { Cascade request } - cmDosShell: DosShell; { DOS shell request } - Else Exit; { Unhandled exit } - End; - ClearEvent(Event); { Clear the event } - End; -END; - -procedure TApplication.WriteShellMsg; - -begin - writeln(sTypeExitOnReturn); -end; - - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ STANDARD MENU AND STATUS LINES ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ StdStatusKeys -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION StdStatusKeys (Next: PStatusItem): PStatusItem; -BEGIN - StdStatusKeys := - NewStatusKey('', kbAltX, cmQuit, - NewStatusKey('', kbF10, cmMenu, - NewStatusKey('', kbAltF3, cmClose, - NewStatusKey('', kbF5, cmZoom, - NewStatusKey('', kbCtrlF5, cmResize, - NewStatusKey('', kbF6, cmNext, - NewStatusKey('', kbShiftF6, cmPrev, - Next))))))); -END; - -{---------------------------------------------------------------------------} -{ StdFileMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION StdFileMenuItems (Next: PMenuItem): PMenuItem; -BEGIN - StdFileMenuItems := - NewItem('~N~ew', '', kbNoKey, cmNew, hcNew, - NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcOpen, - NewItem('~S~ave', 'F2', kbF2, cmSave, hcSave, - NewItem('S~a~ve as...', '', kbNoKey, cmSaveAs, hcSaveAs, - NewItem('Save a~l~l', '', kbNoKey, cmSaveAll, hcSaveAll, - NewLine( - NewItem('~C~hange dir...', '', kbNoKey, cmChangeDir, hcChangeDir, - NewItem('OS shell', '', kbNoKey, cmDosShell, hcDosShell, - NewItem('E~x~it', 'Alt+X', kbAltX, cmQuit, hcExit, - Next))))))))); -END; - -{---------------------------------------------------------------------------} -{ StdEditMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION StdEditMenuItems (Next: PMenuItem): PMenuItem; -BEGIN - StdEditMenuItems := - NewItem('~U~ndo', '', kbAltBack, cmUndo, hcUndo, - NewLine( - NewItem('Cu~t~', 'Shift+Del', kbShiftDel, cmCut, hcCut, - NewItem('~C~opy', 'Ctrl+Ins', kbCtrlIns, cmCopy, hcCopy, - NewItem('~P~aste', 'Shift+Ins', kbShiftIns, cmPaste, hcPaste, - NewItem('C~l~ear', 'Ctrl+Del', kbCtrlDel, cmClear, hcClear, - Next)))))); -END; - -{---------------------------------------------------------------------------} -{ StdWindowMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION StdWindowMenuItems (Next: PMenuItem): PMenuItem; -BEGIN - StdWindowMenuItems := - NewItem('~T~ile', '', kbNoKey, cmTile, hcTile, - NewItem('C~a~scade', '', kbNoKey, cmCascade, hcCascade, - NewItem('Cl~o~se all', '', kbNoKey, cmCloseAll, hcCloseAll, - NewLine( - NewItem('~S~ize/Move','Ctrl+F5', kbCtrlF5, cmResize, hcResize, - NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcZoom, - NewItem('~N~ext', 'F6', kbF6, cmNext, hcNext, - NewItem('~P~revious', 'Shift+F6', kbShiftF6, cmPrev, hcPrev, - NewItem('~C~lose', 'Alt+F3', kbAltF3, cmClose, hcClose, - Next))))))))); -END; - - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ OBJECT REGISTER ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ RegisterApp -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE RegisterApp; -BEGIN - RegisterType(RBackground); { Register background } - RegisterType(RDesktop); { Register desktop } -END; - -END. +{$I app.inc} diff --git a/packages/fv/src/asciitab.pas b/packages/fv/src/asciitab.pas index b109e33247..9bb02313a5 100644 --- a/packages/fv/src/asciitab.pas +++ b/packages/fv/src/asciitab.pas @@ -171,7 +171,7 @@ var CurrentPos : TPoint; Handled : boolean; - procedure SetTo(xpos, ypos : sw_integer;press:integer); + procedure SetTo(xpos, ypos : sw_integer;press:SmallInt); var newchar : ptrint; begin diff --git a/packages/fv/src/dialogs.inc b/packages/fv/src/dialogs.inc new file mode 100644 index 0000000000..de4eb2f0c9 --- /dev/null +++ b/packages/fv/src/dialogs.inc @@ -0,0 +1,4570 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of DIALOGS.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@starwon.com.au - backup e-mail addr } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} + +{$ifdef FV_UNICODE} +UNIT UDialogs; +{$else FV_UNICODE} +UNIT Dialogs; +{$endif FV_UNICODE} + +{$CODEPAGE cp437} + +{2.0 compatibility} +{$ifdef VER2_0} + {$macro on} + {$define resourcestring := const} +{$endif} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES + {$IFDEF OS_WINDOWS} { WIN/NT CODE } + Windows, { Standard units } + {$ENDIF} + + {$IFDEF OS_OS2} { OS2 CODE } + OS2Def, DosCalls, PMWIN, { Standard units } + {$ENDIF} + +{$ifdef FV_UNICODE} + UFVCommon, +{$else FV_UNICODE} + FVCommon, +{$endif FV_UNICODE} + FVConsts, Objects, { Standard GFV units } +{$ifdef FV_UNICODE} + UDrivers, UViews, UValidate, GraphemeBreakProperty; +{$else FV_UNICODE} + Drivers, Views, Validate; +{$endif FV_UNICODE} + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ COLOUR PALETTE DEFINITIONS } +{---------------------------------------------------------------------------} +CONST + CGrayDialog = #32#33#34#35#36#37#38#39#40#41#42#43#44#45#46#47 + + #48#49#50#51#52#53#54#55#56#57#58#59#60#61#62#63; + CBlueDialog = #64#65#66#67#68#69#70#71#72#73#74#75#76#77#78#79 + + #80#81#82#83#84#85#86#87#88#89#90#91#92#92#94#95; + CCyanDialog = #96#97#98#99#100#101#102#103#104#105#106#107#108 + + #109#110#111#112#113#114#115#116#117#118#119#120 + + #121#122#123#124#125#126#127; + CStaticText = #6#7#8#9; + CLabel = #7#8#9#9; + CButton = #10#11#12#13#14#14#14#15; + CCluster = #16#17#18#18#31#6; + CInputLine = #19#19#20#21#14; + CHistory = #22#23; + CHistoryWindow = #19#19#21#24#25#19#20; + CHistoryViewer = #6#6#7#6#6; + + CDialog = CGrayDialog; { Default palette } + +const + { ldXXXX constants } + ldNone = $0000; + ldNew = $0001; + ldEdit = $0002; + ldDelete = $0004; + ldNewEditDelete = ldNew or ldEdit or ldDelete; + ldHelp = $0008; + ldAllButtons = ldNew or ldEdit or ldDelete or ldHelp; + ldNewIcon = $0010; + ldEditIcon = $0020; + ldDeleteIcon = $0040; + ldAllIcons = ldNewIcon or ldEditIcon or ldDeleteIcon; + ldAll = ldAllIcons or ldAllButtons; + ldNoFrame = $0080; + ldNoScrollBar = $0100; + + { ofXXXX constants } + ofNew = $0001; + ofDelete = $0002; + ofEdit = $0004; + ofNewEditDelete = ofNew or ofDelete or ofEdit; + +{---------------------------------------------------------------------------} +{ TDialog PALETTE COLOUR CONSTANTS } +{---------------------------------------------------------------------------} +CONST + dpBlueDialog = 0; { Blue dialog colour } + dpCyanDialog = 1; { Cyan dialog colour } + dpGrayDialog = 2; { Gray dialog colour } + +{---------------------------------------------------------------------------} +{ TButton FLAGS MASKS } +{---------------------------------------------------------------------------} +CONST + bfNormal = $00; { Normal displayed } + bfDefault = $01; { Default command } + bfLeftJust = $02; { Left just text } + bfBroadcast = $04; { Broadcast command } + bfGrabFocus = $08; { Grab focus } + +{---------------------------------------------------------------------------} +{ TMultiCheckBoxes FLAGS - (HiByte = Bits LoByte = Mask) } +{---------------------------------------------------------------------------} +CONST + cfOneBit = $0101; { One bit masks } + cfTwoBits = $0203; { Two bit masks } + cfFourBits = $040F; { Four bit masks } + cfEightBits = $08FF; { Eight bit masks } + +{---------------------------------------------------------------------------} +{ DIALOG BROADCAST COMMANDS } +{---------------------------------------------------------------------------} +CONST + cmRecordHistory = 60; { Record history cmd } + +{***************************************************************************} +{ RECORD DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ ITEM RECORD DEFINITION } +{---------------------------------------------------------------------------} +TYPE + PSItem = ^TSItem; + TSItem = RECORD + Value: Sw_PString; { Item string } + Next: PSItem; { Next item } + END; + +{***************************************************************************} +{ OBJECT DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TInputLine OBJECT - INPUT LINE OBJECT } +{---------------------------------------------------------------------------} +TYPE + TInputLine = OBJECT (TView) + MaxLen: Sw_Integer; { Max input length } + CurPos: Sw_Integer; { Cursor position } + FirstPos: Sw_Integer; { First position } + SelStart: Sw_Integer; { Selected start } + SelEnd: Sw_Integer; { Selected end } + Data: Sw_PString; { Input line data } + Validator: PValidator; { Validator of view } + CONSTRUCTOR Init (Var Bounds: TRect; AMaxLen: Sw_Integer); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION Valid (Command: Word): Boolean; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE DrawCursor; Virtual; + PROCEDURE SelectAll (Enable: Boolean); + PROCEDURE SetValidator (AValid: PValidator); + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PRIVATE + FUNCTION CanScroll (Delta: Sw_Integer): Boolean; + FUNCTION ScreenCurPos: Sw_Integer; + END; + PInputLine = ^TInputLine; + +{---------------------------------------------------------------------------} +{ TButton OBJECT - BUTTON ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TButton = OBJECT (TView) + AmDefault: Boolean; { If default button } + Flags : Byte; { Button flags } + Command : Word; { Button command } + Title : Sw_PString; { Button title } + CONSTRUCTOR Init (Var Bounds: TRect; ATitle: TTitleStr; ACommand: Word; + AFlags: Word); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE Press; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE DrawState (Down: Boolean); + PROCEDURE MakeDefault (Enable: Boolean); + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PRIVATE + DownFlag: Boolean; + END; + PButton = ^TButton; + +{---------------------------------------------------------------------------} +{ TCluster OBJECT - CLUSTER ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + { Palette layout } + { 1 = Normal text } + { 2 = Selected text } + { 3 = Normal shortcut } + { 4 = Selected shortcut } + { 5 = Disabled text } + + TCluster = OBJECT (TView) + Id : Sw_Integer; { New communicate id } + Sel : Sw_Integer; { Selected item } + Value : LongInt; { Bit value } + EnableMask: LongInt; { Mask enable bits } +{$ifdef FV_UNICODE} + Strings : TUnicodeStringCollection; { String collection } +{$else FV_UNICODE} + Strings : TStringCollection; { String collection } +{$endif FV_UNICODE} + CONSTRUCTOR Init (Var Bounds: TRect; AStrings: PSItem); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION GetHelpCtx: Word; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION Mark (Item: Sw_Integer): Boolean; Virtual; + FUNCTION MultiMark (Item: Sw_Integer): Byte; Virtual; + FUNCTION ButtonState (Item: Sw_Integer): Boolean; + PROCEDURE Draw; Virtual; + PROCEDURE Press (Item: Sw_Integer); Virtual; + PROCEDURE MovedTo (Item: Sw_Integer); Virtual; + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE DrawMultiBox (Const Icon, Marker: Sw_String); + PROCEDURE DrawBox (Const Icon: String; Marker: Char); + PROCEDURE SetButtonState (AMask: Longint; Enable: Boolean); + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PRIVATE + FUNCTION FindSel (P: TPoint): Sw_Integer; + FUNCTION Row (Item: Sw_Integer): Sw_Integer; + FUNCTION Column (Item: Sw_Integer): Sw_Integer; + END; + PCluster = ^TCluster; + +{---------------------------------------------------------------------------} +{ TRadioButtons OBJECT - RADIO BUTTON OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Normal text } + { 2 = Selected text } + { 3 = Normal shortcut } + { 4 = Selected shortcut } + + +TYPE + TRadioButtons = OBJECT (TCluster) + FUNCTION Mark (Item: Sw_Integer): Boolean; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Press (Item: Sw_Integer); Virtual; + PROCEDURE MovedTo(Item: Sw_Integer); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + END; + PRadioButtons = ^TRadioButtons; + +{---------------------------------------------------------------------------} +{ TCheckBoxes OBJECT - CHECK BOXES OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Normal text } + { 2 = Selected text } + { 3 = Normal shortcut } + { 4 = Selected shortcut } + +TYPE + TCheckBoxes = OBJECT (TCluster) + FUNCTION Mark (Item: Sw_Integer): Boolean; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Press (Item: Sw_Integer); Virtual; + END; + PCheckBoxes = ^TCheckBoxes; + +{---------------------------------------------------------------------------} +{ TMultiCheckBoxes OBJECT - CHECK BOXES OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Normal text } + { 2 = Selected text } + { 3 = Normal shortcut } + { 4 = Selected shortcut } + +TYPE + TMultiCheckBoxes = OBJECT (TCluster) + SelRange: Byte; { Select item range } + Flags : Word; { Select flags } + States : Sw_PString; { Strings } + CONSTRUCTOR Init (Var Bounds: TRect; AStrings: PSItem; + ASelRange: Byte; AFlags: Word; Const AStates: String); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION MultiMark (Item: Sw_Integer): Byte; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Press (Item: Sw_Integer); Virtual; + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + END; + PMultiCheckBoxes = ^TMultiCheckBoxes; + +{---------------------------------------------------------------------------} +{ TListBox OBJECT - LIST BOX OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Active } + { 2 = Inactive } + { 3 = Focused } + { 4 = Selected } + { 5 = Divider } + +TYPE + TListBox = OBJECT (TListViewer) + List: PCollection; { List of strings } + CONSTRUCTOR Init (Var Bounds: TRect; ANumCols: Sw_Word; + AScrollBar: PScrollBar); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION GetText (Item: Sw_Integer; MaxLen: Sw_Integer): Sw_String; Virtual; + PROCEDURE NewList(AList: PCollection); Virtual; + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + procedure DeleteFocusedItem; virtual; + { DeleteFocusedItem deletes the focused item and redraws the view. } + {#X FreeFocusedItem } + procedure DeleteItem (Item : Sw_Integer); virtual; + { DeleteItem deletes Item from the associated collection. } + {#X FreeItem } + procedure FreeAll; virtual; + { FreeAll deletes and disposes of all items in the associated + collection. } + { FreeFocusedItem FreeItem } + procedure FreeFocusedItem; virtual; + { FreeFocusedItem deletes and disposes of the focused item then redraws + the listbox. } + {#X FreeAll FreeItem } + procedure FreeItem (Item : Sw_Integer); virtual; + { FreeItem deletes Item from the associated collection and disposes of + it, then redraws the listbox. } + {#X FreeFocusedItem FreeAll } + function GetFocusedItem : Pointer; virtual; + { GetFocusedItem is a more readable method of returning the focused + item from the listbox. It is however slightly slower than: } + {#M+} + { + Item := ListBox^.List^.At(ListBox^.Focused); } + {#M-} + procedure Insert (Item : Pointer); virtual; + { Insert inserts Item into the collection, adjusts the listbox's range, + then redraws the listbox. } + {#X FreeItem } + procedure SetFocusedItem (Item : Pointer); virtual; + { SetFocusedItem changes the focused item to Item then redraws the + listbox. } + {# FocusItemNum } + END; + PListBox = ^TListBox; + +{---------------------------------------------------------------------------} +{ TStaticText OBJECT - STATIC TEXT OBJECT } +{---------------------------------------------------------------------------} +TYPE + TStaticText = OBJECT (TView) + Text: Sw_PString; { Text string ptr } + CONSTRUCTOR Init (Var Bounds: TRect; Const AText: Sw_String); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE GetText (Var S: Sw_String); Virtual; + END; + PStaticText = ^TStaticText; + +{---------------------------------------------------------------------------} +{ TParamText OBJECT - PARMETER STATIC TEXT OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Text } + +TYPE + TParamText = OBJECT (TStaticText) + ParamCount: Sw_Integer; { Parameter count } + ParamList : Pointer; { Parameter list } + CONSTRUCTOR Init (Var Bounds: TRect; Const AText: Sw_String; + AParamCount: Sw_Integer); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION DataSize: Sw_Word; Virtual; + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE GetText (Var S: Sw_String); Virtual; + END; + PParamText = ^TParamText; + +{---------------------------------------------------------------------------} +{ TLabel OBJECT - LABEL OBJECT } +{---------------------------------------------------------------------------} +TYPE + TLabel = OBJECT (TStaticText) + Light: Boolean; + Link: PView; { Linked view } + CONSTRUCTOR Init (Var Bounds: TRect; CONST AText: Sw_String; ALink: PView); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PLabel = ^TLabel; + +{---------------------------------------------------------------------------} +{ THistoryViewer OBJECT - HISTORY VIEWER OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Active } + { 2 = Inactive } + { 3 = Focused } + { 4 = Selected } + { 5 = Divider } + +TYPE + THistoryViewer = OBJECT (TListViewer) + HistoryId: Word; { History id } + CONSTRUCTOR Init(Var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar; + AHistoryId: Word); + FUNCTION HistoryWidth: Sw_Integer; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION GetText (Item: Sw_Integer; MaxLen: Sw_Integer): Sw_String; Virtual; + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PHistoryViewer = ^THistoryViewer; + +{---------------------------------------------------------------------------} +{ THistoryWindow OBJECT - HISTORY WINDOW OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Frame passive } + { 2 = Frame active } + { 3 = Frame icon } + { 4 = ScrollBar page area } + { 5 = ScrollBar controls } + { 6 = HistoryViewer normal text } + { 7 = HistoryViewer selected text } + +TYPE + THistoryWindow = OBJECT (TWindow) + Viewer: PListViewer; { List viewer object } + CONSTRUCTOR Init (Var Bounds: TRect; HistoryId: Word); + FUNCTION GetSelection: Sw_String; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE InitViewer (HistoryId: Word); Virtual; + END; + PHistoryWindow = ^THistoryWindow; + +{---------------------------------------------------------------------------} +{ THistory OBJECT - HISTORY OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Arrow } + { 2 = Sides } + +TYPE + THistory = OBJECT (TView) + HistoryId: Word; + Link: PInputLine; + CONSTRUCTOR Init (Var Bounds: TRect; ALink: PInputLine; AHistoryId: Word); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION InitHistoryWindow (Var Bounds: TRect): PHistoryWindow; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE RecordHistory (CONST S: Sw_String); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PHistory = ^THistory; + + {#Z+} + PBrowseInputLine = ^TBrowseInputLine; + TBrowseInputLine = Object(TInputLine) + History: Sw_Word; + constructor Init(var Bounds: TRect; AMaxLen: Sw_Integer; AHistory: Sw_Word); + constructor Load(var S: TStream); + function DataSize: Sw_Word; virtual; + procedure GetData(var Rec); virtual; + procedure SetData(var Rec); virtual; + procedure Store(var S: TStream); + end; { of TBrowseInputLine } + + TBrowseInputLineRec = record + Text: Sw_String; + History: Sw_Word; + end; { of TBrowseInputLineRec } + {#Z+} + PBrowseButton = ^TBrowseButton; + {#Z-} + TBrowseButton = Object(TButton) + Link: PBrowseInputLine; + constructor Init(var Bounds: TRect; ATitle: TTitleStr; ACommand: Word; + AFlags: Byte; ALink: PBrowseInputLine); + constructor Load(var S: TStream); + procedure Press; virtual; + procedure Store(var S: TStream); + end; { of TBrowseButton } + + + {#Z+} + PCommandIcon = ^TCommandIcon; + {#Z-} + TCommandIcon = Object(TStaticText) + { A TCommandIcon sends an evCommand message to its owner with + Event.Command set to #Command# when it is clicked with a mouse. } + constructor Init (var Bounds : TRect; AText : Sw_String; ACommand : Word); + { Creates an instance of a TCommandIcon and sets #Command# to + ACommand. AText is the text which is displayed as the icon. If an + error occurs Init fails. } + procedure HandleEvent (var Event : TEvent); virtual; + { Captures mouse events within its borders and sends an evCommand to + its owner in response to the mouse event. } + {#X Command } + private + Command : Word; + { Command is the command sent to the command icon's owner when it is + clicked. } + end; { of TCommandIcon } + + + {#Z+} + PCommandSItem = ^TCommandSItem; + {#Z-} + TCommandSItem = record + { A TCommandSItem is the data structure used to initialize command + clusters with #NewCommandSItem# rather than the standarad #NewSItem#. + It is used to associate a command with an individual cluster item. } + {#X TCommandCheckBoxes TCommandRadioButtons } + Value : Sw_String; + { Value is the text displayed for the cluster item. } + {#X Command Next } + Command : Word; + { Command is the command broadcast when the cluster item is pressed. } + {#X Value Next } + Next : PCommandSItem; + { Next is a pointer to the next item in the cluster. } + {#X Value Command } + end; { of TCommandSItem } + + + TCommandArray = array[0..15] of Word; + { TCommandArray holds a list of commands which are associated with a + cluster. } + {#X TCommandCheckBoxes TCommandRadioButtons } + + + {#Z+} + PCommandCheckBoxes = ^TCommandCheckBoxes; + {#Z-} + TCommandCheckBoxes = Object(TCheckBoxes) + { TCommandCheckBoxes function as normal TCheckBoxes, except that when a + cluster item is pressed it broadcasts a command associated with the + cluster item to the cluster's owner. + + TCommandCheckBoxes are useful when other parts of a dialog should be + enabled or disabled in response to a check box's status. } + CommandList : TCommandArray; + { CommandList is the list of commands associated with each check box + item. } + {#X Init Load Store } + constructor Init (var Bounds : TRect; ACommandStrings : PCommandSItem); + { Init calls the inherited constructor, then sets up the #CommandList# + with the specified commands. If an error occurs Init fails. } + {#X NewCommandSItem } + constructor Load (var S : TStream); + { Load calls the inherited constructor, then loads the #CommandList# + from the stream S. If an error occurs Load fails. } + {#X Store Init } + procedure Press (Item : Sw_Integer); virtual; + { Press calls the inherited Press then broadcasts the command + associated with the cluster item that was pressed to the check boxes' + owner. } + {#X CommandList } + procedure Store (var S : TStream); { store should never be virtual;} + { Store calls the inherited Store method then writes the #CommandList# + to the stream. } + {#X Load } + end; { of TCommandCheckBoxes } + + + {#Z+} + PCommandRadioButtons = ^TCommandRadioButtons; + {#Z-} + TCommandRadioButtons = Object(TRadioButtons) + { TCommandRadioButtons function as normal TRadioButtons, except that when + a cluster item is pressed it broadcasts a command associated with the + cluster item to the cluster's owner. + + TCommandRadioButtons are useful when other parts of a dialog should be + enabled or disabled in response to a radiobutton's status. } + CommandList : TCommandArray; { commands for each possible value } + { The list of commands associated with each radio button item. } + {#X Init Load Store } + constructor Init (var Bounds : TRect; ACommandStrings : PCommandSItem); + { Init calls the inherited constructor and sets up the #CommandList# + with the specified commands. If an error occurs Init disposes of the + command strings then fails. } + {#X NewCommandSItem } + constructor Load (var S : TStream); + { Load calls the inherited constructor then loads the #CommandList# + from the stream S. If an error occurs Load fails. } + {#X Store } + procedure MovedTo (Item : Sw_Integer); virtual; + { MovedTo calls the inherited MoveTo, then broadcasts the command of + the newly selected cluster item to the cluster's owner. } + {#X Press CommandList } + procedure Press (Item : Sw_Integer); virtual; + { Press calls the inherited Press then broadcasts the command + associated with the cluster item that was pressed to the check boxes + owner. } + {#X CommandList MovedTo } + procedure Store (var S : TStream); { store should never be virtual;} + { Store calls the inherited Store method then writes the #CommandList# + to the stream. } + {#X Load } + end; { of TCommandRadioButtons } + + PEditListBox = ^TEditListBox; + TEditListBox = Object(TListBox) + CurrentField : SmallInt; + constructor Init (Bounds : TRect; ANumCols: Word; + AVScrollBar : PScrollBar); + constructor Load (var S : TStream); + function FieldValidator : PValidator; virtual; + function FieldWidth : SmallInt; virtual; + procedure GetField (InputLine : PInputLine); virtual; + function GetPalette : PPalette; virtual; + procedure HandleEvent (var Event : TEvent); virtual; + procedure SetField (InputLine : PInputLine); virtual; + function StartColumn : SmallInt; virtual; + PRIVATE + procedure EditField (var Event : TEvent); + end; { of TEditListBox } + + + PModalInputLine = ^TModalInputLine; + TModalInputLine = Object(TInputLine) + function Execute : Word; virtual; + procedure HandleEvent (var Event : TEvent); virtual; + procedure SetState (AState : Word; Enable : Boolean); virtual; + private + EndState : Word; + end; { of TModalInputLine } + +{---------------------------------------------------------------------------} +{ TDialog OBJECT - DIALOG OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Frame passive } + { 2 = Frame active } + { 3 = Frame icon } + { 4 = ScrollBar page area } + { 5 = ScrollBar controls } + { 6 = StaticText } + { 7 = Label normal } + { 8 = Label selected } + { 9 = Label shortcut } + { 10 = Button normal } + { 11 = Button default } + { 12 = Button selected } + { 13 = Button disabled } + { 14 = Button shortcut } + { 15 = Button shadow } + { 16 = Cluster normal } + { 17 = Cluster selected } + { 18 = Cluster shortcut } + { 19 = InputLine normal text } + { 20 = InputLine selected text } + { 21 = InputLine arrows } + { 22 = History arrow } + { 23 = History sides } + { 24 = HistoryWindow scrollbar page area } + { 25 = HistoryWindow scrollbar controls } + { 26 = ListViewer normal } + { 27 = ListViewer focused } + { 28 = ListViewer selected } + { 29 = ListViewer divider } + { 30 = InfoPane } + { 31 = Cluster disabled } + { 32 = Reserved } + + PDialog = ^TDialog; + TDialog = object(TWindow) + constructor Init(var Bounds: TRect; ATitle: TTitleStr); + constructor Load(var S: TStream); + procedure Cancel (ACommand : Word); virtual; + { If the dialog is a modal dialog, Cancel calls EndModal(ACommand). If + the dialog is non-modal Cancel calls Close. + + Cancel may be overridden to provide special processing prior to + destructing the dialog. } + procedure ChangeTitle (ANewTitle : TTitleStr); virtual; + { ChangeTitle disposes of the current title, assigns ANewTitle to Title, + then redraws the dialog. } + procedure FreeSubView (ASubView : PView); virtual; + { FreeSubView deletes and disposes ASubView from the dialog. } + {#X FreeAllSubViews IsSubView } + procedure FreeAllSubViews; virtual; + { Deletes then disposes all subviews in the dialog. } + {#X FreeSubView IsSubView } + function GetPalette: PPalette; virtual; + procedure HandleEvent(var Event: TEvent); virtual; + function IsSubView (AView : PView) : Boolean; virtual; + { IsSubView returns True if AView is non-nil and is a subview of the + dialog. } + {#X FreeSubView FreeAllSubViews } + function NewButton (X, Y, W, H : Sw_Integer; ATitle : TTitleStr; + ACommand, AHelpCtx : Word; + AFlags : Byte) : PButton; + { Creates and inserts into the dialog a new TButton with the + help context AHelpCtx. + + A pointer to the new button is returned for checking validity of the + initialization. } + {#X NewInputLine NewLabel } + function NewLabel (X, Y : Sw_Integer; AText : Sw_String; + ALink : PView) : PLabel; + { NewLabel creates and inserts into the dialog a new TLabel and + associates it with ALink. } + {#X NewButton NewInputLine } + function NewInputLine (X, Y, W, AMaxLen : Sw_Integer; AHelpCtx : Word + ; AValidator : PValidator) : PInputLine; + { NewInputLine creates and inserts into the dialog a new TBSDInputLine + with the help context to AHelpCtx and the validator AValidator. + + A pointer to the inputline is returned for checking validity of the + initialization. } + {#X NewButton NewLabel } + function Valid(Command: Word): Boolean; virtual; + end; + + PListDlg = ^TListDlg; + TListDlg = object(TDialog) + { TListDlg displays a listbox of items, with optional New, Edit, and + Delete buttons displayed according to the options bit set in the + dialog. Use the ofXXXX flags declared in this unit OR'd with the + standard ofXXXX flags to set the appropriate bits in Options. + + If enabled, when the New or Edit buttons are pressed, an evCommand + message is sent to the application with a Command value of NewCommand + or EditCommand, respectively. Using this mechanism in combination with + the declared Init parameters, a standard TListDlg can be used with any + type of list displayable in a TListBox or its descendant. } + NewCommand: Word; + EditCommand: Word; + ListBox: PListBox; + ldOptions: Word; + constructor Init (ATitle: TTitleStr; Items: Sw_String; AButtons: Word; + AListBox: PListBox; AEditCommand, ANewCommand: Word); + constructor Load(var S: TStream); + procedure HandleEvent(var Event: TEvent); virtual; + procedure Store(var S: TStream); { store should never be virtual;} + end; { of TListDlg } + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ ITEM STRING ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-NewSItem----------------------------------------------------------- +Allocates memory for a new TSItem record and sets the text field +and chains to the next TSItem. This allows easy construction of +singly-linked lists of strings, to end a chain the next TSItem +should be nil. +28Apr98 LdB +---------------------------------------------------------------------} +FUNCTION NewSItem (Const Str: Sw_String; ANext: PSItem): PSItem; + +{ NewCommandSItem allocates and returns a pointer to a new #TCommandSItem# + record. The Value and Next fields of the record are set to NewStr(Str) + and ANext, respectively. The NewSItem function and the TSItem record type + allow easy construction of singly-linked lists of command strings. } +function NewCommandSItem (Str : Sw_String; ACommand : Word; + ANext : PCommandSItem) : PCommandSItem; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ DIALOG OBJECT REGISTRATION PROCEDURE } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-RegisterDialogs---------------------------------------------------- +This registers all the view type objects used in this unit. +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterDialogs; + +{***************************************************************************} +{ STREAM REGISTRATION RECORDS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TDialog STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RDialog: TStreamRec = ( + ObjType: idDialog; { Register id = 10 } + VmtLink: TypeOf(TDialog); + Load: @TDialog.Load; { Object load method } + Store: @TDialog.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TInputLine STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RInputLine: TStreamRec = ( + ObjType: idInputLine; { Register id = 11 } + VmtLink: TypeOf(TInputLine); + Load: @TInputLine.Load; { Object load method } + Store: @TInputLine.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TButton STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RButton: TStreamRec = ( + ObjType: idButton; { Register id = 12 } + VmtLink: TypeOf(TButton); + Load: @TButton.Load; { Object load method } + Store: @TButton.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TCluster STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RCluster: TStreamRec = ( + ObjType: idCluster; { Register id = 13 } + VmtLink: TypeOf(TCluster); + Load: @TCluster.Load; { Object load method } + Store: @TCluster.Store { Objects store method } + ); + +{---------------------------------------------------------------------------} +{ TRadioButtons STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RRadioButtons: TStreamRec = ( + ObjType: idRadioButtons; { Register id = 14 } + VmtLink: TypeOf(TRadioButtons); + Load: @TRadioButtons.Load; { Object load method } + Store: @TRadioButtons.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TCheckBoxes STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RCheckBoxes: TStreamRec = ( + ObjType: idCheckBoxes; { Register id = 15 } + VmtLink: TypeOf(TCheckBoxes); + Load: @TCheckBoxes.Load; { Object load method } + Store: @TCheckBoxes.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TMultiCheckBoxes STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RMultiCheckBoxes: TStreamRec = ( + ObjType: idMultiCheckBoxes; { Register id = 27 } + VmtLink: TypeOf(TMultiCheckBoxes); + Load: @TMultiCheckBoxes.Load; { Object load method } + Store: @TMultiCheckBoxes.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TListBox STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RListBox: TStreamRec = ( + ObjType: idListBox; { Register id = 16 } + VmtLink: TypeOf(TListBox); + Load: @TListBox.Load; { Object load method } + Store: @TListBox.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TStaticText STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RStaticText: TStreamRec = ( + ObjType: idStaticText; { Register id = 17 } + VmtLink: TypeOf(TStaticText); + Load: @TStaticText.Load; { Object load method } + Store: @TStaticText.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TLabel STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RLabel: TStreamRec = ( + ObjType: idLabel; { Register id = 18 } + VmtLink: TypeOf(TLabel); + Load: @TLabel.Load; { Object load method } + Store: @TLabel.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ THistory STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RHistory: TStreamRec = ( + ObjType: idHistory; { Register id = 19 } + VmtLink: TypeOf(THistory); + Load: @THistory.Load; { Object load method } + Store: @THistory.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TParamText STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RParamText: TStreamRec = ( + ObjType: idParamText; { Register id = 20 } + VmtLink: TypeOf(TParamText); + Load: @TParamText.Load; { Object load method } + Store: @TParamText.Store { Object store method } + ); + + RCommandCheckBoxes : TStreamRec = ( + ObjType : idCommandCheckBoxes; + VmtLink : Ofs(TypeOf(TCommandCheckBoxes)^); + Load : @TCommandCheckBoxes.Load; + Store : @TCommandCheckBoxes.Store); + + RCommandRadioButtons : TStreamRec = ( + ObjType : idCommandRadioButtons; + VmtLink : Ofs(TypeOf(TCommandRadioButtons)^); + Load : @TCommandRadioButtons.Load; + Store : @TCommandRadioButtons.Store); + + RCommandIcon : TStreamRec = ( + ObjType : idCommandIcon; + VmtLink : Ofs(Typeof(TCommandIcon)^); + Load : @TCommandIcon.Load; + Store : @TCommandIcon.Store); + + RBrowseButton: TStreamRec = ( + ObjType : idBrowseButton; + VmtLink : Ofs(TypeOf(TBrowseButton)^); + Load : @TBrowseButton.Load; + Store : @TBrowseButton.Store); + + REditListBox : TStreamRec = ( + ObjType : idEditListBox; + VmtLink : Ofs(TypeOf(TEditListBox)^); + Load : @TEditListBox.Load; + Store : @TEditListBox.Store); + + RListDlg : TStreamRec = ( + ObjType : idListDlg; + VmtLink : Ofs(TypeOf(TListDlg)^); + Load : @TListDlg.Load; + Store : @TListDlg.Store); + + RModalInputLine : TStreamRec = ( + ObjType : idModalInputLine; + VmtLink : Ofs(TypeOf(TModalInputLine)^); + Load : @TModalInputLine.Load; + Store : @TModalInputLine.Store); + +resourcestring slCancel='Cancel'; + slOk='O~k~'; + slYes='~Y~es'; + slNo='~N~o'; + + slHelp='~H~elp'; + slName='~N~ame'; + + slOpen='~O~pen'; + slClose='~C~lose'; + slCloseAll='Cl~o~se all'; + + slSave='~S~ave'; + slSaveAll='Save a~l~l'; + slSaveAs='S~a~ve as...'; + slSaveFileAs='~S~ave file as'; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{$ifdef FV_UNICODE} +USES UApp,UHistList; { Standard GFV unit } +{$else FV_UNICODE} +USES App,HistList; { Standard GFV unit } +{$endif FV_UNICODE} + +{***************************************************************************} +{ PRIVATE DEFINED CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ LEFT AND RIGHT ARROW CHARACTER CONSTANTS } +{---------------------------------------------------------------------------} +CONST LeftArr = '<'; RightArr = '>'; + +{---------------------------------------------------------------------------} +{ TButton MESSAGES } +{---------------------------------------------------------------------------} +CONST + cmGrabDefault = 61; { Grab default } + cmReleaseDefault = 62; { Release default } + +{---------------------------------------------------------------------------} +{ IsBlank -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION IsBlank (Ch: Char): Boolean; +BEGIN + IsBlank := (Ch = ' ') OR (Ch = #13) OR (Ch = #10); { Check for characters } +END; + +{---------------------------------------------------------------------------} +{ HotKey -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION HotKey (Const S: String): Char; +VAR I: Sw_Word; +BEGIN + HotKey := #0; { Preset fail } + If (S <> '') Then Begin { Valid string } + I := Pos('~', S); { Search for tilde } + If (I <> 0) Then HotKey := UpCase(S[I+1]); { Return hotkey } + End; +END; + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TDialog OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TDialog------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TDialog.Init (Var Bounds: TRect; ATitle: TTitleStr); +BEGIN + Inherited Init(Bounds, ATitle, wnNoNumber); { Call ancestor } + Options := Options OR ofVersion20; { Version two dialog } + GrowMode := 0; { Clear grow mode } + Flags := wfMove + wfClose; { Close/moveable flags } + Palette := dpGrayDialog; { Default gray colours } +END; + +{--TDialog------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TDialog.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + If (Options AND ofVersion = ofVersion10) Then Begin + Palette := dpGrayDialog; { Set gray palette } + Options := Options OR ofVersion20; { Update version flag } + End; +END; + +{--TDialog------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TDialog.GetPalette: PPalette; +CONST P: Array[dpBlueDialog..dpGrayDialog] Of String[Length(CBlueDialog)] = + (CBlueDialog, CCyanDialog, CGrayDialog); { Always normal string } +BEGIN + GetPalette := PPalette(@P[Palette]); { Return palette } +END; + +{--TDialog------------------------------------------------------------------} +{ Valid -> Platforms DOS/DPMI/WIN/NT/Os2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TDialog.Valid (Command: Word): Boolean; +BEGIN + If (Command = cmCancel) Then Valid := True { Cancel returns true } + Else Valid := TGroup.Valid(Command); { Call group ancestor } +END; + +{--TDialog------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDialog.HandleEvent (Var Event: TEvent); +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evKeyDown: { Key down event } + Case Event.KeyCode Of + kbEsc, kbCtrlF4: Begin { Escape key press } + Event.What := evCommand; { Command event } + Event.Command := cmCancel; { cancel command } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + ClearEvent(Event); { Clear the event } + End; + kbCtrlF5: Begin { movement of modal dialogs } + If (State AND sfModal <> 0) Then + begin + Event.What := evCommand; + Event.Command := cmResize; + Event.InfoPtr := Nil; + PutEvent(Event); + ClearEvent(Event); + end; + End; + kbEnter: Begin { Enter key press } + Event.What := evBroadcast; { Broadcast event } + Event.Command := cmDefault; { Default command } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + ClearEvent(Event); { Clear the event } + End; + End; + evCommand: { Command event } + Case Event.Command Of + cmOk, cmCancel, cmYes, cmNo: { End dialog cmds } + If (State AND sfModal <> 0) Then Begin { View is modal } + EndModal(Event.Command); { End modal state } + ClearEvent(Event); { Clear the event } + End; + End; + End; +END; + +{****************************************************************************} +{ TDialog.Cancel } +{****************************************************************************} +procedure TDialog.Cancel (ACommand : Word); +begin + if State and sfModal = sfModal then + EndModal(ACommand) + else Close; +end; + +{****************************************************************************} +{ TDialog.ChangeTitle } +{****************************************************************************} +procedure TDialog.ChangeTitle (ANewTitle : TTitleStr); +begin +{$ifdef FV_UNICODE} + Title := ANewTitle; +{$else FV_UNICODE} + if (Title <> nil) then + DisposeStr(Title); + Title := NewStr(ANewTitle); +{$endif FV_UNICODE} + Frame^.DrawView; +end; + +{****************************************************************************} +{ TDialog.FreeSubView } +{****************************************************************************} +procedure TDialog.FreeSubView (ASubView : PView); +begin + if IsSubView(ASubView) then begin + Delete(ASubView); + Dispose(ASubView,Done); + DrawView; + end; +end; + +{****************************************************************************} +{ TDialog.FreeAllSubViews } +{****************************************************************************} +procedure TDialog.FreeAllSubViews; +var + P : PView; +begin + P := First; + repeat + P := First; + if (P <> nil) then begin + Delete(P); + Dispose(P,Done); + end; + until (P = nil); + DrawView; +end; + +{****************************************************************************} +{ TDialog.IsSubView } +{****************************************************************************} +function TDialog.IsSubView (AView : PView) : Boolean; +var P : PView; +begin + P := First; + while (P <> nil) and (P <> AView) do + P := P^.NextView; + IsSubView := ((P <> nil) and (P = AView)); +end; + +{****************************************************************************} +{ TDialog.NewButton } +{****************************************************************************} +function TDialog.NewButton (X, Y, W, H : Sw_Integer; ATitle : TTitleStr; + ACommand, AHelpCtx : Word; + AFlags : Byte) : PButton; +var + B : PButton; + R : TRect; +begin + R.Assign(X,Y,X+W,Y+H); + B := New(PButton,Init(R,ATitle,ACommand,AFlags)); + if (B <> nil) then begin + B^.HelpCtx := AHelpCtx; + Insert(B); + end; + NewButton := B; +end; + +{****************************************************************************} +{ TDialog.NewInputLine } +{****************************************************************************} +function TDialog.NewInputLine (X, Y, W, AMaxLen : Sw_Integer; AHelpCtx : Word + ; AValidator : PValidator) : PInputLine; +var + P : PInputLine; + R : TRect; +begin + R.Assign(X,Y,X+W,Y+1); + P := New(PInputLine,Init(R,AMaxLen)); + if (P <> nil) then begin + P^.SetValidator(AValidator); + P^.HelpCtx := AHelpCtx; + Insert(P); + end; + NewInputLine := P; +end; + +{****************************************************************************} +{ TDialog.NewLabel } +{****************************************************************************} +function TDialog.NewLabel (X, Y : Sw_Integer; AText : Sw_String; + ALink : PView) : PLabel; +var + P : PLabel; + R : TRect; +begin + R.Assign(X,Y,X+CStrLen(AText)+1,Y+1); + P := New(PLabel,Init(R,AText,ALink)); + if (P <> nil) then + Insert(P); + NewLabel := P; +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TInputLine OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TInputLine---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TInputLine.Init (Var Bounds: TRect; AMaxLen: Sw_Integer); +BEGIN + Inherited Init(Bounds); { Call ancestor } + State := State OR sfCursorVis; { Cursor visible } + Options := Options OR (ofSelectable + ofFirstClick + + ofVersion20); { Set options } +{$ifdef FV_UNICODE} + Data := ''; { Data = empty string } +{$else FV_UNICODE} + If (MaxAvail > AMaxLen + 1) Then Begin { Check enough memory } + GetMem(Data, AMaxLen + 1); { Allocate memory } + Data^ := ''; { Data = empty string } + End; +{$endif FV_UNICODE} + MaxLen := AMaxLen; { Hold maximum length } +END; + +{--TInputLine---------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TInputLine.Load (Var S: TStream); +VAR B: Byte; + W: Word; +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(W, sizeof(w)); MaxLen:=W; { Read max length } + S.Read(W, sizeof(w)); CurPos:=w; { Read cursor position } + S.Read(W, sizeof(w)); FirstPos:=w; { Read first position } + S.Read(W, sizeof(w)); SelStart:=w; { Read selected start } + S.Read(W, sizeof(w)); SelEnd:=w; { Read selected end } + S.Read(B, SizeOf(B)); { Read string length } +{$ifdef FV_UNICODE} + Data:=S.ReadUnicodeString; +{$else FV_UNICODE} + GetMem(Data, B + 1); { Allocate memory } + S.Read(Data^[1], B); { Read string data } + SetLength(Data^, B); { Xfer string length } +{$endif FV_UNICODE} + If (Options AND ofVersion >= ofVersion20) Then { Version 2 or above } + Validator := PValidator(S.Get); { Get any validator } + Options := Options OR ofVersion20; { Set version 2 flag } +END; + +{--TInputLine---------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TInputLine.Done; +BEGIN +{$ifndef FV_UNICODE} + If (Data <> Nil) Then FreeMem(Data, MaxLen + 1); { Release any memory } +{$endif FV_UNICODE} + SetValidator(Nil); { Clear any validator } + Inherited Done; { Call ancestor } +END; + +{--TInputLine---------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TInputLine.DataSize: Sw_Word; +VAR DSize: Sw_Word; +BEGIN + DSize := 0; { Preset zero datasize } +{$ifdef FV_UNICODE} + If (Validator <> Nil) AND (Data <> '') Then + DSize := Validator^.Transfer(Data, Nil, + vtDataSize); { Add validator size } +{$else FV_UNICODE} + If (Validator <> Nil) AND (Data <> Nil) Then + DSize := Validator^.Transfer(Data^, Nil, + vtDataSize); { Add validator size } +{$endif FV_UNICODE} + If (DSize <> 0) Then DataSize := DSize { Use validtor size } + Else DataSize := MaxLen + 1; { No validator use size } +END; + +{--TInputLine---------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TInputLine.GetPalette: PPalette; +CONST P: String[Length(CInputLine)] = CInputLine; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TInputLine---------------------------------------------------------------} +{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TInputLine.Valid (Command: Word): Boolean; + + FUNCTION AppendError (AValidator: PValidator): Boolean; + BEGIN + AppendError := False; { Preset false } + If Data <> Sw_PString_Empty Then + With AValidator^ Do + If (Options AND voOnAppend <> 0) AND { Check options } + (CurPos <> Length(Data Sw_PString_DeRef)) AND { Exceeds max length } + NOT IsValidInput(Data Sw_PString_DeRef, True) Then Begin { Check data valid } + Error; { Call error } + AppendError := True; { Return true } + End; + END; + +BEGIN + Valid := Inherited Valid(Command); { Call ancestor } + If (Validator <> Nil) AND (Data <> Sw_PString_Empty) AND { Validator present } + (State AND sfDisabled = 0) Then { Not disabled } + If (Command = cmValid) Then { Valid command } + Valid := Validator^.Status = vsOk { Validator result } + Else If (Command <> cmCancel) Then { Not cancel command } + If AppendError(Validator) OR { Append any error } + NOT Validator^.Valid(Data Sw_PString_DeRef) Then Begin { Check validator } + Select; { Reselect view } + Valid := False; { Return false } + End; +END; + +{--TInputLine---------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +{$ifdef FV_UNICODE} +PROCEDURE TInputLine.Draw; +VAR Color: Byte; L, R, SkipToFirstPosLeft, ScrPos, EGC_StrWidth: Sw_Integer; + B : TDrawBuffer; + EGC: Sw_String; +BEGIN + if Options and ofSelectable = 0 then + Color := GetColor(5) + else + If (State AND sfFocused = 0) Then + Color := GetColor(1) { Not focused colour } + Else + Color := GetColor(2); { Focused colour } + MoveChar(B, ' ', Color, Size.X); + if CanScroll(1) then + MoveChar(B[Size.X - 1], RightArr, GetColor(4), 1); + if (State and sfFocused <> 0) and + (Options and ofSelectable <> 0) then + begin + if CanScroll(-1) then + MoveChar(B[0], LeftArr, GetColor(4), 1); + { Highlighted part } + L := SelStart - FirstPos; + R := SelEnd - FirstPos; + if L < 0 then + L := 0; + if R > Size.X - 2 then + R := Size.X - 2; + SetCursor(ScreenCurPos - FirstPos + 1, 0); + end; + SkipToFirstPosLeft := FirstPos; + ScrPos := 1; + for EGC in TUnicodeStringExtendedGraphemeClustersEnumerator.Create(Data) do + begin + if SkipToFirstPosLeft > 0 then + Dec(SkipToFirstPosLeft, Length(EGC)) + else + begin + EGC_StrWidth := EgcWidth(EGC); + if (ScrPos + EGC_StrWidth - 1) > (Size.X - 2) then + break; + with B[ScrPos] do + begin + ExtendedGraphemeCluster := EGC; + if (L <= 0) and (R > 0) then + Attribute:=GetColor(3) + else + Attribute:=Color; + end; + Inc(ScrPos, EGC_StrWidth); + Dec(L, Length(EGC)); + Dec(R, Length(EGC)); + end; + end; + WriteLine(0, 0, Size.X, Size.Y, B); +end; +{$else FV_UNICODE} +PROCEDURE TInputLine.Draw; +VAR Color: Byte; L, R: Sw_Integer; + B : TDrawBuffer; +BEGIN + if Options and ofSelectable = 0 then + Color := GetColor(5) + else + If (State AND sfFocused = 0) Then + Color := GetColor(1) { Not focused colour } + Else + Color := GetColor(2); { Focused colour } + MoveChar(B, ' ', Color, Size.X); + MoveStr(B[1], Copy(Data Sw_PString_DeRef, FirstPos + 1, Size.X - 2), Color); + if CanScroll(1) then + MoveChar(B[Size.X - 1], RightArr, GetColor(4), 1); + if (State and sfFocused <> 0) and + (Options and ofSelectable <> 0) then + begin + if CanScroll(-1) then + MoveChar(B[0], LeftArr, GetColor(4), 1); + { Highlighted part } + L := SelStart - FirstPos; + R := SelEnd - FirstPos; + if L < 0 then + L := 0; + if R > Size.X - 2 then + R := Size.X - 2; + if L < R then + MoveChar(B[L + 1], #0, GetColor(3), R - L); + SetCursor(ScreenCurPos - FirstPos + 1, 0); + end; + WriteLine(0, 0, Size.X, Size.Y, B); +end; +{$endif FV_UNICODE} + + +{--TInputLine---------------------------------------------------------------} +{ DrawCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.DrawCursor; +BEGIN + If (State AND sfFocused <> 0) Then + Begin { Focused window } + Cursor.Y:=0; + Cursor.X:=ScreenCurPos-FirstPos+1; + ResetCursor; + end; +END; + +{--TInputLine---------------------------------------------------------------} +{ SelectAll -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.SelectAll (Enable: Boolean); +BEGIN + CurPos := 0; { Cursor to start } + FirstPos := 0; { First pos to start } + SelStart := 0; { Selected at start } + If Enable AND (Data <> Sw_PString_Empty) Then + SelEnd := Length(Data Sw_PString_DeRef) Else SelEnd := 0; { Selected which end } + DrawView; { Now redraw the view } +END; + +{--TInputLine---------------------------------------------------------------} +{ SetValidator -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.SetValidator (AValid: PValidator); +BEGIN + If (Validator <> Nil) Then Validator^.Free; { Release validator } + Validator := AValid; { Set new validator } +END; + +{--TInputLine---------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.SetState (AState: Word; Enable: Boolean); +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState = sfSelected) OR ((AState = sfActive) + AND (State and sfSelected <> 0)) Then + SelectAll(Enable) Else { Call select all } + If (AState = sfFocused) Then DrawView; { Redraw for focus } +END; + +{--TInputLine---------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.GetData (Var Rec); +BEGIN + If Data <> Sw_PString_Empty Then Begin { Data ptr valid } + If (Validator = Nil) OR (Validator^.Transfer(Data Sw_PString_DeRef, + @Rec, vtGetData) = 0) Then Begin { No validator/data } +{$ifdef FV_UNICODE} + Sw_String(Rec):=Data; +{$else FV_UNICODE} + FillChar(Rec, DataSize, #0); { Clear the data area } + Move(Data^, Rec, Length(Data^) + 1); { Transfer our data } +{$endif FV_UNICODE} + End; + End Else +{$ifdef FV_UNICODE} + Sw_String(Rec):=''; +{$else FV_UNICODE} + FillChar(Rec, DataSize, #0); { Clear the data area } +{$endif FV_UNICODE} +END; + +{--TInputLine---------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.SetData (Var Rec); +BEGIN + If Data <> Sw_PString_Empty Then Begin { Data ptr valid } + If (Validator = Nil) OR (Validator^.Transfer( + Data Sw_PString_DeRef, @Rec, vtSetData) = 0) Then { No validator/data } +{$ifdef FV_UNICODE} + Data := Sw_String(Rec); +{$else FV_UNICODE} + Move(Rec, Data^[0], DataSize); { Set our data } +{$endif FV_UNICODE} + End; + SelectAll(True); { Now select all } +END; + +{--TInputLine---------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.Store (Var S: TStream); +VAR w: Word; +BEGIN + TView.Store(S); { Implict TView.Store } + w:=MaxLen;S.Write(w, SizeOf(w)); { Read max length } + w:=CurPos;S.Write(w, SizeOf(w)); { Read cursor position } + w:=FirstPos;S.Write(w, SizeOf(w)); { Read first position } + w:=SelStart;S.Write(w, SizeOf(w)); { Read selected start } + w:=SelEnd;S.Write(w, SizeOf(w)); { Read selected end } +{$ifdef FV_UNICODE} + S.WriteUnicodeString(Data); { Write the data } +{$else FV_UNICODE} + S.WriteStr(Data); { Write the data } +{$endif FV_UNICODE} + S.Put(Validator); { Write any validator } +END; + +{--TInputLine---------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.HandleEvent (Var Event: TEvent); +CONST PadKeys = [$47, $4B, $4D, $4F, $73, $74]; +VAR WasAppending: Boolean; ExtendBlock: Boolean; OldData: String; +Delta, Anchor, OldCurPos, OldFirstPos, OldSelStart, OldSelEnd: Sw_Integer; + + FUNCTION MouseDelta: Sw_Integer; + VAR Mouse : TPOint; + BEGIN + MakeLocal(Event.Where, Mouse); + if Mouse.X <= 0 then + MouseDelta := -1 + else if Mouse.X >= Size.X - 1 then + MouseDelta := 1 + else + MouseDelta := 0; + END; + +{$ifdef FV_UNICODE} + FUNCTION MousePos: Sw_Integer; + VAR Skip, Pos: Sw_Integer; + Mouse : TPoint; + EGC: Sw_String; + BEGIN + MakeLocal(Event.Where, Mouse); + if Mouse.X < 1 then Mouse.X := 1; + Skip := FirstPos; + Pos := FirstPos; + for EGC in TUnicodeStringExtendedGraphemeClustersEnumerator.Create(Data) do + begin + if Skip > 0 then + Dec(Skip, Length(EGC)) + else + begin + Dec(Mouse.X, EgcWidth(EGC)); + if Mouse.X <= 0 then + break; + Inc(Pos, Length(EGC)); + end; + end; + if Pos < 0 then Pos := 0; + if Pos > Length(Data) then Pos := Length(Data); + MousePos := Pos; + END; +{$else FV_UNICODE} + FUNCTION MousePos: Sw_Integer; + VAR Pos: Sw_Integer; + Mouse : TPoint; + BEGIN + MakeLocal(Event.Where, Mouse); + if Mouse.X < 1 then Mouse.X := 1; + Pos := Mouse.X + FirstPos - 1; + if Pos < 0 then Pos := 0; + if Pos > Length(Data Sw_PString_DeRef) then Pos := Length(Data Sw_PString_DeRef); + MousePos := Pos; + END; +{$endif FV_UNICODE} + + PROCEDURE DeleteSelect; + BEGIN + If (SelStart <> SelEnd) Then Begin { An area selected } + If Data <> Sw_PString_Empty Then + Delete(Data Sw_PString_DeRef, SelStart+1, SelEnd-SelStart); { Delete the text } + CurPos := SelStart; { Set cursor position } + End; + END; + + PROCEDURE AdjustSelectBlock; + BEGIN + If (CurPos < Anchor) Then Begin { Selection backwards } + SelStart := CurPos; { Start of select } + SelEnd := Anchor; { End of select } + End Else Begin + SelStart := Anchor; { Start of select } + SelEnd := CurPos; { End of select } + End; + END; + + PROCEDURE SaveState; + BEGIN + If (Validator <> Nil) Then Begin { Check for validator } + If Data <> Sw_PString_Empty Then OldData := Data Sw_PString_DeRef; { Hold data } + OldCurPos := CurPos; { Hold cursor position } + OldFirstPos := FirstPos; { Hold first position } + OldSelStart := SelStart; { Hold select start } + OldSelEnd := SelEnd; { Hold select end } + If Data = Sw_PString_Empty Then WasAppending := True { Invalid data ptr } + Else WasAppending := Length(Data Sw_PString_DeRef) = CurPos; { Hold appending state } + End; + END; + + PROCEDURE RestoreState; + BEGIN + If (Validator <> Nil) Then Begin { Validator valid } + If Data <> Sw_PString_Empty Then Data Sw_PString_DeRef := OldData; { Restore data } + CurPos := OldCurPos; { Restore cursor pos } + FirstPos := OldFirstPos; { Restore first pos } + SelStart := OldSelStart; { Restore select start } + SelEnd := OldSelEnd; { Restore select end } + End; + END; + + FUNCTION CheckValid (NoAutoFill: Boolean): Boolean; + VAR OldLen: Sw_Integer; NewData: Sw_String; + BEGIN + If (Validator <> Nil) Then Begin { Validator valid } + CheckValid := False; { Preset false return } + If Data <> Sw_PString_Empty Then OldLen := Length(Data Sw_PString_DeRef); { Hold old length } + If (Validator^.Options AND voOnAppend = 0) OR + (WasAppending AND (CurPos = OldLen)) Then Begin + If Data <> Sw_PString_Empty Then NewData := Data Sw_PString_DeRef { Hold current data } + Else NewData := ''; { Set empty string } + If NOT Validator^.IsValidInput(NewData, + NoAutoFill) Then RestoreState Else Begin + If (Length(NewData) > MaxLen) Then { Exceeds maximum } + SetLength(NewData, MaxLen); { Set string length } + If Data <> Sw_PString_Empty Then Data Sw_PString_DeRef := NewData; { Set data value } + If (Data <> Sw_PString_Empty) AND (CurPos >= OldLen) { Cursor beyond end } + AND (Length(Data Sw_PString_DeRef) > OldLen) Then { Cursor beyond string } + CurPos := Length(Data Sw_PString_DeRef); { Set cursor position } + CheckValid := True; { Return true result } + End; + End Else Begin + CheckValid := True; { Preset true return } + If (CurPos = OldLen) AND (Data <> Sw_PString_Empty) Then { Lengths match } + If NOT Validator^.IsValidInput(Data Sw_PString_DeRef, + False) Then Begin { Check validator } + Validator^.Error; { Call error } + CheckValid := False; { Return false result } + End; + End; + End Else CheckValid := True; { No validator } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (State AND sfSelected <> 0) Then Begin { View is selected } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evMouseDown: Begin { Mouse down event } + Delta := MouseDelta; { Calc scroll value } + If CanScroll(Delta) Then Begin { Can scroll } + Repeat + If CanScroll(Delta) Then Begin { Still can scroll } + Inc(FirstPos, Delta); { Move start position } + DrawView; { Redraw the view } + End; + Until NOT MouseEvent(Event, evMouseAuto); { Until no mouse auto } + End Else If Event.Double Then { Double click } + SelectAll(True) Else Begin { Select whole text } + Anchor := MousePos; { Start of selection } + Repeat + If (Event.What = evMouseAuto) { Mouse auto event } + Then Begin + Delta := MouseDelta; { New position } + If CanScroll(Delta) Then { If can scroll } + Inc(FirstPos, Delta); + End; + CurPos := MousePos; { Set cursor position } + AdjustSelectBlock; { Adjust selected } + DrawView; { Redraw the view } + Until NOT MouseEvent(Event, evMouseMove + + evMouseAuto); { Until mouse released } + End; + ClearEvent(Event); { Clear the event } + End; + evKeyDown: Begin + SaveState; { Save state of view } + Event.KeyCode := CtrlToArrow(Event.KeyCode); { Convert keycode } + If (Event.ScanCode IN PadKeys) AND + (GetShiftState AND $03 <> 0) Then Begin { Mark selection active } + Event.CharCode := #0; { Clear char code } + If (CurPos = SelEnd) Then { Find if at end } + Anchor := SelStart Else { Anchor from start } + Anchor := SelEnd; { Anchor from end } + ExtendBlock := True; { Extended block true } + End Else ExtendBlock := False; { No extended block } + Case Event.KeyCode Of + kbLeft: If (CurPos > 0) Then Dec(CurPos); { Move cursor left } + kbRight: If (Data <> Sw_PString_Empty) AND { Move right cursor } + (CurPos < Length(Data Sw_PString_DeRef)) Then Begin { Check not at end } + Inc(CurPos); { Move cursor } + CheckValid(True); { Check if valid } + End; + kbHome: CurPos := 0; { Move to line start } + kbEnd: Begin { Move to line end } + If Data = Sw_PString_Empty Then CurPos := 0 { Invalid data ptr } + Else CurPos := Length(Data Sw_PString_DeRef); { Set cursor position } + CheckValid(True); { Check if valid } + End; + kbBack: If (Data <> Sw_PString_Empty) AND (CurPos > 0) { Not at line start } + Then Begin + Delete(Data Sw_PString_DeRef, CurPos, 1); { Backspace over char } + Dec(CurPos); { Move cursor back one } + If (FirstPos > 0) Then Dec(FirstPos); { Move first position } + CheckValid(True); { Check if valid } + End; + kbDel: If Data <> Sw_PString_Empty Then Begin { Delete character } + If (SelStart = SelEnd) Then { Select all on } + If (CurPos < Length(Data Sw_PString_DeRef)) Then Begin { Cursor not at end } + SelStart := CurPos; { Set select start } + SelEnd := CurPos + 1; { Set select end } + End; + DeleteSelect; { Deselect selection } + CheckValid(True); { Check if valid } + End; + kbIns: SetState(sfCursorIns, State AND + sfCursorIns = 0); { Flip insert state } +{$ifdef FV_UNICODE} + Else Case Event.UnicodeChar Of + ' '..#$FFFF: { Character key } + Begin + If (State AND sfCursorIns <> 0) Then + Delete(Data Sw_PString_DeRef, CurPos + 1, 1) Else { Overwrite character } + DeleteSelect; { Deselect selected } + If CheckValid(True) Then Begin { Check data valid } + If (Length(Data Sw_PString_DeRef) < MaxLen) Then { Must not exceed maxlen } + Begin + If (FirstPos > CurPos) Then + FirstPos := CurPos; { Advance first position } + Inc(CurPos); { Increment cursor } + Insert(Event.UnicodeChar, Data Sw_PString_DeRef, + CurPos); { Insert the character } + End; + CheckValid(False); { Check data valid } + End; + End; + ^Y: If Data <> Sw_PString_Empty Then Begin { Clear all data } + Data Sw_PString_DeRef := ''; { Set empty string } + CurPos := 0; { Cursor to start } + End; + Else Exit; { Unused key } + End +{$else FV_UNICODE} + Else Case Event.CharCode Of + ' '..#255: If Data <> Sw_PString_Empty Then Begin { Character key } + If (State AND sfCursorIns <> 0) Then + Delete(Data Sw_PString_DeRef, CurPos + 1, 1) Else { Overwrite character } + DeleteSelect; { Deselect selected } + If CheckValid(True) Then Begin { Check data valid } + If (Length(Data Sw_PString_DeRef) < MaxLen) Then { Must not exceed maxlen } + Begin + If (FirstPos > CurPos) Then + FirstPos := CurPos; { Advance first position } + Inc(CurPos); { Increment cursor } + Insert(Event.CharCode, Data Sw_PString_DeRef, + CurPos); { Insert the character } + End; + CheckValid(False); { Check data valid } + End; + End; + ^Y: If Data <> Sw_PString_Empty Then Begin { Clear all data } + Data Sw_PString_DeRef := ''; { Set empty string } + CurPos := 0; { Cursor to start } + End; + Else Exit; { Unused key } + End +{$endif FV_UNICODE} + End; + If ExtendBlock Then AdjustSelectBlock { Extended block } + Else Begin + SelStart := CurPos; { Set select start } + SelEnd := CurPos; { Set select end } + End; + If (FirstPos > CurPos) Then + FirstPos := CurPos; { Advance first pos } + If (Data <> Sw_PString_Empty) Then OldData := Copy(Data Sw_PString_DeRef, + FirstPos+1, CurPos-FirstPos) { Text area string } + Else OldData := ''; { Empty string } + Delta := 1; { Safety = 1 char } + While (TextWidth(OldData) > (Size.X-Delta) + - TextWidth(LeftArr) - TextWidth(RightArr)) { Check text fits } + Do Begin + Inc(FirstPos); { Advance first pos } + OldData := Copy(Data Sw_PString_DeRef, FirstPos+1, + CurPos-FirstPos) { Text area string } + End; + DrawView; { Redraw the view } + ClearEvent(Event); { Clear the event } + End; + End; + End; +END; + +{***************************************************************************} +{ TInputLine OBJECT PRIVATE METHODS } +{***************************************************************************} +{--TInputLine---------------------------------------------------------------} +{ CanScroll -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TInputLine.CanScroll (Delta: Sw_Integer): Boolean; +VAR S: Sw_String; +BEGIN + If (Delta < 0) Then CanScroll := FirstPos > 0 { Check scroll left } + Else If (Delta > 0) Then Begin + If Data = Sw_PString_Empty Then S := '' Else { Data ptr invalid } + S := Copy(Data Sw_PString_DeRef, FirstPos+1, Length(Data Sw_PString_DeRef) + - FirstPos); { Fetch max string } + CanScroll := (TextWidth(S)) > (Size.X - + TextWidth(LeftArr) - TextWidth(RightArr)); { Check scroll right } + End Else CanScroll := False; { Zero so no scroll } +END; + +{$ifdef FV_UNICODE} +FUNCTION TInputLine.ScreenCurPos: Sw_Integer; +VAR EGC: Sw_String; StrPos, ScrPos: Sw_Integer; +BEGIN + StrPos := 0; + ScrPos := 0; + for EGC in TUnicodeStringExtendedGraphemeClustersEnumerator.Create(Data) do + begin + if (StrPos + Length(EGC)) > CurPos then + begin + Result := ScrPos; + exit; + end; + Inc(StrPos, Length(EGC)); + Inc(ScrPos, EgcWidth(EGC)); + end; + Result := CurPos - Length(Data) + ScrPos; +END; +{$else FV_UNICODE} +FUNCTION TInputLine.ScreenCurPos: Sw_Integer; +BEGIN + Result := CurPos; +END; +{$endif FV_UNICODE} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TButton OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TButton------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TButton.Init (Var Bounds: TRect; ATitle: TTitleStr; + ACommand: Word; AFlags: Word); +BEGIN + Inherited Init(Bounds); { Call ancestor } + EventMask := EventMask OR evBroadcast; { Handle broadcasts } + Options := Options OR (ofSelectable + ofFirstClick + + ofPreProcess + ofPostProcess); { Set option flags } + If NOT CommandEnabled(ACommand) Then + State := State OR sfDisabled; { Check command state } + Flags := AFlags; { Hold flags } + If (AFlags AND bfDefault <> 0) Then AmDefault := True + Else AmDefault := False; { Check if default } + Title := Sw_NewStr(ATitle); { Hold title string } + Command := ACommand; { Hold button command } + TabMask := TabMask OR (tmLeft + tmRight + + tmTab + tmShiftTab + tmUp + tmDown); { Set tab masks } +END; + +{--TButton------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TButton.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } +{$ifdef FV_UNICODE} + Title := S.ReadUnicodeString; { Read title } +{$else FV_UNICODE} + Title := S.ReadStr; { Read title } +{$endif FV_UNICODE} + S.Read(Command, SizeOf(Command)); { Read command } + S.Read(Flags, SizeOf(Flags)); { Read flags } + S.Read(AmDefault, SizeOf(AmDefault)); { Read if default } + If NOT CommandEnabled(Command) Then { Check command state } + State := State OR sfDisabled Else { Command disabled } + State := State AND NOT sfDisabled; { Command enabled } +END; + +{--TButton------------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TButton.Done; +BEGIN +{$ifndef FV_UNICODE} + If (Title <> Nil) Then DisposeStr(Title); { Dispose title } +{$endif FV_UNICODE} + Inherited Done; { Call ancestor } +END; + +{--TButton------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TButton.GetPalette: PPalette; +CONST P: String[Length(CButton)] = CButton; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Get button palette } +END; + +{--TButton------------------------------------------------------------------} +{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.Press; +VAR E: TEvent; +BEGIN + Message(Owner, evBroadcast, cmRecordHistory, Nil); { Message for history } + If (Flags AND bfBroadcast <> 0) Then { Broadcasting button } + Message(Owner, evBroadcast, Command, @Self) { Send message } + Else Begin + E.What := evCommand; { Command event } + E.Command := Command; { Set command value } + E.InfoPtr := @Self; { Pointer to self } + PutEvent(E); { Put event on queue } + End; +END; + +{--TButton------------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.Draw; +VAR I, J, Pos: Sw_Integer; + Bc: Word; Db: TDrawBuffer; + C : Sw_ExtendedGraphemeCluster; +BEGIN + If (State AND sfDisabled <> 0) Then { Button disabled } + Bc := GetColor($0404) Else Begin { Disabled colour } + Bc := GetColor($0501); { Set normal colour } + If (State AND sfActive <> 0) Then { Button is active } + If (State AND sfSelected <> 0) Then + Bc := GetColor($0703) Else { Set selected colour } + If AmDefault Then Bc := GetColor($0602); { Set is default colour } + End; + if title=Sw_PString_Empty then + begin + MoveChar(Db[0],' ',GetColor(8),1); + {No title, draw an empty button.} + for j:=sw_integer(downflag) to size.x-2 do + MoveChar(Db[j],' ',Bc,1); + end + else + {We have a title.} + begin + If (Flags AND bfLeftJust = 0) Then Begin { Not left set title } + I := CTextWidth(Title Sw_PString_DeRef); { Fetch title width } + I := (Size.X - I) DIV 2; { Centre in button } + End + Else + I := 1; { Left edge of button } + If DownFlag then + begin + MoveChar(Db[0],' ',GetColor(8),1); + Pos:=1; + end + else + pos:=0; + For j:=0 to I-1 do + MoveChar(Db[pos+j],' ',Bc,1); + MoveCStr(Db[I+pos], Title Sw_PString_DeRef, Bc); { Move title to buffer } + For j:=pos+CStrLen(Title Sw_PString_DeRef)+I to size.X-2 do + MoveChar(Db[j],' ',Bc,1); + end; + If not DownFlag then + Bc:=GetColor(8); + MoveChar(Db[Size.X-1],' ',Bc,1); + WriteLine(0, 0, Size.X,1, Db); { Write the title } + If Size.Y>1 then Begin + Bc:=GetColor(8); + if not DownFlag then + begin +{$ifdef FV_UNICODE} + c:=#$2584; +{$else FV_UNICODE} + c:=#220; +{$endif FV_UNICODE} + MoveChar(Db,c,Bc,1); + WriteLine(Size.X-1, 0, 1, 1, Db); + end; + MoveChar(Db,' ',Bc,1); + if DownFlag then c:=' ' +{$ifdef FV_UNICODE} + else c:=#$2580; +{$else FV_UNICODE} + else c:=#223; +{$endif FV_UNICODE} + MoveChar(Db[1],c,Bc,Size.X-1); + WriteLine(0, 1, Size.X, 1, Db); + End; +END; + +{--TButton------------------------------------------------------------------} +{ DrawState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.DrawState (Down: Boolean); +BEGIN + DownFlag := Down; { Set down flag } + DrawView; { Redraw the view } +END; + +{--TButton------------------------------------------------------------------} +{ MakeDefault -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.MakeDefault (Enable: Boolean); +VAR C: Word; +BEGIN + If (Flags AND bfDefault=0) Then Begin { Not default } + If Enable Then C := cmGrabDefault + Else C := cmReleaseDefault; { Change default } + Message(Owner, evBroadcast, C, @Self); { Message to owner } + AmDefault := Enable; { Set default flag } + DrawView; { Now redraw button } + End; +END; + +{--TButton------------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.SetState (AState: Word; Enable: Boolean); +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState AND (sfSelected + sfActive) <> 0) { Changing select } + Then DrawView; { Redraw required } + If (AState AND sfFocused <> 0) Then + MakeDefault(Enable); { Check for default } +END; + +{--TButton------------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.Store (Var S: TStream); +BEGIN + TView.Store(S); { Implict TView.Store } +{$ifdef FV_UNICODE} + S.WriteUnicodeString(Title); { Store title string } +{$else FV_UNICODE} + S.WriteStr(Title); { Store title string } +{$endif FV_UNICODE} + S.Write(Command, SizeOf(Command)); { Store command } + S.Write(Flags, SizeOf(Flags)); { Store flags } + S.Write(AmDefault, SizeOf(AmDefault)); { Store default flag } +END; + +{--TButton------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.HandleEvent (Var Event: TEvent); +VAR Down: Boolean; C: Char; ButRect: TRect; + Mouse : TPoint; +BEGIN + ButRect.A.X := 0; { Get origin point } + ButRect.A.Y := 0; { Get origin point } + ButRect.B.X := Size.X + 2; { Calc right side } + ButRect.B.Y := Size.Y + 1; { Calc bottom } + If (Event.What = evMouseDown) Then Begin { Mouse down event } + MakeLocal(Event.Where, Mouse); + If NOT ButRect.Contains(Mouse) Then Begin { If point not in view } + ClearEvent(Event); { Clear the event } + Exit; { Speed up exit } + End; + End; + If (Flags AND bfGrabFocus <> 0) Then { Check focus grab } + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evMouseDown: Begin + If (State AND sfDisabled = 0) Then Begin { Button not disabled } + Down := False; { Clear down flag } + Repeat + MakeLocal(Event.Where, Mouse); + If (Down <> ButRect.Contains(Mouse)) { State has changed } + Then Begin + Down := NOT Down; { Invert down flag } + DrawState(Down); { Redraw button } + End; + Until NOT MouseEvent(Event, evMouseMove); { Wait for mouse move } + If Down Then Begin { Button is down } + Press; { Send out command } + DrawState(False); { Draw button up } + End; + End; + ClearEvent(Event); { Event was handled } + End; + evKeyDown: Begin + If Title <> Sw_PString_Empty Then C := HotKey(Title Sw_PString_DeRef) { Key title hotkey } + Else C := #0; { Invalid title } + If (Event.KeyCode = GetAltCode(C)) OR { Alt char } + (Owner^.Phase = phPostProcess) AND (C <> #0) + AND (Upcase(Event.CharCode) = C) OR { Matches hotkey } + (State AND sfFocused <> 0) AND { View focused } + ((Event.CharCode = ' ') OR { Space bar } + (Event.KeyCode=kbEnter)) Then Begin { Enter key } + DrawState(True); { Draw button down } + Press; { Send out command } + ClearEvent(Event); { Clear the event } + DrawState(False); { Draw button up } + End; + End; + evBroadcast: + Case Event.Command of + cmDefault: If AmDefault AND { Default command } + (State AND sfDisabled = 0) Then Begin { Button enabled } + Press; { Send out command } + ClearEvent(Event); { Clear the event } + End; + cmGrabDefault, cmReleaseDefault: { Grab and release cmd } + If (Flags AND bfDefault <> 0) Then Begin { Change button state } + AmDefault := Event.Command = cmReleaseDefault; + DrawView; { Redraw the view } + End; + cmCommandSetChanged: Begin { Command set changed } + SetState(sfDisabled, NOT + CommandEnabled(Command)); { Set button state } + DrawView; { Redraw the view } + End; + End; + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TCluster OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +CONST TvClusterClassName = 'TVCLUSTER'; + +{--TCluster-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TCluster.Init (Var Bounds: TRect; AStrings: PSItem); +VAR I: Sw_Integer; P: PSItem; +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR (ofSelectable + ofFirstClick + + ofPreProcess + ofPostProcess + ofVersion20); { Set option masks } + I := 0; { Zero string count } + P := AStrings; { First item } + While (P <> Nil) Do Begin + Inc(I); { Count 1 item } + P := P^.Next; { Move to next item } + End; + Strings.Init(I, 0); { Create collection } + While (AStrings <> Nil) Do Begin + P := AStrings; { Transfer item ptr } + Strings.AtInsert(Strings.Count, AStrings^.Value);{ Insert string } + AStrings := AStrings^.Next; { Move to next item } + Dispose(P); { Dispose prior item } + End; + Sel := 0; + SetCursor(2,0); + ShowCursor; + EnableMask := Sw_Integer($FFFFFFFF); { Enable bit masks } +END; + +{--TCluster-----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TCluster.Load (Var S: TStream); +VAR w: word; +BEGIN + Inherited Load(S); { Call ancestor } + If ((Options AND ofVersion) >= ofVersion20) Then { Version 2 TV view } + Begin + S.Read(Value, SizeOf(Value)); { Read value } + S.Read(Sel, Sizeof(Sel)); { Read select item } + S.Read(EnableMask, SizeOf(EnableMask)) { Read enable masks } + End + Else + Begin + w:=Value; + S.Read(w, SizeOf(w)); Value:=w; { Read value } + S.Read(Sel, SizeOf(Sel)); { Read select item } + EnableMask := Sw_integer($FFFFFFFF); { Enable all masks } + Options := Options OR ofVersion20; { Set version 2 mask } + End; + Strings.Load(S); { Load string data } + SetButtonState(0, True); { Set button state } +END; + +{--TCluster-----------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TCluster.Done; +BEGIN + Strings.Done; { Dispose of strings } + Inherited Done; { Call ancestor } +END; + +{--TCluster-----------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.DataSize: Sw_Word; +BEGIN + DataSize := SizeOf(Sw_Word); { Exchanges a word } +END; + +{--TCluster-----------------------------------------------------------------} +{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.GetHelpCtx: Word; +BEGIN + If (HelpCtx = hcNoContext) Then { View has no help } + GetHelpCtx := hcNoContext Else { No help context } + GetHelpCtx := HelpCtx + Sel; { Help of selected } +END; + +{--TCluster-----------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.GetPalette: PPalette; +CONST P: String[Length(CCluster)] = CCluster; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Cluster palette } +END; + +{--TCluster-----------------------------------------------------------------} +{ Mark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.Mark (Item: Sw_Integer): Boolean; +BEGIN + Mark := False; { Default false } +END; + +{--TCluster-----------------------------------------------------------------} +{ MultiMark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.MultiMark (Item: Sw_Integer): Byte; +BEGIN + MultiMark := Byte(Mark(Item) = True); { Return multi mark } +END; + +{--TCluster-----------------------------------------------------------------} +{ ButtonState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.ButtonState (Item: Sw_Integer): Boolean; +BEGIN + If (Item > 31) Then ButtonState := False Else { Impossible item } + ButtonState := ((1 SHL Item) AND EnableMask)<>0; { Return true/false } +END; + +{--TCluster-----------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.Draw; +BEGIN +END; + +{--TCluster-----------------------------------------------------------------} +{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.Press (Item: Sw_Integer); +VAR P: PView; +BEGIN + P := TopView; + If (Id <> 0) AND (P <> Nil) Then NewMessage(P, + evCommand, cmIdCommunicate, Id, Value, @Self); { Send new message } +END; + +{--TCluster-----------------------------------------------------------------} +{ MovedTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.MovedTo (Item: Sw_Integer); +BEGIN { Abstract method } +END; + +{--TCluster-----------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.SetState (AState: Word; Enable: Boolean); +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState AND sfFocused <> 0) Then Begin + DrawView; { Redraw masked areas } + End; +END; + +{--TCluster-----------------------------------------------------------------} +{ DrawMultiBox -> Platforms DOS/DPMI/WIN/NT - Updated 05Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.DrawMultiBox (Const Icon, Marker: Sw_String); +VAR I, J, Cur, Col: Sw_Integer; CNorm, CSel, CDis, Color: Word; B: TDrawBuffer; +BEGIN + CNorm := GetColor($0301); { Normal colour } + CSel := GetColor($0402); { Selected colour } + CDis := GetColor($0505); { Disabled colour } + For I := 0 To Size.Y-1 Do Begin { For each line } + MoveChar(B, ' ', Byte(CNorm), Size.X); { Fill buffer } + For J := 0 To (Strings.Count - 1) DIV Size.Y + 1 + Do Begin + Cur := J*Size.Y + I; { Current line } + If (Cur < Strings.Count) Then Begin + Col := Column(Cur); { Calc column } + If (Col + CStrLen(Sw_PString(Strings.At(Cur)) Sw_PString_Deref)+ + 5 < Sizeof(TDrawBuffer) DIV SizeOf(Word)) + AND (Col < Size.X) Then Begin { Text fits in column } + If NOT ButtonState(Cur) Then + Color := CDis Else If (Cur = Sel) AND { Disabled colour } + (State and sfFocused <> 0) Then + Color := CSel Else { Selected colour } + Color := CNorm; { Normal colour } + MoveChar(B[Col], ' ', Byte(Color), + Size.X-Col); { Set this colour } + MoveStr(B[Col], Icon, Byte(Color)); { Transfer icon string } +{$ifdef FV_UNICODE} + B[Col+2].ExtendedGraphemeCluster := Marker[ + MultiMark(Cur) + 1]; { Transfer marker } +{$else FV_UNICODE} + WordRec(B[Col+2]).Lo := Byte(Marker[ + MultiMark(Cur) + 1]); { Transfer marker } +{$endif FV_UNICODE} + MoveCStr(B[Col+5], Sw_PString(Strings.At( + Cur)) Sw_PString_Deref, Color); { Transfer item string } + If ShowMarkers AND (State AND sfFocused <> 0) + AND (Cur = Sel) Then Begin { Current is selected } +{$ifdef FV_UNICODE} + B[Col].ExtendedGraphemeCluster := SpecialChars[0]; + B[Column(Cur+Size.Y)-1].ExtendedGraphemeCluster + := SpecialChars[1]; { Set special character } +{$else FV_UNICODE} + WordRec(B[Col]).Lo := Byte(SpecialChars[0]); + WordRec(B[Column(Cur+Size.Y)-1]).Lo + := Byte(SpecialChars[1]); { Set special character } +{$endif FV_UNICODE} + End; + End; + End; + End; + WriteBuf(0, I, Size.X, 1, B); { Write buffer } + End; + SetCursor(Column(Sel)+2,Row(Sel)); +END; + +{--TCluster-----------------------------------------------------------------} +{ DrawBox -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.DrawBox (Const Icon: String; Marker: Char); +BEGIN + DrawMultiBox(Icon, ' '+Marker); { Call draw routine } +END; + +{--TCluster-----------------------------------------------------------------} +{ SetButtonState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.SetButtonState (AMask: Longint; Enable: Boolean); +VAR I: Sw_Integer; M: Longint; +BEGIN + If Enable Then EnableMask := EnableMask OR AMask { Set enable bit mask } + Else EnableMask := EnableMask AND NOT AMask; { Disable bit mask } + If (Strings.Count <= 32) Then Begin { Valid string number } + M := 1; { Preset bit masks } + For I := 1 To Strings.Count Do Begin { For each item string } + If ((M AND EnableMask) <> 0) Then Begin { Bit enabled } + Options := Options OR ofSelectable; { Set selectable option } + Exit; { Now exit } + End; + M := M SHL 1; { Create newbit mask } + End; + Options := Options AND NOT ofSelectable; { Make not selectable } + End; +END; + +{--TCluster-----------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.GetData (Var Rec); +BEGIN + sw_Word(Rec) := Value; { Return current value } +END; + +{--TCluster-----------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.SetData (Var Rec); +BEGIN + Value :=sw_Word(Rec); { Set current value } + DrawView; { Redraw masked areas } +END; + +{--TCluster-----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.Store (Var S: TStream); +var + w : word; +BEGIN + TView.Store(S); { TView.Store called } + If ((Options AND ofVersion) >= ofVersion20) { Version 2 TV view } + Then Begin + S.Write(Value, SizeOf(Value)); { Write value } + S.Write(Sel, SizeOf(Sel)); { Write select item } + S.Write(EnableMask, SizeOf(EnableMask)); { Write enable masks } + End Else Begin + w:=Value; + S.Write(w, SizeOf(Word)); { Write value } + S.Write(Sel, SizeOf(Sel)); { Write select item } + End; + Strings.Store(S); { Store strings } +END; + +{--TCluster-----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.HandleEvent (Var Event: TEvent); +VAR C: Char; I, S, Vh: Sw_Integer; Key: Word; Mouse: TPoint; Ts: PString; + + PROCEDURE MoveSel; + BEGIN + If (I <= Strings.Count) Then Begin + Sel := S; { Set selected item } + MovedTo(Sel); { Move to selected } + DrawView; { Now draw changes } + End; + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If ((Options AND ofSelectable) = 0) Then Exit; { Check selectable } + If (Event.What = evMouseDown) Then Begin { MOUSE EVENT } + MakeLocal(Event.Where, Mouse); { Make point local } + I := FindSel(Mouse); { Find selected item } + If (I <> -1) Then { Check in view } + If ButtonState(I) Then Sel := I; { If enabled select } + DrawView; { Now draw changes } + Repeat + MakeLocal(Event.Where, Mouse); { Make point local } + Until NOT MouseEvent(Event, evMouseMove); { Wait for mouse up } + MakeLocal(Event.Where, Mouse); { Make point local } + If (FindSel(Mouse) = Sel) AND ButtonState(Sel) { If valid/selected } + Then Begin + Press(Sel); { Call pressed } + DrawView; { Now draw changes } + End; + ClearEvent(Event); { Event was handled } + End Else If (Event.What = evKeyDown) Then Begin { KEY EVENT } + Vh := Size.Y; { View height } + S := Sel; { Hold current item } + Key := CtrlToArrow(Event.KeyCode); { Convert keystroke } + Case Key Of + kbUp, kbDown, kbRight, kbLeft: + If (State AND sfFocused <> 0) Then Begin { Focused key event } + I := 0; { Zero process count } + Repeat + Inc(I); { Inc process count } + Case Key Of + kbUp: Dec(S); { Next item up } + kbDown: Inc(S); { Next item down } + kbRight: Begin { Next column across } + Inc(S, Vh); { Move to next column } + If (S >= Strings.Count) Then { No next column check } + S := (S+1) MOD Vh; { Move to last column } + End; + kbLeft: Begin { Prior column across } + Dec(S, Vh); { Move to prior column } + If (S < 0) Then S := ((Strings.Count + + Vh - 1) DIV Vh) * Vh + S - 1; { No prior column check } + End; + End; + If (S >= Strings.Count) Then S := 0; { Roll up to top } + If (S < 0) Then S := Strings.Count - 1; { Roll down to bottom } + Until ButtonState(S) OR (I > Strings.Count); { Repeat until select } + MoveSel; { Move to selected } + ClearEvent(Event); { Event was handled } + End; + Else Begin { Not an arrow key } + For I := 0 To Strings.Count-1 Do Begin { Scan each item } + Ts := Strings.At(I); { Fetch string pointer } + If (Ts <> Nil) Then C := HotKey(Ts^) { Check for hotkey } + Else C := #0; { No valid string } + If (GetAltCode(C) = Event.KeyCode) OR { Hot key for item } + (((Owner^.Phase = phPostProcess) OR { Owner in post process } + (State AND sfFocused <> 0)) AND (C <> #0) { Non zero hotkey } + AND (UpCase(Event.CharCode) = C)) { Matches current key } + Then Begin + If ButtonState(I) Then Begin { Check mask enabled } + If Focus Then Begin { Check view focus } + Sel := I; { Set selected } + MovedTo(Sel); { Move to selected } + Press(Sel); { Call pressed } + DrawView; { Now draw changes } + End; + ClearEvent(Event); { Event was handled } + End; + Exit; { Now exit } + End; + End; + If (Event.CharCode = ' ') AND { Spacebar key } + (State AND sfFocused <> 0) AND { Check focused view } + ButtonState(Sel) Then Begin { Check item enabled } + Press(Sel); { Call pressed } + DrawView; { Now draw changes } + ClearEvent(Event); { Event was handled } + End; + End; + End; + End; +END; + +{***************************************************************************} +{ TCluster OBJECT PRIVATE METHODS } +{***************************************************************************} + +{--TCluster-----------------------------------------------------------------} +{ FindSel -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.FindSel (P: TPoint): Sw_Integer; +VAR I, S, Vh: Sw_Integer; R: TRect; +BEGIN + GetExtent(R); { Get view extents } + If R.Contains(P) Then Begin { Point in view } + Vh := Size.Y; { View height } + I := 0; { Preset zero value } + While (P.X >= Column(I+Vh)) Do Inc(I, Vh); { Inc view size } + S := I + P.Y; { Line to select } + If ((S >= 0) AND (S < Strings.Count)) { Valid selection } + Then FindSel := S Else FindSel := -1; { Return selected item } + End Else FindSel := -1; { Point outside view } +END; + +{--TCluster-----------------------------------------------------------------} +{ Row -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.Row (Item: Sw_Integer): Sw_Integer; +BEGIN + Row := Item MOD Size.Y; { Normal mod value } +END; + +{--TCluster-----------------------------------------------------------------} +{ Column -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.Column (Item: Sw_Integer): Sw_Integer; +VAR I, Col, Width, L, Vh: Sw_Integer; Ts: PString; +BEGIN + Vh := Size.Y; { Vertical size } + If (Item >= Vh) Then Begin { Valid selection } + Width := 0; { Zero width } + Col := -6; { Start column at -6 } + For I := 0 To Item Do Begin { For each item } + If (I MOD Vh = 0) Then Begin { Start next column } + Inc(Col, Width + 6); { Add column width } + Width := 0; { Zero width } + End; + If (I < Strings.Count) Then Begin { Valid string } + Ts := Strings.At(I); { Transfer string } + If (Ts <> Nil) Then L := CStrLen(Ts^) { Length of string } + Else L := 0; { No string } + End; + If (L > Width) Then Width := L; { Hold longest string } + End; + Column := Col; { Return column } + End Else Column := 0; { Outside select area } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TRadioButtons OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TRadioButtons------------------------------------------------------------} +{ Mark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRadioButtons.Mark (Item: Sw_Integer): Boolean; +BEGIN + Mark := Item = Value; { True if item = value } +END; + +{--TRadioButtons------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRadioButtons.Draw; +CONST Button = ' ( ) '; +BEGIN + Inherited Draw; + DrawMultiBox(Button, ' *'); { Redraw the text } +END; + +{--TRadioButtons------------------------------------------------------------} +{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRadioButtons.Press (Item: Sw_Integer); +BEGIN + Value := Item; { Set value field } + Inherited Press(Item); { Call ancestor } +END; + +{--TRadioButtons------------------------------------------------------------} +{ MovedTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRadioButtons.MovedTo (Item: Sw_Integer); +BEGIN + Value := Item; { Set value to item } + If (Id <> 0) Then NewMessage(Owner, evCommand, + cmIdCommunicate, Id, Value, @Self); { Send new message } +END; + +{--TRadioButtons------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRadioButtons.SetData (Var Rec); +BEGIN + Sel := Sw_word(Rec); { Set selection } + Inherited SetData(Rec); { Call ancestor } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TCheckBoxes OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TCheckBoxes--------------------------------------------------------------} +{ Mark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCheckBoxes.Mark(Item: Sw_Integer): Boolean; +BEGIN + If (Value AND (1 SHL Item) <> 0) Then { Check if item ticked } + Mark := True Else Mark := False; { Return result } +END; + +{--TCheckBoxes--------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCheckBoxes.Draw; +CONST Button = ' [ ] '; +BEGIN + Inherited Draw; + DrawMultiBox(Button, ' X'); { Redraw the text } +END; + +{--TCheckBoxes--------------------------------------------------------------} +{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCheckBoxes.Press (Item: Sw_Integer); +BEGIN + Value := Value XOR (1 SHL Item); { Flip the item mask } + Inherited Press(Item); { Call ancestor } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMultiCheckBoxes OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Jun98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMultiCheckBoxes.Init (Var Bounds: TRect; AStrings: PSItem; +ASelRange: Byte; AFlags: Word; Const AStates: String); +BEGIN + Inherited Init(Bounds, AStrings); { Call ancestor } + SelRange := ASelRange; { Hold select range } + Flags := AFlags; { Hold flags } + States := Sw_NewStr(AStates); { Hold string } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMultiCheckBoxes.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(SelRange, SizeOf(SelRange)); { Read select range } + S.Read(Flags, SizeOf(Flags)); { Read flags } +{$ifdef FV_UNICODE} + States := S.ReadUnicodeString; { Read strings } +{$else FV_UNICODE} + States := S.ReadStr; { Read strings } +{$endif FV_UNICODE} +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TMultiCheckBoxes.Done; +BEGIN +{$ifndef FV_UNICODE} + If (States <> Nil) Then DisposeStr(States); { Dispose strings } +{$endif FV_UNICODE} + Inherited Done; { Call ancestor } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMultiCheckBoxes.DataSize: Sw_Word; +BEGIN + DataSize := SizeOf(LongInt); { Size to exchange } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ MultiMark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMultiCheckBoxes.MultiMark (Item: Sw_Integer): Byte; +BEGIN + MultiMark := (Value SHR (Word(Item) * + WordRec(Flags).Hi)) AND WordRec(Flags).Lo; { Return mark state } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMultiCheckBoxes.Draw; +CONST Button = ' [ ] '; +BEGIN + Inherited Draw; + DrawMultiBox(Button, States Sw_PString_DeRef); { Draw the items } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMultiCheckBoxes.Press (Item: Sw_Integer); +VAR CurState: ShortInt; +BEGIN + CurState := (Value SHR (Word(Item) * + WordRec(Flags).Hi)) AND WordRec(Flags).Lo; { Hold current state } + Dec(CurState); { One down } + If (CurState >= SelRange) OR (CurState < 0) Then + CurState := SelRange - 1; { Roll if needed } + Value := (Value AND NOT (LongInt(WordRec(Flags).Lo) + SHL (Word(Item) * WordRec(Flags).Hi))) OR + (LongInt(CurState) SHL (Word(Item) * + WordRec(Flags).Hi)); { Calculate value } + Inherited Press(Item); { Call ancestor } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMultiCheckBoxes.GetData (Var Rec); +BEGIN + Longint(Rec) := Value; { Return value } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMultiCheckBoxes.SetData (Var Rec); +BEGIN + Value := Longint(Rec); { Set value } + DrawView; { Redraw masked areas } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMultiCheckBoxes.Store (Var S: TStream); +BEGIN + TCluster.Store(S); { TCluster store called } + S.Write(SelRange, SizeOf(SelRange)); { Write select range } + S.Write(Flags, SizeOf(Flags)); { Write select flags } +{$ifdef FV_UNICODE} + S.WriteUnicodeString(States); { Write strings } +{$else FV_UNICODE} + S.WriteStr(States); { Write strings } +{$endif FV_UNICODE} +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TListBox OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +TYPE + TListBoxRec = PACKED RECORD + List: PCollection; { List collection ptr } + Selection: sw_integer; { Selected item } + END; + +{--TListBox-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TListBox.Init (Var Bounds: TRect; ANumCols: Sw_Word; + AScrollBar: PScrollBar); +BEGIN + Inherited Init(Bounds, ANumCols, Nil, AScrollBar); { Call ancestor } + SetRange(0); { Set range to zero } +END; + +{--TListBox-----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TListBox.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + List := PCollection(S.Get); { Fetch collection } +END; + +{--TListBox-----------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/Os2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TListBox.DataSize: Sw_Word; +BEGIN + DataSize := SizeOf(TListBoxRec); { Xchg data size } +END; + +{--TListBox-----------------------------------------------------------------} +{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TListBox.GetText (Item: Sw_Integer; MaxLen: Sw_Integer): Sw_String; +VAR P: Sw_PString; +BEGIN + GetText := ''; { Preset return } + If (List <> Nil) Then Begin { A list exists } + P := Sw_PString(List^.At(Item)); { Get string ptr } + If (P <> Sw_PString_Empty) Then GetText := P Sw_PString_DeRef; { Return string } + End; +END; + +{--TListBox-----------------------------------------------------------------} +{ NewList -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListBox.NewList (AList: PCollection); +BEGIN + If (List <> Nil) Then Dispose(List, Done); { Dispose old list } + List := AList; { Hold new list } + If (AList <> Nil) Then SetRange(AList^.Count) { Set new item range } + Else SetRange(0); { Set zero range } + If (Range > 0) Then FocusItem(0); { Focus first item } + DrawView; { Redraw all view } +END; + +{--TListBox-----------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListBox.GetData (Var Rec); +BEGIN + TListBoxRec(Rec).List := List; { Return current list } + TListBoxRec(Rec).Selection := Focused; { Return focused item } +END; + +{--TListBox-----------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListBox.SetData (Var Rec); +BEGIN + NewList(TListBoxRec(Rec).List); { Hold new list } + FocusItem(TListBoxRec(Rec).Selection); { Focus selected item } + DrawView; { Redraw all view } +END; + +{--TListBox-----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListBox.Store (Var S: TStream); +BEGIN + TListViewer.Store(S); { TListViewer store } + S.Put(List); { Store list to stream } +END; + +{****************************************************************************} +{ TListBox.DeleteFocusedItem } +{****************************************************************************} +procedure TListBox.DeleteFocusedItem; +begin + DeleteItem(Focused); +end; + +{****************************************************************************} +{ TListBox.DeleteItem } +{****************************************************************************} +procedure TListBox.DeleteItem (Item : Sw_Integer); +begin + if (List <> nil) and (List^.Count > 0) and + ((Item < List^.Count) and (Item > -1)) then begin + if IsSelected(Item) and (Item > 0) then + FocusItem(Item - 1); + List^.AtDelete(Item); + SetRange(List^.Count); + end; +end; + +{****************************************************************************} +{ TListBox.FreeAll } +{****************************************************************************} +procedure TListBox.FreeAll; +begin + if (List <> nil) then + begin + List^.FreeAll; + SetRange(List^.Count); + end; +end; + +{****************************************************************************} +{ TListBox.FreeFocusedItem } +{****************************************************************************} +procedure TListBox.FreeFocusedItem; +begin + FreeItem(Focused); +end; + +{****************************************************************************} +{ TListBox.FreeItem } +{****************************************************************************} +procedure TListBox.FreeItem (Item : Sw_Integer); +begin + if (Item > -1) and (Item < Range) then + begin + List^.AtFree(Item); + if (Range > 1) and (Focused >= List^.Count) then + Dec(Focused); + SetRange(List^.Count); + end; +end; + +{****************************************************************************} +{ TListBox.SetFocusedItem } +{****************************************************************************} +procedure TListBox.SetFocusedItem (Item : Pointer); +begin + FocusItem(List^.IndexOf(Item)); +end; + +{****************************************************************************} +{ TListBox.GetFocusedItem } +{****************************************************************************} +function TListBox.GetFocusedItem : Pointer; +begin + if (List = nil) or (List^.Count = 0) then + GetFocusedItem := nil + else GetFocusedItem := List^.At(Focused); +end; + +{****************************************************************************} +{ TListBox.Insert } +{****************************************************************************} +procedure TListBox.Insert (Item : Pointer); +begin + if (List <> nil) then + begin + List^.Insert(Item); + SetRange(List^.Count); + end; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStaticText OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TStaticText--------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStaticText.Init (Var Bounds: TRect; Const AText: Sw_String); +BEGIN + Inherited Init(Bounds); { Call ancestor } + Text := Sw_NewStr(AText); { Create string ptr } +END; + +{--TStaticText--------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStaticText.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } +{$ifdef FV_UNICODE} + Text := S.ReadUnicodeString; { Read text string } +{$else FV_UNICODE} + Text := S.ReadStr; { Read text string } +{$endif FV_UNICODE} +END; + +{--TStaticText--------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TStaticText.Done; +BEGIN +{$ifndef FV_UNICODE} + If (Text <> Nil) Then DisposeStr(Text); { Dispose string } +{$endif FV_UNICODE} + Inherited Done; { Call ancestor } +END; + +{--TStaticText--------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStaticText.GetPalette: PPalette; +CONST P: String[Length(CStaticText)] = CStaticText; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TStaticText--------------------------------------------------------------} +{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +{$ifdef FV_UNICODE} +PROCEDURE TStaticText.Draw; +VAR Just: Byte; I, J, P, Y, CurLineWidth, NextLineWidth, LastWordBoundaryLen, + LastWordBoundaryWidth, LastTruncatedBoundaryLen, LastTruncatedBoundaryWidth: Sw_Integer; + S, EGC, CurLine, NextLine: Sw_String; + B : TDrawBuffer; + Color : Byte; + AtStartOfLine: Boolean; + + procedure BeginNewLine; + begin + MoveChar(B, ' ', Color, Size.X); + CurLine := NextLine; + CurLineWidth := NextLineWidth; + LastWordBoundaryLen := 0; + LastWordBoundaryWidth := 0; + Just := 0; { Default left justify } + AtStartOfLine := True; + end; + + procedure FinishLine; + begin + if CurLine <> '' then + begin + Case Just Of + 0: J := 0; { Left justify } + 1: J := (Size.X - CurLineWidth) DIV 2; { Centre justify } + 2: J := Size.X - CurLineWidth; { Right justify } + End; + MoveStr(B[J], CurLine, Color); + end; + + WriteLine(0, Y, Size.X, 1, B); + Inc(Y); { Next line } + end; + +BEGIN + GetText(S); { Fetch text to write } + Color := GetColor(1); + if (Size.X <= 0) or (Size.Y <= 0) then + exit; + P := 1; { X start position } + Y := 0; { Y start position } + LastWordBoundaryLen := 0; + LastWordBoundaryWidth := 0; + LastTruncatedBoundaryLen := 0; + LastTruncatedBoundaryWidth := 0; + NextLine := ''; + NextLineWidth := 0; + BeginNewLine; + for EGC in TUnicodeStringExtendedGraphemeClustersEnumerator.Create(S) do + begin + if AtStartOfLine and ((EGC = #2) or (EGC = #3)) then + begin + AtStartOfLine := False; + if EGC = #2 then + Just := 2 { Set right justify } + else if EGC = #3 then + Just := 1; { Set centre justify } + end + else + begin + AtStartOfLine := False; + if (EGC <> #13) and (EGC <> #10) then + begin + if EGC = ' ' then + begin + LastWordBoundaryLen := Length(CurLine); + LastWordBoundaryWidth := CurLineWidth; + end; + CurLine := CurLine + EGC; + Inc(CurLineWidth, EgcWidth(EGC)); + if CurLineWidth <= Size.X then + begin + LastTruncatedBoundaryLen := Length(CurLine); + LastTruncatedBoundaryWidth := CurLineWidth; + end; + end; + if (CurLineWidth >= Size.X) or (EGC = #13) then + begin + if CurLineWidth >= Size.X then + begin + if LastWordBoundaryLen > 0 then + begin + NextLine := Copy(CurLine, LastWordBoundaryLen + 1, Length(CurLine) - LastWordBoundaryLen); + NextLineWidth := CurLineWidth - LastWordBoundaryWidth; + Delete(CurLine, LastWordBoundaryLen + 1, Length(CurLine) - LastWordBoundaryLen); + CurLineWidth := LastWordBoundaryWidth; + end + else + begin + NextLine := Copy(CurLine, LastTruncatedBoundaryLen + 1, Length(CurLine) - LastTruncatedBoundaryLen); + NextLineWidth := CurLineWidth - LastTruncatedBoundaryWidth; + Delete(CurLine, LastTruncatedBoundaryLen + 1, Length(CurLine) - LastTruncatedBoundaryLen); + CurLineWidth := LastTruncatedBoundaryWidth; + end; + end + else + begin + NextLine := ''; + NextLineWidth := 0; + end; + LastWordBoundaryLen := 0; + LastWordBoundaryWidth := 0; + LastTruncatedBoundaryLen := 0; + LastTruncatedBoundaryWidth := 0; + FinishLine; + if Y >= Size.Y then + exit; + BeginNewLine; + end; + end; + end; + FinishLine; +END; +{$else FV_UNICODE} +PROCEDURE TStaticText.Draw; +VAR Just: Byte; I, J, P, Y, L: Sw_Integer; S: Sw_String; + B : TDrawBuffer; + Color : Byte; +BEGIN + GetText(S); { Fetch text to write } + Color := GetColor(1); + P := 1; { X start position } + Y := 0; { Y start position } + L := Length(S); { Length of text } + While (Y < Size.Y) Do Begin + MoveChar(B, ' ', Color, Size.X); + if P <= L then + begin + Just := 0; { Default left justify } + If (S[P] = #2) Then Begin { Right justify char } + Just := 2; { Set right justify } + Inc(P); { Next character } + End; + If (S[P] = #3) Then Begin { Centre justify char } + Just := 1; { Set centre justify } + Inc(P); { Next character } + End; + I := P; { Start position } + repeat + J := P; + while (P <= L) and (S[P] = ' ') do + Inc(P); + while (P <= L) and (S[P] <> ' ') and (S[P] <> #13) do + Inc(P); + until (P > L) or (P >= I + Size.X) or (S[P] = #13); + If P > I + Size.X Then { Text to long } + If J > I Then + P := J + Else + P := I + Size.X; + Case Just Of + 0: J := 0; { Left justify } + 1: J := (Size.X - (P-I)) DIV 2; { Centre justify } + 2: J := Size.X - (P-I); { Right justify } + End; + MoveBuf(B[J], S[I], Color, P - I); + While (P <= L) AND (P-I <= Size.X) AND ((S[P] = #13) OR (S[P] = #10)) + Do Inc(P); { Remove CR/LF } + End; + WriteLine(0, Y, Size.X, 1, B); + Inc(Y); { Next line } + End; +END; +{$endif FV_UNICODE} + +{--TStaticText--------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStaticText.Store (Var S: TStream); +BEGIN + TView.Store(S); { Call TView store } +{$ifdef FV_UNICODE} + S.WriteUnicodeString(Text); { Write text string } +{$else FV_UNICODE} + S.WriteStr(Text); { Write text string } +{$endif FV_UNICODE} +END; + +{--TStaticText--------------------------------------------------------------} +{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStaticText.GetText (Var S: Sw_String); +BEGIN +{$ifdef FV_UNICODE} + S := Text; { Copy text string } +{$else FV_UNICODE} + If (Text <> Nil) Then S := Text^ { Copy text string } + Else S := ''; { Return empty string } +{$endif FV_UNICODE} +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TParamText OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TParamText---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TParamText.Init (Var Bounds: TRect; Const AText: Sw_String; + AParamCount: Sw_Integer); +BEGIN + Inherited Init(Bounds, AText); { Call ancestor } + ParamCount := AParamCount; { Hold param count } +END; + +{--TParamText---------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TParamText.Load (Var S: TStream); +VAR w: Word; +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(w, SizeOf(w)); ParamCount:=w; { Read parameter count } +END; + +{--TParamText---------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TParamText.DataSize: Sw_Word; +BEGIN + DataSize := ParamCount * SizeOf(Pointer); { Return data size } +END; + +{--TParamText---------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TParamText.GetData (Var Rec); +BEGIN + Pointer(Rec) := @ParamList; { Return parm ptr } +END; + +{--TParamText---------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TParamText.SetData (Var Rec); +BEGIN + ParamList := @Rec; { Fetch parameter list } + DrawView; { Redraw all the view } +END; + +{--TParamText---------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TParamText.Store (Var S: TStream); +VAR w: Word; +BEGIN + TStaticText.Store(S); { Statictext store } + w:=ParamCount;S.Write(w, SizeOf(w)); { Store param count } +END; + +{--TParamText---------------------------------------------------------------} +{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TParamText.GetText (Var S: Sw_String); +BEGIN + If (Text = Sw_PString_Empty) Then S := '' Else { Return empty string } + FormatStr(S, Text Sw_PString_DeRef, ParamList^); { Return text string } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TLabel OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TLabel-------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TLabel.Init (Var Bounds: TRect; CONST AText: Sw_String; ALink: PView); +BEGIN + Inherited Init(Bounds, AText); { Call ancestor } + Link := ALink; { Hold link } + Options := Options OR (ofPreProcess+ofPostProcess);{ Set pre/post process } + EventMask := EventMask OR evBroadcast; { Sees broadcast events } +END; + +{--TLabel-------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TLabel.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + GetPeerViewPtr(S, Link); { Load link view } +END; + +{--TLabel-------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TLabel.GetPalette: PPalette; +CONST P: String[Length(CLabel)] = CLabel; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TLabel-------------------------------------------------------------------} +{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TLabel.Draw; +VAR SCOff: Byte; Color: Word; B: TDrawBuffer; +BEGIN + If Light Then Begin { Light colour select } + Color := GetColor($0402); { Choose light colour } + SCOff := 0; { Zero offset } + End Else Begin + Color := GetColor($0301); { Darker colour } + SCOff := 4; { Set offset } + End; + MoveChar(B[0], ' ', Byte(Color), Size.X); { Clear the buffer } + If (Text <> Sw_PString_Empty) Then MoveCStr(B[1], Text Sw_PString_DeRef, Color);{ Transfer label text } + If ShowMarkers Then +{$ifdef FV_UNICODE} + B[0].ExtendedGraphemeCluster := SpecialChars[SCOff]; { Show marker if req } +{$else FV_UNICODE} + WordRec(B[0]).Lo := Byte(SpecialChars[SCOff]); { Show marker if req } +{$endif FV_UNICODE} + WriteLine(0, 0, Size.X, 1, B); { Write the text } +END; + +{--TLabel-------------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TLabel.Store (Var S: TStream); +BEGIN + TStaticText.Store(S); { TStaticText.Store } + PutPeerViewPtr(S, Link); { Store link view } +END; + +{--TLabel-------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TLabel.HandleEvent (Var Event: TEvent); +VAR C: Char; + + PROCEDURE FocusLink; + BEGIN + If (Link <> Nil) AND (Link^.Options AND + ofSelectable <> 0) Then Link^.Focus; { Focus link view } + ClearEvent(Event); { Clear the event } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evMouseDown: FocusLink; { Focus link view } + evKeyDown: + Begin + if text<>Sw_PString_Empty then + begin + C := HotKey(Text Sw_PString_DeRef); { Check for hotkey } + If (GetAltCode(C) = Event.KeyCode) OR { Alt plus char } + ((C <> #0) AND (Owner^.Phase = phPostProcess) { Post process phase } + AND (UpCase(Event.CharCode) = C)) Then { Upper case match } + FocusLink; { Focus link view } + end; + end; + evBroadcast: If ((Event.Command = cmReceivedFocus) + OR (Event.Command = cmReleasedFocus)) AND { Focus state change } + (Link <> Nil) Then Begin + Light := Link^.State AND sfFocused <> 0; { Change light state } + DrawView; { Now redraw change } + End; + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ THistoryViewer OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--THistoryViewer-----------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR THistoryViewer.Init (Var Bounds: TRect; AHScrollBar, +AVScrollBar: PScrollBar; AHistoryId: Word); +BEGIN + Inherited Init(Bounds, 1, AHScrollBar, + AVScrollBar); { Call ancestor } + HistoryId := AHistoryId; { Hold history id } + SetRange(HistoryCount(AHistoryId)); { Set history range } + If (Range > 1) Then FocusItem(1); { Set to item 1 } + If (HScrollBar <> Nil) Then + HScrollBar^.SetRange(1, HistoryWidth-Size.X + 3);{ Set scrollbar range } +END; + +{--THistoryViewer-----------------------------------------------------------} +{ HistoryWidth -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistoryViewer.HistoryWidth: Sw_Integer; +VAR Width, T, Count, I: Sw_Integer; +BEGIN + Width := 0; { Zero width variable } + Count := HistoryCount(HistoryId); { Hold count value } + For I := 0 To Count-1 Do Begin { For each item } + T := Length(HistoryStr(HistoryId, I)); { Get width of item } + If (T > Width) Then Width := T; { Set width to max } + End; + HistoryWidth := Width; { Return max item width } +END; + +{--THistoryViewer-----------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistoryViewer.GetPalette: PPalette; +CONST P: String[Length(CHistoryViewer)] = CHistoryViewer;{ Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--THistoryViewer-----------------------------------------------------------} +{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistoryViewer.GetText (Item: Sw_Integer; MaxLen: Sw_Integer): Sw_String; +BEGIN + GetText := HistoryStr(HistoryId, Item); { Return history string } +END; + +{--THistoryViewer-----------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THistoryViewer.HandleEvent (Var Event: TEvent); +BEGIN + If ((Event.What = evMouseDown) AND (Event.Double)) { Double click mouse } + OR ((Event.What = evKeyDown) AND + (Event.KeyCode = kbEnter)) Then Begin { Enter key press } + EndModal(cmOk); { End with cmOk } + ClearEvent(Event); { Event was handled } + End Else If ((Event.What = evKeyDown) AND + (Event.KeyCode = kbEsc)) OR { Esc key press } + ((Event.What = evCommand) AND + (Event.Command = cmCancel)) Then Begin { Cancel command } + EndModal(cmCancel); { End with cmCancel } + ClearEvent(Event); { Event was handled } + End Else Inherited HandleEvent(Event); { Call ancestor } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ THistoryWindow OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--THistoryWindow-----------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR THistoryWindow.Init (Var Bounds: TRect; HistoryId: Word); +BEGIN + Inherited Init(Bounds, '', wnNoNumber); { Call ancestor } + Flags := wfClose; { Close flag only } + InitViewer(HistoryId); { Create list view } +END; + +{--THistoryWindow-----------------------------------------------------------} +{ GetSelection -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistoryWindow.GetSelection: Sw_String; +BEGIN + If (Viewer = Nil) Then GetSelection := '' Else { Return empty string } + GetSelection := Viewer^.GetText(Viewer^.Focused, + 255); { Get focused string } +END; + +{--THistoryWindow-----------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistoryWindow.GetPalette: PPalette; +CONST P: String[Length(CHistoryWindow)] = CHistoryWindow;{ Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return the palette } +END; + +{--THistoryWindow-----------------------------------------------------------} +{ InitViewer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THistoryWindow.InitViewer(HistoryId: Word); +VAR R: TRect; +BEGIN + GetExtent(R); { Get extents } + R.Grow(-1,-1); { Grow inside } + Viewer := New(PHistoryViewer, Init(R, + StandardScrollBar(sbHorizontal + sbHandleKeyboard), + StandardScrollBar(sbVertical + sbHandleKeyboard), + HistoryId)); { Create the viewer } + If (Viewer <> Nil) Then Insert(Viewer); { Insert viewer } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ THistory OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--THistory-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR THistory.Init (Var Bounds: TRect; ALink: PInputLine; +AHistoryId: Word); +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR ofPostProcess; { Set post process } + EventMask := EventMask OR evBroadcast; { See broadcast events } + Link := ALink; { Hold link view } + HistoryId := AHistoryId; { Hold history id } +END; + +{--THistory-----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR THistory.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + GetPeerViewPtr(S, Link); { Load link view } + S.Read(HistoryId, SizeOf(HistoryId)); { Read history id } +END; + +{--THistory-----------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistory.GetPalette: PPalette; +CONST P: String[Length(CHistory)] = CHistory; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return the palette } +END; + +{--THistory-----------------------------------------------------------------} +{ InitHistoryWindow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistory.InitHistoryWindow (Var Bounds: TRect): PHistoryWindow; +VAR P: PHistoryWindow; +BEGIN + P := New(PHistoryWindow, Init(Bounds, HistoryId)); { Create history window } + If (Link <> Nil) Then + P^.HelpCtx := Link^.HelpCtx; { Set help context } + InitHistoryWindow := P; { Return history window } +END; + +PROCEDURE THistory.Draw; +VAR B: TDrawBuffer; +BEGIN + MoveCStr(B,#222'~v~'#221, GetColor($0102)); { Set buffer data } + WriteLine(0, 0, Size.X, Size.Y, B); { Write buffer } +END; + +{--THistory-----------------------------------------------------------------} +{ RecordHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THistory.RecordHistory (CONST S: Sw_String); +BEGIN + HistoryAdd(HistoryId, S); { Add to history } +END; + +{--THistory-----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THistory.Store (Var S: TStream); +BEGIN + TView.Store(S); { TView.Store called } + PutPeerViewPtr(S, Link); { Store link view } + S.Write(HistoryId, SizeOf(HistoryId)); { Store history id } +END; + +{--THistory-----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THistory.HandleEvent (Var Event: TEvent); +VAR C: Word; Rslt: String; R, P: TRect; HistoryWindow: PHistoryWindow; +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Link = Nil) Then Exit; { No link view exits } + If (Event.What = evMouseDown) OR { Mouse down event } + ((Event.What = evKeyDown) AND + (CtrlToArrow(Event.KeyCode) = kbDown) AND { Down arrow key } + (Link^.State AND sfFocused <> 0)) Then Begin { Link view selected } + If NOT Link^.Focus Then Begin + ClearEvent(Event); { Event was handled } + Exit; { Now exit } + End; + RecordHistory(Link^.Data Sw_PString_DeRef); { Record current data } + Link^.GetBounds(R); { Get view bounds } + Dec(R.A.X); { One char in from us } + Inc(R.B.X); { One char short of us } + Inc(R.B.Y, 7); { Seven lines down } + Dec(R.A.Y,1); { One line below us } + Owner^.GetExtent(P); { Get owner extents } + R.Intersect(P); { Intersect views } + Dec(R.B.Y,1); { Shorten length by one } + HistoryWindow := InitHistoryWindow(R); { Create history window } + If (HistoryWindow <> Nil) Then Begin { Window crested okay } + C := Owner^.ExecView(HistoryWindow); { Execute this window } + If (C = cmOk) Then Begin { Result was okay } + Rslt := HistoryWindow^.GetSelection; { Get history selection } + If Length(Rslt) > Link^.MaxLen Then + SetLength(Rslt, Link^.MaxLen); { Hold new length } + Link^.Data Sw_PString_DeRef := Rslt; { Hold new selection } + Link^.SelectAll(True); { Select all string } + Link^.DrawView; { Redraw link view } + End; + Dispose(HistoryWindow, Done); { Dispose of window } + End; + ClearEvent(Event); { Event was handled } + End Else If (Event.What = evBroadcast) Then { Broadcast event } + If ((Event.Command = cmReleasedFocus) AND + (Event.InfoPtr = Link)) OR + (Event.Command = cmRecordHistory) Then { Record command } + RecordHistory(Link^.Data Sw_PString_DeRef); { Record the history } +END; + +{****************************************************************************} +{ TBrowseButton Object } +{****************************************************************************} +{****************************************************************************} +{ TBrowseButton.Init } +{****************************************************************************} +constructor TBrowseButton.Init(var Bounds: TRect; ATitle: TTitleStr; + ACommand: Word; AFlags: Byte; ALink: PBrowseInputLine); +begin + if not inherited Init(Bounds,ATitle,ACommand,AFlags) then + Fail; + Link := ALink; +end; + +{****************************************************************************} +{ TBrowseButton.Load } +{****************************************************************************} +constructor TBrowseButton.Load(var S: TStream); +begin + if not inherited Load(S) then + Fail; + GetPeerViewPtr(S,Link); +end; + +{****************************************************************************} +{ TBrowseButton.Press } +{****************************************************************************} +procedure TBrowseButton.Press; +var + E: TEvent; +begin + Message(Owner, evBroadcast, cmRecordHistory, nil); + if Flags and bfBroadcast <> 0 then + Message(Owner, evBroadcast, Command, Link) else + begin + E.What := evCommand; + E.Command := Command; + E.InfoPtr := Link; + PutEvent(E); + end; +end; + +{****************************************************************************} +{ TBrowseButton.Store } +{****************************************************************************} +procedure TBrowseButton.Store(var S: TStream); +begin + inherited Store(S); + PutPeerViewPtr(S,Link); +end; + + +{****************************************************************************} +{ TBrowseInputLine Object } +{****************************************************************************} +{****************************************************************************} +{ TBrowseInputLine.Init } +{****************************************************************************} +constructor TBrowseInputLine.Init(var Bounds: TRect; AMaxLen: Sw_Integer; AHistory: Sw_Word); +begin + if not inherited Init(Bounds,AMaxLen) then + Fail; + History := AHistory; +end; + +{****************************************************************************} +{ TBrowseInputLine.Load } +{****************************************************************************} +constructor TBrowseInputLine.Load(var S: TStream); +begin + if not inherited Load(S) then + Fail; + S.Read(History,SizeOf(History)); + if (S.Status <> stOk) then + Fail; +end; + +{****************************************************************************} +{ TBrowseInputLine.DataSize } +{****************************************************************************} +function TBrowseInputLine.DataSize: Sw_Word; +begin + DataSize := SizeOf(TBrowseInputLineRec); +end; + +{****************************************************************************} +{ TBrowseInputLine.GetData } +{****************************************************************************} +procedure TBrowseInputLine.GetData(var Rec); +var + LocalRec: TBrowseInputLineRec absolute Rec; +begin + if (Validator = nil) or + (Validator^.Transfer(Data Sw_PString_DeRef,@LocalRec.Text, vtGetData) = 0) then + begin +{$ifdef FV_UNICODE} + LocalRec.Text := Data; +{$else FV_UNICODE} + FillChar(LocalRec.Text, DataSize, #0); + Move(Data^, LocalRec.Text, Length(Data^) + 1); +{$endif FV_UNICODE} + end; + LocalRec.History := History; +end; + +{****************************************************************************} +{ TBrowseInputLine.SetData } +{****************************************************************************} +procedure TBrowseInputLine.SetData(var Rec); +var + LocalRec: TBrowseInputLineRec absolute Rec; +begin + if (Validator = nil) or + (Validator^.Transfer(Data Sw_PString_DeRef, @LocalRec.Text, vtSetData) = 0) then +{$ifdef FV_UNICODE} + Data := LocalRec.Text; +{$else FV_UNICODE} + Move(LocalRec.Text, Data^[0], MaxLen + 1); +{$endif FV_UNICODE} + History := LocalRec.History; + SelectAll(True); +end; + +{****************************************************************************} +{ TBrowseInputLine.Store } +{****************************************************************************} +procedure TBrowseInputLine.Store(var S: TStream); +begin + inherited Store(S); + S.Write(History,SizeOf(History)); +end; + + +{****************************************************************************} +{ TCommandCheckBoxes Object } +{****************************************************************************} +{****************************************************************************} +{ TCommandCheckBoxes.Init } +{****************************************************************************} +constructor TCommandCheckBoxes.Init (var Bounds : TRect; + ACommandStrings : PCommandSItem); +var StartSItem, S : PSItem; + CItems : PCommandSItem; + i : Sw_Integer; +begin + if ACommandStrings = nil then + Fail; + { set up string list } + StartSItem := NewSItem(ACommandStrings^.Value,nil); + S := StartSItem; + CItems := ACommandStrings^.Next; + while (CItems <> nil) do begin + S^.Next := NewSItem(CItems^.Value,nil); + S := S^.Next; + CItems := CItems^.Next; + end; + { construct check boxes } + if not TCheckBoxes.Init(Bounds,StartSItem) then begin + while (StartSItem <> nil) do begin + S := StartSItem; + StartSItem := StartSItem^.Next; +{$ifndef FV_UNICODE} + if (S^.Value <> nil) then + DisposeStr(S^.Value); +{$endif FV_UNICODE} + Dispose(S); + end; + Fail; + end; + { set up CommandList and dispose of memory used by ACommandList } + i := 0; + while (ACommandStrings <> nil) do begin + CommandList[i] := ACommandStrings^.Command; + CItems := ACommandStrings; + ACommandStrings := ACommandStrings^.Next; + Dispose(CItems); + Inc(i); + end; +end; + +{****************************************************************************} +{ TCommandCheckBoxes.Load } +{****************************************************************************} +constructor TCommandCheckBoxes.Load (var S : TStream); +begin + if not TCheckBoxes.Load(S) then + Fail; + S.Read(CommandList,SizeOf(CommandList)); + if (S.Status <> stOk) then begin + TCheckBoxes.Done; + Fail; + end; +end; + +{****************************************************************************} +{ TCommandCheckBoxes.Press } +{****************************************************************************} +procedure TCommandCheckBoxes.Press (Item : Sw_Integer); +var Temp : Sw_Integer; +begin + Temp := Value; + TCheckBoxes.Press(Item); + if (Value <> Temp) then { value changed - notify peers } + Message(Owner,evCommand,CommandList[Item],@Value); +end; + +{****************************************************************************} +{ TCommandCheckBoxes.Store } +{****************************************************************************} +procedure TCommandCheckBoxes.Store (var S : TStream); +begin + TCheckBoxes.Store(S); + S.Write(CommandList,SizeOf(CommandList)); +end; + +{****************************************************************************} +{ TCommandIcon Object } +{****************************************************************************} +{****************************************************************************} +{ TCommandIcon.Init } +{****************************************************************************} +constructor TCommandIcon.Init (var Bounds : TRect; AText : Sw_String; + ACommand : Word); +begin + if not TStaticText.Init(Bounds,AText) then + Fail; + Options := Options or ofPostProcess; + Command := ACommand; +end; + +{****************************************************************************} +{ TCommandIcon.HandleEvent } +{****************************************************************************} +procedure TCommandIcon.HandleEvent (var Event : TEvent); +begin + if ((Event.What = evMouseDown) and MouseInView(MouseWhere)) then begin + ClearEvent(Event); + Message(Owner,evCommand,Command,nil); + end; + TStaticText.HandleEvent(Event); +end; + +{****************************************************************************} +{ TCommandInputLine Object } +{****************************************************************************} +{****************************************************************************} +{ TCommandInputLine.Changed } +{****************************************************************************} +{procedure TCommandInputLine.Changed; +begin + Message(Owner,evBroadcast,cmInputLineChanged,@Self); +end; } + +{****************************************************************************} +{ TCommandInputLine.HandleEvent } +{****************************************************************************} +{procedure TCommandInputLine.HandleEvent (var Event : TEvent); +var E : TEvent; +begin + E := Event; + TBSDInputLine.HandleEvent(Event); + if ((E.What and evKeyBoard = evKeyBoard) and (Event.KeyCode = kbEnter)) + then Changed; +end; } + +{****************************************************************************} +{ TCommandRadioButtons Object } +{****************************************************************************} + +{****************************************************************************} +{ TCommandRadioButtons.Init } +{****************************************************************************} +constructor TCommandRadioButtons.Init (var Bounds : TRect; + ACommandStrings : PCommandSItem); +var + StartSItem, S : PSItem; + CItems : PCommandSItem; + i : Sw_Integer; +begin + if ACommandStrings = nil + then Fail; + { set up string list } + StartSItem := NewSItem(ACommandStrings^.Value,nil); + S := StartSItem; + CItems := ACommandStrings^.Next; + while (CItems <> nil) do begin + S^.Next := NewSItem(CItems^.Value,nil); + S := S^.Next; + CItems := CItems^.Next; + end; + { construct check boxes } + if not TRadioButtons.Init(Bounds,StartSItem) then begin + while (StartSItem <> nil) do begin + S := StartSItem; + StartSItem := StartSItem^.Next; +{$ifndef FV_UNICODE} + if (S^.Value <> nil) then + DisposeStr(S^.Value); +{$endif FV_UNICODE} + Dispose(S); + end; + Fail; + end; + { set up command list } + i := 0; + while (ACommandStrings <> nil) do begin + CommandList[i] := ACommandStrings^.Command; + CItems := ACommandStrings; + ACommandStrings := ACommandStrings^.Next; + Dispose(CItems); + Inc(i); + end; +end; + +{****************************************************************************} +{ TCommandRadioButtons.Load } +{****************************************************************************} +constructor TCommandRadioButtons.Load (var S : TStream); +begin + if not TRadioButtons.Load(S) then + Fail; + S.Read(CommandList,SizeOf(CommandList)); + if (S.Status <> stOk) then begin + TRadioButtons.Done; + Fail; + end; +end; + +{****************************************************************************} +{ TCommandRadioButtons.MoveTo } +{****************************************************************************} +procedure TCommandRadioButtons.MovedTo (Item : Sw_Integer); +var Temp : Sw_Integer; +begin + Temp := Value; + TRadioButtons.MovedTo(Item); + if (Value <> Temp) then { value changed - notify peers } + Message(Owner,evCommand,CommandList[Item],@Value); +end; + +{****************************************************************************} +{ TCommandRadioButtons.Press } +{****************************************************************************} +procedure TCommandRadioButtons.Press (Item : Sw_Integer); +var Temp : Sw_Integer; +begin + Temp := Value; + TRadioButtons.Press(Item); + if (Value <> Temp) then { value changed - notify peers } + Message(Owner,evCommand,CommandList[Item],@Value); +end; + +{****************************************************************************} +{ TCommandRadioButtons.Store } +{****************************************************************************} +procedure TCommandRadioButtons.Store (var S : TStream); +begin + TRadioButtons.Store(S); + S.Write(CommandList,SizeOf(CommandList)); +end; + +{****************************************************************************} +{ TEditListBox Object } +{****************************************************************************} +{****************************************************************************} +{ TEditListBox.Init } +{****************************************************************************} +constructor TEditListBox.Init (Bounds : TRect; ANumCols: Word; + AVScrollBar : PScrollBar); + +begin + if not inherited Init(Bounds,ANumCols,AVScrollBar) + then Fail; + CurrentField := 1; +end; + +{****************************************************************************} +{ TEditListBox.Load } +{****************************************************************************} +constructor TEditListBox.Load (var S : TStream); +begin + if not inherited Load(S) + then Fail; + CurrentField := 1; +end; + +{****************************************************************************} +{ TEditListBox.EditField } +{****************************************************************************} +procedure TEditListBox.EditField (var Event : TEvent); +var R : TRect; + InputLine : PModalInputLine; +begin + R.Assign(StartColumn,(Origin.Y + Focused - TopItem), + (StartColumn + FieldWidth + 2),(Origin.Y + Focused - TopItem + 1)); + Owner^.MakeGlobal(R.A,R.A); + Owner^.MakeGlobal(R.B,R.B); + InputLine := New(PModalInputLine,Init(R,FieldWidth)); + InputLine^.SetValidator(FieldValidator); + if InputLine <> nil + then begin + { Use TInputLine^.SetData so that data validation occurs } + { because TInputLine.Data is allocated memory large enough } + { to hold a string of MaxLen. It is also faster. } + GetField(InputLine); + if (Application^.ExecView(InputLine) = cmOk) + then SetField(InputLine); + Dispose(InputLine,done); + end; +end; + +{****************************************************************************} +{ TEditListBox.FieldValidator } +{****************************************************************************} +function TEditListBox.FieldValidator : PValidator; + { In a multiple field listbox FieldWidth should return the width } + { appropriate for Field. The default is an inputline for editing } + { a string of length large enough to fill the listbox field. } +begin + FieldValidator := nil; +end; + +{****************************************************************************} +{ TEditListBox.FieldWidth } +{****************************************************************************} +function TEditListBox.FieldWidth : SmallInt; + { In a multiple field listbox FieldWidth should return the width } + { appropriate for CurrentField. } +begin + FieldWidth := Size.X - 2; +end; + +{****************************************************************************} +{ TEditListBox.GetField } +{****************************************************************************} +procedure TEditListBox.GetField (InputLine : PInputLine); + { Places a string appropriate to Field and Focused into InputLine that } + { will be edited. Override this method for complex data types. } +begin + InputLine^.SetData(PString(List^.At(Focused))^); +end; + +{****************************************************************************} +{ TEditListBox.GetPalette } +{****************************************************************************} +function TEditListBox.GetPalette : PPalette; +begin + GetPalette := inherited GetPalette; +end; + +{****************************************************************************} +{ TEditListBox.HandleEvent } +{****************************************************************************} +procedure TEditListBox.HandleEvent (var Event : TEvent); +begin + if (Event.What = evKeyboard) and (Event.KeyCode = kbAltE) + then begin { edit field } + EditField(Event); + DrawView; + ClearEvent(Event); + end; + inherited HandleEvent(Event); +end; + +{****************************************************************************} +{ TEditListBox.SetField } +{****************************************************************************} +procedure TEditListBox.SetField (InputLine : PInputLine); + { Override this method for field types other than PStrings. } +var Item : Sw_PString; +begin + Item := Sw_NewStr(InputLine^.Data Sw_PString_DeRef); + if Item <> Sw_PString_Empty + then begin + List^.AtFree(Focused); + List^.Insert(Pointer(Item)); + SetFocusedItem(Pointer(Item)); + end; +end; + +{****************************************************************************} +{ TEditListBox.StartColumn } +{****************************************************************************} +function TEditListBox.StartColumn : SmallInt; +begin + StartColumn := Origin.X; +end; + +{****************************************************************************} +{ TListDlg Object } +{****************************************************************************} +{****************************************************************************} +{ TListDlg.Init } +{****************************************************************************} +constructor TListDlg.Init (ATitle : TTitleStr; Items: + Sw_String; AButtons: Word; AListBox: PListBox; AEditCommand, ANewCommand : + Word); +var + Bounds: TRect; + b: Byte; + ButtonCount: Byte; + i, j, Gap, Line: SmallInt; + Scrollbar: PScrollbar; + HasFrame: Boolean; + HasButtons: Boolean; + HasScrollBar: Boolean; + HasItems: Boolean; +begin + if AListBox = nil then + Fail + else + ListBox := AListBox; + HasFrame := ((AButtons and ldNoFrame) = 0); + HasButtons := ((AButtons and ldAllButtons) <> 0); + HasScrollBar := ((AButtons and ldNoScrollBar) = 0); + HasItems := (Items <> ''); + ButtonCount := 2; + for b := 0 to 3 do + if (AButtons and ($0001 shl 1)) <> 0 then + Inc(ButtonCount); + { Make sure dialog is large enough for buttons } + ListBox^.GetExtent(Bounds); + Bounds.Move(ListBox^.Origin.X,ListBox^.Origin.Y); + if HasFrame then + begin + Inc(Bounds.B.X,2); + Inc(Bounds.B.Y,2); + end; + if HasButtons then + begin + Inc(Bounds.B.X,14); + if Bounds.B.Y < (ButtonCount * 2) + 4 then + Bounds.B.Y := (ButtonCount * 2) + 5; + end; + if HasItems then + Inc(Bounds.B.Y,1); + if not TDialog.Init(Bounds,ATitle) then + Fail; + NewCommand := ANewCommand; + EditCommand := AEditCommand; + Options := Options or ofNewEditDelete; + if (not HasFrame) and (Frame <> nil) then + begin + Delete(Frame); + Dispose(Frame,Done); + Frame := nil; + Options := Options and not ofFramed; + end; + HelpCtx := hcListDlg; + { position and insert ListBox } + ListBox := AListBox; + Insert(ListBox); + if HasItems then + if HasFrame then + ListBox^.MoveTo(2,2) + else ListBox^.MoveTo(0,2) + else + if HasFrame then + ListBox^.MoveTo(1,1) + else ListBox^.MoveTo(0,0); + if HasButtons then + if ListBox^.Size.Y < (ButtonCount * 2) then + ListBox^.GrowTo(ListBox^.Size.X,ButtonCount * 2); + { do Items } + if HasItems then + begin + Bounds.Assign(1,1,CStrLen(Items)+2,2); + Insert(New(PLabel,Init(Bounds,Items,ListBox))); + end; + { do scrollbar } + if HasScrollBar then + begin + Bounds.Assign(ListBox^.Size.X+ListBox^.Origin.X,ListBox^.Origin.Y, + ListBox^.Size.X + ListBox^.Origin.X + 1, + ListBox^.Size.Y + ListBox^.Origin.Y { origin }); + ScrollBar := New(PScrollBar,Init(Bounds)); + Bounds.Assign(Origin.X,Origin.Y,Origin.X + Size.X + 1, Origin.Y + Size.Y); + ChangeBounds(Bounds); + Insert(Scrollbar); + end; + if HasButtons then + begin { do buttons } + j := $0001; + Gap := 0; + for i := 0 to 3 do + if ((j shl i) and AButtons) <> 0 then + Inc(Gap); + Gap := ((Size.Y - 2) div (Gap + 2)); + if Gap < 2 then + Gap := 2; + { Insert Buttons } + Line := 2; + if (AButtons and ldNew) = ldNew then + begin + Insert(NewButton(Size.X - 12,Line,10,2,'~N~ew',cmNew,hcInsert,bfNormal)); + Inc(Line,Gap); + end; + if (AButtons and ldEdit) = ldEdit then + begin + Insert(NewButton(Size.X - 12,Line,10,2,'~E~dit',cmEdit,hcEdit, + bfNormal)); + Inc(Line,Gap); + end; + if (AButtons and ldDelete) = ldDelete then + begin + Insert(NewButton(Size.X - 12,Line,10,2,'~D~elete',cmDelete,hcDelete, + bfNormal)); + Inc(Line,Gap); + end; + Insert(NewButton(Size.X - 12,Line,10,2,'O~k~',cmOK,hcOk,bfDefault or + bfNormal)); + Inc(Line,Gap); + Insert(NewButton(Size.X - 12,Line,10,2,'Cancel',cmCancel,hcCancel, + bfNormal)); + if (AButtons and ldHelp) = ldHelp then + begin + Inc(Line,Gap); + Insert(NewButton(Size.X - 12,Line,10,2,'~H~elp',cmHelp,hcNoContext, + bfNormal)); + end; + end; + if HasFrame and ((AButtons and ldAllIcons) <> 0) then + begin + Line := 2; + if (AButtons and ldNewIcon) = ldNewIcon then + begin + Bounds.Assign(Line,Size.Y-1,Line+5,Size.Y); + Insert(New(PCommandIcon,Init(Bounds,' Ins ',cmNew))); + Inc(Line,5); + if (AButtons and (ldEditIcon or ldDeleteIcon)) <> 0 then + begin + Bounds.Assign(Line,Size.Y-1,Line+1,Size.Y); + Insert(New(PStaticText,Init(Bounds,'/'))); + Inc(Line,1); + end; + end; + if (AButtons and ldEditIcon) = ldEditIcon then + begin + Bounds.Assign(Line,Size.Y-1,Line+6,Size.Y); + Insert(New(PCommandIcon,Init(Bounds,' Edit ',cmEdit))); + Inc(Line,6); + if (AButtons and ldDeleteIcon) <> 0 then + begin + Bounds.Assign(Line,Size.Y-1,Line+1,Size.Y); + Insert(New(PStaticText,Init(Bounds,'/'))); + Inc(Line,1); + end; + end; + if (AButtons and ldNewIcon) = ldNewIcon then + begin + Bounds.Assign(Line,Size.Y-1,Line+5,Size.Y); + Insert(New(PCommandIcon,Init(Bounds,' Del ',cmDelete))); + end; + end; + { Set focus to list boLine when dialog opens } + SelectNext(False); +end; + +{****************************************************************************} +{ TListDlg.Load } +{****************************************************************************} +constructor TListDlg.Load (var S : TStream); +begin + if not TDialog.Load(S) then + Fail; + S.Read(NewCommand,SizeOf(NewCommand)); + S.Read(EditCommand,SizeOf(EditCommand)); + GetSubViewPtr(S,ListBox); +end; + +{****************************************************************************} +{ TListDlg.HandleEvent } +{****************************************************************************} +procedure TListDlg.HandleEvent (var Event : TEvent); +const + TargetCommands: TCommandSet = [cmNew, cmEdit, cmDelete]; +begin + if ((Event.What and evCommand) <> 0) and + (Event.Command in TargetCommands) then + case Event.Command of + cmDelete: + if Options and ofDelete = ofDelete then + begin + ListBox^.FreeFocusedItem; + ListBox^.DrawView; + ClearEvent(Event); + end; + cmNew: + if Options and ofNew = ofNew then + begin + Message(Application,evCommand,NewCommand,nil); + ListBox^.SetRange(ListBox^.List^.Count); + ListBox^.DrawView; + ClearEvent(Event); + end; + cmEdit: + if Options and ofEdit = ofEdit then + begin + Message(Application,evCommand,EditCommand,ListBox^.GetFocusedItem); + ListBox^.DrawView; + ClearEvent(Event); + end; + end; + if (Event.What and evBroadcast > 0) and + (Event.Command = cmListItemSelected) then + begin { use PutEvent instead of Message so that a window list box works } + Event.What := evCommand; + Event.Command := cmOk; + Event.InfoPtr := nil; + PutEvent(Event); + end; + TDialog.HandleEvent(Event); +end; + +{****************************************************************************} +{ TListDlg.Store } +{****************************************************************************} +procedure TListDlg.Store (var S : TStream); +begin + TDialog.Store(S); + S.Write(NewCommand,SizeOf(NewCommand)); + S.Write(EditCommand,SizeOf(EditCommand)); + PutSubViewPtr(S,ListBox); +end; + +{****************************************************************************} +{ TModalInputLine Object } +{****************************************************************************} +{****************************************************************************} +{ TModalInputLine.Execute } +{****************************************************************************} +function TModalInputLine.Execute : Word; +var Event : TEvent; +begin + repeat + EndState := 0; + repeat + GetEvent(Event); + HandleEvent(Event); + if Event.What <> evNothing + then Owner^.EventError(Event); { may change this to ClearEvent } + until (EndState <> 0); + until Valid(EndState); + Execute := EndState; +end; + +{****************************************************************************} +{ TModalInputLine.HandleEvent } +{****************************************************************************} +procedure TModalInputLine.HandleEvent (var Event : TEvent); +begin + case Event.What of + evKeyboard : case Event.KeyCode of + kbUp, kbDown : EndModal(cmCancel); + kbEnter : EndModal(cmOk); + else inherited HandleEvent(Event); + end; + evMouse : if MouseInView(Event.Where) + then inherited HandleEvent(Event) + else EndModal(cmCancel); + else inherited HandleEvent(Event); + end; +end; + +{****************************************************************************} +{ TModalInputLine.SetState } +{****************************************************************************} +procedure TModalInputLine.SetState (AState : Word; Enable : Boolean); +var Pos : SmallInt; +begin + if (AState = sfSelected) + then begin + Pos := CurPos; + inherited SetState(AState,Enable); + CurPos := Pos; + SelStart := CurPos; + SelEnd := CurPos; + BlockCursor; + DrawView; + end + else inherited SetState(AState,Enable); +end; + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ ITEM STRING ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ NewSItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewSItem (Const Str: Sw_String; ANext: PSItem): PSItem; +VAR Item: PSItem; +BEGIN + New(Item); { Allocate item } + Item^.Value := Sw_NewStr(Str); { Hold item string } + Item^.Next := ANext; { Chain the ptr } + NewSItem := Item; { Return item } +END; + +{****************************************************************************} +{ NewCommandSItem } +{****************************************************************************} +function NewCommandSItem (Str : Sw_String; ACommand : Word; + ANext : PCommandSItem) : PCommandSItem; +var Temp : PCommandSItem; +begin + New(Temp); + if (Temp <> nil) then + begin + Temp^.Value := Str; + Temp^.Command := ACommand; + Temp^.Next := ANext; + end; + NewCommandSItem := Temp; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ DIALOG OBJECT REGISTRATION ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ RegisterDialogs -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterDialogs; +BEGIN + RegisterType(RDialog); { Register dialog } + RegisterType(RInputLine); { Register inputline } + RegisterType(RButton); { Register button } + RegisterType(RCluster); { Register cluster } + RegisterType(RRadioButtons); { Register radiobutton } + RegisterType(RCheckBoxes); { Register check boxes } + RegisterType(RMultiCheckBoxes); { Register multi boxes } + RegisterType(RListBox); { Register list box } + RegisterType(RStaticText); { Register static text } + RegisterType(RLabel); { Register label } + RegisterType(RHistory); { Register history } + RegisterType(RParamText); { Register parm text } + RegisterType(RCommandCheckBoxes); + RegisterType(RCommandIcon); + RegisterType(RCommandRadioButtons); + RegisterType(REditListBox); + RegisterType(RModalInputLine); + RegisterType(RListDlg); +END; + +END. diff --git a/packages/fv/src/dialogs.pas b/packages/fv/src/dialogs.pas index 49f314cbc8..c154a72494 100644 --- a/packages/fv/src/dialogs.pas +++ b/packages/fv/src/dialogs.pas @@ -1,4186 +1 @@ -{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} -{ } -{ System independent GRAPHICAL clone of DIALOGS.PAS } -{ } -{ Interface Copyright (c) 1992 Borland International } -{ } -{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } -{ ldeboer@attglobal.net - primary e-mail addr } -{ ldeboer@starwon.com.au - backup e-mail addr } -{ } -{****************[ THIS CODE IS FREEWARE ]*****************} -{ } -{ This sourcecode is released for the purpose to } -{ promote the pascal language on all platforms. You may } -{ redistribute it and/or modify with the following } -{ DISCLAIMER. } -{ } -{ This SOURCE CODE is distributed "AS IS" WITHOUT } -{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } -{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } -{ } -{*****************[ SUPPORTED PLATFORMS ]******************} -{ } -{ Only Free Pascal Compiler supported } -{ } -{**********************************************************} - -UNIT Dialogs; - -{$CODEPAGE cp437} - -{2.0 compatibility} -{$ifdef VER2_0} - {$macro on} - {$define resourcestring := const} -{$endif} - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - INTERFACE -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{====Include file to sort compiler platform out =====================} -{$I platform.inc} -{====================================================================} - -{==== Compiler directives ===========================================} - - -{$X+} { Extended syntax is ok } -{$R-} { Disable range checking } -{$S-} { Disable Stack Checking } -{$I-} { Disable IO Checking } -{$Q-} { Disable Overflow Checking } -{$V-} { Turn off strict VAR strings } -{====================================================================} - -USES - {$IFDEF OS_WINDOWS} { WIN/NT CODE } - Windows, { Standard units } - {$ENDIF} - - {$IFDEF OS_OS2} { OS2 CODE } - OS2Def, DosCalls, PMWIN, { Standard units } - {$ENDIF} - - FVCommon, FVConsts, Objects, Drivers, Views, Validate; { Standard GFV units } - -{***************************************************************************} -{ PUBLIC CONSTANTS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ COLOUR PALETTE DEFINITIONS } -{---------------------------------------------------------------------------} -CONST - CGrayDialog = #32#33#34#35#36#37#38#39#40#41#42#43#44#45#46#47 + - #48#49#50#51#52#53#54#55#56#57#58#59#60#61#62#63; - CBlueDialog = #64#65#66#67#68#69#70#71#72#73#74#75#76#77#78#79 + - #80#81#82#83#84#85#86#87#88#89#90#91#92#92#94#95; - CCyanDialog = #96#97#98#99#100#101#102#103#104#105#106#107#108 + - #109#110#111#112#113#114#115#116#117#118#119#120 + - #121#122#123#124#125#126#127; - CStaticText = #6#7#8#9; - CLabel = #7#8#9#9; - CButton = #10#11#12#13#14#14#14#15; - CCluster = #16#17#18#18#31#6; - CInputLine = #19#19#20#21#14; - CHistory = #22#23; - CHistoryWindow = #19#19#21#24#25#19#20; - CHistoryViewer = #6#6#7#6#6; - - CDialog = CGrayDialog; { Default palette } - -const - { ldXXXX constants } - ldNone = $0000; - ldNew = $0001; - ldEdit = $0002; - ldDelete = $0004; - ldNewEditDelete = ldNew or ldEdit or ldDelete; - ldHelp = $0008; - ldAllButtons = ldNew or ldEdit or ldDelete or ldHelp; - ldNewIcon = $0010; - ldEditIcon = $0020; - ldDeleteIcon = $0040; - ldAllIcons = ldNewIcon or ldEditIcon or ldDeleteIcon; - ldAll = ldAllIcons or ldAllButtons; - ldNoFrame = $0080; - ldNoScrollBar = $0100; - - { ofXXXX constants } - ofNew = $0001; - ofDelete = $0002; - ofEdit = $0004; - ofNewEditDelete = ofNew or ofDelete or ofEdit; - -{---------------------------------------------------------------------------} -{ TDialog PALETTE COLOUR CONSTANTS } -{---------------------------------------------------------------------------} -CONST - dpBlueDialog = 0; { Blue dialog colour } - dpCyanDialog = 1; { Cyan dialog colour } - dpGrayDialog = 2; { Gray dialog colour } - -{---------------------------------------------------------------------------} -{ TButton FLAGS MASKS } -{---------------------------------------------------------------------------} -CONST - bfNormal = $00; { Normal displayed } - bfDefault = $01; { Default command } - bfLeftJust = $02; { Left just text } - bfBroadcast = $04; { Broadcast command } - bfGrabFocus = $08; { Grab focus } - -{---------------------------------------------------------------------------} -{ TMultiCheckBoxes FLAGS - (HiByte = Bits LoByte = Mask) } -{---------------------------------------------------------------------------} -CONST - cfOneBit = $0101; { One bit masks } - cfTwoBits = $0203; { Two bit masks } - cfFourBits = $040F; { Four bit masks } - cfEightBits = $08FF; { Eight bit masks } - -{---------------------------------------------------------------------------} -{ DIALOG BROADCAST COMMANDS } -{---------------------------------------------------------------------------} -CONST - cmRecordHistory = 60; { Record history cmd } - -{***************************************************************************} -{ RECORD DEFINITIONS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ ITEM RECORD DEFINITION } -{---------------------------------------------------------------------------} -TYPE - PSItem = ^TSItem; - TSItem = RECORD - Value: PString; { Item string } - Next: PSItem; { Next item } - END; - -{***************************************************************************} -{ OBJECT DEFINITIONS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TInputLine OBJECT - INPUT LINE OBJECT } -{---------------------------------------------------------------------------} -TYPE - TInputLine = OBJECT (TView) - MaxLen: Sw_Integer; { Max input length } - CurPos: Sw_Integer; { Cursor position } - FirstPos: Sw_Integer; { First position } - SelStart: Sw_Integer; { Selected start } - SelEnd: Sw_Integer; { Selected end } - Data: PString; { Input line data } - Validator: PValidator; { Validator of view } - CONSTRUCTOR Init (Var Bounds: TRect; AMaxLen: Sw_Integer); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION DataSize: Sw_Word; Virtual; - FUNCTION GetPalette: PPalette; Virtual; - FUNCTION Valid (Command: Word): Boolean; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE DrawCursor; Virtual; - PROCEDURE SelectAll (Enable: Boolean); - PROCEDURE SetValidator (AValid: PValidator); - PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; - PROCEDURE GetData (Var Rec); Virtual; - PROCEDURE SetData (Var Rec); Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PRIVATE - FUNCTION CanScroll (Delta: Sw_Integer): Boolean; - END; - PInputLine = ^TInputLine; - -{---------------------------------------------------------------------------} -{ TButton OBJECT - BUTTON ANCESTOR OBJECT } -{---------------------------------------------------------------------------} -TYPE - TButton = OBJECT (TView) - AmDefault: Boolean; { If default button } - Flags : Byte; { Button flags } - Command : Word; { Button command } - Title : PString; { Button title } - CONSTRUCTOR Init (Var Bounds: TRect; ATitle: TTitleStr; ACommand: Word; - AFlags: Word); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION GetPalette: PPalette; Virtual; - PROCEDURE Press; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE DrawState (Down: Boolean); - PROCEDURE MakeDefault (Enable: Boolean); - PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PRIVATE - DownFlag: Boolean; - END; - PButton = ^TButton; - -{---------------------------------------------------------------------------} -{ TCluster OBJECT - CLUSTER ANCESTOR OBJECT } -{---------------------------------------------------------------------------} -TYPE - { Palette layout } - { 1 = Normal text } - { 2 = Selected text } - { 3 = Normal shortcut } - { 4 = Selected shortcut } - { 5 = Disabled text } - - TCluster = OBJECT (TView) - Id : Sw_Integer; { New communicate id } - Sel : Sw_Integer; { Selected item } - Value : LongInt; { Bit value } - EnableMask: LongInt; { Mask enable bits } - Strings : TStringCollection; { String collection } - CONSTRUCTOR Init (Var Bounds: TRect; AStrings: PSItem); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION DataSize: Sw_Word; Virtual; - FUNCTION GetHelpCtx: Word; Virtual; - FUNCTION GetPalette: PPalette; Virtual; - FUNCTION Mark (Item: Sw_Integer): Boolean; Virtual; - FUNCTION MultiMark (Item: Sw_Integer): Byte; Virtual; - FUNCTION ButtonState (Item: Sw_Integer): Boolean; - PROCEDURE Draw; Virtual; - PROCEDURE Press (Item: Sw_Integer); Virtual; - PROCEDURE MovedTo (Item: Sw_Integer); Virtual; - PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; - PROCEDURE DrawMultiBox (Const Icon, Marker: String); - PROCEDURE DrawBox (Const Icon: String; Marker: Char); - PROCEDURE SetButtonState (AMask: Longint; Enable: Boolean); - PROCEDURE GetData (Var Rec); Virtual; - PROCEDURE SetData (Var Rec); Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PRIVATE - FUNCTION FindSel (P: TPoint): Sw_Integer; - FUNCTION Row (Item: Sw_Integer): Sw_Integer; - FUNCTION Column (Item: Sw_Integer): Sw_Integer; - END; - PCluster = ^TCluster; - -{---------------------------------------------------------------------------} -{ TRadioButtons OBJECT - RADIO BUTTON OBJECT } -{---------------------------------------------------------------------------} - - { Palette layout } - { 1 = Normal text } - { 2 = Selected text } - { 3 = Normal shortcut } - { 4 = Selected shortcut } - - -TYPE - TRadioButtons = OBJECT (TCluster) - FUNCTION Mark (Item: Sw_Integer): Boolean; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE Press (Item: Sw_Integer); Virtual; - PROCEDURE MovedTo(Item: Sw_Integer); Virtual; - PROCEDURE SetData (Var Rec); Virtual; - END; - PRadioButtons = ^TRadioButtons; - -{---------------------------------------------------------------------------} -{ TCheckBoxes OBJECT - CHECK BOXES OBJECT } -{---------------------------------------------------------------------------} - - { Palette layout } - { 1 = Normal text } - { 2 = Selected text } - { 3 = Normal shortcut } - { 4 = Selected shortcut } - -TYPE - TCheckBoxes = OBJECT (TCluster) - FUNCTION Mark (Item: Sw_Integer): Boolean; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE Press (Item: Sw_Integer); Virtual; - END; - PCheckBoxes = ^TCheckBoxes; - -{---------------------------------------------------------------------------} -{ TMultiCheckBoxes OBJECT - CHECK BOXES OBJECT } -{---------------------------------------------------------------------------} - - { Palette layout } - { 1 = Normal text } - { 2 = Selected text } - { 3 = Normal shortcut } - { 4 = Selected shortcut } - -TYPE - TMultiCheckBoxes = OBJECT (TCluster) - SelRange: Byte; { Select item range } - Flags : Word; { Select flags } - States : PString; { Strings } - CONSTRUCTOR Init (Var Bounds: TRect; AStrings: PSItem; - ASelRange: Byte; AFlags: Word; Const AStates: String); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION DataSize: Sw_Word; Virtual; - FUNCTION MultiMark (Item: Sw_Integer): Byte; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE Press (Item: Sw_Integer); Virtual; - PROCEDURE GetData (Var Rec); Virtual; - PROCEDURE SetData (Var Rec); Virtual; - PROCEDURE Store (Var S: TStream); - END; - PMultiCheckBoxes = ^TMultiCheckBoxes; - -{---------------------------------------------------------------------------} -{ TListBox OBJECT - LIST BOX OBJECT } -{---------------------------------------------------------------------------} - - { Palette layout } - { 1 = Active } - { 2 = Inactive } - { 3 = Focused } - { 4 = Selected } - { 5 = Divider } - -TYPE - TListBox = OBJECT (TListViewer) - List: PCollection; { List of strings } - CONSTRUCTOR Init (Var Bounds: TRect; ANumCols: Sw_Word; - AScrollBar: PScrollBar); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION DataSize: Sw_Word; Virtual; - FUNCTION GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; Virtual; - PROCEDURE NewList(AList: PCollection); Virtual; - PROCEDURE GetData (Var Rec); Virtual; - PROCEDURE SetData (Var Rec); Virtual; - PROCEDURE Store (Var S: TStream); - procedure DeleteFocusedItem; virtual; - { DeleteFocusedItem deletes the focused item and redraws the view. } - {#X FreeFocusedItem } - procedure DeleteItem (Item : Sw_Integer); virtual; - { DeleteItem deletes Item from the associated collection. } - {#X FreeItem } - procedure FreeAll; virtual; - { FreeAll deletes and disposes of all items in the associated - collection. } - { FreeFocusedItem FreeItem } - procedure FreeFocusedItem; virtual; - { FreeFocusedItem deletes and disposes of the focused item then redraws - the listbox. } - {#X FreeAll FreeItem } - procedure FreeItem (Item : Sw_Integer); virtual; - { FreeItem deletes Item from the associated collection and disposes of - it, then redraws the listbox. } - {#X FreeFocusedItem FreeAll } - function GetFocusedItem : Pointer; virtual; - { GetFocusedItem is a more readable method of returning the focused - item from the listbox. It is however slightly slower than: } - {#M+} - { - Item := ListBox^.List^.At(ListBox^.Focused); } - {#M-} - procedure Insert (Item : Pointer); virtual; - { Insert inserts Item into the collection, adjusts the listbox's range, - then redraws the listbox. } - {#X FreeItem } - procedure SetFocusedItem (Item : Pointer); virtual; - { SetFocusedItem changes the focused item to Item then redraws the - listbox. } - {# FocusItemNum } - END; - PListBox = ^TListBox; - -{---------------------------------------------------------------------------} -{ TStaticText OBJECT - STATIC TEXT OBJECT } -{---------------------------------------------------------------------------} -TYPE - TStaticText = OBJECT (TView) - Text: PString; { Text string ptr } - CONSTRUCTOR Init (Var Bounds: TRect; Const AText: String); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION GetPalette: PPalette; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE GetText (Var S: String); Virtual; - END; - PStaticText = ^TStaticText; - -{---------------------------------------------------------------------------} -{ TParamText OBJECT - PARMETER STATIC TEXT OBJECT } -{---------------------------------------------------------------------------} - - { Palette layout } - { 1 = Text } - -TYPE - TParamText = OBJECT (TStaticText) - ParamCount: Sw_Integer; { Parameter count } - ParamList : Pointer; { Parameter list } - CONSTRUCTOR Init (Var Bounds: TRect; Const AText: String; - AParamCount: Sw_Integer); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION DataSize: Sw_Word; Virtual; - PROCEDURE GetData (Var Rec); Virtual; - PROCEDURE SetData (Var Rec); Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE GetText (Var S: String); Virtual; - END; - PParamText = ^TParamText; - -{---------------------------------------------------------------------------} -{ TLabel OBJECT - LABEL OBJECT } -{---------------------------------------------------------------------------} -TYPE - TLabel = OBJECT (TStaticText) - Light: Boolean; - Link: PView; { Linked view } - CONSTRUCTOR Init (Var Bounds: TRect; CONST AText: String; ALink: PView); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION GetPalette: PPalette; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - END; - PLabel = ^TLabel; - -{---------------------------------------------------------------------------} -{ THistoryViewer OBJECT - HISTORY VIEWER OBJECT } -{---------------------------------------------------------------------------} - - { Palette layout } - { 1 = Active } - { 2 = Inactive } - { 3 = Focused } - { 4 = Selected } - { 5 = Divider } - -TYPE - THistoryViewer = OBJECT (TListViewer) - HistoryId: Word; { History id } - CONSTRUCTOR Init(Var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar; - AHistoryId: Word); - FUNCTION HistoryWidth: Sw_Integer; - FUNCTION GetPalette: PPalette; Virtual; - FUNCTION GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; Virtual; - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - END; - PHistoryViewer = ^THistoryViewer; - -{---------------------------------------------------------------------------} -{ THistoryWindow OBJECT - HISTORY WINDOW OBJECT } -{---------------------------------------------------------------------------} - - { Palette layout } - { 1 = Frame passive } - { 2 = Frame active } - { 3 = Frame icon } - { 4 = ScrollBar page area } - { 5 = ScrollBar controls } - { 6 = HistoryViewer normal text } - { 7 = HistoryViewer selected text } - -TYPE - THistoryWindow = OBJECT (TWindow) - Viewer: PListViewer; { List viewer object } - CONSTRUCTOR Init (Var Bounds: TRect; HistoryId: Word); - FUNCTION GetSelection: String; Virtual; - FUNCTION GetPalette: PPalette; Virtual; - PROCEDURE InitViewer (HistoryId: Word); Virtual; - END; - PHistoryWindow = ^THistoryWindow; - -{---------------------------------------------------------------------------} -{ THistory OBJECT - HISTORY OBJECT } -{---------------------------------------------------------------------------} - - { Palette layout } - { 1 = Arrow } - { 2 = Sides } - -TYPE - THistory = OBJECT (TView) - HistoryId: Word; - Link: PInputLine; - CONSTRUCTOR Init (Var Bounds: TRect; ALink: PInputLine; AHistoryId: Word); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION GetPalette: PPalette; Virtual; - FUNCTION InitHistoryWindow (Var Bounds: TRect): PHistoryWindow; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE RecordHistory (CONST S: String); Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - END; - PHistory = ^THistory; - - {#Z+} - PBrowseInputLine = ^TBrowseInputLine; - TBrowseInputLine = Object(TInputLine) - History: Sw_Word; - constructor Init(var Bounds: TRect; AMaxLen: Sw_Integer; AHistory: Sw_Word); - constructor Load(var S: TStream); - function DataSize: Sw_Word; virtual; - procedure GetData(var Rec); virtual; - procedure SetData(var Rec); virtual; - procedure Store(var S: TStream); - end; { of TBrowseInputLine } - - TBrowseInputLineRec = record - Text: string; - History: Sw_Word; - end; { of TBrowseInputLineRec } - {#Z+} - PBrowseButton = ^TBrowseButton; - {#Z-} - TBrowseButton = Object(TButton) - Link: PBrowseInputLine; - constructor Init(var Bounds: TRect; ATitle: TTitleStr; ACommand: Word; - AFlags: Byte; ALink: PBrowseInputLine); - constructor Load(var S: TStream); - procedure Press; virtual; - procedure Store(var S: TStream); - end; { of TBrowseButton } - - - {#Z+} - PCommandIcon = ^TCommandIcon; - {#Z-} - TCommandIcon = Object(TStaticText) - { A TCommandIcon sends an evCommand message to its owner with - Event.Command set to #Command# when it is clicked with a mouse. } - constructor Init (var Bounds : TRect; AText : String; ACommand : Word); - { Creates an instance of a TCommandIcon and sets #Command# to - ACommand. AText is the text which is displayed as the icon. If an - error occurs Init fails. } - procedure HandleEvent (var Event : TEvent); virtual; - { Captures mouse events within its borders and sends an evCommand to - its owner in response to the mouse event. } - {#X Command } - private - Command : Word; - { Command is the command sent to the command icon's owner when it is - clicked. } - end; { of TCommandIcon } - - - {#Z+} - PCommandSItem = ^TCommandSItem; - {#Z-} - TCommandSItem = record - { A TCommandSItem is the data structure used to initialize command - clusters with #NewCommandSItem# rather than the standarad #NewSItem#. - It is used to associate a command with an individual cluster item. } - {#X TCommandCheckBoxes TCommandRadioButtons } - Value : String; - { Value is the text displayed for the cluster item. } - {#X Command Next } - Command : Word; - { Command is the command broadcast when the cluster item is pressed. } - {#X Value Next } - Next : PCommandSItem; - { Next is a pointer to the next item in the cluster. } - {#X Value Command } - end; { of TCommandSItem } - - - TCommandArray = array[0..15] of Word; - { TCommandArray holds a list of commands which are associated with a - cluster. } - {#X TCommandCheckBoxes TCommandRadioButtons } - - - {#Z+} - PCommandCheckBoxes = ^TCommandCheckBoxes; - {#Z-} - TCommandCheckBoxes = Object(TCheckBoxes) - { TCommandCheckBoxes function as normal TCheckBoxes, except that when a - cluster item is pressed it broadcasts a command associated with the - cluster item to the cluster's owner. - - TCommandCheckBoxes are useful when other parts of a dialog should be - enabled or disabled in response to a check box's status. } - CommandList : TCommandArray; - { CommandList is the list of commands associated with each check box - item. } - {#X Init Load Store } - constructor Init (var Bounds : TRect; ACommandStrings : PCommandSItem); - { Init calls the inherited constructor, then sets up the #CommandList# - with the specified commands. If an error occurs Init fails. } - {#X NewCommandSItem } - constructor Load (var S : TStream); - { Load calls the inherited constructor, then loads the #CommandList# - from the stream S. If an error occurs Load fails. } - {#X Store Init } - procedure Press (Item : Sw_Integer); virtual; - { Press calls the inherited Press then broadcasts the command - associated with the cluster item that was pressed to the check boxes' - owner. } - {#X CommandList } - procedure Store (var S : TStream); { store should never be virtual;} - { Store calls the inherited Store method then writes the #CommandList# - to the stream. } - {#X Load } - end; { of TCommandCheckBoxes } - - - {#Z+} - PCommandRadioButtons = ^TCommandRadioButtons; - {#Z-} - TCommandRadioButtons = Object(TRadioButtons) - { TCommandRadioButtons function as normal TRadioButtons, except that when - a cluster item is pressed it broadcasts a command associated with the - cluster item to the cluster's owner. - - TCommandRadioButtons are useful when other parts of a dialog should be - enabled or disabled in response to a radiobutton's status. } - CommandList : TCommandArray; { commands for each possible value } - { The list of commands associated with each radio button item. } - {#X Init Load Store } - constructor Init (var Bounds : TRect; ACommandStrings : PCommandSItem); - { Init calls the inherited constructor and sets up the #CommandList# - with the specified commands. If an error occurs Init disposes of the - command strings then fails. } - {#X NewCommandSItem } - constructor Load (var S : TStream); - { Load calls the inherited constructor then loads the #CommandList# - from the stream S. If an error occurs Load fails. } - {#X Store } - procedure MovedTo (Item : Sw_Integer); virtual; - { MovedTo calls the inherited MoveTo, then broadcasts the command of - the newly selected cluster item to the cluster's owner. } - {#X Press CommandList } - procedure Press (Item : Sw_Integer); virtual; - { Press calls the inherited Press then broadcasts the command - associated with the cluster item that was pressed to the check boxes - owner. } - {#X CommandList MovedTo } - procedure Store (var S : TStream); { store should never be virtual;} - { Store calls the inherited Store method then writes the #CommandList# - to the stream. } - {#X Load } - end; { of TCommandRadioButtons } - - PEditListBox = ^TEditListBox; - TEditListBox = Object(TListBox) - CurrentField : Integer; - constructor Init (Bounds : TRect; ANumCols: Word; - AVScrollBar : PScrollBar); - constructor Load (var S : TStream); - function FieldValidator : PValidator; virtual; - function FieldWidth : Integer; virtual; - procedure GetField (InputLine : PInputLine); virtual; - function GetPalette : PPalette; virtual; - procedure HandleEvent (var Event : TEvent); virtual; - procedure SetField (InputLine : PInputLine); virtual; - function StartColumn : Integer; virtual; - PRIVATE - procedure EditField (var Event : TEvent); - end; { of TEditListBox } - - - PModalInputLine = ^TModalInputLine; - TModalInputLine = Object(TInputLine) - function Execute : Word; virtual; - procedure HandleEvent (var Event : TEvent); virtual; - procedure SetState (AState : Word; Enable : Boolean); virtual; - private - EndState : Word; - end; { of TModalInputLine } - -{---------------------------------------------------------------------------} -{ TDialog OBJECT - DIALOG OBJECT } -{---------------------------------------------------------------------------} - - { Palette layout } - { 1 = Frame passive } - { 2 = Frame active } - { 3 = Frame icon } - { 4 = ScrollBar page area } - { 5 = ScrollBar controls } - { 6 = StaticText } - { 7 = Label normal } - { 8 = Label selected } - { 9 = Label shortcut } - { 10 = Button normal } - { 11 = Button default } - { 12 = Button selected } - { 13 = Button disabled } - { 14 = Button shortcut } - { 15 = Button shadow } - { 16 = Cluster normal } - { 17 = Cluster selected } - { 18 = Cluster shortcut } - { 19 = InputLine normal text } - { 20 = InputLine selected text } - { 21 = InputLine arrows } - { 22 = History arrow } - { 23 = History sides } - { 24 = HistoryWindow scrollbar page area } - { 25 = HistoryWindow scrollbar controls } - { 26 = ListViewer normal } - { 27 = ListViewer focused } - { 28 = ListViewer selected } - { 29 = ListViewer divider } - { 30 = InfoPane } - { 31 = Cluster disabled } - { 32 = Reserved } - - PDialog = ^TDialog; - TDialog = object(TWindow) - constructor Init(var Bounds: TRect; ATitle: TTitleStr); - constructor Load(var S: TStream); - procedure Cancel (ACommand : Word); virtual; - { If the dialog is a modal dialog, Cancel calls EndModal(ACommand). If - the dialog is non-modal Cancel calls Close. - - Cancel may be overridden to provide special processing prior to - destructing the dialog. } - procedure ChangeTitle (ANewTitle : TTitleStr); virtual; - { ChangeTitle disposes of the current title, assigns ANewTitle to Title, - then redraws the dialog. } - procedure FreeSubView (ASubView : PView); virtual; - { FreeSubView deletes and disposes ASubView from the dialog. } - {#X FreeAllSubViews IsSubView } - procedure FreeAllSubViews; virtual; - { Deletes then disposes all subviews in the dialog. } - {#X FreeSubView IsSubView } - function GetPalette: PPalette; virtual; - procedure HandleEvent(var Event: TEvent); virtual; - function IsSubView (AView : PView) : Boolean; virtual; - { IsSubView returns True if AView is non-nil and is a subview of the - dialog. } - {#X FreeSubView FreeAllSubViews } - function NewButton (X, Y, W, H : Sw_Integer; ATitle : TTitleStr; - ACommand, AHelpCtx : Word; - AFlags : Byte) : PButton; - { Creates and inserts into the dialog a new TButton with the - help context AHelpCtx. - - A pointer to the new button is returned for checking validity of the - initialization. } - {#X NewInputLine NewLabel } - function NewLabel (X, Y : Sw_Integer; AText : String; - ALink : PView) : PLabel; - { NewLabel creates and inserts into the dialog a new TLabel and - associates it with ALink. } - {#X NewButton NewInputLine } - function NewInputLine (X, Y, W, AMaxLen : Sw_Integer; AHelpCtx : Word - ; AValidator : PValidator) : PInputLine; - { NewInputLine creates and inserts into the dialog a new TBSDInputLine - with the help context to AHelpCtx and the validator AValidator. - - A pointer to the inputline is returned for checking validity of the - initialization. } - {#X NewButton NewLabel } - function Valid(Command: Word): Boolean; virtual; - end; - - PListDlg = ^TListDlg; - TListDlg = object(TDialog) - { TListDlg displays a listbox of items, with optional New, Edit, and - Delete buttons displayed according to the options bit set in the - dialog. Use the ofXXXX flags declared in this unit OR'd with the - standard ofXXXX flags to set the appropriate bits in Options. - - If enabled, when the New or Edit buttons are pressed, an evCommand - message is sent to the application with a Command value of NewCommand - or EditCommand, respectively. Using this mechanism in combination with - the declared Init parameters, a standard TListDlg can be used with any - type of list displayable in a TListBox or its descendant. } - NewCommand: Word; - EditCommand: Word; - ListBox: PListBox; - ldOptions: Word; - constructor Init (ATitle: TTitleStr; Items: string; AButtons: Word; - AListBox: PListBox; AEditCommand, ANewCommand: Word); - constructor Load(var S: TStream); - procedure HandleEvent(var Event: TEvent); virtual; - procedure Store(var S: TStream); { store should never be virtual;} - end; { of TListDlg } - - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ ITEM STRING ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-NewSItem----------------------------------------------------------- -Allocates memory for a new TSItem record and sets the text field -and chains to the next TSItem. This allows easy construction of -singly-linked lists of strings, to end a chain the next TSItem -should be nil. -28Apr98 LdB ----------------------------------------------------------------------} -FUNCTION NewSItem (Const Str: String; ANext: PSItem): PSItem; - -{ NewCommandSItem allocates and returns a pointer to a new #TCommandSItem# - record. The Value and Next fields of the record are set to NewStr(Str) - and ANext, respectively. The NewSItem function and the TSItem record type - allow easy construction of singly-linked lists of command strings. } -function NewCommandSItem (Str : String; ACommand : Word; - ANext : PCommandSItem) : PCommandSItem; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ DIALOG OBJECT REGISTRATION PROCEDURE } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-RegisterDialogs---------------------------------------------------- -This registers all the view type objects used in this unit. -30Sep99 LdB ----------------------------------------------------------------------} -PROCEDURE RegisterDialogs; - -{***************************************************************************} -{ STREAM REGISTRATION RECORDS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TDialog STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RDialog: TStreamRec = ( - ObjType: idDialog; { Register id = 10 } - VmtLink: TypeOf(TDialog); - Load: @TDialog.Load; { Object load method } - Store: @TDialog.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TInputLine STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RInputLine: TStreamRec = ( - ObjType: idInputLine; { Register id = 11 } - VmtLink: TypeOf(TInputLine); - Load: @TInputLine.Load; { Object load method } - Store: @TInputLine.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TButton STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RButton: TStreamRec = ( - ObjType: idButton; { Register id = 12 } - VmtLink: TypeOf(TButton); - Load: @TButton.Load; { Object load method } - Store: @TButton.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TCluster STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RCluster: TStreamRec = ( - ObjType: idCluster; { Register id = 13 } - VmtLink: TypeOf(TCluster); - Load: @TCluster.Load; { Object load method } - Store: @TCluster.Store { Objects store method } - ); - -{---------------------------------------------------------------------------} -{ TRadioButtons STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RRadioButtons: TStreamRec = ( - ObjType: idRadioButtons; { Register id = 14 } - VmtLink: TypeOf(TRadioButtons); - Load: @TRadioButtons.Load; { Object load method } - Store: @TRadioButtons.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TCheckBoxes STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RCheckBoxes: TStreamRec = ( - ObjType: idCheckBoxes; { Register id = 15 } - VmtLink: TypeOf(TCheckBoxes); - Load: @TCheckBoxes.Load; { Object load method } - Store: @TCheckBoxes.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TMultiCheckBoxes STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RMultiCheckBoxes: TStreamRec = ( - ObjType: idMultiCheckBoxes; { Register id = 27 } - VmtLink: TypeOf(TMultiCheckBoxes); - Load: @TMultiCheckBoxes.Load; { Object load method } - Store: @TMultiCheckBoxes.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TListBox STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RListBox: TStreamRec = ( - ObjType: idListBox; { Register id = 16 } - VmtLink: TypeOf(TListBox); - Load: @TListBox.Load; { Object load method } - Store: @TListBox.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TStaticText STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RStaticText: TStreamRec = ( - ObjType: idStaticText; { Register id = 17 } - VmtLink: TypeOf(TStaticText); - Load: @TStaticText.Load; { Object load method } - Store: @TStaticText.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TLabel STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RLabel: TStreamRec = ( - ObjType: idLabel; { Register id = 18 } - VmtLink: TypeOf(TLabel); - Load: @TLabel.Load; { Object load method } - Store: @TLabel.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ THistory STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RHistory: TStreamRec = ( - ObjType: idHistory; { Register id = 19 } - VmtLink: TypeOf(THistory); - Load: @THistory.Load; { Object load method } - Store: @THistory.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TParamText STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RParamText: TStreamRec = ( - ObjType: idParamText; { Register id = 20 } - VmtLink: TypeOf(TParamText); - Load: @TParamText.Load; { Object load method } - Store: @TParamText.Store { Object store method } - ); - - RCommandCheckBoxes : TStreamRec = ( - ObjType : idCommandCheckBoxes; - VmtLink : Ofs(TypeOf(TCommandCheckBoxes)^); - Load : @TCommandCheckBoxes.Load; - Store : @TCommandCheckBoxes.Store); - - RCommandRadioButtons : TStreamRec = ( - ObjType : idCommandRadioButtons; - VmtLink : Ofs(TypeOf(TCommandRadioButtons)^); - Load : @TCommandRadioButtons.Load; - Store : @TCommandRadioButtons.Store); - - RCommandIcon : TStreamRec = ( - ObjType : idCommandIcon; - VmtLink : Ofs(Typeof(TCommandIcon)^); - Load : @TCommandIcon.Load; - Store : @TCommandIcon.Store); - - RBrowseButton: TStreamRec = ( - ObjType : idBrowseButton; - VmtLink : Ofs(TypeOf(TBrowseButton)^); - Load : @TBrowseButton.Load; - Store : @TBrowseButton.Store); - - REditListBox : TStreamRec = ( - ObjType : idEditListBox; - VmtLink : Ofs(TypeOf(TEditListBox)^); - Load : @TEditListBox.Load; - Store : @TEditListBox.Store); - - RListDlg : TStreamRec = ( - ObjType : idListDlg; - VmtLink : Ofs(TypeOf(TListDlg)^); - Load : @TListDlg.Load; - Store : @TListDlg.Store); - - RModalInputLine : TStreamRec = ( - ObjType : idModalInputLine; - VmtLink : Ofs(TypeOf(TModalInputLine)^); - Load : @TModalInputLine.Load; - Store : @TModalInputLine.Store); - -resourcestring slCancel='Cancel'; - slOk='O~k~'; - slYes='~Y~es'; - slNo='~N~o'; - - slHelp='~H~elp'; - slName='~N~ame'; - - slOpen='~O~pen'; - slClose='~C~lose'; - slCloseAll='Cl~o~se all'; - - slSave='~S~ave'; - slSaveAll='Save a~l~l'; - slSaveAs='S~a~ve as...'; - slSaveFileAs='~S~ave file as'; - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IMPLEMENTATION -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -USES App,HistList; { Standard GFV unit } - -{***************************************************************************} -{ PRIVATE DEFINED CONSTANTS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ LEFT AND RIGHT ARROW CHARACTER CONSTANTS } -{---------------------------------------------------------------------------} -CONST LeftArr = '<'; RightArr = '>'; - -{---------------------------------------------------------------------------} -{ TButton MESSAGES } -{---------------------------------------------------------------------------} -CONST - cmGrabDefault = 61; { Grab default } - cmReleaseDefault = 62; { Release default } - -{---------------------------------------------------------------------------} -{ IsBlank -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION IsBlank (Ch: Char): Boolean; -BEGIN - IsBlank := (Ch = ' ') OR (Ch = #13) OR (Ch = #10); { Check for characters } -END; - -{---------------------------------------------------------------------------} -{ HotKey -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION HotKey (Const S: String): Char; -VAR I: Sw_Word; -BEGIN - HotKey := #0; { Preset fail } - If (S <> '') Then Begin { Valid string } - I := Pos('~', S); { Search for tilde } - If (I <> 0) Then HotKey := UpCase(S[I+1]); { Return hotkey } - End; -END; - -{***************************************************************************} -{ OBJECT METHODS } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TDialog OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TDialog------------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TDialog.Init (Var Bounds: TRect; ATitle: TTitleStr); -BEGIN - Inherited Init(Bounds, ATitle, wnNoNumber); { Call ancestor } - Options := Options OR ofVersion20; { Version two dialog } - GrowMode := 0; { Clear grow mode } - Flags := wfMove + wfClose; { Close/moveable flags } - Palette := dpGrayDialog; { Default gray colours } -END; - -{--TDialog------------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TDialog.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - If (Options AND ofVersion = ofVersion10) Then Begin - Palette := dpGrayDialog; { Set gray palette } - Options := Options OR ofVersion20; { Update version flag } - End; -END; - -{--TDialog------------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TDialog.GetPalette: PPalette; -CONST P: Array[dpBlueDialog..dpGrayDialog] Of String[Length(CBlueDialog)] = - (CBlueDialog, CCyanDialog, CGrayDialog); { Always normal string } -BEGIN - GetPalette := PPalette(@P[Palette]); { Return palette } -END; - -{--TDialog------------------------------------------------------------------} -{ Valid -> Platforms DOS/DPMI/WIN/NT/Os2 - Updated 25Apr98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TDialog.Valid (Command: Word): Boolean; -BEGIN - If (Command = cmCancel) Then Valid := True { Cancel returns true } - Else Valid := TGroup.Valid(Command); { Call group ancestor } -END; - -{--TDialog------------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TDialog.HandleEvent (Var Event: TEvent); -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - Case Event.What Of - evNothing: Exit; { Speed up exit } - evKeyDown: { Key down event } - Case Event.KeyCode Of - kbEsc, kbCtrlF4: Begin { Escape key press } - Event.What := evCommand; { Command event } - Event.Command := cmCancel; { cancel command } - Event.InfoPtr := Nil; { Clear info ptr } - PutEvent(Event); { Put event on queue } - ClearEvent(Event); { Clear the event } - End; - kbCtrlF5: Begin { movement of modal dialogs } - If (State AND sfModal <> 0) Then - begin - Event.What := evCommand; - Event.Command := cmResize; - Event.InfoPtr := Nil; - PutEvent(Event); - ClearEvent(Event); - end; - End; - kbEnter: Begin { Enter key press } - Event.What := evBroadcast; { Broadcast event } - Event.Command := cmDefault; { Default command } - Event.InfoPtr := Nil; { Clear info ptr } - PutEvent(Event); { Put event on queue } - ClearEvent(Event); { Clear the event } - End; - End; - evCommand: { Command event } - Case Event.Command Of - cmOk, cmCancel, cmYes, cmNo: { End dialog cmds } - If (State AND sfModal <> 0) Then Begin { View is modal } - EndModal(Event.Command); { End modal state } - ClearEvent(Event); { Clear the event } - End; - End; - End; -END; - -{****************************************************************************} -{ TDialog.Cancel } -{****************************************************************************} -procedure TDialog.Cancel (ACommand : Word); -begin - if State and sfModal = sfModal then - EndModal(ACommand) - else Close; -end; - -{****************************************************************************} -{ TDialog.ChangeTitle } -{****************************************************************************} -procedure TDialog.ChangeTitle (ANewTitle : TTitleStr); -begin - if (Title <> nil) then - DisposeStr(Title); - Title := NewStr(ANewTitle); - Frame^.DrawView; -end; - -{****************************************************************************} -{ TDialog.FreeSubView } -{****************************************************************************} -procedure TDialog.FreeSubView (ASubView : PView); -begin - if IsSubView(ASubView) then begin - Delete(ASubView); - Dispose(ASubView,Done); - DrawView; - end; -end; - -{****************************************************************************} -{ TDialog.FreeAllSubViews } -{****************************************************************************} -procedure TDialog.FreeAllSubViews; -var - P : PView; -begin - P := First; - repeat - P := First; - if (P <> nil) then begin - Delete(P); - Dispose(P,Done); - end; - until (P = nil); - DrawView; -end; - -{****************************************************************************} -{ TDialog.IsSubView } -{****************************************************************************} -function TDialog.IsSubView (AView : PView) : Boolean; -var P : PView; -begin - P := First; - while (P <> nil) and (P <> AView) do - P := P^.NextView; - IsSubView := ((P <> nil) and (P = AView)); -end; - -{****************************************************************************} -{ TDialog.NewButton } -{****************************************************************************} -function TDialog.NewButton (X, Y, W, H : Sw_Integer; ATitle : TTitleStr; - ACommand, AHelpCtx : Word; - AFlags : Byte) : PButton; -var - B : PButton; - R : TRect; -begin - R.Assign(X,Y,X+W,Y+H); - B := New(PButton,Init(R,ATitle,ACommand,AFlags)); - if (B <> nil) then begin - B^.HelpCtx := AHelpCtx; - Insert(B); - end; - NewButton := B; -end; - -{****************************************************************************} -{ TDialog.NewInputLine } -{****************************************************************************} -function TDialog.NewInputLine (X, Y, W, AMaxLen : Sw_Integer; AHelpCtx : Word - ; AValidator : PValidator) : PInputLine; -var - P : PInputLine; - R : TRect; -begin - R.Assign(X,Y,X+W,Y+1); - P := New(PInputLine,Init(R,AMaxLen)); - if (P <> nil) then begin - P^.SetValidator(AValidator); - P^.HelpCtx := AHelpCtx; - Insert(P); - end; - NewInputLine := P; -end; - -{****************************************************************************} -{ TDialog.NewLabel } -{****************************************************************************} -function TDialog.NewLabel (X, Y : Sw_Integer; AText : String; - ALink : PView) : PLabel; -var - P : PLabel; - R : TRect; -begin - R.Assign(X,Y,X+CStrLen(AText)+1,Y+1); - P := New(PLabel,Init(R,AText,ALink)); - if (P <> nil) then - Insert(P); - NewLabel := P; -end; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TInputLine OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TInputLine---------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TInputLine.Init (Var Bounds: TRect; AMaxLen: Sw_Integer); -BEGIN - Inherited Init(Bounds); { Call ancestor } - State := State OR sfCursorVis; { Cursor visible } - Options := Options OR (ofSelectable + ofFirstClick - + ofVersion20); { Set options } - If (MaxAvail > AMaxLen + 1) Then Begin { Check enough memory } - GetMem(Data, AMaxLen + 1); { Allocate memory } - Data^ := ''; { Data = empty string } - End; - MaxLen := AMaxLen; { Hold maximum length } -END; - -{--TInputLine---------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TInputLine.Load (Var S: TStream); -VAR B: Byte; - W: Word; -BEGIN - Inherited Load(S); { Call ancestor } - S.Read(W, sizeof(w)); MaxLen:=W; { Read max length } - S.Read(W, sizeof(w)); CurPos:=w; { Read cursor position } - S.Read(W, sizeof(w)); FirstPos:=w; { Read first position } - S.Read(W, sizeof(w)); SelStart:=w; { Read selected start } - S.Read(W, sizeof(w)); SelEnd:=w; { Read selected end } - S.Read(B, SizeOf(B)); { Read string length } - GetMem(Data, B + 1); { Allocate memory } - S.Read(Data^[1], B); { Read string data } - SetLength(Data^, B); { Xfer string length } - If (Options AND ofVersion >= ofVersion20) Then { Version 2 or above } - Validator := PValidator(S.Get); { Get any validator } - Options := Options OR ofVersion20; { Set version 2 flag } -END; - -{--TInputLine---------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TInputLine.Done; -BEGIN - If (Data <> Nil) Then FreeMem(Data, MaxLen + 1); { Release any memory } - SetValidator(Nil); { Clear any validator } - Inherited Done; { Call ancestor } -END; - -{--TInputLine---------------------------------------------------------------} -{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TInputLine.DataSize: Sw_Word; -VAR DSize: Sw_Word; -BEGIN - DSize := 0; { Preset zero datasize } - If (Validator <> Nil) AND (Data <> Nil) Then - DSize := Validator^.Transfer(Data^, Nil, - vtDataSize); { Add validator size } - If (DSize <> 0) Then DataSize := DSize { Use validtor size } - Else DataSize := MaxLen + 1; { No validator use size } -END; - -{--TInputLine---------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TInputLine.GetPalette: PPalette; -CONST P: String[Length(CInputLine)] = CInputLine; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Return palette } -END; - -{--TInputLine---------------------------------------------------------------} -{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TInputLine.Valid (Command: Word): Boolean; - - FUNCTION AppendError (AValidator: PValidator): Boolean; - BEGIN - AppendError := False; { Preset false } - If (Data <> Nil) Then - With AValidator^ Do - If (Options AND voOnAppend <> 0) AND { Check options } - (CurPos <> Length(Data^)) AND { Exceeds max length } - NOT IsValidInput(Data^, True) Then Begin { Check data valid } - Error; { Call error } - AppendError := True; { Return true } - End; - END; - -BEGIN - Valid := Inherited Valid(Command); { Call ancestor } - If (Validator <> Nil) AND (Data <> Nil) AND { Validator present } - (State AND sfDisabled = 0) Then { Not disabled } - If (Command = cmValid) Then { Valid command } - Valid := Validator^.Status = vsOk { Validator result } - Else If (Command <> cmCancel) Then { Not cancel command } - If AppendError(Validator) OR { Append any error } - NOT Validator^.Valid(Data^) Then Begin { Check validator } - Select; { Reselect view } - Valid := False; { Return false } - End; -END; - -{--TInputLine---------------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TInputLine.Draw; -VAR Color: Byte; L, R: Sw_Integer; - B : TDrawBuffer; -BEGIN - if Options and ofSelectable = 0 then - Color := GetColor(5) - else - If (State AND sfFocused = 0) Then - Color := GetColor(1) { Not focused colour } - Else - Color := GetColor(2); { Focused colour } - MoveChar(B, ' ', Color, Size.X); - MoveStr(B[1], Copy(Data^, FirstPos + 1, Size.X - 2), Color); - if CanScroll(1) then - MoveChar(B[Size.X - 1], RightArr, GetColor(4), 1); - if (State and sfFocused <> 0) and - (Options and ofSelectable <> 0) then - begin - if CanScroll(-1) then - MoveChar(B[0], LeftArr, GetColor(4), 1); - { Highlighted part } - L := SelStart - FirstPos; - R := SelEnd - FirstPos; - if L < 0 then - L := 0; - if R > Size.X - 2 then - R := Size.X - 2; - if L < R then - MoveChar(B[L + 1], #0, GetColor(3), R - L); - SetCursor(CurPos - FirstPos + 1, 0); - end; - WriteLine(0, 0, Size.X, Size.Y, B); -end; - - -{--TInputLine---------------------------------------------------------------} -{ DrawCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TInputLine.DrawCursor; -BEGIN - If (State AND sfFocused <> 0) Then - Begin { Focused window } - Cursor.Y:=0; - Cursor.X:=CurPos-FirstPos+1; - ResetCursor; - end; -END; - -{--TInputLine---------------------------------------------------------------} -{ SelectAll -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TInputLine.SelectAll (Enable: Boolean); -BEGIN - CurPos := 0; { Cursor to start } - FirstPos := 0; { First pos to start } - SelStart := 0; { Selected at start } - If Enable AND (Data <> Nil) Then - SelEnd := Length(Data^) Else SelEnd := 0; { Selected which end } - DrawView; { Now redraw the view } -END; - -{--TInputLine---------------------------------------------------------------} -{ SetValidator -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TInputLine.SetValidator (AValid: PValidator); -BEGIN - If (Validator <> Nil) Then Validator^.Free; { Release validator } - Validator := AValid; { Set new validator } -END; - -{--TInputLine---------------------------------------------------------------} -{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TInputLine.SetState (AState: Word; Enable: Boolean); -BEGIN - Inherited SetState(AState, Enable); { Call ancestor } - If (AState = sfSelected) OR ((AState = sfActive) - AND (State and sfSelected <> 0)) Then - SelectAll(Enable) Else { Call select all } - If (AState = sfFocused) Then DrawView; { Redraw for focus } -END; - -{--TInputLine---------------------------------------------------------------} -{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TInputLine.GetData (Var Rec); -BEGIN - If (Data <> Nil) Then Begin { Data ptr valid } - If (Validator = Nil) OR (Validator^.Transfer(Data^, - @Rec, vtGetData) = 0) Then Begin { No validator/data } - FillChar(Rec, DataSize, #0); { Clear the data area } - Move(Data^, Rec, Length(Data^) + 1); { Transfer our data } - End; - End Else FillChar(Rec, DataSize, #0); { Clear the data area } -END; - -{--TInputLine---------------------------------------------------------------} -{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TInputLine.SetData (Var Rec); -BEGIN - If (Data <> Nil) Then Begin { Data ptr valid } - If (Validator = Nil) OR (Validator^.Transfer( - Data^, @Rec, vtSetData) = 0) Then { No validator/data } - Move(Rec, Data^[0], DataSize); { Set our data } - End; - SelectAll(True); { Now select all } -END; - -{--TInputLine---------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TInputLine.Store (Var S: TStream); -VAR w: Word; -BEGIN - TView.Store(S); { Implict TView.Store } - w:=MaxLen;S.Write(w, SizeOf(w)); { Read max length } - w:=CurPos;S.Write(w, SizeOf(w)); { Read cursor position } - w:=FirstPos;S.Write(w, SizeOf(w)); { Read first position } - w:=SelStart;S.Write(w, SizeOf(w)); { Read selected start } - w:=SelEnd;S.Write(w, SizeOf(w)); { Read selected end } - S.WriteStr(Data); { Write the data } - S.Put(Validator); { Write any validator } -END; - -{--TInputLine---------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TInputLine.HandleEvent (Var Event: TEvent); -CONST PadKeys = [$47, $4B, $4D, $4F, $73, $74]; -VAR WasAppending: Boolean; ExtendBlock: Boolean; OldData: String; -Delta, Anchor, OldCurPos, OldFirstPos, OldSelStart, OldSelEnd: Sw_Integer; - - FUNCTION MouseDelta: Sw_Integer; - VAR Mouse : TPOint; - BEGIN - MakeLocal(Event.Where, Mouse); - if Mouse.X <= 0 then - MouseDelta := -1 - else if Mouse.X >= Size.X - 1 then - MouseDelta := 1 - else - MouseDelta := 0; - END; - - FUNCTION MousePos: Sw_Integer; - VAR Pos: Sw_Integer; - Mouse : TPoint; - BEGIN - MakeLocal(Event.Where, Mouse); - if Mouse.X < 1 then Mouse.X := 1; - Pos := Mouse.X + FirstPos - 1; - if Pos < 0 then Pos := 0; - if Pos > Length(Data^) then Pos := Length(Data^); - MousePos := Pos; - END; - - PROCEDURE DeleteSelect; - BEGIN - If (SelStart <> SelEnd) Then Begin { An area selected } - If (Data <> Nil) Then - Delete(Data^, SelStart+1, SelEnd-SelStart); { Delete the text } - CurPos := SelStart; { Set cursor position } - End; - END; - - PROCEDURE AdjustSelectBlock; - BEGIN - If (CurPos < Anchor) Then Begin { Selection backwards } - SelStart := CurPos; { Start of select } - SelEnd := Anchor; { End of select } - End Else Begin - SelStart := Anchor; { Start of select } - SelEnd := CurPos; { End of select } - End; - END; - - PROCEDURE SaveState; - BEGIN - If (Validator <> Nil) Then Begin { Check for validator } - If (Data <> Nil) Then OldData := Data^; { Hold data } - OldCurPos := CurPos; { Hold cursor position } - OldFirstPos := FirstPos; { Hold first position } - OldSelStart := SelStart; { Hold select start } - OldSelEnd := SelEnd; { Hold select end } - If (Data = Nil) Then WasAppending := True { Invalid data ptr } - Else WasAppending := Length(Data^) = CurPos; { Hold appending state } - End; - END; - - PROCEDURE RestoreState; - BEGIN - If (Validator <> Nil) Then Begin { Validator valid } - If (Data <> Nil) Then Data^ := OldData; { Restore data } - CurPos := OldCurPos; { Restore cursor pos } - FirstPos := OldFirstPos; { Restore first pos } - SelStart := OldSelStart; { Restore select start } - SelEnd := OldSelEnd; { Restore select end } - End; - END; - - FUNCTION CheckValid (NoAutoFill: Boolean): Boolean; - VAR OldLen: Sw_Integer; NewData: String; - BEGIN - If (Validator <> Nil) Then Begin { Validator valid } - CheckValid := False; { Preset false return } - If (Data <> Nil) Then OldLen := Length(Data^); { Hold old length } - If (Validator^.Options AND voOnAppend = 0) OR - (WasAppending AND (CurPos = OldLen)) Then Begin - If (Data <> Nil) Then NewData := Data^ { Hold current data } - Else NewData := ''; { Set empty string } - If NOT Validator^.IsValidInput(NewData, - NoAutoFill) Then RestoreState Else Begin - If (Length(NewData) > MaxLen) Then { Exceeds maximum } - SetLength(NewData, MaxLen); { Set string length } - If (Data <> Nil) Then Data^ := NewData; { Set data value } - If (Data <> Nil) AND (CurPos >= OldLen) { Cursor beyond end } - AND (Length(Data^) > OldLen) Then { Cursor beyond string } - CurPos := Length(Data^); { Set cursor position } - CheckValid := True; { Return true result } - End; - End Else Begin - CheckValid := True; { Preset true return } - If (CurPos = OldLen) AND (Data <> Nil) Then { Lengths match } - If NOT Validator^.IsValidInput(Data^, - False) Then Begin { Check validator } - Validator^.Error; { Call error } - CheckValid := False; { Return false result } - End; - End; - End Else CheckValid := True; { No validator } - END; - -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - If (State AND sfSelected <> 0) Then Begin { View is selected } - Case Event.What Of - evNothing: Exit; { Speed up exit } - evMouseDown: Begin { Mouse down event } - Delta := MouseDelta; { Calc scroll value } - If CanScroll(Delta) Then Begin { Can scroll } - Repeat - If CanScroll(Delta) Then Begin { Still can scroll } - Inc(FirstPos, Delta); { Move start position } - DrawView; { Redraw the view } - End; - Until NOT MouseEvent(Event, evMouseAuto); { Until no mouse auto } - End Else If Event.Double Then { Double click } - SelectAll(True) Else Begin { Select whole text } - Anchor := MousePos; { Start of selection } - Repeat - If (Event.What = evMouseAuto) { Mouse auto event } - Then Begin - Delta := MouseDelta; { New position } - If CanScroll(Delta) Then { If can scroll } - Inc(FirstPos, Delta); - End; - CurPos := MousePos; { Set cursor position } - AdjustSelectBlock; { Adjust selected } - DrawView; { Redraw the view } - Until NOT MouseEvent(Event, evMouseMove - + evMouseAuto); { Until mouse released } - End; - ClearEvent(Event); { Clear the event } - End; - evKeyDown: Begin - SaveState; { Save state of view } - Event.KeyCode := CtrlToArrow(Event.KeyCode); { Convert keycode } - If (Event.ScanCode IN PadKeys) AND - (GetShiftState AND $03 <> 0) Then Begin { Mark selection active } - Event.CharCode := #0; { Clear char code } - If (CurPos = SelEnd) Then { Find if at end } - Anchor := SelStart Else { Anchor from start } - Anchor := SelEnd; { Anchor from end } - ExtendBlock := True; { Extended block true } - End Else ExtendBlock := False; { No extended block } - Case Event.KeyCode Of - kbLeft: If (CurPos > 0) Then Dec(CurPos); { Move cursor left } - kbRight: If (Data <> Nil) AND { Move right cursor } - (CurPos < Length(Data^)) Then Begin { Check not at end } - Inc(CurPos); { Move cursor } - CheckValid(True); { Check if valid } - End; - kbHome: CurPos := 0; { Move to line start } - kbEnd: Begin { Move to line end } - If (Data = Nil) Then CurPos := 0 { Invalid data ptr } - Else CurPos := Length(Data^); { Set cursor position } - CheckValid(True); { Check if valid } - End; - kbBack: If (Data <> Nil) AND (CurPos > 0) { Not at line start } - Then Begin - Delete(Data^, CurPos, 1); { Backspace over char } - Dec(CurPos); { Move cursor back one } - If (FirstPos > 0) Then Dec(FirstPos); { Move first position } - CheckValid(True); { Check if valid } - End; - kbDel: If (Data <> Nil) Then Begin { Delete character } - If (SelStart = SelEnd) Then { Select all on } - If (CurPos < Length(Data^)) Then Begin { Cursor not at end } - SelStart := CurPos; { Set select start } - SelEnd := CurPos + 1; { Set select end } - End; - DeleteSelect; { Deselect selection } - CheckValid(True); { Check if valid } - End; - kbIns: SetState(sfCursorIns, State AND - sfCursorIns = 0); { Flip insert state } - Else Case Event.CharCode Of - ' '..#255: If (Data <> Nil) Then Begin { Character key } - If (State AND sfCursorIns <> 0) Then - Delete(Data^, CurPos + 1, 1) Else { Overwrite character } - DeleteSelect; { Deselect selected } - If CheckValid(True) Then Begin { Check data valid } - If (Length(Data^) < MaxLen) Then { Must not exceed maxlen } - Begin - If (FirstPos > CurPos) Then - FirstPos := CurPos; { Advance first position } - Inc(CurPos); { Increment cursor } - Insert(Event.CharCode, Data^, - CurPos); { Insert the character } - End; - CheckValid(False); { Check data valid } - End; - End; - ^Y: If (Data <> Nil) Then Begin { Clear all data } - Data^ := ''; { Set empty string } - CurPos := 0; { Cursor to start } - End; - Else Exit; { Unused key } - End - End; - If ExtendBlock Then AdjustSelectBlock { Extended block } - Else Begin - SelStart := CurPos; { Set select start } - SelEnd := CurPos; { Set select end } - End; - If (FirstPos > CurPos) Then - FirstPos := CurPos; { Advance first pos } - If (Data <> Nil) Then OldData := Copy(Data^, - FirstPos+1, CurPos-FirstPos) { Text area string } - Else OldData := ''; { Empty string } - Delta := 1; { Safety = 1 char } - While (TextWidth(OldData) > (Size.X-Delta) - - TextWidth(LeftArr) - TextWidth(RightArr)) { Check text fits } - Do Begin - Inc(FirstPos); { Advance first pos } - OldData := Copy(Data^, FirstPos+1, - CurPos-FirstPos) { Text area string } - End; - DrawView; { Redraw the view } - ClearEvent(Event); { Clear the event } - End; - End; - End; -END; - -{***************************************************************************} -{ TInputLine OBJECT PRIVATE METHODS } -{***************************************************************************} -{--TInputLine---------------------------------------------------------------} -{ CanScroll -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TInputLine.CanScroll (Delta: Sw_Integer): Boolean; -VAR S: String; -BEGIN - If (Delta < 0) Then CanScroll := FirstPos > 0 { Check scroll left } - Else If (Delta > 0) Then Begin - If (Data = Nil) Then S := '' Else { Data ptr invalid } - S := Copy(Data^, FirstPos+1, Length(Data^) - - FirstPos); { Fetch max string } - CanScroll := (TextWidth(S)) > (Size.X - - TextWidth(LeftArr) - TextWidth(RightArr)); { Check scroll right } - End Else CanScroll := False; { Zero so no scroll } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TButton OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TButton------------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TButton.Init (Var Bounds: TRect; ATitle: TTitleStr; - ACommand: Word; AFlags: Word); -BEGIN - Inherited Init(Bounds); { Call ancestor } - EventMask := EventMask OR evBroadcast; { Handle broadcasts } - Options := Options OR (ofSelectable + ofFirstClick - + ofPreProcess + ofPostProcess); { Set option flags } - If NOT CommandEnabled(ACommand) Then - State := State OR sfDisabled; { Check command state } - Flags := AFlags; { Hold flags } - If (AFlags AND bfDefault <> 0) Then AmDefault := True - Else AmDefault := False; { Check if default } - Title := NewStr(ATitle); { Hold title string } - Command := ACommand; { Hold button command } - TabMask := TabMask OR (tmLeft + tmRight + - tmTab + tmShiftTab + tmUp + tmDown); { Set tab masks } -END; - -{--TButton------------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TButton.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - Title := S.ReadStr; { Read title } - S.Read(Command, SizeOf(Command)); { Read command } - S.Read(Flags, SizeOf(Flags)); { Read flags } - S.Read(AmDefault, SizeOf(AmDefault)); { Read if default } - If NOT CommandEnabled(Command) Then { Check command state } - State := State OR sfDisabled Else { Command disabled } - State := State AND NOT sfDisabled; { Command enabled } -END; - -{--TButton------------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TButton.Done; -BEGIN - If (Title <> Nil) Then DisposeStr(Title); { Dispose title } - Inherited Done; { Call ancestor } -END; - -{--TButton------------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TButton.GetPalette: PPalette; -CONST P: String[Length(CButton)] = CButton; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Get button palette } -END; - -{--TButton------------------------------------------------------------------} -{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TButton.Press; -VAR E: TEvent; -BEGIN - Message(Owner, evBroadcast, cmRecordHistory, Nil); { Message for history } - If (Flags AND bfBroadcast <> 0) Then { Broadcasting button } - Message(Owner, evBroadcast, Command, @Self) { Send message } - Else Begin - E.What := evCommand; { Command event } - E.Command := Command; { Set command value } - E.InfoPtr := @Self; { Pointer to self } - PutEvent(E); { Put event on queue } - End; -END; - -{--TButton------------------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TButton.Draw; -VAR I, J, Pos: Sw_Integer; - Bc: Word; Db: TDrawBuffer; - C : char; -BEGIN - If (State AND sfDisabled <> 0) Then { Button disabled } - Bc := GetColor($0404) Else Begin { Disabled colour } - Bc := GetColor($0501); { Set normal colour } - If (State AND sfActive <> 0) Then { Button is active } - If (State AND sfSelected <> 0) Then - Bc := GetColor($0703) Else { Set selected colour } - If AmDefault Then Bc := GetColor($0602); { Set is default colour } - End; - if title=nil then - begin - MoveChar(Db[0],' ',GetColor(8),1); - {No title, draw an empty button.} - for j:=sw_integer(downflag) to size.x-2 do - MoveChar(Db[j],' ',Bc,1); - end - else - {We have a title.} - begin - If (Flags AND bfLeftJust = 0) Then Begin { Not left set title } - I := CTextWidth(Title^); { Fetch title width } - I := (Size.X - I) DIV 2; { Centre in button } - End - Else - I := 1; { Left edge of button } - If DownFlag then - begin - MoveChar(Db[0],' ',GetColor(8),1); - Pos:=1; - end - else - pos:=0; - For j:=0 to I-1 do - MoveChar(Db[pos+j],' ',Bc,1); - MoveCStr(Db[I+pos], Title^, Bc); { Move title to buffer } - For j:=pos+CStrLen(Title^)+I to size.X-2 do - MoveChar(Db[j],' ',Bc,1); - end; - If not DownFlag then - Bc:=GetColor(8); - MoveChar(Db[Size.X-1],' ',Bc,1); - WriteLine(0, 0, Size.X,1, Db); { Write the title } - If Size.Y>1 then Begin - Bc:=GetColor(8); - if not DownFlag then - begin - c:='Ü'; - MoveChar(Db,c,Bc,1); - WriteLine(Size.X-1, 0, 1, 1, Db); - end; - MoveChar(Db,' ',Bc,1); - if DownFlag then c:=' ' - else c:='ß'; - MoveChar(Db[1],c,Bc,Size.X-1); - WriteLine(0, 1, Size.X, 1, Db); - End; -END; - -{--TButton------------------------------------------------------------------} -{ DrawState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TButton.DrawState (Down: Boolean); -BEGIN - DownFlag := Down; { Set down flag } - DrawView; { Redraw the view } -END; - -{--TButton------------------------------------------------------------------} -{ MakeDefault -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TButton.MakeDefault (Enable: Boolean); -VAR C: Word; -BEGIN - If (Flags AND bfDefault=0) Then Begin { Not default } - If Enable Then C := cmGrabDefault - Else C := cmReleaseDefault; { Change default } - Message(Owner, evBroadcast, C, @Self); { Message to owner } - AmDefault := Enable; { Set default flag } - DrawView; { Now redraw button } - End; -END; - -{--TButton------------------------------------------------------------------} -{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TButton.SetState (AState: Word; Enable: Boolean); -BEGIN - Inherited SetState(AState, Enable); { Call ancestor } - If (AState AND (sfSelected + sfActive) <> 0) { Changing select } - Then DrawView; { Redraw required } - If (AState AND sfFocused <> 0) Then - MakeDefault(Enable); { Check for default } -END; - -{--TButton------------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TButton.Store (Var S: TStream); -BEGIN - TView.Store(S); { Implict TView.Store } - S.WriteStr(Title); { Store title string } - S.Write(Command, SizeOf(Command)); { Store command } - S.Write(Flags, SizeOf(Flags)); { Store flags } - S.Write(AmDefault, SizeOf(AmDefault)); { Store default flag } -END; - -{--TButton------------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TButton.HandleEvent (Var Event: TEvent); -VAR Down: Boolean; C: Char; ButRect: TRect; - Mouse : TPoint; -BEGIN - ButRect.A.X := 0; { Get origin point } - ButRect.A.Y := 0; { Get origin point } - ButRect.B.X := Size.X + 2; { Calc right side } - ButRect.B.Y := Size.Y + 1; { Calc bottom } - If (Event.What = evMouseDown) Then Begin { Mouse down event } - MakeLocal(Event.Where, Mouse); - If NOT ButRect.Contains(Mouse) Then Begin { If point not in view } - ClearEvent(Event); { Clear the event } - Exit; { Speed up exit } - End; - End; - If (Flags AND bfGrabFocus <> 0) Then { Check focus grab } - Inherited HandleEvent(Event); { Call ancestor } - Case Event.What Of - evNothing: Exit; { Speed up exit } - evMouseDown: Begin - If (State AND sfDisabled = 0) Then Begin { Button not disabled } - Down := False; { Clear down flag } - Repeat - MakeLocal(Event.Where, Mouse); - If (Down <> ButRect.Contains(Mouse)) { State has changed } - Then Begin - Down := NOT Down; { Invert down flag } - DrawState(Down); { Redraw button } - End; - Until NOT MouseEvent(Event, evMouseMove); { Wait for mouse move } - If Down Then Begin { Button is down } - Press; { Send out command } - DrawState(False); { Draw button up } - End; - End; - ClearEvent(Event); { Event was handled } - End; - evKeyDown: Begin - If (Title <> Nil) Then C := HotKey(Title^) { Key title hotkey } - Else C := #0; { Invalid title } - If (Event.KeyCode = GetAltCode(C)) OR { Alt char } - (Owner^.Phase = phPostProcess) AND (C <> #0) - AND (Upcase(Event.CharCode) = C) OR { Matches hotkey } - (State AND sfFocused <> 0) AND { View focused } - ((Event.CharCode = ' ') OR { Space bar } - (Event.KeyCode=kbEnter)) Then Begin { Enter key } - DrawState(True); { Draw button down } - Press; { Send out command } - ClearEvent(Event); { Clear the event } - DrawState(False); { Draw button up } - End; - End; - evBroadcast: - Case Event.Command of - cmDefault: If AmDefault AND { Default command } - (State AND sfDisabled = 0) Then Begin { Button enabled } - Press; { Send out command } - ClearEvent(Event); { Clear the event } - End; - cmGrabDefault, cmReleaseDefault: { Grab and release cmd } - If (Flags AND bfDefault <> 0) Then Begin { Change button state } - AmDefault := Event.Command = cmReleaseDefault; - DrawView; { Redraw the view } - End; - cmCommandSetChanged: Begin { Command set changed } - SetState(sfDisabled, NOT - CommandEnabled(Command)); { Set button state } - DrawView; { Redraw the view } - End; - End; - End; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TCluster OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -CONST TvClusterClassName = 'TVCLUSTER'; - -{--TCluster-----------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TCluster.Init (Var Bounds: TRect; AStrings: PSItem); -VAR I: Sw_Integer; P: PSItem; -BEGIN - Inherited Init(Bounds); { Call ancestor } - Options := Options OR (ofSelectable + ofFirstClick - + ofPreProcess + ofPostProcess + ofVersion20); { Set option masks } - I := 0; { Zero string count } - P := AStrings; { First item } - While (P <> Nil) Do Begin - Inc(I); { Count 1 item } - P := P^.Next; { Move to next item } - End; - Strings.Init(I, 0); { Create collection } - While (AStrings <> Nil) Do Begin - P := AStrings; { Transfer item ptr } - Strings.AtInsert(Strings.Count, AStrings^.Value);{ Insert string } - AStrings := AStrings^.Next; { Move to next item } - Dispose(P); { Dispose prior item } - End; - Sel := 0; - SetCursor(2,0); - ShowCursor; - EnableMask := Sw_Integer($FFFFFFFF); { Enable bit masks } -END; - -{--TCluster-----------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TCluster.Load (Var S: TStream); -VAR w: word; -BEGIN - Inherited Load(S); { Call ancestor } - If ((Options AND ofVersion) >= ofVersion20) Then { Version 2 TV view } - Begin - S.Read(Value, SizeOf(Value)); { Read value } - S.Read(Sel, Sizeof(Sel)); { Read select item } - S.Read(EnableMask, SizeOf(EnableMask)) { Read enable masks } - End - Else - Begin - w:=Value; - S.Read(w, SizeOf(w)); Value:=w; { Read value } - S.Read(Sel, SizeOf(Sel)); { Read select item } - EnableMask := Sw_integer($FFFFFFFF); { Enable all masks } - Options := Options OR ofVersion20; { Set version 2 mask } - End; - Strings.Load(S); { Load string data } - SetButtonState(0, True); { Set button state } -END; - -{--TCluster-----------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TCluster.Done; -BEGIN - Strings.Done; { Dispose of strings } - Inherited Done; { Call ancestor } -END; - -{--TCluster-----------------------------------------------------------------} -{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TCluster.DataSize: Sw_Word; -BEGIN - DataSize := SizeOf(Sw_Word); { Exchanges a word } -END; - -{--TCluster-----------------------------------------------------------------} -{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TCluster.GetHelpCtx: Word; -BEGIN - If (HelpCtx = hcNoContext) Then { View has no help } - GetHelpCtx := hcNoContext Else { No help context } - GetHelpCtx := HelpCtx + Sel; { Help of selected } -END; - -{--TCluster-----------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TCluster.GetPalette: PPalette; -CONST P: String[Length(CCluster)] = CCluster; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Cluster palette } -END; - -{--TCluster-----------------------------------------------------------------} -{ Mark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TCluster.Mark (Item: Sw_Integer): Boolean; -BEGIN - Mark := False; { Default false } -END; - -{--TCluster-----------------------------------------------------------------} -{ MultiMark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TCluster.MultiMark (Item: Sw_Integer): Byte; -BEGIN - MultiMark := Byte(Mark(Item) = True); { Return multi mark } -END; - -{--TCluster-----------------------------------------------------------------} -{ ButtonState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TCluster.ButtonState (Item: Sw_Integer): Boolean; -BEGIN - If (Item > 31) Then ButtonState := False Else { Impossible item } - ButtonState := ((1 SHL Item) AND EnableMask)<>0; { Return true/false } -END; - -{--TCluster-----------------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.Draw; -BEGIN -END; - -{--TCluster-----------------------------------------------------------------} -{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.Press (Item: Sw_Integer); -VAR P: PView; -BEGIN - P := TopView; - If (Id <> 0) AND (P <> Nil) Then NewMessage(P, - evCommand, cmIdCommunicate, Id, Value, @Self); { Send new message } -END; - -{--TCluster-----------------------------------------------------------------} -{ MovedTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.MovedTo (Item: Sw_Integer); -BEGIN { Abstract method } -END; - -{--TCluster-----------------------------------------------------------------} -{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.SetState (AState: Word; Enable: Boolean); -BEGIN - Inherited SetState(AState, Enable); { Call ancestor } - If (AState AND sfFocused <> 0) Then Begin - DrawView; { Redraw masked areas } - End; -END; - -{--TCluster-----------------------------------------------------------------} -{ DrawMultiBox -> Platforms DOS/DPMI/WIN/NT - Updated 05Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.DrawMultiBox (Const Icon, Marker: String); -VAR I, J, Cur, Col: Sw_Integer; CNorm, CSel, CDis, Color: Word; B: TDrawBuffer; -BEGIN - CNorm := GetColor($0301); { Normal colour } - CSel := GetColor($0402); { Selected colour } - CDis := GetColor($0505); { Disabled colour } - For I := 0 To Size.Y-1 Do Begin { For each line } - MoveChar(B, ' ', Byte(CNorm), Size.X); { Fill buffer } - For J := 0 To (Strings.Count - 1) DIV Size.Y + 1 - Do Begin - Cur := J*Size.Y + I; { Current line } - If (Cur < Strings.Count) Then Begin - Col := Column(Cur); { Calc column } - If (Col + CStrLen(PString(Strings.At(Cur))^)+ - 5 < Sizeof(TDrawBuffer) DIV SizeOf(Word)) - AND (Col < Size.X) Then Begin { Text fits in column } - If NOT ButtonState(Cur) Then - Color := CDis Else If (Cur = Sel) AND { Disabled colour } - (State and sfFocused <> 0) Then - Color := CSel Else { Selected colour } - Color := CNorm; { Normal colour } - MoveChar(B[Col], ' ', Byte(Color), - Size.X-Col); { Set this colour } - MoveStr(B[Col], Icon, Byte(Color)); { Transfer icon string } - WordRec(B[Col+2]).Lo := Byte(Marker[ - MultiMark(Cur) + 1]); { Transfer marker } - MoveCStr(B[Col+5], PString(Strings.At( - Cur))^, Color); { Transfer item string } - If ShowMarkers AND (State AND sfFocused <> 0) - AND (Cur = Sel) Then Begin { Current is selected } - WordRec(B[Col]).Lo := Byte(SpecialChars[0]); - WordRec(B[Column(Cur+Size.Y)-1]).Lo - := Byte(SpecialChars[1]); { Set special character } - End; - End; - End; - End; - WriteBuf(0, I, Size.X, 1, B); { Write buffer } - End; - SetCursor(Column(Sel)+2,Row(Sel)); -END; - -{--TCluster-----------------------------------------------------------------} -{ DrawBox -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.DrawBox (Const Icon: String; Marker: Char); -BEGIN - DrawMultiBox(Icon, ' '+Marker); { Call draw routine } -END; - -{--TCluster-----------------------------------------------------------------} -{ SetButtonState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.SetButtonState (AMask: Longint; Enable: Boolean); -VAR I: Sw_Integer; M: Longint; -BEGIN - If Enable Then EnableMask := EnableMask OR AMask { Set enable bit mask } - Else EnableMask := EnableMask AND NOT AMask; { Disable bit mask } - If (Strings.Count <= 32) Then Begin { Valid string number } - M := 1; { Preset bit masks } - For I := 1 To Strings.Count Do Begin { For each item string } - If ((M AND EnableMask) <> 0) Then Begin { Bit enabled } - Options := Options OR ofSelectable; { Set selectable option } - Exit; { Now exit } - End; - M := M SHL 1; { Create newbit mask } - End; - Options := Options AND NOT ofSelectable; { Make not selectable } - End; -END; - -{--TCluster-----------------------------------------------------------------} -{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.GetData (Var Rec); -BEGIN - sw_Word(Rec) := Value; { Return current value } -END; - -{--TCluster-----------------------------------------------------------------} -{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.SetData (Var Rec); -BEGIN - Value :=sw_Word(Rec); { Set current value } - DrawView; { Redraw masked areas } -END; - -{--TCluster-----------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.Store (Var S: TStream); -var - w : word; -BEGIN - TView.Store(S); { TView.Store called } - If ((Options AND ofVersion) >= ofVersion20) { Version 2 TV view } - Then Begin - S.Write(Value, SizeOf(Value)); { Write value } - S.Write(Sel, SizeOf(Sel)); { Write select item } - S.Write(EnableMask, SizeOf(EnableMask)); { Write enable masks } - End Else Begin - w:=Value; - S.Write(w, SizeOf(Word)); { Write value } - S.Write(Sel, SizeOf(Sel)); { Write select item } - End; - Strings.Store(S); { Store strings } -END; - -{--TCluster-----------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCluster.HandleEvent (Var Event: TEvent); -VAR C: Char; I, S, Vh: Sw_Integer; Key: Word; Mouse: TPoint; Ts: PString; - - PROCEDURE MoveSel; - BEGIN - If (I <= Strings.Count) Then Begin - Sel := S; { Set selected item } - MovedTo(Sel); { Move to selected } - DrawView; { Now draw changes } - End; - END; - -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - If ((Options AND ofSelectable) = 0) Then Exit; { Check selectable } - If (Event.What = evMouseDown) Then Begin { MOUSE EVENT } - MakeLocal(Event.Where, Mouse); { Make point local } - I := FindSel(Mouse); { Find selected item } - If (I <> -1) Then { Check in view } - If ButtonState(I) Then Sel := I; { If enabled select } - DrawView; { Now draw changes } - Repeat - MakeLocal(Event.Where, Mouse); { Make point local } - Until NOT MouseEvent(Event, evMouseMove); { Wait for mouse up } - MakeLocal(Event.Where, Mouse); { Make point local } - If (FindSel(Mouse) = Sel) AND ButtonState(Sel) { If valid/selected } - Then Begin - Press(Sel); { Call pressed } - DrawView; { Now draw changes } - End; - ClearEvent(Event); { Event was handled } - End Else If (Event.What = evKeyDown) Then Begin { KEY EVENT } - Vh := Size.Y; { View height } - S := Sel; { Hold current item } - Key := CtrlToArrow(Event.KeyCode); { Convert keystroke } - Case Key Of - kbUp, kbDown, kbRight, kbLeft: - If (State AND sfFocused <> 0) Then Begin { Focused key event } - I := 0; { Zero process count } - Repeat - Inc(I); { Inc process count } - Case Key Of - kbUp: Dec(S); { Next item up } - kbDown: Inc(S); { Next item down } - kbRight: Begin { Next column across } - Inc(S, Vh); { Move to next column } - If (S >= Strings.Count) Then { No next column check } - S := (S+1) MOD Vh; { Move to last column } - End; - kbLeft: Begin { Prior column across } - Dec(S, Vh); { Move to prior column } - If (S < 0) Then S := ((Strings.Count + - Vh - 1) DIV Vh) * Vh + S - 1; { No prior column check } - End; - End; - If (S >= Strings.Count) Then S := 0; { Roll up to top } - If (S < 0) Then S := Strings.Count - 1; { Roll down to bottom } - Until ButtonState(S) OR (I > Strings.Count); { Repeat until select } - MoveSel; { Move to selected } - ClearEvent(Event); { Event was handled } - End; - Else Begin { Not an arrow key } - For I := 0 To Strings.Count-1 Do Begin { Scan each item } - Ts := Strings.At(I); { Fetch string pointer } - If (Ts <> Nil) Then C := HotKey(Ts^) { Check for hotkey } - Else C := #0; { No valid string } - If (GetAltCode(C) = Event.KeyCode) OR { Hot key for item } - (((Owner^.Phase = phPostProcess) OR { Owner in post process } - (State AND sfFocused <> 0)) AND (C <> #0) { Non zero hotkey } - AND (UpCase(Event.CharCode) = C)) { Matches current key } - Then Begin - If ButtonState(I) Then Begin { Check mask enabled } - If Focus Then Begin { Check view focus } - Sel := I; { Set selected } - MovedTo(Sel); { Move to selected } - Press(Sel); { Call pressed } - DrawView; { Now draw changes } - End; - ClearEvent(Event); { Event was handled } - End; - Exit; { Now exit } - End; - End; - If (Event.CharCode = ' ') AND { Spacebar key } - (State AND sfFocused <> 0) AND { Check focused view } - ButtonState(Sel) Then Begin { Check item enabled } - Press(Sel); { Call pressed } - DrawView; { Now draw changes } - ClearEvent(Event); { Event was handled } - End; - End; - End; - End; -END; - -{***************************************************************************} -{ TCluster OBJECT PRIVATE METHODS } -{***************************************************************************} - -{--TCluster-----------------------------------------------------------------} -{ FindSel -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TCluster.FindSel (P: TPoint): Sw_Integer; -VAR I, S, Vh: Sw_Integer; R: TRect; -BEGIN - GetExtent(R); { Get view extents } - If R.Contains(P) Then Begin { Point in view } - Vh := Size.Y; { View height } - I := 0; { Preset zero value } - While (P.X >= Column(I+Vh)) Do Inc(I, Vh); { Inc view size } - S := I + P.Y; { Line to select } - If ((S >= 0) AND (S < Strings.Count)) { Valid selection } - Then FindSel := S Else FindSel := -1; { Return selected item } - End Else FindSel := -1; { Point outside view } -END; - -{--TCluster-----------------------------------------------------------------} -{ Row -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TCluster.Row (Item: Sw_Integer): Sw_Integer; -BEGIN - Row := Item MOD Size.Y; { Normal mod value } -END; - -{--TCluster-----------------------------------------------------------------} -{ Column -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TCluster.Column (Item: Sw_Integer): Sw_Integer; -VAR I, Col, Width, L, Vh: Sw_Integer; Ts: PString; -BEGIN - Vh := Size.Y; { Vertical size } - If (Item >= Vh) Then Begin { Valid selection } - Width := 0; { Zero width } - Col := -6; { Start column at -6 } - For I := 0 To Item Do Begin { For each item } - If (I MOD Vh = 0) Then Begin { Start next column } - Inc(Col, Width + 6); { Add column width } - Width := 0; { Zero width } - End; - If (I < Strings.Count) Then Begin { Valid string } - Ts := Strings.At(I); { Transfer string } - If (Ts <> Nil) Then L := CStrLen(Ts^) { Length of string } - Else L := 0; { No string } - End; - If (L > Width) Then Width := L; { Hold longest string } - End; - Column := Col; { Return column } - End Else Column := 0; { Outside select area } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TRadioButtons OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TRadioButtons------------------------------------------------------------} -{ Mark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TRadioButtons.Mark (Item: Sw_Integer): Boolean; -BEGIN - Mark := Item = Value; { True if item = value } -END; - -{--TRadioButtons------------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TRadioButtons.Draw; -CONST Button = ' ( ) '; -BEGIN - Inherited Draw; - DrawMultiBox(Button, ' *'); { Redraw the text } -END; - -{--TRadioButtons------------------------------------------------------------} -{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TRadioButtons.Press (Item: Sw_Integer); -BEGIN - Value := Item; { Set value field } - Inherited Press(Item); { Call ancestor } -END; - -{--TRadioButtons------------------------------------------------------------} -{ MovedTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TRadioButtons.MovedTo (Item: Sw_Integer); -BEGIN - Value := Item; { Set value to item } - If (Id <> 0) Then NewMessage(Owner, evCommand, - cmIdCommunicate, Id, Value, @Self); { Send new message } -END; - -{--TRadioButtons------------------------------------------------------------} -{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TRadioButtons.SetData (Var Rec); -BEGIN - Sel := Sw_word(Rec); { Set selection } - Inherited SetData(Rec); { Call ancestor } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TCheckBoxes OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TCheckBoxes--------------------------------------------------------------} -{ Mark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TCheckBoxes.Mark(Item: Sw_Integer): Boolean; -BEGIN - If (Value AND (1 SHL Item) <> 0) Then { Check if item ticked } - Mark := True Else Mark := False; { Return result } -END; - -{--TCheckBoxes--------------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCheckBoxes.Draw; -CONST Button = ' [ ] '; -BEGIN - Inherited Draw; - DrawMultiBox(Button, ' X'); { Redraw the text } -END; - -{--TCheckBoxes--------------------------------------------------------------} -{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TCheckBoxes.Press (Item: Sw_Integer); -BEGIN - Value := Value XOR (1 SHL Item); { Flip the item mask } - Inherited Press(Item); { Call ancestor } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TMultiCheckBoxes OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TMultiCheckBoxes---------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Jun98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TMultiCheckBoxes.Init (Var Bounds: TRect; AStrings: PSItem; -ASelRange: Byte; AFlags: Word; Const AStates: String); -BEGIN - Inherited Init(Bounds, AStrings); { Call ancestor } - SelRange := ASelRange; { Hold select range } - Flags := AFlags; { Hold flags } - States := NewStr(AStates); { Hold string } -END; - -{--TMultiCheckBoxes---------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TMultiCheckBoxes.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - S.Read(SelRange, SizeOf(SelRange)); { Read select range } - S.Read(Flags, SizeOf(Flags)); { Read flags } - States := S.ReadStr; { Read strings } -END; - -{--TMultiCheckBoxes---------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TMultiCheckBoxes.Done; -BEGIN - If (States <> Nil) Then DisposeStr(States); { Dispose strings } - Inherited Done; { Call ancestor } -END; - -{--TMultiCheckBoxes---------------------------------------------------------} -{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TMultiCheckBoxes.DataSize: Sw_Word; -BEGIN - DataSize := SizeOf(LongInt); { Size to exchange } -END; - -{--TMultiCheckBoxes---------------------------------------------------------} -{ MultiMark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TMultiCheckBoxes.MultiMark (Item: Sw_Integer): Byte; -BEGIN - MultiMark := (Value SHR (Word(Item) * - WordRec(Flags).Hi)) AND WordRec(Flags).Lo; { Return mark state } -END; - -{--TMultiCheckBoxes---------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMultiCheckBoxes.Draw; -CONST Button = ' [ ] '; -BEGIN - Inherited Draw; - DrawMultiBox(Button, States^); { Draw the items } -END; - -{--TMultiCheckBoxes---------------------------------------------------------} -{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMultiCheckBoxes.Press (Item: Sw_Integer); -VAR CurState: ShortInt; -BEGIN - CurState := (Value SHR (Word(Item) * - WordRec(Flags).Hi)) AND WordRec(Flags).Lo; { Hold current state } - Dec(CurState); { One down } - If (CurState >= SelRange) OR (CurState < 0) Then - CurState := SelRange - 1; { Roll if needed } - Value := (Value AND NOT (LongInt(WordRec(Flags).Lo) - SHL (Word(Item) * WordRec(Flags).Hi))) OR - (LongInt(CurState) SHL (Word(Item) * - WordRec(Flags).Hi)); { Calculate value } - Inherited Press(Item); { Call ancestor } -END; - -{--TMultiCheckBoxes---------------------------------------------------------} -{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMultiCheckBoxes.GetData (Var Rec); -BEGIN - Longint(Rec) := Value; { Return value } -END; - -{--TMultiCheckBoxes---------------------------------------------------------} -{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMultiCheckBoxes.SetData (Var Rec); -BEGIN - Value := Longint(Rec); { Set value } - DrawView; { Redraw masked areas } -END; - -{--TMultiCheckBoxes---------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMultiCheckBoxes.Store (Var S: TStream); -BEGIN - TCluster.Store(S); { TCluster store called } - S.Write(SelRange, SizeOf(SelRange)); { Write select range } - S.Write(Flags, SizeOf(Flags)); { Write select flags } - S.WriteStr(States); { Write strings } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TListBox OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -TYPE - TListBoxRec = PACKED RECORD - List: PCollection; { List collection ptr } - Selection: sw_integer; { Selected item } - END; - -{--TListBox-----------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TListBox.Init (Var Bounds: TRect; ANumCols: Sw_Word; - AScrollBar: PScrollBar); -BEGIN - Inherited Init(Bounds, ANumCols, Nil, AScrollBar); { Call ancestor } - SetRange(0); { Set range to zero } -END; - -{--TListBox-----------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TListBox.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - List := PCollection(S.Get); { Fetch collection } -END; - -{--TListBox-----------------------------------------------------------------} -{ DataSize -> Platforms DOS/DPMI/WIN/NT/Os2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TListBox.DataSize: Sw_Word; -BEGIN - DataSize := SizeOf(TListBoxRec); { Xchg data size } -END; - -{--TListBox-----------------------------------------------------------------} -{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TListBox.GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; -VAR P: PString; -BEGIN - GetText := ''; { Preset return } - If (List <> Nil) Then Begin { A list exists } - P := PString(List^.At(Item)); { Get string ptr } - If (P <> Nil) Then GetText := P^; { Return string } - End; -END; - -{--TListBox-----------------------------------------------------------------} -{ NewList -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListBox.NewList (AList: PCollection); -BEGIN - If (List <> Nil) Then Dispose(List, Done); { Dispose old list } - List := AList; { Hold new list } - If (AList <> Nil) Then SetRange(AList^.Count) { Set new item range } - Else SetRange(0); { Set zero range } - If (Range > 0) Then FocusItem(0); { Focus first item } - DrawView; { Redraw all view } -END; - -{--TListBox-----------------------------------------------------------------} -{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListBox.GetData (Var Rec); -BEGIN - TListBoxRec(Rec).List := List; { Return current list } - TListBoxRec(Rec).Selection := Focused; { Return focused item } -END; - -{--TListBox-----------------------------------------------------------------} -{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListBox.SetData (Var Rec); -BEGIN - NewList(TListBoxRec(Rec).List); { Hold new list } - FocusItem(TListBoxRec(Rec).Selection); { Focus selected item } - DrawView; { Redraw all view } -END; - -{--TListBox-----------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListBox.Store (Var S: TStream); -BEGIN - TListViewer.Store(S); { TListViewer store } - S.Put(List); { Store list to stream } -END; - -{****************************************************************************} -{ TListBox.DeleteFocusedItem } -{****************************************************************************} -procedure TListBox.DeleteFocusedItem; -begin - DeleteItem(Focused); -end; - -{****************************************************************************} -{ TListBox.DeleteItem } -{****************************************************************************} -procedure TListBox.DeleteItem (Item : Sw_Integer); -begin - if (List <> nil) and (List^.Count > 0) and - ((Item < List^.Count) and (Item > -1)) then begin - if IsSelected(Item) and (Item > 0) then - FocusItem(Item - 1); - List^.AtDelete(Item); - SetRange(List^.Count); - end; -end; - -{****************************************************************************} -{ TListBox.FreeAll } -{****************************************************************************} -procedure TListBox.FreeAll; -begin - if (List <> nil) then - begin - List^.FreeAll; - SetRange(List^.Count); - end; -end; - -{****************************************************************************} -{ TListBox.FreeFocusedItem } -{****************************************************************************} -procedure TListBox.FreeFocusedItem; -begin - FreeItem(Focused); -end; - -{****************************************************************************} -{ TListBox.FreeItem } -{****************************************************************************} -procedure TListBox.FreeItem (Item : Sw_Integer); -begin - if (Item > -1) and (Item < Range) then - begin - List^.AtFree(Item); - if (Range > 1) and (Focused >= List^.Count) then - Dec(Focused); - SetRange(List^.Count); - end; -end; - -{****************************************************************************} -{ TListBox.SetFocusedItem } -{****************************************************************************} -procedure TListBox.SetFocusedItem (Item : Pointer); -begin - FocusItem(List^.IndexOf(Item)); -end; - -{****************************************************************************} -{ TListBox.GetFocusedItem } -{****************************************************************************} -function TListBox.GetFocusedItem : Pointer; -begin - if (List = nil) or (List^.Count = 0) then - GetFocusedItem := nil - else GetFocusedItem := List^.At(Focused); -end; - -{****************************************************************************} -{ TListBox.Insert } -{****************************************************************************} -procedure TListBox.Insert (Item : Pointer); -begin - if (List <> nil) then - begin - List^.Insert(Item); - SetRange(List^.Count); - end; -end; - - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TStaticText OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TStaticText--------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TStaticText.Init (Var Bounds: TRect; Const AText: String); -BEGIN - Inherited Init(Bounds); { Call ancestor } - Text := NewStr(AText); { Create string ptr } -END; - -{--TStaticText--------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TStaticText.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - Text := S.ReadStr; { Read text string } -END; - -{--TStaticText--------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TStaticText.Done; -BEGIN - If (Text <> Nil) Then DisposeStr(Text); { Dispose string } - Inherited Done; { Call ancestor } -END; - -{--TStaticText--------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TStaticText.GetPalette: PPalette; -CONST P: String[Length(CStaticText)] = CStaticText; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Return palette } -END; - -{--TStaticText--------------------------------------------------------------} -{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStaticText.Draw; -VAR Just: Byte; I, J, P, Y, L: Sw_Integer; S: String; - B : TDrawBuffer; - Color : Byte; -BEGIN - GetText(S); { Fetch text to write } - Color := GetColor(1); - P := 1; { X start position } - Y := 0; { Y start position } - L := Length(S); { Length of text } - While (Y < Size.Y) Do Begin - MoveChar(B, ' ', Color, Size.X); - if P <= L then - begin - Just := 0; { Default left justify } - If (S[P] = #2) Then Begin { Right justify char } - Just := 2; { Set right justify } - Inc(P); { Next character } - End; - If (S[P] = #3) Then Begin { Centre justify char } - Just := 1; { Set centre justify } - Inc(P); { Next character } - End; - I := P; { Start position } - repeat - J := P; - while (P <= L) and (S[P] = ' ') do - Inc(P); - while (P <= L) and (S[P] <> ' ') and (S[P] <> #13) do - Inc(P); - until (P > L) or (P >= I + Size.X) or (S[P] = #13); - If P > I + Size.X Then { Text to long } - If J > I Then - P := J - Else - P := I + Size.X; - Case Just Of - 0: J := 0; { Left justify } - 1: J := (Size.X - (P-I)) DIV 2; { Centre justify } - 2: J := Size.X - (P-I); { Right justify } - End; - MoveBuf(B[J], S[I], Color, P - I); - While (P <= L) AND (P-I <= Size.X) AND ((S[P] = #13) OR (S[P] = #10)) - Do Inc(P); { Remove CR/LF } - End; - WriteLine(0, Y, Size.X, 1, B); - Inc(Y); { Next line } - End; -END; - -{--TStaticText--------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStaticText.Store (Var S: TStream); -BEGIN - TView.Store(S); { Call TView store } - S.WriteStr(Text); { Write text string } -END; - -{--TStaticText--------------------------------------------------------------} -{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStaticText.GetText (Var S: String); -BEGIN - If (Text <> Nil) Then S := Text^ { Copy text string } - Else S := ''; { Return empty string } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TParamText OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TParamText---------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TParamText.Init (Var Bounds: TRect; Const AText: String; - AParamCount: Sw_Integer); -BEGIN - Inherited Init(Bounds, AText); { Call ancestor } - ParamCount := AParamCount; { Hold param count } -END; - -{--TParamText---------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TParamText.Load (Var S: TStream); -VAR w: Word; -BEGIN - Inherited Load(S); { Call ancestor } - S.Read(w, SizeOf(w)); ParamCount:=w; { Read parameter count } -END; - -{--TParamText---------------------------------------------------------------} -{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TParamText.DataSize: Sw_Word; -BEGIN - DataSize := ParamCount * SizeOf(Pointer); { Return data size } -END; - -{--TParamText---------------------------------------------------------------} -{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TParamText.GetData (Var Rec); -BEGIN - Pointer(Rec) := @ParamList; { Return parm ptr } -END; - -{--TParamText---------------------------------------------------------------} -{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TParamText.SetData (Var Rec); -BEGIN - ParamList := @Rec; { Fetch parameter list } - DrawView; { Redraw all the view } -END; - -{--TParamText---------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TParamText.Store (Var S: TStream); -VAR w: Word; -BEGIN - TStaticText.Store(S); { Statictext store } - w:=ParamCount;S.Write(w, SizeOf(w)); { Store param count } -END; - -{--TParamText---------------------------------------------------------------} -{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TParamText.GetText (Var S: String); -BEGIN - If (Text = Nil) Then S := '' Else { Return empty string } - FormatStr(S, Text^, ParamList^); { Return text string } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TLabel OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TLabel-------------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TLabel.Init (Var Bounds: TRect; CONST AText: String; ALink: PView); -BEGIN - Inherited Init(Bounds, AText); { Call ancestor } - Link := ALink; { Hold link } - Options := Options OR (ofPreProcess+ofPostProcess);{ Set pre/post process } - EventMask := EventMask OR evBroadcast; { Sees broadcast events } -END; - -{--TLabel-------------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TLabel.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - GetPeerViewPtr(S, Link); { Load link view } -END; - -{--TLabel-------------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TLabel.GetPalette: PPalette; -CONST P: String[Length(CLabel)] = CLabel; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Return palette } -END; - -{--TLabel-------------------------------------------------------------------} -{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TLabel.Draw; -VAR SCOff: Byte; Color: Word; B: TDrawBuffer; -BEGIN - If Light Then Begin { Light colour select } - Color := GetColor($0402); { Choose light colour } - SCOff := 0; { Zero offset } - End Else Begin - Color := GetColor($0301); { Darker colour } - SCOff := 4; { Set offset } - End; - MoveChar(B[0], ' ', Byte(Color), Size.X); { Clear the buffer } - If (Text <> Nil) Then MoveCStr(B[1], Text^, Color);{ Transfer label text } - If ShowMarkers Then WordRec(B[0]).Lo := Byte( - SpecialChars[SCOff]); { Show marker if req } - WriteLine(0, 0, Size.X, 1, B); { Write the text } -END; - -{--TLabel-------------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TLabel.Store (Var S: TStream); -BEGIN - TStaticText.Store(S); { TStaticText.Store } - PutPeerViewPtr(S, Link); { Store link view } -END; - -{--TLabel-------------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TLabel.HandleEvent (Var Event: TEvent); -VAR C: Char; - - PROCEDURE FocusLink; - BEGIN - If (Link <> Nil) AND (Link^.Options AND - ofSelectable <> 0) Then Link^.Focus; { Focus link view } - ClearEvent(Event); { Clear the event } - END; - -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - Case Event.What Of - evNothing: Exit; { Speed up exit } - evMouseDown: FocusLink; { Focus link view } - evKeyDown: - Begin - if assigned(text) then - begin - C := HotKey(Text^); { Check for hotkey } - If (GetAltCode(C) = Event.KeyCode) OR { Alt plus char } - ((C <> #0) AND (Owner^.Phase = phPostProcess) { Post process phase } - AND (UpCase(Event.CharCode) = C)) Then { Upper case match } - FocusLink; { Focus link view } - end; - end; - evBroadcast: If ((Event.Command = cmReceivedFocus) - OR (Event.Command = cmReleasedFocus)) AND { Focus state change } - (Link <> Nil) Then Begin - Light := Link^.State AND sfFocused <> 0; { Change light state } - DrawView; { Now redraw change } - End; - End; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ THistoryViewer OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--THistoryViewer-----------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR THistoryViewer.Init (Var Bounds: TRect; AHScrollBar, -AVScrollBar: PScrollBar; AHistoryId: Word); -BEGIN - Inherited Init(Bounds, 1, AHScrollBar, - AVScrollBar); { Call ancestor } - HistoryId := AHistoryId; { Hold history id } - SetRange(HistoryCount(AHistoryId)); { Set history range } - If (Range > 1) Then FocusItem(1); { Set to item 1 } - If (HScrollBar <> Nil) Then - HScrollBar^.SetRange(1, HistoryWidth-Size.X + 3);{ Set scrollbar range } -END; - -{--THistoryViewer-----------------------------------------------------------} -{ HistoryWidth -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION THistoryViewer.HistoryWidth: Sw_Integer; -VAR Width, T, Count, I: Sw_Integer; -BEGIN - Width := 0; { Zero width variable } - Count := HistoryCount(HistoryId); { Hold count value } - For I := 0 To Count-1 Do Begin { For each item } - T := Length(HistoryStr(HistoryId, I)); { Get width of item } - If (T > Width) Then Width := T; { Set width to max } - End; - HistoryWidth := Width; { Return max item width } -END; - -{--THistoryViewer-----------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION THistoryViewer.GetPalette: PPalette; -CONST P: String[Length(CHistoryViewer)] = CHistoryViewer;{ Always normal string } -BEGIN - GetPalette := PPalette(@P); { Return palette } -END; - -{--THistoryViewer-----------------------------------------------------------} -{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION THistoryViewer.GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; -BEGIN - GetText := HistoryStr(HistoryId, Item); { Return history string } -END; - -{--THistoryViewer-----------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE THistoryViewer.HandleEvent (Var Event: TEvent); -BEGIN - If ((Event.What = evMouseDown) AND (Event.Double)) { Double click mouse } - OR ((Event.What = evKeyDown) AND - (Event.KeyCode = kbEnter)) Then Begin { Enter key press } - EndModal(cmOk); { End with cmOk } - ClearEvent(Event); { Event was handled } - End Else If ((Event.What = evKeyDown) AND - (Event.KeyCode = kbEsc)) OR { Esc key press } - ((Event.What = evCommand) AND - (Event.Command = cmCancel)) Then Begin { Cancel command } - EndModal(cmCancel); { End with cmCancel } - ClearEvent(Event); { Event was handled } - End Else Inherited HandleEvent(Event); { Call ancestor } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ THistoryWindow OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--THistoryWindow-----------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR THistoryWindow.Init (Var Bounds: TRect; HistoryId: Word); -BEGIN - Inherited Init(Bounds, '', wnNoNumber); { Call ancestor } - Flags := wfClose; { Close flag only } - InitViewer(HistoryId); { Create list view } -END; - -{--THistoryWindow-----------------------------------------------------------} -{ GetSelection -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION THistoryWindow.GetSelection: String; -BEGIN - If (Viewer = Nil) Then GetSelection := '' Else { Return empty string } - GetSelection := Viewer^.GetText(Viewer^.Focused, - 255); { Get focused string } -END; - -{--THistoryWindow-----------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION THistoryWindow.GetPalette: PPalette; -CONST P: String[Length(CHistoryWindow)] = CHistoryWindow;{ Always normal string } -BEGIN - GetPalette := PPalette(@P); { Return the palette } -END; - -{--THistoryWindow-----------------------------------------------------------} -{ InitViewer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE THistoryWindow.InitViewer(HistoryId: Word); -VAR R: TRect; -BEGIN - GetExtent(R); { Get extents } - R.Grow(-1,-1); { Grow inside } - Viewer := New(PHistoryViewer, Init(R, - StandardScrollBar(sbHorizontal + sbHandleKeyboard), - StandardScrollBar(sbVertical + sbHandleKeyboard), - HistoryId)); { Create the viewer } - If (Viewer <> Nil) Then Insert(Viewer); { Insert viewer } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ THistory OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--THistory-----------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR THistory.Init (Var Bounds: TRect; ALink: PInputLine; -AHistoryId: Word); -BEGIN - Inherited Init(Bounds); { Call ancestor } - Options := Options OR ofPostProcess; { Set post process } - EventMask := EventMask OR evBroadcast; { See broadcast events } - Link := ALink; { Hold link view } - HistoryId := AHistoryId; { Hold history id } -END; - -{--THistory-----------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR THistory.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - GetPeerViewPtr(S, Link); { Load link view } - S.Read(HistoryId, SizeOf(HistoryId)); { Read history id } -END; - -{--THistory-----------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION THistory.GetPalette: PPalette; -CONST P: String[Length(CHistory)] = CHistory; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Return the palette } -END; - -{--THistory-----------------------------------------------------------------} -{ InitHistoryWindow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION THistory.InitHistoryWindow (Var Bounds: TRect): PHistoryWindow; -VAR P: PHistoryWindow; -BEGIN - P := New(PHistoryWindow, Init(Bounds, HistoryId)); { Create history window } - If (Link <> Nil) Then - P^.HelpCtx := Link^.HelpCtx; { Set help context } - InitHistoryWindow := P; { Return history window } -END; - -PROCEDURE THistory.Draw; -VAR B: TDrawBuffer; -BEGIN - MoveCStr(B,#222'~v~'#221, GetColor($0102)); { Set buffer data } - WriteLine(0, 0, Size.X, Size.Y, B); { Write buffer } -END; - -{--THistory-----------------------------------------------------------------} -{ RecordHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE THistory.RecordHistory (CONST S: String); -BEGIN - HistoryAdd(HistoryId, S); { Add to history } -END; - -{--THistory-----------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE THistory.Store (Var S: TStream); -BEGIN - TView.Store(S); { TView.Store called } - PutPeerViewPtr(S, Link); { Store link view } - S.Write(HistoryId, SizeOf(HistoryId)); { Store history id } -END; - -{--THistory-----------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE THistory.HandleEvent (Var Event: TEvent); -VAR C: Word; Rslt: String; R, P: TRect; HistoryWindow: PHistoryWindow; -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - If (Link = Nil) Then Exit; { No link view exits } - If (Event.What = evMouseDown) OR { Mouse down event } - ((Event.What = evKeyDown) AND - (CtrlToArrow(Event.KeyCode) = kbDown) AND { Down arrow key } - (Link^.State AND sfFocused <> 0)) Then Begin { Link view selected } - If NOT Link^.Focus Then Begin - ClearEvent(Event); { Event was handled } - Exit; { Now exit } - End; - RecordHistory(Link^.Data^); { Record current data } - Link^.GetBounds(R); { Get view bounds } - Dec(R.A.X); { One char in from us } - Inc(R.B.X); { One char short of us } - Inc(R.B.Y, 7); { Seven lines down } - Dec(R.A.Y,1); { One line below us } - Owner^.GetExtent(P); { Get owner extents } - R.Intersect(P); { Intersect views } - Dec(R.B.Y,1); { Shorten length by one } - HistoryWindow := InitHistoryWindow(R); { Create history window } - If (HistoryWindow <> Nil) Then Begin { Window crested okay } - C := Owner^.ExecView(HistoryWindow); { Execute this window } - If (C = cmOk) Then Begin { Result was okay } - Rslt := HistoryWindow^.GetSelection; { Get history selection } - If Length(Rslt) > Link^.MaxLen Then - SetLength(Rslt, Link^.MaxLen); { Hold new length } - Link^.Data^ := Rslt; { Hold new selection } - Link^.SelectAll(True); { Select all string } - Link^.DrawView; { Redraw link view } - End; - Dispose(HistoryWindow, Done); { Dispose of window } - End; - ClearEvent(Event); { Event was handled } - End Else If (Event.What = evBroadcast) Then { Broadcast event } - If ((Event.Command = cmReleasedFocus) AND - (Event.InfoPtr = Link)) OR - (Event.Command = cmRecordHistory) Then { Record command } - RecordHistory(Link^.Data^); { Record the history } -END; - -{****************************************************************************} -{ TBrowseButton Object } -{****************************************************************************} -{****************************************************************************} -{ TBrowseButton.Init } -{****************************************************************************} -constructor TBrowseButton.Init(var Bounds: TRect; ATitle: TTitleStr; - ACommand: Word; AFlags: Byte; ALink: PBrowseInputLine); -begin - if not inherited Init(Bounds,ATitle,ACommand,AFlags) then - Fail; - Link := ALink; -end; - -{****************************************************************************} -{ TBrowseButton.Load } -{****************************************************************************} -constructor TBrowseButton.Load(var S: TStream); -begin - if not inherited Load(S) then - Fail; - GetPeerViewPtr(S,Link); -end; - -{****************************************************************************} -{ TBrowseButton.Press } -{****************************************************************************} -procedure TBrowseButton.Press; -var - E: TEvent; -begin - Message(Owner, evBroadcast, cmRecordHistory, nil); - if Flags and bfBroadcast <> 0 then - Message(Owner, evBroadcast, Command, Link) else - begin - E.What := evCommand; - E.Command := Command; - E.InfoPtr := Link; - PutEvent(E); - end; -end; - -{****************************************************************************} -{ TBrowseButton.Store } -{****************************************************************************} -procedure TBrowseButton.Store(var S: TStream); -begin - inherited Store(S); - PutPeerViewPtr(S,Link); -end; - - -{****************************************************************************} -{ TBrowseInputLine Object } -{****************************************************************************} -{****************************************************************************} -{ TBrowseInputLine.Init } -{****************************************************************************} -constructor TBrowseInputLine.Init(var Bounds: TRect; AMaxLen: Sw_Integer; AHistory: Sw_Word); -begin - if not inherited Init(Bounds,AMaxLen) then - Fail; - History := AHistory; -end; - -{****************************************************************************} -{ TBrowseInputLine.Load } -{****************************************************************************} -constructor TBrowseInputLine.Load(var S: TStream); -begin - if not inherited Load(S) then - Fail; - S.Read(History,SizeOf(History)); - if (S.Status <> stOk) then - Fail; -end; - -{****************************************************************************} -{ TBrowseInputLine.DataSize } -{****************************************************************************} -function TBrowseInputLine.DataSize: Sw_Word; -begin - DataSize := SizeOf(TBrowseInputLineRec); -end; - -{****************************************************************************} -{ TBrowseInputLine.GetData } -{****************************************************************************} -procedure TBrowseInputLine.GetData(var Rec); -var - LocalRec: TBrowseInputLineRec absolute Rec; -begin - if (Validator = nil) or - (Validator^.Transfer(Data^,@LocalRec.Text, vtGetData) = 0) then - begin - FillChar(LocalRec.Text, DataSize, #0); - Move(Data^, LocalRec.Text, Length(Data^) + 1); - end; - LocalRec.History := History; -end; - -{****************************************************************************} -{ TBrowseInputLine.SetData } -{****************************************************************************} -procedure TBrowseInputLine.SetData(var Rec); -var - LocalRec: TBrowseInputLineRec absolute Rec; -begin - if (Validator = nil) or - (Validator^.Transfer(Data^, @LocalRec.Text, vtSetData) = 0) then - Move(LocalRec.Text, Data^[0], MaxLen + 1); - History := LocalRec.History; - SelectAll(True); -end; - -{****************************************************************************} -{ TBrowseInputLine.Store } -{****************************************************************************} -procedure TBrowseInputLine.Store(var S: TStream); -begin - inherited Store(S); - S.Write(History,SizeOf(History)); -end; - - -{****************************************************************************} -{ TCommandCheckBoxes Object } -{****************************************************************************} -{****************************************************************************} -{ TCommandCheckBoxes.Init } -{****************************************************************************} -constructor TCommandCheckBoxes.Init (var Bounds : TRect; - ACommandStrings : PCommandSItem); -var StartSItem, S : PSItem; - CItems : PCommandSItem; - i : Sw_Integer; -begin - if ACommandStrings = nil then - Fail; - { set up string list } - StartSItem := NewSItem(ACommandStrings^.Value,nil); - S := StartSItem; - CItems := ACommandStrings^.Next; - while (CItems <> nil) do begin - S^.Next := NewSItem(CItems^.Value,nil); - S := S^.Next; - CItems := CItems^.Next; - end; - { construct check boxes } - if not TCheckBoxes.Init(Bounds,StartSItem) then begin - while (StartSItem <> nil) do begin - S := StartSItem; - StartSItem := StartSItem^.Next; - if (S^.Value <> nil) then - DisposeStr(S^.Value); - Dispose(S); - end; - Fail; - end; - { set up CommandList and dispose of memory used by ACommandList } - i := 0; - while (ACommandStrings <> nil) do begin - CommandList[i] := ACommandStrings^.Command; - CItems := ACommandStrings; - ACommandStrings := ACommandStrings^.Next; - Dispose(CItems); - Inc(i); - end; -end; - -{****************************************************************************} -{ TCommandCheckBoxes.Load } -{****************************************************************************} -constructor TCommandCheckBoxes.Load (var S : TStream); -begin - if not TCheckBoxes.Load(S) then - Fail; - S.Read(CommandList,SizeOf(CommandList)); - if (S.Status <> stOk) then begin - TCheckBoxes.Done; - Fail; - end; -end; - -{****************************************************************************} -{ TCommandCheckBoxes.Press } -{****************************************************************************} -procedure TCommandCheckBoxes.Press (Item : Sw_Integer); -var Temp : Sw_Integer; -begin - Temp := Value; - TCheckBoxes.Press(Item); - if (Value <> Temp) then { value changed - notify peers } - Message(Owner,evCommand,CommandList[Item],@Value); -end; - -{****************************************************************************} -{ TCommandCheckBoxes.Store } -{****************************************************************************} -procedure TCommandCheckBoxes.Store (var S : TStream); -begin - TCheckBoxes.Store(S); - S.Write(CommandList,SizeOf(CommandList)); -end; - -{****************************************************************************} -{ TCommandIcon Object } -{****************************************************************************} -{****************************************************************************} -{ TCommandIcon.Init } -{****************************************************************************} -constructor TCommandIcon.Init (var Bounds : TRect; AText : String; - ACommand : Word); -begin - if not TStaticText.Init(Bounds,AText) then - Fail; - Options := Options or ofPostProcess; - Command := ACommand; -end; - -{****************************************************************************} -{ TCommandIcon.HandleEvent } -{****************************************************************************} -procedure TCommandIcon.HandleEvent (var Event : TEvent); -begin - if ((Event.What = evMouseDown) and MouseInView(MouseWhere)) then begin - ClearEvent(Event); - Message(Owner,evCommand,Command,nil); - end; - TStaticText.HandleEvent(Event); -end; - -{****************************************************************************} -{ TCommandInputLine Object } -{****************************************************************************} -{****************************************************************************} -{ TCommandInputLine.Changed } -{****************************************************************************} -{procedure TCommandInputLine.Changed; -begin - Message(Owner,evBroadcast,cmInputLineChanged,@Self); -end; } - -{****************************************************************************} -{ TCommandInputLine.HandleEvent } -{****************************************************************************} -{procedure TCommandInputLine.HandleEvent (var Event : TEvent); -var E : TEvent; -begin - E := Event; - TBSDInputLine.HandleEvent(Event); - if ((E.What and evKeyBoard = evKeyBoard) and (Event.KeyCode = kbEnter)) - then Changed; -end; } - -{****************************************************************************} -{ TCommandRadioButtons Object } -{****************************************************************************} - -{****************************************************************************} -{ TCommandRadioButtons.Init } -{****************************************************************************} -constructor TCommandRadioButtons.Init (var Bounds : TRect; - ACommandStrings : PCommandSItem); -var - StartSItem, S : PSItem; - CItems : PCommandSItem; - i : Sw_Integer; -begin - if ACommandStrings = nil - then Fail; - { set up string list } - StartSItem := NewSItem(ACommandStrings^.Value,nil); - S := StartSItem; - CItems := ACommandStrings^.Next; - while (CItems <> nil) do begin - S^.Next := NewSItem(CItems^.Value,nil); - S := S^.Next; - CItems := CItems^.Next; - end; - { construct check boxes } - if not TRadioButtons.Init(Bounds,StartSItem) then begin - while (StartSItem <> nil) do begin - S := StartSItem; - StartSItem := StartSItem^.Next; - if (S^.Value <> nil) then - DisposeStr(S^.Value); - Dispose(S); - end; - Fail; - end; - { set up command list } - i := 0; - while (ACommandStrings <> nil) do begin - CommandList[i] := ACommandStrings^.Command; - CItems := ACommandStrings; - ACommandStrings := ACommandStrings^.Next; - Dispose(CItems); - Inc(i); - end; -end; - -{****************************************************************************} -{ TCommandRadioButtons.Load } -{****************************************************************************} -constructor TCommandRadioButtons.Load (var S : TStream); -begin - if not TRadioButtons.Load(S) then - Fail; - S.Read(CommandList,SizeOf(CommandList)); - if (S.Status <> stOk) then begin - TRadioButtons.Done; - Fail; - end; -end; - -{****************************************************************************} -{ TCommandRadioButtons.MoveTo } -{****************************************************************************} -procedure TCommandRadioButtons.MovedTo (Item : Sw_Integer); -var Temp : Sw_Integer; -begin - Temp := Value; - TRadioButtons.MovedTo(Item); - if (Value <> Temp) then { value changed - notify peers } - Message(Owner,evCommand,CommandList[Item],@Value); -end; - -{****************************************************************************} -{ TCommandRadioButtons.Press } -{****************************************************************************} -procedure TCommandRadioButtons.Press (Item : Sw_Integer); -var Temp : Sw_Integer; -begin - Temp := Value; - TRadioButtons.Press(Item); - if (Value <> Temp) then { value changed - notify peers } - Message(Owner,evCommand,CommandList[Item],@Value); -end; - -{****************************************************************************} -{ TCommandRadioButtons.Store } -{****************************************************************************} -procedure TCommandRadioButtons.Store (var S : TStream); -begin - TRadioButtons.Store(S); - S.Write(CommandList,SizeOf(CommandList)); -end; - -{****************************************************************************} -{ TEditListBox Object } -{****************************************************************************} -{****************************************************************************} -{ TEditListBox.Init } -{****************************************************************************} -constructor TEditListBox.Init (Bounds : TRect; ANumCols: Word; - AVScrollBar : PScrollBar); - -begin - if not inherited Init(Bounds,ANumCols,AVScrollBar) - then Fail; - CurrentField := 1; -end; - -{****************************************************************************} -{ TEditListBox.Load } -{****************************************************************************} -constructor TEditListBox.Load (var S : TStream); -begin - if not inherited Load(S) - then Fail; - CurrentField := 1; -end; - -{****************************************************************************} -{ TEditListBox.EditField } -{****************************************************************************} -procedure TEditListBox.EditField (var Event : TEvent); -var R : TRect; - InputLine : PModalInputLine; -begin - R.Assign(StartColumn,(Origin.Y + Focused - TopItem), - (StartColumn + FieldWidth + 2),(Origin.Y + Focused - TopItem + 1)); - Owner^.MakeGlobal(R.A,R.A); - Owner^.MakeGlobal(R.B,R.B); - InputLine := New(PModalInputLine,Init(R,FieldWidth)); - InputLine^.SetValidator(FieldValidator); - if InputLine <> nil - then begin - { Use TInputLine^.SetData so that data validation occurs } - { because TInputLine.Data is allocated memory large enough } - { to hold a string of MaxLen. It is also faster. } - GetField(InputLine); - if (Application^.ExecView(InputLine) = cmOk) - then SetField(InputLine); - Dispose(InputLine,done); - end; -end; - -{****************************************************************************} -{ TEditListBox.FieldValidator } -{****************************************************************************} -function TEditListBox.FieldValidator : PValidator; - { In a multiple field listbox FieldWidth should return the width } - { appropriate for Field. The default is an inputline for editing } - { a string of length large enough to fill the listbox field. } -begin - FieldValidator := nil; -end; - -{****************************************************************************} -{ TEditListBox.FieldWidth } -{****************************************************************************} -function TEditListBox.FieldWidth : Integer; - { In a multiple field listbox FieldWidth should return the width } - { appropriate for CurrentField. } -begin - FieldWidth := Size.X - 2; -end; - -{****************************************************************************} -{ TEditListBox.GetField } -{****************************************************************************} -procedure TEditListBox.GetField (InputLine : PInputLine); - { Places a string appropriate to Field and Focused into InputLine that } - { will be edited. Override this method for complex data types. } -begin - InputLine^.SetData(PString(List^.At(Focused))^); -end; - -{****************************************************************************} -{ TEditListBox.GetPalette } -{****************************************************************************} -function TEditListBox.GetPalette : PPalette; -begin - GetPalette := inherited GetPalette; -end; - -{****************************************************************************} -{ TEditListBox.HandleEvent } -{****************************************************************************} -procedure TEditListBox.HandleEvent (var Event : TEvent); -begin - if (Event.What = evKeyboard) and (Event.KeyCode = kbAltE) - then begin { edit field } - EditField(Event); - DrawView; - ClearEvent(Event); - end; - inherited HandleEvent(Event); -end; - -{****************************************************************************} -{ TEditListBox.SetField } -{****************************************************************************} -procedure TEditListBox.SetField (InputLine : PInputLine); - { Override this method for field types other than PStrings. } -var Item : PString; -begin - Item := NewStr(InputLine^.Data^); - if Item <> nil - then begin - List^.AtFree(Focused); - List^.Insert(Item); - SetFocusedItem(Item); - end; -end; - -{****************************************************************************} -{ TEditListBox.StartColumn } -{****************************************************************************} -function TEditListBox.StartColumn : Integer; -begin - StartColumn := Origin.X; -end; - -{****************************************************************************} -{ TListDlg Object } -{****************************************************************************} -{****************************************************************************} -{ TListDlg.Init } -{****************************************************************************} -constructor TListDlg.Init (ATitle : TTitleStr; Items: - String; AButtons: Word; AListBox: PListBox; AEditCommand, ANewCommand : - Word); -var - Bounds: TRect; - b: Byte; - ButtonCount: Byte; - i, j, Gap, Line: Integer; - Scrollbar: PScrollbar; - HasFrame: Boolean; - HasButtons: Boolean; - HasScrollBar: Boolean; - HasItems: Boolean; -begin - if AListBox = nil then - Fail - else - ListBox := AListBox; - HasFrame := ((AButtons and ldNoFrame) = 0); - HasButtons := ((AButtons and ldAllButtons) <> 0); - HasScrollBar := ((AButtons and ldNoScrollBar) = 0); - HasItems := (Items <> ''); - ButtonCount := 2; - for b := 0 to 3 do - if (AButtons and ($0001 shl 1)) <> 0 then - Inc(ButtonCount); - { Make sure dialog is large enough for buttons } - ListBox^.GetExtent(Bounds); - Bounds.Move(ListBox^.Origin.X,ListBox^.Origin.Y); - if HasFrame then - begin - Inc(Bounds.B.X,2); - Inc(Bounds.B.Y,2); - end; - if HasButtons then - begin - Inc(Bounds.B.X,14); - if Bounds.B.Y < (ButtonCount * 2) + 4 then - Bounds.B.Y := (ButtonCount * 2) + 5; - end; - if HasItems then - Inc(Bounds.B.Y,1); - if not TDialog.Init(Bounds,ATitle) then - Fail; - NewCommand := ANewCommand; - EditCommand := AEditCommand; - Options := Options or ofNewEditDelete; - if (not HasFrame) and (Frame <> nil) then - begin - Delete(Frame); - Dispose(Frame,Done); - Frame := nil; - Options := Options and not ofFramed; - end; - HelpCtx := hcListDlg; - { position and insert ListBox } - ListBox := AListBox; - Insert(ListBox); - if HasItems then - if HasFrame then - ListBox^.MoveTo(2,2) - else ListBox^.MoveTo(0,2) - else - if HasFrame then - ListBox^.MoveTo(1,1) - else ListBox^.MoveTo(0,0); - if HasButtons then - if ListBox^.Size.Y < (ButtonCount * 2) then - ListBox^.GrowTo(ListBox^.Size.X,ButtonCount * 2); - { do Items } - if HasItems then - begin - Bounds.Assign(1,1,CStrLen(Items)+2,2); - Insert(New(PLabel,Init(Bounds,Items,ListBox))); - end; - { do scrollbar } - if HasScrollBar then - begin - Bounds.Assign(ListBox^.Size.X+ListBox^.Origin.X,ListBox^.Origin.Y, - ListBox^.Size.X + ListBox^.Origin.X + 1, - ListBox^.Size.Y + ListBox^.Origin.Y { origin }); - ScrollBar := New(PScrollBar,Init(Bounds)); - Bounds.Assign(Origin.X,Origin.Y,Origin.X + Size.X + 1, Origin.Y + Size.Y); - ChangeBounds(Bounds); - Insert(Scrollbar); - end; - if HasButtons then - begin { do buttons } - j := $0001; - Gap := 0; - for i := 0 to 3 do - if ((j shl i) and AButtons) <> 0 then - Inc(Gap); - Gap := ((Size.Y - 2) div (Gap + 2)); - if Gap < 2 then - Gap := 2; - { Insert Buttons } - Line := 2; - if (AButtons and ldNew) = ldNew then - begin - Insert(NewButton(Size.X - 12,Line,10,2,'~N~ew',cmNew,hcInsert,bfNormal)); - Inc(Line,Gap); - end; - if (AButtons and ldEdit) = ldEdit then - begin - Insert(NewButton(Size.X - 12,Line,10,2,'~E~dit',cmEdit,hcEdit, - bfNormal)); - Inc(Line,Gap); - end; - if (AButtons and ldDelete) = ldDelete then - begin - Insert(NewButton(Size.X - 12,Line,10,2,'~D~elete',cmDelete,hcDelete, - bfNormal)); - Inc(Line,Gap); - end; - Insert(NewButton(Size.X - 12,Line,10,2,'O~k~',cmOK,hcOk,bfDefault or - bfNormal)); - Inc(Line,Gap); - Insert(NewButton(Size.X - 12,Line,10,2,'Cancel',cmCancel,hcCancel, - bfNormal)); - if (AButtons and ldHelp) = ldHelp then - begin - Inc(Line,Gap); - Insert(NewButton(Size.X - 12,Line,10,2,'~H~elp',cmHelp,hcNoContext, - bfNormal)); - end; - end; - if HasFrame and ((AButtons and ldAllIcons) <> 0) then - begin - Line := 2; - if (AButtons and ldNewIcon) = ldNewIcon then - begin - Bounds.Assign(Line,Size.Y-1,Line+5,Size.Y); - Insert(New(PCommandIcon,Init(Bounds,' Ins ',cmNew))); - Inc(Line,5); - if (AButtons and (ldEditIcon or ldDeleteIcon)) <> 0 then - begin - Bounds.Assign(Line,Size.Y-1,Line+1,Size.Y); - Insert(New(PStaticText,Init(Bounds,'/'))); - Inc(Line,1); - end; - end; - if (AButtons and ldEditIcon) = ldEditIcon then - begin - Bounds.Assign(Line,Size.Y-1,Line+6,Size.Y); - Insert(New(PCommandIcon,Init(Bounds,' Edit ',cmEdit))); - Inc(Line,6); - if (AButtons and ldDeleteIcon) <> 0 then - begin - Bounds.Assign(Line,Size.Y-1,Line+1,Size.Y); - Insert(New(PStaticText,Init(Bounds,'/'))); - Inc(Line,1); - end; - end; - if (AButtons and ldNewIcon) = ldNewIcon then - begin - Bounds.Assign(Line,Size.Y-1,Line+5,Size.Y); - Insert(New(PCommandIcon,Init(Bounds,' Del ',cmDelete))); - end; - end; - { Set focus to list boLine when dialog opens } - SelectNext(False); -end; - -{****************************************************************************} -{ TListDlg.Load } -{****************************************************************************} -constructor TListDlg.Load (var S : TStream); -begin - if not TDialog.Load(S) then - Fail; - S.Read(NewCommand,SizeOf(NewCommand)); - S.Read(EditCommand,SizeOf(EditCommand)); - GetSubViewPtr(S,ListBox); -end; - -{****************************************************************************} -{ TListDlg.HandleEvent } -{****************************************************************************} -procedure TListDlg.HandleEvent (var Event : TEvent); -const - TargetCommands: TCommandSet = [cmNew, cmEdit, cmDelete]; -begin - if ((Event.What and evCommand) <> 0) and - (Event.Command in TargetCommands) then - case Event.Command of - cmDelete: - if Options and ofDelete = ofDelete then - begin - ListBox^.FreeFocusedItem; - ListBox^.DrawView; - ClearEvent(Event); - end; - cmNew: - if Options and ofNew = ofNew then - begin - Message(Application,evCommand,NewCommand,nil); - ListBox^.SetRange(ListBox^.List^.Count); - ListBox^.DrawView; - ClearEvent(Event); - end; - cmEdit: - if Options and ofEdit = ofEdit then - begin - Message(Application,evCommand,EditCommand,ListBox^.GetFocusedItem); - ListBox^.DrawView; - ClearEvent(Event); - end; - end; - if (Event.What and evBroadcast > 0) and - (Event.Command = cmListItemSelected) then - begin { use PutEvent instead of Message so that a window list box works } - Event.What := evCommand; - Event.Command := cmOk; - Event.InfoPtr := nil; - PutEvent(Event); - end; - TDialog.HandleEvent(Event); -end; - -{****************************************************************************} -{ TListDlg.Store } -{****************************************************************************} -procedure TListDlg.Store (var S : TStream); -begin - TDialog.Store(S); - S.Write(NewCommand,SizeOf(NewCommand)); - S.Write(EditCommand,SizeOf(EditCommand)); - PutSubViewPtr(S,ListBox); -end; - -{****************************************************************************} -{ TModalInputLine Object } -{****************************************************************************} -{****************************************************************************} -{ TModalInputLine.Execute } -{****************************************************************************} -function TModalInputLine.Execute : Word; -var Event : TEvent; -begin - repeat - EndState := 0; - repeat - GetEvent(Event); - HandleEvent(Event); - if Event.What <> evNothing - then Owner^.EventError(Event); { may change this to ClearEvent } - until (EndState <> 0); - until Valid(EndState); - Execute := EndState; -end; - -{****************************************************************************} -{ TModalInputLine.HandleEvent } -{****************************************************************************} -procedure TModalInputLine.HandleEvent (var Event : TEvent); -begin - case Event.What of - evKeyboard : case Event.KeyCode of - kbUp, kbDown : EndModal(cmCancel); - kbEnter : EndModal(cmOk); - else inherited HandleEvent(Event); - end; - evMouse : if MouseInView(Event.Where) - then inherited HandleEvent(Event) - else EndModal(cmCancel); - else inherited HandleEvent(Event); - end; -end; - -{****************************************************************************} -{ TModalInputLine.SetState } -{****************************************************************************} -procedure TModalInputLine.SetState (AState : Word; Enable : Boolean); -var Pos : Integer; -begin - if (AState = sfSelected) - then begin - Pos := CurPos; - inherited SetState(AState,Enable); - CurPos := Pos; - SelStart := CurPos; - SelEnd := CurPos; - BlockCursor; - DrawView; - end - else inherited SetState(AState,Enable); -end; - - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ ITEM STRING ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ NewSItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } -{---------------------------------------------------------------------------} -FUNCTION NewSItem (Const Str: String; ANext: PSItem): PSItem; -VAR Item: PSItem; -BEGIN - New(Item); { Allocate item } - Item^.Value := NewStr(Str); { Hold item string } - Item^.Next := ANext; { Chain the ptr } - NewSItem := Item; { Return item } -END; - -{****************************************************************************} -{ NewCommandSItem } -{****************************************************************************} -function NewCommandSItem (Str : String; ACommand : Word; - ANext : PCommandSItem) : PCommandSItem; -var Temp : PCommandSItem; -begin - New(Temp); - if (Temp <> nil) then - begin - Temp^.Value := Str; - Temp^.Command := ACommand; - Temp^.Next := ANext; - end; - NewCommandSItem := Temp; -end; - - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ DIALOG OBJECT REGISTRATION ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ RegisterDialogs -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE RegisterDialogs; -BEGIN - RegisterType(RDialog); { Register dialog } - RegisterType(RInputLine); { Register inputline } - RegisterType(RButton); { Register button } - RegisterType(RCluster); { Register cluster } - RegisterType(RRadioButtons); { Register radiobutton } - RegisterType(RCheckBoxes); { Register check boxes } - RegisterType(RMultiCheckBoxes); { Register multi boxes } - RegisterType(RListBox); { Register list box } - RegisterType(RStaticText); { Register static text } - RegisterType(RLabel); { Register label } - RegisterType(RHistory); { Register history } - RegisterType(RParamText); { Register parm text } - RegisterType(RCommandCheckBoxes); - RegisterType(RCommandIcon); - RegisterType(RCommandRadioButtons); - RegisterType(REditListBox); - RegisterType(RModalInputLine); - RegisterType(RListDlg); -END; - -END. +{$I dialogs.inc} diff --git a/packages/fv/src/drivers.inc b/packages/fv/src/drivers.inc new file mode 100644 index 0000000000..5a8fa1deab --- /dev/null +++ b/packages/fv/src/drivers.inc @@ -0,0 +1,1798 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent clone of DRIVERS.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999, 2000 } +{ by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@projectent.com.au - backup e-mail addr } +{ } +{ Original FormatStr kindly donated by Marco Schmidt } +{ } +{ Mouse callback hook under FPC with kind assistance of } +{ Pierre Muller, Gertjan Schouten & Florian Klaempfl. } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} + +{$ifdef FV_UNICODE} +UNIT UDrivers; +{$else FV_UNICODE} +UNIT Drivers; +{$endif FV_UNICODE} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$IFNDEF OS_UNIX} +{$S-} { Disable Stack Checking } +{$ENDIF} +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +{$ifdef CPU68K} + {$DEFINE ENDIAN_BIG} +{$endif CPU68K} + +{$ifdef FPC} + {$INLINE ON} +{$endif} + +USES + {$IFDEF OS_WINDOWS} { WIN/NT CODE } + Windows, { Standard unit } + {$ENDIF} + + {$IFDEF OS_WIN16} { WIN16 CODE } + WinProcs, WinTypes, { Standard units } + Crt, { used for Delay() } + {$ENDIF} + + {$ifdef OS_DOS} + Dos, + {$endif OS_DOS} + + {$IFDEF OS_OS2} { OS2 CODE } + {$IFDEF PPC_Virtual} { VIRTUAL PASCAL UNITS } + OS2Def, OS2Base, OS2PMAPI, { Standard units } + {$ENDIF} + {$IFDEF PPC_Speed} { SPEED PASCAL UNITS } + BseDos, Os2Def, { Standard units } + {$ENDIF} + {$IFDEF PPC_FPC} { FPC UNITS } + DosCalls, Os2Def, { Standard units } + {$ENDIF} + {$ENDIF} + + {$IFDEF OS_UNIX} + unixtype,baseunix,unix, + {$ENDIF} + + {$IFDEF OS_NETWARE_LIBC} + libc, + {$ENDIF} + {$IFDEF OS_NETWARE_CLIB} + nwserv, + {$ENDIF} + + {$IFDEF OS_AMIGA} + dos, amigados, + {$ENDIF} + + video, + SysMsg, +{$ifdef FV_UNICODE} + UFVCommon, + GraphemeBreakProperty, +{$else FV_UNICODE} + FVCommon, +{$endif FV_UNICODE} + Objects; { GFV standard units } + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ EVENT TYPE MASKS } +{---------------------------------------------------------------------------} +CONST + evMouseDown = $0001; { Mouse down event } + evMouseUp = $0002; { Mouse up event } + evMouseMove = $0004; { Mouse move event } + evMouseAuto = $0008; { Mouse auto event } + evKeyDown = $0010; { Key down event } + evCommand = $0100; { Command event } + evBroadcast = $0200; { Broadcast event } + +{---------------------------------------------------------------------------} +{ EVENT CODE MASKS } +{---------------------------------------------------------------------------} +CONST + evNothing = $0000; { Empty event } + evMouse = $000F; { Mouse event } + evKeyboard = $0010; { Keyboard event } + evMessage = $FF00; { Message event } + +{---------------------------------------------------------------------------} +{ EXTENDED KEY CODES } +{---------------------------------------------------------------------------} +CONST + kbNoKey = $0000; kbAltEsc = $0100; kbEsc = $011B; + kbAltSpace = $0200; kbCtrlIns = $0400; kbShiftIns = $0500; + kbCtrlDel = $0600; kbShiftDel = $0700; kbAltBack = $0800; + kbAltShiftBack= $0900; kbBack = $0E08; kbCtrlBack = $0E7F; + kbShiftTab = $0F00; kbTab = $0F09; kbAltQ = $1000; + kbCtrlQ = $1011; kbAltW = $1100; kbCtrlW = $1117; + kbAltE = $1200; kbCtrlE = $1205; kbAltR = $1300; + kbCtrlR = $1312; kbAltT = $1400; kbCtrlT = $1414; + kbAltY = $1500; kbCtrlY = $1519; kbAltU = $1600; + kbCtrlU = $1615; kbAltI = $1700; kbCtrlI = $1709; + kbAltO = $1800; kbCtrlO = $180F; kbAltP = $1900; + kbCtrlP = $1910; kbAltLftBrack = $1A00; kbAltRgtBrack = $1B00; + kbCtrlEnter = $1C0A; kbEnter = $1C0D; kbAltA = $1E00; + kbCtrlA = $1E01; kbAltS = $1F00; kbCtrlS = $1F13; + kbAltD = $2000; kbCtrlD = $2004; kbAltF = $2100; + kbCtrlF = $2106; kbAltG = $2200; kbCtrlG = $2207; + kbAltH = $2300; kbCtrlH = $2308; kbAltJ = $2400; + kbCtrlJ = $240A; kbAltK = $2500; kbCtrlK = $250B; + kbAltL = $2600; kbCtrlL = $260C; kbAltSemiCol = $2700; + kbAltQuote = $2800; kbAltOpQuote = $2900; kbAltBkSlash = $2B00; + kbAltZ = $2C00; kbCtrlZ = $2C1A; kbAltX = $2D00; + kbCtrlX = $2D18; kbAltC = $2E00; kbCtrlC = $2E03; + kbAltV = $2F00; kbCtrlV = $2F16; kbAltB = $3000; + kbCtrlB = $3002; kbAltN = $3100; kbCtrlN = $310E; + kbAltM = $3200; kbCtrlM = $320D; kbAltComma = $3300; + kbAltPeriod = $3400; kbAltSlash = $3500; kbAltGreyAst = $3700; + kbSpaceBar = $3920; kbF1 = $3B00; kbF2 = $3C00; + kbF3 = $3D00; kbF4 = $3E00; kbF5 = $3F00; + kbF6 = $4000; kbF7 = $4100; kbF8 = $4200; + kbF9 = $4300; kbF10 = $4400; kbHome = $4700; + kbUp = $4800; kbPgUp = $4900; kbGrayMinus = $4A2D; + kbLeft = $4B00; kbCenter = $4C00; kbRight = $4D00; + kbAltGrayPlus = $4E00; kbGrayPlus = $4E2B; kbEnd = $4F00; + kbDown = $5000; kbPgDn = $5100; kbIns = $5200; + kbDel = $5300; kbShiftF1 = $5400; kbShiftF2 = $5500; + kbShiftF3 = $5600; kbShiftF4 = $5700; kbShiftF5 = $5800; + kbShiftF6 = $5900; kbShiftF7 = $5A00; kbShiftF8 = $5B00; + kbShiftF9 = $5C00; kbShiftF10 = $5D00; kbCtrlF1 = $5E00; + kbCtrlF2 = $5F00; kbCtrlF3 = $6000; kbCtrlF4 = $6100; + kbCtrlF5 = $6200; kbCtrlF6 = $6300; kbCtrlF7 = $6400; + kbCtrlF8 = $6500; kbCtrlF9 = $6600; kbCtrlF10 = $6700; + kbAltF1 = $6800; kbAltF2 = $6900; kbAltF3 = $6A00; + kbAltF4 = $6B00; kbAltF5 = $6C00; kbAltF6 = $6D00; + kbAltF7 = $6E00; kbAltF8 = $6F00; kbAltF9 = $7000; + kbAltF10 = $7100; kbCtrlPrtSc = $7200; kbCtrlLeft = $7300; + kbCtrlRight = $7400; kbCtrlEnd = $7500; kbCtrlPgDn = $7600; + kbCtrlHome = $7700; kbAlt1 = $7800; kbAlt2 = $7900; + kbAlt3 = $7A00; kbAlt4 = $7B00; kbAlt5 = $7C00; + kbAlt6 = $7D00; kbAlt7 = $7E00; kbAlt8 = $7F00; + kbAlt9 = $8000; kbAlt0 = $8100; kbAltMinus = $8200; + kbAltEqual = $8300; kbCtrlPgUp = $8400; kbF11 = $8500; + kbF12 = $8600; kbShiftF11 = $8700; kbShiftF12 = $8800; + kbCtrlF11 = $8900; kbCtrlF12 = $8A00; kbAltF11 = $8B00; + kbAltF12 = $8C00; kbCtrlUp = $8D00; kbCtrlMinus = $8E00; + kbCtrlCenter = $8F00; kbCtrlGreyPlus= $9000; kbCtrlDown = $9100; + kbCtrlTab = $9400; kbAltHome = $9700; kbAltUp = $9800; + kbAltPgUp = $9900; kbAltLeft = $9B00; kbAltRight = $9D00; + kbAltEnd = $9F00; kbAltDown = $A000; kbAltPgDn = $A100; + kbAltIns = $A200; kbAltDel = $A300; kbAltTab = $A500; + +{ ------------------------------- REMARK ------------------------------ } +{ New keys not initially defined by Borland in their unit interface. } +{ ------------------------------ END REMARK --- Leon de Boer, 15May96 - } + kbFullStop = $342E; kbComma = $332C; kbBackSlash = $352F; + kbApostrophe = $2827; kbSemiColon = $273B; kbEqual = $0D3D; + kbGreaterThan = $343E; kbLessThan = $333C; kbQuestion = $353F; + kbQuote = $2822; kbColon = $273A; kbPlus = $0D2B; + kbPipe = $2B7C; kbSlash = $2B5C; kbExclaim = $0221; + kbAt = $0340; kbNumber = $0423; kbPercent = $0625; + kbCaret = $075E; kbAmpersand = $0826; kbAsterix = $092A; + kbLeftBracket = $0A28; kbRightBracket= $0B29; kbApprox = $2960; + kbTilde = $297E; kbDollar = $0524; kbMinus = $0C2D; + kbUnderline = $0C5F; kbLeftSqBr = $1A5B; kbRightSqBr = $1B5D; + kbLeftCurlyBr = $1A7B; kbRightCurlyBr= $1B7D; + +{---------------------------------------------------------------------------} +{ KEYBOARD STATE AND SHIFT MASKS } +{---------------------------------------------------------------------------} +CONST + kbRightShift = $0001; { Right shift key } + kbLeftShift = $0002; { Left shift key } + kbCtrlShift = $0004; { Control key down } + kbAltShift = $0008; { Alt key down } + kbScrollState = $0010; { Scroll lock on } + kbNumState = $0020; { Number lock on } + kbCapsState = $0040; { Caps lock on } + kbInsState = $0080; { Insert mode on } + + kbBothShifts = kbRightShift + kbLeftShift; { Right & Left shifts } + +{---------------------------------------------------------------------------} +{ MOUSE BUTTON STATE MASKS } +{---------------------------------------------------------------------------} +CONST + mbLeftButton = $01; { Left mouse button } + mbRightButton = $02; { Right mouse button } + mbMiddleButton = $04; { Middle mouse button } + mbScrollWheelDown = $08; { Scroll wheel down} + mbScrollWheelUp = $10; { Scroll wheel up } + + +{---------------------------------------------------------------------------} +{ SCREEN CRT MODE CONSTANTS } +{---------------------------------------------------------------------------} +CONST + smBW80 = $0002; { Black and white } + smCO80 = $0003; { Colour mode } + smMono = $0007; { Monochrome mode } + smFont8x8 = $0100; { 8x8 font mode } + +{***************************************************************************} +{ PUBLIC TYPE DEFINITIONS } +{***************************************************************************} + +{ ******************************* REMARK ****************************** } +{ The TEvent definition is completely compatable with all existing } +{ code but adds two new fields ID and Data into the message record } +{ which helps with WIN/NT and OS2 message processing. } +{ ****************************** END REMARK *** Leon de Boer, 11Sep97 * } + +{---------------------------------------------------------------------------} +{ EVENT RECORD DEFINITION } +{---------------------------------------------------------------------------} +TYPE + TEvent = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + What: Sw_Word; { Event type } + Case Sw_Word Of + evNothing: (); { ** NO EVENT ** } + evMouse: ( + Buttons: Byte; { Mouse buttons } + Double: Boolean; { Double click state } + Where: TPoint); { Mouse position } + evKeyDown: ( + { ** KEY EVENT ** } + Case Sw_Integer Of + 0: (KeyCode: Word); { Full key code } + 1: ( +{$ifdef ENDIAN_BIG} + ScanCode: Byte; + CharCode: Char; +{$else not ENDIAN_BIG} + CharCode: Char; { Char code } + ScanCode: Byte; { Scan code } +{$endif not ENDIAN_BIG} + UnicodeChar: WideChar; { Unicode char code. + Code points from the Supplementary Planes (U+010000 to + U+10FFFF) are encoded as 2 consecutive key events, + forming an UTF-16 surrogate pair. } + KeyShift: byte)); { Shift states } + evMessage: ( { ** MESSAGE EVENT ** } + Command: Sw_Word; { Message command } + Id : Sw_Word; { Message id } + Data : Real; { Message data } + Case Sw_Word Of + 0: (InfoPtr: Pointer); { Message pointer } + 1: (InfoLong: Longint); { Message longint } + 2: (InfoWord: Word); { Message Sw_Word } + 3: (InfoInt: SmallInt); { Message Sw_Integer } + 4: (InfoByte: Byte); { Message byte } + 5: (InfoChar: Char)); { Message character } + END; + PEvent = ^TEvent; + + TVideoMode = Video.TVideoMode; { Screen mode } + +{---------------------------------------------------------------------------} +{ ERROR HANDLER FUNCTION DEFINITION } +{---------------------------------------------------------------------------} +TYPE + TSysErrorFunc = FUNCTION (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{ Get Dos counter ticks } +Function GetDosTicks:longint; { returns ticks at 18.2 Hz, just like DOS } + + +procedure GiveUpTimeSlice; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ BUFFER MOVE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + + +{$ifdef FV_UNICODE} +{-EgcWidth----------------------------------------------------------- +Returns the number of display columns needed to display the extended +grapheme cluster EGC. +---------------------------------------------------------------------} +FUNCTION EgcWidth(Const EGC: Sw_String): Sw_Integer; +{$endif FV_UNICODE} + +{-StrWidth----------------------------------------------------------- +Returns the number of display columns needed to display the string S. +---------------------------------------------------------------------} +FUNCTION StrWidth(Const S: Sw_String): Sw_Integer; + +{-CStrLen------------------------------------------------------------ +Returns the length of string S, where S is a control string using tilde +characters ('~') to designate shortcut characters. The tildes are +excluded from the length of the string, as they will not appear on +the screen. For example, given the string '~B~roccoli' as its +parameter, CStrLen returns 8. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION CStrLen (Const S: Sw_String): Sw_Integer; + +{-MoveStr------------------------------------------------------------ +Moves a string into a buffer for use with a view's WriteBuf or WriteLine. +Dest must be a TDrawBuffer (or an equivalent array of Sw_Words). The +characters in Str are moved into the low bytes of corresponding Sw_Words +in Dest. The high bytes of the Sw_Words are set to Attr, or remain +unchanged if Attr is zero. +25May96 LdB +---------------------------------------------------------------------} +PROCEDURE MoveStr (Var Dest; Const Str: Sw_String; Attr: Byte); + +{-MoveCStr----------------------------------------------------------- +The characters in Str are moved into the low bytes of corresponding +Sw_Words in Dest. The high bytes of the Sw_Words are set to Lo(Attr) or +Hi(Attr). Tilde characters (~) in the string toggle between the two +attribute bytes passed in the Attr Sw_Word. +25May96 LdB +---------------------------------------------------------------------} +PROCEDURE MoveCStr (Var Dest; Const Str: Sw_String; Attrs: Word); + +{-MoveBuf------------------------------------------------------------ +Count bytes are moved from Source into the low bytes of corresponding +Sw_Words in Dest. The high bytes of the Sw_Words in Dest are set to Attr, +or remain unchanged if Attr is zero. +25May96 LdB +---------------------------------------------------------------------} +PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; Count: Sw_Word); deprecated; +PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; DestWidth, SourceCount: SizeInt); + +{-MoveChar------------------------------------------------------------ +Moves characters into a buffer for use with a view's WriteBuf or +WriteLine. Dest must be a TDrawBuffer (or an equivalent array of Sw_Words). +The low bytes of the first Count Sw_Words of Dest are set to C, or +remain unchanged if Ord(C) is zero. The high bytes of the Sw_Words are +set to Attr, or remain unchanged if Attr is zero. +25May96 LdB +---------------------------------------------------------------------} +{$ifdef FV_UNICODE} +PROCEDURE MoveChar (Var Dest; C: UnicodeString; Attr: Byte; Count: Sw_Word); +{$else FV_UNICODE} +PROCEDURE MoveChar (Var Dest; C: Char; Attr: Byte; Count: Sw_Word); +{$endif FV_UNICODE} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ KEYBOARD SUPPORT ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-GetAltCode--------------------------------------------------------- +Returns the scancode corresponding to Alt+Ch key that is given. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION GetAltCode (Ch: Char): Word; + +{-GetCtrlCode-------------------------------------------------------- +Returns the scancode corresponding to Alt+Ch key that is given. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION GetCtrlCode (Ch: Char): Word; + +{-GetAltChar--------------------------------------------------------- +Returns the ascii character for the Alt+Key scancode that was given. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION GetAltChar (KeyCode: Word): Char; + +{-GetCtrlChar-------------------------------------------------------- +Returns the ascii character for the Ctrl+Key scancode that was given. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION GetCtrlChar (KeyCode: Word): Char; + +{-CtrlToArrow-------------------------------------------------------- +Converts a WordStar-compatible control key code to the corresponding +cursor key code. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION CtrlToArrow (KeyCode: Word): Word; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ KEYBOARD CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-GetShiftState------------------------------------------------------ +Returns a byte containing the current Shift key state. The return +value contains a combination of the kbXXXX constants for shift states. +08Jul96 LdB +---------------------------------------------------------------------} +FUNCTION GetShiftState: Byte; + +{-GetKeyEvent-------------------------------------------------------- +Checks whether a keyboard event is available. If a key has been pressed, +Event.What is set to evKeyDown and Event.KeyCode is set to the scan +code of the key. Otherwise, Event.What is set to evNothing. +19May98 LdB +---------------------------------------------------------------------} +PROCEDURE GetKeyEvent (Var Event: TEvent); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MOUSE CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-ShowMouse---------------------------------------------------------- +Decrements the hide counter and if zero the mouse is shown on screen. +30Jun98 LdB +---------------------------------------------------------------------} +PROCEDURE ShowMouse; + +{-HideMouse---------------------------------------------------------- +If mouse hide counter is zero it removes the cursor from the screen. +The hide counter is then incremented by one count. +30Jun98 LdB +---------------------------------------------------------------------} +PROCEDURE HideMouse; + +{-GetMouseEvent------------------------------------------------------ +Checks whether a mouse event is available. If a mouse event has occurred, +Event.What is set to evMouseDown, evMouseUp, evMouseMove, or evMouseAuto +and the button and double click variables are set appropriately. +06Jan97 LdB +---------------------------------------------------------------------} +PROCEDURE GetMouseEvent (Var Event: TEvent); + +{-GetSystemEvent------------------------------------------------------ +Checks whether a system event is available. If a system event has occurred, +Event.What is set to evCommand appropriately +10Oct2000 PM +---------------------------------------------------------------------} +procedure GetSystemEvent (Var Event: TEvent); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ EVENT HANDLER CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-InitEvents--------------------------------------------------------- +Initializes the event manager, enabling the mouse handler routine and +under DOS/DPMI shows the mouse on screen. It is called automatically +by TApplication.Init. +02May98 LdB +---------------------------------------------------------------------} +PROCEDURE InitEvents; + +{-DoneEvents--------------------------------------------------------- +Terminates event manager and disables the mouse and under DOS hides +the mouse. It is called automatically by TApplication.Done. +02May98 LdB +---------------------------------------------------------------------} +PROCEDURE DoneEvents; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ VIDEO CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-Initkeyboard------------------------------------------------------- +Initializes the keyboard. Before it is called read(ln)/write(ln) +are functional, after it is called FV's keyboard routines are +functional. +---------------------------------------------------------------------} + +procedure initkeyboard; + +{-Donekeyboard------------------------------------------------------- +Restores keyboard to original state. FV's keyboard routines may not +be used after a call to this. Read(ln)/write(ln) can be used again. +---------------------------------------------------------------------} + +procedure donekeyboard; + +{-DetectVideo--------------------------------------------------------- +Detects the current video mode without initializing or otherwise +changing the current screen. +---------------------------------------------------------------------} +procedure DetectVideo; + +{-InitVideo--------------------------------------------------------- +Initializes the video manager, Saves the current screen mode in +StartupMode, and switches to the mode indicated by ScreenMode. +19May98 LdB +---------------------------------------------------------------------} +function InitVideo:boolean; + +{-DoneVideo--------------------------------------------------------- +Terminates the video manager by restoring the initial screen mode +(given by StartupMode), clearing the screen, and restoring the cursor. +Called automatically by TApplication.Done. +03Jan97 LdB +---------------------------------------------------------------------} +PROCEDURE DoneVideo; + +{-ClearScreen-------------------------------------------------------- +Does nothing provided for compatability purposes only. +04Jan97 LdB +---------------------------------------------------------------------} +PROCEDURE ClearScreen; + +{-SetVideoMode------------------------------------------------------- +Does nothing provided for compatability purposes only. +04Jan97 LdB +---------------------------------------------------------------------} +PROCEDURE SetVideoMode (Mode: Sw_Word); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ ERROR CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-InitSysError------------------------------------------------------- +Error handling is not yet implemented so this simply sets +SysErrActive=True (ie it lies) and exits. +20May98 LdB +---------------------------------------------------------------------} +PROCEDURE InitSysError; + +{-DoneSysError------------------------------------------------------- +Error handling is not yet implemented so this simply sets +SysErrActive=False and exits. +20May98 LdB +---------------------------------------------------------------------} +PROCEDURE DoneSysError; + +{-SystemError--------------------------------------------------------- +Error handling is not yet implemented so this simply drops through. +20May98 LdB +---------------------------------------------------------------------} +FUNCTION SystemError (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STRING FORMAT ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-PrintStr----------------------------------------------------------- +Does nothing provided for compatability purposes only. +30Jun98 LdB +---------------------------------------------------------------------} +PROCEDURE PrintStr (CONST S: String); + +{-FormatStr---------------------------------------------------------- +A string formatting routine that given a string that includes format +specifiers and a list of parameters in Params, FormatStr produces a +formatted output string in Result. +18Feb99 LdB +---------------------------------------------------------------------} +PROCEDURE FormatStr (Var Result: Sw_String; CONST Format: Sw_String; Var Params); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ >> NEW QUEUED EVENT HANDLER ROUTINES << } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-PutEventInQueue----------------------------------------------------- +If there is room in the queue the event is placed in the next vacant +position in the queue manager. +17Mar98 LdB +---------------------------------------------------------------------} +FUNCTION PutEventInQueue (Var Event: TEvent): Boolean; + +{-NextQueuedEvent---------------------------------------------------- +If there are queued events the next event is loaded into event else +evNothing is returned. +17Mar98 LdB +---------------------------------------------------------------------} +PROCEDURE NextQueuedEvent(Var Event: TEvent); + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + +PROCEDURE HideMouseCursor; +PROCEDURE ShowMouseCursor; + + +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +CONST + CheckSnow : Boolean = False; { Compatability only } + MouseEvents : Boolean = False; { Mouse event state } + MouseReverse : Boolean = False; { Mouse reversed } + HiResScreen : Boolean = False; { Compatability only } + CtrlBreakHit : Boolean = False; { Compatability only } + SaveCtrlBreak: Boolean = False; { Compatability only } + SysErrActive : Boolean = False; { Compatability only } + FailSysErrors: Boolean = False; { Compatability only } + ButtonCount : Byte = 0; { Mouse button count } + DoubleDelay : Sw_Word = 8; { Double click delay } + RepeatDelay : Sw_Word = 8; { Auto mouse delay } + SysColorAttr : Sw_Word = $4E4F; { System colour attr } + SysMonoAttr : Sw_Word = $7070; { System mono attr } + StartupMode : Sw_Word = $FFFF; { Compatability only } + CursorLines : Sw_Word = $FFFF; { Compatability only } + ScreenBuffer : Pointer = Nil; { Compatability only } + SaveInt09 : Pointer = Nil; { Compatability only } + SysErrorFunc : TSysErrorFunc = {$ifdef FPC}@{$endif}SystemError; { System error ptr } + + +{***************************************************************************} +{ UNINITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +VAR + MouseIntFlag: Byte; { Mouse in int flag } + MouseButtons: Byte; { Mouse button state } + ScreenWidth : Byte; { Screen text width } + ScreenHeight: Byte; { Screen text height } + ScreenMode : TVideoMode; { Screen mode } + MouseWhere : TPoint; { Mouse position } + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} +{ API Units } + USES + FVConsts, + Keyboard,Mouse; + +{***************************************************************************} +{ PRIVATE INTERNAL CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ DOS/DPMI MOUSE INTERRUPT EVENT QUEUE SIZE } +{---------------------------------------------------------------------------} +CONST EventQSize = 16; { Default int bufsize } + +{---------------------------------------------------------------------------} +{ DOS/DPMI/WIN/NT/OS2 NEW EVENT QUEUE MAX SIZE } +{---------------------------------------------------------------------------} +CONST QueueMax = 64; { Max new queue size } + +{---------------------------------------------------------------------------} +{ MAX WIEW WIDTH to avoid TDrawBuffer overrun in views unit } +{---------------------------------------------------------------------------} +CONST MaxViewWidth = 255; { Max view width } + +{***************************************************************************} +{ PRIVATE INTERNAL TYPES } +{***************************************************************************} + +{***************************************************************************} +{ PRIVATE INTERNAL INITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ DOS/DPMI/WIN/NT/OS2 ALT KEY SCANCODES FROM KEYS (0-127) } +{---------------------------------------------------------------------------} +CONST AltCodes: Array [0..127] Of Byte = ( + $00, $00, $00, $00, $00, $00, $00, $00, { $00 - $07 } + $00, $00, $00, $00, $00, $00, $00, $00, { $08 - $0F } + $00, $00, $00, $00, $00, $00, $00, $00, { $10 - $17 } + $00, $00, $00, $00, $00, $00, $00, $00, { $18 - $1F } + $00, $00, $00, $00, $00, $00, $00, $00, { $20 - $27 } + $00, $00, $00, $00, $00, $82, $00, $00, { $28 - $2F } + $81, $78, $79, $7A, $7B, $7C, $7D, $7E, { $30 - $37 } + $7F, $80, $00, $00, $00, $83, $00, $00, { $38 - $3F } + $00, $1E, $30, $2E, $20, $12, $21, $22, { $40 - $47 } + $23, $17, $24, $25, $26, $32, $31, $18, { $48 - $4F } + $19, $10, $13, $1F, $14, $16, $2F, $11, { $50 - $57 } + $2D, $15, $2C, $00, $00, $00, $00, $00, { $58 - $5F } + $00, $00, $00, $00, $00, $00, $00, $00, { $60 - $67 } + $00, $00, $00, $00, $00, $00, $00, $00, { $68 - $6F } + $00, $00, $00, $00, $00, $00, $00, $00, { $70 - $77 } + $00, $00, $00, $00, $00, $00, $00, $00); { $78 - $7F } + +{***************************************************************************} +{ PRIVATE INTERNAL INITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ NEW CONTROL VARIABLES } +{---------------------------------------------------------------------------} +CONST + HideCount : Sw_Integer = 0; { Cursor hide count } + QueueCount: Sw_Word = 0; { Queued message count } + QueueHead : Sw_Word = 0; { Queue head pointer } + QueueTail : Sw_Word = 0; { Queue tail pointer } + +{***************************************************************************} +{ PRIVATE INTERNAL UNINITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ UNINITIALIZED DOS/DPMI/API VARIABLES } +{---------------------------------------------------------------------------} +VAR + LastDouble : Boolean; { Last double buttons } + LastButtons: Byte; { Last button state } + DownButtons: Byte; { Last down buttons } + EventCount : Sw_Word; { Events in queue } + AutoDelay : Sw_Word; { Delay time count } + DownTicks : Sw_Word; { Down key tick count } + AutoTicks : Sw_Word; { Held key tick count } + LastWhereX : Sw_Word; { Last x position } + LastWhereY : Sw_Word; { Last y position } + DownWhereX : Sw_Word; { Last x position } + DownWhereY : Sw_Word; { Last y position } + LastWhere : TPoint; { Last mouse position } + DownWhere : TPoint; { Last down position } + EventQHead : Pointer; { Head of queue } + EventQTail : Pointer; { Tail of queue } + EventQueue : Array [0..EventQSize - 1] Of TEvent; { Event queue } + EventQLast : RECORD END; { Simple end marker } + StartupScreenMode : TVideoMode; + {$ifdef OS_AMIGA} + StartupTicks: Int64; // ticks at Startup for GetDOSTicks + {$endif} +{---------------------------------------------------------------------------} +{ GetDosTicks (18.2 Hz) } +{---------------------------------------------------------------------------} + +Function GetDosTicks:longint; { returns ticks at 18.2 Hz, just like DOS } +{$IFDEF OS_OS2} + const + QSV_MS_COUNT = 14; + var + L: longint; + begin + DosQuerySysInfo (QSV_MS_COUNT, QSV_MS_COUNT, L, 4); + GetDosTicks := L div 55; + end; +{$ENDIF} +{$IFDEF OS_UNIX} + var + tv : TimeVal; + { tz : TimeZone;} + begin + FPGetTimeOfDay(@tv,nil{,tz}); + GetDosTicks:=((tv.tv_Sec mod 86400) div 60)*1092+((tv.tv_Sec mod 60)*1000000+tv.tv_USec) div 54945; + end; +{$ENDIF OS_UNIX} +{$IFDEF OS_WINDOWS} + begin + GetDosTicks:=GetTickCount div 55; + end; +{$ENDIF OS_WINDOWS} +{$IFDEF OS_WIN16} + begin + GetDosTicks:=GetTickCount div 55; + end; +{$ENDIF OS_WIN16} +{$IFDEF OS_DOS} + begin + GetDosTicks:=MemL[$40:$6c]; + end; +{$ENDIF OS_DOS} +{$IFDEF OS_NETWARE_LIBC} +var + tv : TTimeVal; + tz : TTimeZone; + begin + fpGetTimeOfDay(tv,tz); + GetDosTicks:=((tv.tv_sec mod 86400) div 60)*1092+((tv.tv_Sec mod 60)*1000000+tv.tv_USec) div 549 + end; +{$ENDIF} +{$IFDEF OS_NETWARE_CLIB} + begin + GetDosTicks := Nwserv.GetCurrentTicks; + end; +{$ENDIF} +{$IFDEF OS_AMIGA} + begin + GetDosTicks:= ((dos.GetMsCount div 55) - StartupTicks) and $7FFFFFFF; + end; +{$ENDIF OS_AMIGA} + + +procedure GiveUpTimeSlice; +{$IFDEF OS_DOS} +var r: registers; +begin + Intr ($28, R); (* This is supported everywhere. *) + r.ax:=$1680; + intr($2f,r); +end; +{$ENDIF} +{$IFDEF OS_UNIX} + var + req,rem : timespec; +begin + req.tv_sec:=0; + req.tv_nsec:=10000000;{ 10 ms } + fpnanosleep(@req,@rem); +end; +{$ENDIF} +{$IFDEF OS_OS2} +begin + DosSleep (5); +end; +{$ENDIF} +{$IFDEF OS_WINDOWS} +begin + { if the return value of this call is non zero then + it means that a ReadFileEx or WriteFileEx have completed + unused for now ! } + { wait for 10 ms } + if SleepEx(10,true)=WAIT_IO_COMPLETION then + begin + { here we should handle the completion of the routines + if we use them } + end; +end; +{$ENDIF} +{$IFDEF OS_WIN16} + begin + Delay (10); + end; +{$ENDIF} +{$IFDEF OS_NETWARE_LIBC} + begin + Delay (10); + end; +{$ENDIF} +{$IFDEF OS_NETWARE_CLIB} + begin + Delay (10); + end; +{$ENDIF} +{$IFDEF OS_AMIGA} + begin + { AmigaOS Delay() wait's argument in 1/50 seconds } + { DOSDelay(2); // the old solution... } + Keyboard.WaitForSystemEvent(150); + end; +{$ENDIF OS_AMIGA} + + +{---------------------------------------------------------------------------} +{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +VAR + SaveExit: CodePointer; { Saved exit pointer } + Queue : Array [0..QueueMax-1] Of TEvent; { New message queue } + +{***************************************************************************} +{ PRIVATE INTERNAL ROUTINES } +{***************************************************************************} + +PROCEDURE ShowMouseCursor;inline; +BEGIN + ShowMouse; +END; + +PROCEDURE HideMouseCursor;inline; +BEGIN + HideMouse; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ DOS/DPMI/WIN/NT/OS2 PRIVATE INTERNAL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ ExitDrivers -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE ExitDrivers; {$IFNDEF PPC_FPC}{$IFNDEF OS_UNIX} FAR; {$ENDIF}{$ENDIF} +BEGIN + DoneSysError; { Relase error trap } + DoneEvents; { Close event driver } +{ DoneKeyboard;} + DoneVideo; + ExitProc := SaveExit; { Restore old exit } +END; + +{---------------------------------------------------------------------------} +{ DetectVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} + +procedure DetectVideo; +VAR + CurrMode : TVideoMode; +begin + { Video.InitVideo; Incompatible with BP + and forces a screen clear which is often a bad thing PM } + GetVideoMode(CurrMode); + ScreenMode:=CurrMode; +end; + +{---------------------------------------------------------------------------} +{ DetectMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +FUNCTION DetectMouse: Byte;inline; +begin + DetectMouse:=Mouse.DetectMouse; +end; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ BUFFER MOVE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{$ifdef FV_UNICODE} +FUNCTION EgcWidth(Const EGC: Sw_String): Sw_Integer; +BEGIN + Result := Video.ExtendedGraphemeClusterDisplayWidth(EGC); +END; +{$endif FV_UNICODE} + +{$ifdef FV_UNICODE} +FUNCTION StrWidth(Const S: Sw_String): Sw_Integer; +BEGIN + Result := Video.StringDisplayWidth(S); +END; +{$else FV_UNICODE} +FUNCTION StrWidth(Const S: Sw_String): Sw_Integer; +BEGIN + StrWidth := Length(S); +END; +{$endif FV_UNICODE} + +{---------------------------------------------------------------------------} +{ CStrLen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +{$ifdef FV_UNICODE} +FUNCTION CStrLen (Const S: UnicodeString): Sw_Integer; +VAR EGC: Sw_String; +BEGIN + { todo: handle wide (CJK, emoji) characters as double width } + Result := 0; + for EGC in TUnicodeStringExtendedGraphemeClustersEnumerator.Create(S) do + if EGC <> '~' then + Inc(Result, Video.ExtendedGraphemeClusterDisplayWidth(EGC)); +END; +{$else FV_UNICODE} +FUNCTION CStrLen (Const S: String): Sw_Integer; +VAR I, J: Sw_Integer; +BEGIN + J := 0; { Set result to zero } + For I := 1 To Length(S) Do + If (S[I] <> '~') Then Inc(J); { Inc count if not ~ } + CStrLen := J; { Return length } +END; +{$endif FV_UNICODE} + +{---------------------------------------------------------------------------} +{ MoveStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } +{---------------------------------------------------------------------------} +{$ifdef FV_UNICODE} +PROCEDURE MoveStr (Var Dest; Const Str: UnicodeString; Attr: Byte); +VAR EGC: Sw_String; P: PEnhancedVideoCell; +BEGIN + { todo: handle wide (CJK, emoji) characters as double width } + P := PEnhancedVideoCell(@Dest); { Pointer to TEnhancedVideoCell } + for EGC in TUnicodeStringExtendedGraphemeClustersEnumerator.Create(Str) do + begin + If (Attr <> 0) Then P^.Attribute := Attr; { Copy attribute } + P^.ExtendedGraphemeCluster := EGC; { Copy string char } + Inc(P, Video.ExtendedGraphemeClusterDisplayWidth(EGC)); + end; +END; +{$else FV_UNICODE} +PROCEDURE MoveStr (Var Dest; Const Str: String; Attr: Byte); +VAR I: Word; P: PWord; +BEGIN + For I := 1 To Length(Str) Do Begin { For each character } + P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word } + If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute } + WordRec(P^).Lo := Byte(Str[I]); { Copy string char } + End; +END; +{$endif FV_UNICODE} + +{---------------------------------------------------------------------------} +{ MoveCStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } +{---------------------------------------------------------------------------} +{$ifdef FV_UNICODE} +PROCEDURE MoveCStr (Var Dest; Const Str: UnicodeString; Attrs: Word); +VAR EGC: Sw_String; B: Byte; P: PEnhancedVideoCell; +BEGIN + { todo: handle wide (CJK, emoji) characters as double width } + P := PEnhancedVideoCell(@Dest); { Pointer to TEnhancedVideoCell } + for EGC in TUnicodeStringExtendedGraphemeClustersEnumerator.Create(Str) do + begin + if EGC <> '~' then + begin + If (Lo(Attrs) <> 0) Then + P^.Attribute := Lo(Attrs); { Copy attribute } + P^.ExtendedGraphemeCluster:=EGC; { Copy string char } + Inc(P, Video.ExtendedGraphemeClusterDisplayWidth(EGC)); { Next position } + end + else + begin + B := Hi(Attrs); { Hold attribute } + WordRec(Attrs).Hi := Lo(Attrs); { Copy low to high } + WordRec(Attrs).Lo := B; { Complete exchange } + end; + end; +END; +{$else FV_UNICODE} +PROCEDURE MoveCStr (Var Dest; Const Str: String; Attrs: Word); +VAR B: Byte; I, J: Sw_Word; P: PWord; +BEGIN + J := 0; { Start position } + For I := 1 To Length(Str) Do Begin { For each character } + If (Str[I] <> '~') Then Begin { Not tilde character } + P := @TWordArray(Dest)[J]; { Pointer to Sw_Word } + If (Lo(Attrs) <> 0) Then + WordRec(P^).Hi := Lo(Attrs); { Copy attribute } + WordRec(P^).Lo := Byte(Str[I]); { Copy string char } + Inc(J); { Next position } + End Else Begin + B := Hi(Attrs); { Hold attribute } + WordRec(Attrs).Hi := Lo(Attrs); { Copy low to high } + WordRec(Attrs).Lo := B; { Complete exchange } + End; + End; +END; +{$endif FV_UNICODE} + +{---------------------------------------------------------------------------} +{ MoveBuf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } +{---------------------------------------------------------------------------} +{$ifdef FV_UNICODE} +PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; Count: Sw_Word); deprecated; +VAR I: Word; P: PEnhancedVideoCell; +BEGIN + { todo: split string into extended grapheme clusters properly, handle non-BMP characters, + handle wide (CJK) characters, etc. } + For I := 1 To Count Do Begin + P := @(PEnhancedVideoCell(@Dest)[I-1]); { Pointer to TEnhancedVideoCell } + If (Attr <> 0) Then P^.Attribute := Attr; { Copy attribute } + P^.ExtendedGraphemeCluster := WideChar(TWordArray(Source)[I-1]); { Copy source data } + End; +END; +PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; DestWidth, SourceCount: SizeInt); +VAR + S, EGC: UnicodeString; + P: PEnhancedVideoCell; +BEGIN + SetLength(S, SourceCount); + Move(Source, S[1], SourceCount * SizeOf(WideChar)); + P := PEnhancedVideoCell(@Dest); { Pointer to TEnhancedVideoCell } + for EGC in TUnicodeStringExtendedGraphemeClustersEnumerator.Create(S) do + begin + if DestWidth <= 0 then + exit; + Dec(DestWidth, Video.ExtendedGraphemeClusterDisplayWidth(EGC)); + if DestWidth < 0 then + begin + If (Attr <> 0) Then P^.Attribute := Attr; + P^.ExtendedGraphemeCluster := ' '; + exit; + end; + If (Attr <> 0) Then P^.Attribute := Attr; { Copy attribute } + P^.ExtendedGraphemeCluster := EGC; { Copy string char } + Inc(P, Video.ExtendedGraphemeClusterDisplayWidth(EGC)); + end; +END; +{$else FV_UNICODE} +PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; Count: Sw_Word); deprecated; +VAR I: Word; P: PWord; +BEGIN + For I := 1 To Count Do Begin + P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word } + If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute } + WordRec(P^).Lo := TByteArray(Source)[I-1]; { Copy source data } + End; +END; +PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; DestWidth, SourceCount: SizeInt); +BEGIN + MoveBuf(Dest, Source, Attr, DestWidth); +END; +{$endif FV_UNICODE} + +{---------------------------------------------------------------------------} +{ MoveChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } +{---------------------------------------------------------------------------} +{$ifdef FV_UNICODE} +PROCEDURE MoveChar (Var Dest; C: UnicodeString; Attr: Byte; Count: Sw_Word); +VAR I: Word; P: PEnhancedVideoCell; +BEGIN + For I := 1 To Count Do Begin + P := @(PEnhancedVideoCell(@Dest)[I-1]); { Pointer to TEnhancedVideoCell } + If (Attr <> 0) Then P^.Attribute := Attr; { Copy attribute } + If (C<>'') and (C<>#$0000) Then P^.ExtendedGraphemeCluster := C; { Copy character } + End; +END; +{$else FV_UNICODE} +PROCEDURE MoveChar (Var Dest; C: Char; Attr: Byte; Count: Sw_Word); +VAR I: Word; P: PWord; +BEGIN + For I := 1 To Count Do Begin + P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word } + If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute } + If (Ord(C) <> 0) Then WordRec(P^).Lo := Byte(C); { Copy character } + End; +END; +{$endif FV_UNICODE} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ KEYBOARD SUPPORT ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ GetAltCode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetAltCode (Ch: Char): Word; +BEGIN + GetAltCode := 0; { Preset zero return } + Ch := UpCase(Ch); { Convert upper case } + If (Ch < #128) Then + GetAltCode := AltCodes[Ord(Ch)] SHL 8 { Return code } + Else If (Ch = #240) Then GetAltCode := $0200 { Return code } + Else GetAltCode := 0; { Return zero } +END; + +{---------------------------------------------------------------------------} +{ GetCtrlCode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetCtrlCode (Ch: Char): Word; +BEGIN + GetCtrlCode := GetAltCode(Ch) OR (Ord(Ch) - $40); { Ctrl+key code } +END; + +{---------------------------------------------------------------------------} +{ GetAltChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetAltChar (KeyCode: Word): Char; +VAR I: Sw_Integer; +BEGIN + GetAltChar := #0; { Preset fail return } + If (Lo(KeyCode) = 0) Then Begin { Extended key } + If (Hi(KeyCode) <= $83) Then Begin { Highest value in list } + I := 0; { Start at first } + While (I < 128) AND (Hi(KeyCode) <> AltCodes[I]) + Do Inc(I); { Search for match } + If (I < 128) Then GetAltChar := Chr(I); { Return character } + End Else + If (Hi(KeyCode)=$02) Then GetAltChar := #240; { Return char } + End; +END; + +{---------------------------------------------------------------------------} +{ GetCtrlChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetCtrlChar (KeyCode: Word): Char; +VAR C: Char; +BEGIN + C := #0; { Preset #0 return } + If (Lo(KeyCode) > 0) AND (Lo(KeyCode) <= 26) Then { Between 1-26 } + C := Chr(Lo(KeyCode) + $40); { Return char A-Z } + GetCtrlChar := C; { Return result } +END; + +{---------------------------------------------------------------------------} +{ CtrlToArrow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION CtrlToArrow (KeyCode: Word): Word; +CONST NumCodes = 11; + CtrlCodes : Array [0..NumCodes-1] Of Char = + (#19, #4, #5, #24, #1, #6, #7, #22, #18, #3, #8); + ArrowCodes: Array [0..NumCodes-1] Of Sw_Word = + (kbLeft, kbRight, kbUp, kbDown, kbHome, kbEnd, kbDel, kbIns, + kbPgUp, kbPgDn, kbBack); +VAR I: Sw_Integer; +BEGIN + CtrlToArrow := KeyCode; { Preset key return } + For I := 0 To NumCodes - 1 Do + If WordRec(KeyCode).Lo = Byte(CtrlCodes[I]) { Matches a code } + Then Begin + CtrlToArrow := ArrowCodes[I]; { Return key stroke } + Exit; { Now exit } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ KEYBOARD CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ GetShiftState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul96 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetShiftState: Byte; +begin + GetShiftState:=Keyboard.GetKeyEventShiftState(Keyboard.PollShiftStateEvent); +end; + +{---------------------------------------------------------------------------} +{ GetKeyEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} +procedure GetKeyEvent (Var Event: TEvent); +var + key : TEnhancedKeyEvent; + keycode : Word; +begin + if Keyboard.PollEnhancedKeyEvent<>NilEnhancedKeyEvent then + begin + key:=Keyboard.GetEnhancedKeyEvent; + keycode:=key.VirtualScanCode; + // some kbds still honour old XT E0 prefix. (org IBM ps/2, win98?) bug #8978 + if (keycode and $FF = $E0) and + (byte(keycode shr 8) in + [$1C,$1D,$2A,$35..$38,$46..$49,$4b,$4d,$4f,$50..$53]) Then + keycode := keycode and $FF00; + + { fixup shift-keys } + if essShift in key.ShiftState then + begin + case keycode of + $5200 : keycode:=kbShiftIns; + $5300 : keycode:=kbShiftDel; + $8500 : keycode:=kbShiftF1; + $8600 : keycode:=kbShiftF2; + end; + end + { fixup ctrl-keys } + else if essCtrl in key.ShiftState then + begin + case keycode of + $5200, + $9200 : keycode:=kbCtrlIns; + $5300, + $9300 : keycode:=kbCtrlDel; + end; + end + { fixup alt-keys } + else if essAlt in key.ShiftState then + begin + case keycode of + $0e08, + $0e00 : keycode:=kbAltBack; + end; + end + { fixup normal keys } + else + begin + case keycode of + $e00d : keycode:=kbEnter; + end; + end; + Event.What:=evKeyDown; + Event.KeyCode:=keycode; +{$ifdef ENDIAN_LITTLE} + Event.CharCode:=chr(keycode and $ff); + Event.ScanCode:=keycode shr 8; +{$endif ENDIAN_LITTLE} + Event.UnicodeChar:=key.UnicodeChar; + Event.KeyShift:=ConvertEnhancedToLegacyShiftState(key.ShiftState); + end + else + Event.What:=evNothing; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MOUSE CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ HideMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun98 LdB } +{---------------------------------------------------------------------------} +procedure HideMouse; +begin +{ Is mouse hidden yet? + If (HideCount = 0) Then} + Mouse.HideMouse; +{ Inc(HideCount);} +end; + +{---------------------------------------------------------------------------} +{ ShowMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun98 LdB } +{---------------------------------------------------------------------------} +procedure ShowMouse; +begin +{ if HideCount>0 then + dec(HideCount); + if (HideCount=0) then} + Mouse.ShowMouse; +end; + +{---------------------------------------------------------------------------} +{ GetMouseEvent -> Platforms DOS/DPMI/WINDOWS/OS2 - Updated 30Jun98 LdB } +{---------------------------------------------------------------------------} +procedure GetMouseEvent (Var Event: TEvent); +var + e : Mouse.TMouseEvent; +begin + if Mouse.PollMouseEvent(e) then + begin + Mouse.GetMouseEvent(e); + MouseWhere.X:=e.x; + MouseWhere.Y:=e.y; + Event.Double:=false; + case e.Action of + MouseActionMove : + Event.What:=evMouseMove; + MouseActionDown : + begin + Event.What:=evMouseDown; + if (DownButtons=e.Buttons) and (LastWhere.X=MouseWhere.X) and (LastWhere.Y=MouseWhere.Y) and + (GetDosTicks-DownTicks<=DoubleDelay) then + Event.Double:=true; + DownButtons:=e.Buttons; + DownWhere.X:=MouseWhere.x; + DownWhere.Y:=MouseWhere.y; + DownTicks:=GetDosTicks; + AutoTicks:=GetDosTicks; + if AutoTicks=0 then + AutoTicks:=1; + AutoDelay:=RepeatDelay; + end; + MouseActionUp : + begin + AutoTicks:=0; + Event.What:=evMouseUp; + AutoTicks:=0; + end; + end; + Event.Buttons:=e.Buttons; + Event.Where.X:=MouseWhere.x; + Event.Where.Y:=MouseWhere.y; + LastButtons:=Event.Buttons; + LastWhere.x:=Event.Where.x; + LastWhere.y:=Event.Where.y; + end + else if (AutoTicks <> 0) and (GetDosTicks >= AutoTicks + AutoDelay) then + begin + Event.What:=evMouseAuto; + Event.Buttons:=LastButtons; + Event.Where.X:=LastWhere.x; + Event.Where.Y:=LastWhere.y; + AutoTicks:=GetDosTicks; + AutoDelay:=1; + end + else + FillChar(Event,sizeof(TEvent),0); + if MouseReverse and ((Event.Buttons and 3) in [1,2]) then + Event.Buttons := Event.Buttons xor 3; +end; + +{---------------------------------------------------------------------------} +{ GetSystemEvent } +{---------------------------------------------------------------------------} +procedure GetSystemEvent (Var Event: TEvent); +var + SysEvent : TsystemEvent; +begin + if PollSystemEvent(SysEvent) then + begin + SysMsg.GetSystemEvent(SysEvent); + case SysEvent.typ of + SysNothing : + Event.What:=evNothing; + SysSetFocus : + begin + Event.What:=evBroadcast; + Event.Command:=cmReceivedFocus; + end; + SysReleaseFocus : + begin + Event.What:=evBroadcast; + Event.Command:=cmReleasedFocus; + end; + SysClose : + begin + Event.What:=evCommand; + Event.Command:=cmQuitApp; + end; + SysResize : + begin + Event.What:=evCommand; + Event.Command:=cmResizeApp; + Event.Id:=SysEvent.x; + Event.InfoWord:=SysEvent.y; + end; + else + Event.What:=evNothing; + end; + end + else + Event.What:=evNothing; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ EVENT HANDLER CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ InitEvents -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 07Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE InitEvents; +BEGIN + If (ButtonCount <> 0) Then + begin { Mouse is available } + Mouse.InitMouse; { Hook the mouse } + { this is required by the use of HideCount variable } + Mouse.ShowMouse; { visible by default } + { HideCount:=0; } + LastButtons := 0; { Clear last buttons } + DownButtons := 0; { Clear down buttons } + MouseWhere.X:=Mouse.GetMouseX; + MouseWhere.Y:=Mouse.GetMouseY; { Get mouse position } + LastWhere.x:=MouseWhere.x; + LastWhereX:=MouseWhere.x; + LastWhere.y:=MouseWhere.y; + LastWhereY:=MouseWhere.y; + MouseEvents := True; { Set initialized flag } + end; + InitSystemMsg; +END; + +{---------------------------------------------------------------------------} +{ DoneEvents -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DoneEvents; +BEGIN + DoneSystemMsg; + Mouse.DoneMouse; + MouseEvents:=false; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ VIDEO CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +const + VideoInitialized : boolean = false; + +{---------------------------------------------------------------------------} +{ InitKeyboard -> Platforms ALL - 07May06 DM } +{---------------------------------------------------------------------------} + +procedure initkeyboard;inline; + +begin + keyboard.initkeyboard; +end; + +{---------------------------------------------------------------------------} +{ DoneKeyboard -> Platforms ALL - 07May06 DM } +{---------------------------------------------------------------------------} + +procedure donekeyboard;inline; + +begin + keyboard.donekeyboard; +end; + +{---------------------------------------------------------------------------} +{ InitVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Nov99 LdB } +{---------------------------------------------------------------------------} +function InitVideo:boolean; + +var StoreScreenMode : TVideoMode; + +begin + initvideo:=false; + if VideoInitialized then + begin + StoreScreenMode:=ScreenMode; + DoneVideo; + end + else + StoreScreenMode.Col:=0; + +{$ifdef FV_UNICODE} + Video.InitEnhancedVideo; +{$else FV_UNICODE} + Video.InitVideo; +{$endif FV_UNICODE} + if video.errorcode<>viook then + exit; + GetVideoMode(StartupScreenMode); + GetVideoMode(ScreenMode); +{$ifdef OS_WINDOWS} + { Force the console to the current screen mode } + Video.SetVideoMode(ScreenMode); +{$endif OS_WINDOWS} + + If (StoreScreenMode.Col<>0) and + ((StoreScreenMode.color<>ScreenMode.color) or + (StoreScreenMode.row<>ScreenMode.row) or + (StoreScreenMode.col<>ScreenMode.col)) then + begin + Video.SetVideoMode(StoreScreenMode); + GetVideoMode(ScreenMode); + end; + + if ScreenWidth > MaxViewWidth then + ScreenWidth := MaxViewWidth; + ScreenWidth:=Video.ScreenWidth; + ScreenHeight:=Video.ScreenHeight; + VideoInitialized:=true; + initvideo:=true; +end; + +{---------------------------------------------------------------------------} +{ DoneVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DoneVideo; +BEGIN + if not VideoInitialized then + exit; + Video.SetVideoMode(StartupScreenMode); + Video.ClearScreen; + Video.SetCursorPos(0,0); + Video.DoneVideo; + VideoInitialized:=false; +END; + +{---------------------------------------------------------------------------} +{ ClearScreen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Jan97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE ClearScreen; +BEGIN + Video.ClearScreen; +END; + +{---------------------------------------------------------------------------} +{ SetVideoMode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Nov99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE SetVideoMode (Mode: Sw_Word); +BEGIN +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ ERROR CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ InitSysError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE InitSysError; +BEGIN + SysErrActive := True; { Set active flag } +END; + +{---------------------------------------------------------------------------} +{ DoneSysError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DoneSysError; +BEGIN + SysErrActive := False; { Clear active flag } +END; + +{---------------------------------------------------------------------------} +{ SystemError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION SystemError (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer; +BEGIN + If (FailSysErrors = False) Then Begin { Check error ignore } + + End Else SystemError := 1; { Return 1 for ignored } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STRING FORMAT ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ PrintStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Feb99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE PrintStr (CONST S: String); +BEGIN + Write(S); { Write to screen } +END; + +{---------------------------------------------------------------------------} +{ FormatStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 13Jul99 LdB } +{---------------------------------------------------------------------------} +procedure FormatStr (Var Result: Sw_String; CONST Format: Sw_String; Var Params); +TYPE TLongArray = Array[0..0] Of PtrInt; +VAR W, ResultLength : SmallInt; + FormatIndex, Justify, Wth: Byte; + Fill: Char; S: Sw_String; + + FUNCTION LongToStr (L: Longint; Radix: Byte): Sw_String; + CONST HexChars: Array[0..15] Of Char = + ('0', '1', '2', '3', '4', '5', '6', '7', + '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'); + VAR I: LongInt; S: Sw_String; Sign: String[1]; + begin + LongToStr := ''; { Preset empty return } + If (L < 0) Then begin { If L is negative } + Sign := '-'; { Sign is negative } + L := Abs(L); { Convert to positive } + end Else Sign := ''; { Sign is empty } + S := ''; { Preset empty string } + Repeat + I := L MOD Radix; { Radix mod of value } + S := HexChars[I] + S; { Add char to string } + L := L DIV Radix; { Divid by radix } + Until (L = 0); { Until no remainder } + LongToStr := Sign + S; { Return result } + end; + + procedure HandleParameter (I : LongInt); + begin + While (FormatIndex <= Length(Format)) Do begin { While length valid } +{$ifndef FV_UNICODE} + if ResultLength>=High(Result) then + exit; +{$endif FV_UNICODE} + While (FormatIndex <= Length(Format)) and + (Format[FormatIndex] <> '%') { Param char not found } + Do begin +{$ifdef FV_UNICODE} + SetLength(Result,ResultLength+1); +{$endif FV_UNICODE} + Result[ResultLength+1] := Format[FormatIndex]; { Transfer character } + Inc(ResultLength); { One character added } + Inc(FormatIndex); { Next param char } + end; + If (FormatIndex < Length(Format)) and { Not last char and } + (Format[FormatIndex] = '%') Then begin { '%' char found } + Fill := ' '; { Default fill char } + Justify := 0; { Default justify } + Wth := 0; { Default 0=no width } + Inc(FormatIndex); { Next character } + If (Format[FormatIndex] = '0') Then + Fill := '0'; { Fill char to zero } + If (Format[FormatIndex] = '-') Then begin { Optional just char } + Justify := 1; { Right justify } + Inc(FormatIndex); { Next character } + end; + While ((FormatIndex <= Length(Format)) and { Length still valid } + (Format[FormatIndex] >= '0') and + (Format[FormatIndex] <= '9')) Do begin { Numeric character } + Wth := Wth * 10; { Multiply x10 } + Wth := Wth + Ord(Format[FormatIndex])-$30; { Add numeric value } + Inc(FormatIndex); { Next character } + end; + If ((FormatIndex <= Length(Format)) and { Length still valid } + (Format[FormatIndex] = '#')) Then begin { Parameter marker } + Inc(FormatIndex); { Next character } + HandleParameter(Wth); { Width is param idx } + end; + If (FormatIndex <= Length(Format)) Then begin{ Length still valid } + Case Format[FormatIndex] Of + '%': begin { Literal % } + S := '%'; + Inc(FormatIndex); +{$ifdef FV_UNICODE} + SetLength(Result,ResultLength+Length(S)); + Move(S[1], Result[ResultLength+1], 2); +{$else FV_UNICODE} + Move(S[1], Result[ResultLength+1], 1); +{$endif FV_UNICODE} + Inc(ResultLength,Length(S)); + Continue; + end; + 'c': S := Char(TLongArray(Params)[I]); { Character parameter } + 'd': S := LongToStr(TLongArray(Params)[I], + 10); { Decimal parameter } + 's': S := PString(TLongArray(Params)[I])^;{ String parameter } + 'x': S := LongToStr(TLongArray(Params)[I], + 16); { Hex parameter } + end; + Inc(FormatIndex); { Next character } + If (Wth > 0) Then begin { Width control active } + If (Length(S) > Wth) Then begin { We must shorten S } + If (Justify=1) Then { Check right justify } + S := Copy(S, Length(S)-Wth+1, Wth) { Take right side data } + Else S := Copy(S, 1, Wth); { Take left side data } + end Else begin { We must pad out S } + If (Justify=1) Then { Right justify } + While (Length(S) < Wth) Do + S := S+Fill Else { Right justify fill } + While (Length(S) < Wth) Do + S := Fill + S; { Left justify fill } + end; + end; + W:=Length(S); +{$ifdef FV_UNICODE} + SetLength(Result,ResultLength+W); + Move(S[1], Result[ResultLength+1], + 2*W); { Move data to result } +{$else FV_UNICODE} + if W+ResultLength+1>High(Result) then + W:=High(Result)-ResultLength; + Move(S[1], Result[ResultLength+1], + W); { Move data to result } +{$endif FV_UNICODE} + Inc(ResultLength,W); { Adj result length } + Inc(I); + end; + end; + end; + end; + +begin + ResultLength := 0; { Zero result length } + FormatIndex := 1; { Format index to 1 } + HandleParameter(0); { Handle parameter } +{$ifndef FV_UNICODE} + Result[0] := Chr(ResultLength); { Set string length } +{$endif FV_UNICODE} +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ NEW QUEUED EVENT HANDLER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ PutEventInQueue -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Mar98 LdB } +{---------------------------------------------------------------------------} +FUNCTION PutEventInQueue (Var Event: TEvent): Boolean; +BEGIN + If (QueueCount < QueueMax) Then Begin { Check room in queue } + Queue[QueueHead] := Event; { Store event } + Inc(QueueHead); { Inc head position } + If (QueueHead = QueueMax) Then QueueHead := 0; { Roll to start check } + Inc(QueueCount); { Inc queue count } + PutEventInQueue := True; { Return successful } + End Else PutEventInQueue := False; { Return failure } +END; + +{---------------------------------------------------------------------------} +{ NextQueuedEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Mar98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE NextQueuedEvent(Var Event: TEvent); +BEGIN + If (QueueCount > 0) Then Begin { Check queued event } + Event := Queue[QueueTail]; { Fetch next event } + Inc(QueueTail); { Inc tail position } + If (QueueTail = QueueMax) Then QueueTail := 0; { Roll to start check } + Dec(QueueCount); { Dec queue count } + End Else Event.What := evNothing; { Return empty event } +END; + +{***************************************************************************} +{ UNIT INITIALIZATION ROUTINE } +{***************************************************************************} +BEGIN +{$IFDEF OS_AMIGA} + StartupTicks := (dos.GetMsCount div 55); +{$ENDIF} + ButtonCount := DetectMouse; { Detect mouse } + DetectVideo; { Detect video } +{ InitKeyboard;} + InitSystemMsg; +{$ifdef OS_WINDOWS} + SetFileApisToOEM; +{$endif} + + SaveExit := ExitProc; { Save old exit } + ExitProc := @ExitDrivers; { Set new exit } +END. diff --git a/packages/fv/src/drivers.pas b/packages/fv/src/drivers.pas index c757098275..7bc64ea0c7 100644 --- a/packages/fv/src/drivers.pas +++ b/packages/fv/src/drivers.pas @@ -1,1619 +1 @@ -{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} -{ } -{ System independent clone of DRIVERS.PAS } -{ } -{ Interface Copyright (c) 1992 Borland International } -{ } -{ Copyright (c) 1996, 1997, 1998, 1999, 2000 } -{ by Leon de Boer } -{ ldeboer@attglobal.net - primary e-mail addr } -{ ldeboer@projectent.com.au - backup e-mail addr } -{ } -{ Original FormatStr kindly donated by Marco Schmidt } -{ } -{ Mouse callback hook under FPC with kind assistance of } -{ Pierre Muller, Gertjan Schouten & Florian Klaempfl. } -{ } -{****************[ THIS CODE IS FREEWARE ]*****************} -{ } -{ This sourcecode is released for the purpose to } -{ promote the pascal language on all platforms. You may } -{ redistribute it and/or modify with the following } -{ DISCLAIMER. } -{ } -{ This SOURCE CODE is distributed "AS IS" WITHOUT } -{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } -{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } -{ } -{*****************[ SUPPORTED PLATFORMS ]******************} -{ } -{ Only Free Pascal Compiler supported } -{ } -{**********************************************************} - -UNIT Drivers; - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - INTERFACE -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{====Include file to sort compiler platform out =====================} -{$I platform.inc} -{====================================================================} - -{==== Compiler directives ===========================================} - -{$X+} { Extended syntax is ok } -{$R-} { Disable range checking } -{$IFNDEF OS_UNIX} -{$S-} { Disable Stack Checking } -{$ENDIF} -{$I-} { Disable IO Checking } -{$Q-} { Disable Overflow Checking } -{$V-} { Turn off strict VAR strings } -{====================================================================} - -{$ifdef CPU68K} - {$DEFINE ENDIAN_BIG} -{$endif CPU68K} - -{$ifdef FPC} - {$INLINE ON} -{$endif} - -USES - {$IFDEF OS_WINDOWS} { WIN/NT CODE } - Windows, { Standard unit } - {$ENDIF} - - {$IFDEF OS_WIN16} { WIN16 CODE } - WinProcs, WinTypes, { Standard units } - Crt, { used for Delay() } - {$ENDIF} - - {$ifdef OS_DOS} - Dos, - {$endif OS_DOS} - - {$IFDEF OS_OS2} { OS2 CODE } - {$IFDEF PPC_Virtual} { VIRTUAL PASCAL UNITS } - OS2Def, OS2Base, OS2PMAPI, { Standard units } - {$ENDIF} - {$IFDEF PPC_Speed} { SPEED PASCAL UNITS } - BseDos, Os2Def, { Standard units } - {$ENDIF} - {$IFDEF PPC_FPC} { FPC UNITS } - DosCalls, Os2Def, { Standard units } - {$ENDIF} - {$ENDIF} - - {$IFDEF OS_UNIX} - unixtype,baseunix,unix, - {$ENDIF} - - {$IFDEF OS_NETWARE_LIBC} - libc, - {$ENDIF} - {$IFDEF OS_NETWARE_CLIB} - nwserv, - {$ENDIF} - - {$IFDEF OS_AMIGA} - dos, amigados, - {$ENDIF} - - video, - SysMsg, - FVCommon, Objects; { GFV standard units } - -{***************************************************************************} -{ PUBLIC CONSTANTS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ EVENT TYPE MASKS } -{---------------------------------------------------------------------------} -CONST - evMouseDown = $0001; { Mouse down event } - evMouseUp = $0002; { Mouse up event } - evMouseMove = $0004; { Mouse move event } - evMouseAuto = $0008; { Mouse auto event } - evKeyDown = $0010; { Key down event } - evCommand = $0100; { Command event } - evBroadcast = $0200; { Broadcast event } - -{---------------------------------------------------------------------------} -{ EVENT CODE MASKS } -{---------------------------------------------------------------------------} -CONST - evNothing = $0000; { Empty event } - evMouse = $000F; { Mouse event } - evKeyboard = $0010; { Keyboard event } - evMessage = $FF00; { Message event } - -{---------------------------------------------------------------------------} -{ EXTENDED KEY CODES } -{---------------------------------------------------------------------------} -CONST - kbNoKey = $0000; kbAltEsc = $0100; kbEsc = $011B; - kbAltSpace = $0200; kbCtrlIns = $0400; kbShiftIns = $0500; - kbCtrlDel = $0600; kbShiftDel = $0700; kbAltBack = $0800; - kbAltShiftBack= $0900; kbBack = $0E08; kbCtrlBack = $0E7F; - kbShiftTab = $0F00; kbTab = $0F09; kbAltQ = $1000; - kbCtrlQ = $1011; kbAltW = $1100; kbCtrlW = $1117; - kbAltE = $1200; kbCtrlE = $1205; kbAltR = $1300; - kbCtrlR = $1312; kbAltT = $1400; kbCtrlT = $1414; - kbAltY = $1500; kbCtrlY = $1519; kbAltU = $1600; - kbCtrlU = $1615; kbAltI = $1700; kbCtrlI = $1709; - kbAltO = $1800; kbCtrlO = $180F; kbAltP = $1900; - kbCtrlP = $1910; kbAltLftBrack = $1A00; kbAltRgtBrack = $1B00; - kbCtrlEnter = $1C0A; kbEnter = $1C0D; kbAltA = $1E00; - kbCtrlA = $1E01; kbAltS = $1F00; kbCtrlS = $1F13; - kbAltD = $2000; kbCtrlD = $2004; kbAltF = $2100; - kbCtrlF = $2106; kbAltG = $2200; kbCtrlG = $2207; - kbAltH = $2300; kbCtrlH = $2308; kbAltJ = $2400; - kbCtrlJ = $240A; kbAltK = $2500; kbCtrlK = $250B; - kbAltL = $2600; kbCtrlL = $260C; kbAltSemiCol = $2700; - kbAltQuote = $2800; kbAltOpQuote = $2900; kbAltBkSlash = $2B00; - kbAltZ = $2C00; kbCtrlZ = $2C1A; kbAltX = $2D00; - kbCtrlX = $2D18; kbAltC = $2E00; kbCtrlC = $2E03; - kbAltV = $2F00; kbCtrlV = $2F16; kbAltB = $3000; - kbCtrlB = $3002; kbAltN = $3100; kbCtrlN = $310E; - kbAltM = $3200; kbCtrlM = $320D; kbAltComma = $3300; - kbAltPeriod = $3400; kbAltSlash = $3500; kbAltGreyAst = $3700; - kbSpaceBar = $3920; kbF1 = $3B00; kbF2 = $3C00; - kbF3 = $3D00; kbF4 = $3E00; kbF5 = $3F00; - kbF6 = $4000; kbF7 = $4100; kbF8 = $4200; - kbF9 = $4300; kbF10 = $4400; kbHome = $4700; - kbUp = $4800; kbPgUp = $4900; kbGrayMinus = $4A2D; - kbLeft = $4B00; kbCenter = $4C00; kbRight = $4D00; - kbAltGrayPlus = $4E00; kbGrayPlus = $4E2B; kbEnd = $4F00; - kbDown = $5000; kbPgDn = $5100; kbIns = $5200; - kbDel = $5300; kbShiftF1 = $5400; kbShiftF2 = $5500; - kbShiftF3 = $5600; kbShiftF4 = $5700; kbShiftF5 = $5800; - kbShiftF6 = $5900; kbShiftF7 = $5A00; kbShiftF8 = $5B00; - kbShiftF9 = $5C00; kbShiftF10 = $5D00; kbCtrlF1 = $5E00; - kbCtrlF2 = $5F00; kbCtrlF3 = $6000; kbCtrlF4 = $6100; - kbCtrlF5 = $6200; kbCtrlF6 = $6300; kbCtrlF7 = $6400; - kbCtrlF8 = $6500; kbCtrlF9 = $6600; kbCtrlF10 = $6700; - kbAltF1 = $6800; kbAltF2 = $6900; kbAltF3 = $6A00; - kbAltF4 = $6B00; kbAltF5 = $6C00; kbAltF6 = $6D00; - kbAltF7 = $6E00; kbAltF8 = $6F00; kbAltF9 = $7000; - kbAltF10 = $7100; kbCtrlPrtSc = $7200; kbCtrlLeft = $7300; - kbCtrlRight = $7400; kbCtrlEnd = $7500; kbCtrlPgDn = $7600; - kbCtrlHome = $7700; kbAlt1 = $7800; kbAlt2 = $7900; - kbAlt3 = $7A00; kbAlt4 = $7B00; kbAlt5 = $7C00; - kbAlt6 = $7D00; kbAlt7 = $7E00; kbAlt8 = $7F00; - kbAlt9 = $8000; kbAlt0 = $8100; kbAltMinus = $8200; - kbAltEqual = $8300; kbCtrlPgUp = $8400; kbF11 = $8500; - kbF12 = $8600; kbShiftF11 = $8700; kbShiftF12 = $8800; - kbCtrlF11 = $8900; kbCtrlF12 = $8A00; kbAltF11 = $8B00; - kbAltF12 = $8C00; kbCtrlUp = $8D00; kbCtrlMinus = $8E00; - kbCtrlCenter = $8F00; kbCtrlGreyPlus= $9000; kbCtrlDown = $9100; - kbCtrlTab = $9400; kbAltHome = $9700; kbAltUp = $9800; - kbAltPgUp = $9900; kbAltLeft = $9B00; kbAltRight = $9D00; - kbAltEnd = $9F00; kbAltDown = $A000; kbAltPgDn = $A100; - kbAltIns = $A200; kbAltDel = $A300; kbAltTab = $A500; - -{ ------------------------------- REMARK ------------------------------ } -{ New keys not initially defined by Borland in their unit interface. } -{ ------------------------------ END REMARK --- Leon de Boer, 15May96 - } - kbFullStop = $342E; kbComma = $332C; kbBackSlash = $352F; - kbApostrophe = $2827; kbSemiColon = $273B; kbEqual = $0D3D; - kbGreaterThan = $343E; kbLessThan = $333C; kbQuestion = $353F; - kbQuote = $2822; kbColon = $273A; kbPlus = $0D2B; - kbPipe = $2B7C; kbSlash = $2B5C; kbExclaim = $0221; - kbAt = $0340; kbNumber = $0423; kbPercent = $0625; - kbCaret = $075E; kbAmpersand = $0826; kbAsterix = $092A; - kbLeftBracket = $0A28; kbRightBracket= $0B29; kbApprox = $2960; - kbTilde = $297E; kbDollar = $0524; kbMinus = $0C2D; - kbUnderline = $0C5F; kbLeftSqBr = $1A5B; kbRightSqBr = $1B5D; - kbLeftCurlyBr = $1A7B; kbRightCurlyBr= $1B7D; - -{---------------------------------------------------------------------------} -{ KEYBOARD STATE AND SHIFT MASKS } -{---------------------------------------------------------------------------} -CONST - kbRightShift = $0001; { Right shift key } - kbLeftShift = $0002; { Left shift key } - kbCtrlShift = $0004; { Control key down } - kbAltShift = $0008; { Alt key down } - kbScrollState = $0010; { Scroll lock on } - kbNumState = $0020; { Number lock on } - kbCapsState = $0040; { Caps lock on } - kbInsState = $0080; { Insert mode on } - - kbBothShifts = kbRightShift + kbLeftShift; { Right & Left shifts } - -{---------------------------------------------------------------------------} -{ MOUSE BUTTON STATE MASKS } -{---------------------------------------------------------------------------} -CONST - mbLeftButton = $01; { Left mouse button } - mbRightButton = $02; { Right mouse button } - mbMiddleButton = $04; { Middle mouse button } - mbScrollWheelDown = $08; { Scroll wheel down} - mbScrollWheelUp = $10; { Scroll wheel up } - - -{---------------------------------------------------------------------------} -{ SCREEN CRT MODE CONSTANTS } -{---------------------------------------------------------------------------} -CONST - smBW80 = $0002; { Black and white } - smCO80 = $0003; { Colour mode } - smMono = $0007; { Monochrome mode } - smFont8x8 = $0100; { 8x8 font mode } - -{***************************************************************************} -{ PUBLIC TYPE DEFINITIONS } -{***************************************************************************} - -{ ******************************* REMARK ****************************** } -{ The TEvent definition is completely compatable with all existing } -{ code but adds two new fields ID and Data into the message record } -{ which helps with WIN/NT and OS2 message processing. } -{ ****************************** END REMARK *** Leon de Boer, 11Sep97 * } - -{---------------------------------------------------------------------------} -{ EVENT RECORD DEFINITION } -{---------------------------------------------------------------------------} -TYPE - TEvent = -{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - PACKED -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - RECORD - What: Sw_Word; { Event type } - Case Sw_Word Of - evNothing: (); { ** NO EVENT ** } - evMouse: ( - Buttons: Byte; { Mouse buttons } - Double: Boolean; { Double click state } - Where: TPoint); { Mouse position } - evKeyDown: ( - { ** KEY EVENT ** } - Case Sw_Integer Of - 0: (KeyCode: Word); { Full key code } - 1: ( -{$ifdef ENDIAN_BIG} - ScanCode: Byte; - CharCode: Char; -{$else not ENDIAN_BIG} - CharCode: Char; { Char code } - ScanCode: Byte; { Scan code } -{$endif not ENDIAN_BIG} - KeyShift: byte)); { Shift states } - evMessage: ( { ** MESSAGE EVENT ** } - Command: Sw_Word; { Message command } - Id : Sw_Word; { Message id } - Data : Real; { Message data } - Case Sw_Word Of - 0: (InfoPtr: Pointer); { Message pointer } - 1: (InfoLong: Longint); { Message longint } - 2: (InfoWord: Word); { Message Sw_Word } - 3: (InfoInt: Integer); { Message Sw_Integer } - 4: (InfoByte: Byte); { Message byte } - 5: (InfoChar: Char)); { Message character } - END; - PEvent = ^TEvent; - - TVideoMode = Video.TVideoMode; { Screen mode } - -{---------------------------------------------------------------------------} -{ ERROR HANDLER FUNCTION DEFINITION } -{---------------------------------------------------------------------------} -TYPE - TSysErrorFunc = FUNCTION (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer; - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{ Get Dos counter ticks } -Function GetDosTicks:longint; { returns ticks at 18.2 Hz, just like DOS } - - -procedure GiveUpTimeSlice; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ BUFFER MOVE ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-CStrLen------------------------------------------------------------ -Returns the length of string S, where S is a control string using tilde -characters ('~') to designate shortcut characters. The tildes are -excluded from the length of the string, as they will not appear on -the screen. For example, given the string '~B~roccoli' as its -parameter, CStrLen returns 8. -25May96 LdB ----------------------------------------------------------------------} -FUNCTION CStrLen (Const S: String): Sw_Integer; - -{-MoveStr------------------------------------------------------------ -Moves a string into a buffer for use with a view's WriteBuf or WriteLine. -Dest must be a TDrawBuffer (or an equivalent array of Sw_Words). The -characters in Str are moved into the low bytes of corresponding Sw_Words -in Dest. The high bytes of the Sw_Words are set to Attr, or remain -unchanged if Attr is zero. -25May96 LdB ----------------------------------------------------------------------} -PROCEDURE MoveStr (Var Dest; Const Str: String; Attr: Byte); - -{-MoveCStr----------------------------------------------------------- -The characters in Str are moved into the low bytes of corresponding -Sw_Words in Dest. The high bytes of the Sw_Words are set to Lo(Attr) or -Hi(Attr). Tilde characters (~) in the string toggle between the two -attribute bytes passed in the Attr Sw_Word. -25May96 LdB ----------------------------------------------------------------------} -PROCEDURE MoveCStr (Var Dest; Const Str: String; Attrs: Word); - -{-MoveBuf------------------------------------------------------------ -Count bytes are moved from Source into the low bytes of corresponding -Sw_Words in Dest. The high bytes of the Sw_Words in Dest are set to Attr, -or remain unchanged if Attr is zero. -25May96 LdB ----------------------------------------------------------------------} -PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; Count: Sw_Word); - -{-MoveChar------------------------------------------------------------ -Moves characters into a buffer for use with a view's WriteBuf or -WriteLine. Dest must be a TDrawBuffer (or an equivalent array of Sw_Words). -The low bytes of the first Count Sw_Words of Dest are set to C, or -remain unchanged if Ord(C) is zero. The high bytes of the Sw_Words are -set to Attr, or remain unchanged if Attr is zero. -25May96 LdB ----------------------------------------------------------------------} -PROCEDURE MoveChar (Var Dest; C: Char; Attr: Byte; Count: Sw_Word); - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ KEYBOARD SUPPORT ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-GetAltCode--------------------------------------------------------- -Returns the scancode corresponding to Alt+Ch key that is given. -25May96 LdB ----------------------------------------------------------------------} -FUNCTION GetAltCode (Ch: Char): Word; - -{-GetCtrlCode-------------------------------------------------------- -Returns the scancode corresponding to Alt+Ch key that is given. -25May96 LdB ----------------------------------------------------------------------} -FUNCTION GetCtrlCode (Ch: Char): Word; - -{-GetAltChar--------------------------------------------------------- -Returns the ascii character for the Alt+Key scancode that was given. -25May96 LdB ----------------------------------------------------------------------} -FUNCTION GetAltChar (KeyCode: Word): Char; - -{-GetCtrlChar-------------------------------------------------------- -Returns the ascii character for the Ctrl+Key scancode that was given. -25May96 LdB ----------------------------------------------------------------------} -FUNCTION GetCtrlChar (KeyCode: Word): Char; - -{-CtrlToArrow-------------------------------------------------------- -Converts a WordStar-compatible control key code to the corresponding -cursor key code. -25May96 LdB ----------------------------------------------------------------------} -FUNCTION CtrlToArrow (KeyCode: Word): Word; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ KEYBOARD CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-GetShiftState------------------------------------------------------ -Returns a byte containing the current Shift key state. The return -value contains a combination of the kbXXXX constants for shift states. -08Jul96 LdB ----------------------------------------------------------------------} -FUNCTION GetShiftState: Byte; - -{-GetKeyEvent-------------------------------------------------------- -Checks whether a keyboard event is available. If a key has been pressed, -Event.What is set to evKeyDown and Event.KeyCode is set to the scan -code of the key. Otherwise, Event.What is set to evNothing. -19May98 LdB ----------------------------------------------------------------------} -PROCEDURE GetKeyEvent (Var Event: TEvent); - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ MOUSE CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-ShowMouse---------------------------------------------------------- -Decrements the hide counter and if zero the mouse is shown on screen. -30Jun98 LdB ----------------------------------------------------------------------} -PROCEDURE ShowMouse; - -{-HideMouse---------------------------------------------------------- -If mouse hide counter is zero it removes the cursor from the screen. -The hide counter is then incremented by one count. -30Jun98 LdB ----------------------------------------------------------------------} -PROCEDURE HideMouse; - -{-GetMouseEvent------------------------------------------------------ -Checks whether a mouse event is available. If a mouse event has occurred, -Event.What is set to evMouseDown, evMouseUp, evMouseMove, or evMouseAuto -and the button and double click variables are set appropriately. -06Jan97 LdB ----------------------------------------------------------------------} -PROCEDURE GetMouseEvent (Var Event: TEvent); - -{-GetSystemEvent------------------------------------------------------ -Checks whether a system event is available. If a system event has occurred, -Event.What is set to evCommand appropriately -10Oct2000 PM ----------------------------------------------------------------------} -procedure GetSystemEvent (Var Event: TEvent); - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ EVENT HANDLER CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-InitEvents--------------------------------------------------------- -Initializes the event manager, enabling the mouse handler routine and -under DOS/DPMI shows the mouse on screen. It is called automatically -by TApplication.Init. -02May98 LdB ----------------------------------------------------------------------} -PROCEDURE InitEvents; - -{-DoneEvents--------------------------------------------------------- -Terminates event manager and disables the mouse and under DOS hides -the mouse. It is called automatically by TApplication.Done. -02May98 LdB ----------------------------------------------------------------------} -PROCEDURE DoneEvents; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ VIDEO CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-Initkeyboard------------------------------------------------------- -Initializes the keyboard. Before it is called read(ln)/write(ln) -are functional, after it is called FV's keyboard routines are -functional. ----------------------------------------------------------------------} - -procedure initkeyboard; - -{-Donekeyboard------------------------------------------------------- -Restores keyboard to original state. FV's keyboard routines may not -be used after a call to this. Read(ln)/write(ln) can be used again. ----------------------------------------------------------------------} - -procedure donekeyboard; - -{-DetectVideo--------------------------------------------------------- -Detects the current video mode without initializing or otherwise -changing the current screen. ----------------------------------------------------------------------} -procedure DetectVideo; - -{-InitVideo--------------------------------------------------------- -Initializes the video manager, Saves the current screen mode in -StartupMode, and switches to the mode indicated by ScreenMode. -19May98 LdB ----------------------------------------------------------------------} -function InitVideo:boolean; - -{-DoneVideo--------------------------------------------------------- -Terminates the video manager by restoring the initial screen mode -(given by StartupMode), clearing the screen, and restoring the cursor. -Called automatically by TApplication.Done. -03Jan97 LdB ----------------------------------------------------------------------} -PROCEDURE DoneVideo; - -{-ClearScreen-------------------------------------------------------- -Does nothing provided for compatability purposes only. -04Jan97 LdB ----------------------------------------------------------------------} -PROCEDURE ClearScreen; - -{-SetVideoMode------------------------------------------------------- -Does nothing provided for compatability purposes only. -04Jan97 LdB ----------------------------------------------------------------------} -PROCEDURE SetVideoMode (Mode: Sw_Word); - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ ERROR CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-InitSysError------------------------------------------------------- -Error handling is not yet implemented so this simply sets -SysErrActive=True (ie it lies) and exits. -20May98 LdB ----------------------------------------------------------------------} -PROCEDURE InitSysError; - -{-DoneSysError------------------------------------------------------- -Error handling is not yet implemented so this simply sets -SysErrActive=False and exits. -20May98 LdB ----------------------------------------------------------------------} -PROCEDURE DoneSysError; - -{-SystemError--------------------------------------------------------- -Error handling is not yet implemented so this simply drops through. -20May98 LdB ----------------------------------------------------------------------} -FUNCTION SystemError (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ STRING FORMAT ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-PrintStr----------------------------------------------------------- -Does nothing provided for compatability purposes only. -30Jun98 LdB ----------------------------------------------------------------------} -PROCEDURE PrintStr (CONST S: String); - -{-FormatStr---------------------------------------------------------- -A string formatting routine that given a string that includes format -specifiers and a list of parameters in Params, FormatStr produces a -formatted output string in Result. -18Feb99 LdB ----------------------------------------------------------------------} -PROCEDURE FormatStr (Var Result: String; CONST Format: String; Var Params); - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ >> NEW QUEUED EVENT HANDLER ROUTINES << } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-PutEventInQueue----------------------------------------------------- -If there is room in the queue the event is placed in the next vacant -position in the queue manager. -17Mar98 LdB ----------------------------------------------------------------------} -FUNCTION PutEventInQueue (Var Event: TEvent): Boolean; - -{-NextQueuedEvent---------------------------------------------------- -If there are queued events the next event is loaded into event else -evNothing is returned. -17Mar98 LdB ----------------------------------------------------------------------} -PROCEDURE NextQueuedEvent(Var Event: TEvent); - -{***************************************************************************} -{ INITIALIZED PUBLIC VARIABLES } -{***************************************************************************} - -PROCEDURE HideMouseCursor; -PROCEDURE ShowMouseCursor; - - -{---------------------------------------------------------------------------} -{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } -{---------------------------------------------------------------------------} -CONST - CheckSnow : Boolean = False; { Compatability only } - MouseEvents : Boolean = False; { Mouse event state } - MouseReverse : Boolean = False; { Mouse reversed } - HiResScreen : Boolean = False; { Compatability only } - CtrlBreakHit : Boolean = False; { Compatability only } - SaveCtrlBreak: Boolean = False; { Compatability only } - SysErrActive : Boolean = False; { Compatability only } - FailSysErrors: Boolean = False; { Compatability only } - ButtonCount : Byte = 0; { Mouse button count } - DoubleDelay : Sw_Word = 8; { Double click delay } - RepeatDelay : Sw_Word = 8; { Auto mouse delay } - SysColorAttr : Sw_Word = $4E4F; { System colour attr } - SysMonoAttr : Sw_Word = $7070; { System mono attr } - StartupMode : Sw_Word = $FFFF; { Compatability only } - CursorLines : Sw_Word = $FFFF; { Compatability only } - ScreenBuffer : Pointer = Nil; { Compatability only } - SaveInt09 : Pointer = Nil; { Compatability only } - SysErrorFunc : TSysErrorFunc = {$ifdef FPC}@{$endif}SystemError; { System error ptr } - - -{***************************************************************************} -{ UNINITIALIZED PUBLIC VARIABLES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } -{---------------------------------------------------------------------------} -VAR - MouseIntFlag: Byte; { Mouse in int flag } - MouseButtons: Byte; { Mouse button state } - ScreenWidth : Byte; { Screen text width } - ScreenHeight: Byte; { Screen text height } - ScreenMode : TVideoMode; { Screen mode } - MouseWhere : TPoint; { Mouse position } - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IMPLEMENTATION -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} -{ API Units } - USES - FVConsts, - Keyboard,Mouse; - -{***************************************************************************} -{ PRIVATE INTERNAL CONSTANTS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ DOS/DPMI MOUSE INTERRUPT EVENT QUEUE SIZE } -{---------------------------------------------------------------------------} -CONST EventQSize = 16; { Default int bufsize } - -{---------------------------------------------------------------------------} -{ DOS/DPMI/WIN/NT/OS2 NEW EVENT QUEUE MAX SIZE } -{---------------------------------------------------------------------------} -CONST QueueMax = 64; { Max new queue size } - -{---------------------------------------------------------------------------} -{ MAX WIEW WIDTH to avoid TDrawBuffer overrun in views unit } -{---------------------------------------------------------------------------} -CONST MaxViewWidth = 255; { Max view width } - -{***************************************************************************} -{ PRIVATE INTERNAL TYPES } -{***************************************************************************} - -{***************************************************************************} -{ PRIVATE INTERNAL INITIALIZED VARIABLES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ DOS/DPMI/WIN/NT/OS2 ALT KEY SCANCODES FROM KEYS (0-127) } -{---------------------------------------------------------------------------} -CONST AltCodes: Array [0..127] Of Byte = ( - $00, $00, $00, $00, $00, $00, $00, $00, { $00 - $07 } - $00, $00, $00, $00, $00, $00, $00, $00, { $08 - $0F } - $00, $00, $00, $00, $00, $00, $00, $00, { $10 - $17 } - $00, $00, $00, $00, $00, $00, $00, $00, { $18 - $1F } - $00, $00, $00, $00, $00, $00, $00, $00, { $20 - $27 } - $00, $00, $00, $00, $00, $82, $00, $00, { $28 - $2F } - $81, $78, $79, $7A, $7B, $7C, $7D, $7E, { $30 - $37 } - $7F, $80, $00, $00, $00, $83, $00, $00, { $38 - $3F } - $00, $1E, $30, $2E, $20, $12, $21, $22, { $40 - $47 } - $23, $17, $24, $25, $26, $32, $31, $18, { $48 - $4F } - $19, $10, $13, $1F, $14, $16, $2F, $11, { $50 - $57 } - $2D, $15, $2C, $00, $00, $00, $00, $00, { $58 - $5F } - $00, $00, $00, $00, $00, $00, $00, $00, { $60 - $67 } - $00, $00, $00, $00, $00, $00, $00, $00, { $68 - $6F } - $00, $00, $00, $00, $00, $00, $00, $00, { $70 - $77 } - $00, $00, $00, $00, $00, $00, $00, $00); { $78 - $7F } - -{***************************************************************************} -{ PRIVATE INTERNAL INITIALIZED VARIABLES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ NEW CONTROL VARIABLES } -{---------------------------------------------------------------------------} -CONST - HideCount : Sw_Integer = 0; { Cursor hide count } - QueueCount: Sw_Word = 0; { Queued message count } - QueueHead : Sw_Word = 0; { Queue head pointer } - QueueTail : Sw_Word = 0; { Queue tail pointer } - -{***************************************************************************} -{ PRIVATE INTERNAL UNINITIALIZED VARIABLES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ UNINITIALIZED DOS/DPMI/API VARIABLES } -{---------------------------------------------------------------------------} -VAR - LastDouble : Boolean; { Last double buttons } - LastButtons: Byte; { Last button state } - DownButtons: Byte; { Last down buttons } - EventCount : Sw_Word; { Events in queue } - AutoDelay : Sw_Word; { Delay time count } - DownTicks : Sw_Word; { Down key tick count } - AutoTicks : Sw_Word; { Held key tick count } - LastWhereX : Sw_Word; { Last x position } - LastWhereY : Sw_Word; { Last y position } - DownWhereX : Sw_Word; { Last x position } - DownWhereY : Sw_Word; { Last y position } - LastWhere : TPoint; { Last mouse position } - DownWhere : TPoint; { Last down position } - EventQHead : Pointer; { Head of queue } - EventQTail : Pointer; { Tail of queue } - EventQueue : Array [0..EventQSize - 1] Of TEvent; { Event queue } - EventQLast : RECORD END; { Simple end marker } - StartupScreenMode : TVideoMode; - {$ifdef OS_AMIGA} - StartupTicks: Int64; // ticks at Startup for GetDOSTicks - {$endif} -{---------------------------------------------------------------------------} -{ GetDosTicks (18.2 Hz) } -{---------------------------------------------------------------------------} - -Function GetDosTicks:longint; { returns ticks at 18.2 Hz, just like DOS } -{$IFDEF OS_OS2} - const - QSV_MS_COUNT = 14; - var - L: longint; - begin - DosQuerySysInfo (QSV_MS_COUNT, QSV_MS_COUNT, L, 4); - GetDosTicks := L div 55; - end; -{$ENDIF} -{$IFDEF OS_UNIX} - var - tv : TimeVal; - { tz : TimeZone;} - begin - FPGetTimeOfDay(@tv,nil{,tz}); - GetDosTicks:=((tv.tv_Sec mod 86400) div 60)*1092+((tv.tv_Sec mod 60)*1000000+tv.tv_USec) div 54945; - end; -{$ENDIF OS_UNIX} -{$IFDEF OS_WINDOWS} - begin - GetDosTicks:=GetTickCount div 55; - end; -{$ENDIF OS_WINDOWS} -{$IFDEF OS_WIN16} - begin - GetDosTicks:=GetTickCount div 55; - end; -{$ENDIF OS_WIN16} -{$IFDEF OS_DOS} - begin - GetDosTicks:=MemL[$40:$6c]; - end; -{$ENDIF OS_DOS} -{$IFDEF OS_NETWARE_LIBC} -var - tv : TTimeVal; - tz : TTimeZone; - begin - fpGetTimeOfDay(tv,tz); - GetDosTicks:=((tv.tv_sec mod 86400) div 60)*1092+((tv.tv_Sec mod 60)*1000000+tv.tv_USec) div 549 - end; -{$ENDIF} -{$IFDEF OS_NETWARE_CLIB} - begin - GetDosTicks := Nwserv.GetCurrentTicks; - end; -{$ENDIF} -{$IFDEF OS_AMIGA} - begin - GetDosTicks:= ((dos.GetMsCount div 55) - StartupTicks) and $7FFFFFFF; - end; -{$ENDIF OS_AMIGA} - - -procedure GiveUpTimeSlice; -{$IFDEF OS_DOS} -var r: registers; -begin - Intr ($28, R); (* This is supported everywhere. *) - r.ax:=$1680; - intr($2f,r); -end; -{$ENDIF} -{$IFDEF OS_UNIX} - var - req,rem : timespec; -begin - req.tv_sec:=0; - req.tv_nsec:=10000000;{ 10 ms } - fpnanosleep(@req,@rem); -end; -{$ENDIF} -{$IFDEF OS_OS2} -begin - DosSleep (5); -end; -{$ENDIF} -{$IFDEF OS_WINDOWS} -begin - { if the return value of this call is non zero then - it means that a ReadFileEx or WriteFileEx have completed - unused for now ! } - { wait for 10 ms } - if SleepEx(10,true)=WAIT_IO_COMPLETION then - begin - { here we should handle the completion of the routines - if we use them } - end; -end; -{$ENDIF} -{$IFDEF OS_WIN16} - begin - Delay (10); - end; -{$ENDIF} -{$IFDEF OS_NETWARE_LIBC} - begin - Delay (10); - end; -{$ENDIF} -{$IFDEF OS_NETWARE_CLIB} - begin - Delay (10); - end; -{$ENDIF} -{$IFDEF OS_AMIGA} - begin - { AmigaOS Delay() wait's argument in 1/50 seconds } - { DOSDelay(2); // the old solution... } - Keyboard.WaitForSystemEvent(150); - end; -{$ENDIF OS_AMIGA} - - -{---------------------------------------------------------------------------} -{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } -{---------------------------------------------------------------------------} -VAR - SaveExit: CodePointer; { Saved exit pointer } - Queue : Array [0..QueueMax-1] Of TEvent; { New message queue } - -{***************************************************************************} -{ PRIVATE INTERNAL ROUTINES } -{***************************************************************************} - -PROCEDURE ShowMouseCursor;inline; -BEGIN - ShowMouse; -END; - -PROCEDURE HideMouseCursor;inline; -BEGIN - HideMouse; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ DOS/DPMI/WIN/NT/OS2 PRIVATE INTERNAL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ ExitDrivers -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jun98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE ExitDrivers; {$IFNDEF PPC_FPC}{$IFNDEF OS_UNIX} FAR; {$ENDIF}{$ENDIF} -BEGIN - DoneSysError; { Relase error trap } - DoneEvents; { Close event driver } -{ DoneKeyboard;} - DoneVideo; - ExitProc := SaveExit; { Restore old exit } -END; - -{---------------------------------------------------------------------------} -{ DetectVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } -{---------------------------------------------------------------------------} - -procedure DetectVideo; -VAR - CurrMode : TVideoMode; -begin - { Video.InitVideo; Incompatible with BP - and forces a screen clear which is often a bad thing PM } - GetVideoMode(CurrMode); - ScreenMode:=CurrMode; -end; - -{---------------------------------------------------------------------------} -{ DetectMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } -FUNCTION DetectMouse: Byte;inline; -begin - DetectMouse:=Mouse.DetectMouse; -end; - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ BUFFER MOVE ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ CStrLen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } -{---------------------------------------------------------------------------} -FUNCTION CStrLen (Const S: String): Sw_Integer; -VAR I, J: Sw_Integer; -BEGIN - J := 0; { Set result to zero } - For I := 1 To Length(S) Do - If (S[I] <> '~') Then Inc(J); { Inc count if not ~ } - CStrLen := J; { Return length } -END; - -{---------------------------------------------------------------------------} -{ MoveStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE MoveStr (Var Dest; Const Str: String; Attr: Byte); -VAR I: Word; P: PWord; -BEGIN - For I := 1 To Length(Str) Do Begin { For each character } - P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word } - If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute } - WordRec(P^).Lo := Byte(Str[I]); { Copy string char } - End; -END; - -{---------------------------------------------------------------------------} -{ MoveCStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE MoveCStr (Var Dest; Const Str: String; Attrs: Word); -VAR B: Byte; I, J: Sw_Word; P: PWord; -BEGIN - J := 0; { Start position } - For I := 1 To Length(Str) Do Begin { For each character } - If (Str[I] <> '~') Then Begin { Not tilde character } - P := @TWordArray(Dest)[J]; { Pointer to Sw_Word } - If (Lo(Attrs) <> 0) Then - WordRec(P^).Hi := Lo(Attrs); { Copy attribute } - WordRec(P^).Lo := Byte(Str[I]); { Copy string char } - Inc(J); { Next position } - End Else Begin - B := Hi(Attrs); { Hold attribute } - WordRec(Attrs).Hi := Lo(Attrs); { Copy low to high } - WordRec(Attrs).Lo := B; { Complete exchange } - End; - End; -END; - -{---------------------------------------------------------------------------} -{ MoveBuf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; Count: Sw_Word); -VAR I: Word; P: PWord; -BEGIN - For I := 1 To Count Do Begin - P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word } - If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute } - WordRec(P^).Lo := TByteArray(Source)[I-1]; { Copy source data } - End; -END; - -{---------------------------------------------------------------------------} -{ MoveChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE MoveChar (Var Dest; C: Char; Attr: Byte; Count: Sw_Word); -VAR I: Word; P: PWord; -BEGIN - For I := 1 To Count Do Begin - P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word } - If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute } - If (Ord(C) <> 0) Then WordRec(P^).Lo := Byte(C); { Copy character } - End; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ KEYBOARD SUPPORT ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ GetAltCode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } -{---------------------------------------------------------------------------} -FUNCTION GetAltCode (Ch: Char): Word; -BEGIN - GetAltCode := 0; { Preset zero return } - Ch := UpCase(Ch); { Convert upper case } - If (Ch < #128) Then - GetAltCode := AltCodes[Ord(Ch)] SHL 8 { Return code } - Else If (Ch = #240) Then GetAltCode := $0200 { Return code } - Else GetAltCode := 0; { Return zero } -END; - -{---------------------------------------------------------------------------} -{ GetCtrlCode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } -{---------------------------------------------------------------------------} -FUNCTION GetCtrlCode (Ch: Char): Word; -BEGIN - GetCtrlCode := GetAltCode(Ch) OR (Ord(Ch) - $40); { Ctrl+key code } -END; - -{---------------------------------------------------------------------------} -{ GetAltChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } -{---------------------------------------------------------------------------} -FUNCTION GetAltChar (KeyCode: Word): Char; -VAR I: Sw_Integer; -BEGIN - GetAltChar := #0; { Preset fail return } - If (Lo(KeyCode) = 0) Then Begin { Extended key } - If (Hi(KeyCode) <= $83) Then Begin { Highest value in list } - I := 0; { Start at first } - While (I < 128) AND (Hi(KeyCode) <> AltCodes[I]) - Do Inc(I); { Search for match } - If (I < 128) Then GetAltChar := Chr(I); { Return character } - End Else - If (Hi(KeyCode)=$02) Then GetAltChar := #240; { Return char } - End; -END; - -{---------------------------------------------------------------------------} -{ GetCtrlChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } -{---------------------------------------------------------------------------} -FUNCTION GetCtrlChar (KeyCode: Word): Char; -VAR C: Char; -BEGIN - C := #0; { Preset #0 return } - If (Lo(KeyCode) > 0) AND (Lo(KeyCode) <= 26) Then { Between 1-26 } - C := Chr(Lo(KeyCode) + $40); { Return char A-Z } - GetCtrlChar := C; { Return result } -END; - -{---------------------------------------------------------------------------} -{ CtrlToArrow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } -{---------------------------------------------------------------------------} -FUNCTION CtrlToArrow (KeyCode: Word): Word; -CONST NumCodes = 11; - CtrlCodes : Array [0..NumCodes-1] Of Char = - (#19, #4, #5, #24, #1, #6, #7, #22, #18, #3, #8); - ArrowCodes: Array [0..NumCodes-1] Of Sw_Word = - (kbLeft, kbRight, kbUp, kbDown, kbHome, kbEnd, kbDel, kbIns, - kbPgUp, kbPgDn, kbBack); -VAR I: Sw_Integer; -BEGIN - CtrlToArrow := KeyCode; { Preset key return } - For I := 0 To NumCodes - 1 Do - If WordRec(KeyCode).Lo = Byte(CtrlCodes[I]) { Matches a code } - Then Begin - CtrlToArrow := ArrowCodes[I]; { Return key stroke } - Exit; { Now exit } - End; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ KEYBOARD CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ GetShiftState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul96 LdB } -{---------------------------------------------------------------------------} -FUNCTION GetShiftState: Byte; -begin - GetShiftState:=Keyboard.GetKeyEventShiftState(Keyboard.PollShiftStateEvent); -end; - -{---------------------------------------------------------------------------} -{ GetKeyEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } -{---------------------------------------------------------------------------} -procedure GetKeyEvent (Var Event: TEvent); -var - key : TKeyEvent; - keycode : Word; - keyshift : byte; -begin - if Keyboard.PollKeyEvent<>0 then - begin - key:=Keyboard.GetKeyEvent; - keycode:=Keyboard.GetKeyEventCode(key); - keyshift:=KeyBoard.GetKeyEventShiftState(key); - // some kbds still honour old XT E0 prefix. (org IBM ps/2, win98?) bug #8978 - if (keycode and $FF = $E0) and - (byte(keycode shr 8) in - [$1C,$1D,$2A,$35..$38,$46..$49,$4b,$4d,$4f,$50..$53]) Then - keycode := keycode and $FF00; - - { fixup shift-keys } - if keyshift and kbShift<>0 then - begin - case keycode of - $5200 : keycode:=kbShiftIns; - $5300 : keycode:=kbShiftDel; - $8500 : keycode:=kbShiftF1; - $8600 : keycode:=kbShiftF2; - end; - end - { fixup ctrl-keys } - else if keyshift and kbCtrl<>0 then - begin - case keycode of - $5200, - $9200 : keycode:=kbCtrlIns; - $5300, - $9300 : keycode:=kbCtrlDel; - end; - end - { fixup alt-keys } - else if keyshift and kbAlt<>0 then - begin - case keycode of - $0e08, - $0e00 : keycode:=kbAltBack; - end; - end - { fixup normal keys } - else - begin - case keycode of - $e00d : keycode:=kbEnter; - end; - end; - Event.What:=evKeyDown; - Event.KeyCode:=keycode; -{$ifdef ENDIAN_LITTLE} - Event.CharCode:=chr(keycode and $ff); - Event.ScanCode:=keycode shr 8; -{$endif ENDIAN_LITTLE} - Event.KeyShift:=keyshift; - end - else - Event.What:=evNothing; -end; - - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ MOUSE CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ HideMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun98 LdB } -{---------------------------------------------------------------------------} -procedure HideMouse; -begin -{ Is mouse hidden yet? - If (HideCount = 0) Then} - Mouse.HideMouse; -{ Inc(HideCount);} -end; - -{---------------------------------------------------------------------------} -{ ShowMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun98 LdB } -{---------------------------------------------------------------------------} -procedure ShowMouse; -begin -{ if HideCount>0 then - dec(HideCount); - if (HideCount=0) then} - Mouse.ShowMouse; -end; - -{---------------------------------------------------------------------------} -{ GetMouseEvent -> Platforms DOS/DPMI/WINDOWS/OS2 - Updated 30Jun98 LdB } -{---------------------------------------------------------------------------} -procedure GetMouseEvent (Var Event: TEvent); -var - e : Mouse.TMouseEvent; -begin - if Mouse.PollMouseEvent(e) then - begin - Mouse.GetMouseEvent(e); - MouseWhere.X:=e.x; - MouseWhere.Y:=e.y; - Event.Double:=false; - case e.Action of - MouseActionMove : - Event.What:=evMouseMove; - MouseActionDown : - begin - Event.What:=evMouseDown; - if (DownButtons=e.Buttons) and (LastWhere.X=MouseWhere.X) and (LastWhere.Y=MouseWhere.Y) and - (GetDosTicks-DownTicks<=DoubleDelay) then - Event.Double:=true; - DownButtons:=e.Buttons; - DownWhere.X:=MouseWhere.x; - DownWhere.Y:=MouseWhere.y; - DownTicks:=GetDosTicks; - AutoTicks:=GetDosTicks; - if AutoTicks=0 then - AutoTicks:=1; - AutoDelay:=RepeatDelay; - end; - MouseActionUp : - begin - AutoTicks:=0; - Event.What:=evMouseUp; - AutoTicks:=0; - end; - end; - Event.Buttons:=e.Buttons; - Event.Where.X:=MouseWhere.x; - Event.Where.Y:=MouseWhere.y; - LastButtons:=Event.Buttons; - LastWhere.x:=Event.Where.x; - LastWhere.y:=Event.Where.y; - end - else if (AutoTicks <> 0) and (GetDosTicks >= AutoTicks + AutoDelay) then - begin - Event.What:=evMouseAuto; - Event.Buttons:=LastButtons; - Event.Where.X:=LastWhere.x; - Event.Where.Y:=LastWhere.y; - AutoTicks:=GetDosTicks; - AutoDelay:=1; - end - else - FillChar(Event,sizeof(TEvent),0); - if MouseReverse and ((Event.Buttons and 3) in [1,2]) then - Event.Buttons := Event.Buttons xor 3; -end; - -{---------------------------------------------------------------------------} -{ GetSystemEvent } -{---------------------------------------------------------------------------} -procedure GetSystemEvent (Var Event: TEvent); -var - SysEvent : TsystemEvent; -begin - if PollSystemEvent(SysEvent) then - begin - SysMsg.GetSystemEvent(SysEvent); - case SysEvent.typ of - SysNothing : - Event.What:=evNothing; - SysSetFocus : - begin - Event.What:=evBroadcast; - Event.Command:=cmReceivedFocus; - end; - SysReleaseFocus : - begin - Event.What:=evBroadcast; - Event.Command:=cmReleasedFocus; - end; - SysClose : - begin - Event.What:=evCommand; - Event.Command:=cmQuitApp; - end; - SysResize : - begin - Event.What:=evCommand; - Event.Command:=cmResizeApp; - Event.Id:=SysEvent.x; - Event.InfoWord:=SysEvent.y; - end; - else - Event.What:=evNothing; - end; - end - else - Event.What:=evNothing; -end; - - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ EVENT HANDLER CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ InitEvents -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 07Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE InitEvents; -BEGIN - If (ButtonCount <> 0) Then - begin { Mouse is available } - Mouse.InitMouse; { Hook the mouse } - { this is required by the use of HideCount variable } - Mouse.ShowMouse; { visible by default } - { HideCount:=0; } - LastButtons := 0; { Clear last buttons } - DownButtons := 0; { Clear down buttons } - MouseWhere.X:=Mouse.GetMouseX; - MouseWhere.Y:=Mouse.GetMouseY; { Get mouse position } - LastWhere.x:=MouseWhere.x; - LastWhereX:=MouseWhere.x; - LastWhere.y:=MouseWhere.y; - LastWhereY:=MouseWhere.y; - MouseEvents := True; { Set initialized flag } - end; - InitSystemMsg; -END; - -{---------------------------------------------------------------------------} -{ DoneEvents -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE DoneEvents; -BEGIN - DoneSystemMsg; - Mouse.DoneMouse; - MouseEvents:=false; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ VIDEO CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -const - VideoInitialized : boolean = false; - -{---------------------------------------------------------------------------} -{ InitKeyboard -> Platforms ALL - 07May06 DM } -{---------------------------------------------------------------------------} - -procedure initkeyboard;inline; - -begin - keyboard.initkeyboard; -end; - -{---------------------------------------------------------------------------} -{ DoneKeyboard -> Platforms ALL - 07May06 DM } -{---------------------------------------------------------------------------} - -procedure donekeyboard;inline; - -begin - keyboard.donekeyboard; -end; - -{---------------------------------------------------------------------------} -{ InitVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Nov99 LdB } -{---------------------------------------------------------------------------} -function InitVideo:boolean; - -var StoreScreenMode : TVideoMode; - -begin - initvideo:=false; - if VideoInitialized then - begin - StoreScreenMode:=ScreenMode; - DoneVideo; - end - else - StoreScreenMode.Col:=0; - - Video.InitVideo; - if video.errorcode<>viook then - exit; - GetVideoMode(StartupScreenMode); - GetVideoMode(ScreenMode); -{$ifdef OS_WINDOWS} - { Force the console to the current screen mode } - Video.SetVideoMode(ScreenMode); -{$endif OS_WINDOWS} - - If (StoreScreenMode.Col<>0) and - ((StoreScreenMode.color<>ScreenMode.color) or - (StoreScreenMode.row<>ScreenMode.row) or - (StoreScreenMode.col<>ScreenMode.col)) then - begin - Video.SetVideoMode(StoreScreenMode); - GetVideoMode(ScreenMode); - end; - - if ScreenWidth > MaxViewWidth then - ScreenWidth := MaxViewWidth; - ScreenWidth:=Video.ScreenWidth; - ScreenHeight:=Video.ScreenHeight; - VideoInitialized:=true; - initvideo:=true; -end; - -{---------------------------------------------------------------------------} -{ DoneVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE DoneVideo; -BEGIN - if not VideoInitialized then - exit; - Video.SetVideoMode(StartupScreenMode); - Video.ClearScreen; - Video.SetCursorPos(0,0); - Video.DoneVideo; - VideoInitialized:=false; -END; - -{---------------------------------------------------------------------------} -{ ClearScreen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Jan97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE ClearScreen; -BEGIN - Video.ClearScreen; -END; - -{---------------------------------------------------------------------------} -{ SetVideoMode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Nov99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE SetVideoMode (Mode: Sw_Word); -BEGIN -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ ERROR CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ InitSysError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE InitSysError; -BEGIN - SysErrActive := True; { Set active flag } -END; - -{---------------------------------------------------------------------------} -{ DoneSysError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE DoneSysError; -BEGIN - SysErrActive := False; { Clear active flag } -END; - -{---------------------------------------------------------------------------} -{ SystemError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION SystemError (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer; -BEGIN - If (FailSysErrors = False) Then Begin { Check error ignore } - - End Else SystemError := 1; { Return 1 for ignored } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ STRING FORMAT ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ PrintStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Feb99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE PrintStr (CONST S: String); -BEGIN - Write(S); { Write to screen } -END; - -{---------------------------------------------------------------------------} -{ FormatStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 13Jul99 LdB } -{---------------------------------------------------------------------------} -procedure FormatStr (Var Result: String; CONST Format: String; Var Params); -TYPE TLongArray = Array[0..0] Of PtrInt; -VAR W, ResultLength : integer; - FormatIndex, Justify, Wth: Byte; - Fill: Char; S: String; - - FUNCTION LongToStr (L: Longint; Radix: Byte): String; - CONST HexChars: Array[0..15] Of Char = - ('0', '1', '2', '3', '4', '5', '6', '7', - '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'); - VAR I: LongInt; S: String; Sign: String[1]; - begin - LongToStr := ''; { Preset empty return } - If (L < 0) Then begin { If L is negative } - Sign := '-'; { Sign is negative } - L := Abs(L); { Convert to positive } - end Else Sign := ''; { Sign is empty } - S := ''; { Preset empty string } - Repeat - I := L MOD Radix; { Radix mod of value } - S := HexChars[I] + S; { Add char to string } - L := L DIV Radix; { Divid by radix } - Until (L = 0); { Until no remainder } - LongToStr := Sign + S; { Return result } - end; - - procedure HandleParameter (I : LongInt); - begin - While (FormatIndex <= Length(Format)) Do begin { While length valid } - if ResultLength>=High(Result) then - exit; - While (FormatIndex <= Length(Format)) and - (Format[FormatIndex] <> '%') { Param char not found } - Do begin - Result[ResultLength+1] := Format[FormatIndex]; { Transfer character } - Inc(ResultLength); { One character added } - Inc(FormatIndex); { Next param char } - end; - If (FormatIndex < Length(Format)) and { Not last char and } - (Format[FormatIndex] = '%') Then begin { '%' char found } - Fill := ' '; { Default fill char } - Justify := 0; { Default justify } - Wth := 0; { Default 0=no width } - Inc(FormatIndex); { Next character } - If (Format[FormatIndex] = '0') Then - Fill := '0'; { Fill char to zero } - If (Format[FormatIndex] = '-') Then begin { Optional just char } - Justify := 1; { Right justify } - Inc(FormatIndex); { Next character } - end; - While ((FormatIndex <= Length(Format)) and { Length still valid } - (Format[FormatIndex] >= '0') and - (Format[FormatIndex] <= '9')) Do begin { Numeric character } - Wth := Wth * 10; { Multiply x10 } - Wth := Wth + Ord(Format[FormatIndex])-$30; { Add numeric value } - Inc(FormatIndex); { Next character } - end; - If ((FormatIndex <= Length(Format)) and { Length still valid } - (Format[FormatIndex] = '#')) Then begin { Parameter marker } - Inc(FormatIndex); { Next character } - HandleParameter(Wth); { Width is param idx } - end; - If (FormatIndex <= Length(Format)) Then begin{ Length still valid } - Case Format[FormatIndex] Of - '%': begin { Literal % } - S := '%'; - Inc(FormatIndex); - Move(S[1], Result[ResultLength+1], 1); - Inc(ResultLength,Length(S)); - Continue; - end; - 'c': S := Char(TLongArray(Params)[I]); { Character parameter } - 'd': S := LongToStr(TLongArray(Params)[I], - 10); { Decimal parameter } - 's': S := PString(TLongArray(Params)[I])^;{ String parameter } - 'x': S := LongToStr(TLongArray(Params)[I], - 16); { Hex parameter } - end; - Inc(FormatIndex); { Next character } - If (Wth > 0) Then begin { Width control active } - If (Length(S) > Wth) Then begin { We must shorten S } - If (Justify=1) Then { Check right justify } - S := Copy(S, Length(S)-Wth+1, Wth) { Take right side data } - Else S := Copy(S, 1, Wth); { Take left side data } - end Else begin { We must pad out S } - If (Justify=1) Then { Right justify } - While (Length(S) < Wth) Do - S := S+Fill Else { Right justify fill } - While (Length(S) < Wth) Do - S := Fill + S; { Left justify fill } - end; - end; - W:=Length(S); - if W+ResultLength+1>High(Result) then - W:=High(Result)-ResultLength; - Move(S[1], Result[ResultLength+1], - W); { Move data to result } - Inc(ResultLength,W); { Adj result length } - Inc(I); - end; - end; - end; - end; - -begin - ResultLength := 0; { Zero result length } - FormatIndex := 1; { Format index to 1 } - HandleParameter(0); { Handle parameter } - Result[0] := Chr(ResultLength); { Set string length } -end; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ NEW QUEUED EVENT HANDLER ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ PutEventInQueue -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Mar98 LdB } -{---------------------------------------------------------------------------} -FUNCTION PutEventInQueue (Var Event: TEvent): Boolean; -BEGIN - If (QueueCount < QueueMax) Then Begin { Check room in queue } - Queue[QueueHead] := Event; { Store event } - Inc(QueueHead); { Inc head position } - If (QueueHead = QueueMax) Then QueueHead := 0; { Roll to start check } - Inc(QueueCount); { Inc queue count } - PutEventInQueue := True; { Return successful } - End Else PutEventInQueue := False; { Return failure } -END; - -{---------------------------------------------------------------------------} -{ NextQueuedEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Mar98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE NextQueuedEvent(Var Event: TEvent); -BEGIN - If (QueueCount > 0) Then Begin { Check queued event } - Event := Queue[QueueTail]; { Fetch next event } - Inc(QueueTail); { Inc tail position } - If (QueueTail = QueueMax) Then QueueTail := 0; { Roll to start check } - Dec(QueueCount); { Dec queue count } - End Else Event.What := evNothing; { Return empty event } -END; - -{***************************************************************************} -{ UNIT INITIALIZATION ROUTINE } -{***************************************************************************} -BEGIN -{$IFDEF OS_AMIGA} - StartupTicks := (dos.GetMsCount div 55); -{$ENDIF} - ButtonCount := DetectMouse; { Detect mouse } - DetectVideo; { Detect video } -{ InitKeyboard;} - InitSystemMsg; -{$ifdef OS_WINDOWS} - SetFileApisToOEM; -{$endif} - - SaveExit := ExitProc; { Save old exit } - ExitProc := @ExitDrivers; { Set new exit } -END. +{$I drivers.inc} diff --git a/packages/fv/src/editors.pas b/packages/fv/src/editors.pas index 8f428bd96b..23e9bbed70 100644 --- a/packages/fv/src/editors.pas +++ b/packages/fv/src/editors.pas @@ -84,7 +84,7 @@ const CMemo = #26#27; type - TEditorDialog = function (Dialog : Integer; Info : Pointer) : Word; + TEditorDialog = function (Dialog : SmallInt; Info : Pointer) : Word; PIndicator = ^TIndicator; TIndicator = object (TView) @@ -156,7 +156,7 @@ type BlankLine : Sw_Word; { First blank line after a paragraph. } Word_Wrap : Boolean; { Added boolean to toggle wordwrap on/off. } Line_Number : string[8]; { Holds line number to jump to. } - Right_Margin : Sw_Integer; { Added integer to set right margin. } + Right_Margin : Sw_Integer; { Added SmallInt to set right margin. } Tab_Settings : String[Tab_Stop_Length]; { Added string to hold tab stops. } constructor Init (var Bounds : TRect; AHScrollBar, AVScrollBar : PScrollBar; @@ -192,7 +192,7 @@ type function Valid (Command : Word) : Boolean; virtual; private - KeyState : Integer; + KeyState : SmallInt; LockCount : Byte; UpdateFlags : Byte; Place_Marker : Array [1..10] of Sw_Word; { Inserted array to hold place markers. } @@ -287,7 +287,7 @@ type PEditWindow = ^TEditWindow; TEditWindow = object (TWindow) Editor : PFileEditor; - constructor Init (var Bounds : TRect; FileName : FNameStr; ANumber : Integer); + constructor Init (var Bounds : TRect; FileName : FNameStr; ANumber : SmallInt); constructor Load (var S : Objects.TStream); procedure Close; virtual; function GetTitle (MaxSize : Sw_Integer) : TTitleStr; virtual; @@ -297,14 +297,14 @@ type end; -function DefEditorDialog (Dialog : Integer; Info : Pointer) : Word; +function DefEditorDialog (Dialog : SmallInt; Info : Pointer) : Word; function CreateFindDialog: PDialog; function CreateReplaceDialog: PDialog; function JumpLineDialog : PDialog; function ReformDocDialog : PDialog; function RightMarginDialog : PDialog; function TabStopDialog : Dialogs.PDialog; -function StdEditorDialog(Dialog: Integer; Info: Pointer): Word; +function StdEditorDialog(Dialog: SmallInt; Info: Pointer): Word; const WordChars : set of Char = ['!'..#255]; @@ -605,7 +605,7 @@ CONST Dialogs ****************************************************************************} -function DefEditorDialog (Dialog : Integer; Info : Pointer) : Word; +function DefEditorDialog (Dialog : SmallInt; Info : Pointer) : Word; begin DefEditorDialog := cmCancel; end; { DefEditorDialog } @@ -893,7 +893,7 @@ Begin end { TabStopDialog }; -function StdEditorDialog(Dialog: Integer; Info: Pointer): Word; +function StdEditorDialog(Dialog: SmallInt; Info: Pointer): Word; var R: TRect; T: TPoint; @@ -2338,7 +2338,7 @@ procedure TEditor.Jump_To_Line (Select_Mode : Byte); { This function brings up a dialog box that allows } { the user to select a line number to jump to. } VAR - Code : Integer; { Used for Val conversion. } + Code : SmallInt; { Used for Val conversion. } Temp_Value : Longint; { Holds converted dialog value. } begin if EditorDialog (edJumpToLine, @Line_Number) <> cmCancel then @@ -3055,7 +3055,7 @@ procedure TEditor.Set_Right_Margin; { that allows the user to set Right_Margin. } { Values must be < MaxLineLength and > 9. } VAR - Code : Integer; { Used for Val conversion. } + Code : SmallInt; { Used for Val conversion. } Margin_Data : TRightMarginRec; { Holds dialog results. } Temp_Value : Sw_Integer; { Holds converted dialog value. } begin @@ -3344,7 +3344,7 @@ begin Place_marker[Element] := 0 else begin - if integer (Place_Marker[Element]) - integer (KillCount) > 0 then + if SmallInt (Place_Marker[Element]) - SmallInt (KillCount) > 0 then Place_Marker[Element] := Place_Marker[Element] - KillCount else Place_Marker[Element] := 0; @@ -3356,7 +3356,7 @@ begin BlankLine := BlankLine + AddCount else begin - if integer (BlankLine) - Integer (KillCount) > 0 then + if SmallInt (BlankLine) - SmallInt (KillCount) > 0 then BlankLine := BlankLine - KillCount else BlankLine := 0; @@ -3659,7 +3659,7 @@ end; { TFileEditor.UpdateCommands } function TFileEditor.Valid (Command : Word) : Boolean; VAR - D : Integer; + D : SmallInt; begin if Command = cmValid then Valid := IsValid @@ -3688,7 +3688,7 @@ end; { TFileEditor.Valid } constructor TEditWindow.Init (var Bounds : TRect; FileName : Objects.FNameStr; - ANumber : Integer); + ANumber : SmallInt); var HScrollBar : PScrollBar; VScrollBar : PScrollBar; diff --git a/packages/fv/src/fvcommon.inc b/packages/fv/src/fvcommon.inc new file mode 100644 index 0000000000..e0214fc021 --- /dev/null +++ b/packages/fv/src/fvcommon.inc @@ -0,0 +1,396 @@ +{********************[ COMMON UNIT ]***********************} +{ } +{ System independent COMMON TYPES & DEFINITIONS } +{ } +{ Parts Copyright (c) 1997 by Balazs Scheidler } +{ bazsi@balabit.hu } +{ } +{ Parts Copyright (c) 1999, 2000 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@projectent.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ - Speed Pascal 1.0+ (32 Bit) } +{ - C'T patch to BP (16 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Who Fix } +{ ------- -------- --- ---------------------------- } +{ 0.1 12 Jul 97 Bazsi Initial implementation } +{ 0.2 18 Jul 97 Bazsi Linux specific error codes } +{ 0.2.2 28 Jul 97 Bazsi Base error code for Video } +{ 0.2.3 29 Jul 97 Bazsi Basic types added (PByte etc) } +{ 0.2.5 08 Aug 97 Bazsi Error handling code added } +{ 0.2.6 06 Sep 97 Bazsi Base code for keyboard } +{ 0.2.7 06 Nov 97 Bazsi Base error code for filectrl } +{ 0.2.8 21 Jan 99 LdB Max data sizes added. } +{ 0.2.9 22 Jan 99 LdB General array types added. } +{ 0.3.0 27 Oct 99 LdB Delphi3+ MaxAvail, MemAvail } +{ 0.4.0 14 Nov 00 LdB Revamp of whole unit } +{**********************************************************} + +{$ifdef FV_UNICODE} +UNIT UFVCommon; +{$else FV_UNICODE} +UNIT FVCommon; +{$endif FV_UNICODE} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I platform.inc} +{====================================================================} + +{$ifdef OS_WINDOWS} + uses + Windows; +{$endif} + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ SYSTEM ERROR BASE CONSTANTS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ The following ranges have been defined for error codes: } +{---------------------------------------------------------------------------} +{ 0 - 1000 OS dependant error codes } +{ 1000 - 10000 API reserved error codes } +{ 10000 - Add-On unit error codes } +{---------------------------------------------------------------------------} + +{---------------------------------------------------------------------------} +{ DEFINED BASE ERROR CONSTANTS } +{---------------------------------------------------------------------------} +CONST + errOk = 0; { No error } + errVioBase = 1000; { Video base offset } + errKbdBase = 1010; { Keyboard base offset } + errFileCtrlBase = 1020; { File IO base offset } + errMouseBase = 1030; { Mouse base offset } + +{---------------------------------------------------------------------------} +{ MAXIUM DATA SIZES } +{---------------------------------------------------------------------------} +CONST +{$IFDEF BIT_16} { 16 BIT DEFINITION } + MaxBytes = 65520; { Maximum data size } +{$ENDIF} +{$IFDEF BIT_32_OR_MORE} { 32 BIT DEFINITION } + MaxBytes = 128*1024*1024; { Maximum data size } +{$ENDIF} + MaxWords = MaxBytes DIV SizeOf(Word); { Max words } + MaxInts = MaxBytes DIV SizeOf(SmallInt); { Max integers } + MaxLongs = MaxBytes DIV SizeOf(LongInt); { Max longints } + MaxPtrs = MaxBytes DIV SizeOf(Pointer); { Max pointers } + MaxReals = MaxBytes DIV SizeOf(Real); { Max reals } + MaxStr = MaxBytes DIV SizeOf(String); { Max strings } + +{***************************************************************************} +{ PUBLIC TYPE DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ CPU TYPE DEFINITIONS } +{---------------------------------------------------------------------------} +TYPE +{$IFDEF BIT_32_OR_MORE} { 32 BIT CODE } + CPUWord = Longint; { CPUWord is 32 bit } + CPUInt = Longint; { CPUInt is 32 bit } +{$ELSE} { 16 BIT CODE } + CPUWord = Word; { CPUWord is 16 bit } + CPUInt = SmallInt; { CPUInt is 16 bit } +{$ENDIF} + +{---------------------------------------------------------------------------} +{ 16/32 BIT SWITCHED TYPE CONSTANTS } +{---------------------------------------------------------------------------} +TYPE +{$IFDEF BIT_16} { 16 BIT DEFINITIONS } + Sw_Word = Word; { Standard word } + Sw_Integer = SmallInt; { Standard SmallInt } +{$ENDIF} +{$IFDEF BIT_32_OR_MORE} { 32 BIT DEFINITIONS } + Sw_Word = Cardinal; { Long integer now } + Sw_Integer = LongInt; { Long integer now } +{$ENDIF} + +{---------------------------------------------------------------------------} +{ SHORT/ANSI/UNICODE SWITCHED STRING TYPE } +{---------------------------------------------------------------------------} +{$IFDEF FV_UNICODE} +TYPE + Sw_String = UnicodeString; + Sw_Char = WideChar; + Sw_PString = UnicodeString; + Sw_ExtendedGraphemeCluster = UnicodeString; +CONST + Sw_PString_Empty = ''; +{$ELSE FV_UNICODE} +TYPE + Sw_String = ShortString; + Sw_Char = Char; + Sw_PString = PShortString; + Sw_ExtendedGraphemeCluster = Char; +CONST + Sw_PString_Empty = Nil; +{$ENDIF FV_UNICODE} + +{---------------------------------------------------------------------------} +{ GENERAL ARRAYS } +{---------------------------------------------------------------------------} +TYPE + TByteArray = ARRAY [0..MaxBytes-1] Of Byte; { Byte array } + PByteArray = ^TByteArray; { Byte array pointer } + + TWordArray = ARRAY [0..MaxWords-1] Of Word; { Word array } + PWordArray = ^TWordArray; { Word array pointer } + + TIntegerArray = ARRAY [0..MaxInts-1] Of SmallInt; { SmallInt array } + PIntegerArray = ^TIntegerArray; { SmallInt array pointer } + + TLongIntArray = ARRAY [0..MaxLongs-1] Of LongInt; { LongInt array } + PLongIntArray = ^TLongIntArray; { LongInt array pointer } + + TRealArray = Array [0..MaxReals-1] Of Real; { Real array } + PRealarray = ^TRealArray; { Real array pointer } + + TPointerArray = Array [0..MaxPtrs-1] Of Pointer; { Pointer array } + PPointerArray = ^TPointerArray; { Pointer array ptr } + + TStrArray = Array [0..MaxStr-1] Of String; { String array } + PStrArray = ^TStrArray; { String array ptr } + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{-GetErrorCode------------------------------------------------------- +Returns the last error code and resets ErrorCode to errOk. +07/12/97 Bazsi +---------------------------------------------------------------------} +FUNCTION GetErrorCode: LongInt; + +{-GetErrorInfo------------------------------------------------------- +Returns the info assigned to the previous error, doesn't reset the +value to nil. Would usually only be called if ErrorCode <> errOk. +07/12/97 Bazsi +---------------------------------------------------------------------} +FUNCTION GetErrorInfo: Pointer; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MINIMUM AND MAXIMUM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +FUNCTION Min (I, J: Sw_Integer): Sw_Integer; +FUNCTION Max (I, J: Sw_Integer): Sw_Integer; + +{-MinimumOf---------------------------------------------------------- +Given two real numbers returns the minimum real of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MinimumOf (A, B: Real): Real; + +{-MaximumOf---------------------------------------------------------- +Given two real numbers returns the maximum real of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MaximumOf (A, B: Real): Real; + +{-MinIntegerOf------------------------------------------------------- +Given two SmallInt values returns the lowest SmallInt of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MinIntegerOf (A, B: SmallInt): SmallInt; + +{-MaxIntegerof------------------------------------------------------- +Given two SmallInt values returns the biggest SmallInt of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MaxIntegerOf (A, B: SmallInt): SmallInt; + +{-MinLongIntOf------------------------------------------------------- +Given two long integers returns the minimum longint of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MinLongIntOf (A, B: LongInt): LongInt; + +{-MaxLongIntOf------------------------------------------------------- +Given two long integers returns the maximum longint of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MaxLongIntOf (A, B: LongInt): LongInt; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MISSING DELPHI3 ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{ ******************************* REMARK ****************************** } +{ Delphi 3+ does not define these standard routines so I have made } +{ some public functions here to complete compatability. } +{ ****************************** END REMARK *** Leon de Boer, 14Aug98 * } + +{-MemAvail----------------------------------------------------------- +Returns the free memory available under Delphi 3+. +14Aug98 LdB +---------------------------------------------------------------------} +FUNCTION MemAvail: LongInt; + +{-MaxAvail----------------------------------------------------------- +Returns the max free memory block size available under Delphi 3+. +14Aug98 LdB +---------------------------------------------------------------------} +FUNCTION MaxAvail: LongInt; + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +CONST + ErrorCode: Longint = errOk; { Last error code } + ErrorInfo: Pointer = Nil; { Last error info } + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{$IFDEF PPC_DELPHI3} { DELPHI 3+ COMPILER } +USES WinTypes, WinProcs; { Stardard units } +{$ENDIF} + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ GetErrorCode -> Platforms ALL - Updated 12Jul97 Bazsi } +{---------------------------------------------------------------------------} +FUNCTION GetErrorCode: LongInt; +BEGIN + GetErrorCode := ErrorCode; { Return last error } + ErrorCode := 0; { Now clear errorcode } +END; + +{---------------------------------------------------------------------------} +{ GetErrorInfo -> Platforms ALL - Updated 12Jul97 Bazsi } +{---------------------------------------------------------------------------} +FUNCTION GetErrorInfo: Pointer; +BEGIN + GetErrorInfo := ErrorInfo; { Return errorinfo ptr } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MINIMUM AND MAXIMUM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +FUNCTION Min (I, J: Sw_Integer): Sw_Integer; +BEGIN + If (I < J) Then Min := I Else Min := J; { Select minimum } +END; + +FUNCTION Max (I, J: Sw_Integer): Sw_Integer; +BEGIN + If (I > J) Then Max := I Else Max := J; { Select maximum } +END; + + +{---------------------------------------------------------------------------} +{ MinimumOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MinimumOf (A, B: Real): Real; +BEGIN + If (B < A) Then MinimumOf := B { B smaller take it } + Else MinimumOf := A; { Else take A } +END; + +{---------------------------------------------------------------------------} +{ MaximumOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MaximumOf (A, B: Real): Real; +BEGIN + If (B > A) Then MaximumOf := B { B bigger take it } + Else MaximumOf := A; { Else take A } +END; + +{---------------------------------------------------------------------------} +{ MinIntegerOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MinIntegerOf (A, B: SmallInt): SmallInt; +BEGIN + If (B < A) Then MinIntegerOf := B { B smaller take it } + Else MinIntegerOf := A; { Else take A } +END; + +{---------------------------------------------------------------------------} +{ MaxIntegerOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MaxIntegerOf (A, B: SmallInt): SmallInt; +BEGIN + If (B > A) Then MaxIntegerOf := B { B bigger take it } + Else MaxIntegerOf := A; { Else take A } +END; + +{---------------------------------------------------------------------------} +{ MinLongIntOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MinLongIntOf (A, B: LongInt): LongInt; +BEGIN + If (B < A) Then MinLongIntOf := B { B smaller take it } + Else MinLongIntOf := A; { Else take A } +END; + +{---------------------------------------------------------------------------} +{ MaxLongIntOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MaxLongIntOf (A, B: LongInt): LongInt; +BEGIN + If (B > A) Then MaxLongIntOf := B { B bigger take it } + Else MaxLongIntOf := A; { Else take A } +END; + +FUNCTION MemAvail: LongInt; +BEGIN + { Unlimited } + MemAvail:=high(longint); +END; + +{---------------------------------------------------------------------------} +{ MaxAvail -> Platforms WIN/NT - Updated 14Aug98 LdB } +{---------------------------------------------------------------------------} +FUNCTION MaxAvail: LongInt; +BEGIN + { Unlimited } + MaxAvail:=high(longint); +END; + +END. diff --git a/packages/fv/src/fvcommon.pas b/packages/fv/src/fvcommon.pas index 92cad75ee6..e146f9c0cb 100644 --- a/packages/fv/src/fvcommon.pas +++ b/packages/fv/src/fvcommon.pas @@ -1,371 +1 @@ -{********************[ COMMON UNIT ]***********************} -{ } -{ System independent COMMON TYPES & DEFINITIONS } -{ } -{ Parts Copyright (c) 1997 by Balazs Scheidler } -{ bazsi@balabit.hu } -{ } -{ Parts Copyright (c) 1999, 2000 by Leon de Boer } -{ ldeboer@attglobal.net - primary e-mail address } -{ ldeboer@projectent.com.au - backup e-mail address } -{ } -{****************[ THIS CODE IS FREEWARE ]*****************} -{ } -{ This sourcecode is released for the purpose to } -{ promote the pascal language on all platforms. You may } -{ redistribute it and/or modify with the following } -{ DISCLAIMER. } -{ } -{ This SOURCE CODE is distributed "AS IS" WITHOUT } -{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } -{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } -{ } -{*****************[ SUPPORTED PLATFORMS ]******************} -{ 16 and 32 Bit compilers } -{ DOS - Turbo Pascal 7.0 + (16 Bit) } -{ DPMI - Turbo Pascal 7.0 + (16 Bit) } -{ - FPC 0.9912+ (GO32V2) (32 Bit) } -{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } -{ - Delphi 1.0+ (16 Bit) } -{ WIN95/NT - Delphi 2.0+ (32 Bit) } -{ - Virtual Pascal 2.0+ (32 Bit) } -{ - Speedsoft Sybil 2.0+ (32 Bit) } -{ - FPC 0.9912+ (32 Bit) } -{ OS2 - Virtual Pascal 1.0+ (32 Bit) } -{ - Speed Pascal 1.0+ (32 Bit) } -{ - C'T patch to BP (16 Bit) } -{ } -{******************[ REVISION HISTORY ]********************} -{ Version Date Who Fix } -{ ------- -------- --- ---------------------------- } -{ 0.1 12 Jul 97 Bazsi Initial implementation } -{ 0.2 18 Jul 97 Bazsi Linux specific error codes } -{ 0.2.2 28 Jul 97 Bazsi Base error code for Video } -{ 0.2.3 29 Jul 97 Bazsi Basic types added (PByte etc) } -{ 0.2.5 08 Aug 97 Bazsi Error handling code added } -{ 0.2.6 06 Sep 97 Bazsi Base code for keyboard } -{ 0.2.7 06 Nov 97 Bazsi Base error code for filectrl } -{ 0.2.8 21 Jan 99 LdB Max data sizes added. } -{ 0.2.9 22 Jan 99 LdB General array types added. } -{ 0.3.0 27 Oct 99 LdB Delphi3+ MaxAvail, MemAvail } -{ 0.4.0 14 Nov 00 LdB Revamp of whole unit } -{**********************************************************} - -UNIT FVCommon; - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - INTERFACE -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{====Include file to sort compiler platform out =====================} -{$I platform.inc} -{====================================================================} - -{$ifdef OS_WINDOWS} - uses - Windows; -{$endif} - -{***************************************************************************} -{ PUBLIC CONSTANTS } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ SYSTEM ERROR BASE CONSTANTS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ The following ranges have been defined for error codes: } -{---------------------------------------------------------------------------} -{ 0 - 1000 OS dependant error codes } -{ 1000 - 10000 API reserved error codes } -{ 10000 - Add-On unit error codes } -{---------------------------------------------------------------------------} - -{---------------------------------------------------------------------------} -{ DEFINED BASE ERROR CONSTANTS } -{---------------------------------------------------------------------------} -CONST - errOk = 0; { No error } - errVioBase = 1000; { Video base offset } - errKbdBase = 1010; { Keyboard base offset } - errFileCtrlBase = 1020; { File IO base offset } - errMouseBase = 1030; { Mouse base offset } - -{---------------------------------------------------------------------------} -{ MAXIUM DATA SIZES } -{---------------------------------------------------------------------------} -CONST -{$IFDEF BIT_16} { 16 BIT DEFINITION } - MaxBytes = 65520; { Maximum data size } -{$ENDIF} -{$IFDEF BIT_32_OR_MORE} { 32 BIT DEFINITION } - MaxBytes = 128*1024*1024; { Maximum data size } -{$ENDIF} - MaxWords = MaxBytes DIV SizeOf(Word); { Max words } - MaxInts = MaxBytes DIV SizeOf(Integer); { Max integers } - MaxLongs = MaxBytes DIV SizeOf(LongInt); { Max longints } - MaxPtrs = MaxBytes DIV SizeOf(Pointer); { Max pointers } - MaxReals = MaxBytes DIV SizeOf(Real); { Max reals } - MaxStr = MaxBytes DIV SizeOf(String); { Max strings } - -{***************************************************************************} -{ PUBLIC TYPE DEFINITIONS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ CPU TYPE DEFINITIONS } -{---------------------------------------------------------------------------} -TYPE -{$IFDEF BIT_32_OR_MORE} { 32 BIT CODE } - CPUWord = Longint; { CPUWord is 32 bit } - CPUInt = Longint; { CPUInt is 32 bit } -{$ELSE} { 16 BIT CODE } - CPUWord = Word; { CPUWord is 16 bit } - CPUInt = Integer; { CPUInt is 16 bit } -{$ENDIF} - -{---------------------------------------------------------------------------} -{ 16/32 BIT SWITCHED TYPE CONSTANTS } -{---------------------------------------------------------------------------} -TYPE -{$IFDEF BIT_16} { 16 BIT DEFINITIONS } - Sw_Word = Word; { Standard word } - Sw_Integer = Integer; { Standard integer } -{$ENDIF} -{$IFDEF BIT_32_OR_MORE} { 32 BIT DEFINITIONS } - Sw_Word = Cardinal; { Long integer now } - Sw_Integer = LongInt; { Long integer now } -{$ENDIF} - -{---------------------------------------------------------------------------} -{ GENERAL ARRAYS } -{---------------------------------------------------------------------------} -TYPE - TByteArray = ARRAY [0..MaxBytes-1] Of Byte; { Byte array } - PByteArray = ^TByteArray; { Byte array pointer } - - TWordArray = ARRAY [0..MaxWords-1] Of Word; { Word array } - PWordArray = ^TWordArray; { Word array pointer } - - TIntegerArray = ARRAY [0..MaxInts-1] Of Integer; { Integer array } - PIntegerArray = ^TIntegerArray; { Integer array pointer } - - TLongIntArray = ARRAY [0..MaxLongs-1] Of LongInt; { LongInt array } - PLongIntArray = ^TLongIntArray; { LongInt array pointer } - - TRealArray = Array [0..MaxReals-1] Of Real; { Real array } - PRealarray = ^TRealArray; { Real array pointer } - - TPointerArray = Array [0..MaxPtrs-1] Of Pointer; { Pointer array } - PPointerArray = ^TPointerArray; { Pointer array ptr } - - TStrArray = Array [0..MaxStr-1] Of String; { String array } - PStrArray = ^TStrArray; { String array ptr } - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{-GetErrorCode------------------------------------------------------- -Returns the last error code and resets ErrorCode to errOk. -07/12/97 Bazsi ----------------------------------------------------------------------} -FUNCTION GetErrorCode: LongInt; - -{-GetErrorInfo------------------------------------------------------- -Returns the info assigned to the previous error, doesn't reset the -value to nil. Would usually only be called if ErrorCode <> errOk. -07/12/97 Bazsi ----------------------------------------------------------------------} -FUNCTION GetErrorInfo: Pointer; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ MINIMUM AND MAXIMUM ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -FUNCTION Min (I, J: Sw_Integer): Sw_Integer; -FUNCTION Max (I, J: Sw_Integer): Sw_Integer; - -{-MinimumOf---------------------------------------------------------- -Given two real numbers returns the minimum real of the two. -04Oct99 LdB ----------------------------------------------------------------------} -FUNCTION MinimumOf (A, B: Real): Real; - -{-MaximumOf---------------------------------------------------------- -Given two real numbers returns the maximum real of the two. -04Oct99 LdB ----------------------------------------------------------------------} -FUNCTION MaximumOf (A, B: Real): Real; - -{-MinIntegerOf------------------------------------------------------- -Given two integer values returns the lowest integer of the two. -04Oct99 LdB ----------------------------------------------------------------------} -FUNCTION MinIntegerOf (A, B: Integer): Integer; - -{-MaxIntegerof------------------------------------------------------- -Given two integer values returns the biggest integer of the two. -04Oct99 LdB ----------------------------------------------------------------------} -FUNCTION MaxIntegerOf (A, B: Integer): Integer; - -{-MinLongIntOf------------------------------------------------------- -Given two long integers returns the minimum longint of the two. -04Oct99 LdB ----------------------------------------------------------------------} -FUNCTION MinLongIntOf (A, B: LongInt): LongInt; - -{-MaxLongIntOf------------------------------------------------------- -Given two long integers returns the maximum longint of the two. -04Oct99 LdB ----------------------------------------------------------------------} -FUNCTION MaxLongIntOf (A, B: LongInt): LongInt; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ MISSING DELPHI3 ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{ ******************************* REMARK ****************************** } -{ Delphi 3+ does not define these standard routines so I have made } -{ some public functions here to complete compatability. } -{ ****************************** END REMARK *** Leon de Boer, 14Aug98 * } - -{-MemAvail----------------------------------------------------------- -Returns the free memory available under Delphi 3+. -14Aug98 LdB ----------------------------------------------------------------------} -FUNCTION MemAvail: LongInt; - -{-MaxAvail----------------------------------------------------------- -Returns the max free memory block size available under Delphi 3+. -14Aug98 LdB ----------------------------------------------------------------------} -FUNCTION MaxAvail: LongInt; - -{***************************************************************************} -{ INITIALIZED PUBLIC VARIABLES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } -{---------------------------------------------------------------------------} -CONST - ErrorCode: Longint = errOk; { Last error code } - ErrorInfo: Pointer = Nil; { Last error info } - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IMPLEMENTATION -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{$IFDEF PPC_DELPHI3} { DELPHI 3+ COMPILER } -USES WinTypes, WinProcs; { Stardard units } -{$ENDIF} - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ GetErrorCode -> Platforms ALL - Updated 12Jul97 Bazsi } -{---------------------------------------------------------------------------} -FUNCTION GetErrorCode: LongInt; -BEGIN - GetErrorCode := ErrorCode; { Return last error } - ErrorCode := 0; { Now clear errorcode } -END; - -{---------------------------------------------------------------------------} -{ GetErrorInfo -> Platforms ALL - Updated 12Jul97 Bazsi } -{---------------------------------------------------------------------------} -FUNCTION GetErrorInfo: Pointer; -BEGIN - GetErrorInfo := ErrorInfo; { Return errorinfo ptr } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ MINIMUM AND MAXIMUM ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -FUNCTION Min (I, J: Sw_Integer): Sw_Integer; -BEGIN - If (I < J) Then Min := I Else Min := J; { Select minimum } -END; - -FUNCTION Max (I, J: Sw_Integer): Sw_Integer; -BEGIN - If (I > J) Then Max := I Else Max := J; { Select maximum } -END; - - -{---------------------------------------------------------------------------} -{ MinimumOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION MinimumOf (A, B: Real): Real; -BEGIN - If (B < A) Then MinimumOf := B { B smaller take it } - Else MinimumOf := A; { Else take A } -END; - -{---------------------------------------------------------------------------} -{ MaximumOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION MaximumOf (A, B: Real): Real; -BEGIN - If (B > A) Then MaximumOf := B { B bigger take it } - Else MaximumOf := A; { Else take A } -END; - -{---------------------------------------------------------------------------} -{ MinIntegerOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION MinIntegerOf (A, B: Integer): Integer; -BEGIN - If (B < A) Then MinIntegerOf := B { B smaller take it } - Else MinIntegerOf := A; { Else take A } -END; - -{---------------------------------------------------------------------------} -{ MaxIntegerOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION MaxIntegerOf (A, B: Integer): Integer; -BEGIN - If (B > A) Then MaxIntegerOf := B { B bigger take it } - Else MaxIntegerOf := A; { Else take A } -END; - -{---------------------------------------------------------------------------} -{ MinLongIntOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION MinLongIntOf (A, B: LongInt): LongInt; -BEGIN - If (B < A) Then MinLongIntOf := B { B smaller take it } - Else MinLongIntOf := A; { Else take A } -END; - -{---------------------------------------------------------------------------} -{ MaxLongIntOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } -{---------------------------------------------------------------------------} -FUNCTION MaxLongIntOf (A, B: LongInt): LongInt; -BEGIN - If (B > A) Then MaxLongIntOf := B { B bigger take it } - Else MaxLongIntOf := A; { Else take A } -END; - -FUNCTION MemAvail: LongInt; -BEGIN - { Unlimited } - MemAvail:=high(longint); -END; - -{---------------------------------------------------------------------------} -{ MaxAvail -> Platforms WIN/NT - Updated 14Aug98 LdB } -{---------------------------------------------------------------------------} -FUNCTION MaxAvail: LongInt; -BEGIN - { Unlimited } - MaxAvail:=high(longint); -END; - -END. +{$I fvcommon.inc} diff --git a/packages/fv/src/histlist.inc b/packages/fv/src/histlist.inc new file mode 100644 index 0000000000..d9d439e939 --- /dev/null +++ b/packages/fv/src/histlist.inc @@ -0,0 +1,586 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of HISTLIST.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@starwon.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Fix } +{ ------- --------- --------------------------------- } +{ 1.00 11 Nov 96 First DOS/DPMI platform release. } +{ 1.10 13 Jul 97 Windows platform code added. } +{ 1.20 29 Aug 97 Platform.inc sort added. } +{ 1.30 13 Oct 97 Delphi 2 32 bit code added. } +{ 1.40 05 May 98 Virtual pascal 2.0 code added. } +{ 1.50 30 Sep 99 Complete recheck preformed } +{ 1.51 03 Nov 99 FPC windows support added } +{**********************************************************} + +{$ifdef FV_UNICODE} +UNIT UHistList; +{$else FV_UNICODE} +UNIT HistList; +{$endif FV_UNICODE} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Short calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES +{$ifdef FV_UNICODE} + UFVCommon, +{$else FV_UNICODE} + FVCommon, +{$endif FV_UNICODE} + Objects; { Standard GFV units } + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY SYSTEM CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-InitHistory-------------------------------------------------------- +Initializes the history system usually called from Application.Init +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE InitHistory; + +{-DoneHistory-------------------------------------------------------- +Destroys the history system usually called from Application.Done +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE DoneHistory; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY ITEM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-HistoryCount------------------------------------------------------- +Returns the number of strings in the history list with ID number Id. +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION HistoryCount (Id: Byte): Word; + +{-HistoryStr--------------------------------------------------------- +Returns the Index'th string in the history list with ID number Id. +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION HistoryStr (Id: Byte; Index: Sw_Integer): Sw_String; + +{-ClearHistory------------------------------------------------------- +Removes all strings from all history lists. +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE ClearHistory; + +{-HistoryAdd--------------------------------------------------------- +Adds the string Str to the history list indicated by Id. +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE HistoryAdd (Id: Byte; Const Str: Sw_String); + +function HistoryRemove(Id: Byte; Index: Sw_Integer): boolean; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY STREAM STORAGE AND RETREIVAL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-LoadHistory-------------------------------------------------------- +Reads the application's history block from the stream S by reading the +size of the block, then the block itself. Sets HistoryUsed to the end +of the block read. Use LoadHistory to restore a history block saved +with StoreHistory +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE LoadHistory (Var S: TStream); + +{-StoreHistory-------------------------------------------------------- +Writes the currently used portion of the history block to the stream +S, first writing the length of the block then the block itself. Use +the LoadHistory procedure to restore the history block. +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE StoreHistory (Var S: TStream); + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +CONST + HistorySize: sw_integer = 64*1024; { Maximum history size } + HistoryUsed: sw_integer = 0; { History used } + HistoryBlock: Pointer = Nil; { Storage block } + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{***************************************************************************} +{ PRIVATE RECORD DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ THistRec RECORD DEFINITION + + Zero 1 byte, start marker + Id 1 byte, History id +$ifdef FV_UNICODE + <utf8string> uleb128 length+utf8 string data +$else FV_UNICODE + <shortstring> 1 byte length+string data, Contents +$endif FV_UNICODE + +} + +{***************************************************************************} +{ UNINITIALIZED PRIVATE VARIABLES } +{***************************************************************************} +{---------------------------------------------------------------------------} +{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +VAR + CurId: Byte; { Current history id } +{$ifdef FV_UNICODE} + CurString: Pointer; { Current string } +{$else FV_UNICODE} + CurString: PString; { Current string } +{$endif FV_UNICODE} + +{***************************************************************************} +{ PRIVATE UNIT ROUTINES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ StartId -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE StartId (Id: Byte); +BEGIN + CurId := Id; { Set current id } + CurString := HistoryBlock; { Set current string } +END; + +{$ifdef FV_UNICODE} +{---------------------------------------------------------------------------} +{ DecodeSizeUInt } +{---------------------------------------------------------------------------} +FUNCTION DecodeSizeUInt(var P: PByte): SizeUInt; +VAR Shift: Byte; +BEGIN + Shift := 0; + Result := 0; + repeat + Result := Result or ((P^ and 127) shl Shift); + Inc(Shift, 7); + Inc(P); + until ((P-1)^ and 128) = 0; +END; + +{ stored string length (including size bytes) } +FUNCTION StoredStringSize(P: PByte): SizeUInt; +VAR Len: SizeUInt; OrigP: PByte; +BEGIN + OrigP := P; + Len := DecodeSizeUInt(P); + Result := Len + (P - OrigP); +END; + +{---------------------------------------------------------------------------} +{ EncodeSizeUInt } +{---------------------------------------------------------------------------} +PROCEDURE EncodeSizeUInt(var P: PByte; V: SizeUInt); +BEGIN + repeat + P^ := V and 127; + V := V shr 7; + if V <> 0 then + P^ := P^ or 128; + Inc(P); + until V = 0; +END; + +{---------------------------------------------------------------------------} +{ EncodedSizeLengthInBytes } +{---------------------------------------------------------------------------} +FUNCTION EncodedSizeLengthInBytes(V: SizeUInt): Integer; +BEGIN + if V < (1 shl 7) then + Result := 1 + else if V < (1 shl (2*7)) then + Result := 2 + else if V < (1 shl (3*7)) then + Result := 3 + else if V < (1 shl (4*7)) then + Result := 4 + else if V < (1 shl (5*7)) then + Result := 5 + else if V < (1 shl (6*7)) then + Result := 6 + else if V < (1 shl (7*7)) then + Result := 7 + else if V < (1 shl (8*7)) then + Result := 8 + else if V < (1 shl (9*7)) then + Result := 9 + else + Result := 10; +END; +{$endif FV_UNICODE} + +{---------------------------------------------------------------------------} +{ DeleteString -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +{$ifdef FV_UNICODE} +PROCEDURE DeleteString; +VAR Len: SizeUInt; P, P2: Pointer; +BEGIN + P := CurString; { Current string } + P2 := CurString; { Current string } + Len := DecodeSizeUInt(P2); { Length of string } + Dec(P, 2); { Correct position } + Inc(P2, Len); { Next hist record } + { Shuffle history } + Move(P2^, P^, Pointer(HistoryBlock) + HistoryUsed - Pointer(P2) ); + Dec(HistoryUsed, P2-P); { Adjust history used } +END; +{$else FV_UNICODE} +PROCEDURE DeleteString; +VAR Len: Sw_Integer; P, P2: PChar; +BEGIN + P := PChar(CurString); { Current string } + P2 := PChar(CurString); { Current string } + Len := PByte(P2)^+3; { Length of data } + Dec(P, 2); { Correct position } + Inc(P2, PByte(P2)^+1); { Next hist record } + { Shuffle history } + Move(P2^, P^, Pointer(HistoryBlock) + HistoryUsed - Pointer(P2) ); + Dec(HistoryUsed, Len); { Adjust history used } +END; +{$endif FV_UNICODE} + +{---------------------------------------------------------------------------} +{ AdvanceStringPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE AdvanceStringPtr; +VAR P: PChar; +{$ifdef FV_UNICODE} + Len: SizeUInt; +{$endif FV_UNICODE} +BEGIN + While (CurString <> Nil) Do Begin + If (Pointer(CurString) >= Pointer(HistoryBlock) + HistoryUsed) Then Begin{ Last string check } + CurString := Nil; { Clear current string } + Exit; { Now exit } + End; +{$ifdef FV_UNICODE} + Len := DecodeSizeUInt(CurString); + Inc(CurString, Len); { Move to next string } +{$else FV_UNICODE} + Inc(PChar(CurString), PByte(CurString)^+1); { Move to next string } +{$endif FV_UNICODE} + If (Pointer(CurString) >= Pointer(HistoryBlock) + HistoryUsed) Then Begin{ Last string check } + CurString := Nil; { Clear current string } + Exit; { Now exit } + End; + P := PChar(CurString); { Transfer record ptr } + Inc(PChar(CurString), 2); { Move to string } + if (P^<>#0) then + RunError(215); + Inc(P); + If (P^ = Chr(CurId)) Then Exit; { Found the string } + End; +END; + +{---------------------------------------------------------------------------} +{ InsertString -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +{$ifdef FV_UNICODE} +PROCEDURE InsertString (Id: Byte; Const Str: UnicodeString); +VAR P, P1, P2: PByte; StrU8: UTF8String; + Len: SizeUInt; +BEGIN + StrU8 := Str; + while (HistoryUsed+Length(StrU8)+EncodedSizeLengthInBytes(Length(StrU8))+2>HistorySize) do + begin + P:=HistoryBlock; + while Pointer(P)<Pointer(HistoryBlock)+HistorySize do + begin + if Pointer(P)+StoredStringSize(P+2)+4+Length(StrU8)+EncodedSizeLengthInBytes(Length(StrU8)) > + Pointer(HistoryBlock)+HistorySize then + begin + Dec(HistoryUsed,Length(PShortString(P+2)^)+3); + FillChar(P^,Pointer(HistoryBlock)+HistorySize-Pointer(P),#0); + break; + end; + Inc(P, 2); + Len:=DecodeSizeUInt(P); + Inc(P,Len); + end; + end; + P1 := HistoryBlock+1; { First history record } + P2 := P1+Length(StrU8)+EncodedSizeLengthInBytes(Length(StrU8))+2; { History record after } + Move(P1^, P2^, HistoryUsed - 1); { Shuffle history data } + P1^:=0; { Set marker byte } + Inc(P1); + P1^:=Id; { Set history id } + Inc(P1); + EncodeSizeUInt(P1, Length(StrU8)); + Move(StrU8[1], P1^, Length(StrU8)); { Set history string } + Inc(HistoryUsed, Length(StrU8)+EncodedSizeLengthInBytes(Length(StrU8))+2); { Inc history used } +END; +{$else FV_UNICODE} +PROCEDURE InsertString (Id: Byte; Const Str: String); +VAR P, P1, P2: PChar; +BEGIN + while (HistoryUsed+Length(Str)+3>HistorySize) do + begin + P:=PChar(HistoryBlock); + while Pointer(P)<Pointer(HistoryBlock)+HistorySize do + begin + if Pointer(P)+Length(PShortString(P+2)^)+6+Length(Str) > + Pointer(HistoryBlock)+HistorySize then + begin + Dec(HistoryUsed,Length(PShortString(P+2)^)+3); + FillChar(P^,Pointer(HistoryBlock)+HistorySize-Pointer(P),#0); + break; + end; + Inc(P,Length(PShortString(P+2)^)+3); + end; + end; + P1 := PChar(HistoryBlock)+1; { First history record } + P2 := P1+Length(Str)+3; { History record after } + Move(P1^, P2^, HistoryUsed - 1); { Shuffle history data } + P1^:=#0; { Set marker byte } + Inc(P1); + P1^:=Chr(Id); { Set history id } + Inc(P1); + Move(Str[0], P1^, Length(Str)+1); { Set history string } + Inc(HistoryUsed, Length(Str)+3); { Inc history used } +END; +{$endif FV_UNICODE} + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY SYSTEM CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ InitHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE InitHistory; +BEGIN + if HistorySize>0 then + GetMem(HistoryBlock, HistorySize); { Allocate block } + ClearHistory; { Clear the history } +END; + +{---------------------------------------------------------------------------} +{ DoneHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DoneHistory; +BEGIN + If (HistoryBlock <> Nil) Then { History block valid } + begin + FreeMem(HistoryBlock); { Release history block } + HistoryBlock:=nil; + end; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY ITEM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ HistoryCount -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION HistoryCount(Id: Byte): Word; +VAR Count: Word; +BEGIN + StartId(Id); { Set to first record } + Count := 0; { Clear count } + If (HistoryBlock <> Nil) Then Begin { History initalized } + AdvanceStringPtr; { Move to first string } + While (CurString <> Nil) Do Begin + Inc(Count); { Add one to count } + AdvanceStringPtr; { Move to next string } + End; + End; + HistoryCount := Count; { Return history count } +END; + +{---------------------------------------------------------------------------} +{ HistoryStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION HistoryStr(Id: Byte; Index: Sw_Integer): Sw_String; +VAR I: Sw_Integer; +{$ifdef FV_UNICODE} + TmpP: Pointer; + StrU8: UTF8String; +{$endif FV_UNICODE} +BEGIN + StartId(Id); { Set to first record } + If (HistoryBlock <> Nil) Then Begin { History initalized } + For I := 0 To Index Do AdvanceStringPtr; { Find indexed string } + If (CurString <> Nil) Then Begin +{$ifdef FV_UNICODE} + TmpP := CurString; + SetLength(StrU8, DecodeSizeUInt(TmpP)); + Move(TmpP^, StrU8[1], Length(StrU8)); + HistoryStr := StrU8; +{$else FV_UNICODE} + HistoryStr := CurString^ { Return string } +{$endif FV_UNICODE} + End Else + HistoryStr := ''; { Index not found } + End Else HistoryStr := ''; { History uninitialized } +END; + +{---------------------------------------------------------------------------} +{ ClearHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE ClearHistory; +BEGIN + If (HistoryBlock <> Nil) Then Begin { History initiated } + PChar(HistoryBlock)^ := #0; { Clear first byte } + HistoryUsed := 1; { Set position } + End; +END; + +{---------------------------------------------------------------------------} +{ HistoryAdd -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE HistoryAdd (Id: Byte; Const Str: Sw_String); +{$ifdef FV_UNICODE} +VAR StrU8: UTF8String; TmpP: PByte; TmpLen: SizeUInt; +{$endif FV_UNICODE} +BEGIN + If (Str = '') Then Exit; { Empty string exit } + If (HistoryBlock = Nil) Then Exit; { History uninitialized } +{$ifdef FV_UNICODE} + StrU8:=Str; +{$endif FV_UNICODE} + StartId(Id); { Set current data } + AdvanceStringPtr; { Find the string } + While (CurString <> nil) Do Begin +{$ifdef FV_UNICODE} + TmpP := CurString; + TmpLen := DecodeSizeUInt(TmpP); + If (TmpLen=Length(StrU8)) and (CompareByte(TmpP^, StrU8[1], TmpLen)=0) then + DeleteString; { Delete duplicates } +{$else FV_UNICODE} + If (Str = CurString^) Then DeleteString; { Delete duplicates } +{$endif FV_UNICODE} + AdvanceStringPtr; { Find next string } + End; + InsertString(Id, Str); { Add new history item } +END; + +function HistoryRemove(Id: Byte; Index: Sw_Integer): boolean; +var + I: Sw_Integer; +begin + StartId(Id); + for I := 0 to Index do + AdvanceStringPtr; { Find the string } + if CurString <> nil then + begin + DeleteString; + HistoryRemove:=true; + end + else + HistoryRemove:=false; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY STREAM STORAGE AND RETREIVAL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ LoadHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE LoadHistory (Var S: TStream); +VAR Size: sw_integer; +BEGIN + S.Read(Size, sizeof(Size)); { Read history size } + If (HistoryBlock <> Nil) Then Begin { History initialized } + If (Size <= HistorySize) Then Begin + S.Read(HistoryBlock^, Size); { Read the history } + HistoryUsed := Size; { History used } + End Else S.Seek(S.GetPos + Size); { Move stream position } + End Else S.Seek(S.GetPos + Size); { Move stream position } +END; + +{---------------------------------------------------------------------------} +{ StoreHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE StoreHistory (Var S: TStream); +VAR Size: sw_integer; +BEGIN + If (HistoryBlock = Nil) Then Size := 0 Else { No history data } + Size := HistoryUsed; { Size of history data } + S.Write(Size, sizeof(Size)); { Write history size } + If (Size > 0) Then S.Write(HistoryBlock^, Size); { Write history data } +END; + +END. diff --git a/packages/fv/src/histlist.pas b/packages/fv/src/histlist.pas index e712e01263..da4f290d47 100644 --- a/packages/fv/src/histlist.pas +++ b/packages/fv/src/histlist.pas @@ -1,416 +1 @@ -{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} -{ } -{ System independent GRAPHICAL clone of HISTLIST.PAS } -{ } -{ Interface Copyright (c) 1992 Borland International } -{ } -{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } -{ ldeboer@attglobal.net - primary e-mail address } -{ ldeboer@starwon.com.au - backup e-mail address } -{ } -{****************[ THIS CODE IS FREEWARE ]*****************} -{ } -{ This sourcecode is released for the purpose to } -{ promote the pascal language on all platforms. You may } -{ redistribute it and/or modify with the following } -{ DISCLAIMER. } -{ } -{ This SOURCE CODE is distributed "AS IS" WITHOUT } -{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } -{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } -{ } -{*****************[ SUPPORTED PLATFORMS ]******************} -{ 16 and 32 Bit compilers } -{ DOS - Turbo Pascal 7.0 + (16 Bit) } -{ DPMI - Turbo Pascal 7.0 + (16 Bit) } -{ - FPC 0.9912+ (GO32V2) (32 Bit) } -{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } -{ - Delphi 1.0+ (16 Bit) } -{ WIN95/NT - Delphi 2.0+ (32 Bit) } -{ - Virtual Pascal 2.0+ (32 Bit) } -{ - Speedsoft Sybil 2.0+ (32 Bit) } -{ - FPC 0.9912+ (32 Bit) } -{ OS2 - Virtual Pascal 1.0+ (32 Bit) } -{ } -{******************[ REVISION HISTORY ]********************} -{ Version Date Fix } -{ ------- --------- --------------------------------- } -{ 1.00 11 Nov 96 First DOS/DPMI platform release. } -{ 1.10 13 Jul 97 Windows platform code added. } -{ 1.20 29 Aug 97 Platform.inc sort added. } -{ 1.30 13 Oct 97 Delphi 2 32 bit code added. } -{ 1.40 05 May 98 Virtual pascal 2.0 code added. } -{ 1.50 30 Sep 99 Complete recheck preformed } -{ 1.51 03 Nov 99 FPC windows support added } -{**********************************************************} - -UNIT HistList; - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - INTERFACE -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{====Include file to sort compiler platform out =====================} -{$I platform.inc} -{====================================================================} - -{==== Compiler directives ===========================================} - -{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } - {$F-} { Short calls are okay } - {$A+} { Word Align Data } - {$B-} { Allow short circuit boolean evaluations } - {$O+} { This unit may be overlaid } - {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } - {$P-} { Normal string variables } - {$N-} { No 80x87 code generation } - {$E+} { Emulation is on } -{$ENDIF} - -{$X+} { Extended syntax is ok } -{$R-} { Disable range checking } -{$S-} { Disable Stack Checking } -{$I-} { Disable IO Checking } -{$Q-} { Disable Overflow Checking } -{$V-} { Turn off strict VAR strings } -{====================================================================} - -USES FVCommon, Objects; { Standard GFV units } - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ HISTORY SYSTEM CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-InitHistory-------------------------------------------------------- -Initializes the history system usually called from Application.Init -30Sep99 LdB ----------------------------------------------------------------------} -PROCEDURE InitHistory; - -{-DoneHistory-------------------------------------------------------- -Destroys the history system usually called from Application.Done -30Sep99 LdB ----------------------------------------------------------------------} -PROCEDURE DoneHistory; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ HISTORY ITEM ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-HistoryCount------------------------------------------------------- -Returns the number of strings in the history list with ID number Id. -30Sep99 LdB ----------------------------------------------------------------------} -FUNCTION HistoryCount (Id: Byte): Word; - -{-HistoryStr--------------------------------------------------------- -Returns the Index'th string in the history list with ID number Id. -30Sep99 LdB ----------------------------------------------------------------------} -FUNCTION HistoryStr (Id: Byte; Index: Sw_Integer): String; - -{-ClearHistory------------------------------------------------------- -Removes all strings from all history lists. -30Sep99 LdB ----------------------------------------------------------------------} -PROCEDURE ClearHistory; - -{-HistoryAdd--------------------------------------------------------- -Adds the string Str to the history list indicated by Id. -30Sep99 LdB ----------------------------------------------------------------------} -PROCEDURE HistoryAdd (Id: Byte; Const Str: String); - -function HistoryRemove(Id: Byte; Index: Sw_Integer): boolean; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ HISTORY STREAM STORAGE AND RETREIVAL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-LoadHistory-------------------------------------------------------- -Reads the application's history block from the stream S by reading the -size of the block, then the block itself. Sets HistoryUsed to the end -of the block read. Use LoadHistory to restore a history block saved -with StoreHistory -30Sep99 LdB ----------------------------------------------------------------------} -PROCEDURE LoadHistory (Var S: TStream); - -{-StoreHistory-------------------------------------------------------- -Writes the currently used portion of the history block to the stream -S, first writing the length of the block then the block itself. Use -the LoadHistory procedure to restore the history block. -30Sep99 LdB ----------------------------------------------------------------------} -PROCEDURE StoreHistory (Var S: TStream); - -{***************************************************************************} -{ INITIALIZED PUBLIC VARIABLES } -{***************************************************************************} -{---------------------------------------------------------------------------} -{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } -{---------------------------------------------------------------------------} -CONST - HistorySize: sw_integer = 64*1024; { Maximum history size } - HistoryUsed: sw_integer = 0; { History used } - HistoryBlock: Pointer = Nil; { Storage block } - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IMPLEMENTATION -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{***************************************************************************} -{ PRIVATE RECORD DEFINITIONS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ THistRec RECORD DEFINITION - - Zero 1 byte, start marker - Id 1 byte, History id - <shortstring> 1 byte length+string data, Contents -} - -{***************************************************************************} -{ UNINITIALIZED PRIVATE VARIABLES } -{***************************************************************************} -{---------------------------------------------------------------------------} -{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } -{---------------------------------------------------------------------------} -VAR - CurId: Byte; { Current history id } - CurString: PString; { Current string } - -{***************************************************************************} -{ PRIVATE UNIT ROUTINES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ StartId -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE StartId (Id: Byte); -BEGIN - CurId := Id; { Set current id } - CurString := HistoryBlock; { Set current string } -END; - -{---------------------------------------------------------------------------} -{ DeleteString -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE DeleteString; -VAR Len: Sw_Integer; P, P2: PChar; -BEGIN - P := PChar(CurString); { Current string } - P2 := PChar(CurString); { Current string } - Len := PByte(P2)^+3; { Length of data } - Dec(P, 2); { Correct position } - Inc(P2, PByte(P2)^+1); { Next hist record } - { Shuffle history } - Move(P2^, P^, Pointer(HistoryBlock) + HistoryUsed - Pointer(P2) ); - Dec(HistoryUsed, Len); { Adjust history used } -END; - -{---------------------------------------------------------------------------} -{ AdvanceStringPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE AdvanceStringPtr; -VAR P: PChar; -BEGIN - While (CurString <> Nil) Do Begin - If (Pointer(CurString) >= Pointer(HistoryBlock) + HistoryUsed) Then Begin{ Last string check } - CurString := Nil; { Clear current string } - Exit; { Now exit } - End; - Inc(PChar(CurString), PByte(CurString)^+1); { Move to next string } - If (Pointer(CurString) >= Pointer(HistoryBlock) + HistoryUsed) Then Begin{ Last string check } - CurString := Nil; { Clear current string } - Exit; { Now exit } - End; - P := PChar(CurString); { Transfer record ptr } - Inc(PChar(CurString), 2); { Move to string } - if (P^<>#0) then - RunError(215); - Inc(P); - If (P^ = Chr(CurId)) Then Exit; { Found the string } - End; -END; - -{---------------------------------------------------------------------------} -{ InsertString -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE InsertString (Id: Byte; Const Str: String); -VAR P, P1, P2: PChar; -BEGIN - while (HistoryUsed+Length(Str)+3>HistorySize) do - begin - P:=PChar(HistoryBlock); - while Pointer(P)<Pointer(HistoryBlock)+HistorySize do - begin - if Pointer(P)+Length(PShortString(P+2)^)+6+Length(Str) > - Pointer(HistoryBlock)+HistorySize then - begin - Dec(HistoryUsed,Length(PShortString(P+2)^)+3); - FillChar(P^,Pointer(HistoryBlock)+HistorySize-Pointer(P),#0); - break; - end; - Inc(P,Length(PShortString(P+2)^)+3); - end; - end; - P1 := PChar(HistoryBlock)+1; { First history record } - P2 := P1+Length(Str)+3; { History record after } - Move(P1^, P2^, HistoryUsed - 1); { Shuffle history data } - P1^:=#0; { Set marker byte } - Inc(P1); - P1^:=Chr(Id); { Set history id } - Inc(P1); - Move(Str[0], P1^, Length(Str)+1); { Set history string } - Inc(HistoryUsed, Length(Str)+3); { Inc history used } -END; - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ HISTORY SYSTEM CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ InitHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE InitHistory; -BEGIN - if HistorySize>0 then - GetMem(HistoryBlock, HistorySize); { Allocate block } - ClearHistory; { Clear the history } -END; - -{---------------------------------------------------------------------------} -{ DoneHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE DoneHistory; -BEGIN - If (HistoryBlock <> Nil) Then { History block valid } - begin - FreeMem(HistoryBlock); { Release history block } - HistoryBlock:=nil; - end; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ HISTORY ITEM ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ HistoryCount -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -FUNCTION HistoryCount(Id: Byte): Word; -VAR Count: Word; -BEGIN - StartId(Id); { Set to first record } - Count := 0; { Clear count } - If (HistoryBlock <> Nil) Then Begin { History initalized } - AdvanceStringPtr; { Move to first string } - While (CurString <> Nil) Do Begin - Inc(Count); { Add one to count } - AdvanceStringPtr; { Move to next string } - End; - End; - HistoryCount := Count; { Return history count } -END; - -{---------------------------------------------------------------------------} -{ HistoryStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -FUNCTION HistoryStr(Id: Byte; Index: Sw_Integer): String; -VAR I: Sw_Integer; -BEGIN - StartId(Id); { Set to first record } - If (HistoryBlock <> Nil) Then Begin { History initalized } - For I := 0 To Index Do AdvanceStringPtr; { Find indexed string } - If (CurString <> Nil) Then - HistoryStr := CurString^ Else { Return string } - HistoryStr := ''; { Index not found } - End Else HistoryStr := ''; { History uninitialized } -END; - -{---------------------------------------------------------------------------} -{ ClearHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE ClearHistory; -BEGIN - If (HistoryBlock <> Nil) Then Begin { History initiated } - PChar(HistoryBlock)^ := #0; { Clear first byte } - HistoryUsed := 1; { Set position } - End; -END; - -{---------------------------------------------------------------------------} -{ HistoryAdd -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE HistoryAdd (Id: Byte; Const Str: String); -BEGIN - If (Str = '') Then Exit; { Empty string exit } - If (HistoryBlock = Nil) Then Exit; { History uninitialized } - StartId(Id); { Set current data } - AdvanceStringPtr; { Find the string } - While (CurString <> nil) Do Begin - If (Str = CurString^) Then DeleteString; { Delete duplicates } - AdvanceStringPtr; { Find next string } - End; - InsertString(Id, Str); { Add new history item } -END; - -function HistoryRemove(Id: Byte; Index: Sw_Integer): boolean; -var - I: Sw_Integer; -begin - StartId(Id); - for I := 0 to Index do - AdvanceStringPtr; { Find the string } - if CurString <> nil then - begin - DeleteString; - HistoryRemove:=true; - end - else - HistoryRemove:=false; -end; - - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ HISTORY STREAM STORAGE AND RETREIVAL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ LoadHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE LoadHistory (Var S: TStream); -VAR Size: sw_integer; -BEGIN - S.Read(Size, sizeof(Size)); { Read history size } - If (HistoryBlock <> Nil) Then Begin { History initialized } - If (Size <= HistorySize) Then Begin - S.Read(HistoryBlock^, Size); { Read the history } - HistoryUsed := Size; { History used } - End Else S.Seek(S.GetPos + Size); { Move stream position } - End Else S.Seek(S.GetPos + Size); { Move stream position } -END; - -{---------------------------------------------------------------------------} -{ StoreHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE StoreHistory (Var S: TStream); -VAR Size: sw_integer; -BEGIN - If (HistoryBlock = Nil) Then Size := 0 Else { No history data } - Size := HistoryUsed; { Size of history data } - S.Write(Size, sizeof(Size)); { Write history size } - If (Size > 0) Then S.Write(HistoryBlock^, Size); { Write history data } -END; - -END. +{$I histlist.inc} diff --git a/packages/fv/src/inplong.inc b/packages/fv/src/inplong.inc new file mode 100644 index 0000000000..49c47a2abb --- /dev/null +++ b/packages/fv/src/inplong.inc @@ -0,0 +1,323 @@ +{$ifdef FV_UNICODE} +Unit UInpLong; +{$else FV_UNICODE} +Unit InpLong; +{$endif FV_UNICODE} + +(*-- +TInputLong is a derivitave of TInputline designed to accept LongInt +numeric input. Since both the upper and lower limit of acceptable numeric +input can be set, TInputLong may be used for SmallInt, Word, or Byte input +as well. Option flag bits allow optional hex input and display. A blank +field may optionally be rejected or interpreted as zero. + +Methods + +constructor Init(var R : TRect; AMaxLen : SmallInt; + LowerLim, UpperLim : LongInt; Flgs : Word); + +Calls TInputline.Init and saves the desired limits and Flags. Flags may +be a combination of: + +ilHex will accept hex input (preceded by '$') as well as decimal. +ilBlankEqZero if set, will interpret a blank field as '0'. +ilDisplayHex if set, will display numeric as hex when possible. + + +constructor Load(var S : TStream); +procedure Store(var S : TStream); + +The usual Load and Store routines. Be sure to call RegisterType(RInputLong) +to register the type. + + +FUNCTION DataSize : Word; virtual; +PROCEDURE GetData(var Rec); virtual; +PROCEDURE SetData(var Rec); virtual; + +The transfer methods. DataSize is Sizeof(LongInt) and Rec should be +the address of a LongInt. + + +FUNCTION RangeCheck : Boolean; virtual; + +Returns True if the entered string evaluates to a number >= LowerLim and +<= UpperLim. + + +PROCEDURE Error; virtual; + +Error is called when RangeCheck fails. It displays a messagebox indicating +the label (if any) of the faulting view, as well as the allowable range. + + +PROCEDURE HandleEvent(var Event : TEvent); virtual; + +HandleEvent filters out characters which are not appropriate to numeric +input. Tab and Shift Tab cause a call to RangeCheck and a call to Error +if RangeCheck returns false. The input must be valid to Tab from the view. +There's no attempt made to stop moving to another view with the mouse. + + +FUNCTION Valid(Cmd : Word) : Boolean; virtual; + +if TInputline.Valid is true and Cmd is neither cmValid or cmCancel, Valid +then calls RangeCheck. If RangeCheck is false, then Error is called and +Valid returns False. + +----*) + +{$i platform.inc} + +{$ifdef PPC_FPC} + {$H-} +{$else} + {$F+,O+,E+,N+} +{$endif} +{$X+,R-,I-,Q-,V-} +{$ifndef OS_UNIX} + {$S-} +{$endif} + +Interface +uses objects, +{$ifdef FV_UNICODE} + udrivers, uviews, udialogs, umsgbox, ufvcommon, +{$else FV_UNICODE} + drivers, views, dialogs, msgbox, fvcommon, +{$endif FV_UNICODE} + fvconsts; + +{flags for TInputLong constructor} +const + ilHex = 1; {will enable hex input with leading '$'} + ilBlankEqZero = 2; {No input (blank) will be interpreted as '0'} + ilDisplayHex = 4; {Number displayed as hex when possible} +Type + TInputLong = Object(TInputLine) + ILOptions : Word; + LLim, ULim : LongInt; + constructor Init(var R : TRect; AMaxLen : Sw_Integer; + LowerLim, UpperLim : LongInt; Flgs : Word); + constructor Load(var S : TStream); + procedure Store(var S : TStream); + FUNCTION DataSize : Sw_Word; virtual; + PROCEDURE GetData(var Rec); virtual; + PROCEDURE SetData(var Rec); virtual; + FUNCTION RangeCheck : Boolean; virtual; + PROCEDURE Error; virtual; + PROCEDURE HandleEvent(var Event : TEvent); virtual; + FUNCTION Valid(Cmd : Word) : Boolean; virtual; + end; + PInputLong = ^TInputLong; + +const + RInputLong : TStreamRec = ( + ObjType: idInputLong; + VmtLink: Ofs(Typeof(TInputLong)^); + Load : @TInputLong.Load; + Store : @TInputLong.Store); + +Implementation + +{-----------------TInputLong.Init} +constructor TInputLong.Init(var R : TRect; AMaxLen : Sw_Integer; + LowerLim, UpperLim : LongInt; Flgs : Word); +begin +if not TInputLine.Init(R, AMaxLen) then fail; +ULim := UpperLim; +LLim := LowerLim; +if Flgs and ilDisplayHex <> 0 then Flgs := Flgs or ilHex; +ILOptions := Flgs; +if ILOptions and ilBlankEqZero <> 0 then Data Sw_PString_Deref := '0'; +end; + +{-------------------TInputLong.Load} +constructor TInputLong.Load(var S : TStream); +begin +TInputLine.Load(S); +S.Read(ILOptions, Sizeof(ILOptions)); +S.Read(LLim, Sizeof(LLim)); +S.Read(ULim, Sizeof(ULim)); +end; + +{-------------------TInputLong.Store} +procedure TInputLong.Store(var S : TStream); +begin +TInputLine.Store(S); +S.Write(ILOptions, Sizeof(ILOptions)); +S.Write(LLim, Sizeof(LLim)); +S.Write(ULim, Sizeof(ULim)); +end; + +{-------------------TInputLong.DataSize} +FUNCTION TInputLong.DataSize:Sw_Word; +begin +DataSize := Sizeof(LongInt); +end; + +{-------------------TInputLong.GetData} +PROCEDURE TInputLong.GetData(var Rec); +var code : SmallInt; +begin +Val(Data Sw_PString_Deref, LongInt(Rec), code); +end; + +FUNCTION Hex2(B : Byte) : Sw_String; +Const + HexArray : array[0..15] of char = '0123456789ABCDEF'; +begin +SetLength(Hex2, 2); +Hex2[1] := HexArray[B shr 4]; +Hex2[2] := HexArray[B and $F]; +end; + +FUNCTION Hex4(W : Word) : Sw_String; +begin Hex4 := Hex2(Hi(W))+Hex2(Lo(W)); end; + +FUNCTION Hex8(L : LongInt) : Sw_String; +begin Hex8 := Hex4(LongRec(L).Hi)+Hex4(LongRec(L).Lo); end; + +function FormHexStr(L : LongInt) : Sw_String; +var + Minus : boolean; +{$ifdef FV_UNICODE} + S : Sw_String; +{$else FV_UNICODE} + S : string[20]; +{$endif FV_UNICODE} +begin +Minus := L < 0; +if Minus then L := -L; +S := Hex8(L); +while (Length(S) > 1) and (S[1] = '0') do Delete(S, 1, 1); +S := '$' + S; +if Minus then System.Insert('-', S, 2); +FormHexStr := S; +end; + +{-------------------TInputLong.SetData} +PROCEDURE TInputLong.SetData(var Rec); +var + L : LongInt; + S : Sw_String; +begin +L := LongInt(Rec); +if L > ULim then L := ULim +else if L < LLim then L := LLim; +if ILOptions and ilDisplayHex <> 0 then + S := FormHexStr(L) +else + Str(L : -1, S); +if Length(S) > MaxLen then SetLength(S, MaxLen); +Data Sw_PString_Deref := S; +end; + +{-------------------TInputLong.RangeCheck} +FUNCTION TInputLong.RangeCheck : Boolean; +var + L : LongInt; + code : SmallInt; +begin +if (Data Sw_PString_Deref = '') and (ILOptions and ilBlankEqZero <> 0) then + Data Sw_PString_Deref := '0'; +Val(Data Sw_PString_Deref, L, code); +RangeCheck := (Code = 0) and (L >= LLim) and (L <= ULim); +end; + +{-------------------TInputLong.Error} +PROCEDURE TInputLong.Error; +var +{$ifdef FV_UNICODE} + SU, SL : Sw_String; +{$else FV_UNICODE} + SU, SL : string[40]; +{$endif FV_UNICODE} + PMyLabel : PLabel; + Labl : Sw_String; + I : SmallInt; + + function FindIt(P : PView) : boolean;{$ifdef PPC_BP}far;{$endif} + begin + FindIt := (Typeof(P^) = Typeof(TLabel)) and (PLabel(P)^.Link = PView(@Self)); + end; + +begin +Str(LLim : -1, SL); +Str(ULim : -1, SU); +if ILOptions and ilHex <> 0 then + begin + SL := SL+'('+FormHexStr(LLim)+')'; + SU := SU+'('+FormHexStr(ULim)+')'; + end; +if Owner <> Nil then + PMyLabel := PLabel(Owner^.FirstThat(@FindIt)) +else PMyLabel := Nil; +if PMyLabel <> Nil then PMyLabel^.GetText(Labl) +else Labl := ''; +if Labl <> '' then + begin + I := Pos('~', Labl); + while I > 0 do + begin + System.Delete(Labl, I, 1); + I := Pos('~', Labl); + end; + Labl := '"'+Labl+'"'; + end; +MessageBox(Labl + ^M^J'Value not within range '+SL+' to '+SU, Nil, + mfError+mfOKButton); +end; + +{-------------------TInputLong.HandleEvent} +PROCEDURE TInputLong.HandleEvent(var Event : TEvent); +begin +if (Event.What = evKeyDown) then + begin + case Event.KeyCode of + kbTab, kbShiftTab + : if not RangeCheck then + begin + Error; + SelectAll(True); + ClearEvent(Event); + end; + end; + if Event.CharCode <> #0 then {a character key} + begin + Event.Charcode := Upcase(Event.Charcode); + case Event.Charcode of + '0'..'9', #1..#$1B : ; {acceptable} + + '-' : if (LLim >= 0) or (CurPos <> 0) then + ClearEvent(Event); + '$' : if ILOptions and ilHex = 0 then ClearEvent(Event); + 'A'..'F' : if Pos('$', Data Sw_PString_Deref) = 0 then ClearEvent(Event); + + else ClearEvent(Event); + end; + end; + end; +TInputLine.HandleEvent(Event); +end; + +{-------------------TInputLong.Valid} +FUNCTION TInputLong.Valid(Cmd : Word) : Boolean; +var + Rslt : boolean; +begin +Rslt := TInputLine.Valid(Cmd); +if Rslt and (Cmd <> 0) and (Cmd <> cmCancel) then + begin + Rslt := RangeCheck; + if not Rslt then + begin + Error; + Select; + SelectAll(True); + end; + end; +Valid := Rslt; +end; + +end. diff --git a/packages/fv/src/inplong.pas b/packages/fv/src/inplong.pas index dc2da1a3fd..8b8cf6638b 100644 --- a/packages/fv/src/inplong.pas +++ b/packages/fv/src/inplong.pas @@ -1,305 +1 @@ -Unit InpLong; - -(*-- -TInputLong is a derivitave of TInputline designed to accept LongInt -numeric input. Since both the upper and lower limit of acceptable numeric -input can be set, TInputLong may be used for Integer, Word, or Byte input -as well. Option flag bits allow optional hex input and display. A blank -field may optionally be rejected or interpreted as zero. - -Methods - -constructor Init(var R : TRect; AMaxLen : Integer; - LowerLim, UpperLim : LongInt; Flgs : Word); - -Calls TInputline.Init and saves the desired limits and Flags. Flags may -be a combination of: - -ilHex will accept hex input (preceded by '$') as well as decimal. -ilBlankEqZero if set, will interpret a blank field as '0'. -ilDisplayHex if set, will display numeric as hex when possible. - - -constructor Load(var S : TStream); -procedure Store(var S : TStream); - -The usual Load and Store routines. Be sure to call RegisterType(RInputLong) -to register the type. - - -FUNCTION DataSize : Word; virtual; -PROCEDURE GetData(var Rec); virtual; -PROCEDURE SetData(var Rec); virtual; - -The transfer methods. DataSize is Sizeof(LongInt) and Rec should be -the address of a LongInt. - - -FUNCTION RangeCheck : Boolean; virtual; - -Returns True if the entered string evaluates to a number >= LowerLim and -<= UpperLim. - - -PROCEDURE Error; virtual; - -Error is called when RangeCheck fails. It displays a messagebox indicating -the label (if any) of the faulting view, as well as the allowable range. - - -PROCEDURE HandleEvent(var Event : TEvent); virtual; - -HandleEvent filters out characters which are not appropriate to numeric -input. Tab and Shift Tab cause a call to RangeCheck and a call to Error -if RangeCheck returns false. The input must be valid to Tab from the view. -There's no attempt made to stop moving to another view with the mouse. - - -FUNCTION Valid(Cmd : Word) : Boolean; virtual; - -if TInputline.Valid is true and Cmd is neither cmValid or cmCancel, Valid -then calls RangeCheck. If RangeCheck is false, then Error is called and -Valid returns False. - -----*) - -{$i platform.inc} - -{$ifdef PPC_FPC} - {$H-} -{$else} - {$F+,O+,E+,N+} -{$endif} -{$X+,R-,I-,Q-,V-} -{$ifndef OS_UNIX} - {$S-} -{$endif} - -Interface -uses objects, drivers, views, dialogs, msgbox, fvconsts; - -{flags for TInputLong constructor} -const - ilHex = 1; {will enable hex input with leading '$'} - ilBlankEqZero = 2; {No input (blank) will be interpreted as '0'} - ilDisplayHex = 4; {Number displayed as hex when possible} -Type - TInputLong = Object(TInputLine) - ILOptions : Word; - LLim, ULim : LongInt; - constructor Init(var R : TRect; AMaxLen : Sw_Integer; - LowerLim, UpperLim : LongInt; Flgs : Word); - constructor Load(var S : TStream); - procedure Store(var S : TStream); - FUNCTION DataSize : Sw_Word; virtual; - PROCEDURE GetData(var Rec); virtual; - PROCEDURE SetData(var Rec); virtual; - FUNCTION RangeCheck : Boolean; virtual; - PROCEDURE Error; virtual; - PROCEDURE HandleEvent(var Event : TEvent); virtual; - FUNCTION Valid(Cmd : Word) : Boolean; virtual; - end; - PInputLong = ^TInputLong; - -const - RInputLong : TStreamRec = ( - ObjType: idInputLong; - VmtLink: Ofs(Typeof(TInputLong)^); - Load : @TInputLong.Load; - Store : @TInputLong.Store); - -Implementation - -{-----------------TInputLong.Init} -constructor TInputLong.Init(var R : TRect; AMaxLen : Sw_Integer; - LowerLim, UpperLim : LongInt; Flgs : Word); -begin -if not TInputLine.Init(R, AMaxLen) then fail; -ULim := UpperLim; -LLim := LowerLim; -if Flgs and ilDisplayHex <> 0 then Flgs := Flgs or ilHex; -ILOptions := Flgs; -if ILOptions and ilBlankEqZero <> 0 then Data^ := '0'; -end; - -{-------------------TInputLong.Load} -constructor TInputLong.Load(var S : TStream); -begin -TInputLine.Load(S); -S.Read(ILOptions, Sizeof(ILOptions)); -S.Read(LLim, Sizeof(LLim)); -S.Read(ULim, Sizeof(ULim)); -end; - -{-------------------TInputLong.Store} -procedure TInputLong.Store(var S : TStream); -begin -TInputLine.Store(S); -S.Write(ILOptions, Sizeof(ILOptions)); -S.Write(LLim, Sizeof(LLim)); -S.Write(ULim, Sizeof(ULim)); -end; - -{-------------------TInputLong.DataSize} -FUNCTION TInputLong.DataSize:Sw_Word; -begin -DataSize := Sizeof(LongInt); -end; - -{-------------------TInputLong.GetData} -PROCEDURE TInputLong.GetData(var Rec); -var code : Integer; -begin -Val(Data^, LongInt(Rec), code); -end; - -FUNCTION Hex2(B : Byte) : String; -Const - HexArray : array[0..15] of char = '0123456789ABCDEF'; -begin -Hex2[0] := #2; -Hex2[1] := HexArray[B shr 4]; -Hex2[2] := HexArray[B and $F]; -end; - -FUNCTION Hex4(W : Word) : String; -begin Hex4 := Hex2(Hi(W))+Hex2(Lo(W)); end; - -FUNCTION Hex8(L : LongInt) : String; -begin Hex8 := Hex4(LongRec(L).Hi)+Hex4(LongRec(L).Lo); end; - -function FormHexStr(L : LongInt) : String; -var - Minus : boolean; - S : string[20]; -begin -Minus := L < 0; -if Minus then L := -L; -S := Hex8(L); -while (Length(S) > 1) and (S[1] = '0') do Delete(S, 1, 1); -S := '$' + S; -if Minus then System.Insert('-', S, 2); -FormHexStr := S; -end; - -{-------------------TInputLong.SetData} -PROCEDURE TInputLong.SetData(var Rec); -var - L : LongInt; - S : string; -begin -L := LongInt(Rec); -if L > ULim then L := ULim -else if L < LLim then L := LLim; -if ILOptions and ilDisplayHex <> 0 then - S := FormHexStr(L) -else - Str(L : -1, S); -if Length(S) > MaxLen then S[0] := chr(MaxLen); -Data^ := S; -end; - -{-------------------TInputLong.RangeCheck} -FUNCTION TInputLong.RangeCheck : Boolean; -var - L : LongInt; - code : Integer; -begin -if (Data^ = '') and (ILOptions and ilBlankEqZero <> 0) then - Data^ := '0'; -Val(Data^, L, code); -RangeCheck := (Code = 0) and (L >= LLim) and (L <= ULim); -end; - -{-------------------TInputLong.Error} -PROCEDURE TInputLong.Error; -var - SU, SL : string[40]; - PMyLabel : PLabel; - Labl : string; - I : Integer; - - function FindIt(P : PView) : boolean;{$ifdef PPC_BP}far;{$endif} - begin - FindIt := (Typeof(P^) = Typeof(TLabel)) and (PLabel(P)^.Link = PView(@Self)); - end; - -begin -Str(LLim : -1, SL); -Str(ULim : -1, SU); -if ILOptions and ilHex <> 0 then - begin - SL := SL+'('+FormHexStr(LLim)+')'; - SU := SU+'('+FormHexStr(ULim)+')'; - end; -if Owner <> Nil then - PMyLabel := PLabel(Owner^.FirstThat(@FindIt)) -else PMyLabel := Nil; -if PMyLabel <> Nil then PMyLabel^.GetText(Labl) -else Labl := ''; -if Labl <> '' then - begin - I := Pos('~', Labl); - while I > 0 do - begin - System.Delete(Labl, I, 1); - I := Pos('~', Labl); - end; - Labl := '"'+Labl+'"'; - end; -MessageBox(Labl + ^M^J'Value not within range '+SL+' to '+SU, Nil, - mfError+mfOKButton); -end; - -{-------------------TInputLong.HandleEvent} -PROCEDURE TInputLong.HandleEvent(var Event : TEvent); -begin -if (Event.What = evKeyDown) then - begin - case Event.KeyCode of - kbTab, kbShiftTab - : if not RangeCheck then - begin - Error; - SelectAll(True); - ClearEvent(Event); - end; - end; - if Event.CharCode <> #0 then {a character key} - begin - Event.Charcode := Upcase(Event.Charcode); - case Event.Charcode of - '0'..'9', #1..#$1B : ; {acceptable} - - '-' : if (LLim >= 0) or (CurPos <> 0) then - ClearEvent(Event); - '$' : if ILOptions and ilHex = 0 then ClearEvent(Event); - 'A'..'F' : if Pos('$', Data^) = 0 then ClearEvent(Event); - - else ClearEvent(Event); - end; - end; - end; -TInputLine.HandleEvent(Event); -end; - -{-------------------TInputLong.Valid} -FUNCTION TInputLong.Valid(Cmd : Word) : Boolean; -var - Rslt : boolean; -begin -Rslt := TInputLine.Valid(Cmd); -if Rslt and (Cmd <> 0) and (Cmd <> cmCancel) then - begin - Rslt := RangeCheck; - if not Rslt then - begin - Error; - Select; - SelectAll(True); - end; - end; -Valid := Rslt; -end; - -end. +{$I inplong.inc} diff --git a/packages/fv/src/memory.pas b/packages/fv/src/memory.pas index afb912cc58..4afa47a30e 100644 --- a/packages/fv/src/memory.pas +++ b/packages/fv/src/memory.pas @@ -278,7 +278,7 @@ CONST DisablePool: Boolean = False; { Disable safety pool } SafetyPool : Pointer = Nil; { Safety pool memory } {$IFDEF PROC_REAL} { REAL MODE DOS CODE } - HeapResult: Integer = 0; { Heap result } + HeapResult: SmallInt = 0; { Heap result } BufHeapPtr: Word = 0; { Heap position } BufHeapEnd: Word = 0; { Heap end } CachePtr : Pointer = Nil; { Cache list } @@ -443,7 +443,7 @@ END; {---------------------------------------------------------------------------} { HeapNotify -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } {---------------------------------------------------------------------------} -FUNCTION HeapNotify (Size: Word): Integer; {$IFNDEF PPC_FPC}FAR;{$ENDIF} +FUNCTION HeapNotify (Size: Word): SmallInt; {$IFNDEF PPC_FPC}FAR;{$ENDIF} {$IFDEF PROC_REAL} { REAL MODE DOS CODE } ASSEMBLER; ASM diff --git a/packages/fv/src/menus.inc b/packages/fv/src/menus.inc new file mode 100644 index 0000000000..265984af31 --- /dev/null +++ b/packages/fv/src/menus.inc @@ -0,0 +1,1700 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of MENUS.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@starwon.com.au - backup e-mail addr } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} + +{$ifdef FV_UNICODE} +UNIT UMenus; +{$else FV_UNICODE} +UNIT Menus; +{$endif FV_UNICODE} + +{$CODEPAGE cp437} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Near calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES + {$IFDEF OS_WINDOWS} { WIN/NT CODE } + {$IFNDEF PPC_SPEED} { NON SPEED COMPILER } + {$IFDEF PPC_FPC} { FPC WINDOWS COMPILER } + Windows, { Standard unit } + {$ELSE} { OTHER COMPILERS } + WinTypes,WinProcs, { Standard units } + {$ENDIF} + {$ELSE} { SPEEDSOFT COMPILER } + WinBase, WinDef, { Standard units } + {$ENDIF} + {$ENDIF} + +{$ifdef FV_UNICODE} + objects, udrivers, uviews, UFVCommon, fvconsts; { GFV standard units } +{$else FV_UNICODE} + objects, drivers, views, fvcommon, fvconsts; { GFV standard units } +{$endif FV_UNICODE} + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ COLOUR PALETTES } +{---------------------------------------------------------------------------} +CONST + CMenuView = #2#3#4#5#6#7; { Menu colours } + CStatusLine = #2#3#4#5#6#7; { Statusline colours } + +{***************************************************************************} +{ RECORD DEFINITIONS } +{***************************************************************************} +TYPE +{$ifdef FV_UNICODE} + TMenuStr = UnicodeString; { Menu string } +{$else FV_UNICODE} + TMenuStr = String[31]; { Menu string } +{$endif FV_UNICODE} + + PMenu = ^TMenu; { Pointer to menu } + +{---------------------------------------------------------------------------} +{ TMenuItem RECORD } +{---------------------------------------------------------------------------} + PMenuItem = ^TMenuItem; + TMenuItem = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Next: PMenuItem; { Next menu item } + Name: SW_PString; { Menu item name } + Command: Word; { Menu item command } + Disabled: Boolean; { Menu item state } + KeyCode: Word; { Menu item keycode } + HelpCtx: Word; { Menu item help ctx } +{$ifdef FV_UNICODE} + Param: UnicodeString; + SubMenu: PMenu; +{$else FV_UNICODE} + Case SmallInt Of + 0: (Param: PString); + 1: (SubMenu: PMenu); +{$endif FV_UNICODE} + END; + +{---------------------------------------------------------------------------} +{ TMenu RECORD } +{---------------------------------------------------------------------------} + TMenu = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Items: PMenuItem; { Menu item list } + Default: PMenuItem; { Default menu } + END; + +{---------------------------------------------------------------------------} +{ TStatusItem RECORD } +{---------------------------------------------------------------------------} +TYPE + PStatusItem = ^TStatusItem; + TStatusItem = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Next: PStatusItem; { Next status item } + Text: Sw_PString; { Text of status item } + KeyCode: Word; { Keycode of item } + Command: Word; { Command of item } + END; + +{---------------------------------------------------------------------------} +{ TStatusDef RECORD } +{---------------------------------------------------------------------------} +TYPE + PStatusDef = ^TStatusDef; + TStatusDef = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Next: PStatusDef; { Next status defined } + Min, Max: Word; { Range of item } + Items: PStatusItem; { Item list } + END; + +{***************************************************************************} +{ OBJECT DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TMenuView OBJECT - MENU VIEW ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + PMenuView = ^TMenuView; + TMenuView = OBJECT (TView) + ParentMenu: PMenuView; { Parent menu } + Menu : PMenu; { Menu item list } + Current : PMenuItem; { Current menu item } + OldItem : PMenuItem; { Old item for draws } + CONSTRUCTOR Init (Var Bounds: TRect); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION Execute: Word; Virtual; + FUNCTION GetHelpCtx: Word; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION FindItem (Ch: Char): PMenuItem; + FUNCTION HotKey (KeyCode: Word): PMenuItem; + FUNCTION NewSubView (Var Bounds: TRect; AMenu: PMenu; + AParentMenu: PMenuView): PMenuView; Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE GetItemRect (Item: PMenuItem; Var R: TRect); Virtual; + private + PROCEDURE GetItemRectX (Item: PMenuItem; Var R: TRect); Virtual; + END; + +{---------------------------------------------------------------------------} +{ TMenuBar OBJECT - MENU BAR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TMenuBar = OBJECT (TMenuView) + CONSTRUCTOR Init (Var Bounds: TRect; AMenu: PMenu); + DESTRUCTOR Done; Virtual; + PROCEDURE Draw; Virtual; + private + PROCEDURE GetItemRectX (Item: PMenuItem; Var R: TRect); Virtual; + END; + PMenuBar = ^TMenuBar; + +{---------------------------------------------------------------------------} +{ TMenuBox OBJECT - BOXED MENU OBJECT } +{---------------------------------------------------------------------------} +TYPE + TMenuBox = OBJECT (TMenuView) + CONSTRUCTOR Init (Var Bounds: TRect; AMenu: PMenu; + AParentMenu: PMenuView); + PROCEDURE Draw; Virtual; + private + PROCEDURE GetItemRectX (Item: PMenuItem; Var R: TRect); Virtual; + END; + PMenuBox = ^TMenuBox; + +{---------------------------------------------------------------------------} +{ TMenuPopUp OBJECT - POPUP MENU OBJECT } +{---------------------------------------------------------------------------} +TYPE + TMenuPopup = OBJECT (TMenuBox) + CONSTRUCTOR Init (Var Bounds: TRect; AMenu: PMenu); + DESTRUCTOR Done; Virtual; + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PMenuPopup = ^TMenuPopup; + +{---------------------------------------------------------------------------} +{ TStatusLine OBJECT - STATUS LINE OBJECT } +{---------------------------------------------------------------------------} +TYPE + TStatusLine = OBJECT (TView) + Items: PStatusItem; { Status line items } + Defs : PStatusDef; { Status line default } + CONSTRUCTOR Init (Var Bounds: TRect; ADefs: PStatusDef); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION Hint (AHelpCtx: Word): Sw_String; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Update; Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PRIVATE + PROCEDURE FindItems; + PROCEDURE DrawSelect (Selected: PStatusItem); + END; + PStatusLine = ^TStatusLine; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MENU INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-NewMenu------------------------------------------------------------ +Allocates and returns a pointer to a new TMenu record. Sets the Items +and Default fields of the record to the value given by the parameter. +An error creating will return a nil pointer. +14May98 LdB +---------------------------------------------------------------------} +FUNCTION NewMenu (Items: PMenuItem): PMenu; + +{-DisposeMenu-------------------------------------------------------- +Disposes of all the elements of the specified menu (and all submenus). +14May98 LdB +---------------------------------------------------------------------} +PROCEDURE DisposeMenu (Menu: PMenu); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MENU ITEM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-NewLine------------------------------------------------------------ +Allocates and returns a pointer to a new TMenuItem record that +represents a separator line in a menu box. +An error creating will return a nil pointer. +14May98 LdB +---------------------------------------------------------------------} +FUNCTION NewLine (Next: PMenuItem): PMenuItem; + +{-NewItem------------------------------------------------------------ +Allocates and returns a pointer to a new TMenuItem record that +represents a menu item (using NewStr to allocate the Name and Param). +An error creating will return a nil pointer. +14May98 LdB +---------------------------------------------------------------------} +FUNCTION NewItem (Name, Param: TMenuStr; KeyCode: Word; Command: Word; + AHelpCtx: Word; Next: PMenuItem): PMenuItem; + +{-NewSubMenu--------------------------------------------------------- +Allocates and returns a pointer to a new TMenuItem record, which +represents a submenu (using NewStr to allocate the Name). +An error creating will return a nil pointer. +14May98 LdB +---------------------------------------------------------------------} +FUNCTION NewSubMenu (Name: TMenuStr; AHelpCtx: Word; SubMenu: PMenu; + Next: PMenuItem): PMenuItem; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STATUS INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-NewStatusDef------------------------------------------------------- +Allocates and returns a pointer to a new TStatusDef record initialized +with the given parameter values. Calls to NewStatusDef can be nested. +An error creating will return a nil pointer. +15May98 LdB +---------------------------------------------------------------------} +FUNCTION NewStatusDef (AMin, AMax: Word; AItems: PStatusItem; + ANext: PStatusDef): PStatusDef; + +{-NewStatusKey------------------------------------------------------- +Allocates and returns a pointer to a new TStatusItem record initialized +with the given parameter values (using NewStr to allocate the Text). +An error in creating will return a nil pointer. +15May98 LdB +---------------------------------------------------------------------} +FUNCTION NewStatusKey (AText: Sw_String; AKeyCode: Word; ACommand: Word; + ANext: PStatusItem): PStatusItem; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{-RegisterMenus------------------------------------------------------- +Calls RegisterType for each of the object types defined in this unit. +15May98 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterMenus; + +{***************************************************************************} +{ OBJECT REGISTRATION } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TMenuBar STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RMenuBar: TStreamRec = ( + ObjType: idMenuBar; { Register id = 40 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TMenuBar)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TMenuBar); + {$ENDIF} + Load: @TMenuBar.Load; { Object load method } + Store: @TMenuBar.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TMenuBox STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RMenuBox: TStreamRec = ( + ObjType: idMenuBox; { Register id = 41 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TMenuBox)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TMenuBox); + {$ENDIF} + Load: @TMenuBox.Load; { Object load method } + Store: @TMenuBox.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TStatusLine STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RStatusLine: TStreamRec = ( + ObjType: 42; { Register id = 42 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TStatusLine)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TStatusLine); + {$ENDIF} + Load: @TStatusLine.Load; { Object load method } + Store: @TStatusLine.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TMenuPopup STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RMenuPopup: TStreamRec = ( + ObjType: 43; { Register id = 43 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TMenuPopup)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TMenuPopup); + {$ENDIF} + Load: @TMenuPopup.Load; { Object load method } + Store: @TMenuPopup.Store { Object store method } + ); + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED PUBLIC VARIABLES } +{---------------------------------------------------------------------------} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} +USES + Video; + +CONST +{$ifdef FV_UNICODE} + SubMenuChar : array[boolean] of WideChar = ('>',#$25BA); +{$else FV_UNICODE} + SubMenuChar : array[boolean] of char = ('>',#16); +{$endif FV_UNICODE} + { SubMenuChar is the character displayed at right of submenu } + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMenuView OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMenuView----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMenuView.Init (Var Bounds: TRect); +BEGIN + Inherited Init(Bounds); { Call ancestor } + EventMask := EventMask OR evBroadcast; { See broadcast events } +END; + +{--TMenuView----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMenuView.Load (Var S: TStream); + + FUNCTION DoLoadMenu: PMenu; + VAR Tok: Byte; Item: PMenuItem; Last: ^PMenuItem; HMenu: PMenu; + BEGIN + New(HMenu); { Create new menu } + Last := @HMenu^.Items; { Start on first item } + Item := Nil; { Clear pointer } + S.Read(Tok, SizeOf(Tok)); { Read token } + While (Tok <> 0) Do Begin + New(Item); { Create new item } + Last^ := Item; { First part of chain } + If (Item <> Nil) Then Begin { Check item valid } + Last := @Item^.Next; { Complete chain } + With Item^ Do Begin +{$ifdef FV_UNICODE} + Name := S.ReadUnicodeString; { Read menu name } +{$else FV_UNICODE} + Name := S.ReadStr; { Read menu name } +{$endif FV_UNICODE} + S.Read(Command, SizeOf(Command)); { Menu item command } + S.Read(Disabled, SizeOf(Disabled)); { Menu item state } + S.Read(KeyCode, SizeOf(KeyCode)); { Menu item keycode } + S.Read(HelpCtx, SizeOf(HelpCtx)); { Menu item help ctx } + If (Name <> Sw_PString_Empty) Then + If Command = 0 Then +{$ifdef PPC_FPC} + SubMenu := DoLoadMenu() { Load submenu } +{$else not PPC_FPC} + SubMenu := DoLoadMenu { Load submenu } +{$endif not PPC_FPC} +{$ifdef FV_UNICODE} + Else Param := S.ReadUnicodeString; { Read param string } +{$else FV_UNICODE} + Else Param := S.ReadStr; { Read param string } +{$endif FV_UNICODE} + End; + End; + S.Read(Tok, SizeOf(Tok)); { Read token } + End; + Last^ := Nil; { List complete } + HMenu^.Default := HMenu^.Items; { Set menu default } + DoLoadMenu := HMenu; { Return menu } + End; + +BEGIN + Inherited Load(S); { Call ancestor } + Menu := DoLoadMenu; { Load menu items } +END; + +{--TMenuView----------------------------------------------------------------} +{ Execute -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.Execute: Word; +TYPE MenuAction = (DoNothing, DoSelect, DoReturn); +VAR AutoSelect: Boolean; Action: MenuAction; Ch: Char; Res: Word; R: TRect; + ItemShown, P: PMenuItem; Target: PMenuView; E: TEvent; MouseActive: Boolean; + + PROCEDURE TrackMouse; + VAR Mouse: TPoint; R: TRect; + BEGIN + Mouse.X := E.Where.X - Origin.X; { Local x position } + Mouse.Y := E.Where.Y - oRigin.Y; { Local y position } + Current := Menu^.Items; { Start with current } + While (Current <> Nil) Do Begin + GetItemRectX(Current, R); { Get item rectangle } + If R.Contains(Mouse) Then Begin { Contains mouse } + MouseActive := True; { Return true } + Exit; { Then exit } + End; + Current := Current^.Next; { Try next item } + End; + END; + + PROCEDURE TrackKey (FindNext: Boolean); + + PROCEDURE NextItem; + BEGIN + Current := Current^.Next; { Move to next item } + If (Current = Nil) Then + Current := Menu^.Items; { Return first menu } + END; + + PROCEDURE PrevItem; + VAR P: PMenuItem; + BEGIN + P := Current; { Start on current } + If (P = Menu^.Items) Then P := Nil; { Check if at start } + Repeat NextItem Until Current^.Next = P; { Prev item found } + END; + + BEGIN + If (Current <> Nil) Then { Current view valid } + Repeat + If FindNext Then NextItem Else PrevItem; { Find next/prev item } + Until (Current^.Name <> Sw_PString_Empty); { Until we have name } + END; + + FUNCTION MouseInOwner: Boolean; + VAR Mouse: TPoint; R: TRect; + BEGIN + MouseInOwner := False; { Preset false } + If (ParentMenu <> Nil) AND (ParentMenu^.Size.Y = 1) + Then Begin { Valid parent menu } + Mouse.X := E.Where.X - ParentMenu^.Origin.X;{ Local x position } + Mouse.Y := E.Where.Y - ParentMenu^.Origin.Y;{ Local y position } + ParentMenu^.GetItemRectX(ParentMenu^.Current,R);{ Get item rect } + MouseInOwner := R.Contains(Mouse); { Return result } + End; + END; + + FUNCTION MouseInMenus: Boolean; + VAR P: PMenuView; + BEGIN + P := ParentMenu; { Parent menu } + While (P <> Nil) AND NOT P^.MouseInView(E.Where) + Do P := P^.ParentMenu; { Check next menu } + MouseInMenus := (P <> Nil); { Return result } + END; + + FUNCTION TopMenu: PMenuView; + VAR P: PMenuView; + BEGIN + P := @Self; { Start with self } + While (P^.ParentMenu <> Nil) Do + P := P^.ParentMenu; { Check next menu } + TopMenu := P; { Top menu } + END; + +BEGIN + AutoSelect := False; { Clear select flag } + MouseActive := False; { Clear mouse flag } + Res := 0; { Clear result } + ItemShown := Nil; { Clear item pointer } + If (Menu <> Nil) Then Current := Menu^.Default { Set current item } + Else Current := Nil; { No menu = no current } + Repeat + Action := DoNothing; { Clear action flag } + GetEvent(E); { Get next event } + Case E.What Of + evMouseDown: If MouseInView(E.Where) { Mouse in us } + OR MouseInOwner Then Begin { Mouse in owner area } + TrackMouse; { Track the mouse } + If (Size.Y = 1) Then AutoSelect := True; { Set select flag } + End Else Action := DoReturn; { Set return action } + evMouseUp: Begin + TrackMouse; { Track the mouse } + If MouseInOwner Then { Mouse in owner } + Current := Menu^.Default { Set as current } + Else If (Current <> Nil) AND + (Current^.Name <> Sw_PString_Empty) Then + Action := DoSelect { Set select action } + Else If MouseActive OR MouseInView(E.Where) + Then Action := DoReturn { Set return action } + Else Begin + Current := Menu^.Default; { Set current item } + If (Current = Nil) Then + Current := Menu^.Items; { Select first item } + Action := DoNothing; { Do nothing action } + End; + End; + evMouseMove: If (E.Buttons <> 0) Then Begin { Mouse moved } + TrackMouse; { Track the mouse } + If NOT (MouseInView(E.Where) OR MouseInOwner) + AND MouseInMenus Then Action := DoReturn; { Set return action } + End; + evKeyDown: + Case CtrlToArrow(E.KeyCode) Of { Check arrow keys } + kbUp, kbDown: If (Size.Y <> 1) Then + TrackKey(CtrlToArrow(E.KeyCode) = kbDown){ Track keyboard } + Else If (E.KeyCode = kbDown) Then { Down arrow } + AutoSelect := True; { Select item } + kbLeft, kbRight: If (ParentMenu = Nil) Then + TrackKey(CtrlToArrow(E.KeyCode)=kbRight) { Track keyboard } + Else Action := DoReturn; { Set return action } + kbHome, kbEnd: If (Size.Y <> 1) Then Begin + Current := Menu^.Items; { Set to first item } + If (E.KeyCode = kbEnd) Then { If the 'end' key } + TrackKey(False); { Move to last item } + End; + kbEnter: Begin + If Size.Y = 1 Then AutoSelect := True; { Select item } + Action := DoSelect; { Return the item } + End; + kbEsc: Begin + Action := DoReturn; { Set return action } + If (ParentMenu = Nil) OR + (ParentMenu^.Size.Y <> 1) Then { Check parent } + ClearEvent(E); { Kill the event } + End; + Else Target := @Self; { Set target as self } + Ch := GetAltChar(E.KeyCode); + If (Ch = #0) Then Ch := E.CharCode Else + Target := TopMenu; { Target is top menu } + P := Target^.FindItem(Ch); { Check for item } + If (P = Nil) Then Begin + P := TopMenu^.HotKey(E.KeyCode); { Check for hot key } + If (P <> Nil) AND { Item valid } + CommandEnabled(P^.Command) Then Begin { Command enabled } + Res := P^.Command; { Set return command } + Action := DoReturn; { Set return action } + End + End Else If Target = @Self Then Begin + If Size.Y = 1 Then AutoSelect := True; { Set auto select } + Action := DoSelect; { Select item } + Current := P; { Set current item } + End Else If (ParentMenu <> Target) OR + (ParentMenu^.Current <> P) Then { Item different } + Action := DoReturn; { Set return action } + End; + evCommand: If (E.Command = cmMenu) Then Begin { Menu command } + AutoSelect := False; { Dont select item } + If (ParentMenu <> Nil) Then + Action := DoReturn; { Set return action } + End Else Action := DoReturn; { Set return action } + End; + If (ItemShown <> Current) Then Begin { New current item } + OldItem := ItemShown; { Hold old item } + ItemShown := Current; { Hold new item } + DrawView; { Redraw the items } + OldItem := Nil; { Clear old item } + End; + If (Action = DoSelect) OR ((Action = DoNothing) + AND AutoSelect) Then { Item is selecting } + If (Current <> Nil) Then With Current^ Do { Current item valid } + If (Name <> Sw_PString_Empty) Then { Item has a name } + If (Command = 0) Then Begin { Has no command } + If (E.What AND (evMouseDown+evMouseMove) <> 0) + Then PutEvent(E); { Put event on queue } + GetItemRectX(Current, R); { Get area of item } + R.A.X := R.A.X + Origin.X; { Left start point } + R.A.Y := R.B.Y + Origin.Y;{ Top start point } + R.B.X := Owner^.Size.X; { X screen area left } + R.B.Y := Owner^.Size.Y; { Y screen area left } + Target := TopMenu^.NewSubView(R, SubMenu, + @Self); { Create drop menu } + Res := Owner^.ExecView(Target); { Execute dropped view } + Dispose(Target, Done); { Dispose drop view } + End Else If Action = DoSelect Then + Res := Command; { Return result } + If (Res <> 0) AND CommandEnabled(Res) { Check command } + Then Begin + Action := DoReturn; { Return command } + ClearEvent(E); { Clear the event } + End Else Res := 0; { Clear result } + Until (Action = DoReturn); + If (E.What <> evNothing) Then + If (ParentMenu <> Nil) OR (E.What = evCommand) { Check event type } + Then PutEvent(E); { Put event on queue } + If (Current <> Nil) Then Begin + Menu^.Default := Current; { Set new default } + Current := Nil; { Clear current } + DrawView; { Redraw the view } + End; + Execute := Res; { Return result } +END; + +{--TMenuView----------------------------------------------------------------} +{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.GetHelpCtx: Word; +VAR C: PMenuView; +BEGIN + C := @Self; { Start at self } + While (C <> Nil) AND ((C^.Current = Nil) OR + (C^.Current^.HelpCtx = hcNoContext) OR { Has no context } + (C^.Current^.Name = Sw_PString_Empty)) Do + C := C^.ParentMenu; { Parent menu context } + If (C<>Nil) Then GetHelpCtx := C^.Current^.HelpCtx { Current context } + Else GetHelpCtx := hcNoContext; { No help context } +END; + +{--TMenuView----------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.GetPalette: PPalette; +{$IFDEF PPC_DELPHI3} { DELPHI3+ COMPILER } +CONST P: String = CMenuView; { Possible huge string } +{$ELSE} { OTHER COMPILERS } +CONST P: String[Length(CMenuView)] = CMenuView; { Always normal string } +{$ENDIF} +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TMenuView----------------------------------------------------------------} +{ FindItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.FindItem (Ch: Char): PMenuItem; +VAR I: SmallInt; P: PMenuItem; +BEGIN + Ch := UpCase(Ch); { Upper case of char } + P := Menu^.Items; { First menu item } + While (P <> Nil) Do Begin { While item valid } + If (P^.Name <> Sw_PString_Empty) AND (NOT P^.Disabled) { Valid enabled cmd } + Then Begin + I := Pos('~', P^.Name Sw_PString_Deref); { Scan for highlight } + If (I <> 0) AND (Ch = UpCase(P^.Name Sw_PString_Deref[I+1])) { Hotkey char found } + Then Begin + FindItem := P; { Return item } + Exit; { Now exit } + End; + End; + P := P^.Next; { Next item } + End; + FindItem := Nil; { No item found } +END; + +{--TMenuView----------------------------------------------------------------} +{ HotKey -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.HotKey (KeyCode: Word): PMenuItem; + + FUNCTION FindHotKey (P: PMenuItem): PMenuItem; + VAR T: PMenuItem; + BEGIN + While (P <> Nil) Do Begin { While item valid } + If (P^.Name <> Sw_PString_Empty) Then { If valid name } + If (P^.Command = 0) Then Begin { Valid command } + T := FindHotKey(P^.SubMenu^.Items); { Search for hot key } + If (T <> Nil) Then Begin + FindHotKey := T; { Return hotkey } + Exit; { Now exit } + End; + End Else If NOT P^.Disabled AND { Hotkey is enabled } + (P^.KeyCode <> kbNoKey) AND { Valid keycode } + (P^.KeyCode = KeyCode) Then Begin { Key matches request } + FindHotKey := P; { Return hotkey code } + Exit; { Exit } + End; + P := P^.Next; { Next item } + End; + FindHotKey := Nil; { No item found } + END; + +BEGIN + HotKey := FindHotKey(Menu^.Items); { Hot key function } +END; + +{--TMenuView----------------------------------------------------------------} +{ NewSubView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.NewSubView (Var Bounds: TRect; AMenu: PMenu; + AParentMenu: PMenuView): PMenuView; +BEGIN + NewSubView := New(PMenuBox, Init(Bounds, AMenu, + AParentMenu)); { Create a menu box } +END; + +{--TMenuView----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuView.Store (Var S: TStream); + + PROCEDURE DoStoreMenu (AMenu: PMenu); + VAR Item: PMenuItem; Tok: Byte; + BEGIN + Tok := $FF; { Preset max count } + Item := AMenu^.Items; { Start first item } + While (Item <> Nil) Do Begin + With Item^ Do Begin + S.Write(Tok, SizeOf(Tok)); { Write tok value } +{$ifdef FV_UNICODE} + S.WriteUnicodeString(Name); { Write item name } +{$else FV_UNICODE} + S.WriteStr(Name); { Write item name } +{$endif FV_UNICODE} + S.Write(Command, SizeOf(Command)); { Menu item command } + S.Write(Disabled, SizeOf(Disabled)); { Menu item state } + S.Write(KeyCode, SizeOf(KeyCode)); { Menu item keycode } + S.Write(HelpCtx, SizeOf(HelpCtx)); { Menu item help ctx } + If Name <> Sw_PString_Empty Then + If Command = 0 Then DoStoreMenu(SubMenu) +{$ifdef FV_UNICODE} + Else S.WriteUnicodeString(Param); { Write parameter } +{$else FV_UNICODE} + Else S.WriteStr(Param); { Write parameter } +{$endif FV_UNICODE} + End; + Item := Item^.Next; { Next item } + End; + Tok := 0; { Clear tok count } + S.Write(Tok, SizeOf(Tok)); { Write tok value } + END; + +BEGIN + TView.Store(S); { TView.Store called } + DoStoreMenu(Menu); { Store menu items } +END; + +{--TMenuView----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuView.HandleEvent (Var Event: TEvent); +VAR CallDraw: Boolean; P: PMenuItem; + + PROCEDURE UpdateMenu (AMenu: PMenu); + VAR P: PMenuItem; CommandState: Boolean; + BEGIN + P := AMenu^.Items; { Start on first item } + While (P <> Nil) Do Begin + If (P^.Name <> Sw_PString_Empty) Then { Valid name } + If (P^.Command = 0) Then UpdateMenu(P^.SubMenu){ Update menu } + Else Begin + CommandState := CommandEnabled(P^.Command); { Menu item state } + If (P^.Disabled = CommandState) Then Begin + P^.Disabled := NOT CommandState; { Disable item } + CallDraw := True; { Must draw } + End; + End; + P := P^.Next; { Next item } + End; + END; + + PROCEDURE DoSelect; + BEGIN + PutEvent(Event); { Put event on queue } + Event.Command := Owner^.ExecView(@Self); { Execute view } + If (Event.Command <> 0) AND + CommandEnabled(Event.Command) Then Begin + Event.What := evCommand; { Command event } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + End; + ClearEvent(Event); { Clear the event } + END; + +BEGIN + If (Menu <> Nil) Then + Case Event.What Of + evMouseDown: DoSelect; { Select menu item } + evKeyDown: + If (FindItem(GetAltChar(Event.KeyCode)) <> Nil) + Then DoSelect Else Begin { Select menu item } + P := HotKey(Event.KeyCode); { Check for hotkey } + If (P <> Nil) AND + (CommandEnabled(P^.Command)) Then Begin + Event.What := evCommand; { Command event } + Event.Command := P^.Command; { Set command event } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + ClearEvent(Event); { Clear the event } + End; + End; + evCommand: + If Event.Command = cmMenu Then DoSelect; { Select menu item } + evBroadcast: + If (Event.Command = cmCommandSetChanged) { Commands changed } + Then Begin + CallDraw := False; { Preset no redraw } + UpdateMenu(Menu); { Update menu } + If CallDraw Then DrawView; { Redraw if needed } + End; + End; +END; + +{--TMenuView----------------------------------------------------------------} +{ GetItemRectX -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuView.GetItemRectX (Item: PMenuItem; Var R: TRect); +BEGIN { Abstract method } +END; + +{--TMenuView----------------------------------------------------------------} +{ GetItemRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuView.GetItemRect (Item: PMenuItem; Var R: TRect); +BEGIN + GetItemRectX(Item,R); +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMenuBar OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMenuBar-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMenuBar.Init (Var Bounds: TRect; AMenu: PMenu); +BEGIN + Inherited Init(Bounds); { Call ancestor } + GrowMode := gfGrowHiX; { Set grow mode } + Menu := AMenu; { Hold menu item } + Options := Options OR ofPreProcess; { Preprocessing view } +END; + +{--TMenuBar-----------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TMenuBar.Done; +BEGIN + If (Menu <> Nil) Then DisposeMenu(Menu); { Dispose menu items } + Inherited Done; { Call ancestor } +END; + +{--TMenuBar-----------------------------------------------------------------} +{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuBar.Draw; +VAR I, J, CNormal, CSelect, CNormDisabled, CSelDisabled, Color: Word; + P: PMenuItem; B: TDrawBuffer; +BEGIN + CNormal := GetColor($0301); { Normal colour } + CSelect := GetColor($0604); { Select colour } + CNormDisabled := GetColor($0202); { Disabled colour } + CSelDisabled := GetColor($0505); { Select disabled } + MoveChar(B, ' ', Byte(CNormal), Size.X); { Empty bar } + If (Menu <> Nil) Then Begin { Valid menu } + I := 0; { Set start position } + P := Menu^.Items; { First item } + While (P <> Nil) Do Begin + If (P^.Name <> Sw_PString_Empty) Then Begin { Name valid } + If P^.Disabled Then Begin + If (P = Current) Then Color := CSelDisabled{ Select disabled } + Else Color := CNormDisabled { Normal disabled } + End Else Begin + If (P = Current) Then Color := CSelect { Select colour } + Else Color := CNormal; { Normal colour } + End; + J := CStrLen(P^.Name Sw_PString_Deref); { Length of string } + MoveChar(B[I], ' ', Byte(Color), 1); + MoveCStr(B[I+1], P^.Name Sw_PString_Deref, Color); { Name to buffer } + MoveChar(B[I+1+J], ' ', Byte(Color), 1); + Inc(I, J+2); { Advance position } + End; + P := P^.Next; { Next item } + End; + End; + WriteBuf(0, 0, Size.X, 1, B); { Write the string } +END; + +{--TMenuBar-----------------------------------------------------------------} +{ GetItemRectX -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuBar.GetItemRectX (Item: PMenuItem; Var R: TRect); +VAR I: SmallInt; P: PMenuItem; +BEGIN + I := 0; { Preset to zero } + R.Assign(0, 0, 0, 1); { Initial rect size } + P := Menu^.Items; { First item } + While (P <> Nil) Do Begin { While valid item } + R.A.X := I; { Move area along } + If P^.Name <> Sw_PString_Empty Then Begin { Valid name } + R.B.X := R.A.X+CTextWidth(' ' + P^.Name Sw_PString_Deref + ' ');{ Add text width } + I := I + CStrLen(P^.Name Sw_PString_Deref) + 2; { Add item length } + End Else R.B.X := R.A.X; + If (P = Item) Then break; { Requested item found } + P := P^.Next; { Next item } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMenuBox OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMenuBox-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMenuBox.Init (Var Bounds: TRect; AMenu: PMenu; + AParentMenu: PMenuView); +VAR W, H, L: SmallInt; P: PMenuItem; R: TRect; + S: Sw_String; +BEGIN + W := 0; { Clear initial width } + H := 2; { Set initial height } + If (AMenu <> Nil) Then Begin { Valid menu } + P := AMenu^.Items; { Start on first item } + While (P <> Nil) Do Begin { If item valid } + If (P^.Name <> Sw_PString_Empty) Then Begin { Check for name } + S := ' ' + P^.Name Sw_PString_Deref + ' '; { Transfer string } + If (P^.Command <> 0) AND (P^.Param <> Sw_PString_Empty) + Then S := S + ' - ' + P^.Param Sw_PString_Deref; { Add any parameter } + End; + L := CTextWidth(S); { Width of string } + If (L > W) Then W := L; { Hold maximum } + Inc(H); { Inc count of items } + P := P^.Next; { Move to next item } + End; + End; + W := 5 + W; { Longest text width } + R.Copy(Bounds); { Copy the bounds } + If (R.A.X + W < R.B.X) Then R.B.X := R.A.X + W { Shorten if possible } + Else R.A.X := R.B.X - W; { Insufficent space } + R.B.X := R.A.X + W; + If (R.A.Y + H < R.B.Y) Then R.B.Y := R.A.Y + H { Shorten if possible } + Else R.A.Y := R.B.Y - H; { Insufficent height } + Inherited Init(R); { Call ancestor } + State := State OR sfShadow; { Set shadow state } + Options := Options OR ofFramed or ofPreProcess; { View pre processes } + Menu := AMenu; { Hold menu } + ParentMenu := AParentMenu; { Hold parent } +END; + +{--TMenuBox-----------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuBox.Draw; +VAR CNormal, CSelect, CSelectDisabled, CDisabled, Color: Word; Index, Y: SmallInt; + P: PMenuItem; B: TDrawBuffer; + S: SW_String; +Type + FrameLineType = (UpperLine,NormalLine,SeparationLine,LowerLine); +{$ifdef FV_UNICODE} + FrameLineChars = Array[0..2] of WideChar; +{$else FV_UNICODE} + FrameLineChars = Array[0..2] of char; +{$endif FV_UNICODE} +Const + FrameLines : Array[FrameLineType] of FrameLineChars = +{$ifdef FV_UNICODE} + (#$250C#$2500#$2510,#$2502#$0020#$2502,#$251C#$2500#$2524,#$2514#$2500#$2518); +{$else FV_UNICODE} + (#218#196#191,#179#32#179,#195#196#180,#192#196#217); +{$endif FV_UNICODE} + Procedure CreateBorder(LineType : FrameLineType); + Begin + MoveChar(B, ' ', CNormal, 1); + MoveChar(B[1], FrameLines[LineType][0], CNormal, 1); + MoveChar(B[2], FrameLines[LineType][1], Color, Size.X-4); + MoveChar(B[Size.X-2], FrameLines[LineType][2], CNormal, 1); + MoveChar(B[Size.X-1], ' ', CNormal, 1); + End; + + +BEGIN + CNormal := GetColor($0301); { Normal colour } + CSelect := GetColor($0604); { Selected colour } + CDisabled := GetColor($0202); { Disabled colour } + CSelectDisabled := GetColor($0505); { Selected, but disabled } + Color := CNormal; { Normal colour } + CreateBorder(UpperLine); + WriteBuf(0, 0, Size.X, 1, B); { Write the line } + Y := 1; + If (Menu <> Nil) Then Begin { We have a menu } + P := Menu^.Items; { Start on first } + While (P <> Nil) Do Begin { Valid menu item } + Color := CNormal; { Normal colour } + If (P^.Name <> Sw_PString_Empty) Then Begin { Item has text } + If P^.Disabled Then + begin + if (P = Current) then + Color := CSelectDisabled + else + Color := CDisabled; { Is item disabled } + end + else + If (P = Current) Then Color := CSelect; { Select colour } + CreateBorder(NormalLine); + Index:=2; + S := ' ' + P^.Name Sw_PString_Deref + ' '; { Menu string } + MoveCStr(B[Index], S, Color); { Transfer string } + if P^.Command = 0 then + MoveChar(B[Size.X - 4],SubMenuChar[LowAscii], + Byte(Color), 1) else + If (P^.Command <> 0) AND(P^.Param <> Sw_PString_Empty) Then + Begin + MoveCStr(B[Size.X - 3 - CTextWidth(P^.Param Sw_PString_Deref)], P^.Param Sw_PString_Deref, Color); { Add param chars } + S := S + ' - ' + P^.Param Sw_PString_Deref; { Add to string } + End; + If (OldItem = Nil) OR (OldItem = P) OR + (Current = P) Then + Begin { We need to fix draw } + WriteBuf(0, Y, Size.X, 1, B); { Write the whole line } + End; + End Else Begin { no text NewLine } + Color := CNormal; { Normal colour } + CreateBorder(SeparationLine); + WriteBuf(0, Y, Size.X, 1, B); { Write the line } + End; + Inc(Y); { Next line down } + P := P^.Next; { fetch next item } + End; + End; + Color := CNormal; { Normal colour } + CreateBorder(LowerLine); + WriteBuf(0, Size.Y-1, Size.X, 1, B); { Write the line } +END; + + +{--TMenuBox-----------------------------------------------------------------} +{ GetItemRectX -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuBox.GetItemRectX (Item: PMenuItem; Var R: TRect); +VAR X, Y: SmallInt; P: PMenuItem; +BEGIN + Y := 1; { Initial y position } + P := Menu^.Items; { Initial item } + While (P <> Item) Do Begin { Valid item } + Inc(Y); { Inc position } + P := P^.Next; { Next item } + End; + X := 2; { Left/Right margin } + R.Assign(X, Y, Size.X - X, Y + 1); { Assign area } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMenuPopUp OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMenuPopUp---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMenuPopup.Init (Var Bounds: TRect; AMenu: PMenu); +BEGIN + Inherited Init(Bounds, AMenu, Nil); { Call ancestor } +END; + +{--TMenuPopUp---------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TMenuPopup.Done; +BEGIN + If (Menu <> Nil) Then DisposeMenu(Menu); { Dispose menu items } + Inherited Done; { Call ancestor } +END; + +{--TMenuPopUp---------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuPopup.HandleEvent (Var Event: TEvent); +VAR P: PMenuItem; +BEGIN + Case Event.What Of + evKeyDown: Begin + P := FindItem(GetCtrlChar(Event.KeyCode)); { Find the item } + If (P = Nil) Then P := HotKey(Event.KeyCode);{ Try hot key } + If (P <> Nil) AND (CommandEnabled(P^.Command)) + Then Begin { Command valid } + Event.What := evCommand; { Command event } + Event.Command := P^.Command; { Set command value } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + ClearEvent(Event); { Clear the event } + End Else If (GetAltChar(Event.KeyCode) <> #0) + Then ClearEvent(Event); { Clear the event } + End; + End; + Inherited HandleEvent(Event); { Call ancestor } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStatusLine OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TStatusLine--------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStatusLine.Init (Var Bounds: TRect; ADefs: PStatusDef); +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR ofPreProcess; { Pre processing view } + EventMask := EventMask OR evBroadcast; { See broadcasts } + GrowMode := gfGrowLoY + gfGrowHiX + gfGrowHiY; { Set grow modes } + Defs := ADefs; { Set default items } + FindItems; { Find the items } +END; + +{--TStatusLine--------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStatusLine.Load (Var S: TStream); + + FUNCTION DoLoadStatusItems: PStatusItem; + VAR Count: SmallInt; Cur, First: PStatusItem; Last: ^PStatusItem; + BEGIN + Cur := Nil; { Preset nil } + Last := @First; { Start on first item } + S.Read(Count, SizeOf(Count)); { Read count } + While (Count > 0) Do Begin + New(Cur); { New status item } + Last^ := Cur; { First chain part } + If (Cur <> Nil) Then Begin { Check pointer valid } + Last := @Cur^.Next; { Chain complete } +{$ifdef FV_UNICODE} + Cur^.Text := S.ReadUnicodeString; { Read item text } +{$else FV_UNICODE} + Cur^.Text := S.ReadStr; { Read item text } +{$endif FV_UNICODE} + S.Read(Cur^.KeyCode, SizeOf(Cur^.KeyCode)); { Keycode of item } + S.Read(Cur^.Command, SizeOf(Cur^.Command)); { Command of item } + End; + Dec(Count); { One item loaded } + End; + Last^ := Nil; { Now chain end } + DoLoadStatusItems := First; { Return the list } + END; + + FUNCTION DoLoadStatusDefs: PStatusDef; + VAR Count: SmallInt; Cur, First: PStatusDef; Last: ^PStatusDef; + BEGIN + Last := @First; { Start on first } + S.Read(Count, SizeOf(Count)); { Read item count } + While (Count > 0) Do Begin + New(Cur); { New status def } + Last^ := Cur; { First part of chain } + If (Cur <> Nil) Then Begin { Check pointer valid } + Last := @Cur^.Next; { Chain complete } + S.Read(Cur^.Min, SizeOf(Cur^.Min)); { Read min data } + S.Read(Cur^.Max, SizeOf(Cur^.Max)); { Read max data } + Cur^.Items := DoLoadStatusItems; { Set pointer } + End; + Dec(Count); { One item loaded } + End; + Last^ := Nil; { Now chain ends } + DoLoadStatusDefs := First; { Return item list } + END; + +BEGIN + Inherited Load(S); { Call ancestor } + Defs := DoLoadStatusDefs; { Retreive items } + FindItems; { Find the items } +END; + +{--TStatusLine--------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TStatusLine.Done; +VAR T: PStatusDef; + + PROCEDURE DisposeItems (Item: PStatusItem); + VAR T: PStatusItem; + BEGIN + While (Item <> Nil) Do Begin { Item to dispose } + T := Item; { Hold pointer } + Item := Item^.Next; { Move down chain } +{$ifndef FV_UNICODE} + DisposeStr(T^.Text); { Dispose string } +{$endif FV_UNICODE} + Dispose(T); { Dispose item } + End; + END; + +BEGIN + While (Defs <> Nil) Do Begin + T := Defs; { Hold pointer } + Defs := Defs^.Next; { Move down chain } + DisposeItems(T^.Items); { Dispose the item } + Dispose(T); { Dispose status item } + End; + Inherited Done; { Call ancestor } +END; + + +{--TStatusLine--------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStatusLine.GetPalette: PPalette; +{$IFDEF PPC_DELPHI3} { DELPHI3+ COMPILER } +CONST P: String = CStatusLine; { Possible huge string } +{$ELSE} { OTHER COMPILERS } +CONST P: String[Length(CStatusLine)] = CStatusLine; { Always normal string } +{$ENDIF} +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TStatusLine--------------------------------------------------------------} +{ Hint -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStatusLine.Hint (AHelpCtx: Word): Sw_String; +BEGIN + Hint := ''; { Return nothing } +END; + +{--TStatusLine--------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.Draw; +BEGIN + DrawSelect(Nil); { Call draw select } +END; + +{--TStatusLine--------------------------------------------------------------} +{ Update -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.Update; +VAR H: Word; P: PView; +BEGIN + P := TopView; { Get topmost view } + If (P <> Nil) Then H := P^.GetHelpCtx Else { Top views context } + H := hcNoContext; { No context } + If (HelpCtx <> H) Then Begin { Differs from last } + HelpCtx := H; { Hold new context } + FindItems; { Find the item } + DrawView; { Redraw the view } + End; +END; + +{--TStatusLine--------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.Store (Var S: TStream); + + PROCEDURE DoStoreStatusItems (Cur: PStatusItem); + VAR Count: SmallInt; T: PStatusItem; + BEGIN + Count := 0; { Clear count } + T := Cur; { Start on current } + While (T <> Nil) Do Begin + Inc(Count); { Count items } + T := T^.Next; { Next item } + End; + S.Write(Count, SizeOf(Count)); { Write item count } + While (Cur <> Nil) Do Begin +{$ifdef FV_UNICODE} + S.WriteUnicodeString(Cur^.Text); { Store item text } +{$else FV_UNICODE} + S.WriteStr(Cur^.Text); { Store item text } +{$endif FV_UNICODE} + S.Write(Cur^.KeyCode, SizeOf(Cur^.KeyCode)); { Keycode of item } + S.Write(Cur^.Command, SizeOf(Cur^.Command)); { Command of item } + Cur := Cur^.Next; { Move to next item } + End; + END; + + PROCEDURE DoStoreStatusDefs (Cur: PStatusDef); + VAR Count: SmallInt; T: PStatusDef; + BEGIN + Count := 0; { Clear count } + T := Cur; { Current status item } + While (T <> Nil) Do Begin + Inc(Count); { Count items } + T := T^.Next { Next item } + End; + S.Write(Count, 2); { Write item count } + While (Cur <> Nil) Do Begin + With Cur^ Do Begin + S.Write(Cur^.Min, 2); { Write min data } + S.Write(Cur^.Max, 2); { Write max data } + DoStoreStatusItems(Items); { Store the items } + End; + Cur := Cur^.Next; { Next status item } + End; + END; + +BEGIN + TView.Store(S); { TView.Store called } + DoStoreStatusDefs(Defs); { Store status items } +END; + +{--TStatusLine--------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.HandleEvent (Var Event: TEvent); +VAR Mouse: TPoint; T, Tt: PStatusItem; + + FUNCTION ItemMouseIsIn: PStatusItem; + VAR X, Xi: Word; T: PStatusItem; + BEGIN + ItemMouseIsIn := Nil; { Preset fail } + If (Mouse.Y < 0) OR (Mouse.Y > 1) { Outside view height } + Then Exit; { Not in view exit } + X := 0; { Zero x position } + T := Items; { Start at first item } + While (T <> Nil) Do Begin { While item valid } + If (T^.Text <> Sw_PString_Empty) Then Begin { Check valid text } + Xi := X; { Hold initial x value } + X := Xi + CTextWidth(' ' + T^.Text Sw_PString_Deref + ' '); { Add text width } + If (Mouse.X >= Xi) AND (Mouse.X < X) + Then Begin + ItemMouseIsIn := T; { Selected item } + Exit; { Now exit } + End; + End; + T := T^.Next; { Next item } + End; + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evMouseDown: Begin + T := Nil; { Preset ptr to nil } + Repeat + Mouse.X := Event.Where.X - Origin.X; { Local x position } + Mouse.Y := Event.Where.Y - Origin.Y; { Local y position } + Tt := ItemMouseIsIn; { Find selected item } + If (T <> Tt) Then { Item has changed } + DrawSelect(Tt); { Draw new item } + T := Tt { Transfer item } + Until NOT MouseEvent(Event, evMouseMove); { Mouse stopped moving } + If (T <> Nil) AND CommandEnabled(T^.Command) { Check cmd enabled } + Then Begin + Event.What := evCommand; { Command event } + Event.Command := T^.Command; { Set command value } + Event.InfoPtr := Nil; { No info ptr } + PutEvent(Event); { Put event on queue } + End; + ClearEvent(Event); { Clear the event } + DrawSelect(Nil); { Clear the highlight } + End; + evKeyDown: Begin { Key down event } + T := Items; { Start on first item } + While (T <> Nil) Do Begin { For each valid item } + If (Event.KeyCode = T^.KeyCode) AND { Check for hot key } + CommandEnabled(T^.Command) Then Begin { Check cmd enabled } + Event.What := evCommand; { Change to command } + Event.Command := T^.Command; { Set command value } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + ClearEvent(Event); { Clear the event } + Exit; Exit; { Now exit } + End; + T := T^.Next; { Next item } + End; + End; + evBroadcast: + If (Event.Command = cmCommandSetChanged) Then { Command set change } + DrawView; { Redraw view } + End; +END; + +{***************************************************************************} +{ TStatusLine OBJECT PRIVATE METHODS } +{***************************************************************************} + +{--TStatusLine--------------------------------------------------------------} +{ FindItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.FindItems; +VAR P: PStatusDef; +BEGIN + P := Defs; { First status item } + While (P <> Nil) AND ((HelpCtx < P^.Min) OR + (HelpCtx > P^.Max)) Do P := P^.Next; { Find status item } + If (P = Nil) Then Items := Nil Else + Items := P^.Items; { Return found item } +END; + +{--TStatusLine--------------------------------------------------------------} +{ DrawSelect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.DrawSelect (Selected: PStatusItem); +VAR I, L: SmallInt; Color, CSelect, CNormal, CSelDisabled, CNormDisabled: Word; + B: TDrawBuffer; T: PStatusItem; + HintBuf: Sw_String; +BEGIN + CNormal := GetColor($0301); { Normal colour } + CSelect := GetColor($0604); { Select colour } + CNormDisabled := GetColor($0202); { Disabled colour } + CSelDisabled := GetColor($0505); { Select disabled } + MoveChar(B, ' ', Byte(CNormal), Size.X); { Clear the buffer } + T := Items; { First item } + I := 0; { Clear the count } + L := 0; + While (T <> Nil) Do Begin { While valid item } + If (T^.Text <> Sw_PString_Empty) Then Begin { While valid text } + L := CStrLen(' '+T^.Text Sw_PString_Deref+' '); { Text length } + If CommandEnabled(T^.Command) Then Begin { Command enabled } + If T = Selected Then Color := CSelect { Selected colour } + Else Color := CNormal { Normal colour } + End Else + If T = Selected Then Color := CSelDisabled { Selected disabled } + Else Color := CNormDisabled; { Disabled colour } + MoveCStr(B[I], ' '+T^.Text Sw_PString_Deref+' ', Color); { Move text to buf } + Inc(I, L); { Advance position } + End; + T := T^.Next; { Next item } + End; + HintBuf := Hint(HelpCtx); { Get hint string } + If (HintBuf <> '') Then Begin { Hint present } +{$ifdef FV_UNICODE} + MoveChar(B[I], #$2502, Byte(CNormal), 1); { '|' char to buffer } +{$else FV_UNICODE} + {$IFNDEF OS_WINDOWS} + MoveChar(B[I], #179, Byte(CNormal), 1); { '|' char to buffer } + {$ELSE} + MoveChar(B[I], #124, Byte(CNormal), 1); { '|' char to buffer } + {$ENDIF} +{$endif FV_UNICODE} + Inc(I, 2); { Move along } + MoveStr(B[I], HintBuf, Byte(CNormal)); { Move hint to buffer } + I := I + StrWidth(HintBuf); { Hint length } + End; + WriteLine(0, 0, Size.X, 1, B); { Write the buffer } +END; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MENU INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ NewMenu -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewMenu (Items: PMenuItem): PMenu; +VAR P: PMenu; +BEGIN + New(P); { Create new menu } + FillChar(P^,sizeof(TMenu),0); + If (P <> Nil) Then Begin { Check valid pointer } + P^.Items := Items; { Hold item list } + P^.Default := Items; { Set default item } + End; + NewMenu := P; { Return menu } +END; + +{---------------------------------------------------------------------------} +{ DisposeMenu -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DisposeMenu (Menu: PMenu); +VAR P, Q: PMenuItem; +BEGIN + If (Menu <> Nil) Then Begin { Valid menu item } + P := Menu^.Items; { First item in list } + While (P <> Nil) Do Begin { Item is valid } + If (P^.Name <> Sw_PString_Empty) Then Begin { Valid name pointer } +{$ifndef FV_UNICODE} + DisposeStr(P^.Name); { Dispose of name } +{$endif FV_UNICODE} + If (P^.Command <> 0) Then +{$ifndef FV_UNICODE} + DisposeStr(P^.Param) { Dispose parameter } +{$endif FV_UNICODE} + Else + DisposeMenu(P^.SubMenu); { Dispose submenu } + End; + Q := P; { Hold pointer } + P := P^.Next; { Move to next item } + Dispose(Q); { Dispose of item } + End; + Dispose(Menu); { Dispose of menu } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MENU ITEM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ NewLine -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewLine (Next: PMenuItem): PMenuItem; +VAR P: PMenuItem; +BEGIN + New(P); { Allocate memory } + FillChar(P^,sizeof(TMenuItem),0); + If (P <> Nil) Then Begin { Check valid pointer } + P^.Next := Next; { Hold next menu item } + End; + NewLine := P; { Return new line } +END; + +{---------------------------------------------------------------------------} +{ NewItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewItem (Name, Param: TMenuStr; KeyCode: Word; Command: Word; + AHelpCtx: Word; Next: PMenuItem): PMenuItem; +VAR P: PMenuItem; R: TRect; T: PView; +BEGIN + If (Name <> '') AND (Command <> 0) Then Begin + New(P); { Allocate memory } + FillChar(P^,sizeof(TMenuItem),0); + If (P <> Nil) Then Begin { Check valid pointer } + P^.Next := Next; { Hold next item } + P^.Name := Sw_NewStr(Name); { Hold item name } + P^.Command := Command; { Hold item command } + R.Assign(1, 1, 10, 10); { Random assignment } + T := New(PView, Init(R)); { Create a view } + If (T <> Nil) Then Begin + P^.Disabled := NOT T^.CommandEnabled(Command); + Dispose(T, Done); { Dispose of view } + End Else P^.Disabled := True; + P^.KeyCode := KeyCode; { Hold item keycode } + P^.HelpCtx := AHelpCtx; { Hold help context } + P^.Param := Sw_NewStr(Param); { Hold parameter } + End; + NewItem := P; { Return item } + End Else NewItem := Next; { Move forward } +END; + +{---------------------------------------------------------------------------} +{ NewSubMenu -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewSubMenu (Name: TMenuStr; AHelpCtx: Word; SubMenu: PMenu; + Next: PMenuItem): PMenuItem; +VAR P: PMenuItem; +BEGIN + If (Name <> '') AND (SubMenu <> Nil) Then Begin + New(P); { Allocate memory } + FillChar(P^,sizeof(TMenuItem),0); + If (P <> Nil) Then Begin { Check valid pointer } + P^.Next := Next; { Hold next item } + P^.Name := Sw_NewStr(Name); { Hold submenu name } + P^.HelpCtx := AHelpCtx; { Set help context } + P^.SubMenu := SubMenu; { Hold next submenu } + End; + NewSubMenu := P; { Return submenu } + End Else NewSubMenu := Next; { Return next item } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STATUS INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ NewStatusDef -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewStatusDef (AMin, AMax: Word; AItems: PStatusItem; +ANext:PStatusDef): PStatusDef; +VAR T: PStatusDef; +BEGIN + New(T); { Allocate memory } + If (T <> Nil) Then Begin { Check valid pointer } + T^.Next := ANext; { Set next item } + T^.Min := AMin; { Hold min value } + T^.Max := AMax; { Hold max value } + T^.Items := AItems; { Hold item list } + End; + NewStatusDef := T; { Return status } +END; + +{---------------------------------------------------------------------------} +{ NewStatusKey -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewStatusKey (AText: Sw_String; AKeyCode: Word; ACommand: Word; + ANext: PStatusItem): PStatusItem; +VAR T: PStatusItem; +BEGIN + New(T); { Allocate memory } + If (T <> Nil) Then Begin { Check valid pointer } + T^.Text := Sw_NewStr(AText); { Hold text string } + T^.KeyCode := AKeyCode; { Hold keycode } + T^.Command := ACommand; { Hold command } + T^.Next := ANext; { Pointer to next } + End; + NewStatusKey := T; { Return status item } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ RegisterMenus -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterMenus; +BEGIN + RegisterType(RMenuBar); { Register bar menu } + RegisterType(RMenuBox); { Register menu box } + RegisterType(RStatusLine); { Register status line } + RegisterType(RMenuPopup); { Register popup menu } +END; + +END. diff --git a/packages/fv/src/menus.pas b/packages/fv/src/menus.pas index df0242d169..1b93126860 100644 --- a/packages/fv/src/menus.pas +++ b/packages/fv/src/menus.pas @@ -1,1632 +1 @@ -{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} -{ } -{ System independent GRAPHICAL clone of MENUS.PAS } -{ } -{ Interface Copyright (c) 1992 Borland International } -{ } -{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } -{ ldeboer@attglobal.net - primary e-mail addr } -{ ldeboer@starwon.com.au - backup e-mail addr } -{ } -{****************[ THIS CODE IS FREEWARE ]*****************} -{ } -{ This sourcecode is released for the purpose to } -{ promote the pascal language on all platforms. You may } -{ redistribute it and/or modify with the following } -{ DISCLAIMER. } -{ } -{ This SOURCE CODE is distributed "AS IS" WITHOUT } -{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } -{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } -{ } -{*****************[ SUPPORTED PLATFORMS ]******************} -{ } -{ Only Free Pascal Compiler supported } -{ } -{**********************************************************} - -UNIT Menus; - -{$CODEPAGE cp437} - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - INTERFACE -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{====Include file to sort compiler platform out =====================} -{$I platform.inc} -{====================================================================} - -{==== Compiler directives ===========================================} - -{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } - {$F-} { Near calls are okay } - {$A+} { Word Align Data } - {$B-} { Allow short circuit boolean evaluations } - {$O+} { This unit may be overlaid } - {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } - {$P-} { Normal string variables } - {$N-} { No 80x87 code generation } - {$E+} { Emulation is on } -{$ENDIF} - -{$X+} { Extended syntax is ok } -{$R-} { Disable range checking } -{$S-} { Disable Stack Checking } -{$I-} { Disable IO Checking } -{$Q-} { Disable Overflow Checking } -{$V-} { Turn off strict VAR strings } -{====================================================================} - -USES - {$IFDEF OS_WINDOWS} { WIN/NT CODE } - {$IFNDEF PPC_SPEED} { NON SPEED COMPILER } - {$IFDEF PPC_FPC} { FPC WINDOWS COMPILER } - Windows, { Standard unit } - {$ELSE} { OTHER COMPILERS } - WinTypes,WinProcs, { Standard units } - {$ENDIF} - {$ELSE} { SPEEDSOFT COMPILER } - WinBase, WinDef, { Standard units } - {$ENDIF} - {$ENDIF} - - objects, drivers, views, fvconsts; { GFV standard units } - -{***************************************************************************} -{ PUBLIC CONSTANTS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ COLOUR PALETTES } -{---------------------------------------------------------------------------} -CONST - CMenuView = #2#3#4#5#6#7; { Menu colours } - CStatusLine = #2#3#4#5#6#7; { Statusline colours } - -{***************************************************************************} -{ RECORD DEFINITIONS } -{***************************************************************************} -TYPE - TMenuStr = String[31]; { Menu string } - - PMenu = ^TMenu; { Pointer to menu } - -{---------------------------------------------------------------------------} -{ TMenuItem RECORD } -{---------------------------------------------------------------------------} - PMenuItem = ^TMenuItem; - TMenuItem = -{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - PACKED -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - RECORD - Next: PMenuItem; { Next menu item } - Name: PString; { Menu item name } - Command: Word; { Menu item command } - Disabled: Boolean; { Menu item state } - KeyCode: Word; { Menu item keycode } - HelpCtx: Word; { Menu item help ctx } - Case Integer Of - 0: (Param: PString); - 1: (SubMenu: PMenu); - END; - -{---------------------------------------------------------------------------} -{ TMenu RECORD } -{---------------------------------------------------------------------------} - TMenu = -{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - PACKED -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - RECORD - Items: PMenuItem; { Menu item list } - Default: PMenuItem; { Default menu } - END; - -{---------------------------------------------------------------------------} -{ TStatusItem RECORD } -{---------------------------------------------------------------------------} -TYPE - PStatusItem = ^TStatusItem; - TStatusItem = -{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - PACKED -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - RECORD - Next: PStatusItem; { Next status item } - Text: PString; { Text of status item } - KeyCode: Word; { Keycode of item } - Command: Word; { Command of item } - END; - -{---------------------------------------------------------------------------} -{ TStatusDef RECORD } -{---------------------------------------------------------------------------} -TYPE - PStatusDef = ^TStatusDef; - TStatusDef = -{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - PACKED -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - RECORD - Next: PStatusDef; { Next status defined } - Min, Max: Word; { Range of item } - Items: PStatusItem; { Item list } - END; - -{***************************************************************************} -{ OBJECT DEFINITIONS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TMenuView OBJECT - MENU VIEW ANCESTOR OBJECT } -{---------------------------------------------------------------------------} -TYPE - PMenuView = ^TMenuView; - TMenuView = OBJECT (TView) - ParentMenu: PMenuView; { Parent menu } - Menu : PMenu; { Menu item list } - Current : PMenuItem; { Current menu item } - OldItem : PMenuItem; { Old item for draws } - CONSTRUCTOR Init (Var Bounds: TRect); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION Execute: Word; Virtual; - FUNCTION GetHelpCtx: Word; Virtual; - FUNCTION GetPalette: PPalette; Virtual; - FUNCTION FindItem (Ch: Char): PMenuItem; - FUNCTION HotKey (KeyCode: Word): PMenuItem; - FUNCTION NewSubView (Var Bounds: TRect; AMenu: PMenu; - AParentMenu: PMenuView): PMenuView; Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PROCEDURE GetItemRect (Item: PMenuItem; Var R: TRect); Virtual; - private - PROCEDURE GetItemRectX (Item: PMenuItem; Var R: TRect); Virtual; - END; - -{---------------------------------------------------------------------------} -{ TMenuBar OBJECT - MENU BAR OBJECT } -{---------------------------------------------------------------------------} -TYPE - TMenuBar = OBJECT (TMenuView) - CONSTRUCTOR Init (Var Bounds: TRect; AMenu: PMenu); - DESTRUCTOR Done; Virtual; - PROCEDURE Draw; Virtual; - private - PROCEDURE GetItemRectX (Item: PMenuItem; Var R: TRect); Virtual; - END; - PMenuBar = ^TMenuBar; - -{---------------------------------------------------------------------------} -{ TMenuBox OBJECT - BOXED MENU OBJECT } -{---------------------------------------------------------------------------} -TYPE - TMenuBox = OBJECT (TMenuView) - CONSTRUCTOR Init (Var Bounds: TRect; AMenu: PMenu; - AParentMenu: PMenuView); - PROCEDURE Draw; Virtual; - private - PROCEDURE GetItemRectX (Item: PMenuItem; Var R: TRect); Virtual; - END; - PMenuBox = ^TMenuBox; - -{---------------------------------------------------------------------------} -{ TMenuPopUp OBJECT - POPUP MENU OBJECT } -{---------------------------------------------------------------------------} -TYPE - TMenuPopup = OBJECT (TMenuBox) - CONSTRUCTOR Init (Var Bounds: TRect; AMenu: PMenu); - DESTRUCTOR Done; Virtual; - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - END; - PMenuPopup = ^TMenuPopup; - -{---------------------------------------------------------------------------} -{ TStatusLine OBJECT - STATUS LINE OBJECT } -{---------------------------------------------------------------------------} -TYPE - TStatusLine = OBJECT (TView) - Items: PStatusItem; { Status line items } - Defs : PStatusDef; { Status line default } - CONSTRUCTOR Init (Var Bounds: TRect; ADefs: PStatusDef); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION GetPalette: PPalette; Virtual; - FUNCTION Hint (AHelpCtx: Word): String; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE Update; Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PRIVATE - PROCEDURE FindItems; - PROCEDURE DrawSelect (Selected: PStatusItem); - END; - PStatusLine = ^TStatusLine; - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ MENU INTERFACE ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-NewMenu------------------------------------------------------------ -Allocates and returns a pointer to a new TMenu record. Sets the Items -and Default fields of the record to the value given by the parameter. -An error creating will return a nil pointer. -14May98 LdB ----------------------------------------------------------------------} -FUNCTION NewMenu (Items: PMenuItem): PMenu; - -{-DisposeMenu-------------------------------------------------------- -Disposes of all the elements of the specified menu (and all submenus). -14May98 LdB ----------------------------------------------------------------------} -PROCEDURE DisposeMenu (Menu: PMenu); - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ MENU ITEM ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-NewLine------------------------------------------------------------ -Allocates and returns a pointer to a new TMenuItem record that -represents a separator line in a menu box. -An error creating will return a nil pointer. -14May98 LdB ----------------------------------------------------------------------} -FUNCTION NewLine (Next: PMenuItem): PMenuItem; - -{-NewItem------------------------------------------------------------ -Allocates and returns a pointer to a new TMenuItem record that -represents a menu item (using NewStr to allocate the Name and Param). -An error creating will return a nil pointer. -14May98 LdB ----------------------------------------------------------------------} -FUNCTION NewItem (Name, Param: TMenuStr; KeyCode: Word; Command: Word; - AHelpCtx: Word; Next: PMenuItem): PMenuItem; - -{-NewSubMenu--------------------------------------------------------- -Allocates and returns a pointer to a new TMenuItem record, which -represents a submenu (using NewStr to allocate the Name). -An error creating will return a nil pointer. -14May98 LdB ----------------------------------------------------------------------} -FUNCTION NewSubMenu (Name: TMenuStr; AHelpCtx: Word; SubMenu: PMenu; - Next: PMenuItem): PMenuItem; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ STATUS INTERFACE ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-NewStatusDef------------------------------------------------------- -Allocates and returns a pointer to a new TStatusDef record initialized -with the given parameter values. Calls to NewStatusDef can be nested. -An error creating will return a nil pointer. -15May98 LdB ----------------------------------------------------------------------} -FUNCTION NewStatusDef (AMin, AMax: Word; AItems: PStatusItem; - ANext: PStatusDef): PStatusDef; - -{-NewStatusKey------------------------------------------------------- -Allocates and returns a pointer to a new TStatusItem record initialized -with the given parameter values (using NewStr to allocate the Text). -An error in creating will return a nil pointer. -15May98 LdB ----------------------------------------------------------------------} -FUNCTION NewStatusKey (AText: String; AKeyCode: Word; ACommand: Word; - ANext: PStatusItem): PStatusItem; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ OBJECT REGISTER ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{-RegisterMenus------------------------------------------------------- -Calls RegisterType for each of the object types defined in this unit. -15May98 LdB ----------------------------------------------------------------------} -PROCEDURE RegisterMenus; - -{***************************************************************************} -{ OBJECT REGISTRATION } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TMenuBar STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RMenuBar: TStreamRec = ( - ObjType: idMenuBar; { Register id = 40 } - {$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs(TypeOf(TMenuBar)^); - {$ELSE} { Alt style VMT link } - VmtLink: TypeOf(TMenuBar); - {$ENDIF} - Load: @TMenuBar.Load; { Object load method } - Store: @TMenuBar.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TMenuBox STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RMenuBox: TStreamRec = ( - ObjType: idMenuBox; { Register id = 41 } - {$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs(TypeOf(TMenuBox)^); - {$ELSE} { Alt style VMT link } - VmtLink: TypeOf(TMenuBox); - {$ENDIF} - Load: @TMenuBox.Load; { Object load method } - Store: @TMenuBox.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TStatusLine STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RStatusLine: TStreamRec = ( - ObjType: 42; { Register id = 42 } - {$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs(TypeOf(TStatusLine)^); - {$ELSE} { Alt style VMT link } - VmtLink: TypeOf(TStatusLine); - {$ENDIF} - Load: @TStatusLine.Load; { Object load method } - Store: @TStatusLine.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TMenuPopup STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RMenuPopup: TStreamRec = ( - ObjType: 43; { Register id = 43 } - {$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs(TypeOf(TMenuPopup)^); - {$ELSE} { Alt style VMT link } - VmtLink: TypeOf(TMenuPopup); - {$ENDIF} - Load: @TMenuPopup.Load; { Object load method } - Store: @TMenuPopup.Store { Object store method } - ); - -{***************************************************************************} -{ INITIALIZED PUBLIC VARIABLES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ INITIALIZED PUBLIC VARIABLES } -{---------------------------------------------------------------------------} - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IMPLEMENTATION -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} -USES - Video; - -CONST - SubMenuChar : array[boolean] of char = ('>',#16); - { SubMenuChar is the character displayed at right of submenu } - -{***************************************************************************} -{ OBJECT METHODS } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TMenuView OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TMenuView----------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TMenuView.Init (Var Bounds: TRect); -BEGIN - Inherited Init(Bounds); { Call ancestor } - EventMask := EventMask OR evBroadcast; { See broadcast events } -END; - -{--TMenuView----------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TMenuView.Load (Var S: TStream); - - FUNCTION DoLoadMenu: PMenu; - VAR Tok: Byte; Item: PMenuItem; Last: ^PMenuItem; HMenu: PMenu; - BEGIN - New(HMenu); { Create new menu } - Last := @HMenu^.Items; { Start on first item } - Item := Nil; { Clear pointer } - S.Read(Tok, SizeOf(Tok)); { Read token } - While (Tok <> 0) Do Begin - New(Item); { Create new item } - Last^ := Item; { First part of chain } - If (Item <> Nil) Then Begin { Check item valid } - Last := @Item^.Next; { Complete chain } - With Item^ Do Begin - Name := S.ReadStr; { Read menu name } - S.Read(Command, SizeOf(Command)); { Menu item command } - S.Read(Disabled, SizeOf(Disabled)); { Menu item state } - S.Read(KeyCode, SizeOf(KeyCode)); { Menu item keycode } - S.Read(HelpCtx, SizeOf(HelpCtx)); { Menu item help ctx } - If (Name <> Nil) Then - If Command = 0 Then -{$ifdef PPC_FPC} - SubMenu := DoLoadMenu() { Load submenu } -{$else not PPC_FPC} - SubMenu := DoLoadMenu { Load submenu } -{$endif not PPC_FPC} - Else Param := S.ReadStr; { Read param string } - End; - End; - S.Read(Tok, SizeOf(Tok)); { Read token } - End; - Last^ := Nil; { List complete } - HMenu^.Default := HMenu^.Items; { Set menu default } - DoLoadMenu := HMenu; { Return menu } - End; - -BEGIN - Inherited Load(S); { Call ancestor } - Menu := DoLoadMenu; { Load menu items } -END; - -{--TMenuView----------------------------------------------------------------} -{ Execute -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TMenuView.Execute: Word; -TYPE MenuAction = (DoNothing, DoSelect, DoReturn); -VAR AutoSelect: Boolean; Action: MenuAction; Ch: Char; Res: Word; R: TRect; - ItemShown, P: PMenuItem; Target: PMenuView; E: TEvent; MouseActive: Boolean; - - PROCEDURE TrackMouse; - VAR Mouse: TPoint; R: TRect; - BEGIN - Mouse.X := E.Where.X - Origin.X; { Local x position } - Mouse.Y := E.Where.Y - oRigin.Y; { Local y position } - Current := Menu^.Items; { Start with current } - While (Current <> Nil) Do Begin - GetItemRectX(Current, R); { Get item rectangle } - If R.Contains(Mouse) Then Begin { Contains mouse } - MouseActive := True; { Return true } - Exit; { Then exit } - End; - Current := Current^.Next; { Try next item } - End; - END; - - PROCEDURE TrackKey (FindNext: Boolean); - - PROCEDURE NextItem; - BEGIN - Current := Current^.Next; { Move to next item } - If (Current = Nil) Then - Current := Menu^.Items; { Return first menu } - END; - - PROCEDURE PrevItem; - VAR P: PMenuItem; - BEGIN - P := Current; { Start on current } - If (P = Menu^.Items) Then P := Nil; { Check if at start } - Repeat NextItem Until Current^.Next = P; { Prev item found } - END; - - BEGIN - If (Current <> Nil) Then { Current view valid } - Repeat - If FindNext Then NextItem Else PrevItem; { Find next/prev item } - Until (Current^.Name <> Nil); { Until we have name } - END; - - FUNCTION MouseInOwner: Boolean; - VAR Mouse: TPoint; R: TRect; - BEGIN - MouseInOwner := False; { Preset false } - If (ParentMenu <> Nil) AND (ParentMenu^.Size.Y = 1) - Then Begin { Valid parent menu } - Mouse.X := E.Where.X - ParentMenu^.Origin.X;{ Local x position } - Mouse.Y := E.Where.Y - ParentMenu^.Origin.Y;{ Local y position } - ParentMenu^.GetItemRectX(ParentMenu^.Current,R);{ Get item rect } - MouseInOwner := R.Contains(Mouse); { Return result } - End; - END; - - FUNCTION MouseInMenus: Boolean; - VAR P: PMenuView; - BEGIN - P := ParentMenu; { Parent menu } - While (P <> Nil) AND NOT P^.MouseInView(E.Where) - Do P := P^.ParentMenu; { Check next menu } - MouseInMenus := (P <> Nil); { Return result } - END; - - FUNCTION TopMenu: PMenuView; - VAR P: PMenuView; - BEGIN - P := @Self; { Start with self } - While (P^.ParentMenu <> Nil) Do - P := P^.ParentMenu; { Check next menu } - TopMenu := P; { Top menu } - END; - -BEGIN - AutoSelect := False; { Clear select flag } - MouseActive := False; { Clear mouse flag } - Res := 0; { Clear result } - ItemShown := Nil; { Clear item pointer } - If (Menu <> Nil) Then Current := Menu^.Default { Set current item } - Else Current := Nil; { No menu = no current } - Repeat - Action := DoNothing; { Clear action flag } - GetEvent(E); { Get next event } - Case E.What Of - evMouseDown: If MouseInView(E.Where) { Mouse in us } - OR MouseInOwner Then Begin { Mouse in owner area } - TrackMouse; { Track the mouse } - If (Size.Y = 1) Then AutoSelect := True; { Set select flag } - End Else Action := DoReturn; { Set return action } - evMouseUp: Begin - TrackMouse; { Track the mouse } - If MouseInOwner Then { Mouse in owner } - Current := Menu^.Default { Set as current } - Else If (Current <> Nil) AND - (Current^.Name <> Nil) Then - Action := DoSelect { Set select action } - Else If MouseActive OR MouseInView(E.Where) - Then Action := DoReturn { Set return action } - Else Begin - Current := Menu^.Default; { Set current item } - If (Current = Nil) Then - Current := Menu^.Items; { Select first item } - Action := DoNothing; { Do nothing action } - End; - End; - evMouseMove: If (E.Buttons <> 0) Then Begin { Mouse moved } - TrackMouse; { Track the mouse } - If NOT (MouseInView(E.Where) OR MouseInOwner) - AND MouseInMenus Then Action := DoReturn; { Set return action } - End; - evKeyDown: - Case CtrlToArrow(E.KeyCode) Of { Check arrow keys } - kbUp, kbDown: If (Size.Y <> 1) Then - TrackKey(CtrlToArrow(E.KeyCode) = kbDown){ Track keyboard } - Else If (E.KeyCode = kbDown) Then { Down arrow } - AutoSelect := True; { Select item } - kbLeft, kbRight: If (ParentMenu = Nil) Then - TrackKey(CtrlToArrow(E.KeyCode)=kbRight) { Track keyboard } - Else Action := DoReturn; { Set return action } - kbHome, kbEnd: If (Size.Y <> 1) Then Begin - Current := Menu^.Items; { Set to first item } - If (E.KeyCode = kbEnd) Then { If the 'end' key } - TrackKey(False); { Move to last item } - End; - kbEnter: Begin - If Size.Y = 1 Then AutoSelect := True; { Select item } - Action := DoSelect; { Return the item } - End; - kbEsc: Begin - Action := DoReturn; { Set return action } - If (ParentMenu = Nil) OR - (ParentMenu^.Size.Y <> 1) Then { Check parent } - ClearEvent(E); { Kill the event } - End; - Else Target := @Self; { Set target as self } - Ch := GetAltChar(E.KeyCode); - If (Ch = #0) Then Ch := E.CharCode Else - Target := TopMenu; { Target is top menu } - P := Target^.FindItem(Ch); { Check for item } - If (P = Nil) Then Begin - P := TopMenu^.HotKey(E.KeyCode); { Check for hot key } - If (P <> Nil) AND { Item valid } - CommandEnabled(P^.Command) Then Begin { Command enabled } - Res := P^.Command; { Set return command } - Action := DoReturn; { Set return action } - End - End Else If Target = @Self Then Begin - If Size.Y = 1 Then AutoSelect := True; { Set auto select } - Action := DoSelect; { Select item } - Current := P; { Set current item } - End Else If (ParentMenu <> Target) OR - (ParentMenu^.Current <> P) Then { Item different } - Action := DoReturn; { Set return action } - End; - evCommand: If (E.Command = cmMenu) Then Begin { Menu command } - AutoSelect := False; { Dont select item } - If (ParentMenu <> Nil) Then - Action := DoReturn; { Set return action } - End Else Action := DoReturn; { Set return action } - End; - If (ItemShown <> Current) Then Begin { New current item } - OldItem := ItemShown; { Hold old item } - ItemShown := Current; { Hold new item } - DrawView; { Redraw the items } - OldItem := Nil; { Clear old item } - End; - If (Action = DoSelect) OR ((Action = DoNothing) - AND AutoSelect) Then { Item is selecting } - If (Current <> Nil) Then With Current^ Do { Current item valid } - If (Name <> Nil) Then { Item has a name } - If (Command = 0) Then Begin { Has no command } - If (E.What AND (evMouseDown+evMouseMove) <> 0) - Then PutEvent(E); { Put event on queue } - GetItemRectX(Current, R); { Get area of item } - R.A.X := R.A.X + Origin.X; { Left start point } - R.A.Y := R.B.Y + Origin.Y;{ Top start point } - R.B.X := Owner^.Size.X; { X screen area left } - R.B.Y := Owner^.Size.Y; { Y screen area left } - Target := TopMenu^.NewSubView(R, SubMenu, - @Self); { Create drop menu } - Res := Owner^.ExecView(Target); { Execute dropped view } - Dispose(Target, Done); { Dispose drop view } - End Else If Action = DoSelect Then - Res := Command; { Return result } - If (Res <> 0) AND CommandEnabled(Res) { Check command } - Then Begin - Action := DoReturn; { Return command } - ClearEvent(E); { Clear the event } - End Else Res := 0; { Clear result } - Until (Action = DoReturn); - If (E.What <> evNothing) Then - If (ParentMenu <> Nil) OR (E.What = evCommand) { Check event type } - Then PutEvent(E); { Put event on queue } - If (Current <> Nil) Then Begin - Menu^.Default := Current; { Set new default } - Current := Nil; { Clear current } - DrawView; { Redraw the view } - End; - Execute := Res; { Return result } -END; - -{--TMenuView----------------------------------------------------------------} -{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TMenuView.GetHelpCtx: Word; -VAR C: PMenuView; -BEGIN - C := @Self; { Start at self } - While (C <> Nil) AND ((C^.Current = Nil) OR - (C^.Current^.HelpCtx = hcNoContext) OR { Has no context } - (C^.Current^.Name = Nil)) Do C := C^.ParentMenu; { Parent menu context } - If (C<>Nil) Then GetHelpCtx := C^.Current^.HelpCtx { Current context } - Else GetHelpCtx := hcNoContext; { No help context } -END; - -{--TMenuView----------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TMenuView.GetPalette: PPalette; -{$IFDEF PPC_DELPHI3} { DELPHI3+ COMPILER } -CONST P: String = CMenuView; { Possible huge string } -{$ELSE} { OTHER COMPILERS } -CONST P: String[Length(CMenuView)] = CMenuView; { Always normal string } -{$ENDIF} -BEGIN - GetPalette := PPalette(@P); { Return palette } -END; - -{--TMenuView----------------------------------------------------------------} -{ FindItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TMenuView.FindItem (Ch: Char): PMenuItem; -VAR I: Integer; P: PMenuItem; -BEGIN - Ch := UpCase(Ch); { Upper case of char } - P := Menu^.Items; { First menu item } - While (P <> Nil) Do Begin { While item valid } - If (P^.Name <> Nil) AND (NOT P^.Disabled) { Valid enabled cmd } - Then Begin - I := Pos('~', P^.Name^); { Scan for highlight } - If (I <> 0) AND (Ch = UpCase(P^.Name^[I+1])) { Hotkey char found } - Then Begin - FindItem := P; { Return item } - Exit; { Now exit } - End; - End; - P := P^.Next; { Next item } - End; - FindItem := Nil; { No item found } -END; - -{--TMenuView----------------------------------------------------------------} -{ HotKey -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TMenuView.HotKey (KeyCode: Word): PMenuItem; - - FUNCTION FindHotKey (P: PMenuItem): PMenuItem; - VAR T: PMenuItem; - BEGIN - While (P <> Nil) Do Begin { While item valid } - If (P^.Name <> Nil) Then { If valid name } - If (P^.Command = 0) Then Begin { Valid command } - T := FindHotKey(P^.SubMenu^.Items); { Search for hot key } - If (T <> Nil) Then Begin - FindHotKey := T; { Return hotkey } - Exit; { Now exit } - End; - End Else If NOT P^.Disabled AND { Hotkey is enabled } - (P^.KeyCode <> kbNoKey) AND { Valid keycode } - (P^.KeyCode = KeyCode) Then Begin { Key matches request } - FindHotKey := P; { Return hotkey code } - Exit; { Exit } - End; - P := P^.Next; { Next item } - End; - FindHotKey := Nil; { No item found } - END; - -BEGIN - HotKey := FindHotKey(Menu^.Items); { Hot key function } -END; - -{--TMenuView----------------------------------------------------------------} -{ NewSubView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TMenuView.NewSubView (Var Bounds: TRect; AMenu: PMenu; - AParentMenu: PMenuView): PMenuView; -BEGIN - NewSubView := New(PMenuBox, Init(Bounds, AMenu, - AParentMenu)); { Create a menu box } -END; - -{--TMenuView----------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMenuView.Store (Var S: TStream); - - PROCEDURE DoStoreMenu (AMenu: PMenu); - VAR Item: PMenuItem; Tok: Byte; - BEGIN - Tok := $FF; { Preset max count } - Item := AMenu^.Items; { Start first item } - While (Item <> Nil) Do Begin - With Item^ Do Begin - S.Write(Tok, SizeOf(Tok)); { Write tok value } - S.WriteStr(Name); { Write item name } - S.Write(Command, SizeOf(Command)); { Menu item command } - S.Write(Disabled, SizeOf(Disabled)); { Menu item state } - S.Write(KeyCode, SizeOf(KeyCode)); { Menu item keycode } - S.Write(HelpCtx, SizeOf(HelpCtx)); { Menu item help ctx } - If (Name <> Nil) Then - If Command = 0 Then DoStoreMenu(SubMenu) - Else S.WriteStr(Param); { Write parameter } - End; - Item := Item^.Next; { Next item } - End; - Tok := 0; { Clear tok count } - S.Write(Tok, SizeOf(Tok)); { Write tok value } - END; - -BEGIN - TView.Store(S); { TView.Store called } - DoStoreMenu(Menu); { Store menu items } -END; - -{--TMenuView----------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMenuView.HandleEvent (Var Event: TEvent); -VAR CallDraw: Boolean; P: PMenuItem; - - PROCEDURE UpdateMenu (AMenu: PMenu); - VAR P: PMenuItem; CommandState: Boolean; - BEGIN - P := AMenu^.Items; { Start on first item } - While (P <> Nil) Do Begin - If (P^.Name <> Nil) Then { Valid name } - If (P^.Command = 0) Then UpdateMenu(P^.SubMenu){ Update menu } - Else Begin - CommandState := CommandEnabled(P^.Command); { Menu item state } - If (P^.Disabled = CommandState) Then Begin - P^.Disabled := NOT CommandState; { Disable item } - CallDraw := True; { Must draw } - End; - End; - P := P^.Next; { Next item } - End; - END; - - PROCEDURE DoSelect; - BEGIN - PutEvent(Event); { Put event on queue } - Event.Command := Owner^.ExecView(@Self); { Execute view } - If (Event.Command <> 0) AND - CommandEnabled(Event.Command) Then Begin - Event.What := evCommand; { Command event } - Event.InfoPtr := Nil; { Clear info ptr } - PutEvent(Event); { Put event on queue } - End; - ClearEvent(Event); { Clear the event } - END; - -BEGIN - If (Menu <> Nil) Then - Case Event.What Of - evMouseDown: DoSelect; { Select menu item } - evKeyDown: - If (FindItem(GetAltChar(Event.KeyCode)) <> Nil) - Then DoSelect Else Begin { Select menu item } - P := HotKey(Event.KeyCode); { Check for hotkey } - If (P <> Nil) AND - (CommandEnabled(P^.Command)) Then Begin - Event.What := evCommand; { Command event } - Event.Command := P^.Command; { Set command event } - Event.InfoPtr := Nil; { Clear info ptr } - PutEvent(Event); { Put event on queue } - ClearEvent(Event); { Clear the event } - End; - End; - evCommand: - If Event.Command = cmMenu Then DoSelect; { Select menu item } - evBroadcast: - If (Event.Command = cmCommandSetChanged) { Commands changed } - Then Begin - CallDraw := False; { Preset no redraw } - UpdateMenu(Menu); { Update menu } - If CallDraw Then DrawView; { Redraw if needed } - End; - End; -END; - -{--TMenuView----------------------------------------------------------------} -{ GetItemRectX -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMenuView.GetItemRectX (Item: PMenuItem; Var R: TRect); -BEGIN { Abstract method } -END; - -{--TMenuView----------------------------------------------------------------} -{ GetItemRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMenuView.GetItemRect (Item: PMenuItem; Var R: TRect); -BEGIN - GetItemRectX(Item,R); -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TMenuBar OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TMenuBar-----------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TMenuBar.Init (Var Bounds: TRect; AMenu: PMenu); -BEGIN - Inherited Init(Bounds); { Call ancestor } - GrowMode := gfGrowHiX; { Set grow mode } - Menu := AMenu; { Hold menu item } - Options := Options OR ofPreProcess; { Preprocessing view } -END; - -{--TMenuBar-----------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TMenuBar.Done; -BEGIN - If (Menu <> Nil) Then DisposeMenu(Menu); { Dispose menu items } - Inherited Done; { Call ancestor } -END; - -{--TMenuBar-----------------------------------------------------------------} -{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMenuBar.Draw; -VAR I, J, CNormal, CSelect, CNormDisabled, CSelDisabled, Color: Word; - P: PMenuItem; B: TDrawBuffer; -BEGIN - CNormal := GetColor($0301); { Normal colour } - CSelect := GetColor($0604); { Select colour } - CNormDisabled := GetColor($0202); { Disabled colour } - CSelDisabled := GetColor($0505); { Select disabled } - MoveChar(B, ' ', Byte(CNormal), Size.X); { Empty bar } - If (Menu <> Nil) Then Begin { Valid menu } - I := 0; { Set start position } - P := Menu^.Items; { First item } - While (P <> Nil) Do Begin - If (P^.Name <> Nil) Then Begin { Name valid } - If P^.Disabled Then Begin - If (P = Current) Then Color := CSelDisabled{ Select disabled } - Else Color := CNormDisabled { Normal disabled } - End Else Begin - If (P = Current) Then Color := CSelect { Select colour } - Else Color := CNormal; { Normal colour } - End; - J := CStrLen(P^.Name^); { Length of string } - MoveChar(B[I], ' ', Byte(Color), 1); - MoveCStr(B[I+1], P^.Name^, Color); { Name to buffer } - MoveChar(B[I+1+J], ' ', Byte(Color), 1); - Inc(I, J+2); { Advance position } - End; - P := P^.Next; { Next item } - End; - End; - WriteBuf(0, 0, Size.X, 1, B); { Write the string } -END; - -{--TMenuBar-----------------------------------------------------------------} -{ GetItemRectX -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMenuBar.GetItemRectX (Item: PMenuItem; Var R: TRect); -VAR I: Integer; P: PMenuItem; -BEGIN - I := 0; { Preset to zero } - R.Assign(0, 0, 0, 1); { Initial rect size } - P := Menu^.Items; { First item } - While (P <> Nil) Do Begin { While valid item } - R.A.X := I; { Move area along } - If (P^.Name <> Nil) Then Begin { Valid name } - R.B.X := R.A.X+CTextWidth(' ' + P^.Name^ + ' ');{ Add text width } - I := I + CStrLen(P^.Name^) + 2; { Add item length } - End Else R.B.X := R.A.X; - If (P = Item) Then break; { Requested item found } - P := P^.Next; { Next item } - End; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TMenuBox OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TMenuBox-----------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TMenuBox.Init (Var Bounds: TRect; AMenu: PMenu; - AParentMenu: PMenuView); -VAR W, H, L: Integer; S: String; P: PMenuItem; R: TRect; -BEGIN - W := 0; { Clear initial width } - H := 2; { Set initial height } - If (AMenu <> Nil) Then Begin { Valid menu } - P := AMenu^.Items; { Start on first item } - While (P <> Nil) Do Begin { If item valid } - If (P^.Name <> Nil) Then Begin { Check for name } - S := ' ' + P^.Name^ + ' '; { Transfer string } - If (P^.Command <> 0) AND (P^.Param <> Nil) - Then S := S + ' - ' + P^.Param^; { Add any parameter } - End; - L := CTextWidth(S); { Width of string } - If (L > W) Then W := L; { Hold maximum } - Inc(H); { Inc count of items } - P := P^.Next; { Move to next item } - End; - End; - W := 5 + W; { Longest text width } - R.Copy(Bounds); { Copy the bounds } - If (R.A.X + W < R.B.X) Then R.B.X := R.A.X + W { Shorten if possible } - Else R.A.X := R.B.X - W; { Insufficent space } - R.B.X := R.A.X + W; - If (R.A.Y + H < R.B.Y) Then R.B.Y := R.A.Y + H { Shorten if possible } - Else R.A.Y := R.B.Y - H; { Insufficent height } - Inherited Init(R); { Call ancestor } - State := State OR sfShadow; { Set shadow state } - Options := Options OR ofFramed or ofPreProcess; { View pre processes } - Menu := AMenu; { Hold menu } - ParentMenu := AParentMenu; { Hold parent } -END; - -{--TMenuBox-----------------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMenuBox.Draw; -VAR CNormal, CSelect, CSelectDisabled, CDisabled, Color: Word; Index, Y: Integer; - S: String; P: PMenuItem; B: TDrawBuffer; -Type - FrameLineType = (UpperLine,NormalLine,SeparationLine,LowerLine); - FrameLineChars = Array[0..2] of char; -Const - FrameLines : Array[FrameLineType] of FrameLineChars = - ('ÚÄ¿','³ ³','ÃÄ´','ÀÄÙ'); - Procedure CreateBorder(LineType : FrameLineType); - Begin - MoveChar(B, ' ', CNormal, 1); - MoveChar(B[1], FrameLines[LineType][0], CNormal, 1); - MoveChar(B[2], FrameLines[LineType][1], Color, Size.X-4); - MoveChar(B[Size.X-2], FrameLines[LineType][2], CNormal, 1); - MoveChar(B[Size.X-1], ' ', CNormal, 1); - End; - - -BEGIN - CNormal := GetColor($0301); { Normal colour } - CSelect := GetColor($0604); { Selected colour } - CDisabled := GetColor($0202); { Disabled colour } - CSelectDisabled := GetColor($0505); { Selected, but disabled } - Color := CNormal; { Normal colour } - CreateBorder(UpperLine); - WriteBuf(0, 0, Size.X, 1, B); { Write the line } - Y := 1; - If (Menu <> Nil) Then Begin { We have a menu } - P := Menu^.Items; { Start on first } - While (P <> Nil) Do Begin { Valid menu item } - Color := CNormal; { Normal colour } - If (P^.Name <> Nil) Then Begin { Item has text } - If P^.Disabled Then - begin - if (P = Current) then - Color := CSelectDisabled - else - Color := CDisabled; { Is item disabled } - end - else - If (P = Current) Then Color := CSelect; { Select colour } - CreateBorder(NormalLine); - Index:=2; - S := ' ' + P^.Name^ + ' '; { Menu string } - MoveCStr(B[Index], S, Color); { Transfer string } - if P^.Command = 0 then - MoveChar(B[Size.X - 4],SubMenuChar[LowAscii], - Byte(Color), 1) else - If (P^.Command <> 0) AND(P^.Param <> Nil) Then - Begin - MoveCStr(B[Size.X - 3 - Length(P^.Param^)], P^.Param^, Color); { Add param chars } - S := S + ' - ' + P^.Param^; { Add to string } - End; - If (OldItem = Nil) OR (OldItem = P) OR - (Current = P) Then - Begin { We need to fix draw } - WriteBuf(0, Y, Size.X, 1, B); { Write the whole line } - End; - End Else Begin { no text NewLine } - Color := CNormal; { Normal colour } - CreateBorder(SeparationLine); - WriteBuf(0, Y, Size.X, 1, B); { Write the line } - End; - Inc(Y); { Next line down } - P := P^.Next; { fetch next item } - End; - End; - Color := CNormal; { Normal colour } - CreateBorder(LowerLine); - WriteBuf(0, Size.Y-1, Size.X, 1, B); { Write the line } -END; - - -{--TMenuBox-----------------------------------------------------------------} -{ GetItemRectX -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMenuBox.GetItemRectX (Item: PMenuItem; Var R: TRect); -VAR X, Y: Integer; P: PMenuItem; -BEGIN - Y := 1; { Initial y position } - P := Menu^.Items; { Initial item } - While (P <> Item) Do Begin { Valid item } - Inc(Y); { Inc position } - P := P^.Next; { Next item } - End; - X := 2; { Left/Right margin } - R.Assign(X, Y, Size.X - X, Y + 1); { Assign area } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TMenuPopUp OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TMenuPopUp---------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TMenuPopup.Init (Var Bounds: TRect; AMenu: PMenu); -BEGIN - Inherited Init(Bounds, AMenu, Nil); { Call ancestor } -END; - -{--TMenuPopUp---------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TMenuPopup.Done; -BEGIN - If (Menu <> Nil) Then DisposeMenu(Menu); { Dispose menu items } - Inherited Done; { Call ancestor } -END; - -{--TMenuPopUp---------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TMenuPopup.HandleEvent (Var Event: TEvent); -VAR P: PMenuItem; -BEGIN - Case Event.What Of - evKeyDown: Begin - P := FindItem(GetCtrlChar(Event.KeyCode)); { Find the item } - If (P = Nil) Then P := HotKey(Event.KeyCode);{ Try hot key } - If (P <> Nil) AND (CommandEnabled(P^.Command)) - Then Begin { Command valid } - Event.What := evCommand; { Command event } - Event.Command := P^.Command; { Set command value } - Event.InfoPtr := Nil; { Clear info ptr } - PutEvent(Event); { Put event on queue } - ClearEvent(Event); { Clear the event } - End Else If (GetAltChar(Event.KeyCode) <> #0) - Then ClearEvent(Event); { Clear the event } - End; - End; - Inherited HandleEvent(Event); { Call ancestor } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TStatusLine OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TStatusLine--------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TStatusLine.Init (Var Bounds: TRect; ADefs: PStatusDef); -BEGIN - Inherited Init(Bounds); { Call ancestor } - Options := Options OR ofPreProcess; { Pre processing view } - EventMask := EventMask OR evBroadcast; { See broadcasts } - GrowMode := gfGrowLoY + gfGrowHiX + gfGrowHiY; { Set grow modes } - Defs := ADefs; { Set default items } - FindItems; { Find the items } -END; - -{--TStatusLine--------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TStatusLine.Load (Var S: TStream); - - FUNCTION DoLoadStatusItems: PStatusItem; - VAR Count: Integer; Cur, First: PStatusItem; Last: ^PStatusItem; - BEGIN - Cur := Nil; { Preset nil } - Last := @First; { Start on first item } - S.Read(Count, SizeOf(Count)); { Read count } - While (Count > 0) Do Begin - New(Cur); { New status item } - Last^ := Cur; { First chain part } - If (Cur <> Nil) Then Begin { Check pointer valid } - Last := @Cur^.Next; { Chain complete } - Cur^.Text := S.ReadStr; { Read item text } - S.Read(Cur^.KeyCode, SizeOf(Cur^.KeyCode)); { Keycode of item } - S.Read(Cur^.Command, SizeOf(Cur^.Command)); { Command of item } - End; - Dec(Count); { One item loaded } - End; - Last^ := Nil; { Now chain end } - DoLoadStatusItems := First; { Return the list } - END; - - FUNCTION DoLoadStatusDefs: PStatusDef; - VAR Count: Integer; Cur, First: PStatusDef; Last: ^PStatusDef; - BEGIN - Last := @First; { Start on first } - S.Read(Count, SizeOf(Count)); { Read item count } - While (Count > 0) Do Begin - New(Cur); { New status def } - Last^ := Cur; { First part of chain } - If (Cur <> Nil) Then Begin { Check pointer valid } - Last := @Cur^.Next; { Chain complete } - S.Read(Cur^.Min, SizeOf(Cur^.Min)); { Read min data } - S.Read(Cur^.Max, SizeOf(Cur^.Max)); { Read max data } - Cur^.Items := DoLoadStatusItems; { Set pointer } - End; - Dec(Count); { One item loaded } - End; - Last^ := Nil; { Now chain ends } - DoLoadStatusDefs := First; { Return item list } - END; - -BEGIN - Inherited Load(S); { Call ancestor } - Defs := DoLoadStatusDefs; { Retreive items } - FindItems; { Find the items } -END; - -{--TStatusLine--------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TStatusLine.Done; -VAR T: PStatusDef; - - PROCEDURE DisposeItems (Item: PStatusItem); - VAR T: PStatusItem; - BEGIN - While (Item <> Nil) Do Begin { Item to dispose } - T := Item; { Hold pointer } - Item := Item^.Next; { Move down chain } - DisposeStr(T^.Text); { Dispose string } - Dispose(T); { Dispose item } - End; - END; - -BEGIN - While (Defs <> Nil) Do Begin - T := Defs; { Hold pointer } - Defs := Defs^.Next; { Move down chain } - DisposeItems(T^.Items); { Dispose the item } - Dispose(T); { Dispose status item } - End; - Inherited Done; { Call ancestor } -END; - - -{--TStatusLine--------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TStatusLine.GetPalette: PPalette; -{$IFDEF PPC_DELPHI3} { DELPHI3+ COMPILER } -CONST P: String = CStatusLine; { Possible huge string } -{$ELSE} { OTHER COMPILERS } -CONST P: String[Length(CStatusLine)] = CStatusLine; { Always normal string } -{$ENDIF} -BEGIN - GetPalette := PPalette(@P); { Return palette } -END; - -{--TStatusLine--------------------------------------------------------------} -{ Hint -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TStatusLine.Hint (AHelpCtx: Word): String; -BEGIN - Hint := ''; { Return nothing } -END; - -{--TStatusLine--------------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStatusLine.Draw; -BEGIN - DrawSelect(Nil); { Call draw select } -END; - -{--TStatusLine--------------------------------------------------------------} -{ Update -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStatusLine.Update; -VAR H: Word; P: PView; -BEGIN - P := TopView; { Get topmost view } - If (P <> Nil) Then H := P^.GetHelpCtx Else { Top views context } - H := hcNoContext; { No context } - If (HelpCtx <> H) Then Begin { Differs from last } - HelpCtx := H; { Hold new context } - FindItems; { Find the item } - DrawView; { Redraw the view } - End; -END; - -{--TStatusLine--------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStatusLine.Store (Var S: TStream); - - PROCEDURE DoStoreStatusItems (Cur: PStatusItem); - VAR Count: Integer; T: PStatusItem; - BEGIN - Count := 0; { Clear count } - T := Cur; { Start on current } - While (T <> Nil) Do Begin - Inc(Count); { Count items } - T := T^.Next; { Next item } - End; - S.Write(Count, SizeOf(Count)); { Write item count } - While (Cur <> Nil) Do Begin - S.WriteStr(Cur^.Text); { Store item text } - S.Write(Cur^.KeyCode, SizeOf(Cur^.KeyCode)); { Keycode of item } - S.Write(Cur^.Command, SizeOf(Cur^.Command)); { Command of item } - Cur := Cur^.Next; { Move to next item } - End; - END; - - PROCEDURE DoStoreStatusDefs (Cur: PStatusDef); - VAR Count: Integer; T: PStatusDef; - BEGIN - Count := 0; { Clear count } - T := Cur; { Current status item } - While (T <> Nil) Do Begin - Inc(Count); { Count items } - T := T^.Next { Next item } - End; - S.Write(Count, 2); { Write item count } - While (Cur <> Nil) Do Begin - With Cur^ Do Begin - S.Write(Cur^.Min, 2); { Write min data } - S.Write(Cur^.Max, 2); { Write max data } - DoStoreStatusItems(Items); { Store the items } - End; - Cur := Cur^.Next; { Next status item } - End; - END; - -BEGIN - TView.Store(S); { TView.Store called } - DoStoreStatusDefs(Defs); { Store status items } -END; - -{--TStatusLine--------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStatusLine.HandleEvent (Var Event: TEvent); -VAR Mouse: TPoint; T, Tt: PStatusItem; - - FUNCTION ItemMouseIsIn: PStatusItem; - VAR X, Xi: Word; T: PStatusItem; - BEGIN - ItemMouseIsIn := Nil; { Preset fail } - If (Mouse.Y < 0) OR (Mouse.Y > 1) { Outside view height } - Then Exit; { Not in view exit } - X := 0; { Zero x position } - T := Items; { Start at first item } - While (T <> Nil) Do Begin { While item valid } - If (T^.Text <> Nil) Then Begin { Check valid text } - Xi := X; { Hold initial x value } - X := Xi + CTextWidth(' ' + T^.Text^ + ' '); { Add text width } - If (Mouse.X >= Xi) AND (Mouse.X < X) - Then Begin - ItemMouseIsIn := T; { Selected item } - Exit; { Now exit } - End; - End; - T := T^.Next; { Next item } - End; - END; - -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - Case Event.What Of - evMouseDown: Begin - T := Nil; { Preset ptr to nil } - Repeat - Mouse.X := Event.Where.X - Origin.X; { Local x position } - Mouse.Y := Event.Where.Y - Origin.Y; { Local y position } - Tt := ItemMouseIsIn; { Find selected item } - If (T <> Tt) Then { Item has changed } - DrawSelect(Tt); { Draw new item } - T := Tt { Transfer item } - Until NOT MouseEvent(Event, evMouseMove); { Mouse stopped moving } - If (T <> Nil) AND CommandEnabled(T^.Command) { Check cmd enabled } - Then Begin - Event.What := evCommand; { Command event } - Event.Command := T^.Command; { Set command value } - Event.InfoPtr := Nil; { No info ptr } - PutEvent(Event); { Put event on queue } - End; - ClearEvent(Event); { Clear the event } - DrawSelect(Nil); { Clear the highlight } - End; - evKeyDown: Begin { Key down event } - T := Items; { Start on first item } - While (T <> Nil) Do Begin { For each valid item } - If (Event.KeyCode = T^.KeyCode) AND { Check for hot key } - CommandEnabled(T^.Command) Then Begin { Check cmd enabled } - Event.What := evCommand; { Change to command } - Event.Command := T^.Command; { Set command value } - Event.InfoPtr := Nil; { Clear info ptr } - PutEvent(Event); { Put event on queue } - ClearEvent(Event); { Clear the event } - Exit; Exit; { Now exit } - End; - T := T^.Next; { Next item } - End; - End; - evBroadcast: - If (Event.Command = cmCommandSetChanged) Then { Command set change } - DrawView; { Redraw view } - End; -END; - -{***************************************************************************} -{ TStatusLine OBJECT PRIVATE METHODS } -{***************************************************************************} - -{--TStatusLine--------------------------------------------------------------} -{ FindItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStatusLine.FindItems; -VAR P: PStatusDef; -BEGIN - P := Defs; { First status item } - While (P <> Nil) AND ((HelpCtx < P^.Min) OR - (HelpCtx > P^.Max)) Do P := P^.Next; { Find status item } - If (P = Nil) Then Items := Nil Else - Items := P^.Items; { Return found item } -END; - -{--TStatusLine--------------------------------------------------------------} -{ DrawSelect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStatusLine.DrawSelect (Selected: PStatusItem); -VAR I, L: Integer; Color, CSelect, CNormal, CSelDisabled, CNormDisabled: Word; - HintBuf: String; B: TDrawBuffer; T: PStatusItem; -BEGIN - CNormal := GetColor($0301); { Normal colour } - CSelect := GetColor($0604); { Select colour } - CNormDisabled := GetColor($0202); { Disabled colour } - CSelDisabled := GetColor($0505); { Select disabled } - MoveChar(B, ' ', Byte(CNormal), Size.X); { Clear the buffer } - T := Items; { First item } - I := 0; { Clear the count } - L := 0; - While (T <> Nil) Do Begin { While valid item } - If (T^.Text <> Nil) Then Begin { While valid text } - L := CStrLen(' '+T^.Text^+' '); { Text length } - If CommandEnabled(T^.Command) Then Begin { Command enabled } - If T = Selected Then Color := CSelect { Selected colour } - Else Color := CNormal { Normal colour } - End Else - If T = Selected Then Color := CSelDisabled { Selected disabled } - Else Color := CNormDisabled; { Disabled colour } - MoveCStr(B[I], ' '+T^.Text^+' ', Color); { Move text to buf } - Inc(I, L); { Advance position } - End; - T := T^.Next; { Next item } - End; - HintBuf := Hint(HelpCtx); { Get hint string } - If (HintBuf <> '') Then Begin { Hint present } - {$IFNDEF OS_WINDOWS} - MoveChar(B[I], #179, Byte(CNormal), 1); { '|' char to buffer } - {$ELSE} - MoveChar(B[I], #124, Byte(CNormal), 1); { '|' char to buffer } - {$ENDIF} - Inc(I, 2); { Move along } - MoveStr(B[I], HintBuf, Byte(CNormal)); { Move hint to buffer } - I := I + Length(HintBuf); { Hint length } - End; - WriteLine(0, 0, Size.X, 1, B); { Write the buffer } -END; - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ MENU INTERFACE ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ NewMenu -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION NewMenu (Items: PMenuItem): PMenu; -VAR P: PMenu; -BEGIN - New(P); { Create new menu } - FillChar(P^,sizeof(TMenu),0); - If (P <> Nil) Then Begin { Check valid pointer } - P^.Items := Items; { Hold item list } - P^.Default := Items; { Set default item } - End; - NewMenu := P; { Return menu } -END; - -{---------------------------------------------------------------------------} -{ DisposeMenu -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE DisposeMenu (Menu: PMenu); -VAR P, Q: PMenuItem; -BEGIN - If (Menu <> Nil) Then Begin { Valid menu item } - P := Menu^.Items; { First item in list } - While (P <> Nil) Do Begin { Item is valid } - If (P^.Name <> Nil) Then Begin { Valid name pointer } - DisposeStr(P^.Name); { Dispose of name } - If (P^.Command <> 0) Then - DisposeStr(P^.Param) Else { Dispose parameter } - DisposeMenu(P^.SubMenu); { Dispose submenu } - End; - Q := P; { Hold pointer } - P := P^.Next; { Move to next item } - Dispose(Q); { Dispose of item } - End; - Dispose(Menu); { Dispose of menu } - End; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ MENU ITEM ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ NewLine -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION NewLine (Next: PMenuItem): PMenuItem; -VAR P: PMenuItem; -BEGIN - New(P); { Allocate memory } - FillChar(P^,sizeof(TMenuItem),0); - If (P <> Nil) Then Begin { Check valid pointer } - P^.Next := Next; { Hold next menu item } - End; - NewLine := P; { Return new line } -END; - -{---------------------------------------------------------------------------} -{ NewItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION NewItem (Name, Param: TMenuStr; KeyCode: Word; Command: Word; - AHelpCtx: Word; Next: PMenuItem): PMenuItem; -VAR P: PMenuItem; R: TRect; T: PView; -BEGIN - If (Name <> '') AND (Command <> 0) Then Begin - New(P); { Allocate memory } - FillChar(P^,sizeof(TMenuItem),0); - If (P <> Nil) Then Begin { Check valid pointer } - P^.Next := Next; { Hold next item } - P^.Name := NewStr(Name); { Hold item name } - P^.Command := Command; { Hold item command } - R.Assign(1, 1, 10, 10); { Random assignment } - T := New(PView, Init(R)); { Create a view } - If (T <> Nil) Then Begin - P^.Disabled := NOT T^.CommandEnabled(Command); - Dispose(T, Done); { Dispose of view } - End Else P^.Disabled := True; - P^.KeyCode := KeyCode; { Hold item keycode } - P^.HelpCtx := AHelpCtx; { Hold help context } - P^.Param := NewStr(Param); { Hold parameter } - End; - NewItem := P; { Return item } - End Else NewItem := Next; { Move forward } -END; - -{---------------------------------------------------------------------------} -{ NewSubMenu -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION NewSubMenu (Name: TMenuStr; AHelpCtx: Word; SubMenu: PMenu; - Next: PMenuItem): PMenuItem; -VAR P: PMenuItem; -BEGIN - If (Name <> '') AND (SubMenu <> Nil) Then Begin - New(P); { Allocate memory } - FillChar(P^,sizeof(TMenuItem),0); - If (P <> Nil) Then Begin { Check valid pointer } - P^.Next := Next; { Hold next item } - P^.Name := NewStr(Name); { Hold submenu name } - P^.HelpCtx := AHelpCtx; { Set help context } - P^.SubMenu := SubMenu; { Hold next submenu } - End; - NewSubMenu := P; { Return submenu } - End Else NewSubMenu := Next; { Return next item } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ STATUS INTERFACE ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ NewStatusDef -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION NewStatusDef (AMin, AMax: Word; AItems: PStatusItem; -ANext:PStatusDef): PStatusDef; -VAR T: PStatusDef; -BEGIN - New(T); { Allocate memory } - If (T <> Nil) Then Begin { Check valid pointer } - T^.Next := ANext; { Set next item } - T^.Min := AMin; { Hold min value } - T^.Max := AMax; { Hold max value } - T^.Items := AItems; { Hold item list } - End; - NewStatusDef := T; { Return status } -END; - -{---------------------------------------------------------------------------} -{ NewStatusKey -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION NewStatusKey (AText: String; AKeyCode: Word; ACommand: Word; - ANext: PStatusItem): PStatusItem; -VAR T: PStatusItem; -BEGIN - New(T); { Allocate memory } - If (T <> Nil) Then Begin { Check valid pointer } - T^.Text := NewStr(AText); { Hold text string } - T^.KeyCode := AKeyCode; { Hold keycode } - T^.Command := ACommand; { Hold command } - T^.Next := ANext; { Pointer to next } - End; - NewStatusKey := T; { Return status item } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ OBJECT REGISTER ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ RegisterMenus -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE RegisterMenus; -BEGIN - RegisterType(RMenuBar); { Register bar menu } - RegisterType(RMenuBox); { Register menu box } - RegisterType(RStatusLine); { Register status line } - RegisterType(RMenuPopup); { Register popup menu } -END; - -END. +{$I menus.inc} diff --git a/packages/fv/src/msgbox.inc b/packages/fv/src/msgbox.inc new file mode 100644 index 0000000000..d95d20b9c9 --- /dev/null +++ b/packages/fv/src/msgbox.inc @@ -0,0 +1,342 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of MSGBOX.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@starwon.com.au - backup e-mail addr } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Fix } +{ ------- --------- --------------------------------- } +{ 1.00 12 Jun 96 Initial DOS/DPMI code released. } +{ 1.10 18 Oct 97 Code converted to GUI & TEXT mode. } +{ 1.20 18 Jul 97 Windows conversion added. } +{ 1.30 29 Aug 97 Platform.inc sort added. } +{ 1.40 22 Oct 97 Delphi3 32 bit code added. } +{ 1.50 05 May 98 Virtual pascal 2.0 code added. } +{ 1.60 30 Sep 99 Complete recheck preformed } +{**********************************************************} + +{$ifdef FV_UNICODE} +UNIT UMsgBox; +{$else FV_UNICODE} +UNIT MsgBox; +{$endif FV_UNICODE} + +{2.0 compatibility} +{$ifdef VER2_0} + {$macro on} + {$define resourcestring := const} +{$endif} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Near calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES objects, { Standard GFV units } +{$ifdef FV_UNICODE} + ufvcommon,udialogs; +{$else FV_UNICODE} + fvcommon,dialogs; +{$endif FV_UNICODE} + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ MESSAGE BOX CLASSES } +{---------------------------------------------------------------------------} +CONST + mfWarning = $0000; { Display a Warning box } + mfError = $0001; { Dispaly a Error box } + mfInformation = $0002; { Display an Information Box } + mfConfirmation = $0003; { Display a Confirmation Box } + + mfInsertInApp = $0080; { Insert message box into } + { app instead of the Desktop } +{---------------------------------------------------------------------------} +{ MESSAGE BOX BUTTON FLAGS } +{---------------------------------------------------------------------------} +CONST + mfYesButton = $0100; { Yes button into the dialog } + mfNoButton = $0200; { No button into the dialog } + mfOKButton = $0400; { OK button into the dialog } + mfCancelButton = $0800; { Cancel button into the dialog } + + mfYesNoCancel = mfYesButton + mfNoButton + mfCancelButton; + { Yes, No, Cancel dialog } + mfOKCancel = mfOKButton + mfCancelButton; + { Standard OK, Cancel dialog } + +var +{$ifdef FV_UNICODE} + MsgBoxTitles: array[0..3] of UnicodeString; +{$else FV_UNICODE} + MsgBoxTitles: array[0..3] of string[40]; +{$endif FV_UNICODE} + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +procedure InitMsgBox; +procedure DoneMsgBox; + { Init initializes the message box display system's text strings. Init is + called by TApplication.Init after a successful call to Resource.Init or + Resource.Load. } + +{-MessageBox--------------------------------------------------------- +MessageBox displays the given string in a standard sized dialog box. +Before the dialog is displayed the Msg and Params are passed to FormatStr. +The resulting string is displayed as a TStaticText view in the dialog. +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION MessageBox (Const Msg: Sw_String; Params: Pointer; + AOptions: Word): Word; + +{-MessageBoxRect----------------------------------------------------- +MessageBoxRec allows the specification of a TRect for the message box +to occupy. +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION MessageBoxRect (Var R: TRect; Const Msg: Sw_String; Params: Pointer; + AOptions: Word): Word; + +{-MessageBoxRectDlg-------------------------------------------------- +MessageBoxRecDlg allows the specification of a TRect for the message box +to occupy plus the dialog window (to allow different dialog window types). +---------------------------------------------------------------------} +FUNCTION MessageBoxRectDlg (Dlg: PDialog; Var R: TRect; Const Msg: Sw_String; + Params: Pointer; AOptions: Word): Word; + +{-InputBox----------------------------------------------------------- +InputBox displays a simple dialog that allows user to type in a string +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION InputBox (Const Title, ALabel: Sw_String; Var S: Sw_String; + Limit: Byte): Word; + +{-InputBoxRect------------------------------------------------------- +InputBoxRect is like InputBox but allows the specification of a rectangle. +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION InputBoxRect (Var Bounds: TRect; Const Title, ALabel: Sw_String; + Var S: Sw_String; Limit: Byte): Word; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{$ifdef FV_UNICODE} +USES UDrivers, UViews, UApp{, Resource}; { Standard GFV units } +{$else FV_UNICODE} +USES Drivers, Views, App{, Resource}; { Standard GFV units } +{$endif FV_UNICODE} + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +const + Commands: array[0..3] of word = + (cmYes, cmNo, cmOK, cmCancel); +var +{$ifdef FV_UNICODE} + ButtonName: array[0..3] of Sw_String; +{$else FV_UNICODE} + ButtonName: array[0..3] of string[40]; +{$endif FV_UNICODE} + +resourcestring sConfirm='Confirm'; + sError='Error'; + sInformation='Information'; + sWarning='Warning'; + + +{---------------------------------------------------------------------------} +{ MessageBox -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MessageBox(Const Msg: Sw_String; Params: Pointer; AOptions: Word): Word; +VAR R: TRect; +BEGIN + R.Assign(0, 0, 40, 9); { Assign area } + If (AOptions AND mfInsertInApp = 0) Then { Non app insert } + R.Move((Desktop^.Size.X - R.B.X) DIV 2, + (Desktop^.Size.Y - R.B.Y) DIV 2) Else { Calculate position } + R.Move((Application^.Size.X - R.B.X) DIV 2, + (Application^.Size.Y - R.B.Y) DIV 2); { Calculate position } + MessageBox := MessageBoxRect(R, Msg, Params, + AOptions); { Create message box } +END; + +FUNCTION MessageBoxRectDlg (Dlg: PDialog; Var R: TRect; Const Msg: Sw_String; + Params: Pointer; AOptions: Word): Word; +VAR I, X, ButtonCount: SmallInt; S: Sw_String; Control: PView; + ButtonList: Array[0..4] Of PView; +BEGIN + With Dlg^ Do Begin + FormatStr(S, Msg, Params^); { Format the message } + Control := New(PStaticText, Init(R, S)); { Create static text } + Insert(Control); { Insert the text } + X := -2; { Set initial value } + ButtonCount := 0; { Clear button count } + For I := 0 To 3 Do + If (AOptions AND ($0100 SHL I) <> 0) Then Begin + R.Assign(0, 0, 10, 2); { Assign screen area } + Control := New(PButton, Init(R, ButtonName[I], + Commands[i], bfNormal)); { Create button } + Inc(X, Control^.Size.X + 2); { Adjust position } + ButtonList[ButtonCount] := Control; { Add to button list } + Inc(ButtonCount); { Inc button count } + End; + X := (Size.X - X) SHR 1; { Calc x position } + If (ButtonCount > 0) Then + For I := 0 To ButtonCount - 1 Do Begin { For each button } + Control := ButtonList[I]; { Transfer button } + Insert(Control); { Insert button } + Control^.MoveTo(X, Size.Y - 3); { Position button } + Inc(X, Control^.Size.X + 2); { Adjust position } + End; + SelectNext(False); { Select first button } + End; + If (AOptions AND mfInsertInApp = 0) Then + MessageBoxRectDlg := DeskTop^.ExecView(Dlg) Else { Execute dialog } + MessageBoxRectDlg := Application^.ExecView(Dlg); { Execute dialog } +end; + + +{---------------------------------------------------------------------------} +{ MessageBoxRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MessageBoxRect(Var R: TRect; Const Msg: Sw_String; Params: Pointer; + AOptions: Word): Word; +var + Dialog: PDialog; +BEGIN + Dialog := New (PDialog, Init (R, MsgBoxTitles [AOptions + AND $3])); { Create dialog } + with Dialog^ do + R.Assign(3, 2, Size.X - 2, Size.Y - 3); { Assign area for text } + MessageBoxRect := MessageBoxRectDlg (Dialog, R, Msg, Params, AOptions); + Dispose (Dialog, Done); { Dispose of dialog } +END; + +{---------------------------------------------------------------------------} +{ InputBox -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION InputBox(Const Title, ALabel: Sw_String; Var S: Sw_String; + Limit: Byte): Word; +VAR R: TRect; +BEGIN + R.Assign(0, 0, 60, 8); { Assign screen area } + R.Move((Desktop^.Size.X - R.B.X) DIV 2, + (Desktop^.Size.Y - R.B.Y) DIV 2); { Position area } + InputBox := InputBoxRect(R, Title, ALabel, S, + Limit); { Create input box } +END; + +{---------------------------------------------------------------------------} +{ InputBoxRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION InputBoxRect(Var Bounds: TRect; Const Title, ALabel: Sw_String; + Var S: Sw_String; Limit: Byte): Word; +VAR C: Word; R: TRect; Control: PView; Dialog: PDialog; +BEGIN + Dialog := New(PDialog, Init(Bounds, Title)); { Create dialog } + With Dialog^ Do Begin + R.Assign(4 + CStrLen(ALabel), 2, Size.X - 3, 3); { Assign screen area } + Control := New(PInputLine, Init(R, Limit)); { Create input line } + Insert(Control); { Insert input line } + R.Assign(2, 2, 3 + CStrLen(ALabel), 3); { Assign screen area } + Insert(New(PLabel, Init(R, ALabel, Control))); { Insert label } + R.Assign(Size.X - 24, Size.Y - 4, Size.X - 14, + Size.Y - 2); { Assign screen area } + Insert(New(PButton, Init(R, 'O~K~', cmOk, + bfDefault))); { Insert okay button } + Inc(R.A.X, 12); { New start x position } + Inc(R.B.X, 12); { New end x position } + Insert(New(PButton, Init(R, 'Cancel', cmCancel, + bfNormal))); { Insert cancel button } + Inc(R.A.X, 12); { New start x position } + Inc(R.B.X, 12); { New end x position } + SelectNext(False); { Select first button } + End; + Dialog^.SetData(S); { Set data in dialog } + C := DeskTop^.ExecView(Dialog); { Execute the dialog } + If (C <> cmCancel) Then Dialog^.GetData(S); { Get data from dialog } + Dispose(Dialog, Done); { Dispose of dialog } + InputBoxRect := C; { Return execute result } +END; + + +procedure InitMsgBox; +begin + ButtonName[0] := slYes; + ButtonName[1] := slNo; + ButtonName[2] := slOk; + ButtonName[3] := slCancel; + MsgBoxTitles[0] := sWarning; + MsgBoxTitles[1] := sError; + MsgBoxTitles[2] := sInformation; + MsgBoxTitles[3] := sConfirm; +end; + +procedure DoneMsgBox; +begin +end; + +END. diff --git a/packages/fv/src/msgbox.pas b/packages/fv/src/msgbox.pas index 7b79b7304c..4064067013 100644 --- a/packages/fv/src/msgbox.pas +++ b/packages/fv/src/msgbox.pas @@ -1,321 +1 @@ -{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} -{ } -{ System independent GRAPHICAL clone of MSGBOX.PAS } -{ } -{ Interface Copyright (c) 1992 Borland International } -{ } -{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } -{ ldeboer@attglobal.net - primary e-mail addr } -{ ldeboer@starwon.com.au - backup e-mail addr } -{ } -{****************[ THIS CODE IS FREEWARE ]*****************} -{ } -{ This sourcecode is released for the purpose to } -{ promote the pascal language on all platforms. You may } -{ redistribute it and/or modify with the following } -{ DISCLAIMER. } -{ } -{ This SOURCE CODE is distributed "AS IS" WITHOUT } -{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } -{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } -{ } -{*****************[ SUPPORTED PLATFORMS ]******************} -{ 16 and 32 Bit compilers } -{ DOS - Turbo Pascal 7.0 + (16 Bit) } -{ DPMI - Turbo Pascal 7.0 + (16 Bit) } -{ - FPC 0.9912+ (GO32V2) (32 Bit) } -{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } -{ - Delphi 1.0+ (16 Bit) } -{ WIN95/NT - Delphi 2.0+ (32 Bit) } -{ - Virtual Pascal 2.0+ (32 Bit) } -{ - Speedsoft Sybil 2.0+ (32 Bit) } -{ OS2 - Virtual Pascal 1.0+ (32 Bit) } -{ - Speedsoft Sybil 2.0+ (32 Bit) } -{ } -{******************[ REVISION HISTORY ]********************} -{ Version Date Fix } -{ ------- --------- --------------------------------- } -{ 1.00 12 Jun 96 Initial DOS/DPMI code released. } -{ 1.10 18 Oct 97 Code converted to GUI & TEXT mode. } -{ 1.20 18 Jul 97 Windows conversion added. } -{ 1.30 29 Aug 97 Platform.inc sort added. } -{ 1.40 22 Oct 97 Delphi3 32 bit code added. } -{ 1.50 05 May 98 Virtual pascal 2.0 code added. } -{ 1.60 30 Sep 99 Complete recheck preformed } -{**********************************************************} - -UNIT MsgBox; - -{2.0 compatibility} -{$ifdef VER2_0} - {$macro on} - {$define resourcestring := const} -{$endif} - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - INTERFACE -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{====Include file to sort compiler platform out =====================} -{$I platform.inc} -{====================================================================} - -{==== Compiler directives ===========================================} - -{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } - {$F-} { Near calls are okay } - {$A+} { Word Align Data } - {$B-} { Allow short circuit boolean evaluations } - {$O+} { This unit may be overlaid } - {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } - {$P-} { Normal string variables } - {$N-} { No 80x87 code generation } - {$E+} { Emulation is on } -{$ENDIF} - -{$X+} { Extended syntax is ok } -{$R-} { Disable range checking } -{$S-} { Disable Stack Checking } -{$I-} { Disable IO Checking } -{$Q-} { Disable Overflow Checking } -{$V-} { Turn off strict VAR strings } -{====================================================================} - -USES objects, dialogs; { Standard GFV units } - -{***************************************************************************} -{ PUBLIC CONSTANTS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ MESSAGE BOX CLASSES } -{---------------------------------------------------------------------------} -CONST - mfWarning = $0000; { Display a Warning box } - mfError = $0001; { Dispaly a Error box } - mfInformation = $0002; { Display an Information Box } - mfConfirmation = $0003; { Display a Confirmation Box } - - mfInsertInApp = $0080; { Insert message box into } - { app instead of the Desktop } -{---------------------------------------------------------------------------} -{ MESSAGE BOX BUTTON FLAGS } -{---------------------------------------------------------------------------} -CONST - mfYesButton = $0100; { Yes button into the dialog } - mfNoButton = $0200; { No button into the dialog } - mfOKButton = $0400; { OK button into the dialog } - mfCancelButton = $0800; { Cancel button into the dialog } - - mfYesNoCancel = mfYesButton + mfNoButton + mfCancelButton; - { Yes, No, Cancel dialog } - mfOKCancel = mfOKButton + mfCancelButton; - { Standard OK, Cancel dialog } - -var - MsgBoxTitles: array[0..3] of string[40]; - - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -procedure InitMsgBox; -procedure DoneMsgBox; - { Init initializes the message box display system's text strings. Init is - called by TApplication.Init after a successful call to Resource.Init or - Resource.Load. } - -{-MessageBox--------------------------------------------------------- -MessageBox displays the given string in a standard sized dialog box. -Before the dialog is displayed the Msg and Params are passed to FormatStr. -The resulting string is displayed as a TStaticText view in the dialog. -30Sep99 LdB ----------------------------------------------------------------------} -FUNCTION MessageBox (Const Msg: String; Params: Pointer; - AOptions: Word): Word; - -{-MessageBoxRect----------------------------------------------------- -MessageBoxRec allows the specification of a TRect for the message box -to occupy. -30Sep99 LdB ----------------------------------------------------------------------} -FUNCTION MessageBoxRect (Var R: TRect; Const Msg: String; Params: Pointer; - AOptions: Word): Word; - -{-MessageBoxRectDlg-------------------------------------------------- -MessageBoxRecDlg allows the specification of a TRect for the message box -to occupy plus the dialog window (to allow different dialog window types). ----------------------------------------------------------------------} -FUNCTION MessageBoxRectDlg (Dlg: PDialog; Var R: TRect; Const Msg: String; - Params: Pointer; AOptions: Word): Word; - -{-InputBox----------------------------------------------------------- -InputBox displays a simple dialog that allows user to type in a string -30Sep99 LdB ----------------------------------------------------------------------} -FUNCTION InputBox (Const Title, ALabel: String; Var S: String; - Limit: Byte): Word; - -{-InputBoxRect------------------------------------------------------- -InputBoxRect is like InputBox but allows the specification of a rectangle. -30Sep99 LdB ----------------------------------------------------------------------} -FUNCTION InputBoxRect (Var Bounds: TRect; Const Title, ALabel: String; - Var S: String; Limit: Byte): Word; - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IMPLEMENTATION -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -USES Drivers, Views, App{, Resource}; { Standard GFV units } - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -const - Commands: array[0..3] of word = - (cmYes, cmNo, cmOK, cmCancel); -var - ButtonName: array[0..3] of string[40]; - -resourcestring sConfirm='Confirm'; - sError='Error'; - sInformation='Information'; - sWarning='Warning'; - - -{---------------------------------------------------------------------------} -{ MessageBox -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -FUNCTION MessageBox(Const Msg: String; Params: Pointer; AOptions: Word): Word; -VAR R: TRect; -BEGIN - R.Assign(0, 0, 40, 9); { Assign area } - If (AOptions AND mfInsertInApp = 0) Then { Non app insert } - R.Move((Desktop^.Size.X - R.B.X) DIV 2, - (Desktop^.Size.Y - R.B.Y) DIV 2) Else { Calculate position } - R.Move((Application^.Size.X - R.B.X) DIV 2, - (Application^.Size.Y - R.B.Y) DIV 2); { Calculate position } - MessageBox := MessageBoxRect(R, Msg, Params, - AOptions); { Create message box } -END; - -FUNCTION MessageBoxRectDlg (Dlg: PDialog; Var R: TRect; Const Msg: String; - Params: Pointer; AOptions: Word): Word; -VAR I, X, ButtonCount: Integer; S: String; Control: PView; - ButtonList: Array[0..4] Of PView; -BEGIN - With Dlg^ Do Begin - FormatStr(S, Msg, Params^); { Format the message } - Control := New(PStaticText, Init(R, S)); { Create static text } - Insert(Control); { Insert the text } - X := -2; { Set initial value } - ButtonCount := 0; { Clear button count } - For I := 0 To 3 Do - If (AOptions AND ($0100 SHL I) <> 0) Then Begin - R.Assign(0, 0, 10, 2); { Assign screen area } - Control := New(PButton, Init(R, ButtonName[I], - Commands[i], bfNormal)); { Create button } - Inc(X, Control^.Size.X + 2); { Adjust position } - ButtonList[ButtonCount] := Control; { Add to button list } - Inc(ButtonCount); { Inc button count } - End; - X := (Size.X - X) SHR 1; { Calc x position } - If (ButtonCount > 0) Then - For I := 0 To ButtonCount - 1 Do Begin { For each button } - Control := ButtonList[I]; { Transfer button } - Insert(Control); { Insert button } - Control^.MoveTo(X, Size.Y - 3); { Position button } - Inc(X, Control^.Size.X + 2); { Adjust position } - End; - SelectNext(False); { Select first button } - End; - If (AOptions AND mfInsertInApp = 0) Then - MessageBoxRectDlg := DeskTop^.ExecView(Dlg) Else { Execute dialog } - MessageBoxRectDlg := Application^.ExecView(Dlg); { Execute dialog } -end; - - -{---------------------------------------------------------------------------} -{ MessageBoxRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -FUNCTION MessageBoxRect(Var R: TRect; Const Msg: String; Params: Pointer; - AOptions: Word): Word; -var - Dialog: PDialog; -BEGIN - Dialog := New (PDialog, Init (R, MsgBoxTitles [AOptions - AND $3])); { Create dialog } - with Dialog^ do - R.Assign(3, 2, Size.X - 2, Size.Y - 3); { Assign area for text } - MessageBoxRect := MessageBoxRectDlg (Dialog, R, Msg, Params, AOptions); - Dispose (Dialog, Done); { Dispose of dialog } -END; - -{---------------------------------------------------------------------------} -{ InputBox -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -FUNCTION InputBox(Const Title, ALabel: String; Var S: String; - Limit: Byte): Word; -VAR R: TRect; -BEGIN - R.Assign(0, 0, 60, 8); { Assign screen area } - R.Move((Desktop^.Size.X - R.B.X) DIV 2, - (Desktop^.Size.Y - R.B.Y) DIV 2); { Position area } - InputBox := InputBoxRect(R, Title, ALabel, S, - Limit); { Create input box } -END; - -{---------------------------------------------------------------------------} -{ InputBoxRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } -{---------------------------------------------------------------------------} -FUNCTION InputBoxRect(Var Bounds: TRect; Const Title, ALabel: String; - Var S: String; Limit: Byte): Word; -VAR C: Word; R: TRect; Control: PView; Dialog: PDialog; -BEGIN - Dialog := New(PDialog, Init(Bounds, Title)); { Create dialog } - With Dialog^ Do Begin - R.Assign(4 + CStrLen(ALabel), 2, Size.X - 3, 3); { Assign screen area } - Control := New(PInputLine, Init(R, Limit)); { Create input line } - Insert(Control); { Insert input line } - R.Assign(2, 2, 3 + CStrLen(ALabel), 3); { Assign screen area } - Insert(New(PLabel, Init(R, ALabel, Control))); { Insert label } - R.Assign(Size.X - 24, Size.Y - 4, Size.X - 14, - Size.Y - 2); { Assign screen area } - Insert(New(PButton, Init(R, 'O~K~', cmOk, - bfDefault))); { Insert okay button } - Inc(R.A.X, 12); { New start x position } - Inc(R.B.X, 12); { New end x position } - Insert(New(PButton, Init(R, 'Cancel', cmCancel, - bfNormal))); { Insert cancel button } - Inc(R.A.X, 12); { New start x position } - Inc(R.B.X, 12); { New end x position } - SelectNext(False); { Select first button } - End; - Dialog^.SetData(S); { Set data in dialog } - C := DeskTop^.ExecView(Dialog); { Execute the dialog } - If (C <> cmCancel) Then Dialog^.GetData(S); { Get data from dialog } - Dispose(Dialog, Done); { Dispose of dialog } - InputBoxRect := C; { Return execute result } -END; - - -procedure InitMsgBox; -begin - ButtonName[0] := slYes; - ButtonName[1] := slNo; - ButtonName[2] := slOk; - ButtonName[3] := slCancel; - MsgBoxTitles[0] := sWarning; - MsgBoxTitles[1] := sError; - MsgBoxTitles[2] := sInformation; - MsgBoxTitles[3] := sConfirm; -end; - -procedure DoneMsgBox; -begin -end; - -END. +{$I msgbox.inc} diff --git a/packages/fv/src/outline.inc b/packages/fv/src/outline.inc new file mode 100644 index 0000000000..296f0a2c9f --- /dev/null +++ b/packages/fv/src/outline.inc @@ -0,0 +1,808 @@ +{$ifdef FV_UNICODE} +unit uoutline; +{$else FV_UNICODE} +unit outline; +{$endif FV_UNICODE} + +{$CODEPAGE cp437} + +{***************************************************************************} + interface +{***************************************************************************} + +{$ifdef FV_UNICODE} +uses udrivers,objects,uviews; +{$else FV_UNICODE} +uses drivers,objects,views; +{$endif FV_UNICODE} + +type Pnode=^Tnode; + Tnode=record + next:Pnode; +{$ifdef FV_UNICODE} + text:UnicodeString; +{$else FV_UNICODE} + text:Pstring; +{$endif FV_UNICODE} + childlist:Pnode; + expanded:boolean; + end; + + Poutlineviewer=^Toutlineviewer; + Toutlineviewer=object(Tscroller) + foc:sw_integer; + constructor init(var bounds:Trect; + AHscrollbar,AVscrollbar:Pscrollbar); + procedure adjust(node:pointer;expand:boolean);virtual; +{$ifdef FV_UNICODE} + function creategraph(level:SmallInt;lines:longint; + flags:word;levwidth,endwidth:SmallInt; + const chars:UnicodeString):UnicodeString; +{$else FV_UNICODE} + function creategraph(level:SmallInt;lines:longint; + flags:word;levwidth,endwidth:SmallInt; + const chars:string):string; +{$endif FV_UNICODE} + procedure draw;virtual; + procedure expandall(node:pointer); + function firstthat(test:codepointer):pointer; + procedure focused(i:sw_integer);virtual; + procedure foreach(action:codepointer); + function getchild(node:pointer;i:sw_integer):pointer;virtual; +{$ifdef FV_UNICODE} + function getgraph(level:SmallInt;lines:longint;flags:word):UnicodeString; +{$else FV_UNICODE} + function getgraph(level:SmallInt;lines:longint;flags:word):string; +{$endif FV_UNICODE} + function getnode(i:sw_integer):pointer;virtual; + function getnumchildren(node:pointer):sw_integer;virtual; + function getpalette:Ppalette;virtual; + function getroot:pointer;virtual; +{$ifdef FV_UNICODE} + function gettext(node:pointer):UnicodeString;virtual; +{$else FV_UNICODE} + function gettext(node:pointer):string;virtual; +{$endif FV_UNICODE} + procedure handleevent(var event:Tevent);virtual; + function haschildren(node:pointer):boolean;virtual; + function isexpanded(node:pointer):boolean;virtual; + function isselected(i:sw_integer):boolean;virtual; + procedure selected(i:sw_integer);virtual; + procedure setstate(Astate:word;enable:boolean);virtual; + procedure update; + private + procedure set_focus(Afocus:sw_integer); + function do_recurse(action:codepointer;callerframe:pointer; + stop_if_found:boolean):pointer; + end; + + Poutline=^Toutline; + Toutline=object(Toutlineviewer) + root:Pnode; + constructor init(var bounds:Trect; + AHscrollbar,AVscrollbar:Pscrollbar; + Aroot:Pnode); + procedure adjust(node:pointer;expand:boolean);virtual; + function getchild(node:pointer;i:sw_integer):pointer;virtual; + function getnumchildren(node:pointer):sw_integer;virtual; + function getroot:pointer;virtual; +{$ifdef FV_UNICODE} + function gettext(node:pointer):UnicodeString;virtual; +{$else FV_UNICODE} + function gettext(node:pointer):string;virtual; +{$endif FV_UNICODE} + function haschildren(node:pointer):boolean;virtual; + function isexpanded(node:pointer):boolean;virtual; + destructor done;virtual; + end; + +const ovExpanded = $1; + ovChildren = $2; + ovLast = $4; + + Coutlineviewer=Cscroller+#8#8; + +{$ifdef FV_UNICODE} +function newnode(const Atext:UnicodeString;Achildren,Anext:Pnode):Pnode; +{$else FV_UNICODE} +function newnode(const Atext:string;Achildren,Anext:Pnode):Pnode; +{$endif FV_UNICODE} +procedure disposenode(node:Pnode); + + +{***************************************************************************} + implementation +{***************************************************************************} + +type TMyFunc = function(_EBP: Pointer; Cur: Pointer; + Level, Position: sw_integer; Lines: LongInt; + Flags: Word): Boolean; + + +{$ifdef FV_UNICODE} +function newnode(const Atext:UnicodeString;Achildren,Anext:Pnode):Pnode; +{$else FV_UNICODE} +function newnode(const Atext:string;Achildren,Anext:Pnode):Pnode; +{$endif FV_UNICODE} + +begin + newnode:=new(Pnode); + with newnode^ do + begin + next:=Anext; +{$ifdef FV_UNICODE} + text:=Atext; +{$else FV_UNICODE} + text:=newstr(Atext); +{$endif FV_UNICODE} + childlist:=Achildren; + expanded:=true; + end; +end; + +procedure disposenode(node:Pnode); + +var next:Pnode; + +begin + while node<>nil do + begin + disposenode(node^.childlist); +{$ifndef FV_UNICODE} + disposestr(node^.text); +{$endif FV_UNICODE} + next:=node^.next; + dispose(node); + node:=next; + end; +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ Toutlineviewer object methods } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +constructor Toutlineviewer.init(var bounds:Trect; + AHscrollbar,AVscrollbar:Pscrollbar); + +begin + inherited init(bounds,AHscrollbar,AVscrollbar); + foc:=0; + growmode:=gfGrowHiX+gfGrowHiY; +end; + +procedure Toutlineviewer.adjust(node:pointer;expand:boolean); + +begin + abstract; +end; + +{$ifdef FV_UNICODE} +function TOutlineViewer.CreateGraph(Level: SmallInt; Lines: LongInt; + Flags: Word; LevWidth, EndWidth: SmallInt; + const Chars: UnicodeString): UnicodeString; +{$else FV_UNICODE} +function TOutlineViewer.CreateGraph(Level: SmallInt; Lines: LongInt; + Flags: Word; LevWidth, EndWidth: SmallInt; + const Chars: String): String; +{$endif FV_UNICODE} +const + FillerOrBar = 0; + YorL = 2; + StraightOrTee= 4; + Retracted = 6; +var + Last, Children, Expanded: Boolean; + I , J : Byte; +{$ifdef FV_UNICODE} + Graph : UnicodeString; +{$else FV_UNICODE} + Graph : String; +{$endif FV_UNICODE} + +begin + { Load registers } + graph:=space(Level*LevWidth+EndWidth+1); + + { Write bar characters } + J := 1; + while (Level > 0) do + begin + Inc(J); + if (Lines and 1) <> 0 then + Graph[J] := Chars[FillerOrBar+2] + else + Graph[J] := Chars[FillerOrBar+1]; + for I := 1 to LevWidth - 1 do + Graph[I]:= Chars[FillerOrBar+1]; + J := J + LevWidth - 1; + Dec(Level); + Lines := Lines shr 1; + end; + + { Write end characters } + Dec(EndWidth); + if EndWidth > 0 then + begin + Inc(J); + if Flags and ovLast <> 0 then + Graph[J] := Chars[YorL+2] + else + Graph[J] := Chars[YorL+1]; + Dec(EndWidth); + if EndWidth > 0 then + begin + Dec(EndWidth); + for I := 1 to EndWidth do + Graph[I]:= Chars[StraightOrTee+1]; + J := J + EndWidth; + Inc(J); + if (Flags and ovChildren) <> 0 then + Graph[J] := Chars[StraightOrTee+2] + else + Graph[J] := Chars[StraightOrTee+1]; + end; + Inc(J); + if Flags and ovExpanded <> 0 then + Graph[J] := Chars[Retracted+2] + else + Graph[J] := Chars[Retracted+1]; + end; + SetLength(Graph, J); + + CreateGraph := Graph; +end; + +function Toutlineviewer.do_recurse(action:codepointer;callerframe:pointer; + stop_if_found:boolean):pointer; + +var position:sw_integer; + r:pointer; + + function recurse(cur:pointer;level:SmallInt;lines:longint;lastchild:boolean):pointer; + + var i,childcount:sw_integer; + child:pointer; + flags:word; + children,expanded,found:boolean; + + begin + inc(position); + recurse:=nil; + + children:=haschildren(cur); + expanded:=isexpanded(cur); + + {Determine flags.} + flags:=0; + if not children or expanded then + inc(flags,ovExpanded); + if children and expanded then + inc(flags,ovChildren); + if lastchild then + inc(flags,ovLast); + + {Call the function.} + found:=TMyFunc(action)(callerframe,cur,level,position,lines,flags); + + if stop_if_found and found then + recurse:=cur + else if children and expanded then {Recurse children?} + begin + if not lastchild then + lines:=lines or (1 shl level); + {Iterate all childs.} + childcount:=getnumchildren(cur); + for i:=0 to childcount-1 do + begin + child:=getchild(cur,i); + if (child<>nil) and (level<31) then + recurse:=recurse(child,level+1,lines,i=childcount-1); + {Did we find a node?} + if recurse<>nil then + break; + end; + end; + end; + +begin + position:=-1; + r:=getroot; + if r<>nil then + do_recurse:=recurse(r,0,0,true) + else + do_recurse:=nil; +end; + +procedure Toutlineviewer.draw; + +var c_normal,c_normal_x,c_select,c_focus:byte; + maxpos:sw_integer; + b:Tdrawbuffer; + + function draw_item(cur:pointer;level,position:sw_integer; + lines:longint;flags:word):boolean; + + var c,i:byte; +{$ifdef FV_UNICODE} + s,t:UnicodeString; +{$else FV_UNICODE} + s,t:string; +{$endif FV_UNICODE} + + begin + draw_item:=position>=delta.y+size.y; + if (position<delta.y) or draw_item then + exit; + + maxpos:=position; + s:=getgraph(level,lines,flags); + t:=gettext(cur); + + {Determine text colour.} + if (foc=position) and (state and sffocused<>0) then + c:=c_focus + else if isselected(position) then + c:=c_select + else if flags and ovexpanded<>0 then + c:=c_normal_x + else + c:=c_normal; + + {Fill drawbuffer with graph and text to draw.} + for i:=0 to size.x-1 do + begin +{$ifdef FV_UNICODE} + b[i].Attribute:=c; +{$else FV_UNICODE} + wordrec(b[i]).hi:=c; +{$endif FV_UNICODE} + if i+delta.x<length(s) then +{$ifdef FV_UNICODE} + b[i].ExtendedGraphemeCluster:=s[1+i+delta.x] +{$else FV_UNICODE} + wordrec(b[i]).lo:=byte(s[1+i+delta.x]) +{$endif FV_UNICODE} + else if 1+i+delta.x-length(s)<=length(t) then +{$ifdef FV_UNICODE} + b[i].ExtendedGraphemeCluster:=t[1+i+delta.x-length(s)] +{$else FV_UNICODE} + wordrec(b[i]).lo:=byte(t[1+i+delta.x-length(s)]) +{$endif FV_UNICODE} + else +{$ifdef FV_UNICODE} + b[i].ExtendedGraphemeCluster:=' '; +{$else FV_UNICODE} + wordrec(b[i]).lo:=byte(' '); +{$endif FV_UNICODE} + end; + + {Draw!} + writeline(0,position-delta.y,size.x,1,b); + end; + +begin + c_normal:=getcolor(4); + c_normal_x:=getcolor(1); + c_focus:=getcolor(2); + c_select:=getcolor(3); + maxpos:=-1; + foreach(@draw_item); + movechar(b,' ',c_normal,size.x); + writeline(0,maxpos+1,size.x,size.y-(maxpos-delta.y),b); +end; + +procedure Toutlineviewer.expandall(node:pointer); + +var i:sw_integer; + +begin + if haschildren(node) then + begin + for i:=0 to getnumchildren(node)-1 do + expandall(getchild(node,i)); + adjust(node,true); + end; +end; + +function Toutlineviewer.firstthat(test:codepointer):pointer; + +begin + firstthat:=do_recurse(test, + { On most systems, locals are accessed relative to base pointer, + but for MIPS cpu, they are accessed relative to stack pointer. + This needs adaptation for so low level routines, + like MethodPointerLocal and related objects unit functions. } +{$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE} + get_caller_frame(get_frame,get_pc_addr) +{$else} + get_frame +{$endif} + ,true); +end; + +procedure Toutlineviewer.focused(i:sw_integer); + +begin + foc:=i; +end; + +procedure Toutlineviewer.foreach(action:codepointer); + +begin + do_recurse(action, + { On most systems, locals are accessed relative to base pointer, + but for MIPS cpu, they are accessed relative to stack pointer. + This needs adaptation for so low level routines, + like MethodPointerLocal and related objects unit functions. } +{$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE} + get_caller_frame(get_frame,get_pc_addr) +{$else} + get_frame +{$endif} + ,false); +end; + +function Toutlineviewer.getchild(node:pointer;i:sw_integer):pointer; + +begin + abstract; +end; + +{$ifdef FV_UNICODE} +function Toutlineviewer.getgraph(level:SmallInt;lines:longint; + flags:word):UnicodeString; + +begin + getgraph:=creategraph(level,lines,flags,3,3,#$0020#$2502#$251C#$2514#$2500#$2500#$002B#$2500); +end; +{$else FV_UNICODE} +function Toutlineviewer.getgraph(level:SmallInt;lines:longint; + flags:word):string; + +begin + getgraph:=creategraph(level,lines,flags,3,3,#32#179#195#192#196#196#43#196); +end; +{$endif FV_UNICODE} + +function Toutlineviewer.getnode(i:sw_integer):pointer; + + function test_position(node:pointer;level,position:sw_integer;lines:longInt; + flags:word):boolean; + + begin + test_position:=position=i; + end; + +begin + getnode:=firstthat(@test_position); +end; + +function Toutlineviewer.getnumchildren(node:pointer):sw_integer; + +begin + abstract; +end; + +function Toutlineviewer.getpalette:Ppalette; + +const p:string[length(Coutlineviewer)]=Coutlineviewer; + +begin + getpalette:=@p; +end; + +function Toutlineviewer.getroot:pointer; + +begin + abstract; +end; + +{$ifdef FV_UNICODE} +function Toutlineviewer.gettext(node:pointer):UnicodeString; +{$else FV_UNICODE} +function Toutlineviewer.gettext(node:pointer):string; +{$endif FV_UNICODE} + +begin + abstract; +end; + +procedure Toutlineviewer.handleevent(var event:Tevent); + +var mouse:Tpoint; + cur:pointer; + new_focus:sw_integer; + count:byte; + handled,m,mouse_drag:boolean; +{$ifdef FV_UNICODE} + graph:UnicodeString; +{$else FV_UNICODE} + graph:string; +{$endif FV_UNICODE} + +{$ifdef FV_UNICODE} + function graph_of_focus(var graph:UnicodeString):pointer; +{$else FV_UNICODE} + function graph_of_focus(var graph:string):pointer; +{$endif FV_UNICODE} + + var _level:sw_integer; + _lines:longInt; + _flags:word; + + function find_focused(cur:pointer;level,position:sw_integer; + lines:longint;flags:word):boolean; + + begin + find_focused:=position=foc; + if find_focused then + begin + _level:=level; + _lines:=lines; + _flags:=flags; + end; + end; + + begin + graph_of_focus:=firstthat(@find_focused); + graph:=getgraph(_level,_lines,_flags); + end; + +const skip_mouse_events=3; + +begin + inherited handleevent(event); + case event.what of + evKeyboard: + begin + new_focus:=foc; + handled:=true; + case ctrltoarrow(event.keycode) of + kbUp,kbLeft: + dec(new_focus); + kbDown,kbRight: + inc(new_focus); + kbPgDn: + inc(new_focus,size.y-1); + kbPgUp: + dec(new_focus,size.y-1); + kbCtrlPgUp: + new_focus:=0; + kbCtrlPgDn: + new_focus:=limit.y-1; + kbHome: + new_focus:=delta.y; + kbEnd: + new_focus:=delta.y+size.y-1; + kbCtrlEnter,kbEnter: + selected(new_focus); + else + case event.charcode of + '-','+': + begin + adjust(getnode(new_focus),event.charcode='+'); + update; + end; + '*': + begin + expandall(getnode(new_focus)); + update; + end; + else + handled:=false; + end; + end; + if new_focus<0 then + new_focus:=0; + if new_focus>=limit.y then + new_focus:=limit.y-1; + if foc<>new_focus then + set_focus(new_focus); + if handled then + clearevent(event); + end; + evMouseDown: + begin + count:=1; + mouse_drag:=false; + repeat + makelocal(event.where,mouse); + if mouseinview(event.where) then + new_focus:=delta.y+mouse.y + else + begin + inc(count,byte(event.what=evMouseAuto)); + if count and skip_mouse_events=0 then + begin + if mouse.y<0 then + dec(new_focus); + if mouse.y>=size.y then + inc(new_focus); + end; + end; + if new_focus<0 then + new_focus:=0; + if new_focus>=limit.y then + new_focus:=limit.y-1; + if foc<>new_focus then + set_focus(new_focus); + m:=mouseevent(event,evMouseMove+evMouseAuto); + if m then + mouse_drag:=true; + until not m; + if event.double then + selected(foc) + else if not mouse_drag then + begin + cur:=graph_of_focus(graph); + if mouse.x<length(graph) then + begin + adjust(cur,not isexpanded(cur)); + update; + end; + end; + end; + end; +end; + + +function Toutlineviewer.haschildren(node:pointer):boolean; + +begin + abstract; +end; + +function Toutlineviewer.isexpanded(node:pointer):boolean; + +begin + abstract; +end; + +function Toutlineviewer.isselected(i:sw_integer):boolean; + +begin + isselected:=foc=i; +end; + +procedure Toutlineviewer.selected(i:sw_integer); + +begin + {Does nothing by default.} +end; + +procedure Toutlineviewer.set_focus(Afocus:sw_integer); + +begin + assert((Afocus>=0) and (Afocus<limit.y)); + focused(Afocus); + if Afocus<delta.y then + scrollto(delta.x,Afocus) + else if Afocus-size.y>=delta.y then + scrollto(delta.x,Afocus-size.y+1); + drawview; +end; + +procedure Toutlineviewer.setstate(Astate:word;enable:boolean); + +begin + if Astate and sffocused<>0 then + drawview; + inherited setstate(Astate,enable); +end; + +procedure Toutlineviewer.update; + +var count:sw_integer; + maxwidth:byte; + + procedure check_item(cur:pointer;level,position:sw_integer; + lines:longint;flags:word); + + var width:word; + + begin + inc(count); + width:=length(gettext(cur))+length(getgraph(level,lines,flags)); + if width>maxwidth then + maxwidth:=width; + end; + +begin + count:=0; + maxwidth:=0; + foreach(@check_item); + setlimit(maxwidth,count); + set_focus(foc); +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ Toutline object methods } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +constructor Toutline.init(var bounds:Trect; + AHscrollbar,AVscrollbar:Pscrollbar; + Aroot:Pnode); + +begin + inherited init(bounds,AHscrollbar,AVscrollbar); + root:=Aroot; + update; +end; + +procedure Toutline.adjust(node:pointer;expand:boolean); + +begin + assert(node<>nil); + Pnode(node)^.expanded:=expand; +end; + +function Toutline.getnumchildren(node:pointer):sw_integer; + +var p:Pnode; + +begin + assert(node<>nil); + p:=Pnode(node)^.childlist; + getnumchildren:=0; + while p<>nil do + begin + inc(getnumchildren); + p:=p^.next; + end; +end; + +function Toutline.getchild(node:pointer;i:sw_integer):pointer; + +begin + assert(node<>nil); + getchild:=Pnode(node)^.childlist; + while i<>0 do + begin + dec(i); + getchild:=Pnode(getchild)^.next; + end; +end; + +function Toutline.getroot:pointer; + +begin + getroot:=root; +end; + +{$ifdef FV_UNICODE} +function Toutline.gettext(node:pointer):UnicodeString; +{$else FV_UNICODE} +function Toutline.gettext(node:pointer):string; +{$endif FV_UNICODE} + +begin + assert(node<>nil); +{$ifdef FV_UNICODE} + gettext:=Pnode(node)^.text; +{$else FV_UNICODE} + gettext:=Pnode(node)^.text^; +{$endif FV_UNICODE} +end; + +function Toutline.haschildren(node:pointer):boolean; + +begin + assert(node<>nil); + haschildren:=Pnode(node)^.childlist<>nil; +end; + +function Toutline.isexpanded(node:pointer):boolean; + +begin + assert(node<>nil); + isexpanded:=Pnode(node)^.expanded; +end; + +destructor Toutline.done; + +begin + disposenode(root); + inherited done; +end; + +end. diff --git a/packages/fv/src/outline.pas b/packages/fv/src/outline.pas index 6690f3b7ae..1ddc1dc4a2 100644 --- a/packages/fv/src/outline.pas +++ b/packages/fv/src/outline.pas @@ -1,705 +1 @@ -unit outline; - -{$CODEPAGE cp437} - -{***************************************************************************} - interface -{***************************************************************************} - -uses drivers,objects,views; - -type Pnode=^Tnode; - Tnode=record - next:Pnode; - text:Pstring; - childlist:Pnode; - expanded:boolean; - end; - - Poutlineviewer=^Toutlineviewer; - Toutlineviewer=object(Tscroller) - foc:sw_integer; - constructor init(var bounds:Trect; - AHscrollbar,AVscrollbar:Pscrollbar); - procedure adjust(node:pointer;expand:boolean);virtual; - function creategraph(level:integer;lines:longint; - flags:word;levwidth,endwidth:integer; - const chars:string):string; - procedure draw;virtual; - procedure expandall(node:pointer); - function firstthat(test:codepointer):pointer; - procedure focused(i:sw_integer);virtual; - procedure foreach(action:codepointer); - function getchild(node:pointer;i:sw_integer):pointer;virtual; - function getgraph(level:integer;lines:longint;flags:word):string; - function getnode(i:sw_integer):pointer;virtual; - function getnumchildren(node:pointer):sw_integer;virtual; - function getpalette:Ppalette;virtual; - function getroot:pointer;virtual; - function gettext(node:pointer):string;virtual; - procedure handleevent(var event:Tevent);virtual; - function haschildren(node:pointer):boolean;virtual; - function isexpanded(node:pointer):boolean;virtual; - function isselected(i:sw_integer):boolean;virtual; - procedure selected(i:sw_integer);virtual; - procedure setstate(Astate:word;enable:boolean);virtual; - procedure update; - private - procedure set_focus(Afocus:sw_integer); - function do_recurse(action:codepointer;callerframe:pointer; - stop_if_found:boolean):pointer; - end; - - Poutline=^Toutline; - Toutline=object(Toutlineviewer) - root:Pnode; - constructor init(var bounds:Trect; - AHscrollbar,AVscrollbar:Pscrollbar; - Aroot:Pnode); - procedure adjust(node:pointer;expand:boolean);virtual; - function getchild(node:pointer;i:sw_integer):pointer;virtual; - function getnumchildren(node:pointer):sw_integer;virtual; - function getroot:pointer;virtual; - function gettext(node:pointer):string;virtual; - function haschildren(node:pointer):boolean;virtual; - function isexpanded(node:pointer):boolean;virtual; - destructor done;virtual; - end; - -const ovExpanded = $1; - ovChildren = $2; - ovLast = $4; - - Coutlineviewer=Cscroller+#8#8; - -function newnode(const Atext:string;Achildren,Anext:Pnode):Pnode; -procedure disposenode(node:Pnode); - - -{***************************************************************************} - implementation -{***************************************************************************} - -type TMyFunc = function(_EBP: Pointer; Cur: Pointer; - Level, Position: sw_integer; Lines: LongInt; - Flags: Word): Boolean; - - -function newnode(const Atext:string;Achildren,Anext:Pnode):Pnode; - -begin - newnode:=new(Pnode); - with newnode^ do - begin - next:=Anext; - text:=newstr(Atext); - childlist:=Achildren; - expanded:=true; - end; -end; - -procedure disposenode(node:Pnode); - -var next:Pnode; - -begin - while node<>nil do - begin - disposenode(node^.childlist); - disposestr(node^.text); - next:=node^.next; - dispose(node); - node:=next; - end; -end; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ Toutlineviewer object methods } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -constructor Toutlineviewer.init(var bounds:Trect; - AHscrollbar,AVscrollbar:Pscrollbar); - -begin - inherited init(bounds,AHscrollbar,AVscrollbar); - foc:=0; - growmode:=gfGrowHiX+gfGrowHiY; -end; - -procedure Toutlineviewer.adjust(node:pointer;expand:boolean); - -begin - abstract; -end; - -function TOutlineViewer.CreateGraph(Level: Integer; Lines: LongInt; - Flags: Word; LevWidth, EndWidth: Integer; - const Chars: String): String; -const - FillerOrBar = 0; - YorL = 2; - StraightOrTee= 4; - Retracted = 6; -var - Last, Children, Expanded: Boolean; - I , J : Byte; - Graph : String; - -begin - { Load registers } - graph:=space(Level*LevWidth+EndWidth+1); - - { Write bar characters } - J := 1; - while (Level > 0) do - begin - Inc(J); - if (Lines and 1) <> 0 then - Graph[J] := Chars[FillerOrBar+2] - else - Graph[J] := Chars[FillerOrBar+1]; - for I := 1 to LevWidth - 1 do - Graph[I]:= Chars[FillerOrBar+1]; - J := J + LevWidth - 1; - Dec(Level); - Lines := Lines shr 1; - end; - - { Write end characters } - Dec(EndWidth); - if EndWidth > 0 then - begin - Inc(J); - if Flags and ovLast <> 0 then - Graph[J] := Chars[YorL+2] - else - Graph[J] := Chars[YorL+1]; - Dec(EndWidth); - if EndWidth > 0 then - begin - Dec(EndWidth); - for I := 1 to EndWidth do - Graph[I]:= Chars[StraightOrTee+1]; - J := J + EndWidth; - Inc(J); - if (Flags and ovChildren) <> 0 then - Graph[J] := Chars[StraightOrTee+2] - else - Graph[J] := Chars[StraightOrTee+1]; - end; - Inc(J); - if Flags and ovExpanded <> 0 then - Graph[J] := Chars[Retracted+2] - else - Graph[J] := Chars[Retracted+1]; - end; - Graph[0] := Char(J); - - CreateGraph := Graph; -end; - -function Toutlineviewer.do_recurse(action:codepointer;callerframe:pointer; - stop_if_found:boolean):pointer; - -var position:sw_integer; - r:pointer; - - function recurse(cur:pointer;level:integer;lines:longint;lastchild:boolean):pointer; - - var i,childcount:sw_integer; - child:pointer; - flags:word; - children,expanded,found:boolean; - - begin - inc(position); - recurse:=nil; - - children:=haschildren(cur); - expanded:=isexpanded(cur); - - {Determine flags.} - flags:=0; - if not children or expanded then - inc(flags,ovExpanded); - if children and expanded then - inc(flags,ovChildren); - if lastchild then - inc(flags,ovLast); - - {Call the function.} - found:=TMyFunc(action)(callerframe,cur,level,position,lines,flags); - - if stop_if_found and found then - recurse:=cur - else if children and expanded then {Recurse children?} - begin - if not lastchild then - lines:=lines or (1 shl level); - {Iterate all childs.} - childcount:=getnumchildren(cur); - for i:=0 to childcount-1 do - begin - child:=getchild(cur,i); - if (child<>nil) and (level<31) then - recurse:=recurse(child,level+1,lines,i=childcount-1); - {Did we find a node?} - if recurse<>nil then - break; - end; - end; - end; - -begin - position:=-1; - r:=getroot; - if r<>nil then - do_recurse:=recurse(r,0,0,true) - else - do_recurse:=nil; -end; - -procedure Toutlineviewer.draw; - -var c_normal,c_normal_x,c_select,c_focus:byte; - maxpos:sw_integer; - b:Tdrawbuffer; - - function draw_item(cur:pointer;level,position:sw_integer; - lines:longint;flags:word):boolean; - - var c,i:byte; - s,t:string; - - begin - draw_item:=position>=delta.y+size.y; - if (position<delta.y) or draw_item then - exit; - - maxpos:=position; - s:=getgraph(level,lines,flags); - t:=gettext(cur); - - {Determine text colour.} - if (foc=position) and (state and sffocused<>0) then - c:=c_focus - else if isselected(position) then - c:=c_select - else if flags and ovexpanded<>0 then - c:=c_normal_x - else - c:=c_normal; - - {Fill drawbuffer with graph and text to draw.} - for i:=0 to size.x-1 do - begin - wordrec(b[i]).hi:=c; - if i+delta.x<length(s) then - wordrec(b[i]).lo:=byte(s[1+i+delta.x]) - else if 1+i+delta.x-length(s)<=length(t) then - wordrec(b[i]).lo:=byte(t[1+i+delta.x-length(s)]) - else - wordrec(b[i]).lo:=byte(' '); - end; - - {Draw!} - writeline(0,position-delta.y,size.x,1,b); - end; - -begin - c_normal:=getcolor(4); - c_normal_x:=getcolor(1); - c_focus:=getcolor(2); - c_select:=getcolor(3); - maxpos:=-1; - foreach(@draw_item); - movechar(b,' ',c_normal,size.x); - writeline(0,maxpos+1,size.x,size.y-(maxpos-delta.y),b); -end; - -procedure Toutlineviewer.expandall(node:pointer); - -var i:sw_integer; - -begin - if haschildren(node) then - begin - for i:=0 to getnumchildren(node)-1 do - expandall(getchild(node,i)); - adjust(node,true); - end; -end; - -function Toutlineviewer.firstthat(test:codepointer):pointer; - -begin - firstthat:=do_recurse(test, - { On most systems, locals are accessed relative to base pointer, - but for MIPS cpu, they are accessed relative to stack pointer. - This needs adaptation for so low level routines, - like MethodPointerLocal and related objects unit functions. } -{$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE} - get_caller_frame(get_frame,get_pc_addr) -{$else} - get_frame -{$endif} - ,true); -end; - -procedure Toutlineviewer.focused(i:sw_integer); - -begin - foc:=i; -end; - -procedure Toutlineviewer.foreach(action:codepointer); - -begin - do_recurse(action, - { On most systems, locals are accessed relative to base pointer, - but for MIPS cpu, they are accessed relative to stack pointer. - This needs adaptation for so low level routines, - like MethodPointerLocal and related objects unit functions. } -{$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE} - get_caller_frame(get_frame,get_pc_addr) -{$else} - get_frame -{$endif} - ,false); -end; - -function Toutlineviewer.getchild(node:pointer;i:sw_integer):pointer; - -begin - abstract; -end; - -function Toutlineviewer.getgraph(level:integer;lines:longint; - flags:word):string; - -begin - getgraph:=creategraph(level,lines,flags,3,3,' ³ÃÀÄÄ+Ä'); -end; - -function Toutlineviewer.getnode(i:sw_integer):pointer; - - function test_position(node:pointer;level,position:sw_integer;lines:longInt; - flags:word):boolean; - - begin - test_position:=position=i; - end; - -begin - getnode:=firstthat(@test_position); -end; - -function Toutlineviewer.getnumchildren(node:pointer):sw_integer; - -begin - abstract; -end; - -function Toutlineviewer.getpalette:Ppalette; - -const p:string[length(Coutlineviewer)]=Coutlineviewer; - -begin - getpalette:=@p; -end; - -function Toutlineviewer.getroot:pointer; - -begin - abstract; -end; - -function Toutlineviewer.gettext(node:pointer):string; - -begin - abstract; -end; - -procedure Toutlineviewer.handleevent(var event:Tevent); - -var mouse:Tpoint; - cur:pointer; - new_focus:sw_integer; - count:byte; - handled,m,mouse_drag:boolean; - graph:string; - - function graph_of_focus(var graph:string):pointer; - - var _level:sw_integer; - _lines:longInt; - _flags:word; - - function find_focused(cur:pointer;level,position:sw_integer; - lines:longint;flags:word):boolean; - - begin - find_focused:=position=foc; - if find_focused then - begin - _level:=level; - _lines:=lines; - _flags:=flags; - end; - end; - - begin - graph_of_focus:=firstthat(@find_focused); - graph:=getgraph(_level,_lines,_flags); - end; - -const skip_mouse_events=3; - -begin - inherited handleevent(event); - case event.what of - evKeyboard: - begin - new_focus:=foc; - handled:=true; - case ctrltoarrow(event.keycode) of - kbUp,kbLeft: - dec(new_focus); - kbDown,kbRight: - inc(new_focus); - kbPgDn: - inc(new_focus,size.y-1); - kbPgUp: - dec(new_focus,size.y-1); - kbCtrlPgUp: - new_focus:=0; - kbCtrlPgDn: - new_focus:=limit.y-1; - kbHome: - new_focus:=delta.y; - kbEnd: - new_focus:=delta.y+size.y-1; - kbCtrlEnter,kbEnter: - selected(new_focus); - else - case event.charcode of - '-','+': - begin - adjust(getnode(new_focus),event.charcode='+'); - update; - end; - '*': - begin - expandall(getnode(new_focus)); - update; - end; - else - handled:=false; - end; - end; - if new_focus<0 then - new_focus:=0; - if new_focus>=limit.y then - new_focus:=limit.y-1; - if foc<>new_focus then - set_focus(new_focus); - if handled then - clearevent(event); - end; - evMouseDown: - begin - count:=1; - mouse_drag:=false; - repeat - makelocal(event.where,mouse); - if mouseinview(event.where) then - new_focus:=delta.y+mouse.y - else - begin - inc(count,byte(event.what=evMouseAuto)); - if count and skip_mouse_events=0 then - begin - if mouse.y<0 then - dec(new_focus); - if mouse.y>=size.y then - inc(new_focus); - end; - end; - if new_focus<0 then - new_focus:=0; - if new_focus>=limit.y then - new_focus:=limit.y-1; - if foc<>new_focus then - set_focus(new_focus); - m:=mouseevent(event,evMouseMove+evMouseAuto); - if m then - mouse_drag:=true; - until not m; - if event.double then - selected(foc) - else if not mouse_drag then - begin - cur:=graph_of_focus(graph); - if mouse.x<length(graph) then - begin - adjust(cur,not isexpanded(cur)); - update; - end; - end; - end; - end; -end; - - -function Toutlineviewer.haschildren(node:pointer):boolean; - -begin - abstract; -end; - -function Toutlineviewer.isexpanded(node:pointer):boolean; - -begin - abstract; -end; - -function Toutlineviewer.isselected(i:sw_integer):boolean; - -begin - isselected:=foc=i; -end; - -procedure Toutlineviewer.selected(i:sw_integer); - -begin - {Does nothing by default.} -end; - -procedure Toutlineviewer.set_focus(Afocus:sw_integer); - -begin - assert((Afocus>=0) and (Afocus<limit.y)); - focused(Afocus); - if Afocus<delta.y then - scrollto(delta.x,Afocus) - else if Afocus-size.y>=delta.y then - scrollto(delta.x,Afocus-size.y+1); - drawview; -end; - -procedure Toutlineviewer.setstate(Astate:word;enable:boolean); - -begin - if Astate and sffocused<>0 then - drawview; - inherited setstate(Astate,enable); -end; - -procedure Toutlineviewer.update; - -var count:sw_integer; - maxwidth:byte; - - procedure check_item(cur:pointer;level,position:sw_integer; - lines:longint;flags:word); - - var width:word; - - begin - inc(count); - width:=length(gettext(cur))+length(getgraph(level,lines,flags)); - if width>maxwidth then - maxwidth:=width; - end; - -begin - count:=0; - maxwidth:=0; - foreach(@check_item); - setlimit(maxwidth,count); - set_focus(foc); -end; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ Toutline object methods } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -constructor Toutline.init(var bounds:Trect; - AHscrollbar,AVscrollbar:Pscrollbar; - Aroot:Pnode); - -begin - inherited init(bounds,AHscrollbar,AVscrollbar); - root:=Aroot; - update; -end; - -procedure Toutline.adjust(node:pointer;expand:boolean); - -begin - assert(node<>nil); - Pnode(node)^.expanded:=expand; -end; - -function Toutline.getnumchildren(node:pointer):sw_integer; - -var p:Pnode; - -begin - assert(node<>nil); - p:=Pnode(node)^.childlist; - getnumchildren:=0; - while p<>nil do - begin - inc(getnumchildren); - p:=p^.next; - end; -end; - -function Toutline.getchild(node:pointer;i:sw_integer):pointer; - -begin - assert(node<>nil); - getchild:=Pnode(node)^.childlist; - while i<>0 do - begin - dec(i); - getchild:=Pnode(getchild)^.next; - end; -end; - -function Toutline.getroot:pointer; - -begin - getroot:=root; -end; - -function Toutline.gettext(node:pointer):string; - -begin - assert(node<>nil); - gettext:=Pnode(node)^.text^; -end; - -function Toutline.haschildren(node:pointer):boolean; - -begin - assert(node<>nil); - haschildren:=Pnode(node)^.childlist<>nil; -end; - -function Toutline.isexpanded(node:pointer):boolean; - -begin - assert(node<>nil); - isexpanded:=Pnode(node)^.expanded; -end; - -destructor Toutline.done; - -begin - disposenode(root); - inherited done; -end; - -end. +{$I outline.inc} diff --git a/packages/fv/src/platform.inc b/packages/fv/src/platform.inc index c523629802..410ae39dad 100644 --- a/packages/fv/src/platform.inc +++ b/packages/fv/src/platform.inc @@ -175,7 +175,17 @@ FOR FPC THESE ARE THE TRANSLATIONS { FPC 64 BIT COMPILER added - Update 28Nov2010 PM } {---------------------------------------------------------------------------} {$IFDEF FPC} - {$mode fpc} + {$mode objfpc} + + {$MACRO ON} + + {$IFDEF FV_UNICODE} + {$DEFINE Sw_PString_DeRef:=} + {$DEFINE Sw_NewStr:=} + {$ELSE FV_UNICODE} + {$DEFINE Sw_PString_DeRef:=^} + {$DEFINE Sw_NewStr:=NewStr} + {$ENDIF FV_UNICODE} {$UNDEF PROC_Real} {$DEFINE PROC_Protected} diff --git a/packages/fv/src/resource.pas b/packages/fv/src/resource.pas index fe2a6cbc88..b69ba0cc70 100644 --- a/packages/fv/src/resource.pas +++ b/packages/fv/src/resource.pas @@ -326,7 +326,7 @@ end; procedure TConstant.SetValue (AValue: string); var N: Word; - ErrorCode: Integer; + ErrorCode: SmallInt; begin Val(AValue,N,ErrorCode); if ErrorCode = 0 then @@ -529,7 +529,7 @@ var var i, j: Byte; N: Byte; - ErrorCode: Integer; + ErrorCode: SmallInt; S: string; begin with Constant^ do diff --git a/packages/fv/src/statuses.pas b/packages/fv/src/statuses.pas index a32a463faa..f9d256ccb0 100644 --- a/packages/fv/src/statuses.pas +++ b/packages/fv/src/statuses.pas @@ -168,7 +168,11 @@ Highlighted TextÄÄÄÄÄÄÄÄÄÄÄÙ } {#Z-} {#X tvStatus TStatusDlg TStatusMessageDlg } - SpinChars : String[4] = '³/Ä\'; +{$ifdef FV_UNICODE} + SpinChars : UnicodeString = #$2502'/'#$2500'\'; +{$else FV_UNICODE} + SpinChars : String[4] = #179'/'#196'\'; +{$endif FV_UNICODE} { SpinChars are the characters used by a #TSpinnerGauge# when it is drawn. Only one character is displayed at a time. The string is cycled through then started over again until the view is disposed. } @@ -197,7 +201,7 @@ type Event.Command field against Command before handling the event. } {#X HandleEvent } constructor Init (R : TRect; ACommand : Word; AText : String; - AParamCount : Integer); + AParamCount : SmallInt); { Init calls the inherited constructor then sets #Command# to ACommand. If an error occurs Init fails. } @@ -471,7 +475,7 @@ Min = XXX Max = XXX Current = XXX } TPercentGauge = Object(TGauge) { A TPercentGauge displays a numerical percentage as returned by #Percent# followed by a '%' sign. } - function Percent : Integer; virtual; + function Percent : SmallInt; virtual; { Percent returns the whole number value of (Current / Max) * 100. } {#X TGauge.Current TGauge.Max } procedure Draw; virtual; @@ -505,7 +509,7 @@ Min = XXX Max = XXX Current = XXX } TSpinnerGauge = Object(TGauge) { A TSpinnerGauge displays a series of characters in one spot on the screen giving the illusion of a spinning line. } - constructor Init (X, Y : Integer; ACommand : Word); + constructor Init (X, Y : SmallInt; ACommand : Word); { Init calls the inherited constructor with AMin set to 0 and AMax set to 4. } procedure Draw; virtual; @@ -545,7 +549,7 @@ Min = XXX Max = XXX Current = XXX } memory. It responds to a cmStatusUpdate event by calling MaxAvail and comparing the result to #Max#, then updating the view if necessary. } {#X THeapMemAvail } - constructor Init (X, Y : Integer); + constructor Init (X, Y : SmallInt); { Init creates the view with the following text: MaxAvail = xxxx @@ -570,7 +574,7 @@ Min = XXX Max = XXX Current = XXX } MemAvail and comparing the result to #Max#, then updating the view if necessary. } {#X THeapMaxAvail } - constructor Init (X, Y : Integer); + constructor Init (X, Y : SmallInt); { Init creates the view with the following text: MemAvail = xxxx @@ -922,7 +926,7 @@ end; {****************************************************************************} { THeapMaxAvail.Init } {****************************************************************************} -constructor THeapMaxAvail.Init (X, Y : Integer); +constructor THeapMaxAvail.Init (X, Y : SmallInt); var R : TRect; begin @@ -953,7 +957,7 @@ end; {****************************************************************************} { THeapMemAvail.Init } {****************************************************************************} -constructor THeapMemAvail.Init (X, Y : Integer); +constructor THeapMemAvail.Init (X, Y : SmallInt); var R : TRect; begin @@ -991,7 +995,7 @@ var C : Word; S : String; PercentDone : LongInt; - FillSize : Integer; + FillSize : SmallInt; begin C := GetColor(1); MoveChar(B,' ',C,Size.X); @@ -1005,8 +1009,8 @@ end; {****************************************************************************} { TPercentGauge.Percent } {****************************************************************************} -function TPercentGauge.Percent : Integer; - { Returns percent as a whole integer Current of Max } +function TPercentGauge.Percent : SmallInt; + { Returns percent as a whole SmallInt Current of Max } begin Percent := Round((Current/Max) * 100); end; @@ -1018,7 +1022,7 @@ end; {****************************************************************************} { TSpinnerGauge.Init } {****************************************************************************} -constructor TSpinnerGauge.Init (X, Y : Integer; ACommand : Word); +constructor TSpinnerGauge.Init (X, Y : SmallInt; ACommand : Word); var R : TRect; begin R.Assign(X,Y,X+1,Y+1); @@ -1067,7 +1071,7 @@ end; { TStatus.Init } {****************************************************************************} constructor TStatus.Init (R : TRect; ACommand : Word; AText : String; - AParamCount : Integer); + AParamCount : SmallInt); begin if (not TParamText.Init(R,AText,AParamCount)) then Fail; @@ -1295,7 +1299,7 @@ var R : TRect; P : PButton; Buttons : Byte; - X, Y, Gap : Integer; + X, Y, Gap : SmallInt; i : Word; begin Buttons := Byte(((AFlags and sdCancelButton) = sdCancelButton)); @@ -1354,7 +1358,7 @@ constructor TStatusMessageDlg.Init (ATitle : TTitleStr; AStatus : PStatus; AFlags : Word; AMessage : String); var P : PStaticText; - X, Y : Integer; + X, Y : SmallInt; R : TRect; begin if not TStatusDlg.Init(ATitle,AStatus,AFlags) then diff --git a/packages/fv/src/stddlg.pas b/packages/fv/src/stddlg.pas index 948916b82d..6a4bea07ec 100644 --- a/packages/fv/src/stddlg.pas +++ b/packages/fv/src/stddlg.pas @@ -925,7 +925,7 @@ begin end; function MatchesMaskList(What, MaskList: string): boolean; -var P: integer; +var P: SmallInt; Match: boolean; begin Match:=false; @@ -1832,12 +1832,21 @@ begin end; procedure TDirListBox.NewDirectory(var ADir: DirStr); +{$ifdef FV_UNICODE} const - PathDir = 'ÀÄÂ'; - FirstDir = 'ÀÂÄ'; - MiddleDir = ' ÃÄ'; - LastDir = ' ÀÄ'; + PathDir = #$2514#$2500#$252C; + FirstDir = #$2514#$252C#$2500; + MiddleDir = ' '#$251C#$2500; + LastDir = ' '#$2514#$2500; IndentSize = ' '; +{$else FV_UNICODE} +const + PathDir = #192#196#194; + FirstDir = #192#194#196; + MiddleDir = ' '#195#196; + LastDir = ' '#192#196; + IndentSize = ' '; +{$endif FV_UNICODE} var AList: PCollection; NewDir, Dirct: DirStr; @@ -1943,16 +1952,29 @@ begin end; FindClose(SR); P := PDirEntry(AList^.At(AList^.Count-1))^.DisplayText; - I := Pos('À',P^); +{$ifdef FV_UNICODE} + I := Pos(#$2514,P^); + if I = 0 then + begin + I := Pos(#$251C,P^); + if I <> 0 then P^[I] := #$2514; + end else + begin + P^[I+1] := #$2500; + P^[I+2] := #$2500; + end; +{$else FV_UNICODE} + I := Pos(#192,P^); if I = 0 then begin - I := Pos('Ã',P^); - if I <> 0 then P^[I] := 'À'; + I := Pos(#195,P^); + if I <> 0 then P^[I] := #192; end else begin - P^[I+1] := 'Ä'; - P^[I+2] := 'Ä'; + P^[I+1] := #196; + P^[I+2] := #196; end; +{$endif FV_UNICODE} end; NewList(AList); FocusItem(NewCur); @@ -2485,31 +2507,29 @@ end; function IsDir(const S: String): Boolean; var SR: SearchRec; - Is: boolean; begin - Is:=false; + Result:=false; {$ifdef Unix} - Is:=(S=DirSeparator); { handle root } + Result:=(S=DirSeparator); { handle root } {$else} {$ifdef HASAMIGA} - Is := (Length(S) > 0) and (S[Length(S)] = DriveSeparator); + Result := (Length(S) > 0) and (S[Length(S)] = DriveSeparator); {$else} - Is:=(length(S)=3) and (Upcase(S[1]) in['A'..'Z']) and (S[2]=':') and (S[3]=DirSeparator); + Result:=(length(S)=3) and (Upcase(S[1]) in['A'..'Z']) and (S[2]=':') and (S[3]=DirSeparator); {$endif} { handle root dirs } {$endif} - if Is=false then + if Result=false then begin FindFirst(S, Directory, SR); if DosError = 0 then - Is := (SR.Attr and Directory) <> 0 + Result := (SR.Attr and Directory) <> 0 else - Is := False; + Result := False; {$ifdef fpc} FindClose(SR); {$endif} end; - IsDir:=Is; end; {****************************************************************************} diff --git a/packages/fv/src/tabs.inc b/packages/fv/src/tabs.inc new file mode 100644 index 0000000000..ffd082822b --- /dev/null +++ b/packages/fv/src/tabs.inc @@ -0,0 +1,814 @@ +{ + + Tabbed group for TV/FV dialogs + + Copyright 2000-4 by Free Pascal core team + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, + MA 02110-1301, USA. + + ****************************************************************************} +{$ifdef FV_UNICODE} +unit utabs; +{$else FV_UNICODE} +unit tabs; +{$endif FV_UNICODE} + +{$I platform.inc} (* Multi-platform support defines *) +{$CODEPAGE cp437} + +interface + +uses + objects, +{$ifdef FV_UNICODE} + UFvCommon, + udrivers, + uviews, +{$else FV_UNICODE} + FvCommon, + drivers, + views, +{$endif FV_UNICODE} + fvconsts; + + +type + PTabItem = ^TTabItem; + TTabItem = record + Next : PTabItem; + View : PView; + Dis : boolean; + end; + + PTabDef = ^TTabDef; + TTabDef = record + Next : PTabDef; + Name : Sw_PString; + Items : PTabItem; + DefItem : PView; + ShortCut : char; + end; + + PTab = ^TTab; + TTab = object(TGroup) + TabDefs : PTabDef; + ActiveDef : SmallInt; + DefCount : word; + constructor Init(var Bounds: TRect; ATabDef: PTabDef); + constructor Load (var S: TStream); + function AtTab(Index: SmallInt): PTabDef; virtual; + procedure SelectTab(Index: SmallInt); virtual; + procedure Store (var S: TStream); + function TabCount: SmallInt; + function Valid(Command: Word): Boolean; virtual; + procedure ChangeBounds(var Bounds: TRect); virtual; + procedure HandleEvent(var Event: TEvent); virtual; + function GetPalette: PPalette; virtual; + procedure Draw; virtual; + function DataSize: sw_word;virtual; + procedure SetData(var Rec);virtual; + procedure GetData(var Rec);virtual; + procedure SetState(AState: Word; Enable: Boolean); virtual; + destructor Done; virtual; + private + InDraw: boolean; + function FirstSelectable: PView; + function LastSelectable: PView; + end; + +function NewTabItem(AView: PView; ANext: PTabItem): PTabItem; +procedure DisposeTabItem(P: PTabItem); +function NewTabDef(AName: Sw_String; ADefItem: PView; AItems: PTabItem; ANext: PTabDef): PTabDef; +procedure DisposeTabDef(P: PTabDef); + +procedure RegisterTab; + +const + RTab: TStreamRec = ( + ObjType: idTab; +{$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs (TypeOf (TTab)^); +{$ELSE BP_VMTLink} { Alt style VMT link } + VmtLink: TypeOf (TTab); +{$ENDIF BP_VMTLink} + Load: @TTab.Load; + Store: @TTab.Store + ); + + +implementation + +uses +{$ifdef FV_UNICODE} + Udialogs; +{$else FV_UNICODE} + dialogs; +{$endif FV_UNICODE} + +constructor TTab.Init(var Bounds: TRect; ATabDef: PTabDef); +begin + inherited Init(Bounds); + Options:=Options or ofSelectable or ofFirstClick or ofPreProcess or ofPostProcess; + GrowMode:=gfGrowHiX+gfGrowHiY+gfGrowRel; + TabDefs:=ATabDef; + ActiveDef:=-1; + SelectTab(0); + ReDraw; +end; + +constructor TTab.Load (var S: TStream); + + function DoLoadTabItems (var XDefItem: PView; ActItem: longint): PTabItem; + var + Count: longint; + Cur, First: PTabItem; + Last: ^PTabItem; + begin + Cur := nil; { Preset nil } + Last := @First; { Start on first item } + S.Read (Count, SizeOf(Count)); { Read item count } + while (Count > 0) do + begin + New (Cur); { New status item } + Last^ := Cur; { First chain part } + if (Cur <> nil) then { Check pointer valid } + begin + Last := @Cur^.Next; { Chain complete } + S.Read (Cur^.Dis, SizeOf (Cur^.Dis)); + Cur^.View := PView (S.Get); + if ActItem = 0 then + XDefItem := Cur^.View; { Find default view } + end; + Dec (Count); { One item loaded } + Dec (ActItem); + end; + Last^ := nil; { Now chain end } + DoLoadTabItems := First; { Return the list } + end; + + function DoLoadTabDefs: PTabDef; + var + Count: longint; + Cur, First: PTabDef; + Last: ^PTabDef; + ActItem: longint; + begin + Last := @First; { Start on first } + Count := DefCount; + while (Count > 0) do + begin + New (Cur); { New status def } + Last^ := Cur; { First part of chain } + if (Cur <> nil) then { Check pointer valid } + begin + Last := @Cur^.Next; { Chain complete } +{$ifdef FV_UNICODE} + Cur^.Name := S.ReadUnicodeString; { Read name } +{$else FV_UNICODE} + Cur^.Name := S.ReadStr; { Read name } +{$endif FV_UNICODE} + S.Read (Cur^.ShortCut, SizeOf (Cur^.ShortCut)); + S.Read (ActItem, SizeOf (ActItem)); + Cur^.Items := DoLoadTabItems (Cur^.DefItem, ActItem); { Set pointer } + end; + Dec (Count); { One item loaded } + end; + Last^ := nil; { Now chain ends } + DoLoadTabDefs := First; { Return item list } + end; + +begin + inherited Load (S); + S.Read (DefCount, SizeOf (DefCount)); + S.Read (ActiveDef, SizeOf (ActiveDef)); + TabDefs := DoLoadTabDefs; +end; + +procedure TTab.Store (var S: TStream); + + procedure DoStoreTabItems (Cur: PTabItem; XDefItem: PView); + var + Count: longint; + T: PTabItem; + ActItem: longint; + begin + Count := 0; { Clear count } + T := Cur; { Start on current } + while (T <> nil) do + begin + if T^.View = XDefItem then { Current = active? } + ActItem := Count; { => set order } + Inc (Count); { Count items } + T := T^.Next; { Next item } + end; + S.Write (ActItem, SizeOf (ActItem)); + S.Write (Count, SizeOf (Count)); { Write item count } + while (Cur <> nil) do + begin + S.Write (Cur^.Dis, SizeOf (Cur^.Dis)); + S.Put (Cur^.View); + end; + end; + + procedure DoStoreTabDefs (Cur: PTabDef); + begin + while (Cur <> nil) do + begin + with Cur^ do + begin +{$ifdef FV_UNICODE} + S.WriteUnicodeString(Cur^.Name); { Write name } +{$else FV_UNICODE} + S.WriteStr (Cur^.Name); { Write name } +{$endif FV_UNICODE} + S.Write (Cur^.ShortCut, SizeOf (Cur^.ShortCut)); + DoStoreTabItems (Items, DefItem); { Store the items } + end; + Cur := Cur^.Next; { Next status item } + end; + end; + +begin + inherited Store (S); + S.Write (DefCount, SizeOf (DefCount)); + S.Write (ActiveDef, SizeOf (ActiveDef)); + DoStoreTabDefs (TabDefs); +end; + +function TTab.TabCount: SmallInt; +var i: SmallInt; + P: PTabDef; +begin + I:=0; P:=TabDefs; + while (P<>nil) do + begin + Inc(I); + P:=P^.Next; + end; + TabCount:=I; +end; + + +function TTab.AtTab(Index: SmallInt): PTabDef; +var i: SmallInt; + P: PTabDef; +begin + i:=0; P:=TabDefs; + while (I<Index) do + begin + if P=nil then RunError($AA); + P:=P^.Next; + Inc(i); + end; + AtTab:=P; +end; + +procedure TTab.SelectTab(Index: SmallInt); +var P: PTabItem; + V: PView; +begin + if ActiveDef<>Index then + begin + if Owner<>nil then Owner^.Lock; + Lock; + { --- Update --- } + if TabDefs<>nil then + begin + DefCount:=1; + while AtTab(DefCount-1)^.Next<>nil do Inc(DefCount); + end + else DefCount:=0; + if ActiveDef<>-1 then + begin + P:=AtTab(ActiveDef)^.Items; + while P<>nil do + begin + if P^.View<>nil then Delete(P^.View); + P:=P^.Next; + end; + end; + ActiveDef:=Index; + P:=AtTab(ActiveDef)^.Items; + while P<>nil do + begin + if P^.View<>nil then Insert(P^.View); + P:=P^.Next; + end; + V:=AtTab(ActiveDef)^.DefItem; + if V<>nil then V^.Select; + ReDraw; + { --- Update --- } + UnLock; + if Owner<>nil then Owner^.UnLock; + DrawView; + end; +end; + +procedure TTab.ChangeBounds(var Bounds: TRect); +var D: TPoint; +procedure DoCalcChange(P: PView); {$ifndef FPC}far;{$endif} +var + R: TRect; +begin + if P^.Owner=nil then Exit; { it think this is a bug in TV } + P^.CalcBounds(R, D); + P^.ChangeBounds(R); +end; +var + P: PTabItem; + I: SmallInt; +begin + D.X := Bounds.B.X - Bounds.A.X - Size.X; + D.Y := Bounds.B.Y - Bounds.A.Y - Size.Y; + inherited ChangeBounds(Bounds); + for I:=0 to TabCount-1 do + if I<>ActiveDef then + begin + P:=AtTab(I)^.Items; + while P<>nil do + begin + if P^.View<>nil then DoCalcChange(P^.View); + P:=P^.Next; + end; + end; +end; + + +function TTab.FirstSelectable: PView; +var + FV : PView; +begin + FV := First; + while (FV<>nil) and ((FV^.Options and ofSelectable)=0) and (FV<>Last) do + FV:=FV^.Next; + if FV<>nil then + if (FV^.Options and ofSelectable)=0 then FV:=nil; + FirstSelectable:=FV; +end; + + +function TTab.LastSelectable: PView; +var + LV : PView; +begin + LV := Last; + while (LV<>nil) and ((LV^.Options and ofSelectable)=0) and (LV<>First) do + LV:=LV^.Prev; + if LV<>nil then + if (LV^.Options and ofSelectable)=0 then LV:=nil; + LastSelectable:=LV; +end; + +procedure TTab.HandleEvent(var Event: TEvent); +var Index : SmallInt; + I : SmallInt; + X : SmallInt; + Len : byte; + P : TPoint; + V : PView; + CallOrig: boolean; + LastV : PView; + FirstV: PView; +begin + if (Event.What and evMouseDown)<>0 then + begin + MakeLocal(Event.Where,P); + if P.Y<3 then + begin + Index:=-1; X:=1; + for i:=0 to DefCount-1 do + begin + Len:=CStrLen(AtTab(i)^.Name Sw_PString_Deref); + if (P.X>=X) and (P.X<=X+Len+1) then Index:=i; + X:=X+Len+3; + end; + if Index<>-1 then + SelectTab(Index); + end; + end; + if Event.What=evKeyDown then + begin + Index:=-1; + case Event.KeyCode of + kbTab,kbShiftTab : + if GetState(sfSelected) then + begin + if Current<>nil then + begin + LastV:=LastSelectable; FirstV:=FirstSelectable; + if ((Current=LastV) or (Current=PLabel(LastV)^.Link)) and (Event.KeyCode=kbShiftTab) then + begin + if Owner<>nil then Owner^.SelectNext(true); + end else + if ((Current=FirstV) or (Current=PLabel(FirstV)^.Link)) and (Event.KeyCode=kbTab) then + begin + Lock; + if Owner<>nil then Owner^.SelectNext(false); + UnLock; + end else + SelectNext(Event.KeyCode=kbShiftTab); + ClearEvent(Event); + end; + end; + kbCtrlPgUp: + begin + if ActiveDef > 0 then + Index := Pred (ActiveDef) + else + Index := Pred (DefCount); + ClearEvent(Event); + end; + kbCtrlPgDn: + begin + if ActiveDef < Pred (DefCount) then + Index := Succ (ActiveDef) + else + Index := 0; + ClearEvent(Event); + end; + else + for I:=0 to DefCount-1 do + begin + if (AtTab(I)^.ShortCut <> #0) and + (Upcase(GetAltChar(Event.KeyCode))=AtTab(I)^.ShortCut) + then begin + Index:=I; + ClearEvent(Event); + Break; + end; + end; + end; + if Index<>-1 then + begin + Select; + SelectTab(Index); + V:=AtTab(ActiveDef)^.DefItem; + if V<>nil then V^.Focus; + end; + end; + CallOrig:=true; + if Event.What=evKeyDown then + begin + if ((Owner<>nil) and (Owner^.Phase=phPostProcess) + and (GetAltChar(Event.KeyCode)<>#0)) or GetState(sfFocused) + then + else CallOrig:=false; + end; + if CallOrig then inherited HandleEvent(Event); +end; + +function TTab.GetPalette: PPalette; +begin + GetPalette:=nil; +end; + +{$define AVOIDTHREELINES} + +procedure TTab.Draw; +const +{$ifdef AVOIDTHREELINES} + UDL={$ifdef FV_UNICODE}#$2510{$else}#191{$endif}; + LUR={$ifdef FV_UNICODE}#$2500{$else}#196{$endif}; + URD={$ifdef FV_UNICODE}#$250C{$else}#218{$endif}; +{$else not AVOIDTHREELINES} + UDL={$ifdef FV_UNICODE}#$2524{$else}#180{$endif}; + LUR={$ifdef FV_UNICODE}#$2534{$else}#193{$endif}; + URD={$ifdef FV_UNICODE}#$251C{$else}#195{$endif}; +{$endif not AVOIDTHREELINES} + + +var B : TDrawBuffer; + i : SmallInt; + C1,C2,C3,C : word; + HeaderLen : SmallInt; + X,X2 : SmallInt; + Name : Sw_PString; + ActiveKPos : SmallInt; + ActiveVPos : SmallInt; + FC : char; +procedure SWriteBuf(X,Y,W,H: SmallInt; var Buf); +var i: SmallInt; +begin + if Y+H>Size.Y then H:=Size.Y-Y; + if X+W>Size.X then W:=Size.X-X; + if Buffer=nil then WriteBuf(X,Y,W,H,Buf) + else for i:=1 to H do + Move(Buf,Buffer^[X+(Y+i-1)*Size.X],W*2); +end; +procedure ClearBuf; +begin + MoveChar(B,' ',C1,Size.X); +end; +begin + if InDraw then Exit; + InDraw:=true; + { - Start of TGroup.Draw - } +{ if Buffer = nil then + begin + GetBuffer; + end; } + { - Start of TGroup.Draw - } + + C1:=GetColor(1); + C2:=(GetColor(7) and $f0 or $08)+GetColor(9)*256; + C3:=GetColor(8)+GetColor({9}8)*256; + + { Calculate the size of the headers } + HeaderLen:=0; + for i:=0 to DefCount-1 do + HeaderLen:=HeaderLen+CStrLen(AtTab(i)^.Name Sw_PString_Deref)+3; + Dec(HeaderLen); + if HeaderLen>Size.X-2 then HeaderLen:=Size.X-2; + + { --- 1. sor --- } + ClearBuf; + MoveChar(B[0],{$ifdef FV_UNICODE}#$2502{$else}#179{$endif},C1,1); + MoveChar(B[HeaderLen+1],{$ifdef FV_UNICODE}#$2502{$else}#179{$endif},C1,1); + X:=1; + for i:=0 to DefCount-1 do + begin + Name:=AtTab(i)^.Name; X2:=CStrLen(Name Sw_PString_Deref); + if i=ActiveDef + then begin + ActiveKPos:=X-1; + ActiveVPos:=X+X2+2; + if GetState(sfFocused) then C:=C3 else C:=C2; + end + else C:=C2; + MoveCStr(B[X],' '+Name Sw_PString_Deref+' ',C); + X:=X+X2+3; + MoveChar(B[X-1],{$ifdef FV_UNICODE}#$2502{$else}#179{$endif},C1,1); + end; + SWriteBuf(0,1,Size.X,1,B); + + { --- 0. sor --- } + ClearBuf; MoveChar(B[0],{$ifdef FV_UNICODE}#$250C{$else}#218{$endif},C1,1); + X:=1; + for i:=0 to DefCount-1 do + begin +{$ifdef AVOIDTHREELINES} + if I<ActiveDef then + FC:={$ifdef FV_UNICODE}#$250C{$else}#218{$endif} + else + FC:={$ifdef FV_UNICODE}#$2510{$else}#191{$endif}; +{$else not AVOIDTHREELINES} + FC:={$ifdef FV_UNICODE}#$252C{$else}#194{$endif}; +{$endif not AVOIDTHREELINES} + X2:=CStrLen(AtTab(i)^.Name Sw_PString_Deref)+2; + MoveChar(B[X+X2],FC,C1,1); + if i=DefCount-1 then X2:=X2+1; + if X2>0 then + MoveChar(B[X],{$ifdef FV_UNICODE}#$2500{$else}#196{$endif},C1,X2); + X:=X+X2+1; + end; + MoveChar(B[HeaderLen+1],{$ifdef FV_UNICODE}#$2510{$else}#191{$endif},C1,1); + MoveChar(B[ActiveKPos],{$ifdef FV_UNICODE}#$250C{$else}#218{$endif},C1,1); + MoveChar(B[ActiveVPos],{$ifdef FV_UNICODE}#$2510{$else}#191{$endif},C1,1); + SWriteBuf(0,0,Size.X,1,B); + + { --- 2. sor --- } + MoveChar(B[1],{$ifdef FV_UNICODE}#$2500{$else}#196{$endif},C1,Max(HeaderLen,0)); + MoveChar(B[HeaderLen+2],{$ifdef FV_UNICODE}#$2500{$else}#196{$endif},C1,Max(Size.X-HeaderLen-3,0)); + MoveChar(B[HeaderLen+1],LUR,C1,1); + MoveChar(B[ActiveKPos],{$ifdef FV_UNICODE}#$2518{$else}#217{$endif},C1,1); + if ActiveDef=0 then + MoveChar(B[0],{$ifdef FV_UNICODE}#$2502{$else}#179{$endif},C1,1) + else + MoveChar(B[0],URD,C1,1); + MoveChar(B[ActiveKPos+1],' ',C1,Max(ActiveVPos-ActiveKPos-1,0)); + MoveChar(B[ActiveVPos],{$ifdef FV_UNICODE}#$2514{$else}#192{$endif},C1,1); + if HeaderLen+1<Size.X-1 then + MoveChar(B[Size.X-1],{$ifdef FV_UNICODE}#$2510{$else}#191{$endif},C1,1) + else if (ActiveDef=DefCount-1) then + MoveChar(B[Size.X-1],{$ifdef FV_UNICODE}#$2502{$else}#179{$endif},C1,1) + else + MoveChar(B[Size.X-1],UDL,C1,1); + SWriteBuf(0,2,Size.X,1,B); + + { --- marad‚k sor --- } + ClearBuf; MoveChar(B[0],{$ifdef FV_UNICODE}#$2502{$else}#179{$endif},C1,1); + MoveChar(B[Size.X-1],{$ifdef FV_UNICODE}#$2502{$else}#179{$endif},C1,1); + {SWriteBuf(0,3,Size.X,Size.Y-4,B);} + for i:=3 to Size.Y-1 do + SWriteBuf(0,i,Size.X,1,B); + + { --- Size.X . sor --- } + MoveChar(B[0],{$ifdef FV_UNICODE}#$2514{$else}#192{$endif},C1,1); + MoveChar(B[1],{$ifdef FV_UNICODE}#$2500{$else}#196{$endif},C1,Max(Size.X-2,0)); + MoveChar(B[Size.X-1],{$ifdef FV_UNICODE}#$2518{$else}#217{$endif},C1,1); + SWriteBuf(0,Size.Y-1,Size.X,1,B); + + { - End of TGroup.Draw - } + if Buffer <> nil then + begin + Lock; + Redraw; + UnLock; + end; + if Buffer <> nil then + WriteBuf(0, 0, Size.X, Size.Y, Buffer^) + else + Redraw; + { - End of TGroup.Draw - } + InDraw:=false; +end; + +function TTab.Valid(Command: Word): Boolean; +var PT : PTabDef; + PI : PTabItem; + OK : boolean; +begin + OK:=true; + PT:=TabDefs; + while (PT<>nil) and (OK=true) do + begin + PI:=PT^.Items; + while (PI<>nil) and (OK=true) do + begin + if PI^.View<>nil then OK:=OK and PI^.View^.Valid(Command); + PI:=PI^.Next; + end; + PT:=PT^.Next; + end; + Valid:=OK; +end; + + +procedure TTab.SetData(var Rec); +type + Bytes = array[0..65534] of Byte; +var + I: Sw_Word; + PT : PTabDef; + PI : PTabItem; +begin + I := 0; + PT:=TabDefs; + while (PT<>nil) do + begin + PI:=PT^.Items; + while (PI<>nil) do + begin + if PI^.View<>nil then + begin + PI^.View^.SetData(Bytes(Rec)[I]); + Inc(I, PI^.View^.DataSize); + end; + PI:=PI^.Next; + end; + PT:=PT^.Next; + end; +end; + + +function TTab.DataSize: sw_word; +var + I: Sw_Word; + PT : PTabDef; + PI : PTabItem; +begin + I := 0; + PT:=TabDefs; + while (PT<>nil) do + begin + PI:=PT^.Items; + while (PI<>nil) do + begin + if PI^.View<>nil then + begin + Inc(I, PI^.View^.DataSize); + end; + PI:=PI^.Next; + end; + PT:=PT^.Next; + end; + DataSize:=i; +end; + + +procedure TTab.GetData(var Rec); +type + Bytes = array[0..65534] of Byte; +var + I: Sw_Word; + PT : PTabDef; + PI : PTabItem; +begin + I := 0; + PT:=TabDefs; + while (PT<>nil) do + begin + PI:=PT^.Items; + while (PI<>nil) do + begin + if PI^.View<>nil then + begin + PI^.View^.GetData(Bytes(Rec)[I]); + Inc(I, PI^.View^.DataSize); + end; + PI:=PI^.Next; + end; + PT:=PT^.Next; + end; +end; + + +procedure TTab.SetState(AState: Word; Enable: Boolean); +var + LastV : PView; +begin + inherited SetState(AState,Enable); + { Select first item } + if (AState and sfSelected)<>0 then + begin + LastV:=LastSelectable; + if LastV<>nil then + LastV^.Select; + end; +end; + +destructor TTab.Done; +var P,X: PTabDef; +procedure DeleteViews(P: PView); {$ifndef FPC}far;{$endif} +begin + if P<>nil then Delete(P); +end; +begin + ForEach(TCallbackProcParam(@DeleteViews)); + inherited Done; + P:=TabDefs; + while P<>nil do + begin + X:=P^.Next; + DisposeTabDef(P); + P:=X; + end; +end; + + +function NewTabItem(AView: PView; ANext: PTabItem): PTabItem; +var P: PTabItem; +begin + New(P); FillChar(P^,SizeOf(P^),0); + P^.Next:=ANext; P^.View:=AView; + NewTabItem:=P; +end; + +procedure DisposeTabItem(P: PTabItem); +begin + if P<>nil then + begin + if P^.View<>nil then Dispose(P^.View, Done); + Dispose(P); + end; +end; + +function NewTabDef(AName: Sw_String; ADefItem: PView; AItems: PTabItem; ANext: PTabDef): PTabDef; +var P: PTabDef; + x: byte; +begin + New(P); + P^.Next:=ANext; P^.Name:=Sw_NewStr(AName); P^.Items:=AItems; + x:=pos('~',AName); + if (x<>0) and (x<length(AName)) then P^.ShortCut:=Upcase(AName[x+1]) + else P^.ShortCut:=#0; + P^.DefItem:=ADefItem; + NewTabDef:=P; +end; + +procedure DisposeTabDef(P: PTabDef); +var PI,X: PTabItem; +begin +{$ifndef FV_UNICODE} + DisposeStr(P^.Name); +{$endif FV_UNICODE} + PI:=P^.Items; + while PI<>nil do + begin + X:=PI^.Next; + DisposeTabItem(PI); + PI:=X; + end; + Dispose(P); +end; + +procedure RegisterTab; +begin + RegisterType (RTab); +end; + + +begin + RegisterTab; +end. diff --git a/packages/fv/src/tabs.pas b/packages/fv/src/tabs.pas index 7471a9af8f..821299a544 100644 --- a/packages/fv/src/tabs.pas +++ b/packages/fv/src/tabs.pas @@ -1,790 +1 @@ -{ - - Tabbed group for TV/FV dialogs - - Copyright 2000-4 by Free Pascal core team - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This library 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 - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, - MA 02110-1301, USA. - - ****************************************************************************} -unit tabs; - -{$I platform.inc} (* Multi-platform support defines *) -{$CODEPAGE cp437} - -interface - -uses - objects, - drivers, - views, - fvconsts; - - -type - PTabItem = ^TTabItem; - TTabItem = record - Next : PTabItem; - View : PView; - Dis : boolean; - end; - - PTabDef = ^TTabDef; - TTabDef = record - Next : PTabDef; - Name : PString; - Items : PTabItem; - DefItem : PView; - ShortCut : char; - end; - - PTab = ^TTab; - TTab = object(TGroup) - TabDefs : PTabDef; - ActiveDef : integer; - DefCount : word; - constructor Init(var Bounds: TRect; ATabDef: PTabDef); - constructor Load (var S: TStream); - function AtTab(Index: integer): PTabDef; virtual; - procedure SelectTab(Index: integer); virtual; - procedure Store (var S: TStream); - function TabCount: integer; - function Valid(Command: Word): Boolean; virtual; - procedure ChangeBounds(var Bounds: TRect); virtual; - procedure HandleEvent(var Event: TEvent); virtual; - function GetPalette: PPalette; virtual; - procedure Draw; virtual; - function DataSize: sw_word;virtual; - procedure SetData(var Rec);virtual; - procedure GetData(var Rec);virtual; - procedure SetState(AState: Word; Enable: Boolean); virtual; - destructor Done; virtual; - private - InDraw: boolean; - function FirstSelectable: PView; - function LastSelectable: PView; - end; - -function NewTabItem(AView: PView; ANext: PTabItem): PTabItem; -procedure DisposeTabItem(P: PTabItem); -function NewTabDef(AName: string; ADefItem: PView; AItems: PTabItem; ANext: PTabDef): PTabDef; -procedure DisposeTabDef(P: PTabDef); - -procedure RegisterTab; - -const - RTab: TStreamRec = ( - ObjType: idTab; -{$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs (TypeOf (TTab)^); -{$ELSE BP_VMTLink} { Alt style VMT link } - VmtLink: TypeOf (TTab); -{$ENDIF BP_VMTLink} - Load: @TTab.Load; - Store: @TTab.Store - ); - - -implementation - -uses - FvCommon, - dialogs; - -constructor TTab.Init(var Bounds: TRect; ATabDef: PTabDef); -begin - inherited Init(Bounds); - Options:=Options or ofSelectable or ofFirstClick or ofPreProcess or ofPostProcess; - GrowMode:=gfGrowHiX+gfGrowHiY+gfGrowRel; - TabDefs:=ATabDef; - ActiveDef:=-1; - SelectTab(0); - ReDraw; -end; - -constructor TTab.Load (var S: TStream); - - function DoLoadTabItems (var XDefItem: PView; ActItem: longint): PTabItem; - var - Count: longint; - Cur, First: PTabItem; - Last: ^PTabItem; - begin - Cur := nil; { Preset nil } - Last := @First; { Start on first item } - S.Read (Count, SizeOf(Count)); { Read item count } - while (Count > 0) do - begin - New (Cur); { New status item } - Last^ := Cur; { First chain part } - if (Cur <> nil) then { Check pointer valid } - begin - Last := @Cur^.Next; { Chain complete } - S.Read (Cur^.Dis, SizeOf (Cur^.Dis)); - Cur^.View := PView (S.Get); - if ActItem = 0 then - XDefItem := Cur^.View; { Find default view } - end; - Dec (Count); { One item loaded } - Dec (ActItem); - end; - Last^ := nil; { Now chain end } - DoLoadTabItems := First; { Return the list } - end; - - function DoLoadTabDefs: PTabDef; - var - Count: longint; - Cur, First: PTabDef; - Last: ^PTabDef; - ActItem: longint; - begin - Last := @First; { Start on first } - Count := DefCount; - while (Count > 0) do - begin - New (Cur); { New status def } - Last^ := Cur; { First part of chain } - if (Cur <> nil) then { Check pointer valid } - begin - Last := @Cur^.Next; { Chain complete } - Cur^.Name := S.ReadStr; { Read name } - S.Read (Cur^.ShortCut, SizeOf (Cur^.ShortCut)); - S.Read (ActItem, SizeOf (ActItem)); - Cur^.Items := DoLoadTabItems (Cur^.DefItem, ActItem); { Set pointer } - end; - Dec (Count); { One item loaded } - end; - Last^ := nil; { Now chain ends } - DoLoadTabDefs := First; { Return item list } - end; - -begin - inherited Load (S); - S.Read (DefCount, SizeOf (DefCount)); - S.Read (ActiveDef, SizeOf (ActiveDef)); - TabDefs := DoLoadTabDefs; -end; - -procedure TTab.Store (var S: TStream); - - procedure DoStoreTabItems (Cur: PTabItem; XDefItem: PView); - var - Count: longint; - T: PTabItem; - ActItem: longint; - begin - Count := 0; { Clear count } - T := Cur; { Start on current } - while (T <> nil) do - begin - if T^.View = XDefItem then { Current = active? } - ActItem := Count; { => set order } - Inc (Count); { Count items } - T := T^.Next; { Next item } - end; - S.Write (ActItem, SizeOf (ActItem)); - S.Write (Count, SizeOf (Count)); { Write item count } - while (Cur <> nil) do - begin - S.Write (Cur^.Dis, SizeOf (Cur^.Dis)); - S.Put (Cur^.View); - end; - end; - - procedure DoStoreTabDefs (Cur: PTabDef); - begin - while (Cur <> nil) do - begin - with Cur^ do - begin - S.WriteStr (Cur^.Name); { Write name } - S.Write (Cur^.ShortCut, SizeOf (Cur^.ShortCut)); - DoStoreTabItems (Items, DefItem); { Store the items } - end; - Cur := Cur^.Next; { Next status item } - end; - end; - -begin - inherited Store (S); - S.Write (DefCount, SizeOf (DefCount)); - S.Write (ActiveDef, SizeOf (ActiveDef)); - DoStoreTabDefs (TabDefs); -end; - -function TTab.TabCount: integer; -var i: integer; - P: PTabDef; -begin - I:=0; P:=TabDefs; - while (P<>nil) do - begin - Inc(I); - P:=P^.Next; - end; - TabCount:=I; -end; - - -function TTab.AtTab(Index: integer): PTabDef; -var i: integer; - P: PTabDef; -begin - i:=0; P:=TabDefs; - while (I<Index) do - begin - if P=nil then RunError($AA); - P:=P^.Next; - Inc(i); - end; - AtTab:=P; -end; - -procedure TTab.SelectTab(Index: integer); -var P: PTabItem; - V: PView; -begin - if ActiveDef<>Index then - begin - if Owner<>nil then Owner^.Lock; - Lock; - { --- Update --- } - if TabDefs<>nil then - begin - DefCount:=1; - while AtTab(DefCount-1)^.Next<>nil do Inc(DefCount); - end - else DefCount:=0; - if ActiveDef<>-1 then - begin - P:=AtTab(ActiveDef)^.Items; - while P<>nil do - begin - if P^.View<>nil then Delete(P^.View); - P:=P^.Next; - end; - end; - ActiveDef:=Index; - P:=AtTab(ActiveDef)^.Items; - while P<>nil do - begin - if P^.View<>nil then Insert(P^.View); - P:=P^.Next; - end; - V:=AtTab(ActiveDef)^.DefItem; - if V<>nil then V^.Select; - ReDraw; - { --- Update --- } - UnLock; - if Owner<>nil then Owner^.UnLock; - DrawView; - end; -end; - -procedure TTab.ChangeBounds(var Bounds: TRect); -var D: TPoint; -procedure DoCalcChange(P: PView); {$ifndef FPC}far;{$endif} -var - R: TRect; -begin - if P^.Owner=nil then Exit; { it think this is a bug in TV } - P^.CalcBounds(R, D); - P^.ChangeBounds(R); -end; -var - P: PTabItem; - I: integer; -begin - D.X := Bounds.B.X - Bounds.A.X - Size.X; - D.Y := Bounds.B.Y - Bounds.A.Y - Size.Y; - inherited ChangeBounds(Bounds); - for I:=0 to TabCount-1 do - if I<>ActiveDef then - begin - P:=AtTab(I)^.Items; - while P<>nil do - begin - if P^.View<>nil then DoCalcChange(P^.View); - P:=P^.Next; - end; - end; -end; - - -function TTab.FirstSelectable: PView; -var - FV : PView; -begin - FV := First; - while (FV<>nil) and ((FV^.Options and ofSelectable)=0) and (FV<>Last) do - FV:=FV^.Next; - if FV<>nil then - if (FV^.Options and ofSelectable)=0 then FV:=nil; - FirstSelectable:=FV; -end; - - -function TTab.LastSelectable: PView; -var - LV : PView; -begin - LV := Last; - while (LV<>nil) and ((LV^.Options and ofSelectable)=0) and (LV<>First) do - LV:=LV^.Prev; - if LV<>nil then - if (LV^.Options and ofSelectable)=0 then LV:=nil; - LastSelectable:=LV; -end; - -procedure TTab.HandleEvent(var Event: TEvent); -var Index : integer; - I : integer; - X : integer; - Len : byte; - P : TPoint; - V : PView; - CallOrig: boolean; - LastV : PView; - FirstV: PView; -begin - if (Event.What and evMouseDown)<>0 then - begin - MakeLocal(Event.Where,P); - if P.Y<3 then - begin - Index:=-1; X:=1; - for i:=0 to DefCount-1 do - begin - Len:=CStrLen(AtTab(i)^.Name^); - if (P.X>=X) and (P.X<=X+Len+1) then Index:=i; - X:=X+Len+3; - end; - if Index<>-1 then - SelectTab(Index); - end; - end; - if Event.What=evKeyDown then - begin - Index:=-1; - case Event.KeyCode of - kbTab,kbShiftTab : - if GetState(sfSelected) then - begin - if Current<>nil then - begin - LastV:=LastSelectable; FirstV:=FirstSelectable; - if ((Current=LastV) or (Current=PLabel(LastV)^.Link)) and (Event.KeyCode=kbShiftTab) then - begin - if Owner<>nil then Owner^.SelectNext(true); - end else - if ((Current=FirstV) or (Current=PLabel(FirstV)^.Link)) and (Event.KeyCode=kbTab) then - begin - Lock; - if Owner<>nil then Owner^.SelectNext(false); - UnLock; - end else - SelectNext(Event.KeyCode=kbShiftTab); - ClearEvent(Event); - end; - end; - kbCtrlPgUp: - begin - if ActiveDef > 0 then - Index := Pred (ActiveDef) - else - Index := Pred (DefCount); - ClearEvent(Event); - end; - kbCtrlPgDn: - begin - if ActiveDef < Pred (DefCount) then - Index := Succ (ActiveDef) - else - Index := 0; - ClearEvent(Event); - end; - else - for I:=0 to DefCount-1 do - begin - if (AtTab(I)^.ShortCut <> #0) and - (Upcase(GetAltChar(Event.KeyCode))=AtTab(I)^.ShortCut) - then begin - Index:=I; - ClearEvent(Event); - Break; - end; - end; - end; - if Index<>-1 then - begin - Select; - SelectTab(Index); - V:=AtTab(ActiveDef)^.DefItem; - if V<>nil then V^.Focus; - end; - end; - CallOrig:=true; - if Event.What=evKeyDown then - begin - if ((Owner<>nil) and (Owner^.Phase=phPostProcess) - and (GetAltChar(Event.KeyCode)<>#0)) or GetState(sfFocused) - then - else CallOrig:=false; - end; - if CallOrig then inherited HandleEvent(Event); -end; - -function TTab.GetPalette: PPalette; -begin - GetPalette:=nil; -end; - -{$define AVOIDTHREELINES} - -procedure TTab.Draw; -const -{$ifdef AVOIDTHREELINES} - UDL='¿'; - LUR='Ä'; - URD='Ú'; -{$else not AVOIDTHREELINES} - UDL='´'; - LUR='Á'; - URD='Ã'; -{$endif not AVOIDTHREELINES} - - -var B : TDrawBuffer; - i : integer; - C1,C2,C3,C : word; - HeaderLen : integer; - X,X2 : integer; - Name : PString; - ActiveKPos : integer; - ActiveVPos : integer; - FC : char; -procedure SWriteBuf(X,Y,W,H: integer; var Buf); -var i: integer; -begin - if Y+H>Size.Y then H:=Size.Y-Y; - if X+W>Size.X then W:=Size.X-X; - if Buffer=nil then WriteBuf(X,Y,W,H,Buf) - else for i:=1 to H do - Move(Buf,Buffer^[X+(Y+i-1)*Size.X],W*2); -end; -procedure ClearBuf; -begin - MoveChar(B,' ',C1,Size.X); -end; -begin - if InDraw then Exit; - InDraw:=true; - { - Start of TGroup.Draw - } -{ if Buffer = nil then - begin - GetBuffer; - end; } - { - Start of TGroup.Draw - } - - C1:=GetColor(1); - C2:=(GetColor(7) and $f0 or $08)+GetColor(9)*256; - C3:=GetColor(8)+GetColor({9}8)*256; - - { Calculate the size of the headers } - HeaderLen:=0; - for i:=0 to DefCount-1 do - HeaderLen:=HeaderLen+CStrLen(AtTab(i)^.Name^)+3; - Dec(HeaderLen); - if HeaderLen>Size.X-2 then HeaderLen:=Size.X-2; - - { --- 1. sor --- } - ClearBuf; - MoveChar(B[0],'³',C1,1); - MoveChar(B[HeaderLen+1],'³',C1,1); - X:=1; - for i:=0 to DefCount-1 do - begin - Name:=AtTab(i)^.Name; X2:=CStrLen(Name^); - if i=ActiveDef - then begin - ActiveKPos:=X-1; - ActiveVPos:=X+X2+2; - if GetState(sfFocused) then C:=C3 else C:=C2; - end - else C:=C2; - MoveCStr(B[X],' '+Name^+' ',C); - X:=X+X2+3; - MoveChar(B[X-1],'³',C1,1); - end; - SWriteBuf(0,1,Size.X,1,B); - - { --- 0. sor --- } - ClearBuf; MoveChar(B[0],'Ú',C1,1); - X:=1; - for i:=0 to DefCount-1 do - begin -{$ifdef AVOIDTHREELINES} - if I<ActiveDef then - FC:='Ú' - else - FC:='¿'; -{$else not AVOIDTHREELINES} - FC:='Â'; -{$endif not AVOIDTHREELINES} - X2:=CStrLen(AtTab(i)^.Name^)+2; - MoveChar(B[X+X2],FC,C1,1); - if i=DefCount-1 then X2:=X2+1; - if X2>0 then - MoveChar(B[X],'Ä',C1,X2); - X:=X+X2+1; - end; - MoveChar(B[HeaderLen+1],'¿',C1,1); - MoveChar(B[ActiveKPos],'Ú',C1,1); - MoveChar(B[ActiveVPos],'¿',C1,1); - SWriteBuf(0,0,Size.X,1,B); - - { --- 2. sor --- } - MoveChar(B[1],'Ä',C1,Max(HeaderLen,0)); - MoveChar(B[HeaderLen+2],'Ä',C1,Max(Size.X-HeaderLen-3,0)); - MoveChar(B[HeaderLen+1],LUR,C1,1); - MoveChar(B[ActiveKPos],'Ù',C1,1); - if ActiveDef=0 then - MoveChar(B[0],'³',C1,1) - else - MoveChar(B[0],URD,C1,1); - MoveChar(B[ActiveKPos+1],' ',C1,Max(ActiveVPos-ActiveKPos-1,0)); - MoveChar(B[ActiveVPos],'À',C1,1); - if HeaderLen+1<Size.X-1 then - MoveChar(B[Size.X-1],'¿',C1,1) - else if (ActiveDef=DefCount-1) then - MoveChar(B[Size.X-1],'³',C1,1) - else - MoveChar(B[Size.X-1],UDL,C1,1); - SWriteBuf(0,2,Size.X,1,B); - - { --- marad‚k sor --- } - ClearBuf; MoveChar(B[0],'³',C1,1); - MoveChar(B[Size.X-1],'³',C1,1); - {SWriteBuf(0,3,Size.X,Size.Y-4,B);} - for i:=3 to Size.Y-1 do - SWriteBuf(0,i,Size.X,1,B); - - { --- Size.X . sor --- } - MoveChar(B[0],'À',C1,1); - MoveChar(B[1],'Ä',C1,Max(Size.X-2,0)); - MoveChar(B[Size.X-1],'Ù',C1,1); - SWriteBuf(0,Size.Y-1,Size.X,1,B); - - { - End of TGroup.Draw - } - if Buffer <> nil then - begin - Lock; - Redraw; - UnLock; - end; - if Buffer <> nil then - WriteBuf(0, 0, Size.X, Size.Y, Buffer^) - else - Redraw; - { - End of TGroup.Draw - } - InDraw:=false; -end; - -function TTab.Valid(Command: Word): Boolean; -var PT : PTabDef; - PI : PTabItem; - OK : boolean; -begin - OK:=true; - PT:=TabDefs; - while (PT<>nil) and (OK=true) do - begin - PI:=PT^.Items; - while (PI<>nil) and (OK=true) do - begin - if PI^.View<>nil then OK:=OK and PI^.View^.Valid(Command); - PI:=PI^.Next; - end; - PT:=PT^.Next; - end; - Valid:=OK; -end; - - -procedure TTab.SetData(var Rec); -type - Bytes = array[0..65534] of Byte; -var - I: Sw_Word; - PT : PTabDef; - PI : PTabItem; -begin - I := 0; - PT:=TabDefs; - while (PT<>nil) do - begin - PI:=PT^.Items; - while (PI<>nil) do - begin - if PI^.View<>nil then - begin - PI^.View^.SetData(Bytes(Rec)[I]); - Inc(I, PI^.View^.DataSize); - end; - PI:=PI^.Next; - end; - PT:=PT^.Next; - end; -end; - - -function TTab.DataSize: sw_word; -var - I: Sw_Word; - PT : PTabDef; - PI : PTabItem; -begin - I := 0; - PT:=TabDefs; - while (PT<>nil) do - begin - PI:=PT^.Items; - while (PI<>nil) do - begin - if PI^.View<>nil then - begin - Inc(I, PI^.View^.DataSize); - end; - PI:=PI^.Next; - end; - PT:=PT^.Next; - end; - DataSize:=i; -end; - - -procedure TTab.GetData(var Rec); -type - Bytes = array[0..65534] of Byte; -var - I: Sw_Word; - PT : PTabDef; - PI : PTabItem; -begin - I := 0; - PT:=TabDefs; - while (PT<>nil) do - begin - PI:=PT^.Items; - while (PI<>nil) do - begin - if PI^.View<>nil then - begin - PI^.View^.GetData(Bytes(Rec)[I]); - Inc(I, PI^.View^.DataSize); - end; - PI:=PI^.Next; - end; - PT:=PT^.Next; - end; -end; - - -procedure TTab.SetState(AState: Word; Enable: Boolean); -var - LastV : PView; -begin - inherited SetState(AState,Enable); - { Select first item } - if (AState and sfSelected)<>0 then - begin - LastV:=LastSelectable; - if LastV<>nil then - LastV^.Select; - end; -end; - -destructor TTab.Done; -var P,X: PTabDef; -procedure DeleteViews(P: PView); {$ifndef FPC}far;{$endif} -begin - if P<>nil then Delete(P); -end; -begin - ForEach(TCallbackProcParam(@DeleteViews)); - inherited Done; - P:=TabDefs; - while P<>nil do - begin - X:=P^.Next; - DisposeTabDef(P); - P:=X; - end; -end; - - -function NewTabItem(AView: PView; ANext: PTabItem): PTabItem; -var P: PTabItem; -begin - New(P); FillChar(P^,SizeOf(P^),0); - P^.Next:=ANext; P^.View:=AView; - NewTabItem:=P; -end; - -procedure DisposeTabItem(P: PTabItem); -begin - if P<>nil then - begin - if P^.View<>nil then Dispose(P^.View, Done); - Dispose(P); - end; -end; - -function NewTabDef(AName: string; ADefItem: PView; AItems: PTabItem; ANext: PTabDef): PTabDef; -var P: PTabDef; - x: byte; -begin - New(P); - P^.Next:=ANext; P^.Name:=NewStr(AName); P^.Items:=AItems; - x:=pos('~',AName); - if (x<>0) and (x<length(AName)) then P^.ShortCut:=Upcase(AName[x+1]) - else P^.ShortCut:=#0; - P^.DefItem:=ADefItem; - NewTabDef:=P; -end; - -procedure DisposeTabDef(P: PTabDef); -var PI,X: PTabItem; -begin - DisposeStr(P^.Name); - PI:=P^.Items; - while PI<>nil do - begin - X:=PI^.Next; - DisposeTabItem(PI); - PI:=X; - end; - Dispose(P); -end; - -procedure RegisterTab; -begin - RegisterType (RTab); -end; - - -begin - RegisterTab; -end. +{$I tabs.inc} diff --git a/packages/fv/src/timeddlg.inc b/packages/fv/src/timeddlg.inc new file mode 100644 index 0000000000..cb5db96c85 --- /dev/null +++ b/packages/fv/src/timeddlg.inc @@ -0,0 +1,267 @@ +{ + + Timed dialogs for Free Vision + + Copyright (c) 2004 by Free Pascal core team + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, + MA 02110-1301, USA. + + ****************************************************************************} +{$ifdef FV_UNICODE} +UNIT utimeddlg; +{$else FV_UNICODE} +UNIT timeddlg; +{$endif FV_UNICODE} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Near calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES objects, + fvconsts, +{$ifdef FV_UNICODE} + ufvcommon, udialogs, udrivers, uviews; { Standard GFV unit } +{$else FV_UNICODE} + fvcommon, dialogs, drivers, views; { Standard GFV unit } +{$endif FV_UNICODE} + +type + TTimedDialog = object (TDialog) + Secs: longint; + constructor Init (var Bounds: TRect; ATitle: TTitleStr; ASecs: word); + constructor Load (var S: TStream); + procedure GetEvent (var Event: TEvent); virtual; + procedure Store (var S: TStream); virtual; + private + Secs0: longint; + Secs2: longint; + DayWrap: boolean; + end; + PTimedDialog = ^TTimedDialog; + +(* Must be always included in TTimeDialog! *) + TTimedDialogText = object (TStaticText) + constructor Init (var Bounds: TRect); + procedure GetText (var S: Sw_String); virtual; + end; + PTimedDialogText = ^TTimedDialogText; + +const + RTimedDialog: TStreamRec = ( + ObjType: idTimedDialog; +{$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs (TypeOf (TTimedDialog)^); +{$ELSE} { Alt style VMT link } + VmtLink: TypeOf (TTimedDialog); +{$ENDIF BP_VMTLink} + Load: @TTimedDialog.Load; + Store: @TTimedDialog.Store + ); + + RTimedDialogText: TStreamRec = ( + ObjType: idTimedDialogText; +{$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs (TypeOf (TTimedDialogText)^); +{$ELSE} { Alt style VMT link } + VmtLink: TypeOf (TTimedDialogText); +{$ENDIF BP_VMTLink} + Load: @TTimedDialogText.Load; + Store: @TTimedDialogText.Store + ); + +procedure RegisterTimedDialog; + +FUNCTION TimedMessageBox (Const Msg: Sw_String; Params: Pointer; + AOptions: Word; ASecs: Word): Word; + +{-TimedMessageBoxRect------------------------------------------------ +TimedMessageBoxRect allows the specification of a TRect for the message box +to occupy. +---------------------------------------------------------------------} +FUNCTION TimedMessageBoxRect (Var R: TRect; Const Msg: Sw_String; Params: Pointer; + AOptions: Word; ASecs: Word): Word; + + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +USES + dos, +{$ifdef FV_UNICODE} + uapp, {resource,} umsgbox; { Standard GFV units } +{$else FV_UNICODE} + app, {resource,} msgbox; { Standard GFV units } +{$endif FV_UNICODE} + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +constructor TTimedDialogText.Init (var Bounds: TRect); +begin + inherited Init (Bounds, ''); +end; + + +procedure TTimedDialogText.GetText (var S: Sw_String); +begin + if Owner <> nil +(* and (TypeOf (Owner^) = TypeOf (TTimedDialog)) *) + then + begin + Str (PTimedDialog (Owner)^.Secs, S); + S := #3 + S; + end + else + S := ''; +end; + + + +constructor TTimedDialog.Init (var Bounds: TRect; ATitle: TTitleStr; + ASecs: word); +var + H, M, S, S100: word; +begin + inherited Init (Bounds, ATitle); + GetTime (H, M, S, S100); + Secs0 := H * 3600 + M * 60 + S; + Secs2 := Secs0 + ASecs; + Secs := ASecs; + DayWrap := Secs2 > 24 * 3600; +end; + + +procedure TTimedDialog.GetEvent (var Event: TEvent); +var + H, M, S, S100: word; + Secs1: longint; +begin + inherited GetEvent (Event); + GetTime (H, M, S, S100); + Secs1 := H * 3600 + M * 60 + S; + if DayWrap then Inc (Secs1, 24 * 3600); + if Secs2 - Secs1 <> Secs then + begin + Secs := Secs2 - Secs1; + if Secs < 0 then + Secs := 0; +(* If remaining seconds are displayed in one of included views, update them. *) + Redraw; + end; + with Event do + if (Secs = 0) and (What = evNothing) then + begin + What := evCommand; + Command := cmCancel; + end; +end; + + +constructor TTimedDialog.Load (var S: TStream); +begin + inherited Load (S); + S.Read (Secs, SizeOf (Secs)); + S.Read (Secs0, SizeOf (Secs0)); + S.Read (Secs2, SizeOf (Secs2)); + S.Read (DayWrap, SizeOf (DayWrap)); +end; + + +procedure TTimedDialog.Store (var S: TStream); +begin + inherited Store (S); + S.Write (Secs, SizeOf (Secs)); + S.Write (Secs0, SizeOf (Secs0)); + S.Write (Secs2, SizeOf (Secs2)); + S.Write (DayWrap, SizeOf (DayWrap)); +end; + + + +function TimedMessageBox (const Msg: Sw_String; Params: pointer; + AOptions: word; ASecs: word): word; +var + R: TRect; +begin + R.Assign(0, 0, 40, 10); { Assign area } + if (AOptions AND mfInsertInApp = 0) then { Non app insert } + R.Move((Desktop^.Size.X - R.B.X) div 2, + (Desktop^.Size.Y - R.B.Y) div 2) { Calculate position } + else + R.Move((Application^.Size.X - R.B.X) div 2, + (Application^.Size.Y - R.B.Y) div 2); { Calculate position } + TimedMessageBox := TimedMessageBoxRect (R, Msg, Params, + AOptions, ASecs); { Create message box } +end; + + +function TimedMessageBoxRect (var R: TRect; const Msg: Sw_String; Params: pointer; + AOptions: word; ASecs: word): word; +var + Dlg: PTimedDialog; + TimedText: PTimedDialogText; +begin + Dlg := New (PTimedDialog, Init (R, MsgBoxTitles [AOptions + and $3], ASecs)); { Create dialog } + with Dlg^ do + begin + R.Assign (3, Size.Y - 5, Size.X - 2, Size.Y - 4); + New (TimedText, Init (R)); + Insert (TimedText); + R.Assign (3, 2, Size.X - 2, Size.Y - 5); { Assign area for text } + end; + TimedMessageBoxRect := MessageBoxRectDlg (Dlg, R, Msg, Params, AOptions); + Dispose (Dlg, Done); { Dispose of dialog } +end; + + + +procedure RegisterTimedDialog; +begin + RegisterType (RTimedDialog); + RegisterType (RTimedDialogText); +end; + + +begin + RegisterTimedDialog; +end. diff --git a/packages/fv/src/timeddlg.pas b/packages/fv/src/timeddlg.pas index baf8d53da5..74ce02cc1c 100644 --- a/packages/fv/src/timeddlg.pas +++ b/packages/fv/src/timeddlg.pas @@ -1,253 +1 @@ -{ - - Timed dialogs for Free Vision - - Copyright (c) 2004 by Free Pascal core team - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This library 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 - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, - MA 02110-1301, USA. - - ****************************************************************************} -UNIT timeddlg; - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - INTERFACE -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{====Include file to sort compiler platform out =====================} -{$I platform.inc} -{====================================================================} - -{==== Compiler directives ===========================================} - -{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } - {$F-} { Near calls are okay } - {$A+} { Word Align Data } - {$B-} { Allow short circuit boolean evaluations } - {$O+} { This unit may be overlaid } - {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } - {$P-} { Normal string variables } - {$N-} { No 80x87 code generation } - {$E+} { Emulation is on } -{$ENDIF} - -{$X+} { Extended syntax is ok } -{$R-} { Disable range checking } -{$S-} { Disable Stack Checking } -{$I-} { Disable IO Checking } -{$Q-} { Disable Overflow Checking } -{$V-} { Turn off strict VAR strings } -{====================================================================} - -USES objects, dialogs, fvconsts, drivers, views; { Standard GFV unit } - -type - TTimedDialog = object (TDialog) - Secs: longint; - constructor Init (var Bounds: TRect; ATitle: TTitleStr; ASecs: word); - constructor Load (var S: TStream); - procedure GetEvent (var Event: TEvent); virtual; - procedure Store (var S: TStream); virtual; - private - Secs0: longint; - Secs2: longint; - DayWrap: boolean; - end; - PTimedDialog = ^TTimedDialog; - -(* Must be always included in TTimeDialog! *) - TTimedDialogText = object (TStaticText) - constructor Init (var Bounds: TRect); - procedure GetText (var S: string); virtual; - end; - PTimedDialogText = ^TTimedDialogText; - -const - RTimedDialog: TStreamRec = ( - ObjType: idTimedDialog; -{$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs (TypeOf (TTimedDialog)^); -{$ELSE} { Alt style VMT link } - VmtLink: TypeOf (TTimedDialog); -{$ENDIF BP_VMTLink} - Load: @TTimedDialog.Load; - Store: @TTimedDialog.Store - ); - - RTimedDialogText: TStreamRec = ( - ObjType: idTimedDialogText; -{$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs (TypeOf (TTimedDialogText)^); -{$ELSE} { Alt style VMT link } - VmtLink: TypeOf (TTimedDialogText); -{$ENDIF BP_VMTLink} - Load: @TTimedDialogText.Load; - Store: @TTimedDialogText.Store - ); - -procedure RegisterTimedDialog; - -FUNCTION TimedMessageBox (Const Msg: String; Params: Pointer; - AOptions: Word; ASecs: Word): Word; - -{-TimedMessageBoxRect------------------------------------------------ -TimedMessageBoxRect allows the specification of a TRect for the message box -to occupy. ----------------------------------------------------------------------} -FUNCTION TimedMessageBoxRect (Var R: TRect; Const Msg: String; Params: Pointer; - AOptions: Word; ASecs: Word): Word; - - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IMPLEMENTATION -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -USES - dos, - app, {resource,} msgbox; { Standard GFV units } - - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -constructor TTimedDialogText.Init (var Bounds: TRect); -begin - inherited Init (Bounds, ''); -end; - - -procedure TTimedDialogText.GetText (var S: string); -begin - if Owner <> nil -(* and (TypeOf (Owner^) = TypeOf (TTimedDialog)) *) - then - begin - Str (PTimedDialog (Owner)^.Secs, S); - S := #3 + S; - end - else - S := ''; -end; - - - -constructor TTimedDialog.Init (var Bounds: TRect; ATitle: TTitleStr; - ASecs: word); -var - H, M, S, S100: word; -begin - inherited Init (Bounds, ATitle); - GetTime (H, M, S, S100); - Secs0 := H * 3600 + M * 60 + S; - Secs2 := Secs0 + ASecs; - Secs := ASecs; - DayWrap := Secs2 > 24 * 3600; -end; - - -procedure TTimedDialog.GetEvent (var Event: TEvent); -var - H, M, S, S100: word; - Secs1: longint; -begin - inherited GetEvent (Event); - GetTime (H, M, S, S100); - Secs1 := H * 3600 + M * 60 + S; - if DayWrap then Inc (Secs1, 24 * 3600); - if Secs2 - Secs1 <> Secs then - begin - Secs := Secs2 - Secs1; - if Secs < 0 then - Secs := 0; -(* If remaining seconds are displayed in one of included views, update them. *) - Redraw; - end; - with Event do - if (Secs = 0) and (What = evNothing) then - begin - What := evCommand; - Command := cmCancel; - end; -end; - - -constructor TTimedDialog.Load (var S: TStream); -begin - inherited Load (S); - S.Read (Secs, SizeOf (Secs)); - S.Read (Secs0, SizeOf (Secs0)); - S.Read (Secs2, SizeOf (Secs2)); - S.Read (DayWrap, SizeOf (DayWrap)); -end; - - -procedure TTimedDialog.Store (var S: TStream); -begin - inherited Store (S); - S.Write (Secs, SizeOf (Secs)); - S.Write (Secs0, SizeOf (Secs0)); - S.Write (Secs2, SizeOf (Secs2)); - S.Write (DayWrap, SizeOf (DayWrap)); -end; - - - -function TimedMessageBox (const Msg: string; Params: pointer; - AOptions: word; ASecs: word): word; -var - R: TRect; -begin - R.Assign(0, 0, 40, 10); { Assign area } - if (AOptions AND mfInsertInApp = 0) then { Non app insert } - R.Move((Desktop^.Size.X - R.B.X) div 2, - (Desktop^.Size.Y - R.B.Y) div 2) { Calculate position } - else - R.Move((Application^.Size.X - R.B.X) div 2, - (Application^.Size.Y - R.B.Y) div 2); { Calculate position } - TimedMessageBox := TimedMessageBoxRect (R, Msg, Params, - AOptions, ASecs); { Create message box } -end; - - -function TimedMessageBoxRect (var R: TRect; const Msg: string; Params: pointer; - AOptions: word; ASecs: word): word; -var - Dlg: PTimedDialog; - TimedText: PTimedDialogText; -begin - Dlg := New (PTimedDialog, Init (R, MsgBoxTitles [AOptions - and $3], ASecs)); { Create dialog } - with Dlg^ do - begin - R.Assign (3, Size.Y - 5, Size.X - 2, Size.Y - 4); - New (TimedText, Init (R)); - Insert (TimedText); - R.Assign (3, 2, Size.X - 2, Size.Y - 5); { Assign area for text } - end; - TimedMessageBoxRect := MessageBoxRectDlg (Dlg, R, Msg, Params, AOptions); - Dispose (Dlg, Done); { Dispose of dialog } -end; - - - -procedure RegisterTimedDialog; -begin - RegisterType (RTimedDialog); - RegisterType (RTimedDialogText); -end; - - -begin - RegisterTimedDialog; -end. +{$I timeddlg.inc} diff --git a/packages/fv/src/uapp.pas b/packages/fv/src/uapp.pas new file mode 100644 index 0000000000..1b0590d789 --- /dev/null +++ b/packages/fv/src/uapp.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I app.inc} diff --git a/packages/fv/src/udialogs.pas b/packages/fv/src/udialogs.pas new file mode 100644 index 0000000000..882d2261fe --- /dev/null +++ b/packages/fv/src/udialogs.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I dialogs.inc} diff --git a/packages/fv/src/udrivers.pas b/packages/fv/src/udrivers.pas new file mode 100644 index 0000000000..659356eda0 --- /dev/null +++ b/packages/fv/src/udrivers.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I drivers.inc} diff --git a/packages/fv/src/ufvcommon.pas b/packages/fv/src/ufvcommon.pas new file mode 100644 index 0000000000..f917ea4161 --- /dev/null +++ b/packages/fv/src/ufvcommon.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I fvcommon.inc} diff --git a/packages/fv/src/uhistlist.pas b/packages/fv/src/uhistlist.pas new file mode 100644 index 0000000000..0332cd419c --- /dev/null +++ b/packages/fv/src/uhistlist.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I histlist.inc} diff --git a/packages/fv/src/uinplong.pas b/packages/fv/src/uinplong.pas new file mode 100644 index 0000000000..afec038922 --- /dev/null +++ b/packages/fv/src/uinplong.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I inplong.inc} diff --git a/packages/fv/src/umenus.pas b/packages/fv/src/umenus.pas new file mode 100644 index 0000000000..b6b0b73412 --- /dev/null +++ b/packages/fv/src/umenus.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I menus.inc} diff --git a/packages/fv/src/umsgbox.pas b/packages/fv/src/umsgbox.pas new file mode 100644 index 0000000000..e8d39b738c --- /dev/null +++ b/packages/fv/src/umsgbox.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I msgbox.inc} diff --git a/packages/fv/src/uoutline.pas b/packages/fv/src/uoutline.pas new file mode 100644 index 0000000000..3477bd6df3 --- /dev/null +++ b/packages/fv/src/uoutline.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I outline.inc} diff --git a/packages/fv/src/utabs.pas b/packages/fv/src/utabs.pas new file mode 100644 index 0000000000..c0419787e7 --- /dev/null +++ b/packages/fv/src/utabs.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I tabs.inc} diff --git a/packages/fv/src/utimeddlg.pas b/packages/fv/src/utimeddlg.pas new file mode 100644 index 0000000000..76fe19b5e6 --- /dev/null +++ b/packages/fv/src/utimeddlg.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I timeddlg.inc} diff --git a/packages/fv/src/uvalidate.pas b/packages/fv/src/uvalidate.pas new file mode 100644 index 0000000000..0f7e8f45b1 --- /dev/null +++ b/packages/fv/src/uvalidate.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I validate.inc} diff --git a/packages/fv/src/uviews.pas b/packages/fv/src/uviews.pas new file mode 100644 index 0000000000..69f57178d1 --- /dev/null +++ b/packages/fv/src/uviews.pas @@ -0,0 +1,2 @@ +{$DEFINE FV_UNICODE} +{$I views.inc} diff --git a/packages/fv/src/validate.inc b/packages/fv/src/validate.inc new file mode 100644 index 0000000000..f93a91630a --- /dev/null +++ b/packages/fv/src/validate.inc @@ -0,0 +1,1072 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of VALIDATE.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@ibm.net } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Fix } +{ ------- --------- --------------------------------- } +{ 1.00 12 Jun 96 Initial DOS/DPMI code released. } +{ 1.10 29 Aug 97 Platform.inc sort added. } +{ 1.20 13 Oct 97 Delphi3 32 bit code added. } +{ 1.30 11 May 98 Virtual pascal 2.0 code added. } +{ 1.40 10 Jul 99 Sybil 2.0 code added } +{ 1.41 03 Nov 99 FPC windows code added } +{**********************************************************} + +{$ifdef FV_UNICODE} +UNIT UValidate; +{$else FV_UNICODE} +UNIT Validate; +{$endif FV_UNICODE} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Short calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES +{$ifdef FV_UNICODE} + UFVCommon, +{$else FV_UNICODE} + FVCommon, +{$endif FV_UNICODE} + Objects, fvconsts; { GFV standard units } + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ VALIDATOR STATUS CONSTANTS } +{---------------------------------------------------------------------------} +CONST + vsOk = 0; { Validator ok } + vsSyntax = 1; { Validator sytax err } + +{---------------------------------------------------------------------------} +{ VALIDATOR OPTION MASKS } +{---------------------------------------------------------------------------} +CONST + voFill = $0001; { Validator fill } + voTransfer = $0002; { Validator transfer } + voOnAppend = $0004; { Validator append } + voReserved = $00F8; { Clear above flags } + +{***************************************************************************} +{ RECORD DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ VALIDATOR TRANSFER CONSTANTS } +{---------------------------------------------------------------------------} +TYPE + TVTransfer = (vtDataSize, vtSetData, vtGetData); { Transfer states } + +{---------------------------------------------------------------------------} +{ PICTURE VALIDATOR RESULT CONSTANTS } +{---------------------------------------------------------------------------} +TYPE + TPicResult = (prComplete, prIncomplete, prEmpty, prError, prSyntax, + prAmbiguous, prIncompNoFill); + +{***************************************************************************} +{ OBJECT DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TValidator OBJECT - VALIDATOR ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TValidator = OBJECT (TObject) + Status : Word; { Validator status } + Options: Word; { Validator options } + CONSTRUCTOR Load (Var S: TStream); + FUNCTION Valid(CONST S: Sw_String): Boolean; + FUNCTION IsValid (CONST S: Sw_String): Boolean; Virtual; + FUNCTION IsValidInput (Var S: Sw_String; + SuppressFill: Boolean): Boolean; Virtual; + FUNCTION Transfer (Var S: Sw_String; Buffer: Pointer; + Flag: TVTransfer): Word; Virtual; + PROCEDURE Error; Virtual; + PROCEDURE Store (Var S: TStream); + END; + PValidator = ^TValidator; + +{---------------------------------------------------------------------------} +{ TPictureValidator OBJECT - PICTURE VALIDATOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TPXPictureValidator = OBJECT (TValidator) + Pic: Sw_PString; { Picture filename } + CONSTRUCTOR Init (Const APic: Sw_String; AutoFill: Boolean); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION IsValid (Const S: Sw_String): Boolean; Virtual; + FUNCTION IsValidInput (Var S: Sw_String; + SuppressFill: Boolean): Boolean; Virtual; + FUNCTION Picture (Var Input: Sw_String; + AutoFill: Boolean): TPicResult; Virtual; + PROCEDURE Error; Virtual; + PROCEDURE Store (Var S: TStream); + END; + PPXPictureValidator = ^TPXPictureValidator; + +TYPE CharSet = TCharSet; + +{---------------------------------------------------------------------------} +{ TFilterValidator OBJECT - FILTER VALIDATOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TFilterValidator = OBJECT (TValidator) + ValidChars: CharSet; { Valid char set } + CONSTRUCTOR Init (AValidChars: CharSet); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION IsValid (CONST S: Sw_String): Boolean; Virtual; + FUNCTION IsValidInput (Var S: Sw_String; + SuppressFill: Boolean): Boolean; Virtual; + PROCEDURE Error; Virtual; + PROCEDURE Store (Var S: TStream); + END; + PFilterValidator = ^TFilterValidator; + +{---------------------------------------------------------------------------} +{ TRangeValidator OBJECT - RANGE VALIDATOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TRangeValidator = OBJECT (TFilterValidator) + Min: LongInt; { Min valid value } + Max: LongInt; { Max valid value } + CONSTRUCTOR Init(AMin, AMax: LongInt); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION IsValid (Const S: Sw_String): Boolean; Virtual; + FUNCTION Transfer (Var S: Sw_String; Buffer: Pointer; + Flag: TVTransfer): Word; Virtual; + PROCEDURE Error; Virtual; + PROCEDURE Store (Var S: TStream); + END; + PRangeValidator = ^TRangeValidator; + +{---------------------------------------------------------------------------} +{ TLookUpValidator OBJECT - LOOKUP VALIDATOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TLookupValidator = OBJECT (TValidator) + FUNCTION IsValid (Const S: Sw_String): Boolean; Virtual; + FUNCTION Lookup (Const S: Sw_String): Boolean; Virtual; + END; + PLookupValidator = ^TLookupValidator; + +{---------------------------------------------------------------------------} +{ TStringLookUpValidator OBJECT - STRING LOOKUP VALIDATOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TStringLookupValidator = OBJECT (TLookupValidator) + Strings: PStringCollection; + CONSTRUCTOR Init (AStrings: PStringCollection); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION Lookup (Const S: Sw_String): Boolean; Virtual; + PROCEDURE Error; Virtual; + PROCEDURE NewStringList (AStrings: PStringCollection); + PROCEDURE Store (Var S: TStream); + END; + PStringLookupValidator = ^TStringLookupValidator; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{-RegisterValidate--------------------------------------------------- +Calls RegisterType for each of the object types defined in this unit. +18May98 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterValidate; + +{***************************************************************************} +{ OBJECT REGISTRATION } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TPXPictureValidator STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RPXPictureValidator: TStreamRec = ( + ObjType: idPXPictureValidator; { Register id = 80 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TPXPictureValidator)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TPXPictureValidator); + {$ENDIF} + Load: @TPXPictureValidator.Load; { Object load method } + Store: @TPXPictureValidator.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TFilterValidator STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RFilterValidator: TStreamRec = ( + ObjType: idFilterValidator; { Register id = 81 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TFilterValidator)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TFilterValidator); + {$ENDIF} + Load: @TFilterValidator.Load; { Object load method } + Store: @TFilterValidator.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TRangeValidator STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RRangeValidator: TStreamRec = ( + ObjType: idRangeValidator; { Register id = 82 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TRangeValidator)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TRangeValidator); + {$ENDIF} + Load: @TRangeValidator.Load; { Object load method } + Store: @TRangeValidator.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TStringLookupValidator STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RStringLookupValidator: TStreamRec = ( + ObjType: idStringLookupValidator; { Register id = 83 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TStringLookupValidator)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TStringLookupValidator); + {$ENDIF} + Load: @TStringLookupValidator.Load; { Object load method } + Store: @TStringLookupValidator.Store { Object store method } + ); + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{$ifdef FV_UNICODE} +USES UMsgBox; { GFV standard unit } +{$else FV_UNICODE} +USES MsgBox; { GFV standard unit } +{$endif FV_UNICODE} + +{***************************************************************************} +{ PRIVATE ROUTINES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ IsLetter -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION IsLetter (Chr: Char): Boolean; +BEGIN + Chr := Char(Ord(Chr) AND $DF); { Lower to upper case } + If (Chr >= 'A') AND (Chr <='Z') Then { Check if A..Z } + IsLetter := True Else IsLetter := False; { Return result } +END; + +{---------------------------------------------------------------------------} +{ IsComplete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION IsComplete (Rslt: TPicResult): Boolean; +BEGIN + IsComplete := Rslt IN [prComplete, prAmbiguous]; { Return if complete } +END; + +{---------------------------------------------------------------------------} +{ IsInComplete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION IsIncomplete (Rslt: TPicResult): Boolean; +BEGIN + IsIncomplete := Rslt IN + [prIncomplete, prIncompNoFill]; { Return if incomplete } +END; + +{---------------------------------------------------------------------------} +{ NumChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NumChar (Chr: Char; Const S: String): Byte; +VAR I, Total: Byte; +BEGIN + Total := 0; { Zero total } + For I := 1 To Length(S) Do { For entire string } + If (S[I] = Chr) Then Inc(Total); { Count matches of Chr } + NumChar := Total; { Return char count } +END; + +{---------------------------------------------------------------------------} +{ IsSpecial -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION IsSpecial (Chr: Char; Const Special: String): Boolean; +VAR Rslt: Boolean; I: Byte; +BEGIN + Rslt := False; { Preset false result } + For I := 1 To Length(Special) Do + If (Special[I] = Chr) Then Rslt := True; { Character found } + IsSpecial := Rslt; { Return result } +END; + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TValidator---------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TValidator.Load (Var S:TStream); +BEGIN + Inherited Init; { Call ancestor } + S.Read(Options, SizeOf(Options)); { Read option masks } +END; + +{--TValidator---------------------------------------------------------------} +{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TValidator.Valid (Const S: Sw_String): Boolean; +BEGIN + Valid := False; { Preset false result } + If Not IsValid(S) Then Error { Check for error } + Else Valid := True; { Return valid result } +END; + +{--TValidator---------------------------------------------------------------} +{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TValidator.IsValid (Const S: Sw_String): Boolean; +BEGIN + IsValid := True; { Default return valid } +END; + +{--TValidator---------------------------------------------------------------} +{ IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TValidator.IsValidInput (Var S: Sw_String; SuppressFill: Boolean): Boolean; +BEGIN + IsValidInput := True; { Default return true } +END; + +{--TValidator---------------------------------------------------------------} +{ Transfer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TValidator.Transfer (Var S: Sw_String; Buffer: Pointer; + Flag: TVTransfer): Word; +BEGIN + Transfer := 0; { Default return zero } +END; + +{--TValidator---------------------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TValidator.Error; +BEGIN { Abstract method } +END; + +{--TValidator---------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TValidator.Store (Var S: TStream); +BEGIN + S.Write(Options, SizeOf(Options)); { Write options } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TPXPictureValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TPXPictureValidator------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TPXPictureValidator.Init (Const APic: Sw_String; AutoFill: Boolean); +VAR S: Sw_String; +BEGIN + Inherited Init; { Call ancestor } + Pic := Sw_NewStr(APic); { Hold filename } + Options := voOnAppend; { Preset option mask } + If AutoFill Then Options := Options OR voFill; { Check/set fill mask } + S := ''; { Create empty string } + If (Picture(S, False) <> prEmpty) Then { Check for empty } + Status := vsSyntax; { Set error mask } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TPXPictureValidator.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } +{$ifdef FV_UNICODE} + Pic := S.ReadUnicodeString; { Read filename } +{$else FV_UNICODE} + Pic := S.ReadStr; { Read filename } +{$endif FV_UNICODE} +END; + +{--TPXPictureValidator------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TPXPictureValidator.Done; +BEGIN +{$ifndef FV_UNICODE} + If (Pic <> Nil) Then DisposeStr(Pic); { Dispose of filename } +{$endif FV_UNICODE} + Inherited Done; { Call ancestor } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TPXPictureValidator.IsValid (Const S: Sw_String): Boolean; +VAR Str: Sw_String; Rslt: TPicResult; +BEGIN + Str := S; { Transfer string } + Rslt := Picture(Str, False); { Check for picture } + IsValid := (Pic = Sw_PString_Empty) OR (Rslt = prComplete) OR + (Rslt = prEmpty); { Return result } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TPXPictureValidator.IsValidInput (Var S: Sw_String; + SuppressFill: Boolean): Boolean; +BEGIN + IsValidInput := (Pic = Sw_PString_Empty) OR (Picture(S, + (Options AND voFill <> 0) AND NOT SuppressFill) + <> prError); { Return input result } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ Picture -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TPXPictureValidator.Picture (Var Input: Sw_String; AutoFill: Boolean): TPicResult; +VAR I, J: Byte; Rslt: TPicResult; Reprocess: Boolean; + + FUNCTION Process (TermCh: Byte): TPicResult; + VAR Rslt: TPicResult; Incomp: Boolean; OldI, OldJ, IncompJ, IncompI: Byte; + + PROCEDURE Consume (Ch: Char); + BEGIN + Input[J] := Ch; { Return character } + Inc(J); { Inc count J } + Inc(I); { Inc count I } + END; + + PROCEDURE ToGroupEnd (Var I: Byte); + VAR BrkLevel, BrcLevel: SmallInt; + BEGIN + BrkLevel := 0; { Zero bracket level } + BrcLevel := 0; { Zero bracket level } + Repeat + If (I <> TermCh) Then Begin { Not end } + Case Pic Sw_PString_DeRef[I] Of + '[': Inc(BrkLevel); { Inc bracket level } + ']': Dec(BrkLevel); { Dec bracket level } + '{': Inc(BrcLevel); { Inc bracket level } + '}': Dec(BrcLevel); { Dec bracket level } + ';': Inc(I); { Next character } + '*': Begin + Inc(I); { Next character } + While Pic Sw_PString_DeRef[I] in ['0'..'9'] Do Inc(I); { Search for text } + ToGroupEnd(I); { Move to group end } + Continue; { Now continue } + End; + End; + Inc(I); { Next character } + End; + Until ((BrkLevel = 0) AND (BrcLevel = 0)) OR { Both levels must be 0 } + (I = TermCh); { Terminal character } + END; + + FUNCTION SkipToComma: Boolean; + BEGIN + Repeat + ToGroupEnd(I); { Find group end } + Until (I = TermCh) OR (Pic Sw_PString_DeRef[I] = ','); { Terminator found } + If (Pic Sw_PString_DeRef[I] = ',') Then Inc(I); { Comma so continue } + SkipToComma := (I < TermCh); { Return result } + END; + + FUNCTION CalcTerm: Byte; + VAR K: Byte; + BEGIN + K := I; { Hold count } + ToGroupEnd(K); { Find group end } + CalcTerm := K; { Return count } + END; + + FUNCTION Iteration: TPicResult; + VAR Itr, K, L: Byte; Rslt: TPicResult; NewTermCh: Byte; + BEGIN + Itr := 0; { Zero iteration } + Iteration := prError; { Preset error result } + Inc(I); { Skip '*' character } + While Pic Sw_PString_DeRef[I] in ['0'..'9'] Do Begin { Entry is a number } + Itr := Itr * 10 + Byte(Pic Sw_PString_DeRef[I]) - Byte('0'); { Convert to number } + Inc(I); { Next character } + End; + If (I <= TermCh) Then Begin { Not end of name } + K := I; { Hold count } + NewTermCh := CalcTerm; { Calc next terminator } + If (Itr <> 0) Then Begin + For L := 1 To Itr Do Begin { For each character } + I := K; { Reset count } + Rslt := Process(NewTermCh); { Process new entry } + If (NOT IsComplete(Rslt)) Then Begin { Not empty } + If (Rslt = prEmpty) Then { Check result } + Rslt := prIncomplete; { Return incomplete } + Iteration := Rslt; { Return result } + Exit; { Now exit } + End; + End; + End Else Begin + Repeat + I := K; { Hold count } + Rslt := Process(NewTermCh); { Process new entry } + Until (NOT IsComplete(Rslt)); { Until complete } + If (Rslt = prEmpty) OR (Rslt = prError) { Check for any error } + Then Begin + Inc(I); { Next character } + Rslt := prAmbiguous; { Return result } + End; + End; + I := NewTermCh; { Find next name } + End Else Rslt := prSyntax; { Completed } + Iteration := Rslt; { Return result } + END; + + FUNCTION Group: TPicResult; + VAR Rslt: TPicResult; TermCh: Byte; + BEGIN + TermCh := CalcTerm; { Calc new term } + Inc(I); { Next character } + Rslt := Process(TermCh - 1); { Process the name } + If (NOT IsIncomplete(Rslt)) Then I := TermCh; { Did not complete } + Group := Rslt; { Return result } + END; + + FUNCTION CheckComplete (Rslt: TPicResult): TPicResult; + VAR J: Byte; + BEGIN + J := I; { Hold count } + If IsIncomplete(Rslt) Then Begin { Check if complete } + While True Do + Case Pic Sw_PString_DeRef[J] Of + '[': ToGroupEnd(J); { Find name end } + '*': If not(Pic Sw_PString_DeRef[J + 1] in ['0'..'9']) + Then Begin + Inc(J); { Next name } + ToGroupEnd(J); { Find name end } + End Else Break; + Else Break; + End; + If (J = TermCh) Then Rslt := prAmbiguous; { End of name } + End; + CheckComplete := Rslt; { Return result } + END; + + FUNCTION Scan: TPicResult; + VAR Ch: Char; Rslt: TPicResult; + BEGIN + Scan := prError; { Preset return error } + Rslt := prEmpty; { Preset empty result } + While (I <> TermCh) AND (Pic Sw_PString_DeRef[I] <> ',') { For each entry } + Do Begin + If (J > Length(Input)) Then Begin { Move beyond length } + Scan := CheckComplete(Rslt); { Return result } + Exit; { Now exit } + End; + Ch := Input[J]; { Fetch character } + Case Pic Sw_PString_DeRef[I] of + '#': If NOT (Ch in ['0'..'9']) Then Exit { Check is a number } + Else Consume(Ch); { Transfer number } + '?': If (NOT IsLetter(Ch)) Then Exit { Check is a letter } + Else Consume(Ch); { Transfer character } + '&': If (NOT IsLetter(Ch)) Then Exit { Check is a letter } + Else Consume(UpCase(Ch)); { Transfer character } + '!': Consume(UpCase(Ch)); { Transfer character } + '@': Consume(Ch); { Transfer character } + '*': Begin + Rslt := Iteration; { Now re-iterate } + If (NOT IsComplete(Rslt)) Then Begin { Check not complete } + Scan := Rslt; { Return result } + Exit; { Now exit } + End; + If (Rslt = prError) Then { Check for error } + Rslt := prAmbiguous; { Return ambiguous } + End; + '{': Begin + Rslt := Group; { Return group } + If (NOT IsComplete(Rslt)) Then Begin { Not incomplete check } + Scan := Rslt; { Return result } + Exit; { Now exit } + End; + End; + '[': Begin + Rslt := Group; { Return group } + If IsIncomplete(Rslt) Then Begin { Incomplete check } + Scan := Rslt; { Return result } + Exit; { Now exit } + End; + If (Rslt = prError) Then { Check for error } + Rslt := prAmbiguous; { Return ambiguous } + End; + Else If Pic Sw_PString_DeRef[I] = ';' Then Inc(I); { Move fwd for follow } + If (UpCase(Pic Sw_PString_DeRef[I]) <> UpCase(Ch)) Then { Characters differ } + If (Ch = ' ') Then Ch := Pic Sw_PString_DeRef[I] { Ignore space } + Else Exit; + Consume(Pic Sw_PString_DeRef[I]); { Consume character } + End; { Case } + If (Rslt = prAmbiguous) Then { If ambiguous result } + Rslt := prIncompNoFill { Set incomplete fill } + Else Rslt := prIncomplete; { Set incomplete } + End;{ While} + If (Rslt = prIncompNoFill) Then { Check incomp fill } + Scan := prAmbiguous Else { Return ambiguous } + Scan := prComplete; { Return completed } + END; + + BEGIN + Incomp := False; { Clear incomplete } + InCompJ:=0; { set to avoid a warning } + OldI := I; { Hold I count } + OldJ := J; { Hold J count } + Repeat + Rslt := Scan; { Scan names } + If (Rslt IN [prComplete, prAmbiguous]) AND + Incomp AND (J < IncompJ) Then Begin { Check if complete } + Rslt := prIncomplete; { Return result } + J := IncompJ; { Return position } + End; + If ((Rslt = prError) OR (Rslt = prIncomplete)) { Check no errors } + Then Begin + Process := Rslt; { Hold result } + If ((NOT Incomp) AND (Rslt = prIncomplete)) { Check complete } + Then Begin + Incomp := True; { Set incomplete } + IncompI := I; { Set current position } + IncompJ := J; { Set current position } + End; + I := OldI; { Restore held value } + J := OldJ; { Restore held value } + If (NOT SkipToComma) Then Begin { Check not comma } + If Incomp Then Begin { Check incomplete } + Process := prIncomplete; { Set incomplete mask } + I := IncompI; { Hold incomp position } + J := IncompJ; { Hold incomp position } + End; + Exit; { Now exit } + End; + OldI := I; { Hold position } + End; + Until (Rslt <> prError) AND { Check for error } + (Rslt <> prIncomplete); { Incomplete load } + If (Rslt = prComplete) AND Incomp Then { Complete load } + Process := prAmbiguous Else { Return completed } + Process := Rslt; { Return result } + END; + + FUNCTION SyntaxCheck: Boolean; + VAR I, BrkLevel, BrcLevel: SmallInt; + Begin + SyntaxCheck := False; { Preset false result } + If (Pic Sw_PString_DeRef <> '') AND (Pic Sw_PString_DeRef[Length(Pic Sw_PString_DeRef)] <> ';') { Name is valid } + AND ((Pic Sw_PString_DeRef[Length(Pic Sw_PString_DeRef)] = '*') AND + (Pic Sw_PString_DeRef[Length(Pic Sw_PString_DeRef) - 1] <> ';') = False) { Not wildcard list } + Then Begin + I := 1; { Set count to 1 } + BrkLevel := 0; { Zero bracket level } + BrcLevel := 0; { Zero bracket level } + While (I <= Length(Pic Sw_PString_DeRef)) Do Begin { For each character } + Case Pic Sw_PString_DeRef[I] Of + '[': Inc(BrkLevel); { Inc bracket level } + ']': Dec(BrkLevel); { Dec bracket level } + '{': Inc(BrcLevel); { Inc bracket level } + '}': Dec(BrcLevel); { Dec bracket level } + ';': Inc(I); { Next character } + End; + Inc(I); { Next character } + End; + If (BrkLevel = 0) AND (BrcLevel = 0) Then { Check both levels 0 } + SyntaxCheck := True; { Return true syntax } + End; + End; + +BEGIN + Picture := prSyntax; { Preset error default } + If SyntaxCheck Then Begin { Check syntax } + Picture := prEmpty; { Preset picture empty } + If (Input <> '') Then Begin { We have an input } + J := 1; { Set J count to 1 } + I := 1; { Set I count to 1 } + Rslt := Process(Length(Pic Sw_PString_DeRef) + 1); { Set end of name } + If (Rslt <> prError) AND (Rslt <> prSyntax) AND + (J <= Length(Input)) Then Rslt := prError; { Check for any error } + If (Rslt = prIncomplete) AND AutoFill { Check autofill flags } + Then Begin + Reprocess := False; { Set reprocess false } + while (I <= Length(Pic Sw_PString_DeRef)) AND (NOT { Not at end of name } + IsSpecial(Pic Sw_PString_DeRef[I], '#?&!@*{}[],'#0)) { No special chars } + DO Begin + If Pic Sw_PString_DeRef[I] = ';' Then Inc(I); { Check for next mark } + Input := Input + Pic Sw_PString_DeRef[I]; { Move to that name } + Inc(I); { Inc count } + Reprocess := True; { Set reprocess flag } + End; + J := 1; { Set J count to 1 } + I := 1; { Set I count to 1 } + If Reprocess Then { Check for reprocess } + Rslt := Process(Length(Pic Sw_PString_DeRef) + 1); { Move to next name } + End; + If (Rslt = prAmbiguous) Then { Result ambiguous } + Picture := prComplete Else { Return completed } + If (Rslt = prInCompNoFill) Then { Result incomplete } + Picture := prIncomplete Else { Return incomplete } + Picture := Rslt; { Return result } + End; + End; +END; + +{--TPXPictureValidator------------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TPXPictureValidator.Error; +CONST PXErrMsg = 'Input does not conform to picture:'; +VAR S: Sw_String; +BEGIN + If Pic <> Sw_PString_Empty Then S := Pic Sw_PString_DeRef Else S := 'No name';{ Transfer filename } + MessageBox(PxErrMsg + #13' %s', @S, mfError OR + mfOKButton); { Message box } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TPXPictureValidator.Store (Var S: TStream); +BEGIN + TValidator.Store(S); { TValidator.store call } +{$ifdef FV_UNICODE} + S.WriteUnicodeString(Pic); { Write filename } +{$else FV_UNICODE} + S.WriteStr(Pic); { Write filename } +{$endif FV_UNICODE} +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TFilterValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TFilterValidator---------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TFilterValidator.Init (AValidChars: CharSet); +BEGIN + Inherited Init; { Call ancestor } + ValidChars := AValidChars; { Hold valid char set } +END; + +{--TFilterValidator---------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TFilterValidator.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(ValidChars, SizeOf(ValidChars)); { Read valid char set } +END; + +{--TFilterValidator---------------------------------------------------------} +{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TFilterValidator.IsValid (Const S: Sw_String): Boolean; +VAR I: SmallInt; +BEGIN + I := 1; { Start at position 1 } + While S[I] In ValidChars Do Inc(I); { Check each char } + If (I > Length(S)) Then IsValid := True Else { All characters valid } + IsValid := False; { Invalid characters } +END; + +{--TFilterValidator---------------------------------------------------------} +{ IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TFilterValidator.IsValidInput (Var S: Sw_String; SuppressFill: Boolean): Boolean; +VAR I: SmallInt; +BEGIN + I := 1; { Start at position 1 } + While S[I] In ValidChars Do Inc(I); { Check each char } + If (I > Length(S)) Then IsValidInput := True { All characters valid } + Else IsValidInput := False; { Invalid characters } +END; + +{--TFilterValidator---------------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TFilterValidator.Error; +CONST PXErrMsg = 'Invalid character in input'; +BEGIN + MessageBox(PXErrMsg, Nil, mfError OR mfOKButton); { Show error message } +END; + +{--TFilterValidator---------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TFilterValidator.Store (Var S: TStream); +BEGIN + TValidator.Store(S); { TValidator.Store call } + S.Write(ValidChars, SizeOf(ValidChars)); { Write valid char set } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TRangeValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TRangeValidator----------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TRangeValidator.Init (AMin, AMax: LongInt); +BEGIN + Inherited Init(['0'..'9','+','-']); { Call ancestor } + If (AMin >= 0) Then { Check min value > 0 } + ValidChars := ValidChars - ['-']; { Is so no negatives } + Min := AMin; { Hold min value } + Max := AMax; { Hold max value } +END; + +{--TRangeValidator----------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TRangeValidator.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(Min, SizeOf(Min)); { Read min value } + S.Read(Max, SizeOf(Max)); { Read max value } +END; + +{--TRangeValidator----------------------------------------------------------} +{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRangeValidator.IsValid (Const S: Sw_String): Boolean; +VAR Value: LongInt; Code: Sw_Integer; +BEGIN + IsValid := False; { Preset false result } + If Inherited IsValid(S) Then Begin { Call ancestor } + Val(S, Value, Code); { Convert to number } + If (Value >= Min) AND (Value <= Max) { With valid range } + AND (Code = 0) Then IsValid := True; { No illegal chars } + End; +END; + +{--TRangeValidator----------------------------------------------------------} +{ Transfer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRangeValidator.Transfer (Var S: Sw_String; Buffer: Pointer; Flag: TVTransfer): Word; +VAR Value: LongInt; Code: Sw_Integer; +BEGIN + If (Options AND voTransfer <> 0) Then Begin { Tranfer mask set } + Transfer := SizeOf(Value); { Transfer a longint } + Case Flag Of + vtGetData: Begin + Val(S, Value, Code); { Convert s to number } + LongInt(Buffer^) := Value; { Transfer result } + End; + vtSetData: Str(LongInt(Buffer^), S); { Convert to string s } + End; + End Else Transfer := 0; { No transfer = zero } +END; + +{--TRangeValidator----------------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRangeValidator.Error; +CONST PXErrMsg = 'Value not in the range'; +VAR Params: Array[0..1] Of PtrInt; +BEGIN + Params[0] := Min; { Transfer min value } + Params[1] := Max; { Transfer max value } + MessageBox(PXErrMsg+' %d to %d', @Params, + mfError OR mfOKButton); { Display message } +END; + +{--TRangeValidator----------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRangeValidator.Store (Var S: TStream); +BEGIN + TFilterValidator.Store(S); { TFilterValidator.Store } + S.Write(Min, SizeOf(Min)); { Write min value } + S.Write(Max, SizeOf(Max)); { Write max value } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TLookUpValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TLookUpValidator---------------------------------------------------------} +{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TLookUpValidator.IsValid (Const S: Sw_String): Boolean; +BEGIN + IsValid := LookUp(S); { Check for string } +END; + +{--TLookUpValidator---------------------------------------------------------} +{ LookUp -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TLookupValidator.Lookup (Const S: Sw_String): Boolean; +BEGIN + Lookup := True; { Default return true } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStringLookUpValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TStringLookUpValidator---------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStringLookUpValidator.Init (AStrings: PStringCollection); +BEGIN + Inherited Init; { Call ancestor } + Strings := AStrings; { Hold string list } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStringLookUpValidator.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + Strings := PStringCollection(S.Get); { Fecth string list } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TStringLookUpValidator.Done; +BEGIN + NewStringList(Nil); { Dispsoe string list } + Inherited Done; { Call ancestor } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ Lookup -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStringLookUpValidator.Lookup (Const S: Sw_String): Boolean; +{$IFDEF PPC_VIRTUAL} VAR Index: LongInt; {$ELSE} VAR Index: sw_Integer; {$ENDIF} +BEGIN + Lookup := False; { Preset false return } + If (Strings <> Nil) Then + Lookup := Strings^.Search(@S, Index); { Search for string } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStringLookUpValidator.Error; +CONST PXErrMsg = 'Input not in valid-list'; +BEGIN + MessageBox(PXErrMsg, Nil, mfError OR mfOKButton); { Display message } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ NewStringList -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStringLookUpValidator.NewStringList (AStrings: PStringCollection); +BEGIN + If (Strings <> Nil) Then Dispose(Strings, Done); { Free old string list } + Strings := AStrings; { Hold new string list } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStringLookUpValidator.Store (Var S: TStream); +BEGIN + TLookupValidator.Store(S); { TlookupValidator call } + S.Put(Strings); { Now store strings } +END; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ RegisterValidate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterValidate; +BEGIN + RegisterType(RPXPictureValidator); { Register viewer } + RegisterType(RFilterValidator); { Register filter } + RegisterType(RRangeValidator); { Register validator } + RegisterType(RStringLookupValidator); { Register str lookup } +END; + +END. diff --git a/packages/fv/src/validate.pas b/packages/fv/src/validate.pas index 6e700855f3..10d7d78be9 100644 --- a/packages/fv/src/validate.pas +++ b/packages/fv/src/validate.pas @@ -1,1048 +1 @@ -{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} -{ } -{ System independent GRAPHICAL clone of VALIDATE.PAS } -{ } -{ Interface Copyright (c) 1992 Borland International } -{ } -{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } -{ ldeboer@ibm.net } -{ } -{****************[ THIS CODE IS FREEWARE ]*****************} -{ } -{ This sourcecode is released for the purpose to } -{ promote the pascal language on all platforms. You may } -{ redistribute it and/or modify with the following } -{ DISCLAIMER. } -{ } -{ This SOURCE CODE is distributed "AS IS" WITHOUT } -{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } -{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } -{ } -{*****************[ SUPPORTED PLATFORMS ]******************} -{ 16 and 32 Bit compilers } -{ DOS - Turbo Pascal 7.0 + (16 Bit) } -{ DPMI - Turbo Pascal 7.0 + (16 Bit) } -{ - FPC 0.9912+ (GO32V2) (32 Bit) } -{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } -{ - Delphi 1.0+ (16 Bit) } -{ WIN95/NT - Delphi 2.0+ (32 Bit) } -{ - Virtual Pascal 2.0+ (32 Bit) } -{ - Speedsoft Sybil 2.0+ (32 Bit) } -{ - FPC 0.9912+ (32 Bit) } -{ OS2 - Virtual Pascal 1.0+ (32 Bit) } -{ } -{******************[ REVISION HISTORY ]********************} -{ Version Date Fix } -{ ------- --------- --------------------------------- } -{ 1.00 12 Jun 96 Initial DOS/DPMI code released. } -{ 1.10 29 Aug 97 Platform.inc sort added. } -{ 1.20 13 Oct 97 Delphi3 32 bit code added. } -{ 1.30 11 May 98 Virtual pascal 2.0 code added. } -{ 1.40 10 Jul 99 Sybil 2.0 code added } -{ 1.41 03 Nov 99 FPC windows code added } -{**********************************************************} - -UNIT Validate; - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - INTERFACE -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{====Include file to sort compiler platform out =====================} -{$I platform.inc} -{====================================================================} - -{==== Compiler directives ===========================================} - -{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } - {$F-} { Short calls are okay } - {$A+} { Word Align Data } - {$B-} { Allow short circuit boolean evaluations } - {$O+} { This unit may be overlaid } - {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } - {$P-} { Normal string variables } - {$N-} { No 80x87 code generation } - {$E+} { Emulation is on } -{$ENDIF} - -{$X+} { Extended syntax is ok } -{$R-} { Disable range checking } -{$S-} { Disable Stack Checking } -{$I-} { Disable IO Checking } -{$Q-} { Disable Overflow Checking } -{$V-} { Turn off strict VAR strings } -{====================================================================} - -USES FVCommon, Objects, fvconsts; { GFV standard units } - -{***************************************************************************} -{ PUBLIC CONSTANTS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ VALIDATOR STATUS CONSTANTS } -{---------------------------------------------------------------------------} -CONST - vsOk = 0; { Validator ok } - vsSyntax = 1; { Validator sytax err } - -{---------------------------------------------------------------------------} -{ VALIDATOR OPTION MASKS } -{---------------------------------------------------------------------------} -CONST - voFill = $0001; { Validator fill } - voTransfer = $0002; { Validator transfer } - voOnAppend = $0004; { Validator append } - voReserved = $00F8; { Clear above flags } - -{***************************************************************************} -{ RECORD DEFINITIONS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ VALIDATOR TRANSFER CONSTANTS } -{---------------------------------------------------------------------------} -TYPE - TVTransfer = (vtDataSize, vtSetData, vtGetData); { Transfer states } - -{---------------------------------------------------------------------------} -{ PICTURE VALIDATOR RESULT CONSTANTS } -{---------------------------------------------------------------------------} -TYPE - TPicResult = (prComplete, prIncomplete, prEmpty, prError, prSyntax, - prAmbiguous, prIncompNoFill); - -{***************************************************************************} -{ OBJECT DEFINITIONS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TValidator OBJECT - VALIDATOR ANCESTOR OBJECT } -{---------------------------------------------------------------------------} -TYPE - TValidator = OBJECT (TObject) - Status : Word; { Validator status } - Options: Word; { Validator options } - CONSTRUCTOR Load (Var S: TStream); - FUNCTION Valid(CONST S: String): Boolean; - FUNCTION IsValid (CONST S: String): Boolean; Virtual; - FUNCTION IsValidInput (Var S: String; - SuppressFill: Boolean): Boolean; Virtual; - FUNCTION Transfer (Var S: String; Buffer: Pointer; - Flag: TVTransfer): Word; Virtual; - PROCEDURE Error; Virtual; - PROCEDURE Store (Var S: TStream); - END; - PValidator = ^TValidator; - -{---------------------------------------------------------------------------} -{ TPictureValidator OBJECT - PICTURE VALIDATOR OBJECT } -{---------------------------------------------------------------------------} -TYPE - TPXPictureValidator = OBJECT (TValidator) - Pic: PString; { Picture filename } - CONSTRUCTOR Init (Const APic: String; AutoFill: Boolean); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION IsValid (Const S: String): Boolean; Virtual; - FUNCTION IsValidInput (Var S: String; - SuppressFill: Boolean): Boolean; Virtual; - FUNCTION Picture (Var Input: String; - AutoFill: Boolean): TPicResult; Virtual; - PROCEDURE Error; Virtual; - PROCEDURE Store (Var S: TStream); - END; - PPXPictureValidator = ^TPXPictureValidator; - -TYPE CharSet = TCharSet; - -{---------------------------------------------------------------------------} -{ TFilterValidator OBJECT - FILTER VALIDATOR OBJECT } -{---------------------------------------------------------------------------} -TYPE - TFilterValidator = OBJECT (TValidator) - ValidChars: CharSet; { Valid char set } - CONSTRUCTOR Init (AValidChars: CharSet); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION IsValid (CONST S: String): Boolean; Virtual; - FUNCTION IsValidInput (Var S: String; - SuppressFill: Boolean): Boolean; Virtual; - PROCEDURE Error; Virtual; - PROCEDURE Store (Var S: TStream); - END; - PFilterValidator = ^TFilterValidator; - -{---------------------------------------------------------------------------} -{ TRangeValidator OBJECT - RANGE VALIDATOR OBJECT } -{---------------------------------------------------------------------------} -TYPE - TRangeValidator = OBJECT (TFilterValidator) - Min: LongInt; { Min valid value } - Max: LongInt; { Max valid value } - CONSTRUCTOR Init(AMin, AMax: LongInt); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION IsValid (Const S: String): Boolean; Virtual; - FUNCTION Transfer (Var S: String; Buffer: Pointer; - Flag: TVTransfer): Word; Virtual; - PROCEDURE Error; Virtual; - PROCEDURE Store (Var S: TStream); - END; - PRangeValidator = ^TRangeValidator; - -{---------------------------------------------------------------------------} -{ TLookUpValidator OBJECT - LOOKUP VALIDATOR OBJECT } -{---------------------------------------------------------------------------} -TYPE - TLookupValidator = OBJECT (TValidator) - FUNCTION IsValid (Const S: String): Boolean; Virtual; - FUNCTION Lookup (Const S: String): Boolean; Virtual; - END; - PLookupValidator = ^TLookupValidator; - -{---------------------------------------------------------------------------} -{ TStringLookUpValidator OBJECT - STRING LOOKUP VALIDATOR OBJECT } -{---------------------------------------------------------------------------} -TYPE - TStringLookupValidator = OBJECT (TLookupValidator) - Strings: PStringCollection; - CONSTRUCTOR Init (AStrings: PStringCollection); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION Lookup (Const S: String): Boolean; Virtual; - PROCEDURE Error; Virtual; - PROCEDURE NewStringList (AStrings: PStringCollection); - PROCEDURE Store (Var S: TStream); - END; - PStringLookupValidator = ^TStringLookupValidator; - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ OBJECT REGISTER ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{-RegisterValidate--------------------------------------------------- -Calls RegisterType for each of the object types defined in this unit. -18May98 LdB ----------------------------------------------------------------------} -PROCEDURE RegisterValidate; - -{***************************************************************************} -{ OBJECT REGISTRATION } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TPXPictureValidator STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RPXPictureValidator: TStreamRec = ( - ObjType: idPXPictureValidator; { Register id = 80 } - {$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs(TypeOf(TPXPictureValidator)^); - {$ELSE} { Alt style VMT link } - VmtLink: TypeOf(TPXPictureValidator); - {$ENDIF} - Load: @TPXPictureValidator.Load; { Object load method } - Store: @TPXPictureValidator.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TFilterValidator STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RFilterValidator: TStreamRec = ( - ObjType: idFilterValidator; { Register id = 81 } - {$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs(TypeOf(TFilterValidator)^); - {$ELSE} { Alt style VMT link } - VmtLink: TypeOf(TFilterValidator); - {$ENDIF} - Load: @TFilterValidator.Load; { Object load method } - Store: @TFilterValidator.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TRangeValidator STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RRangeValidator: TStreamRec = ( - ObjType: idRangeValidator; { Register id = 82 } - {$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs(TypeOf(TRangeValidator)^); - {$ELSE} { Alt style VMT link } - VmtLink: TypeOf(TRangeValidator); - {$ENDIF} - Load: @TRangeValidator.Load; { Object load method } - Store: @TRangeValidator.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TStringLookupValidator STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RStringLookupValidator: TStreamRec = ( - ObjType: idStringLookupValidator; { Register id = 83 } - {$IFDEF BP_VMTLink} { BP style VMT link } - VmtLink: Ofs(TypeOf(TStringLookupValidator)^); - {$ELSE} { Alt style VMT link } - VmtLink: TypeOf(TStringLookupValidator); - {$ENDIF} - Load: @TStringLookupValidator.Load; { Object load method } - Store: @TStringLookupValidator.Store { Object store method } - ); - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IMPLEMENTATION -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -USES MsgBox; { GFV standard unit } - -{***************************************************************************} -{ PRIVATE ROUTINES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ IsLetter -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION IsLetter (Chr: Char): Boolean; -BEGIN - Chr := Char(Ord(Chr) AND $DF); { Lower to upper case } - If (Chr >= 'A') AND (Chr <='Z') Then { Check if A..Z } - IsLetter := True Else IsLetter := False; { Return result } -END; - -{---------------------------------------------------------------------------} -{ IsComplete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION IsComplete (Rslt: TPicResult): Boolean; -BEGIN - IsComplete := Rslt IN [prComplete, prAmbiguous]; { Return if complete } -END; - -{---------------------------------------------------------------------------} -{ IsInComplete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION IsIncomplete (Rslt: TPicResult): Boolean; -BEGIN - IsIncomplete := Rslt IN - [prIncomplete, prIncompNoFill]; { Return if incomplete } -END; - -{---------------------------------------------------------------------------} -{ NumChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION NumChar (Chr: Char; Const S: String): Byte; -VAR I, Total: Byte; -BEGIN - Total := 0; { Zero total } - For I := 1 To Length(S) Do { For entire string } - If (S[I] = Chr) Then Inc(Total); { Count matches of Chr } - NumChar := Total; { Return char count } -END; - -{---------------------------------------------------------------------------} -{ IsSpecial -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION IsSpecial (Chr: Char; Const Special: String): Boolean; -VAR Rslt: Boolean; I: Byte; -BEGIN - Rslt := False; { Preset false result } - For I := 1 To Length(Special) Do - If (Special[I] = Chr) Then Rslt := True; { Character found } - IsSpecial := Rslt; { Return result } -END; - -{***************************************************************************} -{ OBJECT METHODS } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TValidator OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TValidator---------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TValidator.Load (Var S:TStream); -BEGIN - Inherited Init; { Call ancestor } - S.Read(Options, SizeOf(Options)); { Read option masks } -END; - -{--TValidator---------------------------------------------------------------} -{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TValidator.Valid (Const S: String): Boolean; -BEGIN - Valid := False; { Preset false result } - If Not IsValid(S) Then Error { Check for error } - Else Valid := True; { Return valid result } -END; - -{--TValidator---------------------------------------------------------------} -{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TValidator.IsValid (Const S: String): Boolean; -BEGIN - IsValid := True; { Default return valid } -END; - -{--TValidator---------------------------------------------------------------} -{ IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TValidator.IsValidInput (Var S: String; SuppressFill: Boolean): Boolean; -BEGIN - IsValidInput := True; { Default return true } -END; - -{--TValidator---------------------------------------------------------------} -{ Transfer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TValidator.Transfer (Var S: String; Buffer: Pointer; - Flag: TVTransfer): Word; -BEGIN - Transfer := 0; { Default return zero } -END; - -{--TValidator---------------------------------------------------------------} -{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TValidator.Error; -BEGIN { Abstract method } -END; - -{--TValidator---------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TValidator.Store (Var S: TStream); -BEGIN - S.Write(Options, SizeOf(Options)); { Write options } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TPXPictureValidator OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TPXPictureValidator------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TPXPictureValidator.Init (Const APic: String; AutoFill: Boolean); -VAR S: String; -BEGIN - Inherited Init; { Call ancestor } - Pic := NewStr(APic); { Hold filename } - Options := voOnAppend; { Preset option mask } - If AutoFill Then Options := Options OR voFill; { Check/set fill mask } - S := ''; { Create empty string } - If (Picture(S, False) <> prEmpty) Then { Check for empty } - Status := vsSyntax; { Set error mask } -END; - -{--TPXPictureValidator------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TPXPictureValidator.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - Pic := S.ReadStr; { Read filename } -END; - -{--TPXPictureValidator------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TPXPictureValidator.Done; -BEGIN - If (Pic <> Nil) Then DisposeStr(Pic); { Dispose of filename } - Inherited Done; { Call ancestor } -END; - -{--TPXPictureValidator------------------------------------------------------} -{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TPXPictureValidator.IsValid (Const S: String): Boolean; -VAR Str: String; Rslt: TPicResult; -BEGIN - Str := S; { Transfer string } - Rslt := Picture(Str, False); { Check for picture } - IsValid := (Pic = nil) OR (Rslt = prComplete) OR - (Rslt = prEmpty); { Return result } -END; - -{--TPXPictureValidator------------------------------------------------------} -{ IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TPXPictureValidator.IsValidInput (Var S: String; - SuppressFill: Boolean): Boolean; -BEGIN - IsValidInput := (Pic = Nil) OR (Picture(S, - (Options AND voFill <> 0) AND NOT SuppressFill) - <> prError); { Return input result } -END; - -{--TPXPictureValidator------------------------------------------------------} -{ Picture -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TPXPictureValidator.Picture (Var Input: String; AutoFill: Boolean): TPicResult; -VAR I, J: Byte; Rslt: TPicResult; Reprocess: Boolean; - - FUNCTION Process (TermCh: Byte): TPicResult; - VAR Rslt: TPicResult; Incomp: Boolean; OldI, OldJ, IncompJ, IncompI: Byte; - - PROCEDURE Consume (Ch: Char); - BEGIN - Input[J] := Ch; { Return character } - Inc(J); { Inc count J } - Inc(I); { Inc count I } - END; - - PROCEDURE ToGroupEnd (Var I: Byte); - VAR BrkLevel, BrcLevel: Integer; - BEGIN - BrkLevel := 0; { Zero bracket level } - BrcLevel := 0; { Zero bracket level } - Repeat - If (I <> TermCh) Then Begin { Not end } - Case Pic^[I] Of - '[': Inc(BrkLevel); { Inc bracket level } - ']': Dec(BrkLevel); { Dec bracket level } - '{': Inc(BrcLevel); { Inc bracket level } - '}': Dec(BrcLevel); { Dec bracket level } - ';': Inc(I); { Next character } - '*': Begin - Inc(I); { Next character } - While Pic^[I] in ['0'..'9'] Do Inc(I); { Search for text } - ToGroupEnd(I); { Move to group end } - Continue; { Now continue } - End; - End; - Inc(I); { Next character } - End; - Until ((BrkLevel = 0) AND (BrcLevel = 0)) OR { Both levels must be 0 } - (I = TermCh); { Terminal character } - END; - - FUNCTION SkipToComma: Boolean; - BEGIN - Repeat - ToGroupEnd(I); { Find group end } - Until (I = TermCh) OR (Pic^[I] = ','); { Terminator found } - If (Pic^[I] = ',') Then Inc(I); { Comma so continue } - SkipToComma := (I < TermCh); { Return result } - END; - - FUNCTION CalcTerm: Byte; - VAR K: Byte; - BEGIN - K := I; { Hold count } - ToGroupEnd(K); { Find group end } - CalcTerm := K; { Return count } - END; - - FUNCTION Iteration: TPicResult; - VAR Itr, K, L: Byte; Rslt: TPicResult; NewTermCh: Byte; - BEGIN - Itr := 0; { Zero iteration } - Iteration := prError; { Preset error result } - Inc(I); { Skip '*' character } - While Pic^[I] in ['0'..'9'] Do Begin { Entry is a number } - Itr := Itr * 10 + Byte(Pic^[I]) - Byte('0'); { Convert to number } - Inc(I); { Next character } - End; - If (I <= TermCh) Then Begin { Not end of name } - K := I; { Hold count } - NewTermCh := CalcTerm; { Calc next terminator } - If (Itr <> 0) Then Begin - For L := 1 To Itr Do Begin { For each character } - I := K; { Reset count } - Rslt := Process(NewTermCh); { Process new entry } - If (NOT IsComplete(Rslt)) Then Begin { Not empty } - If (Rslt = prEmpty) Then { Check result } - Rslt := prIncomplete; { Return incomplete } - Iteration := Rslt; { Return result } - Exit; { Now exit } - End; - End; - End Else Begin - Repeat - I := K; { Hold count } - Rslt := Process(NewTermCh); { Process new entry } - Until (NOT IsComplete(Rslt)); { Until complete } - If (Rslt = prEmpty) OR (Rslt = prError) { Check for any error } - Then Begin - Inc(I); { Next character } - Rslt := prAmbiguous; { Return result } - End; - End; - I := NewTermCh; { Find next name } - End Else Rslt := prSyntax; { Completed } - Iteration := Rslt; { Return result } - END; - - FUNCTION Group: TPicResult; - VAR Rslt: TPicResult; TermCh: Byte; - BEGIN - TermCh := CalcTerm; { Calc new term } - Inc(I); { Next character } - Rslt := Process(TermCh - 1); { Process the name } - If (NOT IsIncomplete(Rslt)) Then I := TermCh; { Did not complete } - Group := Rslt; { Return result } - END; - - FUNCTION CheckComplete (Rslt: TPicResult): TPicResult; - VAR J: Byte; - BEGIN - J := I; { Hold count } - If IsIncomplete(Rslt) Then Begin { Check if complete } - While True Do - Case Pic^[J] Of - '[': ToGroupEnd(J); { Find name end } - '*': If not(Pic^[J + 1] in ['0'..'9']) - Then Begin - Inc(J); { Next name } - ToGroupEnd(J); { Find name end } - End Else Break; - Else Break; - End; - If (J = TermCh) Then Rslt := prAmbiguous; { End of name } - End; - CheckComplete := Rslt; { Return result } - END; - - FUNCTION Scan: TPicResult; - VAR Ch: Char; Rslt: TPicResult; - BEGIN - Scan := prError; { Preset return error } - Rslt := prEmpty; { Preset empty result } - While (I <> TermCh) AND (Pic^[I] <> ',') { For each entry } - Do Begin - If (J > Length(Input)) Then Begin { Move beyond length } - Scan := CheckComplete(Rslt); { Return result } - Exit; { Now exit } - End; - Ch := Input[J]; { Fetch character } - Case Pic^[I] of - '#': If NOT (Ch in ['0'..'9']) Then Exit { Check is a number } - Else Consume(Ch); { Transfer number } - '?': If (NOT IsLetter(Ch)) Then Exit { Check is a letter } - Else Consume(Ch); { Transfer character } - '&': If (NOT IsLetter(Ch)) Then Exit { Check is a letter } - Else Consume(UpCase(Ch)); { Transfer character } - '!': Consume(UpCase(Ch)); { Transfer character } - '@': Consume(Ch); { Transfer character } - '*': Begin - Rslt := Iteration; { Now re-iterate } - If (NOT IsComplete(Rslt)) Then Begin { Check not complete } - Scan := Rslt; { Return result } - Exit; { Now exit } - End; - If (Rslt = prError) Then { Check for error } - Rslt := prAmbiguous; { Return ambiguous } - End; - '{': Begin - Rslt := Group; { Return group } - If (NOT IsComplete(Rslt)) Then Begin { Not incomplete check } - Scan := Rslt; { Return result } - Exit; { Now exit } - End; - End; - '[': Begin - Rslt := Group; { Return group } - If IsIncomplete(Rslt) Then Begin { Incomplete check } - Scan := Rslt; { Return result } - Exit; { Now exit } - End; - If (Rslt = prError) Then { Check for error } - Rslt := prAmbiguous; { Return ambiguous } - End; - Else If Pic^[I] = ';' Then Inc(I); { Move fwd for follow } - If (UpCase(Pic^[I]) <> UpCase(Ch)) Then { Characters differ } - If (Ch = ' ') Then Ch := Pic^[I] { Ignore space } - Else Exit; - Consume(Pic^[I]); { Consume character } - End; { Case } - If (Rslt = prAmbiguous) Then { If ambiguous result } - Rslt := prIncompNoFill { Set incomplete fill } - Else Rslt := prIncomplete; { Set incomplete } - End;{ While} - If (Rslt = prIncompNoFill) Then { Check incomp fill } - Scan := prAmbiguous Else { Return ambiguous } - Scan := prComplete; { Return completed } - END; - - BEGIN - Incomp := False; { Clear incomplete } - InCompJ:=0; { set to avoid a warning } - OldI := I; { Hold I count } - OldJ := J; { Hold J count } - Repeat - Rslt := Scan; { Scan names } - If (Rslt IN [prComplete, prAmbiguous]) AND - Incomp AND (J < IncompJ) Then Begin { Check if complete } - Rslt := prIncomplete; { Return result } - J := IncompJ; { Return position } - End; - If ((Rslt = prError) OR (Rslt = prIncomplete)) { Check no errors } - Then Begin - Process := Rslt; { Hold result } - If ((NOT Incomp) AND (Rslt = prIncomplete)) { Check complete } - Then Begin - Incomp := True; { Set incomplete } - IncompI := I; { Set current position } - IncompJ := J; { Set current position } - End; - I := OldI; { Restore held value } - J := OldJ; { Restore held value } - If (NOT SkipToComma) Then Begin { Check not comma } - If Incomp Then Begin { Check incomplete } - Process := prIncomplete; { Set incomplete mask } - I := IncompI; { Hold incomp position } - J := IncompJ; { Hold incomp position } - End; - Exit; { Now exit } - End; - OldI := I; { Hold position } - End; - Until (Rslt <> prError) AND { Check for error } - (Rslt <> prIncomplete); { Incomplete load } - If (Rslt = prComplete) AND Incomp Then { Complete load } - Process := prAmbiguous Else { Return completed } - Process := Rslt; { Return result } - END; - - FUNCTION SyntaxCheck: Boolean; - VAR I, BrkLevel, BrcLevel: Integer; - Begin - SyntaxCheck := False; { Preset false result } - If (Pic^ <> '') AND (Pic^[Length(Pic^)] <> ';') { Name is valid } - AND ((Pic^[Length(Pic^)] = '*') AND - (Pic^[Length(Pic^) - 1] <> ';') = False) { Not wildcard list } - Then Begin - I := 1; { Set count to 1 } - BrkLevel := 0; { Zero bracket level } - BrcLevel := 0; { Zero bracket level } - While (I <= Length(Pic^)) Do Begin { For each character } - Case Pic^[I] Of - '[': Inc(BrkLevel); { Inc bracket level } - ']': Dec(BrkLevel); { Dec bracket level } - '{': Inc(BrcLevel); { Inc bracket level } - '}': Dec(BrcLevel); { Dec bracket level } - ';': Inc(I); { Next character } - End; - Inc(I); { Next character } - End; - If (BrkLevel = 0) AND (BrcLevel = 0) Then { Check both levels 0 } - SyntaxCheck := True; { Return true syntax } - End; - End; - -BEGIN - Picture := prSyntax; { Preset error default } - If SyntaxCheck Then Begin { Check syntax } - Picture := prEmpty; { Preset picture empty } - If (Input <> '') Then Begin { We have an input } - J := 1; { Set J count to 1 } - I := 1; { Set I count to 1 } - Rslt := Process(Length(Pic^) + 1); { Set end of name } - If (Rslt <> prError) AND (Rslt <> prSyntax) AND - (J <= Length(Input)) Then Rslt := prError; { Check for any error } - If (Rslt = prIncomplete) AND AutoFill { Check autofill flags } - Then Begin - Reprocess := False; { Set reprocess false } - while (I <= Length(Pic^)) AND (NOT { Not at end of name } - IsSpecial(Pic^[I], '#?&!@*{}[],'#0)) { No special chars } - DO Begin - If Pic^[I] = ';' Then Inc(I); { Check for next mark } - Input := Input + Pic^[I]; { Move to that name } - Inc(I); { Inc count } - Reprocess := True; { Set reprocess flag } - End; - J := 1; { Set J count to 1 } - I := 1; { Set I count to 1 } - If Reprocess Then { Check for reprocess } - Rslt := Process(Length(Pic^) + 1); { Move to next name } - End; - If (Rslt = prAmbiguous) Then { Result ambiguous } - Picture := prComplete Else { Return completed } - If (Rslt = prInCompNoFill) Then { Result incomplete } - Picture := prIncomplete Else { Return incomplete } - Picture := Rslt; { Return result } - End; - End; -END; - -{--TPXPictureValidator------------------------------------------------------} -{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TPXPictureValidator.Error; -CONST PXErrMsg = 'Input does not conform to picture:'; -VAR S: String; -BEGIN - If (Pic <> Nil) Then S := Pic^ Else S := 'No name';{ Transfer filename } - MessageBox(PxErrMsg + #13' %s', @S, mfError OR - mfOKButton); { Message box } -END; - -{--TPXPictureValidator------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TPXPictureValidator.Store (Var S: TStream); -BEGIN - TValidator.Store(S); { TValidator.store call } - S.WriteStr(Pic); { Write filename } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TFilterValidator OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TFilterValidator---------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TFilterValidator.Init (AValidChars: CharSet); -BEGIN - Inherited Init; { Call ancestor } - ValidChars := AValidChars; { Hold valid char set } -END; - -{--TFilterValidator---------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TFilterValidator.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - S.Read(ValidChars, SizeOf(ValidChars)); { Read valid char set } -END; - -{--TFilterValidator---------------------------------------------------------} -{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TFilterValidator.IsValid (Const S: String): Boolean; -VAR I: Integer; -BEGIN - I := 1; { Start at position 1 } - While S[I] In ValidChars Do Inc(I); { Check each char } - If (I > Length(S)) Then IsValid := True Else { All characters valid } - IsValid := False; { Invalid characters } -END; - -{--TFilterValidator---------------------------------------------------------} -{ IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TFilterValidator.IsValidInput (Var S: String; SuppressFill: Boolean): Boolean; -VAR I: Integer; -BEGIN - I := 1; { Start at position 1 } - While S[I] In ValidChars Do Inc(I); { Check each char } - If (I > Length(S)) Then IsValidInput := True { All characters valid } - Else IsValidInput := False; { Invalid characters } -END; - -{--TFilterValidator---------------------------------------------------------} -{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TFilterValidator.Error; -CONST PXErrMsg = 'Invalid character in input'; -BEGIN - MessageBox(PXErrMsg, Nil, mfError OR mfOKButton); { Show error message } -END; - -{--TFilterValidator---------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TFilterValidator.Store (Var S: TStream); -BEGIN - TValidator.Store(S); { TValidator.Store call } - S.Write(ValidChars, SizeOf(ValidChars)); { Write valid char set } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TRangeValidator OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TRangeValidator----------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TRangeValidator.Init (AMin, AMax: LongInt); -BEGIN - Inherited Init(['0'..'9','+','-']); { Call ancestor } - If (AMin >= 0) Then { Check min value > 0 } - ValidChars := ValidChars - ['-']; { Is so no negatives } - Min := AMin; { Hold min value } - Max := AMax; { Hold max value } -END; - -{--TRangeValidator----------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TRangeValidator.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - S.Read(Min, SizeOf(Min)); { Read min value } - S.Read(Max, SizeOf(Max)); { Read max value } -END; - -{--TRangeValidator----------------------------------------------------------} -{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TRangeValidator.IsValid (Const S: String): Boolean; -VAR Value: LongInt; Code: Sw_Integer; -BEGIN - IsValid := False; { Preset false result } - If Inherited IsValid(S) Then Begin { Call ancestor } - Val(S, Value, Code); { Convert to number } - If (Value >= Min) AND (Value <= Max) { With valid range } - AND (Code = 0) Then IsValid := True; { No illegal chars } - End; -END; - -{--TRangeValidator----------------------------------------------------------} -{ Transfer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TRangeValidator.Transfer (Var S: String; Buffer: Pointer; Flag: TVTransfer): Word; -VAR Value: LongInt; Code: Sw_Integer; -BEGIN - If (Options AND voTransfer <> 0) Then Begin { Tranfer mask set } - Transfer := SizeOf(Value); { Transfer a longint } - Case Flag Of - vtGetData: Begin - Val(S, Value, Code); { Convert s to number } - LongInt(Buffer^) := Value; { Transfer result } - End; - vtSetData: Str(LongInt(Buffer^), S); { Convert to string s } - End; - End Else Transfer := 0; { No transfer = zero } -END; - -{--TRangeValidator----------------------------------------------------------} -{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TRangeValidator.Error; -CONST PXErrMsg = 'Value not in the range'; -VAR Params: Array[0..1] Of PtrInt; -BEGIN - Params[0] := Min; { Transfer min value } - Params[1] := Max; { Transfer max value } - MessageBox(PXErrMsg+' %d to %d', @Params, - mfError OR mfOKButton); { Display message } -END; - -{--TRangeValidator----------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TRangeValidator.Store (Var S: TStream); -BEGIN - TFilterValidator.Store(S); { TFilterValidator.Store } - S.Write(Min, SizeOf(Min)); { Write min value } - S.Write(Max, SizeOf(Max)); { Write max value } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TLookUpValidator OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TLookUpValidator---------------------------------------------------------} -{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TLookUpValidator.IsValid (Const S: String): Boolean; -BEGIN - IsValid := LookUp(S); { Check for string } -END; - -{--TLookUpValidator---------------------------------------------------------} -{ LookUp -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TLookupValidator.Lookup (Const S: String): Boolean; -BEGIN - Lookup := True; { Default return true } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TStringLookUpValidator OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TStringLookUpValidator---------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TStringLookUpValidator.Init (AStrings: PStringCollection); -BEGIN - Inherited Init; { Call ancestor } - Strings := AStrings; { Hold string list } -END; - -{--TStringLookUpValidator---------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TStringLookUpValidator.Load (Var S: TStream); -BEGIN - Inherited Load(S); { Call ancestor } - Strings := PStringCollection(S.Get); { Fecth string list } -END; - -{--TStringLookUpValidator---------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TStringLookUpValidator.Done; -BEGIN - NewStringList(Nil); { Dispsoe string list } - Inherited Done; { Call ancestor } -END; - -{--TStringLookUpValidator---------------------------------------------------} -{ Lookup -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TStringLookUpValidator.Lookup (Const S: String): Boolean; -{$IFDEF PPC_VIRTUAL} VAR Index: LongInt; {$ELSE} VAR Index: sw_Integer; {$ENDIF} -BEGIN - Lookup := False; { Preset false return } - If (Strings <> Nil) Then - Lookup := Strings^.Search(@S, Index); { Search for string } -END; - -{--TStringLookUpValidator---------------------------------------------------} -{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStringLookUpValidator.Error; -CONST PXErrMsg = 'Input not in valid-list'; -BEGIN - MessageBox(PXErrMsg, Nil, mfError OR mfOKButton); { Display message } -END; - -{--TStringLookUpValidator---------------------------------------------------} -{ NewStringList -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStringLookUpValidator.NewStringList (AStrings: PStringCollection); -BEGIN - If (Strings <> Nil) Then Dispose(Strings, Done); { Free old string list } - Strings := AStrings; { Hold new string list } -END; - -{--TStringLookUpValidator---------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TStringLookUpValidator.Store (Var S: TStream); -BEGIN - TLookupValidator.Store(S); { TlookupValidator call } - S.Put(Strings); { Now store strings } -END; - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ OBJECT REGISTER ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ RegisterValidate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE RegisterValidate; -BEGIN - RegisterType(RPXPictureValidator); { Register viewer } - RegisterType(RFilterValidator); { Register filter } - RegisterType(RRangeValidator); { Register validator } - RegisterType(RStringLookupValidator); { Register str lookup } -END; - -END. +{$I validate.inc} diff --git a/packages/fv/src/views.inc b/packages/fv/src/views.inc new file mode 100644 index 0000000000..4d5af5dfd3 --- /dev/null +++ b/packages/fv/src/views.inc @@ -0,0 +1,4838 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of VIEWS.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@starwon.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} + +{$ifdef FV_UNICODE} +UNIT UViews; +{$else FV_UNICODE} +UNIT Views; +{$endif FV_UNICODE} + +{$CODEPAGE cp437} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES + {$IFDEF OS_WINDOWS} { WIN/NT CODE } + Windows, { Standard unit } + {$ENDIF} + + {$IFDEF OS_OS2} { OS2 CODE } + Os2Def, DosCalls, PmWin, + {$ENDIF} + + Objects, {$ifdef FV_UNICODE}UFVCommon,UDrivers,GraphemeBreakProperty{$else}FVCommon,Drivers{$endif}, fvconsts, { GFV standard units } + Video; + + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TView STATE MASKS } +{---------------------------------------------------------------------------} +CONST + sfVisible = $0001; { View visible mask } + sfCursorVis = $0002; { Cursor visible } + sfCursorIns = $0004; { Cursor insert mode } + sfShadow = $0008; { View has shadow } + sfActive = $0010; { View is active } + sfSelected = $0020; { View is selected } + sfFocused = $0040; { View is focused } + sfDragging = $0080; { View is dragging } + sfDisabled = $0100; { View is disabled } + sfModal = $0200; { View is modal } + sfDefault = $0400; { View is default } + sfExposed = $0800; { View is exposed } + sfIconised = $1000; { View is iconised } + +{---------------------------------------------------------------------------} +{ TView OPTION MASKS } +{---------------------------------------------------------------------------} +CONST + ofSelectable = $0001; { View selectable } + ofTopSelect = $0002; { Top selectable } + ofFirstClick = $0004; { First click react } + ofFramed = $0008; { View is framed } + ofPreProcess = $0010; { Pre processes } + ofPostProcess = $0020; { Post processes } + ofBuffered = $0040; { View is buffered } + ofTileable = $0080; { View is tileable } + ofCenterX = $0100; { View centred on x } + ofCenterY = $0200; { View centred on y } + ofCentered = $0300; { View x,y centred } + ofValidate = $0400; { View validates } + ofVersion = $3000; { View TV version } + ofVersion10 = $0000; { TV version 1 view } + ofVersion20 = $1000; { TV version 2 view } + +{---------------------------------------------------------------------------} +{ TView GROW MODE MASKS } +{---------------------------------------------------------------------------} +CONST + gfGrowLoX = $01; { Left side grow } + gfGrowLoY = $02; { Top side grow } + gfGrowHiX = $04; { Right side grow } + gfGrowHiY = $08; { Bottom side grow } + gfGrowAll = $0F; { Grow on all sides } + gfGrowRel = $10; { Grow relative } + +{---------------------------------------------------------------------------} +{ TView DRAG MODE MASKS } +{---------------------------------------------------------------------------} +CONST + dmDragMove = $01; { Move view } + dmDragGrow = $02; { Grow view } + dmLimitLoX = $10; { Limit left side } + dmLimitLoY = $20; { Limit top side } + dmLimitHiX = $40; { Limit right side } + dmLimitHiY = $80; { Limit bottom side } + dmLimitAll = $F0; { Limit all sides } + +{---------------------------------------------------------------------------} +{ >> NEW << TAB OPTION MASKS } +{---------------------------------------------------------------------------} +CONST + tmTab = $01; { Tab move mask } + tmShiftTab = $02; { Shift+tab move mask } + tmEnter = $04; { Enter move mask } + tmLeft = $08; { Left arrow move mask } + tmRight = $10; { Right arrow move mask } + tmUp = $20; { Up arrow move mask } + tmDown = $40; { Down arrow move mask } + +{---------------------------------------------------------------------------} +{ >> NEW << VIEW DRAW MASKS } +{---------------------------------------------------------------------------} +CONST + vdBackGnd = $01; { Draw backgound } + vdInner = $02; { Draw inner detail } + vdCursor = $04; { Draw cursor } + vdBorder = $08; { Draw view border } + vdFocus = $10; { Draw focus state } + vdNoChild = $20; { Draw no children } + vdShadow = $40; + vdAll = vdBackGnd + vdInner + vdCursor + vdBorder + vdFocus + vdShadow; + +{---------------------------------------------------------------------------} +{ TView HELP CONTEXTS } +{---------------------------------------------------------------------------} +CONST + hcNoContext = 0; { No view context } + hcDragging = 1; { No drag context } + +{---------------------------------------------------------------------------} +{ TWindow FLAG MASKS } +{---------------------------------------------------------------------------} +CONST + wfMove = $01; { Window can move } + wfGrow = $02; { Window can grow } + wfClose = $04; { Window can close } + wfZoom = $08; { Window can zoom } + +{---------------------------------------------------------------------------} +{ TWindow PALETTES } +{---------------------------------------------------------------------------} +CONST + wpBlueWindow = 0; { Blue palette } + wpCyanWindow = 1; { Cyan palette } + wpGrayWindow = 2; { Gray palette } + +{---------------------------------------------------------------------------} +{ COLOUR PALETTES } +{---------------------------------------------------------------------------} +CONST + CFrame = #1#1#2#2#3; { Frame palette } + CScrollBar = #4#5#5; { Scrollbar palette } + CScroller = #6#7; { Scroller palette } + CListViewer = #26#26#27#28#29; { Listviewer palette } + + CBlueWindow = #8#9#10#11#12#13#14#15; { Blue window palette } + CCyanWindow = #16#17#18#19#20#21#22#23; { Cyan window palette } + CGrayWindow = #24#25#26#27#28#29#30#31; { Grey window palette } + +{---------------------------------------------------------------------------} +{ TScrollBar PART CODES } +{---------------------------------------------------------------------------} +CONST + sbLeftArrow = 0; { Left arrow part } + sbRightArrow = 1; { Right arrow part } + sbPageLeft = 2; { Page left part } + sbPageRight = 3; { Page right part } + sbUpArrow = 4; { Up arrow part } + sbDownArrow = 5; { Down arrow part } + sbPageUp = 6; { Page up part } + sbPageDown = 7; { Page down part } + sbIndicator = 8; { Indicator part } + +{---------------------------------------------------------------------------} +{ TScrollBar OPTIONS FOR TWindow.StandardScrollBar } +{---------------------------------------------------------------------------} +CONST + sbHorizontal = $0000; { Horz scrollbar } + sbVertical = $0001; { Vert scrollbar } + sbHandleKeyboard = $0002; { Handle keyboard } + +{---------------------------------------------------------------------------} +{ STANDARD COMMAND CODES } +{---------------------------------------------------------------------------} +CONST + cmValid = 0; { Valid command } + cmQuit = 1; { Quit command } + cmError = 2; { Error command } + cmMenu = 3; { Menu command } + cmClose = 4; { Close command } + cmZoom = 5; { Zoom command } + cmResize = 6; { Resize command } + cmNext = 7; { Next view command } + cmPrev = 8; { Prev view command } + cmHelp = 9; { Help command } + cmOK = 10; { Okay command } + cmCancel = 11; { Cancel command } + cmYes = 12; { Yes command } + cmNo = 13; { No command } + cmDefault = 14; { Default command } + cmCut = 20; { Clipboard cut cmd } + cmCopy = 21; { Clipboard copy cmd } + cmPaste = 22; { Clipboard paste cmd } + cmUndo = 23; { Clipboard undo cmd } + cmClear = 24; { Clipboard clear cmd } + cmTile = 25; { Tile subviews cmd } + cmCascade = 26; { Cascade subviews cmd } + cmReceivedFocus = 50; { Received focus } + cmReleasedFocus = 51; { Released focus } + cmCommandSetChanged = 52; { Commands changed } + cmScrollBarChanged = 53; { Scrollbar changed } + cmScrollBarClicked = 54; { Scrollbar clicked on } + cmSelectWindowNum = 55; { Select window } + cmListItemSelected = 56; { Listview item select } + + cmNotify = 27; + cmIdCommunicate = 28; { Communicate via id } + cmIdSelect = 29; { Select via id } + +{---------------------------------------------------------------------------} +{ TWindow NUMBER CONSTANTS } +{---------------------------------------------------------------------------} +CONST + wnNoNumber = 0; { Window has no num } + MaxViewWidth = 255; { Max view width } + + +{***************************************************************************} +{ PUBLIC TYPE DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TWindow Title string } +{---------------------------------------------------------------------------} +TYPE +{$ifdef FV_UNICODE} + TTitleStr = UnicodeString; { Window title string } +{$else FV_UNICODE} + TTitleStr = String[80]; { Window title string } +{$endif FV_UNICODE} + +{---------------------------------------------------------------------------} +{ COMMAND SET RECORD } +{---------------------------------------------------------------------------} +TYPE + TCommandSet = SET OF Byte; { Command set record } + PCommandSet = ^TCommandSet; { Ptr to command set } + +{---------------------------------------------------------------------------} +{ PALETTE RECORD } +{---------------------------------------------------------------------------} +TYPE + TPalette = String; { Palette record } + PPalette = ^TPalette; { Pointer to palette } + +{---------------------------------------------------------------------------} +{ TDrawBuffer RECORD } +{---------------------------------------------------------------------------} +TYPE +{$ifdef FV_UNICODE} + TDrawBuffer = Array [0..MaxViewWidth - 1] Of TEnhancedVideoCell; { Draw buffer record } +{$else FV_UNICODE} + TDrawBuffer = Array [0..MaxViewWidth - 1] Of Word; { Draw buffer record } +{$endif FV_UNICODE} + PDrawBuffer = ^TDrawBuffer; { Ptr to draw buffer } + +{---------------------------------------------------------------------------} +{ TVideoBuffer RECORD } +{---------------------------------------------------------------------------} +TYPE +{$ifdef FV_UNICODE} + TVideoBuf = ARRAY [0..3999] of TEnhancedVideoCell; { Video buffer } +{$else FV_UNICODE} + TVideoBuf = ARRAY [0..3999] of Word; { Video buffer } +{$endif FV_UNICODE} + PVideoBuf = ^TVideoBuf; { Pointer to buffer } + +{---------------------------------------------------------------------------} +{ TComplexArea RECORD } +{---------------------------------------------------------------------------} +TYPE + PComplexArea = ^TComplexArea; { Complex area } + TComplexArea = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + X1, Y1 : Sw_Integer; { Top left corner } + X2, Y2 : Sw_Integer; { Lower right corner } + NextArea: PComplexArea; { Next area pointer } + END; + +{***************************************************************************} +{ PUBLIC OBJECT DEFINITIONS } +{***************************************************************************} + +TYPE + PGroup = ^TGroup; { Pointer to group } + +{---------------------------------------------------------------------------} +{ TView OBJECT - ANCESTOR VIEW OBJECT } +{---------------------------------------------------------------------------} + PView = ^TView; + TView = OBJECT (TObject) + GrowMode : Byte; { View grow mode } + DragMode : Byte; { View drag mode } + TabMask : Byte; { Tab move masks } + ColourOfs: Sw_Integer; { View palette offset } + HelpCtx : Word; { View help context } + State : Word; { View state masks } + Options : Word; { View options masks } + EventMask: Word; { View event masks } + Origin : TPoint; { View origin } + Size : TPoint; { View size } + Cursor : TPoint; { Cursor position } + Next : PView; { Next peerview } + Owner : PGroup; { Owner group } + HoldLimit: PComplexArea; { Hold limit values } + + RevCol : Boolean; + BackgroundChar : Char; + + CONSTRUCTOR Init (Var Bounds: TRect); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION Prev: PView; + FUNCTION Execute: Word; Virtual; + FUNCTION Focus: Boolean; + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION TopView: PView; + FUNCTION PrevView: PView; + FUNCTION NextView: PView; + FUNCTION GetHelpCtx: Word; Virtual; + FUNCTION EventAvail: Boolean; + FUNCTION GetPalette: PPalette; Virtual; + function MapColor (color:byte):byte; + FUNCTION GetColor (Color: Word): Word; + FUNCTION Valid (Command: Word): Boolean; Virtual; + FUNCTION GetState (AState: Word): Boolean; + FUNCTION TextWidth (const Txt: Sw_String): Sw_Integer; + FUNCTION CTextWidth (const Txt: Sw_String): Sw_Integer; + FUNCTION MouseInView (Point: TPoint): Boolean; + FUNCTION CommandEnabled (Command: Word): Boolean; + FUNCTION OverLapsArea (X1, Y1, X2, Y2: Sw_Integer): Boolean; + FUNCTION MouseEvent (Var Event: TEvent; Mask: Word): Boolean; + PROCEDURE Hide; + PROCEDURE Show; + PROCEDURE Draw; Virtual; + PROCEDURE ResetCursor; Virtual; + PROCEDURE Select; + PROCEDURE Awaken; Virtual; + PROCEDURE DrawView; + PROCEDURE MakeFirst; + PROCEDURE DrawCursor; Virtual; + PROCEDURE HideCursor; + PROCEDURE ShowCursor; + PROCEDURE BlockCursor; + PROCEDURE NormalCursor; + PROCEDURE FocusFromTop; Virtual; + PROCEDURE MoveTo (X, Y: Sw_Integer); + PROCEDURE GrowTo (X, Y: Sw_Integer); + PROCEDURE EndModal (Command: Word); Virtual; + PROCEDURE SetCursor (X, Y: Sw_Integer); + PROCEDURE PutInFrontOf (Target: PView); + PROCEDURE SetCommands (Commands: TCommandSet); + PROCEDURE EnableCommands (Commands: TCommandSet); + PROCEDURE DisableCommands (Commands: TCommandSet); + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE SetCmdState (Commands: TCommandSet; Enable: Boolean); + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE Locate (Var Bounds: TRect); + PROCEDURE KeyEvent (Var Event: TEvent); + PROCEDURE GetEvent (Var Event: TEvent); Virtual; + PROCEDURE PutEvent (Var Event: TEvent); Virtual; + PROCEDURE GetExtent (Var Extent: TRect); + PROCEDURE GetBounds (Var Bounds: TRect); + PROCEDURE SetBounds (Var Bounds: TRect); + PROCEDURE GetClipRect (Var Clip: TRect); + PROCEDURE ClearEvent (Var Event: TEvent); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; + PROCEDURE SizeLimits (Var Min, Max: TPoint); Virtual; + PROCEDURE GetCommands (Var Commands: TCommandSet); + PROCEDURE GetPeerViewPtr (Var S: TStream; Var P); + PROCEDURE PutPeerViewPtr (Var S: TStream; P: PView); + PROCEDURE CalcBounds (Var Bounds: TRect; Delta: TPoint); Virtual; + + FUNCTION Exposed: Boolean; { This needs help!!!!! } + PROCEDURE WriteBuf (X, Y, W, H: Sw_Integer; Var Buf); + PROCEDURE WriteLine (X, Y, W, H: Sw_Integer; Var Buf); + PROCEDURE MakeLocal (Source: TPoint; Var Dest: TPoint); + PROCEDURE MakeGlobal (Source: TPoint; Var Dest: TPoint); + PROCEDURE WriteStr (X, Y: Sw_Integer; Str: Sw_String; Color: Byte); +{$ifdef FV_UNICODE} + PROCEDURE WriteChar (X, Y: Sw_Integer; C: UnicodeString; Color: Byte; + Count: Sw_Integer); +{$else FV_UNICODE} + PROCEDURE WriteChar (X, Y: Sw_Integer; C: Char; Color: Byte; + Count: Sw_Integer); +{$endif FV_UNICODE} + PROCEDURE DragView (Event: TEvent; Mode: Byte; Var Limits: TRect; + MinSize, MaxSize: TPoint); + private + procedure CursorChanged; + procedure DrawHide(LastView: PView); + procedure DrawShow(LastView: PView); + procedure DrawUnderRect(var R: TRect; LastView: PView); + procedure DrawUnderView(DoShadow: Boolean; LastView: PView); + procedure do_WriteView(x1,x2,y:Sw_Integer; var Buf); + procedure do_WriteViewRec1(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); + procedure do_WriteViewRec2(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); + function do_ExposedRec1(x1,x2:Sw_integer; p:PView):boolean; + function do_ExposedRec2(x1,x2:Sw_integer; p:PView):boolean; + END; + + SelectMode = (NormalSelect, EnterSelect, LeaveSelect); + +{---------------------------------------------------------------------------} +{ TGroup OBJECT - GROUP OBJECT ANCESTOR } +{---------------------------------------------------------------------------} +{$ifndef TYPED_LOCAL_CALLBACKS} + TGroupFirstThatCallback = CodePointer; +{$else} + TGroupFirstThatCallback = Function(View: PView): Boolean is nested; +{$endif} + + TGroup = OBJECT (TView) + Phase : (phFocused, phPreProcess, phPostProcess); + EndState: Word; { Modal result } + Current : PView; { Selected subview } + Last : PView; { 1st view inserted } + Buffer : PVideoBuf; { Speed up buffer } + CONSTRUCTOR Init (Var Bounds: TRect); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION First: PView; + FUNCTION Execute: Word; Virtual; + FUNCTION GetHelpCtx: Word; Virtual; + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION ExecView (P: PView): Word; Virtual; + FUNCTION FirstThat (P: TGroupFirstThatCallback): PView; + FUNCTION Valid (Command: Word): Boolean; Virtual; + FUNCTION FocusNext (Forwards: Boolean): Boolean; + PROCEDURE Draw; Virtual; + PROCEDURE Lock; + PROCEDURE UnLock; + PROCEDURE ResetCursor; Virtual; + PROCEDURE Awaken; Virtual; + PROCEDURE ReDraw; + PROCEDURE SelectDefaultView; + PROCEDURE Insert (P: PView); + PROCEDURE Delete (P: PView); + PROCEDURE ForEach (P: TCallbackProcParam); + { ForEach can't be virtual because it generates SIGSEGV } + PROCEDURE EndModal (Command: Word); Virtual; + PROCEDURE SelectNext (Forwards: Boolean); + PROCEDURE InsertBefore (P, Target: PView); + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE EventError (Var Event: TEvent); Virtual; + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; + PROCEDURE GetSubViewPtr (Var S: TStream; Var P); + PROCEDURE PutSubViewPtr (Var S: TStream; P: PView); + function ClipChilds: boolean; virtual; + procedure BeforeInsert(P: PView); virtual; + procedure AfterInsert(P: PView); virtual; + procedure BeforeDelete(P: PView); virtual; + procedure AfterDelete(P: PView); virtual; + + PRIVATE + LockFlag: Byte; + Clip : TRect; + FUNCTION IndexOf (P: PView): Sw_Integer; + FUNCTION FindNext (Forwards: Boolean): PView; + FUNCTION FirstMatch (AState: Word; AOptions: Word): PView; + PROCEDURE ResetCurrent; + PROCEDURE RemoveView (P: PView); + PROCEDURE InsertView (P, Target: PView); + PROCEDURE SetCurrent (P: PView; Mode: SelectMode); + procedure DrawSubViews(P, Bottom: PView); + END; + +{---------------------------------------------------------------------------} +{ TFrame OBJECT - FRAME VIEW OBJECT } +{---------------------------------------------------------------------------} +TYPE + TFrame = OBJECT (TView) + CONSTRUCTOR Init (Var Bounds: TRect); + FUNCTION GetPalette: PPalette; Virtual; + procedure Draw; virtual; + procedure HandleEvent(var Event: TEvent); virtual; + procedure SetState(AState: Word; Enable: Boolean); virtual; + private + FrameMode: Word; + procedure FrameLine(var FrameBuf; Y, N: Sw_Integer; Color: Byte); + END; + PFrame = ^TFrame; + +{---------------------------------------------------------------------------} +{ TScrollBar OBJECT - SCROLL BAR OBJECT } +{---------------------------------------------------------------------------} +TYPE +{$ifdef FV_UNICODE} + TScrollChars = Array [0..4] of WideChar; +{$else FV_UNICODE} + TScrollChars = Array [0..4] of Char; +{$endif FV_UNICODE} + + TScrollBar = OBJECT (TView) + Value : Sw_Integer; { Scrollbar value } + Min : Sw_Integer; { Scrollbar minimum } + Max : Sw_Integer; { Scrollbar maximum } + PgStep: Sw_Integer; { One page step } + ArStep: Sw_Integer; { One range step } + Id : Sw_Integer; { Scrollbar ID } + CONSTRUCTOR Init (Var Bounds: TRect); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION ScrollStep (Part: Sw_Integer): Sw_Integer; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE ScrollDraw; Virtual; + PROCEDURE SetValue (AValue: Sw_Integer); + PROCEDURE SetRange (AMin, AMax: Sw_Integer); + PROCEDURE SetStep (APgStep, AArStep: Sw_Integer); + PROCEDURE SetParams (AValue, AMin, AMax, APgStep, AArStep: Sw_Integer); + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PRIVATE + Chars: TScrollChars; { Scrollbar chars } + FUNCTION GetPos: Sw_Integer; + FUNCTION GetSize: Sw_Integer; + PROCEDURE DrawPos (Pos: Sw_Integer); + END; + PScrollBar = ^TScrollBar; + +{---------------------------------------------------------------------------} +{ TScroller OBJECT - SCROLLING VIEW ANCESTOR } +{---------------------------------------------------------------------------} +TYPE + TScroller = OBJECT (TView) + Delta : TPoint; + Limit : TPoint; + HScrollBar: PScrollBar; { Horz scroll bar } + VScrollBar: PScrollBar; { Vert scroll bar } + CONSTRUCTOR Init (Var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE ScrollDraw; Virtual; + PROCEDURE SetLimit (X, Y: Sw_Integer); + PROCEDURE ScrollTo (X, Y: Sw_Integer); + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; + PRIVATE + DrawFlag: Boolean; + DrawLock: Byte; + PROCEDURE CheckDraw; + END; + PScroller = ^TScroller; + +{---------------------------------------------------------------------------} +{ TListViewer OBJECT - LIST VIEWER OBJECT } +{---------------------------------------------------------------------------} +TYPE + TListViewer = OBJECT (TView) + NumCols : Sw_Integer; { Number of columns } + TopItem : Sw_Integer; { Top most item } + Focused : Sw_Integer; { Focused item } + Range : Sw_Integer; { Range of listview } + HScrollBar: PScrollBar; { Horz scrollbar } + VScrollBar: PScrollBar; { Vert scrollbar } + CONSTRUCTOR Init (Var Bounds: TRect; ANumCols: Sw_Word; AHScrollBar, + AVScrollBar: PScrollBar); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION IsSelected (Item: Sw_Integer): Boolean; Virtual; + FUNCTION GetText (Item: Sw_Integer; MaxLen: Sw_Integer): Sw_String; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE FocusItem (Item: Sw_Integer); Virtual; + PROCEDURE SetTopItem (Item: Sw_Integer); + PROCEDURE SetRange (ARange: Sw_Integer); + PROCEDURE SelectItem (Item: Sw_Integer); Virtual; + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; + PROCEDURE FocusItemNum (Item: Sw_Integer); Virtual; + END; + PListViewer = ^TListViewer; + +{---------------------------------------------------------------------------} +{ TWindow OBJECT - WINDOW OBJECT ANCESTOR } +{---------------------------------------------------------------------------} +TYPE + TWindow = OBJECT (TGroup) + Flags : Byte; { Window flags } + Number : Sw_Integer; { Window number } + Palette : Sw_Integer; { Window palette } + ZoomRect: TRect; { Zoom rectangle } + Frame : PFrame; { Frame view object } +{$ifdef FV_UNICODE} + Title : UnicodeString; { Title string } +{$else FV_UNICODE} + Title : PString; { Title string } +{$endif FV_UNICODE} + CONSTRUCTOR Init (Var Bounds: TRect; ATitle: TTitleStr; ANumber: Sw_Integer); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION GetTitle (MaxSize: Sw_Integer): TTitleStr; Virtual; + FUNCTION StandardScrollBar (AOptions: Word): PScrollBar; + PROCEDURE Zoom; Virtual; + PROCEDURE Close; Virtual; + PROCEDURE InitFrame; Virtual; + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE SizeLimits (Var Min, Max: TPoint); Virtual; + END; + PWindow = ^TWindow; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ WINDOW MESSAGE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-Message------------------------------------------------------------ +Message sets up an event record and calls Receiver^.HandleEvent to +handle the event. Message returns nil if Receiver is nil, or if +the event is not handled successfully. +12Sep97 LdB +---------------------------------------------------------------------} +FUNCTION Message (Receiver: PView; What, Command: Word; + InfoPtr: Pointer): Pointer; + +{-NewMessage--------------------------------------------------------- +NewMessage sets up an event record including the new fields and calls +Receiver^.HandleEvent to handle the event. Message returns nil if +Receiver is nil, or if the event is not handled successfully. +19Sep97 LdB +---------------------------------------------------------------------} +FUNCTION NewMessage (P: PView; What, Command: Word; Id: Sw_Integer; Data: Real; + InfoPtr: Pointer): Pointer; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ VIEW OBJECT REGISTRATION ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{-RegisterViews------------------------------------------------------ +This registers all the view type objects used in this unit. +11Aug99 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterViews; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ NEW VIEW ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-CreateIdScrollBar-------------------------------------------------- +Creates and scrollbar object of the given size and direction and sets +the scrollbar id number. +22Sep97 LdB +---------------------------------------------------------------------} +FUNCTION CreateIdScrollBar (X, Y, Size, Id: Sw_Integer; Horz: Boolean): PScrollBar; + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + + +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +CONST + UseNativeClasses: Boolean = True; { Native class modes } + CommandSetChanged: Boolean = False; { Command change flag } + ShowMarkers: Boolean = False; { Show marker state } + ErrorAttr: Byte = $CF; { Error colours } + PositionalEvents: Word = evMouse; { Positional defined } + FocusedEvents: Word = evKeyboard + evCommand; { Focus defined } + MinWinSize: TPoint = (X: 16; Y: 6); { Minimum window size } + ShadowSize: TPoint = (X: 2; Y: 1); { Shadow sizes } + ShadowAttr: Byte = $08; { Shadow attribute } + +{ Characters used for drawing selected and default items in } +{ monochrome color sets } +{$ifdef FV_UNICODE} + SpecialChars: Array [0..5] Of WideChar = (#$00BB, #$00AB, #$2192, #$2190, ' ', ' '); +{$else FV_UNICODE} + SpecialChars: Array [0..5] Of Char = (#175, #174, #26, #27, ' ', ' '); +{$endif FV_UNICODE} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STREAM REGISTRATION RECORDS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ TView STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RView: TStreamRec = ( + ObjType: idView; { Register id = 1 } + VmtLink: TypeOf(TView); { Alt style VMT link } + Load: @TView.Load; { Object load method } + Store: @TView.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TFrame STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RFrame: TStreamRec = ( + ObjType: idFrame; { Register id = 2 } + VmtLink: TypeOf(TFrame); { Alt style VMT link } + Load: @TFrame.Load; { Frame load method } + Store: @TFrame.Store { Frame store method } + ); + +{---------------------------------------------------------------------------} +{ TScrollBar STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RScrollBar: TStreamRec = ( + ObjType: idScrollBar; { Register id = 3 } + VmtLink: TypeOf(TScrollBar); { Alt style VMT link } + Load: @TScrollBar.Load; { Object load method } + Store: @TScrollBar.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TScroller STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RScroller: TStreamRec = ( + ObjType: idScroller; { Register id = 4 } + VmtLink: TypeOf(TScroller); { Alt style VMT link } + Load: @TScroller.Load; { Object load method } + Store: @TScroller.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TListViewer STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RListViewer: TStreamRec = ( + ObjType: idListViewer; { Register id = 5 } + VmtLink: TypeOf(TListViewer); { Alt style VMT link } + Load: @TListViewer.Load; { Object load method } + Store: @TLIstViewer.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TGroup STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RGroup: TStreamRec = ( + ObjType: idGroup; { Register id = 6 } + VmtLink: TypeOf(TGroup); { Alt style VMT link } + Load: @TGroup.Load; { Object load method } + Store: @TGroup.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TWindow STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RWindow: TStreamRec = ( + ObjType: idWindow; { Register id = 7 } + VmtLink: TypeOf(TWindow); { Alt style VMT link } + Load: @TWindow.Load; { Object load method } + Store: @TWindow.Store { Object store method } + ); + + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{***************************************************************************} +{ PRIVATE TYPE DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TFixupList DEFINITION } +{---------------------------------------------------------------------------} +TYPE + TFixupList = ARRAY [1..4096] Of Pointer; { Fix up ptr array } + PFixupList = ^TFixupList; { Ptr to fix up list } + +{***************************************************************************} +{ PRIVATE INITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/NT/OS2 PRIVATE VARIABLES } +{---------------------------------------------------------------------------} +CONST + TheTopView : PView = Nil; { Top focused view } + LimitsLocked: PView = Nil; { View locking limits } + OwnerGroup : PGroup = Nil; { Used for loading } + FixupList : PFixupList = Nil; { Used for loading } + CurCommandSet: TCommandSet = ([0..255] - + [cmZoom, cmClose, cmResize, cmNext, cmPrev]); { All active but these } + + vdInSetCursor = $80; { AVOID RECURSION IN SetCursor } + + { Flags for TFrame } + fmCloseClicked = $01; + fmZoomClicked = $02; + + +type + TstatVar2 = record + target : PView; + offset,y : SmallInt; + end; + +var + staticVar1 : PDrawBuffer; + staticVar2 : TstatVar2; + + +{***************************************************************************} +{ PRIVATE INTERNAL ROUTINES } +{***************************************************************************} + +{$ifdef UNIX} +const + MouseUsesVideoBuf = true; +{$else not UNIX} +const + MouseUsesVideoBuf = false; +{$endif not UNIX} + +procedure DrawScreenBuf(force:boolean); +begin + if (GetLockScreenCount=0) then + begin +{ If MouseUsesVideoBuf then + begin + LockScreenUpdate; + HideMouse; + ShowMouse; + UnlockScreenUpdate; + end + else + HideMouse;} + UpdateScreen(force); +{ If not MouseUsesVideoBuf then + ShowMouse;} + end; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ VIEW PORT CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +TYPE + ViewPortType = RECORD + X1, Y1, X2, Y2: SmallInt; { Corners of viewport } + Clip : Boolean; { Clip status } + END; + +var + ViewPort : ViewPortType; + +{---------------------------------------------------------------------------} +{ GetViewSettings -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB } +{---------------------------------------------------------------------------} +PROCEDURE GetViewSettings (Var CurrentViewPort: ViewPortType); +BEGIN + CurrentViewPort := ViewPort; { Textmode viewport } +END; + +{---------------------------------------------------------------------------} +{ SetViewPort -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB } +{---------------------------------------------------------------------------} +PROCEDURE SetViewPort (X1, Y1, X2, Y2: SmallInt; Clip: Boolean); +BEGIN + If (X1 < 0) Then X1 := 0; { X1 negative fix } + If (X1 >ScreenWidth) Then + X1 := ScreenWidth; { X1 off screen fix } + If (Y1 < 0) Then Y1 := 0; { Y1 negative fix } + If (Y1 > ScreenHeight) Then + Y1 := ScreenHeight; { Y1 off screen fix } + If (X2 < 0) Then X2 := 0; { X2 negative fix } + If (X2 > ScreenWidth) Then + X2 := ScreenWidth; { X2 off screen fix } + If (Y2 < 0) Then Y2 := 0; { Y2 negative fix } + If (Y2 > ScreenHeight) Then + Y2 := ScreenHeight; { Y2 off screen fix } + ViewPort.X1 := X1; { Set X1 port value } + ViewPort.Y1 := Y1; { Set Y1 port value } + ViewPort.X2 := X2; { Set X2 port value } + ViewPort.Y2 := Y2; { Set Y2 port value } + ViewPort.Clip := Clip; { Set port clip value } +{ $ifdef DEBUG + If WriteDebugInfo then + Writeln(stderr,'New ViewPort(',X1,',',Y1,',',X2,',',Y2,')'); + $endif DEBUG} +END; + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TView OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TView--------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20Jun96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TView.Init (Var Bounds: TRect); +BEGIN + Inherited Init; { Call ancestor } + DragMode := dmLimitLoY; { Default drag mode } + HelpCtx := hcNoContext; { Clear help context } + State := sfVisible; { Default state } + EventMask := evMouseDown + evKeyDown + evCommand; { Default event masks } + BackgroundChar := ' '; + SetBounds(Bounds); { Set view bounds } +END; + +{--TView--------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06May98 LdB } +{---------------------------------------------------------------------------} +{ This load method will read old original TV data from a stream but the } +{ new options and tabmasks are not set so some NEW functionality is not } +{ supported but it should work as per original TV code. } +{---------------------------------------------------------------------------} +CONSTRUCTOR TView.Load (Var S: TStream); +VAR i: SmallInt; +BEGIN + Inherited Init; { Call ancestor } + S.Read(i, SizeOf(i)); Origin.X:=i; { Read origin x value } + S.Read(i, SizeOf(i)); Origin.Y:=i; { Read origin y value } + S.Read(i, SizeOf(i)); Size.X:=i; { Read view x size } + S.Read(i, SizeOf(i)); Size.Y:=i; { Read view y size } + S.Read(i, SizeOf(i)); Cursor.X:=i; { Read cursor x size } + S.Read(i, SizeOf(i)); Cursor.Y:=i; { Read cursor y size } + S.Read(GrowMode, SizeOf(GrowMode)); { Read growmode flags } + S.Read(DragMode, SizeOf(DragMode)); { Read dragmode flags } + S.Read(HelpCtx, SizeOf(HelpCtx)); { Read help context } + S.Read(State, SizeOf(State)); { Read state masks } + S.Read(Options, SizeOf(Options)); { Read options masks } + S.Read(Eventmask, SizeOf(Eventmask)); { Read event masks } +END; + +{--TView--------------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Nov99 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TView.Done; +VAR P: PComplexArea; +BEGIN + Hide; { Hide the view } + If (Owner <> Nil) Then Owner^.Delete(@Self); { Delete from owner } + While (HoldLimit <> Nil) Do Begin { Free limit memory } + P := HoldLimit^.NextArea; { Hold next pointer } + FreeMem(HoldLimit, SizeOf(TComplexArea)); { Release memory } + HoldLimit := P; { Shuffle to next } + End; +END; + +{--TView--------------------------------------------------------------------} +{ Prev -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.Prev: PView; +VAR NP : PView; +BEGIN + Prev := @Self; + NP := Next; + While (NP <> Nil) AND (NP <> @Self) Do + Begin + Prev := NP; { Locate next view } + NP := NP^.Next; + End; +END; + +{--TView--------------------------------------------------------------------} +{ Execute -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.Execute: Word; +BEGIN + Execute := cmCancel; { Return cancel } +END; + +{--TView--------------------------------------------------------------------} +{ Focus -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.Focus: Boolean; +VAR Res: Boolean; +BEGIN + Res := True; { Preset result } + If (State AND (sfSelected + sfModal)=0) Then Begin { Not modal/selected } + If (Owner <> Nil) Then Begin { View has an owner } + Res := Owner^.Focus; { Return focus state } + If Res Then { Owner has focus } + If ((Owner^.Current = Nil) OR { No current view } + (Owner^.Current^.Options AND ofValidate = 0) { Non validating view } + OR (Owner^.Current^.Valid(cmReleasedFocus))) { Okay to drop focus } + Then Select Else Res := False; { Then select us } + End; + End; + Focus := Res; { Return focus result } +END; + +{--TView--------------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.DataSize: Sw_Word; +BEGIN + DataSize := 0; { Transfer size } +END; + +{--TView--------------------------------------------------------------------} +{ TopView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.TopView: PView; +VAR P: PView; +BEGIN + If (TheTopView = Nil) Then Begin { Check topmost view } + P := @Self; { Start with us } + While (P <> Nil) AND (P^.State AND sfModal = 0) { Check if modal } + Do P := P^.Owner; { Search each owner } + TopView := P; { Return result } + End Else TopView := TheTopView; { Return topview } +END; + +{--TView--------------------------------------------------------------------} +{ PrevView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.PrevView: PView; +BEGIN + If (@Self = Owner^.First) Then PrevView := Nil { We are first view } + Else PrevView := Prev; { Return our prior } +END; + +{--TView--------------------------------------------------------------------} +{ NextView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.NextView: PView; +BEGIN + If (@Self = Owner^.Last) Then NextView := Nil { This is last view } + Else NextView := Next; { Return our next } +END; + +{--TView--------------------------------------------------------------------} +{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.GetHelpCtx: Word; +BEGIN + If (State AND sfDragging <> 0) Then { Dragging state check } + GetHelpCtx := hcDragging Else { Return dragging } + GetHelpCtx := HelpCtx; { Return help context } +END; + +{--TView--------------------------------------------------------------------} +{ EventAvail -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.EventAvail: Boolean; +VAR Event: TEvent; +BEGIN + GetEvent(Event); { Get next event } + If (Event.What <> evNothing) Then PutEvent(Event); { Put it back } + EventAvail := (Event.What <> evNothing); { Return result } +END; + +{--TView--------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.GetPalette: PPalette; +BEGIN + GetPalette := Nil; { Return nil ptr } +END; + +{--TView--------------------------------------------------------------------} +{ MapColor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } +{---------------------------------------------------------------------------} +function TView.MapColor(color:byte):byte; +var + cur : PView; + p : PPalette; +begin + if color=0 then + MapColor:=errorAttr + else + begin + cur:=@Self; + repeat + p:=cur^.GetPalette; + if (p<>Nil) then + if ord(p^[0])<>0 then + begin + if color>ord(p^[0]) then + begin + MapColor:=errorAttr; + Exit; + end; + color:=ord(p^[color]); + if color=0 then + begin + MapColor:=errorAttr; + Exit; + end; + end; + cur:=cur^.Owner; + until (cur=Nil); + MapColor:=color; + end; +end; + + +{--TView--------------------------------------------------------------------} +{ GetColor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.GetColor (Color: Word): Word; +VAR Col: Byte; W: Word; P: PPalette; Q: PView; +BEGIN + W := 0; { Clear colour Sw_Word } + If (Hi(Color) > 0) Then Begin { High colour req } + Col := Hi(Color) + ColourOfs; { Initial offset } + Q := @Self; { Pointer to self } + Repeat + P := Q^.GetPalette; { Get our palette } + If (P <> Nil) Then Begin { Palette is valid } + If (Col <= Length(P^)) Then + Col := Ord(P^[Col]) Else { Return colour } + Col := ErrorAttr; { Error attribute } + End; + Q := Q^.Owner; { Move up to owner } + Until (Q = Nil); { Until no owner } + W := Col SHL 8; { Translate colour } + End; + If (Lo(Color) > 0) Then Begin + Col := Lo(Color) + ColourOfs; { Initial offset } + Q := @Self; { Pointer to self } + Repeat + P := Q^.GetPalette; { Get our palette } + If (P <> Nil) Then Begin { Palette is valid } + If (Col <= Length(P^)) Then + Col := Ord(P^[Col]) Else { Return colour } + Col := ErrorAttr; { Error attribute } + End; + Q := Q^.Owner; { Move up to owner } + Until (Q = Nil); { Until no owner } + End Else Col := ErrorAttr; { No colour found } + GetColor := W OR Col; { Return color } +END; + +{--TView--------------------------------------------------------------------} +{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.Valid (Command: Word): Boolean; +BEGIN + Valid := True; { Simply return true } +END; + +{--TView--------------------------------------------------------------------} +{ GetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.GetState (AState: Word): Boolean; +BEGIN + GetState := State AND AState = AState; { Check states equal } +END; + +{--TView--------------------------------------------------------------------} +{ TextWidth -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Nov99 LdB } +{---------------------------------------------------------------------------} + +FUNCTION TView.TextWidth (const Txt: Sw_String): Sw_Integer; +BEGIN + TextWidth := StrWidth(Txt); +END; + +FUNCTION TView.CTextWidth (const Txt: Sw_String): Sw_Integer; +VAR I: Sw_Integer; S: UnicodeString; +BEGIN + CTextWidth := CStrLen(Txt); +END; + +{--TView--------------------------------------------------------------------} +{ MouseInView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.MouseInView (Point: TPoint): Boolean; +BEGIN + MakeLocal(Point,Point); + MouseInView := (Point.X >= 0) and + (Point.Y >= 0) and + (Point.X < Size.X) and + (Point.Y < Size.Y); +END; + +{--TView--------------------------------------------------------------------} +{ CommandEnabled -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.CommandEnabled(Command: Word): Boolean; +BEGIN + CommandEnabled := (Command > 255) OR + (Command IN CurCommandSet); { Check command } +END; + +{--TView--------------------------------------------------------------------} +{ OverLapsArea -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.OverlapsArea (X1, Y1, X2, Y2: Sw_Integer): Boolean; +BEGIN + OverLapsArea := False; { Preset false } + If (Origin.X > X2) Then Exit; { Area to the left } + If ((Origin.X + Size.X) < X1) Then Exit; { Area to the right } + If (Origin.Y > Y2) Then Exit; { Area is above } + If ((Origin.Y + Size.Y) < Y1) Then Exit; { Area is below } + OverLapsArea := True; { Return true } +END; + +{--TView--------------------------------------------------------------------} +{ MouseEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.MouseEvent (Var Event: TEvent; Mask: Word): Boolean; +BEGIN + Repeat + GetEvent(Event); { Get next event } + Until (Event.What AND (Mask OR evMouseUp) <> 0); { Wait till valid } + MouseEvent := Event.What <> evMouseUp; { Return result } +END; + +{--TView--------------------------------------------------------------------} +{ Hide -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Hide; +BEGIN + If (State AND sfVisible <> 0) Then { View is visible } + SetState(sfVisible, False); { Hide the view } +END; + +{--TView--------------------------------------------------------------------} +{ Show -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Show; +BEGIN + If (State AND sfVisible = 0) Then { View not visible } + SetState(sfVisible, True); { Show the view } +END; + +{--TView--------------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Draw; +VAR B : TDrawBuffer; +BEGIN + MoveChar(B, ' ', GetColor(1), Size.X); + WriteLine(0, 0, Size.X, Size.Y, B); +END; + + +procedure TView.ResetCursor; +const + sfV_CV_F:word = sfVisible + sfCursorVis + sfFocused; +var + p,p2 : PView; + G : PGroup; + cur : TPoint; + + function Check0:boolean; + var + res : byte; + begin + res:=0; + while res=0 do + begin + p:=p^.next; + if p=p2 then + begin + p:=P^.owner; + res:=1 + end + else + if ((p^.state and sfVisible)<>0) and + (cur.x>=p^.origin.x) and + (cur.x<p^.size.x+p^.origin.x) and + (cur.y>=p^.origin.y) and + (cur.y<p^.size.y+p^.origin.y) then + res:=2; + end; + Check0:=res=2; + end; + +begin + if ((state and sfV_CV_F) = sfV_CV_F) then + begin + p:=@Self; + cur:=cursor; + while true do + begin + if (cur.x<0) or (cur.x>=p^.size.x) or + (cur.y<0) or (cur.y>=p^.size.y) then + break; + inc(cur.X,p^.origin.X); + inc(cur.Y,p^.origin.Y); + p2:=p; + G:=p^.owner; + if G=Nil then { top view } + begin + Video.SetCursorPos(cur.x,cur.y); + if (state and sfCursorIns)<>0 then + Video.SetCursorType(crBlock) + else + Video.SetCursorType(crUnderline); + exit; + end; + if (G^.state and sfVisible)=0 then + break; + p:=G^.Last; + if Check0 then + break; + end; { while } + end; { if } + Video.SetCursorType(crHidden); +end; + + +{--TView--------------------------------------------------------------------} +{ Select -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Select; +BEGIN + If (Options AND ofSelectable <> 0) Then { View is selectable } + If (Options AND ofTopSelect <> 0) Then MakeFirst { Top selectable } + Else If (Owner <> Nil) Then { Valid owner } + Owner^.SetCurrent(@Self, NormalSelect); { Make owners current } +END; + +{--TView--------------------------------------------------------------------} +{ Awaken -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Awaken; +BEGIN { Abstract method } +END; + + +{--TView--------------------------------------------------------------------} +{ MakeFirst -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.MakeFirst; +BEGIN + If (Owner <> Nil) Then Begin { Must have owner } + PutInFrontOf(Owner^.First); { Float to the top } + End; +END; + +{--TView--------------------------------------------------------------------} +{ DrawCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.DrawCursor; +BEGIN { Abstract method } + if State and sfFocused <> 0 then + ResetCursor; +END; + + +procedure TView.DrawHide(LastView: PView); +begin + TView.DrawCursor; + DrawUnderView(State and sfShadow <> 0, LastView); +end; + + +procedure TView.DrawShow(LastView: PView); +begin + DrawView; + if State and sfShadow <> 0 then + DrawUnderView(True, LastView); +end; + + +procedure TView.DrawUnderRect(var R: TRect; LastView: PView); +begin + Owner^.Clip.Intersect(R); + Owner^.DrawSubViews(NextView, LastView); + Owner^.GetExtent(Owner^.Clip); +end; + + +procedure TView.DrawUnderView(DoShadow: Boolean; LastView: PView); +var + R: TRect; +begin + GetBounds(R); + if DoShadow then + begin + inc(R.B.X,ShadowSize.X); + inc(R.B.Y,ShadowSize.Y); + end; + DrawUnderRect(R, LastView); +end; + + +procedure TView.DrawView; +begin + if Exposed then + begin + LockScreenUpdate; { don't update the screen yet } + Draw; + UnLockScreenUpdate; + DrawScreenBuf(false); + TView.DrawCursor; + end; +end; + + +{--TView--------------------------------------------------------------------} +{ HideCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.HideCursor; +BEGIN + SetState(sfCursorVis , False); { Hide the cursor } +END; + +{--TView--------------------------------------------------------------------} +{ ShowCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.ShowCursor; +BEGIN + SetState(sfCursorVis , True); { Show the cursor } +END; + +{--TView--------------------------------------------------------------------} +{ BlockCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.BlockCursor; +BEGIN + SetState(sfCursorIns, True); { Set insert mode } +END; + +{--TView--------------------------------------------------------------------} +{ NormalCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.NormalCursor; +BEGIN + SetState(sfCursorIns, False); { Clear insert mode } +END; + +{--TView--------------------------------------------------------------------} +{ FocusFromTop -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11Aug99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.FocusFromTop; +BEGIN + If (Owner <> Nil) AND + (Owner^.State AND sfSelected = 0) + Then Owner^.Select; + If (State AND sfFocused = 0) Then Focus; + If (State AND sfSelected = 0) Then Select; +END; + +{--TView--------------------------------------------------------------------} +{ MoveTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.MoveTo (X, Y: Sw_Integer); +VAR R: TRect; +BEGIN + R.Assign(X, Y, X + Size.X, Y + Size.Y); { Assign area } + Locate(R); { Locate the view } +END; + +{--TView--------------------------------------------------------------------} +{ GrowTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GrowTo (X, Y: Sw_Integer); +VAR R: TRect; +BEGIN + R.Assign(Origin.X, Origin.Y, Origin.X + X, + Origin.Y + Y); { Assign area } + Locate(R); { Locate the view } +END; + +{--TView--------------------------------------------------------------------} +{ EndModal -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.EndModal (Command: Word); +VAR P: PView; +BEGIN + P := TopView; { Get top view } + If (P <> Nil) Then P^.EndModal(Command); { End modal operation } +END; + +{--TView--------------------------------------------------------------------} +{ SetCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SetCursor (X, Y: Sw_Integer); +BEGIN + if (Cursor.X<>X) or (Cursor.Y<>Y) then + begin + Cursor.X := X; + Cursor.Y := Y; + CursorChanged; + end; + TView.DrawCursor; +END; + + +procedure TView.CursorChanged; +begin + Message(Owner,evBroadcast,cmCursorChanged,@Self); +end; + + +{--TView--------------------------------------------------------------------} +{ PutInFrontOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.PutInFrontOf (Target: PView); +VAR P, LastView: PView; +BEGIN + If (Owner <> Nil) AND (Target <> @Self) AND + (Target <> NextView) AND ((Target = Nil) OR + (Target^.Owner = Owner)) Then { Check validity } + If (State AND sfVisible = 0) Then Begin { View not visible } + Owner^.RemoveView(@Self); { Remove from list } + Owner^.InsertView(@Self, Target); { Insert into list } + End Else Begin + LastView := NextView; { Hold next view } + If (LastView <> Nil) Then Begin { Lastview is valid } + P := Target; { P is target } + While (P <> Nil) AND (P <> LastView) + Do P := P^.NextView; { Find our next view } + If (P = Nil) Then LastView := Target; { Lastview is target } + End; + State := State AND NOT sfVisible; { Temp stop drawing } + If (LastView = Target) Then + DrawHide(LastView); + Owner^.Lock; + Owner^.RemoveView(@Self); { Remove from list } + Owner^.InsertView(@Self, Target); { Insert into list } + State := State OR sfVisible; { Allow drawing again } + If (LastView <> Target) Then + DrawShow(LastView); + If (Options AND ofSelectable <> 0) Then { View is selectable } + begin + Owner^.ResetCurrent; { Reset current } + Owner^.ResetCursor; + end; + Owner^.Unlock; + End; +END; + +{--TView--------------------------------------------------------------------} +{ SetCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SetCommands (Commands: TCommandSet); +BEGIN + CommandSetChanged := CommandSetChanged OR + (CurCommandSet <> Commands); { Set change flag } + CurCommandSet := Commands; { Set command set } +END; + +{--TView--------------------------------------------------------------------} +{ EnableCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.EnableCommands (Commands: TCommandSet); +BEGIN + CommandSetChanged := CommandSetChanged OR + (CurCommandSet * Commands <> Commands); { Set changed flag } + CurCommandSet := CurCommandSet + Commands; { Update command set } +END; + +{--TView--------------------------------------------------------------------} +{ DisableCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.DisableCommands (Commands: TCommandSet); +BEGIN + CommandSetChanged := CommandSetChanged OR + (CurCommandSet * Commands <> []); { Set changed flag } + CurCommandSet := CurCommandSet - Commands; { Update command set } +END; + +{--TView--------------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SetState (AState: Word; Enable: Boolean); +var + Command: Word; + OState : Word; +begin + OState:=State; + if Enable then + State := State or AState + else + State := State and not AState; + if Owner <> nil then + case AState of + sfVisible: + begin + if Owner^.State and sfExposed <> 0 then + SetState(sfExposed, Enable); + if Enable then + DrawShow(nil) + else + DrawHide(nil); + if Options and ofSelectable <> 0 then + Owner^.ResetCurrent; + end; + sfCursorVis, + sfCursorIns: + TView.DrawCursor; + sfShadow: + DrawUnderView(True, nil); + sfFocused: + begin + ResetCursor; + if Enable then + Command := cmReceivedFocus + else + Command := cmReleasedFocus; + Message(Owner, evBroadcast, Command, @Self); + end; + end; + if ((OState xor State) and (sfCursorVis+sfCursorIns+sfFocused))<>0 then + CursorChanged; +end; + + +{--TView--------------------------------------------------------------------} +{ SetCmdState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SetCmdState (Commands: TCommandSet; Enable: Boolean); +BEGIN + If Enable Then EnableCommands(Commands) { Enable commands } + Else DisableCommands(Commands); { Disable commands } +END; + +{--TView--------------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetData (Var Rec); +BEGIN { Abstract method } +END; + +{--TView--------------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SetData (Var Rec); +BEGIN { Abstract method } +END; + +{--TView--------------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Store (Var S: TStream); +VAR SaveState: Word; + i: SmallInt; +BEGIN + SaveState := State; { Hold current state } + State := State AND NOT (sfActive OR sfSelected OR + sfFocused OR sfExposed); { Clear flags } + i:=Origin.X;S.Write(i, SizeOf(i)); { Write view x origin } + i:=Origin.Y;S.Write(i, SizeOf(i)); { Write view y origin } + i:=Size.X;S.Write(i, SizeOf(i)); { Write view x size } + i:=Size.Y;S.Write(i, SizeOf(i)); { Write view y size } + i:=Cursor.X;S.Write(i, SizeOf(i)); { Write cursor x size } + i:=Cursor.Y;S.Write(i, SizeOf(i)); { Write cursor y size } + S.Write(GrowMode, SizeOf(GrowMode)); { Write growmode flags } + S.Write(DragMode, SizeOf(DragMode)); { Write dragmode flags } + S.Write(HelpCtx, SizeOf(HelpCtx)); { Write help context } + S.Write(State, SizeOf(State)); { Write state masks } + S.Write(Options, SizeOf(Options)); { Write options masks } + S.Write(Eventmask, SizeOf(Eventmask)); { Write event masks } + State := SaveState; { Reset state masks } +END; + +{--TView--------------------------------------------------------------------} +{ Locate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Locate (Var Bounds: TRect); +VAR + Min, Max: TPoint; R: TRect; + + FUNCTION Range(Val, Min, Max: Sw_Integer): Sw_Integer; + BEGIN + If (Val < Min) Then Range := Min Else { Value to small } + If (Val > Max) Then Range := Max Else { Value to large } + Range := Val; { Value is okay } + END; + +BEGIN + SizeLimits(Min, Max); { Get size limits } + Bounds.B.X := Bounds.A.X + Range(Bounds.B.X - + Bounds.A.X, Min.X, Max.X); { X bound limit } + Bounds.B.Y := Bounds.A.Y + Range(Bounds.B.Y + - Bounds.A.Y, Min.Y, Max.Y); { Y bound limit } + GetBounds(R); { Current bounds } + If NOT Bounds.Equals(R) Then Begin { Size has changed } + ChangeBounds(Bounds); { Change bounds } + If (State AND sfVisible <> 0) AND { View is visible } + (State AND sfExposed <> 0) AND (Owner <> Nil) { Check view exposed } + Then + begin + if State and sfShadow <> 0 then + begin + R.Union(Bounds); + Inc(R.B.X, ShadowSize.X); + Inc(R.B.Y, ShadowSize.Y); + end; + DrawUnderRect(R, nil); + end; + End; +END; + +{--TView--------------------------------------------------------------------} +{ KeyEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.KeyEvent (Var Event: TEvent); +BEGIN + Repeat + GetEvent(Event); { Get next event } + Until (Event.What = evKeyDown); { Wait till keydown } +END; + +{--TView--------------------------------------------------------------------} +{ GetEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetEvent (Var Event: TEvent); +BEGIN + If (Owner <> Nil) Then Owner^.GetEvent(Event); { Event from owner } +END; + +{--TView--------------------------------------------------------------------} +{ PutEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.PutEvent (Var Event: TEvent); +BEGIN + If (Owner <> Nil) Then Owner^.PutEvent(Event); { Put in owner } +END; + +{--TView--------------------------------------------------------------------} +{ GetExtent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetExtent (Var Extent: TRect); +BEGIN + Extent.A.X := 0; { Zero x field } + Extent.A.Y := 0; { Zero y field } + Extent.B.X := Size.X; { Return x size } + Extent.B.Y := Size.Y; { Return y size } +END; + +{--TView--------------------------------------------------------------------} +{ GetBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetBounds (Var Bounds: TRect); +BEGIN + Bounds.A := Origin; { Get first corner } + Bounds.B.X := Origin.X + Size.X; { Calc corner x value } + Bounds.B.Y := Origin.Y + Size.Y; { Calc corner y value } +END; + +{--TView--------------------------------------------------------------------} +{ SetBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Sep99 LdB } +{---------------------------------------------------------------------------} +procedure TView.SetBounds(var Bounds: TRect); +begin + Origin := Bounds.A; { Get first corner } + Size := Bounds.B; { Get second corner } + Dec(Size.X,Origin.X); + Dec(Size.Y,Origin.Y); +end; + +{--TView--------------------------------------------------------------------} +{ GetClipRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetClipRect (Var Clip: TRect); +BEGIN + GetBounds(Clip); { Get current bounds } + If (Owner <> Nil) Then Clip.Intersect(Owner^.Clip);{ Intersect with owner } + Clip.Move(-Origin.X, -Origin.Y); { Sub owner origin } +END; + +{--TView--------------------------------------------------------------------} +{ ClearEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.ClearEvent (Var Event: TEvent); +BEGIN + Event.What := evNothing; { Clear the event } + Event.InfoPtr := @Self; { Set us as handler } +END; + +{--TView--------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.HandleEvent (Var Event: TEvent); +BEGIN + If (Event.What = evMouseDown) Then { Mouse down event } + If (State AND (sfSelected OR sfDisabled) = 0) { Not selected/disabled } + AND (Options AND ofSelectable <> 0) Then { View is selectable } + If (Focus = False) OR { Not view with focus } + (Options AND ofFirstClick = 0) { Not 1st click select } + Then ClearEvent(Event); { Handle the event } +END; + +{--TView--------------------------------------------------------------------} +{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.ChangeBounds (Var Bounds: TRect); +BEGIN + SetBounds(Bounds); { Set new bounds } + DrawView; { Draw the view } +END; + +{--TView--------------------------------------------------------------------} +{ SizeLimits -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SizeLimits (Var Min, Max: TPoint); +BEGIN + Min.X := 0; { Zero x minimum } + Min.Y := 0; { Zero y minimum } + If (Owner <> Nil) and(Owner^.ClipChilds) Then + Max := Owner^.Size + else { Max owner size } + Begin + Max.X := high(sw_integer); { Max possible x size } + Max.Y := high(sw_integer); { Max possible y size } + End; +END; + +{--TView--------------------------------------------------------------------} +{ GetCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetCommands (Var Commands: TCommandSet); +BEGIN + Commands := CurCommandSet; { Return command set } +END; + +{--TView--------------------------------------------------------------------} +{ GetPeerViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetPeerViewPtr (Var S: TStream; Var P); +VAR Index: SmallInt; +BEGIN + Index := 0; { Zero index value } + S.Read(Index, SizeOf(Index)); { Read view index } + If (Index = 0) OR (OwnerGroup = Nil) Then { Check for peer views } + Pointer(P) := Nil Else Begin { Return nil } + Pointer(P) := FixupList^[Index]; { New view ptr } + FixupList^[Index] := @P; { Patch this pointer } + End; +END; + +{--TView--------------------------------------------------------------------} +{ PutPeerViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.PutPeerViewPtr (Var S: TStream; P: PView); +VAR Index: SmallInt; +BEGIN + If (P = Nil) OR (OwnerGroup = Nil) Then Index := 0 { Return zero index } + Else Index := OwnerGroup^.IndexOf(P); { Return view index } + S.Write(Index, SizeOf(Index)); { Write the index } +END; + +{--TView--------------------------------------------------------------------} +{ CalcBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.CalcBounds (Var Bounds: Objects.TRect; Delta: TPoint); +VAR S, D: Sw_Integer; Min, Max: TPoint; + + FUNCTION Range (Val, Min, Max: Sw_Integer): Sw_Integer; + BEGIN + If (Val < Min) Then Range := Min Else { Value below min } + If (Val > Max) Then Range := Max Else { Value above max } + Range := Val; { Accept value } + END; + + PROCEDURE GrowI (Var I: Sw_Integer); + BEGIN + If (GrowMode AND gfGrowRel = 0) Then Inc(I, D) + Else If S = D then I := 1 + Else I := (I * S + (S - D) SHR 1) DIV (S - D); { Calc grow value } + END; + +BEGIN + GetBounds(Bounds); { Get bounds } + If (GrowMode = 0) Then Exit; { No grow flags exits } + S := Owner^.Size.X; { Set initial size } + D := Delta.X; { Set initial delta } + If (GrowMode AND gfGrowLoX <> 0) Then + GrowI(Bounds.A.X); { Grow left side } + If (GrowMode AND gfGrowHiX <> 0) Then + GrowI(Bounds.B.X); { Grow right side } + If (Bounds.B.X - Bounds.A.X > MaxViewWidth) Then + Bounds.B.X := Bounds.A.X + MaxViewWidth; { Check values } + S := Owner^.Size.Y; D := Delta.Y; { set initial values } + If (GrowMode AND gfGrowLoY <> 0) Then + GrowI(Bounds.A.Y); { Grow top side } + If (GrowMode AND gfGrowHiY <> 0) Then + GrowI(Bounds.B.Y); { grow lower side } + SizeLimits(Min, Max); { Check sizes } + Bounds.B.X := Bounds.A.X + Range(Bounds.B.X - + Bounds.A.X, Min.X, Max.X); { Set right side } + Bounds.B.Y := Bounds.A.Y + Range(Bounds.B.Y - + Bounds.A.Y, Min.Y, Max.Y); { Set lower side } +END; + +{***************************************************************************} +{ TView OBJECT PRIVATE METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TGroup OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TGroup-------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Jul99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TGroup.Init (Var Bounds: TRect); +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR (ofSelectable + ofBuffered); { Set options } + GetExtent(Clip); { Get clip extents } + EventMask := $FFFF; { See all events } +END; + +{--TGroup-------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TGroup.Load (Var S: TStream); +VAR I: Sw_Word; + Count: Word; + P, Q: ^Pointer; V: PView; OwnerSave: PGroup; + FixupSave: PFixupList; +BEGIN + Inherited Load(S); { Call ancestor } + GetExtent(Clip); { Get view extents } + OwnerSave := OwnerGroup; { Save current group } + OwnerGroup := @Self; { We are current group } + FixupSave := FixupList; { Save current list } + Count := 0; { Zero count value } + S.Read(Count, SizeOf(Count)); { Read entry count } + If (MaxAvail >= Count*SizeOf(Pointer)) Then Begin { Memory available } + GetMem(FixupList, Count*SizeOf(Pointer)); { List size needed } + FillChar(FixUpList^, Count*SizeOf(Pointer), #0); { Zero all entries } + For I := 1 To Count Do Begin + V := PView(S.Get); { Get view off stream } + If (V <> Nil) Then InsertView(V, Nil); { Insert valid views } + End; + V := Last; { Start on last view } + For I := 1 To Count Do Begin + V := V^.Next; { Fetch next view } + P := FixupList^[I]; { Transfer pointer } + While (P <> Nil) Do Begin { If valid view } + Q := P; { Copy pointer } + P := P^; { Fetch pointer } + Q^ := V; { Transfer view ptr } + End; + End; + FreeMem(FixupList, Count*SizeOf(Pointer)); { Release fixup list } + End; + OwnerGroup := OwnerSave; { Reload current group } + FixupList := FixupSave; { Reload current list } + GetSubViewPtr(S, V); { Load any subviews } + SetCurrent(V, NormalSelect); { Select current view } + If (OwnerGroup = Nil) Then Awaken; { If topview activate } +END; + +{--TGroup-------------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TGroup.Done; +VAR P, T: PView; +BEGIN + Hide; { Hide the view } + P := Last; { Start on last } + If (P <> Nil) Then Begin { Subviews exist } + Repeat + P^.Hide; { Hide each view } + P := P^.Prev; { Prior view } + Until (P = Last); { Loop complete } + Repeat + T := P^.Prev; { Hold prior pointer } + Dispose(P, Done); { Dispose subview } + P := T; { Transfer pointer } + Until (Last = Nil); { Loop complete } + End; + Inherited Done; { Call ancestor } +END; + +{--TGroup-------------------------------------------------------------------} +{ First -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.First: PView; +BEGIN + If (Last = Nil) Then First := Nil { No first view } + Else First := Last^.Next; { Return first view } +END; + +{--TGroup-------------------------------------------------------------------} +{ Execute -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.Execute: Word; +VAR Event: TEvent; +BEGIN + Repeat + EndState := 0; { Clear end state } + Repeat + GetEvent(Event); { Get next event } + HandleEvent(Event); { Handle the event } + If (Event.What <> evNothing) Then + EventError(Event); { Event not handled } + Until (EndState <> 0); { Until command set } + Until Valid(EndState); { Repeat until valid } + Execute := EndState; { Return result } + EndState := 0; { Clear end state } +END; + +{--TGroup-------------------------------------------------------------------} +{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.GetHelpCtx: Word; +VAR H: Word; +BEGIN + H := hcNoContext; { Preset no context } + If (Current <> Nil) Then H := Current^.GetHelpCtx; { Current context } + If (H=hcNoContext) Then H := Inherited GetHelpCtx; { Call ancestor } + GetHelpCtx := H; { Return result } +END; + +{--TGroup-------------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Jul98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.DataSize: Sw_Word; +VAR Total: Word; P: PView; +BEGIN + Total := 0; { Zero totals count } + P := Last; { Start on last view } + If (P <> Nil) Then Begin { Subviews exist } + Repeat + P := P^.Next; { Move to next view } + Total := Total + P^.DataSize; { Add view size } + Until (P = Last); { Until last view } + End; + DataSize := Total; { Return data size } +END; + +{--TGroup-------------------------------------------------------------------} +{ ExecView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Jul99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.ExecView (P: PView): Word; +VAR SaveOptions: Word; SaveTopView, SaveCurrent: PView; SaveOwner: PGroup; + SaveCommands: TCommandSet; +BEGIN + If (P<>Nil) Then Begin + SaveOptions := P^.Options; { Hold options } + SaveOwner := P^.Owner; { Hold owner } + SaveTopView := TheTopView; { Save topmost view } + SaveCurrent := Current; { Save current view } + GetCommands(SaveCommands); { Save commands } + TheTopView := P; { Set top view } + P^.Options := P^.Options AND NOT ofSelectable; { Not selectable } + P^.SetState(sfModal, True); { Make modal } + SetCurrent(P, EnterSelect); { Select next } + If (SaveOwner = Nil) Then Insert(P); { Insert view } + ExecView := P^.Execute; { Execute view } + If (SaveOwner = Nil) Then Delete(P); { Remove view } + SetCurrent(SaveCurrent, LeaveSelect); { Unselect current } + P^.SetState(sfModal, False); { Clear modal state } + P^.Options := SaveOptions; { Restore options } + TheTopView := SaveTopView; { Restore topview } + SetCommands(SaveCommands); { Restore commands } + End Else ExecView := cmCancel; { Return cancel } +END; + +{ ********************************* REMARK ******************************** } +{ This call really is very COMPILER SPECIFIC and really can't be done } +{ effectively any other way but assembler code as SELF & FRAMES need } +{ to be put down in exact order and OPTIMIZERS make a mess of it. } +{ ******************************** END REMARK *** Leon de Boer, 17Jul99 *** } + +{--TGroup-------------------------------------------------------------------} +{ FirstThat -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.FirstThat (P: TGroupFirstThatCallback): PView; +VAR + Tp : PView; +BEGIN + If (Last<>Nil) Then + Begin + Tp := Last; { Set temporary ptr } + Repeat + Tp := Tp^.Next; { Get next view } + IF Byte(PtrUInt(CallPointerMethodLocal(TCallbackFunBoolParam(P), + { On most systems, locals are accessed relative to base pointer, + but for MIPS cpu, they are accessed relative to stack pointer. + This needs adaptation for so low level routines, + like MethodPointerLocal and related objects unit functions. } +{$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE} + get_caller_frame(get_frame,get_pc_addr) +{$else} + get_frame +{$endif} + ,@self,Tp)))<>0 THEN + Begin { Test each view } + FirstThat := Tp; { View returned true } + Exit; { Now exit } + End; + Until (Tp=Last); { Until last } + FirstThat := Nil; { None passed test } + End + Else + FirstThat := Nil; { Return nil } +END; + +{--TGroup-------------------------------------------------------------------} +{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.Valid (Command: Word): Boolean; + + FUNCTION IsInvalid (P: PView): Boolean; + BEGIN + IsInvalid := NOT P^.Valid(Command); { Check if valid } + END; + +BEGIN + Valid := True; { Preset valid } + If (Command = cmReleasedFocus) Then Begin { Release focus cmd } + If (Current <> Nil) AND { Current view exists } + (Current^.Options AND ofValidate <> 0) Then { Validating view } + Valid := Current^.Valid(Command); { Validate command } + End Else Valid := FirstThat(@IsInvalid) = Nil; { Check first valid } +END; + +{--TGroup-------------------------------------------------------------------} +{ FocusNext -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.FocusNext (Forwards: Boolean): Boolean; +VAR P: PView; +BEGIN + P := FindNext(Forwards); { Find next view } + FocusNext := True; { Preset true } + If (P <> Nil) Then FocusNext := P^.Focus; { Check next focus } +END; + + +procedure TGroup.DrawSubViews(P, Bottom: PView); +begin + if P <> nil then + while P <> Bottom do + begin + P^.DrawView; + P := P^.NextView; + end; +end; + + +{--TGroup-------------------------------------------------------------------} +{ ReDraw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 2Jun06 DM } +{---------------------------------------------------------------------------} +procedure TGroup.Redraw; +begin + {Lock to prevent screen update.} + lockscreenupdate; + DrawSubViews(First, nil); + unlockscreenupdate; + {Draw all views at once, forced update.} + drawscreenbuf(true); +end; + + +PROCEDURE TGroup.ResetCursor; +BEGIN + if (Current<>nil) then + Current^.ResetCursor; +END; + + +{--TGroup-------------------------------------------------------------------} +{ Awaken -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Awaken; + + PROCEDURE DoAwaken (P: PView); + BEGIN + If (P <> Nil) Then P^.Awaken; { Awaken view } + END; + +BEGIN + ForEach(TCallbackProcParam(@DoAwaken)); { Awaken each view } +END; + +{--TGroup-------------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Draw; +BEGIN + If Buffer=Nil then + DrawSubViews(First, nil) + else + WriteBuf(0,0,Size.X,Size.Y,Buffer); +END; + + +{--TGroup-------------------------------------------------------------------} +{ SelectDefaultView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.SelectDefaultView; +VAR P: PView; +BEGIN + P := Last; { Start at last } + While (P <> Nil) Do Begin + If P^.GetState(sfDefault) Then Begin { Search 1st default } + P^.Select; { Select default view } + P := Nil; { Force kick out } + End Else P := P^.PrevView; { Prior subview } + End; +END; + + +function TGroup.ClipChilds: boolean; +begin + ClipChilds:=true; +end; + + +procedure TGroup.BeforeInsert(P: PView); +begin + { abstract } +end; + +procedure TGroup.AfterInsert(P: PView); +begin + { abstract } +end; + +procedure TGroup.BeforeDelete(P: PView); +begin + { abstract } +end; + +procedure TGroup.AfterDelete(P: PView); +begin + { abstract } +end; + +{--TGroup-------------------------------------------------------------------} +{ Insert -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Insert (P: PView); +BEGIN + BeforeInsert(P); + InsertBefore(P, First); + AfterInsert(P); +END; + +{--TGroup-------------------------------------------------------------------} +{ Delete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Delete (P: PView); +VAR SaveState: Word; +BEGIN + BeforeDelete(P); + SaveState := P^.State; { Save state } + P^.Hide; { Hide the view } + RemoveView(P); { Remove the view } + P^.Owner := Nil; { Clear owner ptr } + P^.Next := Nil; { Clear next ptr } + if SaveState and sfVisible <> 0 then + P^.Show; + AfterDelete(P); +END; + +{ ********************************* REMARK ******************************** } +{ This call really is very COMPILER SPECIFIC and really can't be done } +{ effectively any other way but assembler code as SELF & FRAMES need } +{ to be put down in exact order and OPTIMIZERS make a mess of it. } +{ ******************************** END REMARK *** Leon de Boer, 17Jul99 *** } + +{--TGroup-------------------------------------------------------------------} +{ ForEach -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.ForEach (P: TCallbackProcParam); +VAR + Tp,Hp,L0 : PView; +{ Vars Hp and L0 are necessary to hold original pointers in case } +{ when some view closes himself as a result of broadcast message ! } +BEGIN + If (Last<>Nil) Then + Begin + Tp:=Last; + Hp:=Tp^.Next; + L0:=Last; { Set temporary ptr } + Repeat + Tp:=Hp; + if tp=nil then + exit; + Hp:=Tp^.Next; { Get next view } + CallPointerMethodLocal(P, + { On most systems, locals are accessed relative to base pointer, + but for MIPS cpu, they are accessed relative to stack pointer. + This needs adaptation for so low level routines, + like MethodPointerLocal and related objects unit functions. } +{$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE} + get_caller_frame(get_frame,get_pc_addr) +{$else} + get_frame +{$endif} + ,@self,Tp); + Until (Tp=L0); { Until last } + End; +END; + + + +{--TGroup-------------------------------------------------------------------} +{ EndModal -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.EndModal (Command: Word); +BEGIN + If (State AND sfModal <> 0) Then { This view is modal } + EndState := Command Else { Set endstate } + Inherited EndModal(Command); { Call ancestor } +END; + +{--TGroup-------------------------------------------------------------------} +{ SelectNext -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.SelectNext (Forwards: Boolean); +VAR P: PView; +BEGIN + P := FindNext(Forwards); { Find next view } + If (P <> Nil) Then P^.Select; { Select view } +END; + +{--TGroup-------------------------------------------------------------------} +{ InsertBefore -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.InsertBefore (P, Target: PView); +VAR SaveState : Word; +BEGIN + If (P <> Nil) AND (P^.Owner = Nil) AND { View valid } + ((Target = Nil) OR (Target^.Owner = @Self)) { Target valid } + Then Begin + If (P^.Options AND ofCenterX <> 0) Then { Centre on x axis } + P^.Origin.X := (Size.X - P^.Size.X) div 2; + If (P^.Options AND ofCenterY <> 0) Then { Centre on y axis } + P^.Origin.Y := (Size.Y - P^.Size.Y) div 2; + SaveState := P^.State; { Save view state } + P^.Hide; { Make sure hidden } + InsertView(P, Target); { Insert into list } + If (SaveState AND sfVisible <> 0) Then P^.Show; { Show the view } + If (State AND sfActive <> 0) Then { Was active before } + P^.SetState(sfActive , True); { Make active again } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.SetState (AState: Word; Enable: Boolean); + + PROCEDURE DoSetState (P: PView); + BEGIN + If (P <> Nil) Then P^.SetState(AState, Enable); { Set subview state } + END; + + PROCEDURE DoExpose (P: PView); + BEGIN + If (P <> Nil) Then Begin + If (P^.State AND sfVisible <> 0) Then { Check view visible } + P^.SetState(sfExposed, Enable); { Set exposed flag } + End; + END; + +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + Case AState Of + sfActive, sfDragging: Begin + Lock; { Lock the view } + ForEach(TCallbackProcParam(@DoSetState)); { Set each subview } + UnLock; { Unlock the view } + End; + sfFocused: Begin + If (Current <> Nil) Then + Current^.SetState(sfFocused, Enable); { Focus current view } + End; + sfExposed: Begin + ForEach(TCallbackProcParam(@DoExpose)); { Expose each subview } + End; + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Mar98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.GetData (Var Rec); +VAR Total: Sw_Word; P: PView; +BEGIN + Total := 0; { Clear total } + P := Last; { Start at last } + While (P <> Nil) Do Begin { Subviews exist } + P^.GetData(TByteArray(Rec)[Total]); { Get data } + Inc(Total, P^.DataSize); { Increase total } + P := P^.PrevView; { Previous view } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Mar98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.SetData (Var Rec); +VAR Total: Sw_Word; P: PView; +BEGIN + Total := 0; { Clear total } + P := Last; { Start at last } + While (P <> Nil) Do Begin { Subviews exist } + P^.SetData(TByteArray(Rec)[Total]); { Get data } + Inc(Total, P^.DataSize); { Increase total } + P := P^.PrevView; { Previous view } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Mar98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Store (Var S: TStream); +VAR Count: Word; OwnerSave: PGroup; + + PROCEDURE DoPut (P: PView); + BEGIN + S.Put(P); { Put view on stream } + END; + +BEGIN + TView.Store(S); { Call view store } + OwnerSave := OwnerGroup; { Save ownergroup } + OwnerGroup := @Self; { Set as owner group } + Count := IndexOf(Last); { Subview count } + S.Write(Count, SizeOf(Count)); { Write the count } + ForEach(TCallbackProcParam(@DoPut)); { Put each in stream } + PutSubViewPtr(S, Current); { Current on stream } + OwnerGroup := OwnerSave; { Restore ownergroup } +END; + +{--TGroup-------------------------------------------------------------------} +{ EventError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.EventError (Var Event: TEvent); +BEGIN + If (Owner <> Nil) Then Owner^.EventError(Event); { Event error } +END; + +{--TGroup-------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.HandleEvent (Var Event: TEvent); + + FUNCTION ContainsMouse (P: PView): Boolean; + BEGIN + ContainsMouse := (P^.State AND sfVisible <> 0) { Is view visible } + AND P^.MouseInView(Event.Where); { Is point in view } + END; + + PROCEDURE DoHandleEvent (P: PView); + BEGIN + If (P = Nil) OR ((P^.State AND sfDisabled <> 0) AND + (Event.What AND(PositionalEvents OR FocusedEvents) <>0 )) + Then Exit; { Invalid/disabled } + Case Phase Of + phPreProcess: If (P^.Options AND ofPreProcess = 0) + Then Exit; { Not pre processing } + phPostProcess: If (P^.Options AND ofPostProcess = 0) + Then Exit; { Not post processing } + End; + If (Event.What AND P^.EventMask <> 0) Then { View handles event } + P^.HandleEvent(Event); { Pass to view } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evNothing) Then Exit; { No valid event exit } + If (Event.What AND FocusedEvents <> 0) Then Begin { Focused event } + Phase := phPreProcess; { Set pre process } + ForEach(TCallbackProcParam(@DoHandleEvent)); { Pass to each view } + Phase := phFocused; { Set focused } + DoHandleEvent(Current); { Pass to current } + Phase := phPostProcess; { Set post process } + ForEach(TCallbackProcParam(@DoHandleEvent)); { Pass to each } + End Else Begin + Phase := phFocused; { Set focused } + If (Event.What AND PositionalEvents <> 0) Then { Positional event } + DoHandleEvent(FirstThat(@ContainsMouse)) { Pass to first } + Else ForEach(TCallbackProcParam(@DoHandleEvent)); { Pass to all } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.ChangeBounds (Var Bounds: TRect); +VAR D: TPoint; + + PROCEDURE DoCalcChange (P: PView); + VAR R: TRect; + BEGIN + P^.CalcBounds(R, D); { Calc view bounds } + P^.ChangeBounds(R); { Change view bounds } + END; + +BEGIN + D.X := Bounds.B.X - Bounds.A.X - Size.X; { Delta x value } + D.Y := Bounds.B.Y - Bounds.A.Y - Size.Y; { Delta y value } + If ((D.X=0) AND (D.Y=0)) Then Begin + SetBounds(Bounds); { Set new bounds } + { Force redraw } + ReDraw; { Draw the view } + End Else Begin + SetBounds(Bounds); { Set new bounds } + GetExtent(Clip); { Get new clip extents } + Lock; { Lock drawing } + ForEach(TCallbackProcParam(@DoCalcChange)); { Change each view } + UnLock; { Unlock drawing } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ GetSubViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.GetSubViewPtr (Var S: TStream; Var P); +VAR Index, I: Sw_Word; Q: PView; +BEGIN + Index := 0; { Zero index value } + S.Read(Index, SizeOf(Index)); { Read view index } + If (Index > 0) Then Begin { Valid index } + Q := Last; { Start on last } + For I := 1 To Index Do Q := Q^.Next; { Loop for count } + Pointer(P) := Q; { Return the view } + End Else Pointer(P) := Nil; { Return nil } +END; + +{--TGroup-------------------------------------------------------------------} +{ PutSubViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.PutSubViewPtr (Var S: TStream; P: PView); +VAR Index: Sw_Word; +BEGIN + If (P = Nil) Then Index := 0 Else { Nil view, Index = 0 } + Index := IndexOf(P); { Calc view index } + S.Write(Index, SizeOf(Index)); { Write the index } +END; + + +{***************************************************************************} +{ TGroup OBJECT PRIVATE METHODS } +{***************************************************************************} + +{--TGroup-------------------------------------------------------------------} +{ IndexOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.IndexOf (P: PView): Sw_Integer; +VAR I: Sw_Integer; Q: PView; +BEGIN + Q := Last; { Start on last view } + If (Q <> Nil) Then Begin { Subviews exist } + I := 1; { Preset value } + While (Q <> P) AND (Q^.Next <> Last) Do Begin + Q := Q^.Next; { Load next view } + Inc(I); { Increment count } + End; + If (Q <> P) Then IndexOf := 0 Else IndexOf := I; { Return index } + End Else IndexOf := 0; { Return zero } +END; + +{--TGroup-------------------------------------------------------------------} +{ FindNext -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.FindNext (Forwards: Boolean): PView; +VAR P: PView; +BEGIN + FindNext := Nil; { Preset nil return } + If (Current <> Nil) Then Begin { Has current view } + P := Current; { Start on current } + Repeat + If Forwards Then P := P^.Next { Get next view } + Else P := P^.Prev; { Get prev view } + Until ((P^.State AND (sfVisible+sfDisabled) = sfVisible) AND + (P^.Options AND ofSelectable <> 0)) OR { Tab selectable } + (P = Current); { Not singular select } + If (P <> Current) Then FindNext := P; { Return result } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ FirstMatch -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.FirstMatch (AState: Word; AOptions: Word): PView; + + FUNCTION Matches (P: PView): Boolean; + BEGIN + Matches := (P^.State AND AState = AState) AND + (P^.Options AND AOptions = AOptions); { Return match state } + END; + +BEGIN + FirstMatch := FirstThat(@Matches); { Return first match } +END; + +{--TGroup-------------------------------------------------------------------} +{ ResetCurrent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.ResetCurrent; +BEGIN + SetCurrent(FirstMatch(sfVisible, ofSelectable), + NormalSelect); { Reset current view } +END; + +{--TGroup-------------------------------------------------------------------} +{ RemoveView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.RemoveView (P: PView); +VAR Q: PView; +BEGIN + If (P <> Nil) AND (Last <> Nil) Then Begin { Check view is valid } + Q := Last; { Start on last view } + While (Q^.Next <> P) AND (Q^.Next <> Last) Do + Q := Q^.Next; { Find prior view } + If (Q^.Next = P) Then Begin { View found } + If (Q^.Next <> Q) Then Begin { Not only view } + Q^.Next := P^.Next; { Rechain views } + If (P = Last) Then Last := P^.Next; { Fix if last removed } + End Else Last := Nil; { Only view } + End; + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ InsertView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.InsertView (P, Target: PView); +BEGIN + If (P <> Nil) Then Begin { Check view is valid } + P^.Owner := @Self; { Views owner is us } + If (Target <> Nil) Then Begin { Valid target } + Target := Target^.Prev; { 1st part of chain } + P^.Next := Target^.Next; { 2nd part of chain } + Target^.Next := P; { Chain completed } + End Else Begin + If (Last <> Nil) Then Begin { Not first view } + P^.Next := Last^.Next; { 1st part of chain } + Last^.Next := P; { Completed chain } + End Else P^.Next := P; { 1st chain to self } + Last := P; { P is now last } + End; + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ SetCurrent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.SetCurrent (P: PView; Mode: SelectMode); + + PROCEDURE SelectView (P: PView; Enable: Boolean); + BEGIN + If (P <> Nil) Then { View is valid } + P^.SetState(sfSelected, Enable); { Select the view } + END; + + PROCEDURE FocusView (P: PView; Enable: Boolean); + BEGIN + If (State AND sfFocused <> 0) AND (P <> Nil) { Check not focused } + Then P^.SetState(sfFocused, Enable); { Focus the view } + END; + +BEGIN + If (Current<>P) Then Begin { Not already current } + Lock; { Stop drawing } + FocusView(Current, False); { Defocus current } + If (Mode <> EnterSelect) Then + SelectView(Current, False); { Deselect current } + If (Mode<>LeaveSelect) Then SelectView(P, True); { Select view P } + FocusView(P, True); { Focus view P } + Current := P; { Set as current view } + UnLock; { Redraw now } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TFrame OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TFrame-------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TFrame.Init (Var Bounds: TRect); +BEGIN + Inherited Init(Bounds); { Call ancestor } + GrowMode := gfGrowHiX + gfGrowHiY; { Set grow modes } + EventMask := EventMask OR evBroadcast; { See broadcasts } +END; + +procedure TFrame.FrameLine(var FrameBuf; Y, N: Sw_Integer; Color: Byte); +const + InitFrame: array[0..17] of Byte = + ($06, $0A, $0C, $05, $00, $05, $03, $0A, $09, + $16, $1A, $1C, $15, $00, $15, $13, $1A, $19); +{$ifdef FV_UNICODE} + FrameChars_Unicode: array[0..31] of WideChar = + #$0020#$0020#$0020#$2514#$0020#$2502#$250C#$251C+ + #$0020#$2518#$2500#$2534#$2510#$2524#$252C#$253C+ + #$0020#$0020#$0020#$255A#$0020#$2551#$2554#$255F+ + #$0020#$255D#$2550#$2567#$2557#$2562#$2564#$256C; +{$else FV_UNICODE} + FrameChars_437: array[0..31] of Char = + ' '#192' '#179#218#195' '#217#196#193#191#180#194#197' '#200' '#186#201#199' '#188#205#207#187#182#209#206; + FrameChars_850: array[0..31] of Char = + ' '#192' '#179#218#195' '#217#196#193#191#180#194#197' '#200' '#186#201#186' '#188#205#205#187#186#205#206; +{$endif FV_UNICODE} +var + FrameMask : array[0..MaxViewWidth-1] of Byte; +{$ifndef FV_UNICODE} + ColorMask : word; +{$endif FV_UNICODE} + i,j,k : {Sw_ lo and hi are used !! }SmallInt; + CurrView : PView; +{$ifndef FV_UNICODE} + p : Pchar; +{$endif FV_UNICODE} +begin + FrameMask[0]:=InitFrame[n]; + FillChar(FrameMask[1],Size.X-2,InitFrame[n+1]); + FrameMask[Size.X-1]:=InitFrame[n+2]; + CurrView:=Owner^.Last^.Next; + while (CurrView<>PView(@Self)) do + begin + if ((CurrView^.Options and ofFramed)<>0) and + ((CurrView^.State and sfVisible)<>0) then + begin + i:=Y-CurrView^.Origin.Y; + if (i<0) then + begin + inc(i); + if i=0 then + i:=$0a06 + else + i:=0; + end + else + begin + if i<CurrView^.Size.Y then + i:=$0005 + else + if i=CurrView^.Size.Y then + i:=$0a03 + else + i:=0; + end; + if (i<>0) then + begin + j:=CurrView^.Origin.X; + k:=CurrView^.Size.X+j; + if j<1 then + j:=1; + if k>Size.X then + k:=Size.X; + if (k>j) then + begin + FrameMask[j-1]:=FrameMask[j-1] or lo(i); + i:=(lo(i) xor hi(i)) or (i and $ff00); + FrameMask[k]:=FrameMask[k] or lo(i); + if hi(i)<>0 then + begin + dec(k,j); + repeat + FrameMask[j]:=FrameMask[j] or hi(i); + inc(j); + dec(k); + until k=0; + end; + end; + end; + end; + CurrView:=CurrView^.Next; + end; +{$ifdef FV_UNICODE} + for i:=0 to Size.X-1 do + with TVideoBuf(FrameBuf)[i] do + begin + Attribute:=Color; + ExtendedGraphemeCluster:=FrameChars_Unicode[FrameMask[i]]; + end; +{$else FV_UNICODE} + ColorMask:=Color shl 8; + p:=framechars_437; + if GetActiveCodePage<>437 then + p:=framechars_850; + for i:=0 to Size.X-1 do + TVideoBuf(FrameBuf)[i]:=ord(p[FrameMask[i]]) or ColorMask; +{$endif FV_UNICODE} +end; + + +procedure TFrame.Draw; +const +{$ifdef FV_UNICODE} + LargeC:array[boolean] of widechar=('^',#$2191); + RestoreC:array[boolean] of widechar=('|',#$2195); + ClickC:array[boolean] of widechar=('*',#$263C); +{$else FV_UNICODE} + LargeC:array[boolean] of char=('^',#24); + RestoreC:array[boolean] of char=('|',#18); + ClickC:array[boolean] of char=('*',#15); +{$endif FV_UNICODE} +var + CFrame, CTitle: Word; + F, I, L, Width: Sw_Integer; + B: TDrawBuffer; + Title: TTitleStr; + Min, Max: TPoint; +begin + if State and sfDragging <> 0 then + begin + CFrame := $0505; + CTitle := $0005; + F := 0; + end + else if State and sfActive = 0 then + begin + CFrame := $0101; + CTitle := $0002; + F := 0; + end + else + begin + CFrame := $0503; + CTitle := $0004; + F := 9; + end; + CFrame := GetColor(CFrame); + CTitle := GetColor(CTitle); + Width := Size.X; + L := Width - 10; + if PWindow(Owner)^.Flags and (wfClose+wfZoom) <> 0 then + Dec(L,6); + FrameLine(B, 0, F, Byte(CFrame)); + if (PWindow(Owner)^.Number <> wnNoNumber) and + (PWindow(Owner)^.Number < 10) then + begin + Dec(L,4); + if PWindow(Owner)^.Flags and wfZoom <> 0 then + I := 7 + else + I := 3; +{$ifdef FV_UNICODE} + B[Width - I].ExtendedGraphemeCluster := WideChar(PWindow(Owner)^.Number + $30); +{$else FV_UNICODE} + WordRec(B[Width - I]).Lo := PWindow(Owner)^.Number + $30; +{$endif FV_UNICODE} + end; + if Owner <> nil then + Title := PWindow(Owner)^.GetTitle(L) + else + Title := ''; + if Title <> '' then + begin + L := StrWidth(Title); + if L > Width - 10 then + L := Width - 10; + if L < 0 then + L := 0; + I := (Width - L) shr 1; + MoveChar(B[I - 1], ' ', CTitle, 1); + MoveBuf(B[I], Title[1], CTitle, L, Length(Title)); + MoveChar(B[I + L], ' ', CTitle, 1); + end; + if State and sfActive <> 0 then + begin + if PWindow(Owner)^.Flags and wfClose <> 0 then + if FrameMode and fmCloseClicked = 0 then +{$ifdef FV_UNICODE} + MoveCStr(B[2], '[~'#$25A0'~]', CFrame) +{$else FV_UNICODE} + MoveCStr(B[2], '[~'#254'~]', CFrame) +{$endif FV_UNICODE} + else + MoveCStr(B[2], '[~'+ClickC[LowAscii]+'~]', CFrame); + if PWindow(Owner)^.Flags and wfZoom <> 0 then + begin + MoveCStr(B[Width - 5], '[~'+LargeC[LowAscii]+'~]', CFrame); + Owner^.SizeLimits(Min, Max); + if FrameMode and fmZoomClicked <> 0 then +{$ifdef FV_UNICODE} + B[Width - 4].ExtendedGraphemeCluster := ClickC[LowAscii] +{$else FV_UNICODE} + WordRec(B[Width - 4]).Lo := ord(ClickC[LowAscii]) +{$endif FV_UNICODE} + else + if (Owner^.Size.X=Max.X) and (Owner^.Size.Y=Max.Y) then +{$ifdef FV_UNICODE} + B[Width - 4].ExtendedGraphemeCluster := RestoreC[LowAscii]; +{$else FV_UNICODE} + WordRec(B[Width - 4]).Lo := ord(RestoreC[LowAscii]); +{$endif FV_UNICODE} + end; + end; + WriteLine(0, 0, Size.X, 1, B); + for I := 1 to Size.Y - 2 do + begin + FrameLine(B, I, F + 3, Byte(CFrame)); + WriteLine(0, I, Size.X, 1, B); + end; + FrameLine(B, Size.Y - 1, F + 6, Byte(CFrame)); + if State and sfActive <> 0 then + if PWindow(Owner)^.Flags and wfGrow <> 0 then +{$ifdef FV_UNICODE} + MoveCStr(B[Width - 2], '~'#$2500#$2518'~', CFrame); +{$else FV_UNICODE} + MoveCStr(B[Width - 2], '~'#196#217'~', CFrame); +{$endif FV_UNICODE} + WriteLine(0, Size.Y - 1, Size.X, 1, B); +end; + +{--TFrame-------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TFrame.GetPalette: PPalette; +CONST P: String[Length(CFrame)] = CFrame; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +procedure TFrame.HandleEvent(var Event: TEvent); +var + Mouse: TPoint; + + procedure DragWindow(Mode: Byte); + var + Limits: TRect; + Min, Max: TPoint; + begin + Owner^.Owner^.GetExtent(Limits); + Owner^.SizeLimits(Min, Max); + Owner^.DragView(Event, Owner^.DragMode or Mode, Limits, Min, Max); + ClearEvent(Event); + end; + +begin + TView.HandleEvent(Event); + if Event.What = evMouseDown then + begin + MakeLocal(Event.Where, Mouse); + if Mouse.Y = 0 then + begin + if (PWindow(Owner)^.Flags and wfClose <> 0) and + (State and sfActive <> 0) and (Mouse.X >= 2) and (Mouse.X <= 4) then + begin + {Close button clicked.} + repeat + MakeLocal(Event.Where, Mouse); + if (Mouse.X >= 2) and (Mouse.X <= 4) and (Mouse.Y = 0) then + FrameMode := fmCloseClicked + else FrameMode := 0; + DrawView; + until not MouseEvent(Event, evMouseMove + evMouseAuto); + FrameMode := 0; + if (Mouse.X >= 2) and (Mouse.X <= 4) and (Mouse.Y = 0) then + begin + Event.What := evCommand; + Event.Command := cmClose; + Event.InfoPtr := Owner; + PutEvent(Event); + end; + ClearEvent(Event); + DrawView; + end else + if (PWindow(Owner)^.Flags and wfZoom <> 0) and + (State and sfActive <> 0) and (Event.Double or + (Mouse.X >= Size.X - 5) and + (Mouse.X <= Size.X - 3)) then + begin + {Zoom button clicked.} + if not Event.Double then + repeat + MakeLocal(Event.Where, Mouse); + if (Mouse.X >= Size.X - 5) and (Mouse.X <= Size.X - 3) and + (Mouse.Y = 0) then + FrameMode := fmZoomClicked + else FrameMode := 0; + DrawView; + until not MouseEvent(Event, evMouseMove + evMouseAuto); + FrameMode := 0; + if ((Mouse.X >= Size.X - 5) and (Mouse.X <= Size.X - 3) and + (Mouse.Y = 0)) or Event.Double then + begin + Event.What := evCommand; + Event.Command := cmZoom; + Event.InfoPtr := Owner; + PutEvent(Event); + end; + ClearEvent(Event); + DrawView; + end else + if PWindow(Owner)^.Flags and wfMove <> 0 then + DragWindow(dmDragMove); + end else + if (State and sfActive <> 0) and (Mouse.X >= Size.X - 2) and + (Mouse.Y >= Size.Y - 1) then + if PWindow(Owner)^.Flags and wfGrow <> 0 then + DragWindow(dmDragGrow); + end; +end; + + +procedure TFrame.SetState(AState: Word; Enable: Boolean); +begin + TView.SetState(AState, Enable); + if AState and (sfActive + sfDragging) <> 0 then + DrawView; +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TScrollBar OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + + +{--TScrollBar---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TScrollBar.Init (Var Bounds: TRect); +const +{$ifdef FV_UNICODE} + VChars: array[boolean] of TScrollChars = + (('^','V', #$2592, #$25A0, #$2593),(#$25B2, #$25BC, #$2592, #$25A0, #$2593)); + HChars: array[boolean] of TScrollChars = + (('<','>', #$2592, #$25A0, #$2593),(#$25C4, #$25BA, #$2592, #$25A0, #$2593)); +{$else FV_UNICODE} + VChars: array[boolean] of TScrollChars = + (('^','V', #177, #254, #178),(#30, #31, #177, #254, #178)); + HChars: array[boolean] of TScrollChars = + (('<','>', #177, #254, #178),(#17, #16, #177, #254, #178)); +{$endif FV_UNICODE} +BEGIN + Inherited Init(Bounds); { Call ancestor } + PgStep := 1; { Page step size = 1 } + ArStep := 1; { Arrow step sizes = 1 } + If (Size.X = 1) Then Begin { Vertical scrollbar } + GrowMode := gfGrowLoX + gfGrowHiX + gfGrowHiY; { Grow vertically } + Chars := VChars[LowAscii]; { Vertical chars } + End Else Begin { Horizontal scrollbar } + GrowMode := gfGrowLoY + gfGrowHiX + gfGrowHiY; { Grow horizontal } + Chars := HChars[LowAscii]; { Horizontal chars } + End; +END; + +{--TScrollBar---------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +{ This load method will read old original TV data from a stream with the } +{ scrollbar id set to zero. } +{---------------------------------------------------------------------------} +CONSTRUCTOR TScrollBar.Load (Var S: TStream); +VAR i: SmallInt; +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(i, SizeOf(i)); Value:=i; { Read current value } + S.Read(i, SizeOf(i)); Min:=i; { Read min value } + S.Read(i, SizeOf(i)); Max:=i; { Read max value } + S.Read(i, SizeOf(i)); PgStep:=i; { Read page step size } + S.Read(i, SizeOf(i)); ArStep:=i; { Read arrow step size } + S.Read(Chars, SizeOf(Chars)); { Read scroll chars } +END; + +{--TScrollBar---------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TScrollBar.GetPalette: PPalette; +CONST P: String[Length(CScrollBar)] = CScrollBar; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TScrollBar---------------------------------------------------------------} +{ ScrollStep -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TScrollBar.ScrollStep (Part: Sw_Integer): Sw_Integer; +VAR Step: Sw_Integer; +BEGIN + If (Part AND $0002 = 0) Then Step := ArStep { Range step size } + Else Step := PgStep; { Page step size } + If (Part AND $0001 = 0) Then ScrollStep := -Step { Upwards move } + Else ScrollStep := Step; { Downwards move } +END; + +{--TScrollBar---------------------------------------------------------------} +{ ScrollDraw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.ScrollDraw; +VAR P: PView; +BEGIN + If (Id <> 0) Then Begin + P := TopView; { Get topmost view } + NewMessage(P, evCommand, cmIdCommunicate, Id, + Value, @Self); { New Id style message } + End; + NewMessage(Owner, evBroadcast, cmScrollBarChanged, + Id, Value, @Self); { Old TV style message } +END; + + +{--TScrollBar---------------------------------------------------------------} +{ SetValue -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.SetValue (AValue: Sw_Integer); +BEGIN + SetParams(AValue, Min, Max, PgStep, ArStep); { Set value } +END; + +{--TScrollBar---------------------------------------------------------------} +{ SetRange -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.SetRange (AMin, AMax: Sw_Integer); +BEGIN + SetParams(Value, AMin, AMax, PgStep, ArStep); { Set range } +END; + +{--TScrollBar---------------------------------------------------------------} +{ SetStep -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.SetStep (APgStep, AArStep: Sw_Integer); +BEGIN + SetParams(Value, Min, Max, APgStep, AArStep); { Set step sizes } +END; + +{--TScrollBar---------------------------------------------------------------} +{ SetParams -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 21Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.SetParams (AValue, AMin, AMax, APgStep, AArStep: Sw_Integer); +var + OldValue : Sw_Integer; +BEGIN + If (AMax < AMin) Then AMax := AMin; { Max below min fix up } + If (AValue < AMin) Then AValue := AMin; { Value below min fix } + If (AValue > AMax) Then AValue := AMax; { Value above max fix } + OldValue:=Value; + If (Value <> AValue) OR (Min <> AMin) OR + (Max <> AMax) Then Begin { Something changed } + Min := AMin; { Set new minimum } + Max := AMax; { Set new maximum } + Value := AValue; { Set new value } + DrawView; + if OldValue <> AValue then + ScrollDraw; + End; + PgStep := APgStep; { Hold page step } + ArStep := AArStep; { Hold arrow step } +END; + +{--TScrollBar---------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +{ You can save data to the stream compatable with the old original TV by } +{ temporarily turning off the ofGrafVersion making the call to this store } +{ routine and resetting the ofGrafVersion flag after the call. } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.Store (Var S: TStream); +VAR i: SmallInt; +BEGIN + TView.Store(S); { TView.Store called } + i:=Value;S.Write(i, SizeOf(i)); { Write current value } + i:=Min;S.Write(i, SizeOf(i)); { Write min value } + i:=Max;S.Write(i, SizeOf(i)); { Write max value } + i:=PgStep;S.Write(i, SizeOf(i)); { Write page step size } + i:=ArStep;S.Write(i, SizeOf(i)); { Write arrow step size } + S.Write(Chars, SizeOf(Chars)); { Write scroll chars } +END; + +{--TScrollBar---------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.HandleEvent (Var Event: TEvent); +VAR Tracking: Boolean; I, P, S, ClickPart, Iv: Sw_Integer; + Mouse: TPoint; Extent: TRect; + + FUNCTION GetPartCode: Sw_Integer; + VAR Mark, Part : Sw_Integer; + BEGIN + Part := -1; { Preset failure } + If Extent.Contains(Mouse) Then Begin { Contains mouse } + If (Size.X = 1) Then Begin { Vertical scrollbar } + Mark := Mouse.Y; { Calc position } + End Else Begin { Horizontal bar } + Mark := Mouse.X; { Calc position } + End; + If (Mark >= P) AND (Mark < P+1) Then { Within thumbnail } + Part := sbIndicator; { Indicator part } + If (Part <> sbIndicator) Then Begin { Not indicator part } + If (Mark < 1) Then Part := sbLeftArrow Else { Left arrow part } + If (Mark < P) Then Part := sbPageLeft Else { Page left part } + If (Mark < S-1) Then Part := sbPageRight Else { Page right part } + Part := sbRightArrow; { Right arrow part } + If (Size.X = 1) Then Inc(Part, 4); { Correct for vertical } + End; + End; + GetPartCode := Part; { Return part code } + END; + + PROCEDURE Clicked; + BEGIN + NewMessage(Owner, evBroadcast, cmScrollBarClicked, + Id, Value, @Self); { Old TV style message } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evCommand: Begin { Command event } + If (Event.Command = cmIdCommunicate) AND { Id communication } + (Event.Id = Id) AND (Event.InfoPtr <> @Self) { Targeted to us } + Then Begin + SetValue(Round(Event.Data)); { Set scrollbar value } + ClearEvent(Event); { Event was handled } + End; + End; + evKeyDown: + If (State AND sfVisible <> 0) Then Begin { Scrollbar visible } + ClickPart := sbIndicator; { Preset result } + If (Size.Y = 1) Then { Horizontal bar } + Case CtrlToArrow(Event.KeyCode) Of + kbLeft: ClickPart := sbLeftArrow; { Left one item } + kbRight: ClickPart := sbRightArrow; { Right one item } + kbCtrlLeft: ClickPart := sbPageLeft; { One page left } + kbCtrlRight: ClickPart := sbPageRight; { One page right } + kbHome: I := Min; { Move to start } + kbEnd: I := Max; { Move to end } + Else Exit; { Not a valid key } + End + Else { Vertical bar } + Case CtrlToArrow(Event.KeyCode) Of + kbUp: ClickPart := sbUpArrow; { One item up } + kbDown: ClickPart := sbDownArrow; { On item down } + kbPgUp: ClickPart := sbPageUp; { One page up } + kbPgDn: ClickPart := sbPageDown; { One page down } + kbCtrlPgUp: I := Min; { Move to top } + kbCtrlPgDn: I := Max; { Move to bottom } + Else Exit; { Not a valid key } + End; + Clicked; { Send out message } + If (ClickPart <> sbIndicator) Then + I := Value + ScrollStep(ClickPart); { Calculate position } + SetValue(I); { Set new item } + ClearEvent(Event); { Event now handled } + End; + evMouseDown: Begin { Mouse press event } + Clicked; { Scrollbar clicked } + MakeLocal(Event.Where, Mouse); { Localize mouse } + Extent.A.X := 0; { Zero x extent value } + Extent.A.Y := 0; { Zero y extent value } + Extent.B.X := Size.X; { Set extent x value } + Extent.B.Y := Size.Y; { set extent y value } + P := GetPos; { Current position } + S := GetSize; { Initial size } + ClickPart := GetPartCode; { Get part code } + If (ClickPart <> sbIndicator) Then Begin { Not thumb nail } + Repeat + MakeLocal(Event.Where, Mouse); { Localize mouse } + If GetPartCode = ClickPart Then + SetValue(Value+ScrollStep(ClickPart)); { Same part repeat } + Until NOT MouseEvent(Event, evMouseAuto); { Until auto done } + Clicked; { Scrollbar clicked } + End Else Begin { Thumb nail move } + Iv := Value; { Initial value } + Repeat + MakeLocal(Event.Where, Mouse); { Localize mouse } + Tracking := Extent.Contains(Mouse); { Check contains } + If Tracking Then Begin { Tracking mouse } + If (Size.X=1) Then + I := Mouse.Y Else { Calc vert position } + I := Mouse.X; { Calc horz position } + If (I < 0) Then I := 0; { Check underflow } + If (I > S) Then I := S; { Check overflow } + End Else I := GetPos; { Get position } + If (I <> P) Then Begin + SetValue(LongInt((LongInt(I)*(Max-Min)) + +(S SHR 1)) DIV S + Min); { Set new value } + P := I; { Hold new position } + End; + Until NOT MouseEvent(Event, evMouseMove); { Until not moving } + If Tracking AND (S > 0) Then { Tracking mouse } + SetValue(LongInt((LongInt(P)*(Max-Min))+ + (S SHR 1)) DIV S + Min); { Set new value } + If (Iv <> Value) Then Clicked; { Scroll has moved } + End; + ClearEvent(Event); { Clear the event } + End; + End; +END; + +{***************************************************************************} +{ TScrollBar OBJECT PRIVATE METHODS } +{***************************************************************************} + +{--TScrollBar---------------------------------------------------------------} +{ GetPos -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TScrollBar.GetPos: Sw_Integer; +VAR R: Sw_Integer; +BEGIN + R := Max - Min; { Get full range } + If (R = 0) Then GetPos := 1 Else { Return zero } + GetPos := LongInt((LongInt(Value-Min) * (GetSize -3)) + + (R SHR 1)) DIV R + 1; { Calc position } +END; + +{--TScrollBar---------------------------------------------------------------} +{ GetSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TScrollBar.GetSize: Sw_Integer; +VAR S: Sw_Integer; +BEGIN + If Size.X = 1 Then + S:= Size.Y + else + S:= Size.X; + If (S < 3) Then S := 3; { Fix minimum size } + GetSize := S; { Return size } +END; + + +{--TScrollBar---------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.Draw; +BEGIN + DrawPos(GetPos); { Draw position } +END; + + +procedure TScrollBar.DrawPos(Pos: Sw_Integer); +var + S: Sw_Integer; + B: TDrawBuffer; +begin + S := GetSize - 1; + MoveChar(B[0], Chars[0], GetColor(2), 1); + if Max = Min then + MoveChar(B[1], Chars[4], GetColor(1), S - 1) + else + begin + MoveChar(B[1], Chars[2], GetColor(1), S - 1); + MoveChar(B[Pos], Chars[3], GetColor(3), 1); + end; + MoveChar(B[S], Chars[1], GetColor(2), 1); + WriteBuf(0, 0, Size.X, Size.Y, B); +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TScroller OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TScroller----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TScroller.Init (Var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar); +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR ofSelectable; { View is selectable } + EventMask := EventMask OR evBroadcast; { See broadcasts } + HScrollBar := AHScrollBar; { Hold horz scrollbar } + VScrollBar := AVScrollBar; { Hold vert scrollbar } +END; + +{--TScroller----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +{ This load method will read old original TV data from a stream as well } +{ as the new graphical scroller views. } +{---------------------------------------------------------------------------} +CONSTRUCTOR TScroller.Load (Var S: TStream); +VAR i: SmallInt; +BEGIN + Inherited Load(S); { Call ancestor } + GetPeerViewPtr(S, HScrollBar); { Load horz scrollbar } + GetPeerViewPtr(S, VScrollBar); { Load vert scrollbar } + S.Read(i, SizeOf(i)); Delta.X:=i; { Read delta x value } + S.Read(i, SizeOf(i)); Delta.Y:=i; { Read delta y value } + S.Read(i, SizeOf(i)); Limit.X:=i; { Read limit x value } + S.Read(i, SizeOf(i)); Limit.Y:=i; { Read limit y value } +END; + +{--TScroller----------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TScroller.GetPalette: PPalette; +CONST P: String[Length(CScroller)] = CScroller; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Scroller palette } +END; + +{--TScroller----------------------------------------------------------------} +{ ScrollTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScroller.ScrollTo (X, Y: Sw_Integer); +BEGIN + Inc(DrawLock); { Set draw lock } + If (HScrollBar<>Nil) Then HScrollBar^.SetValue(X); { Set horz scrollbar } + If (VScrollBar<>Nil) Then VScrollBar^.SetValue(Y); { Set vert scrollbar } + Dec(DrawLock); { Release draw lock } + CheckDraw; { Check need to draw } +END; + +{--TScroller----------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScroller.SetState (AState: Word; Enable: Boolean); + + PROCEDURE ShowSBar (SBar: PScrollBar); + BEGIN + If (SBar <> Nil) Then { Scroll bar valid } + If GetState(sfActive + sfSelected) Then { Check state masks } + SBar^.Show Else SBar^.Hide; { Draw appropriately } + END; + +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState AND (sfActive + sfSelected) <> 0) { Active/select change } + Then Begin + ShowSBar(HScrollBar); { Redraw horz scrollbar } + ShowSBar(VScrollBar); { Redraw vert scrollbar } + End; +END; + +{--TScroller----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +{ The scroller is saved to the stream compatable with the old TV object. } +{---------------------------------------------------------------------------} +PROCEDURE TScroller.Store (Var S: TStream); +VAR i: SmallInt; +BEGIN + TView.Store(S); { Call TView explicitly } + PutPeerViewPtr(S, HScrollBar); { Store horz bar } + PutPeerViewPtr(S, VScrollBar); { Store vert bar } + i:=Delta.X;S.Write(i, SizeOf(i)); { Write delta x value } + i:=Delta.Y;S.Write(i, SizeOf(i)); { Write delta y value } + i:=Limit.X;S.Write(i, SizeOf(i)); { Write limit x value } + i:=Limit.Y;S.Write(i, SizeOf(i)); { Write limit y value } +END; + +{--TScroller----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScroller.HandleEvent (Var Event: TEvent); +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evBroadcast) AND + (Event.Command = cmScrollBarChanged) AND { Scroll bar change } + ((Event.InfoPtr = HScrollBar) OR { Our scrollbar? } + (Event.InfoPtr = VScrollBar)) Then ScrollDraw; { Redraw scroller } +END; + +{--TScroller----------------------------------------------------------------} +{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScroller.ChangeBounds (Var Bounds: TRect); +BEGIN + SetBounds(Bounds); { Set new bounds } + Inc(DrawLock); { Set draw lock } + SetLimit(Limit.X, Limit.Y); { Adjust limits } + Dec(DrawLock); { Release draw lock } + DrawFlag := False; { Clear draw flag } + DrawView; { Redraw now } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TListViewer OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +CONST TvListViewerName = 'LISTBOX'; { Native name } + +{--TListViewer--------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TListViewer.Init (Var Bounds: TRect; ANumCols: Sw_Word; AHScrollBar, + AVScrollBar: PScrollBar); +VAR ArStep, PgStep: Sw_Integer; +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR (ofFirstClick+ofSelectable); { Set options } + EventMask := EventMask OR evBroadcast; { Set event mask } + NumCols := ANumCols; { Hold column number } + If (AVScrollBar <> Nil) Then Begin { Chk vert scrollbar } + If (NumCols = 1) Then Begin { Only one column } + PgStep := Size.Y -1; { Set page size } + ArStep := 1; { Set step size } + End Else Begin { Multiple columns } + PgStep := Size.Y * NumCols; { Set page size } + ArStep := Size.Y; { Set step size } + End; + AVScrollBar^.SetStep(PgStep, ArStep); { Set scroll values } + End; + If (AHScrollBar <> Nil) Then + AHScrollBar^.SetStep(Size.X DIV NumCols, 1); { Set step size } + HScrollBar := AHScrollBar; { Horz scrollbar held } + VScrollBar := AVScrollBar; { Vert scrollbar held } +END; + +{--TListViewer--------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TListViewer.Load (Var S: TStream); +VAR w: Word; +BEGIN + Inherited Load(S); { Call ancestor } + GetPeerViewPtr(S, HScrollBar); { Get horz scrollbar } + GetPeerViewPtr(S, VScrollBar); { Get vert scrollbar } + S.Read(w, SizeOf(w)); NumCols:=w; { Read column number } + S.Read(w, SizeOf(w)); TopItem:=w; { Read top most item } + S.Read(w, SizeOf(w)); Focused:=w; { Read focused item } + S.Read(w, SizeOf(w)); Range:=w; { Read listview range } +END; + +{--TListViewer--------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TListViewer.GetPalette: PPalette; +CONST P: String[Length(CListViewer)] = CListViewer; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TListViewer--------------------------------------------------------------} +{ IsSelected -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TListViewer.IsSelected (Item: Sw_Integer): Boolean; +BEGIN + If (Item = Focused) Then IsSelected := True Else + IsSelected := False; { Selected item } +END; + +{--TListViewer--------------------------------------------------------------} +{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TListViewer.GetText (Item: Sw_Integer; MaxLen: Sw_Integer): Sw_String; +BEGIN { Abstract method } + GetText := ''; { Return empty } +END; + +{--TListViewer--------------------------------------------------------------} +{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.Draw; +VAR I, J, ColWidth, Item, Indent, CurCol: Sw_Integer; + Color: Word; SCOff: Byte; + Text: Sw_String; + B: TDrawBuffer; +BEGIN + ColWidth := Size.X DIV NumCols + 1; { Calc column width } + If (HScrollBar = Nil) Then Indent := 0 Else { Set indent to zero } + Indent := HScrollBar^.Value; { Fetch any indent } + For I := 0 To Size.Y - 1 Do Begin { For each line } + For J := 0 To NumCols-1 Do Begin { For each column } + Item := J*Size.Y + I + TopItem; { Process this item } + CurCol := J*ColWidth; { Current column } + If (State AND (sfSelected + sfActive) = + (sfSelected + sfActive)) AND (Focused = Item) { Focused item } + AND (Range > 0) Then Begin + Color := GetColor(3); { Focused colour } + SetCursor(CurCol+1,I); { Set the cursor } + SCOff := 0; { Zero colour offset } + End Else If (Item < Range) AND IsSelected(Item){ Selected item } + Then Begin + Color := GetColor(4); { Selected color } + SCOff := 2; { Colour offset=2 } + End Else Begin + Color := GetColor(2); { Normal Color } + SCOff := 4; { Colour offset=4 } + End; + MoveChar(B[CurCol], ' ', Color, ColWidth); { Clear buffer } + If (Item < Range) Then Begin { Within text range } + Text := GetText(Item, ColWidth + Indent); { Fetch text } + Text := Copy(Text, Indent, ColWidth); { Select right bit } + MoveStr(B[CurCol+1], Text, Color); { Transfer to buffer } + If ShowMarkers Then Begin +{$ifdef FV_UNICODE} + B[CurCol].ExtendedGraphemeCluster := + SpecialChars[SCOff]; { Set marker character } + B[CurCol+ColWidth-2].ExtendedGraphemeCluster := + SpecialChars[SCOff+1]; { Set marker character } +{$else FV_UNICODE} + WordRec(B[CurCol]).Lo := Byte( + SpecialChars[SCOff]); { Set marker character } + WordRec(B[CurCol+ColWidth-2]).Lo := Byte( + SpecialChars[SCOff+1]); { Set marker character } +{$endif FV_UNICODE} + End; + End; +{$ifdef FV_UNICODE} + MoveChar(B[CurCol+ColWidth-1], #$2502, + GetColor(5), 1); { Put centre line marker } +{$else FV_UNICODE} + MoveChar(B[CurCol+ColWidth-1], #179, + GetColor(5), 1); { Put centre line marker } +{$endif FV_UNICODE} + End; + WriteLine(0, I, Size.X, 1, B); { Write line to screen } + End; +END; + + +{--TListViewer--------------------------------------------------------------} +{ FocusItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.FocusItem (Item: Sw_Integer); +BEGIN + Focused := Item; { Set focus to item } + If (VScrollBar <> Nil) Then + VScrollBar^.SetValue(Item); { Scrollbar to value } + If (Item < TopItem) Then { Item above top item } + If (NumCols = 1) Then TopItem := Item { Set top item } + Else TopItem := Item - Item MOD Size.Y { Set top item } + Else If (Item >= TopItem + (Size.Y*NumCols)) Then { Item below bottom } + If (NumCols = 1) Then TopItem := Item-Size.Y+1 { Set new top item } + Else TopItem := Item - Item MOD Size.Y - + (Size.Y*(NumCols-1)); { Set new top item } +END; + +{--TListViewer--------------------------------------------------------------} +{ SetTopItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Aug99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.SetTopItem (Item: Sw_Integer); +BEGIN + TopItem := Item; { Set the top item } +END; + +{--TListViewer--------------------------------------------------------------} +{ SetRange -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.SetRange (ARange: Sw_Integer); +BEGIN + Range := ARange; { Set new range } + If (VScrollBar <> Nil) Then Begin { Vertical scrollbar } + If (Focused > ARange) Then Focused := 0; { Clear focused } + VScrollBar^.SetParams(Focused, 0, ARange - 1, + VScrollBar^.PgStep, VScrollBar^.ArStep); { Set parameters } + End; +END; + +{--TListViewer--------------------------------------------------------------} +{ SelectItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.SelectItem (Item: Sw_Integer); +BEGIN + Message(Owner, evBroadcast, cmListItemSelected, + @Self); { Send message } +END; + +{--TListViewer--------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.SetState (AState: Word; Enable: Boolean); + + PROCEDURE ShowSBar(SBar: PScrollBar); + BEGIN + If (SBar <> Nil) Then { Valid scrollbar } + If GetState(sfActive) AND GetState(sfVisible) { Check states } + Then SBar^.Show Else SBar^.Hide; { Show or hide } + END; + +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState AND (sfSelected + sfActive + sfVisible) <> 0) + Then Begin { Check states } + DrawView; { Draw the view } + ShowSBar(HScrollBar); { Show horz scrollbar } + ShowSBar(VScrollBar); { Show vert scrollbar } + End; +END; + +{--TListViewer--------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.Store (Var S: TStream); +VAR w: Word; +BEGIN + TView.Store(S); { Call TView explicitly } + PutPeerViewPtr(S, HScrollBar); { Put horz scrollbar } + PutPeerViewPtr(S, VScrollBar); { Put vert scrollbar } + w:=NumCols;S.Write(w, SizeOf(w)); { Write column number } + w:=TopItem;S.Write(w, SizeOf(w)); { Write top most item } + w:=Focused;S.Write(w, SizeOf(w)); { Write focused item } + w:=Range;S.Write(w, SizeOf(w)); { Write listview range } +END; + +{--TListViewer--------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.HandleEvent (Var Event: TEvent); +CONST MouseAutosToSkip = 4; +VAR Oi, Ni: Sw_Integer; Ct, Cw: Word; Mouse: TPoint; + + PROCEDURE MoveFocus (Req: Sw_Integer); + BEGIN + FocusItemNum(Req); { Focus req item } + DrawView; { Redraw focus box } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evKeyDown: Begin { Key down event } + If (Event.CharCode = ' ') AND (Focused < Range){ Spacebar select } + Then Begin + SelectItem(Focused); { Select focused item } + Ni := Focused; { Hold new item } + End Else Case CtrlToArrow(Event.KeyCode) Of + kbUp: Ni := Focused - 1; { One item up } + kbDown: Ni := Focused + 1; { One item down } + kbRight: If (NumCols > 1) Then + Ni := Focused + Size.Y Else Exit; { One column right } + kbLeft: If (NumCols > 1) Then + Ni := Focused - Size.Y Else Exit; { One column left } + kbPgDn: Ni := Focused + Size.Y * NumCols; { One page down } + kbPgUp: Ni := Focused - Size.Y * NumCols; { One page up } + kbHome: Ni := TopItem; { Move to top } + kbEnd: Ni := TopItem + (Size.Y*NumCols)-1; { Move to bottom } + kbCtrlPgDn: Ni := Range - 1; { Move to last item } + kbCtrlPgUp: Ni := 0; { Move to first item } + Else Exit; + End; + MoveFocus(Ni); { Move the focus } + ClearEvent(Event); { Event was handled } + End; + evBroadcast: Begin { Broadcast event } + If (Options AND ofSelectable <> 0) Then { View is selectable } + If (Event.Command = cmScrollBarClicked) AND { Scrollbar click } + ((Event.InfoPtr = HScrollBar) OR + (Event.InfoPtr = VScrollBar)) Then Select { Scrollbar selects us } + Else If (Event.Command = cmScrollBarChanged) { Scrollbar changed } + Then Begin + If (VScrollBar = Event.InfoPtr) Then Begin + MoveFocus(VScrollBar^.Value); { Focus us to item } + End Else If (HScrollBar = Event.InfoPtr) + Then DrawView; { Redraw the view } + End; + End; + evMouseDown: Begin { Mouse down event } + Cw := Size.X DIV NumCols + 1; { Column width } + Oi := Focused; { Hold focused item } + MakeLocal(Event.Where, Mouse); { Localize mouse } + If MouseInView(Event.Where) Then Ni := Mouse.Y + + (Size.Y*(Mouse.X DIV Cw))+TopItem { Calc item to focus } + Else Ni := Oi; { Focus old item } + Ct := 0; { Clear count value } + Repeat + If (Ni <> Oi) Then Begin { Item is different } + MoveFocus(Ni); { Move the focus } + Oi := Focused; { Hold as focused item } + End; + MakeLocal(Event.Where, Mouse); { Localize mouse } + If NOT MouseInView(Event.Where) Then Begin + If (Event.What = evMouseAuto) Then Inc(Ct);{ Inc auto count } + If (Ct = MouseAutosToSkip) Then Begin + Ct := 0; { Reset count } + If (NumCols = 1) Then Begin { Only one column } + If (Mouse.Y < 0) Then Ni := Focused-1; { Move up one item } + If (Mouse.Y >= Size.Y) Then + Ni := Focused+1; { Move down one item } + End Else Begin { Multiple columns } + If (Mouse.X < 0) Then { Mouse x below zero } + Ni := Focused-Size.Y; { Move down 1 column } + If (Mouse.X >= Size.X) Then { Mouse x above width } + Ni := Focused+Size.Y; { Move up 1 column } + If (Mouse.Y < 0) Then { Mouse y below zero } + Ni := Focused-Focused MOD Size.Y; { Move up one item } + If (Mouse.Y > Size.Y) Then { Mouse y above height } + Ni := Focused-Focused MOD + Size.Y+Size.Y-1; { Move down one item } + End; + End; + End Else Ni := Mouse.Y + (Size.Y*(Mouse.X + DIV Cw))+TopItem; { New item to focus } + Until NOT MouseEvent(Event, evMouseMove + + evMouseAuto); { Mouse stopped } + If (Oi <> Ni) Then MoveFocus(Ni); { Focus moved again } + If (Event.Double AND (Range > Focused)) Then + SelectItem(Focused); { Select the item } + ClearEvent(Event); { Event was handled } + End; + End; +END; + +{--TListViewer--------------------------------------------------------------} +{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.ChangeBounds (Var Bounds: TRect); +BEGIN + Inherited ChangeBounds(Bounds); { Call ancestor } + If (HScrollBar <> Nil) Then { Valid horz scrollbar } + HScrollBar^.SetStep(Size.X DIV NumCols, + HScrollBar^.ArStep); { Update horz bar } + If (VScrollBar <> Nil) Then { Valid vert scrollbar } + VScrollBar^.SetStep(Size.Y * NumCols, + VScrollBar^.ArStep); { Update vert bar } +END; + +{***************************************************************************} +{ TListViewer OBJECT PRIVATE METHODS } +{***************************************************************************} + +{--TListViewer--------------------------------------------------------------} +{ FocusItemNum -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.FocusItemNum (Item: Sw_Integer); +BEGIN + If (Item < 0) Then Item := 0 Else { Restrain underflow } + If (Item >= Range) AND (Range > 0) Then + Item := Range-1; { Restrain overflow } + If (Range <> 0) Then FocusItem(Item); { Set focus value } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TWindow OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TWindow------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TWindow.Init (Var Bounds: TRect; ATitle: TTitleStr; ANumber: Sw_Integer); +BEGIN + Inherited Init(Bounds); { Call ancestor } + State := State OR sfShadow; { View is shadowed } + Options := Options OR (ofSelectable+ofTopSelect); { Select options set } + GrowMode := gfGrowAll + gfGrowRel; { Set growmodes } + Flags := wfMove + wfGrow + wfClose + wfZoom; { Set flags } +{$ifdef FV_UNICODE} + Title := ATitle; { Hold title } +{$else FV_UNICODE} + Title := NewStr(ATitle); { Hold title } +{$endif FV_UNICODE} + Number := ANumber; { Hold number } + Palette := wpBlueWindow; { Default palette } + InitFrame; { Initialize frame } + If (Frame <> Nil) Then Insert(Frame); { Insert any frame } + GetBounds(ZoomRect); { Default zoom rect } +END; + +{--TWindow------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +{ This load method will read old original TV data from a stream however } +{ although a frame view is read for compatability it is disposed of. } +{---------------------------------------------------------------------------} +CONSTRUCTOR TWindow.Load (Var S: TStream); +VAR I: SmallInt; +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(Flags, SizeOf(Flags)); { Read window flags } + S.Read(i, SizeOf(i)); Number:=i; { Read window number } + S.Read(i, SizeOf(i)); Palette:=i; { Read window palette } + S.Read(i, SizeOf(i)); ZoomRect.A.X:=i; { Read zoom area x1 } + S.Read(i, SizeOf(i)); ZoomRect.A.Y:=i; { Read zoom area y1 } + S.Read(i, SizeOf(i)); ZoomRect.B.X:=i; { Read zoom area x2 } + S.Read(i, SizeOf(i)); ZoomRect.B.Y:=i; { Read zoom area y2 } + GetSubViewPtr(S, Frame); { Now read frame object } +{$ifdef FV_UNICODE} + Title := S.ReadUnicodeString; { Read title } +{$else FV_UNICODE} + Title := S.ReadStr; { Read title } +{$endif FV_UNICODE} +END; + +{--TWindow------------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TWindow.Done; +BEGIN + Inherited Done; { Call ancestor } +{$ifndef FV_UNICODE} + If (Title <> Nil) Then DisposeStr(Title); { Dispose title } +{$endif FV_UNICODE} +END; + +{--TWindow------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TWindow.GetPalette: PPalette; +CONST P: ARRAY [wpBlueWindow..wpGrayWindow] Of String[Length(CBlueWindow)] = + (CBlueWindow, CCyanWindow, CGrayWindow); { Always normal string } +BEGIN + GetPalette := PPalette(@P[Palette]); { Return palette } +END; + +{--TWindow------------------------------------------------------------------} +{ GetTitle -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{ Modified 31may2002 PM (No number included anymore) } +{---------------------------------------------------------------------------} +FUNCTION TWindow.GetTitle (MaxSize: Sw_Integer): TTitleStr; +VAR S: Sw_String; +BEGIN +{$ifdef FV_UNICODE} + S:=Title; +{$else FV_UNICODE} + If (Title <> Nil) Then S:=Title^ + Else S := ''; +{$endif FV_UNICODE} + if Length(S)>MaxSize then + GetTitle:=Copy(S,1,MaxSize) + else + GetTitle:=S; +END; + +{--TWindow------------------------------------------------------------------} +{ StandardScrollBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TWindow.StandardScrollBar (AOptions: Word): PScrollBar; +VAR R: TRect; S: PScrollBar; +BEGIN + GetExtent(R); { View extents } + If (AOptions AND sbVertical = 0) Then + R.Assign(R.A.X+2, R.B.Y-1, R.B.X-2, R.B.Y) { Horizontal scrollbar } + Else R.Assign(R.B.X-1, R.A.Y+1, R.B.X, R.B.Y-1); { Vertical scrollbar } + S := New(PScrollBar, Init(R)); { Create scrollbar } + Insert(S); { Insert scrollbar } + If (AOptions AND sbHandleKeyboard <> 0) Then + S^.Options := S^.Options or ofPostProcess; { Post process } + StandardScrollBar := S; { Return scrollbar } +END; + +{--TWindow------------------------------------------------------------------} +{ Zoom -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.Zoom; +VAR R: TRect; Max, Min: TPoint; +BEGIN + SizeLimits(Min, Max); { Return size limits } + If ((Size.X <> Max.X) OR (Size.Y <> Max.Y)) { Larger size possible } + Then Begin + GetBounds(ZoomRect); { Get zoom bounds } + R.A.X := 0; { Zero x origin } + R.A.Y := 0; { Zero y origin } + R.B := Max; { Bounds to max size } + Locate(R); { Locate the view } + End Else Locate(ZoomRect); { Move to zoom rect } +END; + +{--TWindow------------------------------------------------------------------} +{ Close -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.Close; +BEGIN + If Valid(cmClose) Then Free; { Dispose of self } +END; + +{--TWindow------------------------------------------------------------------} +{ InitFrame -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.InitFrame; +VAR + R: TRect; +BEGIN + GetExtent(R); + Frame := New(PFrame, Init(R)); +END; + +{--TWindow------------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Mar98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.SetState (AState: Word; Enable: Boolean); +VAR WindowCommands: TCommandSet; +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState = sfSelected) Then + SetState(sfActive, Enable); { Set active state } + If (AState = sfSelected) OR ((AState = sfExposed) + AND (State AND sfSelected <> 0)) Then Begin { View is selected } + WindowCommands := [cmNext, cmPrev]; { Set window commands } + If (Flags AND (wfGrow + wfMove) <> 0) Then + WindowCommands := WindowCommands + [cmResize]; { Add resize command } + If (Flags AND wfClose <> 0) Then + WindowCommands := WindowCommands + [cmClose]; { Add close command } + If (Flags AND wfZoom <> 0) Then + WindowCommands := WindowCommands + [cmZoom]; { Add zoom command } + If Enable Then EnableCommands(WindowCommands) { Enable commands } + Else DisableCommands(WindowCommands); { Disable commands } + End; +END; + +{--TWindow------------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Mar98 LdB } +{---------------------------------------------------------------------------} +{ You can save data to the stream compatable with the old original TV by } +{ temporarily turning off the ofGrafVersion making the call to this store } +{ routine and resetting the ofGrafVersion flag after the call. } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.Store (Var S: TStream); +VAR i: SmallInt; +BEGIN + TGroup.Store(S); { Call group store } + S.Write(Flags, SizeOf(Flags)); { Write window flags } + i:=Number;S.Write(i, SizeOf(i)); { Write window number } + i:=Palette;S.Write(i, SizeOf(i)); { Write window palette } + i:=ZoomRect.A.X;S.Write(i, SizeOf(i)); { Write zoom area x1 } + i:=ZoomRect.A.Y;S.Write(i, SizeOf(i)); { Write zoom area y1 } + i:=ZoomRect.B.X;S.Write(i, SizeOf(i)); { Write zoom area x2 } + i:=ZoomRect.B.Y;S.Write(i, SizeOf(i)); { Write zoom area y2 } + PutSubViewPtr(S, Frame); { Write any frame } +{$ifdef FV_UNICODE} + S.WriteUnicodeString(Title); { Write title string } +{$else FV_UNICODE} + S.WriteStr(Title); { Write title string } +{$endif FV_UNICODE} +END; + +{--TWindow------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11Aug99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.HandleEvent (Var Event: TEvent); +VAR + Min, Max: TPoint; Limits: TRect; + + PROCEDURE DragWindow (Mode: Byte); + VAR Limits: TRect; Min, Max: TPoint; + BEGIN + Owner^.GetExtent(Limits); { Get owner extents } + SizeLimits(Min, Max); { Restrict size } + DragView(Event, DragMode OR Mode, Limits, Min, + Max); { Drag the view } + ClearEvent(Event); { Clear the event } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speeds up exit } + evCommand: { COMMAND EVENT } + Case Event.Command Of { Command type case } + cmResize: { RESIZE COMMAND } + If (Flags AND (wfMove + wfGrow) <> 0) { Window can resize } + AND (Owner <> Nil) Then Begin { Valid owner } + Owner^.GetExtent(Limits); { Owners extents } + SizeLimits(Min, Max); { Check size limits } + DragView(Event, DragMode OR (Flags AND + (wfMove + wfGrow)), Limits, Min, Max); { Drag the view } + ClearEvent(Event); { Clear the event } + End; + cmClose: { CLOSE COMMAND } + If (Flags AND wfClose <> 0) AND { Close flag set } + ((Event.InfoPtr = Nil) OR { None specific close } + (Event.InfoPtr = @Self)) Then Begin { Close to us } + ClearEvent(Event); { Clear the event } + If (State AND sfModal = 0) Then Close { Non modal so close } + Else Begin { Modal window } + Event.What := evCommand; { Command event } + Event.Command := cmCancel; { Cancel command } + PutEvent(Event); { Place on queue } + ClearEvent(Event); { Clear the event } + End; + End; + cmZoom: { ZOOM COMMAND } + If (Flags AND wfZoom <> 0) AND { Zoom flag set } + ((Event.InfoPtr = Nil) OR { No specific zoom } + (Event.InfoPtr = @Self)) Then Begin + Zoom; { Zoom our window } + ClearEvent(Event); { Clear the event } + End; + End; + evBroadcast: { BROADCAST EVENT } + If (Event.Command = cmSelectWindowNum) AND + (Event.InfoInt = Number) AND { Select our number } + (Options AND ofSelectable <> 0) Then Begin { Is view selectable } + Select; { Select our view } + ClearEvent(Event); { Clear the event } + End; + evKeyDown: Begin { KEYDOWN EVENT } + Case Event.KeyCode Of + kbTab: Begin { TAB KEY } + FocusNext(False); { Select next view } + ClearEvent(Event); { Clear the event } + End; + kbShiftTab: Begin { SHIFT TAB KEY } + FocusNext(True); { Select prior view } + ClearEvent(Event); { Clear the event } + End; + End; + End; + End; { Event.What case end } +END; + +{--TWindow------------------------------------------------------------------} +{ SizeLimits -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.SizeLimits (Var Min, Max: TPoint); +BEGIN + Inherited SizeLimits(Min, Max); { View size limits } + Min.X := MinWinSize.X; { Set min x size } + Min.Y := MinWinSize.Y; { Set min y size } +END; + + + +{--TView--------------------------------------------------------------------} +{ Exposed -> Platforms DOS/DPMI/WIN/OS2 - Checked 17Sep97 LdB } +{---------------------------------------------------------------------------} +function TView.do_ExposedRec1(x1,x2:sw_integer; p:PView):boolean; +var + G : PGroup; + dy,dx : sw_integer; +begin + while true do + begin + p:=p^.Next; + G:=p^.Owner; + if p=staticVar2.target then + begin + do_exposedRec1:=do_exposedRec2(x1,x2,G); + Exit; + end; + dy:=p^.origin.y; + dx:=p^.origin.x; + if ((p^.state and sfVisible)<>0) and (staticVar2.y>=dy) then + begin + if staticVar2.y<dy+p^.size.y then + begin + if x1<dx then + begin + if x2<=dx then + continue; + if x2>dx+p^.size.x then + begin + if do_exposedRec1(x1,dx,p) then + begin + do_exposedRec1:=True; + Exit; + end; + x1:=dx+p^.size.x; + end + else + x2:=dx; + end + else + begin + if x1<dx+p^.size.x then + x1:=dx+p^.size.x; + if x1>=x2 then + begin + do_exposedRec1:=False; + Exit; + end; + end; + end; + end; + end; +end; + + +function TView.do_ExposedRec2(x1,x2:Sw_integer; p:PView):boolean; +var + G : PGroup; + savedStat : TStatVar2; +begin + if (p^.state and sfVisible)=0 then + do_ExposedRec2:=false + else + begin + G:=p^.Owner; + if (G=Nil) or (G^.Buffer<>Nil) then + do_ExposedRec2:=true + else + begin + savedStat:=staticVar2; + inc(staticVar2.y,p^.origin.y); + inc(x1,p^.origin.x); + inc(x2,p^.origin.x); + staticVar2.target:=p; + if (staticVar2.y<G^.clip.a.y) or (staticVar2.y>=G^.clip.b.y) then + do_ExposedRec2:=false + else + begin + if (x1<G^.clip.a.x) then + x1:=G^.clip.a.x; + if (x2>G^.clip.b.x) then + x2:=G^.clip.b.x; + if (x1>=x2) then + do_ExposedRec2:=false + else + do_ExposedRec2:=do_exposedRec1(x1,x2,G^.Last); + end; + staticVar2 := savedStat; + end; + end; +end; + + +function TView.Exposed: Boolean; +var + OK : boolean; + y : sw_integer; +begin + if ((State and sfExposed)<>0) and (Size.X>0) and (Size.Y>0) then + begin + OK:=false; + y:=0; + while (y<Size.Y) and (not OK) do + begin + staticVar2.y:=y; + OK:=do_ExposedRec2(0,Size.X,@Self); + inc(y); + end; + Exposed:=OK; + end + else + Exposed:=False +end; + + +{--TView--------------------------------------------------------------------} +{ MakeLocal -> Platforms DOS/DPMI/WIN/OS2 - Checked 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.MakeLocal (Source: TPoint; Var Dest: TPoint); +var + cur : PView; +begin + cur:=@Self; + Dest:=Source; + repeat + dec(Dest.X,cur^.Origin.X); + if dest.x<0 then + break; + dec(Dest.Y,cur^.Origin.Y); + if dest.y<0 then + break; + cur:=cur^.Owner; + until cur=nil; +end; + + +{--TView--------------------------------------------------------------------} +{ MakeGlobal -> Platforms DOS/DPMI/WIN/OS2 - Checked 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.MakeGlobal (Source: TPoint; Var Dest: TPoint); +var + cur : PView; +begin + cur:=@Self; + Dest:=Source; + repeat + inc(Dest.X,cur^.Origin.X); + inc(Dest.Y,cur^.Origin.Y); + cur:=cur^.Owner; + until cur=nil; +end; + + +procedure TView.do_writeViewRec1(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); +var + G : PGroup; +{$ifdef FV_UNICODE} + c : TEnhancedVideoCell; +{$else FV_UNICODE} + c : Word; +{$endif FV_UNICODE} + BufPos, + SrcPos, + l,dx : Sw_integer; +begin + repeat + p:=p^.Next; + if (p=staticVar2.target) then + begin + G:=p^.Owner; + if (G^.buffer<>Nil) then + begin + BufPos:=G^.size.x * staticVar2.y + x1; + SrcPos:=x1 - staticVar2.offset; + l:=x2-x1; + if (shadowCounter=0) then + begin +{$ifdef FV_UNICODE} + while (l>0) do + begin + PVideoBuf(G^.buffer)^[BufPos]:=staticVar1^[SrcPos]; + inc(BufPos); + inc(SrcPos); + dec(l); + end; +{$else FV_UNICODE} + move(staticVar1^[SrcPos],PVideoBuf(G^.buffer)^[BufPos],l shl 1) +{$endif FV_UNICODE} + end + else + begin { paint with shadowAttr } + while (l>0) do + begin + c:=staticVar1^[SrcPos]; +{$ifdef FV_UNICODE} + c.Attribute:=shadowAttr; +{$else FV_UNICODE} + WordRec(c).hi:=shadowAttr; +{$endif FV_UNICODE} + PVideoBuf(G^.buffer)^[BufPos]:=c; + inc(BufPos); + inc(SrcPos); + dec(l); + end; + end; + end; + if G^.lockFlag=0 then + do_writeViewRec2(x1,x2,G,shadowCounter); + exit; + end; { p=staticVar2.target } + + if ((p^.state and sfVisible)<>0) and (staticVar2.y>=p^.Origin.Y) then + begin + if staticVar2.y<p^.Origin.Y+p^.size.Y then + begin + if x1<p^.origin.x then + begin + if x2<=p^.origin.x then + continue; + do_writeViewRec1(x1,p^.origin.x,p,shadowCounter); + x1:=p^.origin.x; + end; + dx:=p^.origin.x+p^.size.x; + if (x2<=dx) then + exit; + if (x1<dx) then + x1:=dx; + inc(dx,shadowSize.x); + if ((p^.state and sfShadow)<>0) and (staticVar2.y>=p^.origin.y+shadowSize.y) then + if (x1>dx) then + continue + else + begin + inc(shadowCounter); + if (x2<=dx) then + continue + else + begin + do_writeViewRec1(x1,dx,p,shadowCounter); + x1:=dx; + dec(shadowCounter); + continue; + end; + end + else + continue; + end; + + if ((p^.state and sfShadow)<>0) and (staticVar2.y<p^.origin.y+p^.size.y+shadowSize.y) then + begin + dx:=p^.origin.x+shadowSize.x; + if x1<dx then + begin + if x2<=dx then + continue; + do_writeViewRec1(x1,dx,p,shadowCounter); + x1:=dx; + end; + inc(dx,p^.size.x); + if x1>=dx then + continue; + inc(shadowCounter); + if x2<=dx then + continue + else + begin + do_writeViewRec1(x1,dx,p,shadowCounter); + x1:=dx; + dec(shadowCounter); + end; + end; + end; + until false; +end; + + +procedure TView.do_writeViewRec2(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); +var + savedStatics : TstatVar2; + dx : Sw_integer; + G : PGroup; +begin + G:=P^.Owner; + if ((p^.State and sfVisible) <> 0) and (G<>Nil) then + begin + savedStatics:=staticVar2; + inc(staticVar2.y,p^.Origin.Y); + dx:=p^.Origin.X; + inc(x1,dx); + inc(x2,dx); + inc(staticVar2.offset,dx); + staticVar2.target:=p; + if (staticVar2.y >= G^.clip.a.y) and (staticVar2.y < G^.clip.b.y) then + begin + if (x1<g^.clip.a.x) then + x1 := g^.clip.a.x; + if (x2>g^.clip.b.x) then + x2 := g^.clip.b.x; + if x1<x2 then + do_writeViewRec1(x1,x2,G^.Last,shadowCounter); + end; + staticVar2 := savedStatics; + end; +end; + + +procedure TView.do_WriteView(x1,x2,y:Sw_integer; var Buf); +begin + if (y>=0) and (y<Size.Y) then + begin + if x1<0 then + x1:=0; + if x2>Size.X then + x2:=Size.X; + if x1<x2 then + begin + staticVar2.offset:=x1; + staticVar2.y:=y; + staticVar1:=@Buf; + do_writeViewRec2( x1, x2, @Self, 0 ); + end; + end; +end; + + +procedure TView.WriteBuf(X, Y, W, H: Sw_Integer; var Buf); +var + i : Sw_integer; +begin + if h>0 then + for i:= 0 to h-1 do + do_writeView(X,X+W,Y+i,TVideoBuf(Buf)[W*i]); +end; + + +{$ifdef FV_UNICODE} +procedure TView.WriteChar(X,Y:Sw_Integer; C:UnicodeString; Color:Byte; Count:Sw_Integer); +{$else FV_UNICODE} +procedure TView.WriteChar(X,Y:Sw_Integer; C:Char; Color:Byte; Count:Sw_Integer); +{$endif FV_UNICODE} +var + B : TDrawBuffer; +{$ifdef FV_UNICODE} + myChar : TEnhancedVideoCell; +{$else FV_UNICODE} + myChar : word; +{$endif FV_UNICODE} + i : Sw_integer; +begin +{$ifdef FV_UNICODE} + myChar.Attribute:=MapColor(Color); + myChar.ExtendedGraphemeCluster:=C; +{$else FV_UNICODE} + myChar:=MapColor(Color); + myChar:=(myChar shl 8) + ord(C); +{$endif FV_UNICODE} + if Count>0 then + begin + if Count>maxViewWidth then + Count:=maxViewWidth; + for i:=0 to Count-1 do + B[i]:=myChar; + do_writeView(X,X+Count,Y,B); + end; + DrawScreenBuf(false); +end; + + +procedure TView.WriteLine(X, Y, W, H: Sw_Integer; var Buf); +var + i:Sw_integer; +begin + if h>0 then + for i:=0 to h-1 do + do_writeView(x,x+w,y+i,buf); + DrawScreenBuf(false); +end; + + +procedure TView.WriteStr(X, Y: Sw_Integer; Str: Sw_String; Color: Byte); +var +{$ifdef FV_UNICODE} + EGC: Sw_String; +{$endif FV_UNICODE} + l,i : Sw_word; + B : TDrawBuffer; + myColor : word; +begin + l:=StrWidth(Str); + if l>0 then + begin + if l>maxViewWidth then + l:=maxViewWidth; + MyColor:=MapColor(Color); +{$ifdef FV_UNICODE} + i:=0; + for EGC in TUnicodeStringExtendedGraphemeClustersEnumerator.Create(Str) do + begin + with B[i] do + begin + Attribute:=MyColor; + ExtendedGraphemeCluster:=EGC; + end; + Inc(i, EgcWidth(EGC)); + end; +{$else FV_UNICODE} + MyColor:=MyColor shl 8; + for i:=0 to l-1 do + B[i]:=MyColor+ord(Str[i+1]); +{$endif FV_UNICODE} + do_writeView(x,x+l,y,b); + end; + DrawScreenBuf(false); +end; + + +procedure TView.DragView(Event: TEvent; Mode: Byte; + var Limits: TRect; MinSize, MaxSize: TPoint); +var + P, S: TPoint; + SaveBounds: TRect; + + procedure MoveGrow(P, S: TPoint); + var + R: TRect; + begin + S.X := Min(Max(S.X, MinSize.X), MaxSize.X); + S.Y := Min(Max(S.Y, MinSize.Y), MaxSize.Y); + P.X := Min(Max(P.X, Limits.A.X - S.X + 1), Limits.B.X - 1); + P.Y := Min(Max(P.Y, Limits.A.Y - S.Y + 1), Limits.B.Y - 1); + if Mode and dmLimitLoX <> 0 then P.X := Max(P.X, Limits.A.X); + if Mode and dmLimitLoY <> 0 then P.Y := Max(P.Y, Limits.A.Y); + if Mode and dmLimitHiX <> 0 then P.X := Min(P.X, Limits.B.X - S.X); + if Mode and dmLimitHiY <> 0 then P.Y := Min(P.Y, Limits.B.Y - S.Y); + R.Assign(P.X, P.Y, P.X + S.X, P.Y + S.Y); + Locate(R); + end; + + procedure Change(DX, DY: Sw_Integer); + begin + if (Mode and dmDragMove <> 0) and (Event.KeyShift{GetShiftState} and $03 = 0) then + begin + Inc(P.X, DX); + Inc(P.Y, DY); + end else + if (Mode and dmDragGrow <> 0) and (Event.KeyShift{GetShiftState} and $03 <> 0) then + begin + Inc(S.X, DX); + Inc(S.Y, DY); + end; + end; + + procedure Update(X, Y: Sw_Integer); + begin + if Mode and dmDragMove <> 0 then + begin + P.X := X; + P.Y := Y; + end; + end; + +begin + SetState(sfDragging, True); + if Event.What = evMouseDown then + begin + if Mode and dmDragMove <> 0 then + begin + P.X := Origin.X - Event.Where.X; + P.Y := Origin.Y - Event.Where.Y; + repeat + Inc(Event.Where.X, P.X); + Inc(Event.Where.Y, P.Y); + MoveGrow(Event.Where, Size); + until not MouseEvent(Event, evMouseMove); + {We need to process the mouse-up event, since not all terminals + send drag events.} + Inc(Event.Where.X, P.X); + Inc(Event.Where.Y, P.Y); + MoveGrow(Event.Where, Size); + end else + begin + P.X := Size.X - Event.Where.X; + P.Y := Size.Y - Event.Where.Y; + repeat + Inc(Event.Where.X, P.X); + Inc(Event.Where.Y, P.Y); + MoveGrow(Origin, Event.Where); + until not MouseEvent(Event, evMouseMove); + {We need to process the mouse-up event, since not all terminals + send drag events.} + Inc(Event.Where.X, P.X); + Inc(Event.Where.Y, P.Y); + MoveGrow(Origin, Event.Where); + end; + end else + begin + GetBounds(SaveBounds); + repeat + P := Origin; + S := Size; + KeyEvent(Event); + case Event.KeyCode and $FF00 of + kbLeft: Change(-1, 0); + kbRight: Change(1, 0); + kbUp: Change(0, -1); + kbDown: Change(0, 1); + kbCtrlLeft: Change(-8, 0); + kbCtrlRight: Change(8, 0); + kbHome: Update(Limits.A.X, P.Y); + kbEnd: Update(Limits.B.X - S.X, P.Y); + kbPgUp: Update(P.X, Limits.A.Y); + kbPgDn: Update(P.X, Limits.B.Y - S.Y); + end; + MoveGrow(P, S); + until (Event.KeyCode = kbEnter) or (Event.KeyCode = kbEsc); + if Event.KeyCode = kbEsc then + Locate(SaveBounds); + end; + SetState(sfDragging, False); +end; + + +{***************************************************************************} +{ TScroller OBJECT METHODS } +{***************************************************************************} + +PROCEDURE TScroller.ScrollDraw; +VAR D: TPoint; +BEGIN + If (HScrollBar<>Nil) Then D.X := HScrollBar^.Value + Else D.X := 0; { Horz scroll value } + If (VScrollBar<>Nil) Then D.Y := VScrollBar^.Value + Else D.Y := 0; { Vert scroll value } + If (D.X<>Delta.X) OR (D.Y<>Delta.Y) Then Begin { View has moved } + SetCursor(Cursor.X+Delta.X-D.X, + Cursor.Y+Delta.Y-D.Y); { Move the cursor } + Delta := D; { Set new delta } + If (DrawLock<>0) Then DrawFlag := True { Draw will need draw } + Else DrawView; { Redraw the view } + End; +END; + +PROCEDURE TScroller.SetLimit (X, Y: Sw_Integer); +VAR PState: Word; +BEGIN + Limit.X := X; { Hold x limit } + Limit.Y := Y; { Hold y limit } + Inc(DrawLock); { Set draw lock } + If (HScrollBar<>Nil) Then Begin + PState := HScrollBar^.State; { Hold bar state } + HScrollBar^.State := PState AND NOT sfVisible; { Temp not visible } + HScrollBar^.SetParams(HScrollBar^.Value, 0, + X-Size.X, Size.X-1, HScrollBar^.ArStep); { Set horz scrollbar } + HScrollBar^.State := PState; { Restore bar state } + End; + If (VScrollBar<>Nil) Then Begin + PState := VScrollBar^.State; { Hold bar state } + VScrollBar^.State := PState AND NOT sfVisible; { Temp not visible } + VScrollBar^.SetParams(VScrollBar^.Value, 0, + Y-Size.Y, Size.Y-1, VScrollBar^.ArStep); { Set vert scrollbar } + VScrollBar^.State := PState; { Restore bar state } + End; + Dec(DrawLock); { Release draw lock } + CheckDraw; { Check need to draw } +END; + +{***************************************************************************} +{ TScroller OBJECT PRIVATE METHODS } +{***************************************************************************} +PROCEDURE TScroller.CheckDraw; +BEGIN + If (DrawLock = 0) AND DrawFlag Then Begin { Clear & draw needed } + DrawFlag := False; { Clear draw flag } + DrawView; { Draw now } + End; +END; + + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TGroup OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + + + + +{--TGroup-------------------------------------------------------------------} +{ Lock -> Platforms DOS/DPMI/WIN/OS2 - Checked 23Sep97 LdB } +{---------------------------------------------------------------------------} +{$ifndef NoLock} +{$define UseLock} +{$endif ndef NoLock} +PROCEDURE TGroup.Lock; +BEGIN +{$ifdef UseLock} + {If (Buffer <> Nil) OR (LockFlag <> 0) + Then} Inc(LockFlag); { Increment count } +{$endif UseLock} +END; + +{--TGroup-------------------------------------------------------------------} +{ UnLock -> Platforms DOS/DPMI/WIN/OS2 - Checked 23Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Unlock; +BEGIN +{$ifdef UseLock} + If (LockFlag <> 0) Then Begin + Dec(LockFlag); { Decrement count } + If (LockFlag = 0) Then DrawView; { Lock release draw } + End; +{$endif UseLock} +END; + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ WINDOW MESSAGE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ Message -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION Message (Receiver: PView; What, Command: Word; + InfoPtr: Pointer): Pointer; +VAR Event: TEvent; +BEGIN + Message := Nil; { Preset nil } + If (Receiver <> Nil) Then Begin { Valid receiver } + Event.What := What; { Set what } + Event.Command := Command; { Set command } + Event.Id := 0; { Zero id field } + Event.Data := 0; { Zero data field } + Event.InfoPtr := InfoPtr; { Set info ptr } + Receiver^.HandleEvent(Event); { Pass to handler } + If (Event.What = evNothing) Then + Message := Event.InfoPtr; { Return handler } + End; +END; + +{---------------------------------------------------------------------------} +{ NewMessage -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewMessage (P: PView; What, Command: Word; Id: Sw_Integer; + Data: Real; InfoPtr: Pointer): Pointer; +VAR Event: TEvent; +BEGIN + NewMessage := Nil; { Preset failure } + If (P <> Nil) Then Begin + Event.What := What; { Set what } + Event.Command := Command; { Set event command } + Event.Id := Id; { Set up Id } + Event.Data := Data; { Set up data } + Event.InfoPtr := InfoPtr; { Set up event ptr } + P^.HandleEvent(Event); { Send to view } + If (Event.What = evNothing) Then + NewMessage := Event.InfoPtr; { Return handler } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ NEW VIEW ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ CreateIdScrollBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Checked 22May97 LdB } +{---------------------------------------------------------------------------} +FUNCTION CreateIdScrollBar (X, Y, Size, Id: Sw_Integer; Horz: Boolean): PScrollBar; +VAR R: TRect; P: PScrollBar; +BEGIN + If Horz Then R.Assign(X, Y, X+Size, Y+1) Else { Horizontal bar } + R.Assign(X, Y, X+1, Y+Size); { Vertical bar } + P := New(PScrollBar, Init(R)); { Create scrollbar } + If (P <> Nil) Then Begin + P^.Id := Id; { Set scrollbar id } + P^.Options := P^.Options OR ofPostProcess; { Set post processing } + End; + CreateIdScrollBar := P; { Return scrollbar } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTRATION PROCEDURES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ RegisterViews -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterViews; +BEGIN + RegisterType(RView); { Register views } + RegisterType(RFrame); { Register frame } + RegisterType(RScrollBar); { Register scrollbar } + RegisterType(RScroller); { Register scroller } + RegisterType(RListViewer); { Register listview } + RegisterType(RGroup); { Register group } + RegisterType(RWindow); { Register window } +END; + +END. diff --git a/packages/fv/src/views.pas b/packages/fv/src/views.pas index 7a44ccec42..eb4074092b 100644 --- a/packages/fv/src/views.pas +++ b/packages/fv/src/views.pas @@ -1,4700 +1 @@ -{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} -{ } -{ System independent GRAPHICAL clone of VIEWS.PAS } -{ } -{ Interface Copyright (c) 1992 Borland International } -{ } -{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } -{ ldeboer@attglobal.net - primary e-mail address } -{ ldeboer@starwon.com.au - backup e-mail address } -{ } -{****************[ THIS CODE IS FREEWARE ]*****************} -{ } -{ This sourcecode is released for the purpose to } -{ promote the pascal language on all platforms. You may } -{ redistribute it and/or modify with the following } -{ DISCLAIMER. } -{ } -{ This SOURCE CODE is distributed "AS IS" WITHOUT } -{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } -{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } -{ } -{*****************[ SUPPORTED PLATFORMS ]******************} -{ } -{ Only Free Pascal Compiler supported } -{ } -{**********************************************************} - -UNIT Views; - -{$CODEPAGE cp437} - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - INTERFACE -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -{====Include file to sort compiler platform out =====================} -{$I platform.inc} -{====================================================================} - -{==== Compiler directives ===========================================} - -{$X+} { Extended syntax is ok } -{$R-} { Disable range checking } -{$S-} { Disable Stack Checking } -{$I-} { Disable IO Checking } -{$Q-} { Disable Overflow Checking } -{$V-} { Turn off strict VAR strings } -{====================================================================} - -USES - {$IFDEF OS_WINDOWS} { WIN/NT CODE } - Windows, { Standard unit } - {$ENDIF} - - {$IFDEF OS_OS2} { OS2 CODE } - Os2Def, DosCalls, PmWin, - {$ENDIF} - - Objects, FVCommon, Drivers, fvconsts; { GFV standard units } - -{***************************************************************************} -{ PUBLIC CONSTANTS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TView STATE MASKS } -{---------------------------------------------------------------------------} -CONST - sfVisible = $0001; { View visible mask } - sfCursorVis = $0002; { Cursor visible } - sfCursorIns = $0004; { Cursor insert mode } - sfShadow = $0008; { View has shadow } - sfActive = $0010; { View is active } - sfSelected = $0020; { View is selected } - sfFocused = $0040; { View is focused } - sfDragging = $0080; { View is dragging } - sfDisabled = $0100; { View is disabled } - sfModal = $0200; { View is modal } - sfDefault = $0400; { View is default } - sfExposed = $0800; { View is exposed } - sfIconised = $1000; { View is iconised } - -{---------------------------------------------------------------------------} -{ TView OPTION MASKS } -{---------------------------------------------------------------------------} -CONST - ofSelectable = $0001; { View selectable } - ofTopSelect = $0002; { Top selectable } - ofFirstClick = $0004; { First click react } - ofFramed = $0008; { View is framed } - ofPreProcess = $0010; { Pre processes } - ofPostProcess = $0020; { Post processes } - ofBuffered = $0040; { View is buffered } - ofTileable = $0080; { View is tileable } - ofCenterX = $0100; { View centred on x } - ofCenterY = $0200; { View centred on y } - ofCentered = $0300; { View x,y centred } - ofValidate = $0400; { View validates } - ofVersion = $3000; { View TV version } - ofVersion10 = $0000; { TV version 1 view } - ofVersion20 = $1000; { TV version 2 view } - -{---------------------------------------------------------------------------} -{ TView GROW MODE MASKS } -{---------------------------------------------------------------------------} -CONST - gfGrowLoX = $01; { Left side grow } - gfGrowLoY = $02; { Top side grow } - gfGrowHiX = $04; { Right side grow } - gfGrowHiY = $08; { Bottom side grow } - gfGrowAll = $0F; { Grow on all sides } - gfGrowRel = $10; { Grow relative } - -{---------------------------------------------------------------------------} -{ TView DRAG MODE MASKS } -{---------------------------------------------------------------------------} -CONST - dmDragMove = $01; { Move view } - dmDragGrow = $02; { Grow view } - dmLimitLoX = $10; { Limit left side } - dmLimitLoY = $20; { Limit top side } - dmLimitHiX = $40; { Limit right side } - dmLimitHiY = $80; { Limit bottom side } - dmLimitAll = $F0; { Limit all sides } - -{---------------------------------------------------------------------------} -{ >> NEW << TAB OPTION MASKS } -{---------------------------------------------------------------------------} -CONST - tmTab = $01; { Tab move mask } - tmShiftTab = $02; { Shift+tab move mask } - tmEnter = $04; { Enter move mask } - tmLeft = $08; { Left arrow move mask } - tmRight = $10; { Right arrow move mask } - tmUp = $20; { Up arrow move mask } - tmDown = $40; { Down arrow move mask } - -{---------------------------------------------------------------------------} -{ >> NEW << VIEW DRAW MASKS } -{---------------------------------------------------------------------------} -CONST - vdBackGnd = $01; { Draw backgound } - vdInner = $02; { Draw inner detail } - vdCursor = $04; { Draw cursor } - vdBorder = $08; { Draw view border } - vdFocus = $10; { Draw focus state } - vdNoChild = $20; { Draw no children } - vdShadow = $40; - vdAll = vdBackGnd + vdInner + vdCursor + vdBorder + vdFocus + vdShadow; - -{---------------------------------------------------------------------------} -{ TView HELP CONTEXTS } -{---------------------------------------------------------------------------} -CONST - hcNoContext = 0; { No view context } - hcDragging = 1; { No drag context } - -{---------------------------------------------------------------------------} -{ TWindow FLAG MASKS } -{---------------------------------------------------------------------------} -CONST - wfMove = $01; { Window can move } - wfGrow = $02; { Window can grow } - wfClose = $04; { Window can close } - wfZoom = $08; { Window can zoom } - -{---------------------------------------------------------------------------} -{ TWindow PALETTES } -{---------------------------------------------------------------------------} -CONST - wpBlueWindow = 0; { Blue palette } - wpCyanWindow = 1; { Cyan palette } - wpGrayWindow = 2; { Gray palette } - -{---------------------------------------------------------------------------} -{ COLOUR PALETTES } -{---------------------------------------------------------------------------} -CONST - CFrame = #1#1#2#2#3; { Frame palette } - CScrollBar = #4#5#5; { Scrollbar palette } - CScroller = #6#7; { Scroller palette } - CListViewer = #26#26#27#28#29; { Listviewer palette } - - CBlueWindow = #8#9#10#11#12#13#14#15; { Blue window palette } - CCyanWindow = #16#17#18#19#20#21#22#23; { Cyan window palette } - CGrayWindow = #24#25#26#27#28#29#30#31; { Grey window palette } - -{---------------------------------------------------------------------------} -{ TScrollBar PART CODES } -{---------------------------------------------------------------------------} -CONST - sbLeftArrow = 0; { Left arrow part } - sbRightArrow = 1; { Right arrow part } - sbPageLeft = 2; { Page left part } - sbPageRight = 3; { Page right part } - sbUpArrow = 4; { Up arrow part } - sbDownArrow = 5; { Down arrow part } - sbPageUp = 6; { Page up part } - sbPageDown = 7; { Page down part } - sbIndicator = 8; { Indicator part } - -{---------------------------------------------------------------------------} -{ TScrollBar OPTIONS FOR TWindow.StandardScrollBar } -{---------------------------------------------------------------------------} -CONST - sbHorizontal = $0000; { Horz scrollbar } - sbVertical = $0001; { Vert scrollbar } - sbHandleKeyboard = $0002; { Handle keyboard } - -{---------------------------------------------------------------------------} -{ STANDARD COMMAND CODES } -{---------------------------------------------------------------------------} -CONST - cmValid = 0; { Valid command } - cmQuit = 1; { Quit command } - cmError = 2; { Error command } - cmMenu = 3; { Menu command } - cmClose = 4; { Close command } - cmZoom = 5; { Zoom command } - cmResize = 6; { Resize command } - cmNext = 7; { Next view command } - cmPrev = 8; { Prev view command } - cmHelp = 9; { Help command } - cmOK = 10; { Okay command } - cmCancel = 11; { Cancel command } - cmYes = 12; { Yes command } - cmNo = 13; { No command } - cmDefault = 14; { Default command } - cmCut = 20; { Clipboard cut cmd } - cmCopy = 21; { Clipboard copy cmd } - cmPaste = 22; { Clipboard paste cmd } - cmUndo = 23; { Clipboard undo cmd } - cmClear = 24; { Clipboard clear cmd } - cmTile = 25; { Tile subviews cmd } - cmCascade = 26; { Cascade subviews cmd } - cmReceivedFocus = 50; { Received focus } - cmReleasedFocus = 51; { Released focus } - cmCommandSetChanged = 52; { Commands changed } - cmScrollBarChanged = 53; { Scrollbar changed } - cmScrollBarClicked = 54; { Scrollbar clicked on } - cmSelectWindowNum = 55; { Select window } - cmListItemSelected = 56; { Listview item select } - - cmNotify = 27; - cmIdCommunicate = 28; { Communicate via id } - cmIdSelect = 29; { Select via id } - -{---------------------------------------------------------------------------} -{ TWindow NUMBER CONSTANTS } -{---------------------------------------------------------------------------} -CONST - wnNoNumber = 0; { Window has no num } - MaxViewWidth = 255; { Max view width } - - -{***************************************************************************} -{ PUBLIC TYPE DEFINITIONS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TWindow Title string } -{---------------------------------------------------------------------------} -TYPE - TTitleStr = String[80]; { Window title string } - -{---------------------------------------------------------------------------} -{ COMMAND SET RECORD } -{---------------------------------------------------------------------------} -TYPE - TCommandSet = SET OF Byte; { Command set record } - PCommandSet = ^TCommandSet; { Ptr to command set } - -{---------------------------------------------------------------------------} -{ PALETTE RECORD } -{---------------------------------------------------------------------------} -TYPE - TPalette = String; { Palette record } - PPalette = ^TPalette; { Pointer to palette } - -{---------------------------------------------------------------------------} -{ TDrawBuffer RECORD } -{---------------------------------------------------------------------------} -TYPE - TDrawBuffer = Array [0..MaxViewWidth - 1] Of Word; { Draw buffer record } - PDrawBuffer = ^TDrawBuffer; { Ptr to draw buffer } - -{---------------------------------------------------------------------------} -{ TVideoBuffer RECORD } -{---------------------------------------------------------------------------} -TYPE - TVideoBuf = ARRAY [0..3999] of Word; { Video buffer } - PVideoBuf = ^TVideoBuf; { Pointer to buffer } - -{---------------------------------------------------------------------------} -{ TComplexArea RECORD } -{---------------------------------------------------------------------------} -TYPE - PComplexArea = ^TComplexArea; { Complex area } - TComplexArea = -{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - PACKED -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - RECORD - X1, Y1 : Sw_Integer; { Top left corner } - X2, Y2 : Sw_Integer; { Lower right corner } - NextArea: PComplexArea; { Next area pointer } - END; - -{***************************************************************************} -{ PUBLIC OBJECT DEFINITIONS } -{***************************************************************************} - -TYPE - PGroup = ^TGroup; { Pointer to group } - -{---------------------------------------------------------------------------} -{ TView OBJECT - ANCESTOR VIEW OBJECT } -{---------------------------------------------------------------------------} - PView = ^TView; - TView = OBJECT (TObject) - GrowMode : Byte; { View grow mode } - DragMode : Byte; { View drag mode } - TabMask : Byte; { Tab move masks } - ColourOfs: Sw_Integer; { View palette offset } - HelpCtx : Word; { View help context } - State : Word; { View state masks } - Options : Word; { View options masks } - EventMask: Word; { View event masks } - Origin : TPoint; { View origin } - Size : TPoint; { View size } - Cursor : TPoint; { Cursor position } - Next : PView; { Next peerview } - Owner : PGroup; { Owner group } - HoldLimit: PComplexArea; { Hold limit values } - - RevCol : Boolean; - BackgroundChar : Char; - - CONSTRUCTOR Init (Var Bounds: TRect); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION Prev: PView; - FUNCTION Execute: Word; Virtual; - FUNCTION Focus: Boolean; - FUNCTION DataSize: Sw_Word; Virtual; - FUNCTION TopView: PView; - FUNCTION PrevView: PView; - FUNCTION NextView: PView; - FUNCTION GetHelpCtx: Word; Virtual; - FUNCTION EventAvail: Boolean; - FUNCTION GetPalette: PPalette; Virtual; - function MapColor (color:byte):byte; - FUNCTION GetColor (Color: Word): Word; - FUNCTION Valid (Command: Word): Boolean; Virtual; - FUNCTION GetState (AState: Word): Boolean; - FUNCTION TextWidth (const Txt: String): Sw_Integer; - FUNCTION CTextWidth (const Txt: String): Sw_Integer; - FUNCTION MouseInView (Point: TPoint): Boolean; - FUNCTION CommandEnabled (Command: Word): Boolean; - FUNCTION OverLapsArea (X1, Y1, X2, Y2: Sw_Integer): Boolean; - FUNCTION MouseEvent (Var Event: TEvent; Mask: Word): Boolean; - PROCEDURE Hide; - PROCEDURE Show; - PROCEDURE Draw; Virtual; - PROCEDURE ResetCursor; Virtual; - PROCEDURE Select; - PROCEDURE Awaken; Virtual; - PROCEDURE DrawView; - PROCEDURE MakeFirst; - PROCEDURE DrawCursor; Virtual; - PROCEDURE HideCursor; - PROCEDURE ShowCursor; - PROCEDURE BlockCursor; - PROCEDURE NormalCursor; - PROCEDURE FocusFromTop; Virtual; - PROCEDURE MoveTo (X, Y: Sw_Integer); - PROCEDURE GrowTo (X, Y: Sw_Integer); - PROCEDURE EndModal (Command: Word); Virtual; - PROCEDURE SetCursor (X, Y: Sw_Integer); - PROCEDURE PutInFrontOf (Target: PView); - PROCEDURE SetCommands (Commands: TCommandSet); - PROCEDURE EnableCommands (Commands: TCommandSet); - PROCEDURE DisableCommands (Commands: TCommandSet); - PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; - PROCEDURE SetCmdState (Commands: TCommandSet; Enable: Boolean); - PROCEDURE GetData (Var Rec); Virtual; - PROCEDURE SetData (Var Rec); Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE Locate (Var Bounds: TRect); - PROCEDURE KeyEvent (Var Event: TEvent); - PROCEDURE GetEvent (Var Event: TEvent); Virtual; - PROCEDURE PutEvent (Var Event: TEvent); Virtual; - PROCEDURE GetExtent (Var Extent: TRect); - PROCEDURE GetBounds (Var Bounds: TRect); - PROCEDURE SetBounds (Var Bounds: TRect); - PROCEDURE GetClipRect (Var Clip: TRect); - PROCEDURE ClearEvent (Var Event: TEvent); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; - PROCEDURE SizeLimits (Var Min, Max: TPoint); Virtual; - PROCEDURE GetCommands (Var Commands: TCommandSet); - PROCEDURE GetPeerViewPtr (Var S: TStream; Var P); - PROCEDURE PutPeerViewPtr (Var S: TStream; P: PView); - PROCEDURE CalcBounds (Var Bounds: TRect; Delta: TPoint); Virtual; - - FUNCTION Exposed: Boolean; { This needs help!!!!! } - PROCEDURE WriteBuf (X, Y, W, H: Sw_Integer; Var Buf); - PROCEDURE WriteLine (X, Y, W, H: Sw_Integer; Var Buf); - PROCEDURE MakeLocal (Source: TPoint; Var Dest: TPoint); - PROCEDURE MakeGlobal (Source: TPoint; Var Dest: TPoint); - PROCEDURE WriteStr (X, Y: Sw_Integer; Str: String; Color: Byte); - PROCEDURE WriteChar (X, Y: Sw_Integer; C: Char; Color: Byte; - Count: Sw_Integer); - PROCEDURE DragView (Event: TEvent; Mode: Byte; Var Limits: TRect; - MinSize, MaxSize: TPoint); - private - procedure CursorChanged; - procedure DrawHide(LastView: PView); - procedure DrawShow(LastView: PView); - procedure DrawUnderRect(var R: TRect; LastView: PView); - procedure DrawUnderView(DoShadow: Boolean; LastView: PView); - procedure do_WriteView(x1,x2,y:Sw_Integer; var Buf); - procedure do_WriteViewRec1(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); - procedure do_WriteViewRec2(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); - function do_ExposedRec1(x1,x2:Sw_integer; p:PView):boolean; - function do_ExposedRec2(x1,x2:Sw_integer; p:PView):boolean; - END; - - SelectMode = (NormalSelect, EnterSelect, LeaveSelect); - -{---------------------------------------------------------------------------} -{ TGroup OBJECT - GROUP OBJECT ANCESTOR } -{---------------------------------------------------------------------------} -{$ifndef TYPED_LOCAL_CALLBACKS} - TGroupFirstThatCallback = CodePointer; -{$else} - TGroupFirstThatCallback = Function(View: PView): Boolean is nested; -{$endif} - - TGroup = OBJECT (TView) - Phase : (phFocused, phPreProcess, phPostProcess); - EndState: Word; { Modal result } - Current : PView; { Selected subview } - Last : PView; { 1st view inserted } - Buffer : PVideoBuf; { Speed up buffer } - CONSTRUCTOR Init (Var Bounds: TRect); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION First: PView; - FUNCTION Execute: Word; Virtual; - FUNCTION GetHelpCtx: Word; Virtual; - FUNCTION DataSize: Sw_Word; Virtual; - FUNCTION ExecView (P: PView): Word; Virtual; - FUNCTION FirstThat (P: TGroupFirstThatCallback): PView; - FUNCTION Valid (Command: Word): Boolean; Virtual; - FUNCTION FocusNext (Forwards: Boolean): Boolean; - PROCEDURE Draw; Virtual; - PROCEDURE Lock; - PROCEDURE UnLock; - PROCEDURE ResetCursor; Virtual; - PROCEDURE Awaken; Virtual; - PROCEDURE ReDraw; - PROCEDURE SelectDefaultView; - PROCEDURE Insert (P: PView); - PROCEDURE Delete (P: PView); - PROCEDURE ForEach (P: TCallbackProcParam); - { ForEach can't be virtual because it generates SIGSEGV } - PROCEDURE EndModal (Command: Word); Virtual; - PROCEDURE SelectNext (Forwards: Boolean); - PROCEDURE InsertBefore (P, Target: PView); - PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; - PROCEDURE GetData (Var Rec); Virtual; - PROCEDURE SetData (Var Rec); Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE EventError (Var Event: TEvent); Virtual; - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; - PROCEDURE GetSubViewPtr (Var S: TStream; Var P); - PROCEDURE PutSubViewPtr (Var S: TStream; P: PView); - function ClipChilds: boolean; virtual; - procedure BeforeInsert(P: PView); virtual; - procedure AfterInsert(P: PView); virtual; - procedure BeforeDelete(P: PView); virtual; - procedure AfterDelete(P: PView); virtual; - - PRIVATE - LockFlag: Byte; - Clip : TRect; - FUNCTION IndexOf (P: PView): Sw_Integer; - FUNCTION FindNext (Forwards: Boolean): PView; - FUNCTION FirstMatch (AState: Word; AOptions: Word): PView; - PROCEDURE ResetCurrent; - PROCEDURE RemoveView (P: PView); - PROCEDURE InsertView (P, Target: PView); - PROCEDURE SetCurrent (P: PView; Mode: SelectMode); - procedure DrawSubViews(P, Bottom: PView); - END; - -{---------------------------------------------------------------------------} -{ TFrame OBJECT - FRAME VIEW OBJECT } -{---------------------------------------------------------------------------} -TYPE - TFrame = OBJECT (TView) - CONSTRUCTOR Init (Var Bounds: TRect); - FUNCTION GetPalette: PPalette; Virtual; - procedure Draw; virtual; - procedure HandleEvent(var Event: TEvent); virtual; - procedure SetState(AState: Word; Enable: Boolean); virtual; - private - FrameMode: Word; - procedure FrameLine(var FrameBuf; Y, N: Sw_Integer; Color: Byte); - END; - PFrame = ^TFrame; - -{---------------------------------------------------------------------------} -{ TScrollBar OBJECT - SCROLL BAR OBJECT } -{---------------------------------------------------------------------------} -TYPE - TScrollChars = Array [0..4] of Char; - - TScrollBar = OBJECT (TView) - Value : Sw_Integer; { Scrollbar value } - Min : Sw_Integer; { Scrollbar minimum } - Max : Sw_Integer; { Scrollbar maximum } - PgStep: Sw_Integer; { One page step } - ArStep: Sw_Integer; { One range step } - Id : Sw_Integer; { Scrollbar ID } - CONSTRUCTOR Init (Var Bounds: TRect); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION GetPalette: PPalette; Virtual; - FUNCTION ScrollStep (Part: Sw_Integer): Sw_Integer; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE ScrollDraw; Virtual; - PROCEDURE SetValue (AValue: Sw_Integer); - PROCEDURE SetRange (AMin, AMax: Sw_Integer); - PROCEDURE SetStep (APgStep, AArStep: Sw_Integer); - PROCEDURE SetParams (AValue, AMin, AMax, APgStep, AArStep: Sw_Integer); - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PRIVATE - Chars: TScrollChars; { Scrollbar chars } - FUNCTION GetPos: Sw_Integer; - FUNCTION GetSize: Sw_Integer; - PROCEDURE DrawPos (Pos: Sw_Integer); - END; - PScrollBar = ^TScrollBar; - -{---------------------------------------------------------------------------} -{ TScroller OBJECT - SCROLLING VIEW ANCESTOR } -{---------------------------------------------------------------------------} -TYPE - TScroller = OBJECT (TView) - Delta : TPoint; - Limit : TPoint; - HScrollBar: PScrollBar; { Horz scroll bar } - VScrollBar: PScrollBar; { Vert scroll bar } - CONSTRUCTOR Init (Var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION GetPalette: PPalette; Virtual; - PROCEDURE ScrollDraw; Virtual; - PROCEDURE SetLimit (X, Y: Sw_Integer); - PROCEDURE ScrollTo (X, Y: Sw_Integer); - PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; - PRIVATE - DrawFlag: Boolean; - DrawLock: Byte; - PROCEDURE CheckDraw; - END; - PScroller = ^TScroller; - -{---------------------------------------------------------------------------} -{ TListViewer OBJECT - LIST VIEWER OBJECT } -{---------------------------------------------------------------------------} -TYPE - TListViewer = OBJECT (TView) - NumCols : Sw_Integer; { Number of columns } - TopItem : Sw_Integer; { Top most item } - Focused : Sw_Integer; { Focused item } - Range : Sw_Integer; { Range of listview } - HScrollBar: PScrollBar; { Horz scrollbar } - VScrollBar: PScrollBar; { Vert scrollbar } - CONSTRUCTOR Init (Var Bounds: TRect; ANumCols: Sw_Word; AHScrollBar, - AVScrollBar: PScrollBar); - CONSTRUCTOR Load (Var S: TStream); - FUNCTION GetPalette: PPalette; Virtual; - FUNCTION IsSelected (Item: Sw_Integer): Boolean; Virtual; - FUNCTION GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; Virtual; - PROCEDURE Draw; Virtual; - PROCEDURE FocusItem (Item: Sw_Integer); Virtual; - PROCEDURE SetTopItem (Item: Sw_Integer); - PROCEDURE SetRange (ARange: Sw_Integer); - PROCEDURE SelectItem (Item: Sw_Integer); Virtual; - PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; - PROCEDURE FocusItemNum (Item: Sw_Integer); Virtual; - END; - PListViewer = ^TListViewer; - -{---------------------------------------------------------------------------} -{ TWindow OBJECT - WINDOW OBJECT ANCESTOR } -{---------------------------------------------------------------------------} -TYPE - TWindow = OBJECT (TGroup) - Flags : Byte; { Window flags } - Number : Sw_Integer; { Window number } - Palette : Sw_Integer; { Window palette } - ZoomRect: TRect; { Zoom rectangle } - Frame : PFrame; { Frame view object } - Title : PString; { Title string } - CONSTRUCTOR Init (Var Bounds: TRect; ATitle: TTitleStr; ANumber: Sw_Integer); - CONSTRUCTOR Load (Var S: TStream); - DESTRUCTOR Done; Virtual; - FUNCTION GetPalette: PPalette; Virtual; - FUNCTION GetTitle (MaxSize: Sw_Integer): TTitleStr; Virtual; - FUNCTION StandardScrollBar (AOptions: Word): PScrollBar; - PROCEDURE Zoom; Virtual; - PROCEDURE Close; Virtual; - PROCEDURE InitFrame; Virtual; - PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; - PROCEDURE Store (Var S: TStream); - PROCEDURE HandleEvent (Var Event: TEvent); Virtual; - PROCEDURE SizeLimits (Var Min, Max: TPoint); Virtual; - END; - PWindow = ^TWindow; - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ WINDOW MESSAGE ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-Message------------------------------------------------------------ -Message sets up an event record and calls Receiver^.HandleEvent to -handle the event. Message returns nil if Receiver is nil, or if -the event is not handled successfully. -12Sep97 LdB ----------------------------------------------------------------------} -FUNCTION Message (Receiver: PView; What, Command: Word; - InfoPtr: Pointer): Pointer; - -{-NewMessage--------------------------------------------------------- -NewMessage sets up an event record including the new fields and calls -Receiver^.HandleEvent to handle the event. Message returns nil if -Receiver is nil, or if the event is not handled successfully. -19Sep97 LdB ----------------------------------------------------------------------} -FUNCTION NewMessage (P: PView; What, Command: Word; Id: Sw_Integer; Data: Real; - InfoPtr: Pointer): Pointer; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ VIEW OBJECT REGISTRATION ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{-RegisterViews------------------------------------------------------ -This registers all the view type objects used in this unit. -11Aug99 LdB ----------------------------------------------------------------------} -PROCEDURE RegisterViews; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ NEW VIEW ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{-CreateIdScrollBar-------------------------------------------------- -Creates and scrollbar object of the given size and direction and sets -the scrollbar id number. -22Sep97 LdB ----------------------------------------------------------------------} -FUNCTION CreateIdScrollBar (X, Y, Size, Id: Sw_Integer; Horz: Boolean): PScrollBar; - -{***************************************************************************} -{ INITIALIZED PUBLIC VARIABLES } -{***************************************************************************} - - -{---------------------------------------------------------------------------} -{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } -{---------------------------------------------------------------------------} -CONST - UseNativeClasses: Boolean = True; { Native class modes } - CommandSetChanged: Boolean = False; { Command change flag } - ShowMarkers: Boolean = False; { Show marker state } - ErrorAttr: Byte = $CF; { Error colours } - PositionalEvents: Word = evMouse; { Positional defined } - FocusedEvents: Word = evKeyboard + evCommand; { Focus defined } - MinWinSize: TPoint = (X: 16; Y: 6); { Minimum window size } - ShadowSize: TPoint = (X: 2; Y: 1); { Shadow sizes } - ShadowAttr: Byte = $08; { Shadow attribute } - -{ Characters used for drawing selected and default items in } -{ monochrome color sets } - SpecialChars: Array [0..5] Of Char = (#175, #174, #26, #27, ' ', ' '); - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ STREAM REGISTRATION RECORDS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ TView STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RView: TStreamRec = ( - ObjType: idView; { Register id = 1 } - VmtLink: TypeOf(TView); { Alt style VMT link } - Load: @TView.Load; { Object load method } - Store: @TView.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TFrame STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RFrame: TStreamRec = ( - ObjType: idFrame; { Register id = 2 } - VmtLink: TypeOf(TFrame); { Alt style VMT link } - Load: @TFrame.Load; { Frame load method } - Store: @TFrame.Store { Frame store method } - ); - -{---------------------------------------------------------------------------} -{ TScrollBar STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RScrollBar: TStreamRec = ( - ObjType: idScrollBar; { Register id = 3 } - VmtLink: TypeOf(TScrollBar); { Alt style VMT link } - Load: @TScrollBar.Load; { Object load method } - Store: @TScrollBar.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TScroller STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RScroller: TStreamRec = ( - ObjType: idScroller; { Register id = 4 } - VmtLink: TypeOf(TScroller); { Alt style VMT link } - Load: @TScroller.Load; { Object load method } - Store: @TScroller.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TListViewer STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RListViewer: TStreamRec = ( - ObjType: idListViewer; { Register id = 5 } - VmtLink: TypeOf(TListViewer); { Alt style VMT link } - Load: @TListViewer.Load; { Object load method } - Store: @TLIstViewer.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TGroup STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RGroup: TStreamRec = ( - ObjType: idGroup; { Register id = 6 } - VmtLink: TypeOf(TGroup); { Alt style VMT link } - Load: @TGroup.Load; { Object load method } - Store: @TGroup.Store { Object store method } - ); - -{---------------------------------------------------------------------------} -{ TWindow STREAM REGISTRATION } -{---------------------------------------------------------------------------} -CONST - RWindow: TStreamRec = ( - ObjType: idWindow; { Register id = 7 } - VmtLink: TypeOf(TWindow); { Alt style VMT link } - Load: @TWindow.Load; { Object load method } - Store: @TWindow.Store { Object store method } - ); - - -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - IMPLEMENTATION -{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} - -USES - Video; - -{***************************************************************************} -{ PRIVATE TYPE DEFINITIONS } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ TFixupList DEFINITION } -{---------------------------------------------------------------------------} -TYPE - TFixupList = ARRAY [1..4096] Of Pointer; { Fix up ptr array } - PFixupList = ^TFixupList; { Ptr to fix up list } - -{***************************************************************************} -{ PRIVATE INITIALIZED VARIABLES } -{***************************************************************************} - -{---------------------------------------------------------------------------} -{ INITIALIZED DOS/DPMI/WIN/NT/OS2 PRIVATE VARIABLES } -{---------------------------------------------------------------------------} -CONST - TheTopView : PView = Nil; { Top focused view } - LimitsLocked: PView = Nil; { View locking limits } - OwnerGroup : PGroup = Nil; { Used for loading } - FixupList : PFixupList = Nil; { Used for loading } - CurCommandSet: TCommandSet = ([0..255] - - [cmZoom, cmClose, cmResize, cmNext, cmPrev]); { All active but these } - - vdInSetCursor = $80; { AVOID RECURSION IN SetCursor } - - { Flags for TFrame } - fmCloseClicked = $01; - fmZoomClicked = $02; - - -type - TstatVar2 = record - target : PView; - offset,y : integer; - end; - -var - staticVar1 : PDrawBuffer; - staticVar2 : TstatVar2; - - -{***************************************************************************} -{ PRIVATE INTERNAL ROUTINES } -{***************************************************************************} - - function posidx(const substr,s : string;idx:sw_integer):sw_integer; - var - i,j : sw_integer; - e : boolean; - begin - i:=idx; - j:=0; - e:=(length(SubStr)>0); - while e and (i<=Length(s)-Length(SubStr)) do - begin - if (SubStr[1]=s[i]) and (Substr=Copy(s,i,Length(SubStr))) then - begin - j:=i; - e:=false; - end; - inc(i); - end; - PosIdx:=j; - end; - - -{$ifdef UNIX} -const - MouseUsesVideoBuf = true; -{$else not UNIX} -const - MouseUsesVideoBuf = false; -{$endif not UNIX} - -procedure DrawScreenBuf(force:boolean); -begin - if (GetLockScreenCount=0) then - begin -{ If MouseUsesVideoBuf then - begin - LockScreenUpdate; - HideMouse; - ShowMouse; - UnlockScreenUpdate; - end - else - HideMouse;} - UpdateScreen(force); -{ If not MouseUsesVideoBuf then - ShowMouse;} - end; -end; - - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ VIEW PORT CONTROL ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -TYPE - ViewPortType = RECORD - X1, Y1, X2, Y2: Integer; { Corners of viewport } - Clip : Boolean; { Clip status } - END; - -var - ViewPort : ViewPortType; - -{---------------------------------------------------------------------------} -{ GetViewSettings -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB } -{---------------------------------------------------------------------------} -PROCEDURE GetViewSettings (Var CurrentViewPort: ViewPortType); -BEGIN - CurrentViewPort := ViewPort; { Textmode viewport } -END; - -{---------------------------------------------------------------------------} -{ SetViewPort -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB } -{---------------------------------------------------------------------------} -PROCEDURE SetViewPort (X1, Y1, X2, Y2: Integer; Clip: Boolean); -BEGIN - If (X1 < 0) Then X1 := 0; { X1 negative fix } - If (X1 >ScreenWidth) Then - X1 := ScreenWidth; { X1 off screen fix } - If (Y1 < 0) Then Y1 := 0; { Y1 negative fix } - If (Y1 > ScreenHeight) Then - Y1 := ScreenHeight; { Y1 off screen fix } - If (X2 < 0) Then X2 := 0; { X2 negative fix } - If (X2 > ScreenWidth) Then - X2 := ScreenWidth; { X2 off screen fix } - If (Y2 < 0) Then Y2 := 0; { Y2 negative fix } - If (Y2 > ScreenHeight) Then - Y2 := ScreenHeight; { Y2 off screen fix } - ViewPort.X1 := X1; { Set X1 port value } - ViewPort.Y1 := Y1; { Set Y1 port value } - ViewPort.X2 := X2; { Set X2 port value } - ViewPort.Y2 := Y2; { Set Y2 port value } - ViewPort.Clip := Clip; { Set port clip value } -{ $ifdef DEBUG - If WriteDebugInfo then - Writeln(stderr,'New ViewPort(',X1,',',Y1,',',X2,',',Y2,')'); - $endif DEBUG} -END; - -{***************************************************************************} -{ OBJECT METHODS } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TView OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TView--------------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20Jun96 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TView.Init (Var Bounds: TRect); -BEGIN - Inherited Init; { Call ancestor } - DragMode := dmLimitLoY; { Default drag mode } - HelpCtx := hcNoContext; { Clear help context } - State := sfVisible; { Default state } - EventMask := evMouseDown + evKeyDown + evCommand; { Default event masks } - BackgroundChar := ' '; - SetBounds(Bounds); { Set view bounds } -END; - -{--TView--------------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06May98 LdB } -{---------------------------------------------------------------------------} -{ This load method will read old original TV data from a stream but the } -{ new options and tabmasks are not set so some NEW functionality is not } -{ supported but it should work as per original TV code. } -{---------------------------------------------------------------------------} -CONSTRUCTOR TView.Load (Var S: TStream); -VAR i: Integer; -BEGIN - Inherited Init; { Call ancestor } - S.Read(i, SizeOf(i)); Origin.X:=i; { Read origin x value } - S.Read(i, SizeOf(i)); Origin.Y:=i; { Read origin y value } - S.Read(i, SizeOf(i)); Size.X:=i; { Read view x size } - S.Read(i, SizeOf(i)); Size.Y:=i; { Read view y size } - S.Read(i, SizeOf(i)); Cursor.X:=i; { Read cursor x size } - S.Read(i, SizeOf(i)); Cursor.Y:=i; { Read cursor y size } - S.Read(GrowMode, SizeOf(GrowMode)); { Read growmode flags } - S.Read(DragMode, SizeOf(DragMode)); { Read dragmode flags } - S.Read(HelpCtx, SizeOf(HelpCtx)); { Read help context } - S.Read(State, SizeOf(State)); { Read state masks } - S.Read(Options, SizeOf(Options)); { Read options masks } - S.Read(Eventmask, SizeOf(Eventmask)); { Read event masks } -END; - -{--TView--------------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Nov99 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TView.Done; -VAR P: PComplexArea; -BEGIN - Hide; { Hide the view } - If (Owner <> Nil) Then Owner^.Delete(@Self); { Delete from owner } - While (HoldLimit <> Nil) Do Begin { Free limit memory } - P := HoldLimit^.NextArea; { Hold next pointer } - FreeMem(HoldLimit, SizeOf(TComplexArea)); { Release memory } - HoldLimit := P; { Shuffle to next } - End; -END; - -{--TView--------------------------------------------------------------------} -{ Prev -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.Prev: PView; -VAR NP : PView; -BEGIN - Prev := @Self; - NP := Next; - While (NP <> Nil) AND (NP <> @Self) Do - Begin - Prev := NP; { Locate next view } - NP := NP^.Next; - End; -END; - -{--TView--------------------------------------------------------------------} -{ Execute -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.Execute: Word; -BEGIN - Execute := cmCancel; { Return cancel } -END; - -{--TView--------------------------------------------------------------------} -{ Focus -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.Focus: Boolean; -VAR Res: Boolean; -BEGIN - Res := True; { Preset result } - If (State AND (sfSelected + sfModal)=0) Then Begin { Not modal/selected } - If (Owner <> Nil) Then Begin { View has an owner } - Res := Owner^.Focus; { Return focus state } - If Res Then { Owner has focus } - If ((Owner^.Current = Nil) OR { No current view } - (Owner^.Current^.Options AND ofValidate = 0) { Non validating view } - OR (Owner^.Current^.Valid(cmReleasedFocus))) { Okay to drop focus } - Then Select Else Res := False; { Then select us } - End; - End; - Focus := Res; { Return focus result } -END; - -{--TView--------------------------------------------------------------------} -{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.DataSize: Sw_Word; -BEGIN - DataSize := 0; { Transfer size } -END; - -{--TView--------------------------------------------------------------------} -{ TopView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.TopView: PView; -VAR P: PView; -BEGIN - If (TheTopView = Nil) Then Begin { Check topmost view } - P := @Self; { Start with us } - While (P <> Nil) AND (P^.State AND sfModal = 0) { Check if modal } - Do P := P^.Owner; { Search each owner } - TopView := P; { Return result } - End Else TopView := TheTopView; { Return topview } -END; - -{--TView--------------------------------------------------------------------} -{ PrevView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.PrevView: PView; -BEGIN - If (@Self = Owner^.First) Then PrevView := Nil { We are first view } - Else PrevView := Prev; { Return our prior } -END; - -{--TView--------------------------------------------------------------------} -{ NextView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.NextView: PView; -BEGIN - If (@Self = Owner^.Last) Then NextView := Nil { This is last view } - Else NextView := Next; { Return our next } -END; - -{--TView--------------------------------------------------------------------} -{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.GetHelpCtx: Word; -BEGIN - If (State AND sfDragging <> 0) Then { Dragging state check } - GetHelpCtx := hcDragging Else { Return dragging } - GetHelpCtx := HelpCtx; { Return help context } -END; - -{--TView--------------------------------------------------------------------} -{ EventAvail -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.EventAvail: Boolean; -VAR Event: TEvent; -BEGIN - GetEvent(Event); { Get next event } - If (Event.What <> evNothing) Then PutEvent(Event); { Put it back } - EventAvail := (Event.What <> evNothing); { Return result } -END; - -{--TView--------------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.GetPalette: PPalette; -BEGIN - GetPalette := Nil; { Return nil ptr } -END; - -{--TView--------------------------------------------------------------------} -{ MapColor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } -{---------------------------------------------------------------------------} -function TView.MapColor(color:byte):byte; -var - cur : PView; - p : PPalette; -begin - if color=0 then - MapColor:=errorAttr - else - begin - cur:=@Self; - repeat - p:=cur^.GetPalette; - if (p<>Nil) then - if ord(p^[0])<>0 then - begin - if color>ord(p^[0]) then - begin - MapColor:=errorAttr; - Exit; - end; - color:=ord(p^[color]); - if color=0 then - begin - MapColor:=errorAttr; - Exit; - end; - end; - cur:=cur^.Owner; - until (cur=Nil); - MapColor:=color; - end; -end; - - -{--TView--------------------------------------------------------------------} -{ GetColor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.GetColor (Color: Word): Word; -VAR Col: Byte; W: Word; P: PPalette; Q: PView; -BEGIN - W := 0; { Clear colour Sw_Word } - If (Hi(Color) > 0) Then Begin { High colour req } - Col := Hi(Color) + ColourOfs; { Initial offset } - Q := @Self; { Pointer to self } - Repeat - P := Q^.GetPalette; { Get our palette } - If (P <> Nil) Then Begin { Palette is valid } - If (Col <= Length(P^)) Then - Col := Ord(P^[Col]) Else { Return colour } - Col := ErrorAttr; { Error attribute } - End; - Q := Q^.Owner; { Move up to owner } - Until (Q = Nil); { Until no owner } - W := Col SHL 8; { Translate colour } - End; - If (Lo(Color) > 0) Then Begin - Col := Lo(Color) + ColourOfs; { Initial offset } - Q := @Self; { Pointer to self } - Repeat - P := Q^.GetPalette; { Get our palette } - If (P <> Nil) Then Begin { Palette is valid } - If (Col <= Length(P^)) Then - Col := Ord(P^[Col]) Else { Return colour } - Col := ErrorAttr; { Error attribute } - End; - Q := Q^.Owner; { Move up to owner } - Until (Q = Nil); { Until no owner } - End Else Col := ErrorAttr; { No colour found } - GetColor := W OR Col; { Return color } -END; - -{--TView--------------------------------------------------------------------} -{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.Valid (Command: Word): Boolean; -BEGIN - Valid := True; { Simply return true } -END; - -{--TView--------------------------------------------------------------------} -{ GetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.GetState (AState: Word): Boolean; -BEGIN - GetState := State AND AState = AState; { Check states equal } -END; - -{--TView--------------------------------------------------------------------} -{ TextWidth -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Nov99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.TextWidth (const Txt: String): Sw_Integer; -BEGIN - TextWidth := Length(Txt); { Calc text length } -END; - -FUNCTION TView.CTextWidth (const Txt: String): Sw_Integer; -VAR I: Sw_Integer; S: String; -BEGIN - S := Txt; { Transfer text } - Repeat - I := Pos('~', S); { Check for tilde } - If (I <> 0) Then System.Delete(S, I, 1); { Remove the tilde } - Until (I = 0); { Remove all tildes } - CTextWidth := Length(S); { Calc text length } -END; - -{--TView--------------------------------------------------------------------} -{ MouseInView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.MouseInView (Point: TPoint): Boolean; -BEGIN - MakeLocal(Point,Point); - MouseInView := (Point.X >= 0) and - (Point.Y >= 0) and - (Point.X < Size.X) and - (Point.Y < Size.Y); -END; - -{--TView--------------------------------------------------------------------} -{ CommandEnabled -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.CommandEnabled(Command: Word): Boolean; -BEGIN - CommandEnabled := (Command > 255) OR - (Command IN CurCommandSet); { Check command } -END; - -{--TView--------------------------------------------------------------------} -{ OverLapsArea -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.OverlapsArea (X1, Y1, X2, Y2: Sw_Integer): Boolean; -BEGIN - OverLapsArea := False; { Preset false } - If (Origin.X > X2) Then Exit; { Area to the left } - If ((Origin.X + Size.X) < X1) Then Exit; { Area to the right } - If (Origin.Y > Y2) Then Exit; { Area is above } - If ((Origin.Y + Size.Y) < Y1) Then Exit; { Area is below } - OverLapsArea := True; { Return true } -END; - -{--TView--------------------------------------------------------------------} -{ MouseEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TView.MouseEvent (Var Event: TEvent; Mask: Word): Boolean; -BEGIN - Repeat - GetEvent(Event); { Get next event } - Until (Event.What AND (Mask OR evMouseUp) <> 0); { Wait till valid } - MouseEvent := Event.What <> evMouseUp; { Return result } -END; - -{--TView--------------------------------------------------------------------} -{ Hide -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.Hide; -BEGIN - If (State AND sfVisible <> 0) Then { View is visible } - SetState(sfVisible, False); { Hide the view } -END; - -{--TView--------------------------------------------------------------------} -{ Show -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.Show; -BEGIN - If (State AND sfVisible = 0) Then { View not visible } - SetState(sfVisible, True); { Show the view } -END; - -{--TView--------------------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.Draw; -VAR B : TDrawBuffer; -BEGIN - MoveChar(B, ' ', GetColor(1), Size.X); - WriteLine(0, 0, Size.X, Size.Y, B); -END; - - -procedure TView.ResetCursor; -const - sfV_CV_F:word = sfVisible + sfCursorVis + sfFocused; -var - p,p2 : PView; - G : PGroup; - cur : TPoint; - - function Check0:boolean; - var - res : byte; - begin - res:=0; - while res=0 do - begin - p:=p^.next; - if p=p2 then - begin - p:=P^.owner; - res:=1 - end - else - if ((p^.state and sfVisible)<>0) and - (cur.x>=p^.origin.x) and - (cur.x<p^.size.x+p^.origin.x) and - (cur.y>=p^.origin.y) and - (cur.y<p^.size.y+p^.origin.y) then - res:=2; - end; - Check0:=res=2; - end; - -begin - if ((state and sfV_CV_F) = sfV_CV_F) then - begin - p:=@Self; - cur:=cursor; - while true do - begin - if (cur.x<0) or (cur.x>=p^.size.x) or - (cur.y<0) or (cur.y>=p^.size.y) then - break; - inc(cur.X,p^.origin.X); - inc(cur.Y,p^.origin.Y); - p2:=p; - G:=p^.owner; - if G=Nil then { top view } - begin - Video.SetCursorPos(cur.x,cur.y); - if (state and sfCursorIns)<>0 then - Video.SetCursorType(crBlock) - else - Video.SetCursorType(crUnderline); - exit; - end; - if (G^.state and sfVisible)=0 then - break; - p:=G^.Last; - if Check0 then - break; - end; { while } - end; { if } - Video.SetCursorType(crHidden); -end; - - -{--TView--------------------------------------------------------------------} -{ Select -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.Select; -BEGIN - If (Options AND ofSelectable <> 0) Then { View is selectable } - If (Options AND ofTopSelect <> 0) Then MakeFirst { Top selectable } - Else If (Owner <> Nil) Then { Valid owner } - Owner^.SetCurrent(@Self, NormalSelect); { Make owners current } -END; - -{--TView--------------------------------------------------------------------} -{ Awaken -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.Awaken; -BEGIN { Abstract method } -END; - - -{--TView--------------------------------------------------------------------} -{ MakeFirst -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.MakeFirst; -BEGIN - If (Owner <> Nil) Then Begin { Must have owner } - PutInFrontOf(Owner^.First); { Float to the top } - End; -END; - -{--TView--------------------------------------------------------------------} -{ DrawCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.DrawCursor; -BEGIN { Abstract method } - if State and sfFocused <> 0 then - ResetCursor; -END; - - -procedure TView.DrawHide(LastView: PView); -begin - TView.DrawCursor; - DrawUnderView(State and sfShadow <> 0, LastView); -end; - - -procedure TView.DrawShow(LastView: PView); -begin - DrawView; - if State and sfShadow <> 0 then - DrawUnderView(True, LastView); -end; - - -procedure TView.DrawUnderRect(var R: TRect; LastView: PView); -begin - Owner^.Clip.Intersect(R); - Owner^.DrawSubViews(NextView, LastView); - Owner^.GetExtent(Owner^.Clip); -end; - - -procedure TView.DrawUnderView(DoShadow: Boolean; LastView: PView); -var - R: TRect; -begin - GetBounds(R); - if DoShadow then - begin - inc(R.B.X,ShadowSize.X); - inc(R.B.Y,ShadowSize.Y); - end; - DrawUnderRect(R, LastView); -end; - - -procedure TView.DrawView; -begin - if Exposed then - begin - LockScreenUpdate; { don't update the screen yet } - Draw; - UnLockScreenUpdate; - DrawScreenBuf(false); - TView.DrawCursor; - end; -end; - - -{--TView--------------------------------------------------------------------} -{ HideCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.HideCursor; -BEGIN - SetState(sfCursorVis , False); { Hide the cursor } -END; - -{--TView--------------------------------------------------------------------} -{ ShowCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.ShowCursor; -BEGIN - SetState(sfCursorVis , True); { Show the cursor } -END; - -{--TView--------------------------------------------------------------------} -{ BlockCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.BlockCursor; -BEGIN - SetState(sfCursorIns, True); { Set insert mode } -END; - -{--TView--------------------------------------------------------------------} -{ NormalCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.NormalCursor; -BEGIN - SetState(sfCursorIns, False); { Clear insert mode } -END; - -{--TView--------------------------------------------------------------------} -{ FocusFromTop -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11Aug99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.FocusFromTop; -BEGIN - If (Owner <> Nil) AND - (Owner^.State AND sfSelected = 0) - Then Owner^.Select; - If (State AND sfFocused = 0) Then Focus; - If (State AND sfSelected = 0) Then Select; -END; - -{--TView--------------------------------------------------------------------} -{ MoveTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.MoveTo (X, Y: Sw_Integer); -VAR R: TRect; -BEGIN - R.Assign(X, Y, X + Size.X, Y + Size.Y); { Assign area } - Locate(R); { Locate the view } -END; - -{--TView--------------------------------------------------------------------} -{ GrowTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.GrowTo (X, Y: Sw_Integer); -VAR R: TRect; -BEGIN - R.Assign(Origin.X, Origin.Y, Origin.X + X, - Origin.Y + Y); { Assign area } - Locate(R); { Locate the view } -END; - -{--TView--------------------------------------------------------------------} -{ EndModal -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.EndModal (Command: Word); -VAR P: PView; -BEGIN - P := TopView; { Get top view } - If (P <> Nil) Then P^.EndModal(Command); { End modal operation } -END; - -{--TView--------------------------------------------------------------------} -{ SetCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.SetCursor (X, Y: Sw_Integer); -BEGIN - if (Cursor.X<>X) or (Cursor.Y<>Y) then - begin - Cursor.X := X; - Cursor.Y := Y; - CursorChanged; - end; - TView.DrawCursor; -END; - - -procedure TView.CursorChanged; -begin - Message(Owner,evBroadcast,cmCursorChanged,@Self); -end; - - -{--TView--------------------------------------------------------------------} -{ PutInFrontOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.PutInFrontOf (Target: PView); -VAR P, LastView: PView; -BEGIN - If (Owner <> Nil) AND (Target <> @Self) AND - (Target <> NextView) AND ((Target = Nil) OR - (Target^.Owner = Owner)) Then { Check validity } - If (State AND sfVisible = 0) Then Begin { View not visible } - Owner^.RemoveView(@Self); { Remove from list } - Owner^.InsertView(@Self, Target); { Insert into list } - End Else Begin - LastView := NextView; { Hold next view } - If (LastView <> Nil) Then Begin { Lastview is valid } - P := Target; { P is target } - While (P <> Nil) AND (P <> LastView) - Do P := P^.NextView; { Find our next view } - If (P = Nil) Then LastView := Target; { Lastview is target } - End; - State := State AND NOT sfVisible; { Temp stop drawing } - If (LastView = Target) Then - DrawHide(LastView); - Owner^.Lock; - Owner^.RemoveView(@Self); { Remove from list } - Owner^.InsertView(@Self, Target); { Insert into list } - State := State OR sfVisible; { Allow drawing again } - If (LastView <> Target) Then - DrawShow(LastView); - If (Options AND ofSelectable <> 0) Then { View is selectable } - begin - Owner^.ResetCurrent; { Reset current } - Owner^.ResetCursor; - end; - Owner^.Unlock; - End; -END; - -{--TView--------------------------------------------------------------------} -{ SetCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.SetCommands (Commands: TCommandSet); -BEGIN - CommandSetChanged := CommandSetChanged OR - (CurCommandSet <> Commands); { Set change flag } - CurCommandSet := Commands; { Set command set } -END; - -{--TView--------------------------------------------------------------------} -{ EnableCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.EnableCommands (Commands: TCommandSet); -BEGIN - CommandSetChanged := CommandSetChanged OR - (CurCommandSet * Commands <> Commands); { Set changed flag } - CurCommandSet := CurCommandSet + Commands; { Update command set } -END; - -{--TView--------------------------------------------------------------------} -{ DisableCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.DisableCommands (Commands: TCommandSet); -BEGIN - CommandSetChanged := CommandSetChanged OR - (CurCommandSet * Commands <> []); { Set changed flag } - CurCommandSet := CurCommandSet - Commands; { Update command set } -END; - -{--TView--------------------------------------------------------------------} -{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.SetState (AState: Word; Enable: Boolean); -var - Command: Word; - OState : Word; -begin - OState:=State; - if Enable then - State := State or AState - else - State := State and not AState; - if Owner <> nil then - case AState of - sfVisible: - begin - if Owner^.State and sfExposed <> 0 then - SetState(sfExposed, Enable); - if Enable then - DrawShow(nil) - else - DrawHide(nil); - if Options and ofSelectable <> 0 then - Owner^.ResetCurrent; - end; - sfCursorVis, - sfCursorIns: - TView.DrawCursor; - sfShadow: - DrawUnderView(True, nil); - sfFocused: - begin - ResetCursor; - if Enable then - Command := cmReceivedFocus - else - Command := cmReleasedFocus; - Message(Owner, evBroadcast, Command, @Self); - end; - end; - if ((OState xor State) and (sfCursorVis+sfCursorIns+sfFocused))<>0 then - CursorChanged; -end; - - -{--TView--------------------------------------------------------------------} -{ SetCmdState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.SetCmdState (Commands: TCommandSet; Enable: Boolean); -BEGIN - If Enable Then EnableCommands(Commands) { Enable commands } - Else DisableCommands(Commands); { Disable commands } -END; - -{--TView--------------------------------------------------------------------} -{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.GetData (Var Rec); -BEGIN { Abstract method } -END; - -{--TView--------------------------------------------------------------------} -{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.SetData (Var Rec); -BEGIN { Abstract method } -END; - -{--TView--------------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.Store (Var S: TStream); -VAR SaveState: Word; - i: integer; -BEGIN - SaveState := State; { Hold current state } - State := State AND NOT (sfActive OR sfSelected OR - sfFocused OR sfExposed); { Clear flags } - i:=Origin.X;S.Write(i, SizeOf(i)); { Write view x origin } - i:=Origin.Y;S.Write(i, SizeOf(i)); { Write view y origin } - i:=Size.X;S.Write(i, SizeOf(i)); { Write view x size } - i:=Size.Y;S.Write(i, SizeOf(i)); { Write view y size } - i:=Cursor.X;S.Write(i, SizeOf(i)); { Write cursor x size } - i:=Cursor.Y;S.Write(i, SizeOf(i)); { Write cursor y size } - S.Write(GrowMode, SizeOf(GrowMode)); { Write growmode flags } - S.Write(DragMode, SizeOf(DragMode)); { Write dragmode flags } - S.Write(HelpCtx, SizeOf(HelpCtx)); { Write help context } - S.Write(State, SizeOf(State)); { Write state masks } - S.Write(Options, SizeOf(Options)); { Write options masks } - S.Write(Eventmask, SizeOf(Eventmask)); { Write event masks } - State := SaveState; { Reset state masks } -END; - -{--TView--------------------------------------------------------------------} -{ Locate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.Locate (Var Bounds: TRect); -VAR - Min, Max: TPoint; R: TRect; - - FUNCTION Range(Val, Min, Max: Sw_Integer): Sw_Integer; - BEGIN - If (Val < Min) Then Range := Min Else { Value to small } - If (Val > Max) Then Range := Max Else { Value to large } - Range := Val; { Value is okay } - END; - -BEGIN - SizeLimits(Min, Max); { Get size limits } - Bounds.B.X := Bounds.A.X + Range(Bounds.B.X - - Bounds.A.X, Min.X, Max.X); { X bound limit } - Bounds.B.Y := Bounds.A.Y + Range(Bounds.B.Y - - Bounds.A.Y, Min.Y, Max.Y); { Y bound limit } - GetBounds(R); { Current bounds } - If NOT Bounds.Equals(R) Then Begin { Size has changed } - ChangeBounds(Bounds); { Change bounds } - If (State AND sfVisible <> 0) AND { View is visible } - (State AND sfExposed <> 0) AND (Owner <> Nil) { Check view exposed } - Then - begin - if State and sfShadow <> 0 then - begin - R.Union(Bounds); - Inc(R.B.X, ShadowSize.X); - Inc(R.B.Y, ShadowSize.Y); - end; - DrawUnderRect(R, nil); - end; - End; -END; - -{--TView--------------------------------------------------------------------} -{ KeyEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.KeyEvent (Var Event: TEvent); -BEGIN - Repeat - GetEvent(Event); { Get next event } - Until (Event.What = evKeyDown); { Wait till keydown } -END; - -{--TView--------------------------------------------------------------------} -{ GetEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.GetEvent (Var Event: TEvent); -BEGIN - If (Owner <> Nil) Then Owner^.GetEvent(Event); { Event from owner } -END; - -{--TView--------------------------------------------------------------------} -{ PutEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.PutEvent (Var Event: TEvent); -BEGIN - If (Owner <> Nil) Then Owner^.PutEvent(Event); { Put in owner } -END; - -{--TView--------------------------------------------------------------------} -{ GetExtent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.GetExtent (Var Extent: TRect); -BEGIN - Extent.A.X := 0; { Zero x field } - Extent.A.Y := 0; { Zero y field } - Extent.B.X := Size.X; { Return x size } - Extent.B.Y := Size.Y; { Return y size } -END; - -{--TView--------------------------------------------------------------------} -{ GetBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.GetBounds (Var Bounds: TRect); -BEGIN - Bounds.A := Origin; { Get first corner } - Bounds.B.X := Origin.X + Size.X; { Calc corner x value } - Bounds.B.Y := Origin.Y + Size.Y; { Calc corner y value } -END; - -{--TView--------------------------------------------------------------------} -{ SetBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Sep99 LdB } -{---------------------------------------------------------------------------} -procedure TView.SetBounds(var Bounds: TRect); -begin - Origin := Bounds.A; { Get first corner } - Size := Bounds.B; { Get second corner } - Dec(Size.X,Origin.X); - Dec(Size.Y,Origin.Y); -end; - -{--TView--------------------------------------------------------------------} -{ GetClipRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.GetClipRect (Var Clip: TRect); -BEGIN - GetBounds(Clip); { Get current bounds } - If (Owner <> Nil) Then Clip.Intersect(Owner^.Clip);{ Intersect with owner } - Clip.Move(-Origin.X, -Origin.Y); { Sub owner origin } -END; - -{--TView--------------------------------------------------------------------} -{ ClearEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.ClearEvent (Var Event: TEvent); -BEGIN - Event.What := evNothing; { Clear the event } - Event.InfoPtr := @Self; { Set us as handler } -END; - -{--TView--------------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.HandleEvent (Var Event: TEvent); -BEGIN - If (Event.What = evMouseDown) Then { Mouse down event } - If (State AND (sfSelected OR sfDisabled) = 0) { Not selected/disabled } - AND (Options AND ofSelectable <> 0) Then { View is selectable } - If (Focus = False) OR { Not view with focus } - (Options AND ofFirstClick = 0) { Not 1st click select } - Then ClearEvent(Event); { Handle the event } -END; - -{--TView--------------------------------------------------------------------} -{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.ChangeBounds (Var Bounds: TRect); -BEGIN - SetBounds(Bounds); { Set new bounds } - DrawView; { Draw the view } -END; - -{--TView--------------------------------------------------------------------} -{ SizeLimits -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.SizeLimits (Var Min, Max: TPoint); -BEGIN - Min.X := 0; { Zero x minimum } - Min.Y := 0; { Zero y minimum } - If (Owner <> Nil) and(Owner^.ClipChilds) Then - Max := Owner^.Size - else { Max owner size } - Begin - Max.X := high(sw_integer); { Max possible x size } - Max.Y := high(sw_integer); { Max possible y size } - End; -END; - -{--TView--------------------------------------------------------------------} -{ GetCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.GetCommands (Var Commands: TCommandSet); -BEGIN - Commands := CurCommandSet; { Return command set } -END; - -{--TView--------------------------------------------------------------------} -{ GetPeerViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.GetPeerViewPtr (Var S: TStream; Var P); -VAR Index: Integer; -BEGIN - Index := 0; { Zero index value } - S.Read(Index, SizeOf(Index)); { Read view index } - If (Index = 0) OR (OwnerGroup = Nil) Then { Check for peer views } - Pointer(P) := Nil Else Begin { Return nil } - Pointer(P) := FixupList^[Index]; { New view ptr } - FixupList^[Index] := @P; { Patch this pointer } - End; -END; - -{--TView--------------------------------------------------------------------} -{ PutPeerViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.PutPeerViewPtr (Var S: TStream; P: PView); -VAR Index: Integer; -BEGIN - If (P = Nil) OR (OwnerGroup = Nil) Then Index := 0 { Return zero index } - Else Index := OwnerGroup^.IndexOf(P); { Return view index } - S.Write(Index, SizeOf(Index)); { Write the index } -END; - -{--TView--------------------------------------------------------------------} -{ CalcBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.CalcBounds (Var Bounds: Objects.TRect; Delta: TPoint); -VAR S, D: Sw_Integer; Min, Max: TPoint; - - FUNCTION Range (Val, Min, Max: Sw_Integer): Sw_Integer; - BEGIN - If (Val < Min) Then Range := Min Else { Value below min } - If (Val > Max) Then Range := Max Else { Value above max } - Range := Val; { Accept value } - END; - - PROCEDURE GrowI (Var I: Sw_Integer); - BEGIN - If (GrowMode AND gfGrowRel = 0) Then Inc(I, D) - Else If S = D then I := 1 - Else I := (I * S + (S - D) SHR 1) DIV (S - D); { Calc grow value } - END; - -BEGIN - GetBounds(Bounds); { Get bounds } - If (GrowMode = 0) Then Exit; { No grow flags exits } - S := Owner^.Size.X; { Set initial size } - D := Delta.X; { Set initial delta } - If (GrowMode AND gfGrowLoX <> 0) Then - GrowI(Bounds.A.X); { Grow left side } - If (GrowMode AND gfGrowHiX <> 0) Then - GrowI(Bounds.B.X); { Grow right side } - If (Bounds.B.X - Bounds.A.X > MaxViewWidth) Then - Bounds.B.X := Bounds.A.X + MaxViewWidth; { Check values } - S := Owner^.Size.Y; D := Delta.Y; { set initial values } - If (GrowMode AND gfGrowLoY <> 0) Then - GrowI(Bounds.A.Y); { Grow top side } - If (GrowMode AND gfGrowHiY <> 0) Then - GrowI(Bounds.B.Y); { grow lower side } - SizeLimits(Min, Max); { Check sizes } - Bounds.B.X := Bounds.A.X + Range(Bounds.B.X - - Bounds.A.X, Min.X, Max.X); { Set right side } - Bounds.B.Y := Bounds.A.Y + Range(Bounds.B.Y - - Bounds.A.Y, Min.Y, Max.Y); { Set lower side } -END; - -{***************************************************************************} -{ TView OBJECT PRIVATE METHODS } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TGroup OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TGroup-------------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Jul99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TGroup.Init (Var Bounds: TRect); -BEGIN - Inherited Init(Bounds); { Call ancestor } - Options := Options OR (ofSelectable + ofBuffered); { Set options } - GetExtent(Clip); { Get clip extents } - EventMask := $FFFF; { See all events } -END; - -{--TGroup-------------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TGroup.Load (Var S: TStream); -VAR I: Sw_Word; - Count: Word; - P, Q: ^Pointer; V: PView; OwnerSave: PGroup; - FixupSave: PFixupList; -BEGIN - Inherited Load(S); { Call ancestor } - GetExtent(Clip); { Get view extents } - OwnerSave := OwnerGroup; { Save current group } - OwnerGroup := @Self; { We are current group } - FixupSave := FixupList; { Save current list } - Count := 0; { Zero count value } - S.Read(Count, SizeOf(Count)); { Read entry count } - If (MaxAvail >= Count*SizeOf(Pointer)) Then Begin { Memory available } - GetMem(FixupList, Count*SizeOf(Pointer)); { List size needed } - FillChar(FixUpList^, Count*SizeOf(Pointer), #0); { Zero all entries } - For I := 1 To Count Do Begin - V := PView(S.Get); { Get view off stream } - If (V <> Nil) Then InsertView(V, Nil); { Insert valid views } - End; - V := Last; { Start on last view } - For I := 1 To Count Do Begin - V := V^.Next; { Fetch next view } - P := FixupList^[I]; { Transfer pointer } - While (P <> Nil) Do Begin { If valid view } - Q := P; { Copy pointer } - P := P^; { Fetch pointer } - Q^ := V; { Transfer view ptr } - End; - End; - FreeMem(FixupList, Count*SizeOf(Pointer)); { Release fixup list } - End; - OwnerGroup := OwnerSave; { Reload current group } - FixupList := FixupSave; { Reload current list } - GetSubViewPtr(S, V); { Load any subviews } - SetCurrent(V, NormalSelect); { Select current view } - If (OwnerGroup = Nil) Then Awaken; { If topview activate } -END; - -{--TGroup-------------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TGroup.Done; -VAR P, T: PView; -BEGIN - Hide; { Hide the view } - P := Last; { Start on last } - If (P <> Nil) Then Begin { Subviews exist } - Repeat - P^.Hide; { Hide each view } - P := P^.Prev; { Prior view } - Until (P = Last); { Loop complete } - Repeat - T := P^.Prev; { Hold prior pointer } - Dispose(P, Done); { Dispose subview } - P := T; { Transfer pointer } - Until (Last = Nil); { Loop complete } - End; - Inherited Done; { Call ancestor } -END; - -{--TGroup-------------------------------------------------------------------} -{ First -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.First: PView; -BEGIN - If (Last = Nil) Then First := Nil { No first view } - Else First := Last^.Next; { Return first view } -END; - -{--TGroup-------------------------------------------------------------------} -{ Execute -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.Execute: Word; -VAR Event: TEvent; -BEGIN - Repeat - EndState := 0; { Clear end state } - Repeat - GetEvent(Event); { Get next event } - HandleEvent(Event); { Handle the event } - If (Event.What <> evNothing) Then - EventError(Event); { Event not handled } - Until (EndState <> 0); { Until command set } - Until Valid(EndState); { Repeat until valid } - Execute := EndState; { Return result } - EndState := 0; { Clear end state } -END; - -{--TGroup-------------------------------------------------------------------} -{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.GetHelpCtx: Word; -VAR H: Word; -BEGIN - H := hcNoContext; { Preset no context } - If (Current <> Nil) Then H := Current^.GetHelpCtx; { Current context } - If (H=hcNoContext) Then H := Inherited GetHelpCtx; { Call ancestor } - GetHelpCtx := H; { Return result } -END; - -{--TGroup-------------------------------------------------------------------} -{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Jul98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.DataSize: Sw_Word; -VAR Total: Word; P: PView; -BEGIN - Total := 0; { Zero totals count } - P := Last; { Start on last view } - If (P <> Nil) Then Begin { Subviews exist } - Repeat - P := P^.Next; { Move to next view } - Total := Total + P^.DataSize; { Add view size } - Until (P = Last); { Until last view } - End; - DataSize := Total; { Return data size } -END; - -{--TGroup-------------------------------------------------------------------} -{ ExecView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Jul99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.ExecView (P: PView): Word; -VAR SaveOptions: Word; SaveTopView, SaveCurrent: PView; SaveOwner: PGroup; - SaveCommands: TCommandSet; -BEGIN - If (P<>Nil) Then Begin - SaveOptions := P^.Options; { Hold options } - SaveOwner := P^.Owner; { Hold owner } - SaveTopView := TheTopView; { Save topmost view } - SaveCurrent := Current; { Save current view } - GetCommands(SaveCommands); { Save commands } - TheTopView := P; { Set top view } - P^.Options := P^.Options AND NOT ofSelectable; { Not selectable } - P^.SetState(sfModal, True); { Make modal } - SetCurrent(P, EnterSelect); { Select next } - If (SaveOwner = Nil) Then Insert(P); { Insert view } - ExecView := P^.Execute; { Execute view } - If (SaveOwner = Nil) Then Delete(P); { Remove view } - SetCurrent(SaveCurrent, LeaveSelect); { Unselect current } - P^.SetState(sfModal, False); { Clear modal state } - P^.Options := SaveOptions; { Restore options } - TheTopView := SaveTopView; { Restore topview } - SetCommands(SaveCommands); { Restore commands } - End Else ExecView := cmCancel; { Return cancel } -END; - -{ ********************************* REMARK ******************************** } -{ This call really is very COMPILER SPECIFIC and really can't be done } -{ effectively any other way but assembler code as SELF & FRAMES need } -{ to be put down in exact order and OPTIMIZERS make a mess of it. } -{ ******************************** END REMARK *** Leon de Boer, 17Jul99 *** } - -{--TGroup-------------------------------------------------------------------} -{ FirstThat -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.FirstThat (P: TGroupFirstThatCallback): PView; -VAR - Tp : PView; -BEGIN - If (Last<>Nil) Then - Begin - Tp := Last; { Set temporary ptr } - Repeat - Tp := Tp^.Next; { Get next view } - IF Byte(PtrUInt(CallPointerMethodLocal(TCallbackFunBoolParam(P), - { On most systems, locals are accessed relative to base pointer, - but for MIPS cpu, they are accessed relative to stack pointer. - This needs adaptation for so low level routines, - like MethodPointerLocal and related objects unit functions. } -{$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE} - get_caller_frame(get_frame,get_pc_addr) -{$else} - get_frame -{$endif} - ,@self,Tp)))<>0 THEN - Begin { Test each view } - FirstThat := Tp; { View returned true } - Exit; { Now exit } - End; - Until (Tp=Last); { Until last } - FirstThat := Nil; { None passed test } - End - Else - FirstThat := Nil; { Return nil } -END; - -{--TGroup-------------------------------------------------------------------} -{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.Valid (Command: Word): Boolean; - - FUNCTION IsInvalid (P: PView): Boolean; - BEGIN - IsInvalid := NOT P^.Valid(Command); { Check if valid } - END; - -BEGIN - Valid := True; { Preset valid } - If (Command = cmReleasedFocus) Then Begin { Release focus cmd } - If (Current <> Nil) AND { Current view exists } - (Current^.Options AND ofValidate <> 0) Then { Validating view } - Valid := Current^.Valid(Command); { Validate command } - End Else Valid := FirstThat(@IsInvalid) = Nil; { Check first valid } -END; - -{--TGroup-------------------------------------------------------------------} -{ FocusNext -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.FocusNext (Forwards: Boolean): Boolean; -VAR P: PView; -BEGIN - P := FindNext(Forwards); { Find next view } - FocusNext := True; { Preset true } - If (P <> Nil) Then FocusNext := P^.Focus; { Check next focus } -END; - - -procedure TGroup.DrawSubViews(P, Bottom: PView); -begin - if P <> nil then - while P <> Bottom do - begin - P^.DrawView; - P := P^.NextView; - end; -end; - - -{--TGroup-------------------------------------------------------------------} -{ ReDraw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 2Jun06 DM } -{---------------------------------------------------------------------------} -procedure TGroup.Redraw; -begin - {Lock to prevent screen update.} - lockscreenupdate; - DrawSubViews(First, nil); - unlockscreenupdate; - {Draw all views at once, forced update.} - drawscreenbuf(true); -end; - - -PROCEDURE TGroup.ResetCursor; -BEGIN - if (Current<>nil) then - Current^.ResetCursor; -END; - - -{--TGroup-------------------------------------------------------------------} -{ Awaken -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.Awaken; - - PROCEDURE DoAwaken (P: PView); - BEGIN - If (P <> Nil) Then P^.Awaken; { Awaken view } - END; - -BEGIN - ForEach(TCallbackProcParam(@DoAwaken)); { Awaken each view } -END; - -{--TGroup-------------------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.Draw; -BEGIN - If Buffer=Nil then - DrawSubViews(First, nil) - else - WriteBuf(0,0,Size.X,Size.Y,Buffer); -END; - - -{--TGroup-------------------------------------------------------------------} -{ SelectDefaultView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.SelectDefaultView; -VAR P: PView; -BEGIN - P := Last; { Start at last } - While (P <> Nil) Do Begin - If P^.GetState(sfDefault) Then Begin { Search 1st default } - P^.Select; { Select default view } - P := Nil; { Force kick out } - End Else P := P^.PrevView; { Prior subview } - End; -END; - - -function TGroup.ClipChilds: boolean; -begin - ClipChilds:=true; -end; - - -procedure TGroup.BeforeInsert(P: PView); -begin - { abstract } -end; - -procedure TGroup.AfterInsert(P: PView); -begin - { abstract } -end; - -procedure TGroup.BeforeDelete(P: PView); -begin - { abstract } -end; - -procedure TGroup.AfterDelete(P: PView); -begin - { abstract } -end; - -{--TGroup-------------------------------------------------------------------} -{ Insert -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.Insert (P: PView); -BEGIN - BeforeInsert(P); - InsertBefore(P, First); - AfterInsert(P); -END; - -{--TGroup-------------------------------------------------------------------} -{ Delete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.Delete (P: PView); -VAR SaveState: Word; -BEGIN - BeforeDelete(P); - SaveState := P^.State; { Save state } - P^.Hide; { Hide the view } - RemoveView(P); { Remove the view } - P^.Owner := Nil; { Clear owner ptr } - P^.Next := Nil; { Clear next ptr } - if SaveState and sfVisible <> 0 then - P^.Show; - AfterDelete(P); -END; - -{ ********************************* REMARK ******************************** } -{ This call really is very COMPILER SPECIFIC and really can't be done } -{ effectively any other way but assembler code as SELF & FRAMES need } -{ to be put down in exact order and OPTIMIZERS make a mess of it. } -{ ******************************** END REMARK *** Leon de Boer, 17Jul99 *** } - -{--TGroup-------------------------------------------------------------------} -{ ForEach -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.ForEach (P: TCallbackProcParam); -VAR - Tp,Hp,L0 : PView; -{ Vars Hp and L0 are necessary to hold original pointers in case } -{ when some view closes himself as a result of broadcast message ! } -BEGIN - If (Last<>Nil) Then - Begin - Tp:=Last; - Hp:=Tp^.Next; - L0:=Last; { Set temporary ptr } - Repeat - Tp:=Hp; - if tp=nil then - exit; - Hp:=Tp^.Next; { Get next view } - CallPointerMethodLocal(P, - { On most systems, locals are accessed relative to base pointer, - but for MIPS cpu, they are accessed relative to stack pointer. - This needs adaptation for so low level routines, - like MethodPointerLocal and related objects unit functions. } -{$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE} - get_caller_frame(get_frame,get_pc_addr) -{$else} - get_frame -{$endif} - ,@self,Tp); - Until (Tp=L0); { Until last } - End; -END; - - - -{--TGroup-------------------------------------------------------------------} -{ EndModal -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.EndModal (Command: Word); -BEGIN - If (State AND sfModal <> 0) Then { This view is modal } - EndState := Command Else { Set endstate } - Inherited EndModal(Command); { Call ancestor } -END; - -{--TGroup-------------------------------------------------------------------} -{ SelectNext -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.SelectNext (Forwards: Boolean); -VAR P: PView; -BEGIN - P := FindNext(Forwards); { Find next view } - If (P <> Nil) Then P^.Select; { Select view } -END; - -{--TGroup-------------------------------------------------------------------} -{ InsertBefore -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.InsertBefore (P, Target: PView); -VAR SaveState : Word; -BEGIN - If (P <> Nil) AND (P^.Owner = Nil) AND { View valid } - ((Target = Nil) OR (Target^.Owner = @Self)) { Target valid } - Then Begin - If (P^.Options AND ofCenterX <> 0) Then { Centre on x axis } - P^.Origin.X := (Size.X - P^.Size.X) div 2; - If (P^.Options AND ofCenterY <> 0) Then { Centre on y axis } - P^.Origin.Y := (Size.Y - P^.Size.Y) div 2; - SaveState := P^.State; { Save view state } - P^.Hide; { Make sure hidden } - InsertView(P, Target); { Insert into list } - If (SaveState AND sfVisible <> 0) Then P^.Show; { Show the view } - If (State AND sfActive <> 0) Then { Was active before } - P^.SetState(sfActive , True); { Make active again } - End; -END; - -{--TGroup-------------------------------------------------------------------} -{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.SetState (AState: Word; Enable: Boolean); - - PROCEDURE DoSetState (P: PView); - BEGIN - If (P <> Nil) Then P^.SetState(AState, Enable); { Set subview state } - END; - - PROCEDURE DoExpose (P: PView); - BEGIN - If (P <> Nil) Then Begin - If (P^.State AND sfVisible <> 0) Then { Check view visible } - P^.SetState(sfExposed, Enable); { Set exposed flag } - End; - END; - -BEGIN - Inherited SetState(AState, Enable); { Call ancestor } - Case AState Of - sfActive, sfDragging: Begin - Lock; { Lock the view } - ForEach(TCallbackProcParam(@DoSetState)); { Set each subview } - UnLock; { Unlock the view } - End; - sfFocused: Begin - If (Current <> Nil) Then - Current^.SetState(sfFocused, Enable); { Focus current view } - End; - sfExposed: Begin - ForEach(TCallbackProcParam(@DoExpose)); { Expose each subview } - End; - End; -END; - -{--TGroup-------------------------------------------------------------------} -{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Mar98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.GetData (Var Rec); -VAR Total: Sw_Word; P: PView; -BEGIN - Total := 0; { Clear total } - P := Last; { Start at last } - While (P <> Nil) Do Begin { Subviews exist } - P^.GetData(TByteArray(Rec)[Total]); { Get data } - Inc(Total, P^.DataSize); { Increase total } - P := P^.PrevView; { Previous view } - End; -END; - -{--TGroup-------------------------------------------------------------------} -{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Mar98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.SetData (Var Rec); -VAR Total: Sw_Word; P: PView; -BEGIN - Total := 0; { Clear total } - P := Last; { Start at last } - While (P <> Nil) Do Begin { Subviews exist } - P^.SetData(TByteArray(Rec)[Total]); { Get data } - Inc(Total, P^.DataSize); { Increase total } - P := P^.PrevView; { Previous view } - End; -END; - -{--TGroup-------------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Mar98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.Store (Var S: TStream); -VAR Count: Word; OwnerSave: PGroup; - - PROCEDURE DoPut (P: PView); - BEGIN - S.Put(P); { Put view on stream } - END; - -BEGIN - TView.Store(S); { Call view store } - OwnerSave := OwnerGroup; { Save ownergroup } - OwnerGroup := @Self; { Set as owner group } - Count := IndexOf(Last); { Subview count } - S.Write(Count, SizeOf(Count)); { Write the count } - ForEach(TCallbackProcParam(@DoPut)); { Put each in stream } - PutSubViewPtr(S, Current); { Current on stream } - OwnerGroup := OwnerSave; { Restore ownergroup } -END; - -{--TGroup-------------------------------------------------------------------} -{ EventError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.EventError (Var Event: TEvent); -BEGIN - If (Owner <> Nil) Then Owner^.EventError(Event); { Event error } -END; - -{--TGroup-------------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.HandleEvent (Var Event: TEvent); - - FUNCTION ContainsMouse (P: PView): Boolean; - BEGIN - ContainsMouse := (P^.State AND sfVisible <> 0) { Is view visible } - AND P^.MouseInView(Event.Where); { Is point in view } - END; - - PROCEDURE DoHandleEvent (P: PView); - BEGIN - If (P = Nil) OR ((P^.State AND sfDisabled <> 0) AND - (Event.What AND(PositionalEvents OR FocusedEvents) <>0 )) - Then Exit; { Invalid/disabled } - Case Phase Of - phPreProcess: If (P^.Options AND ofPreProcess = 0) - Then Exit; { Not pre processing } - phPostProcess: If (P^.Options AND ofPostProcess = 0) - Then Exit; { Not post processing } - End; - If (Event.What AND P^.EventMask <> 0) Then { View handles event } - P^.HandleEvent(Event); { Pass to view } - END; - -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - If (Event.What = evNothing) Then Exit; { No valid event exit } - If (Event.What AND FocusedEvents <> 0) Then Begin { Focused event } - Phase := phPreProcess; { Set pre process } - ForEach(TCallbackProcParam(@DoHandleEvent)); { Pass to each view } - Phase := phFocused; { Set focused } - DoHandleEvent(Current); { Pass to current } - Phase := phPostProcess; { Set post process } - ForEach(TCallbackProcParam(@DoHandleEvent)); { Pass to each } - End Else Begin - Phase := phFocused; { Set focused } - If (Event.What AND PositionalEvents <> 0) Then { Positional event } - DoHandleEvent(FirstThat(@ContainsMouse)) { Pass to first } - Else ForEach(TCallbackProcParam(@DoHandleEvent)); { Pass to all } - End; -END; - -{--TGroup-------------------------------------------------------------------} -{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.ChangeBounds (Var Bounds: TRect); -VAR D: TPoint; - - PROCEDURE DoCalcChange (P: PView); - VAR R: TRect; - BEGIN - P^.CalcBounds(R, D); { Calc view bounds } - P^.ChangeBounds(R); { Change view bounds } - END; - -BEGIN - D.X := Bounds.B.X - Bounds.A.X - Size.X; { Delta x value } - D.Y := Bounds.B.Y - Bounds.A.Y - Size.Y; { Delta y value } - If ((D.X=0) AND (D.Y=0)) Then Begin - SetBounds(Bounds); { Set new bounds } - { Force redraw } - ReDraw; { Draw the view } - End Else Begin - SetBounds(Bounds); { Set new bounds } - GetExtent(Clip); { Get new clip extents } - Lock; { Lock drawing } - ForEach(TCallbackProcParam(@DoCalcChange)); { Change each view } - UnLock; { Unlock drawing } - End; -END; - -{--TGroup-------------------------------------------------------------------} -{ GetSubViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.GetSubViewPtr (Var S: TStream; Var P); -VAR Index, I: Sw_Word; Q: PView; -BEGIN - Index := 0; { Zero index value } - S.Read(Index, SizeOf(Index)); { Read view index } - If (Index > 0) Then Begin { Valid index } - Q := Last; { Start on last } - For I := 1 To Index Do Q := Q^.Next; { Loop for count } - Pointer(P) := Q; { Return the view } - End Else Pointer(P) := Nil; { Return nil } -END; - -{--TGroup-------------------------------------------------------------------} -{ PutSubViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.PutSubViewPtr (Var S: TStream; P: PView); -VAR Index: Sw_Word; -BEGIN - If (P = Nil) Then Index := 0 Else { Nil view, Index = 0 } - Index := IndexOf(P); { Calc view index } - S.Write(Index, SizeOf(Index)); { Write the index } -END; - - -{***************************************************************************} -{ TGroup OBJECT PRIVATE METHODS } -{***************************************************************************} - -{--TGroup-------------------------------------------------------------------} -{ IndexOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.IndexOf (P: PView): Sw_Integer; -VAR I: Sw_Integer; Q: PView; -BEGIN - Q := Last; { Start on last view } - If (Q <> Nil) Then Begin { Subviews exist } - I := 1; { Preset value } - While (Q <> P) AND (Q^.Next <> Last) Do Begin - Q := Q^.Next; { Load next view } - Inc(I); { Increment count } - End; - If (Q <> P) Then IndexOf := 0 Else IndexOf := I; { Return index } - End Else IndexOf := 0; { Return zero } -END; - -{--TGroup-------------------------------------------------------------------} -{ FindNext -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.FindNext (Forwards: Boolean): PView; -VAR P: PView; -BEGIN - FindNext := Nil; { Preset nil return } - If (Current <> Nil) Then Begin { Has current view } - P := Current; { Start on current } - Repeat - If Forwards Then P := P^.Next { Get next view } - Else P := P^.Prev; { Get prev view } - Until ((P^.State AND (sfVisible+sfDisabled) = sfVisible) AND - (P^.Options AND ofSelectable <> 0)) OR { Tab selectable } - (P = Current); { Not singular select } - If (P <> Current) Then FindNext := P; { Return result } - End; -END; - -{--TGroup-------------------------------------------------------------------} -{ FirstMatch -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TGroup.FirstMatch (AState: Word; AOptions: Word): PView; - - FUNCTION Matches (P: PView): Boolean; - BEGIN - Matches := (P^.State AND AState = AState) AND - (P^.Options AND AOptions = AOptions); { Return match state } - END; - -BEGIN - FirstMatch := FirstThat(@Matches); { Return first match } -END; - -{--TGroup-------------------------------------------------------------------} -{ ResetCurrent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.ResetCurrent; -BEGIN - SetCurrent(FirstMatch(sfVisible, ofSelectable), - NormalSelect); { Reset current view } -END; - -{--TGroup-------------------------------------------------------------------} -{ RemoveView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.RemoveView (P: PView); -VAR Q: PView; -BEGIN - If (P <> Nil) AND (Last <> Nil) Then Begin { Check view is valid } - Q := Last; { Start on last view } - While (Q^.Next <> P) AND (Q^.Next <> Last) Do - Q := Q^.Next; { Find prior view } - If (Q^.Next = P) Then Begin { View found } - If (Q^.Next <> Q) Then Begin { Not only view } - Q^.Next := P^.Next; { Rechain views } - If (P = Last) Then Last := P^.Next; { Fix if last removed } - End Else Last := Nil; { Only view } - End; - End; -END; - -{--TGroup-------------------------------------------------------------------} -{ InsertView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.InsertView (P, Target: PView); -BEGIN - If (P <> Nil) Then Begin { Check view is valid } - P^.Owner := @Self; { Views owner is us } - If (Target <> Nil) Then Begin { Valid target } - Target := Target^.Prev; { 1st part of chain } - P^.Next := Target^.Next; { 2nd part of chain } - Target^.Next := P; { Chain completed } - End Else Begin - If (Last <> Nil) Then Begin { Not first view } - P^.Next := Last^.Next; { 1st part of chain } - Last^.Next := P; { Completed chain } - End Else P^.Next := P; { 1st chain to self } - Last := P; { P is now last } - End; - End; -END; - -{--TGroup-------------------------------------------------------------------} -{ SetCurrent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.SetCurrent (P: PView; Mode: SelectMode); - - PROCEDURE SelectView (P: PView; Enable: Boolean); - BEGIN - If (P <> Nil) Then { View is valid } - P^.SetState(sfSelected, Enable); { Select the view } - END; - - PROCEDURE FocusView (P: PView; Enable: Boolean); - BEGIN - If (State AND sfFocused <> 0) AND (P <> Nil) { Check not focused } - Then P^.SetState(sfFocused, Enable); { Focus the view } - END; - -BEGIN - If (Current<>P) Then Begin { Not already current } - Lock; { Stop drawing } - FocusView(Current, False); { Defocus current } - If (Mode <> EnterSelect) Then - SelectView(Current, False); { Deselect current } - If (Mode<>LeaveSelect) Then SelectView(P, True); { Select view P } - FocusView(P, True); { Focus view P } - Current := P; { Set as current view } - UnLock; { Redraw now } - End; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TFrame OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TFrame-------------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TFrame.Init (Var Bounds: TRect); -BEGIN - Inherited Init(Bounds); { Call ancestor } - GrowMode := gfGrowHiX + gfGrowHiY; { Set grow modes } - EventMask := EventMask OR evBroadcast; { See broadcasts } -END; - -procedure TFrame.FrameLine(var FrameBuf; Y, N: Sw_Integer; Color: Byte); -const - InitFrame: array[0..17] of Byte = - ($06, $0A, $0C, $05, $00, $05, $03, $0A, $09, - $16, $1A, $1C, $15, $00, $15, $13, $1A, $19); - FrameChars_437: array[0..31] of Char = - ' À ³Úà ÙÄÁ¿´ÂÅ È ºÉÇ ¼ÍÏ»¶ÑÎ'; - FrameChars_850: array[0..31] of Char = - ' À ³Úà ÙÄÁ¿´ÂÅ È ºÉº ¼ÍÍ»ºÍÎ'; -var - FrameMask : array[0..MaxViewWidth-1] of Byte; - ColorMask : word; - i,j,k : {Sw_ lo and hi are used !! }integer; - CurrView : PView; - p : Pchar; -begin - FrameMask[0]:=InitFrame[n]; - FillChar(FrameMask[1],Size.X-2,InitFrame[n+1]); - FrameMask[Size.X-1]:=InitFrame[n+2]; - CurrView:=Owner^.Last^.Next; - while (CurrView<>PView(@Self)) do - begin - if ((CurrView^.Options and ofFramed)<>0) and - ((CurrView^.State and sfVisible)<>0) then - begin - i:=Y-CurrView^.Origin.Y; - if (i<0) then - begin - inc(i); - if i=0 then - i:=$0a06 - else - i:=0; - end - else - begin - if i<CurrView^.Size.Y then - i:=$0005 - else - if i=CurrView^.Size.Y then - i:=$0a03 - else - i:=0; - end; - if (i<>0) then - begin - j:=CurrView^.Origin.X; - k:=CurrView^.Size.X+j; - if j<1 then - j:=1; - if k>Size.X then - k:=Size.X; - if (k>j) then - begin - FrameMask[j-1]:=FrameMask[j-1] or lo(i); - i:=(lo(i) xor hi(i)) or (i and $ff00); - FrameMask[k]:=FrameMask[k] or lo(i); - if hi(i)<>0 then - begin - dec(k,j); - repeat - FrameMask[j]:=FrameMask[j] or hi(i); - inc(j); - dec(k); - until k=0; - end; - end; - end; - end; - CurrView:=CurrView^.Next; - end; - ColorMask:=Color shl 8; - p:=framechars_437; - {$ifdef unix} - {Codepage variables are currently Unix only.} - if internal_codepage<>cp437 then - p:=framechars_850; - {$endif} - for i:=0 to Size.X-1 do - TVideoBuf(FrameBuf)[i]:=ord(p[FrameMask[i]]) or ColorMask; -end; - - -procedure TFrame.Draw; -const - LargeC:array[boolean] of char=('^',#24); - RestoreC:array[boolean] of char=('|',#18); - ClickC:array[boolean] of char=('*',#15); -var - CFrame, CTitle: Word; - F, I, L, Width: Sw_Integer; - B: TDrawBuffer; - Title: TTitleStr; - Min, Max: TPoint; -begin - if State and sfDragging <> 0 then - begin - CFrame := $0505; - CTitle := $0005; - F := 0; - end - else if State and sfActive = 0 then - begin - CFrame := $0101; - CTitle := $0002; - F := 0; - end - else - begin - CFrame := $0503; - CTitle := $0004; - F := 9; - end; - CFrame := GetColor(CFrame); - CTitle := GetColor(CTitle); - Width := Size.X; - L := Width - 10; - if PWindow(Owner)^.Flags and (wfClose+wfZoom) <> 0 then - Dec(L,6); - FrameLine(B, 0, F, Byte(CFrame)); - if (PWindow(Owner)^.Number <> wnNoNumber) and - (PWindow(Owner)^.Number < 10) then - begin - Dec(L,4); - if PWindow(Owner)^.Flags and wfZoom <> 0 then - I := 7 - else - I := 3; - WordRec(B[Width - I]).Lo := PWindow(Owner)^.Number + $30; - end; - if Owner <> nil then - Title := PWindow(Owner)^.GetTitle(L) - else - Title := ''; - if Title <> '' then - begin - L := Length(Title); - if L > Width - 10 then - L := Width - 10; - if L < 0 then - L := 0; - I := (Width - L) shr 1; - MoveChar(B[I - 1], ' ', CTitle, 1); - MoveBuf(B[I], Title[1], CTitle, L); - MoveChar(B[I + L], ' ', CTitle, 1); - end; - if State and sfActive <> 0 then - begin - if PWindow(Owner)^.Flags and wfClose <> 0 then - if FrameMode and fmCloseClicked = 0 then - MoveCStr(B[2], '[~þ~]', CFrame) - else - MoveCStr(B[2], '[~'+ClickC[LowAscii]+'~]', CFrame); - if PWindow(Owner)^.Flags and wfZoom <> 0 then - begin - MoveCStr(B[Width - 5], '[~'+LargeC[LowAscii]+'~]', CFrame); - Owner^.SizeLimits(Min, Max); - if FrameMode and fmZoomClicked <> 0 then - WordRec(B[Width - 4]).Lo := ord(ClickC[LowAscii]) - else - if (Owner^.Size.X=Max.X) and (Owner^.Size.Y=Max.Y) then - WordRec(B[Width - 4]).Lo := ord(RestoreC[LowAscii]); - end; - end; - WriteLine(0, 0, Size.X, 1, B); - for I := 1 to Size.Y - 2 do - begin - FrameLine(B, I, F + 3, Byte(CFrame)); - WriteLine(0, I, Size.X, 1, B); - end; - FrameLine(B, Size.Y - 1, F + 6, Byte(CFrame)); - if State and sfActive <> 0 then - if PWindow(Owner)^.Flags and wfGrow <> 0 then - MoveCStr(B[Width - 2], '~ÄÙ~', CFrame); - WriteLine(0, Size.Y - 1, Size.X, 1, B); -end; - -{--TFrame-------------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TFrame.GetPalette: PPalette; -CONST P: String[Length(CFrame)] = CFrame; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Return palette } -END; - -procedure TFrame.HandleEvent(var Event: TEvent); -var - Mouse: TPoint; - - procedure DragWindow(Mode: Byte); - var - Limits: TRect; - Min, Max: TPoint; - begin - Owner^.Owner^.GetExtent(Limits); - Owner^.SizeLimits(Min, Max); - Owner^.DragView(Event, Owner^.DragMode or Mode, Limits, Min, Max); - ClearEvent(Event); - end; - -begin - TView.HandleEvent(Event); - if Event.What = evMouseDown then - begin - MakeLocal(Event.Where, Mouse); - if Mouse.Y = 0 then - begin - if (PWindow(Owner)^.Flags and wfClose <> 0) and - (State and sfActive <> 0) and (Mouse.X >= 2) and (Mouse.X <= 4) then - begin - {Close button clicked.} - repeat - MakeLocal(Event.Where, Mouse); - if (Mouse.X >= 2) and (Mouse.X <= 4) and (Mouse.Y = 0) then - FrameMode := fmCloseClicked - else FrameMode := 0; - DrawView; - until not MouseEvent(Event, evMouseMove + evMouseAuto); - FrameMode := 0; - if (Mouse.X >= 2) and (Mouse.X <= 4) and (Mouse.Y = 0) then - begin - Event.What := evCommand; - Event.Command := cmClose; - Event.InfoPtr := Owner; - PutEvent(Event); - end; - ClearEvent(Event); - DrawView; - end else - if (PWindow(Owner)^.Flags and wfZoom <> 0) and - (State and sfActive <> 0) and (Event.Double or - (Mouse.X >= Size.X - 5) and - (Mouse.X <= Size.X - 3)) then - begin - {Zoom button clicked.} - if not Event.Double then - repeat - MakeLocal(Event.Where, Mouse); - if (Mouse.X >= Size.X - 5) and (Mouse.X <= Size.X - 3) and - (Mouse.Y = 0) then - FrameMode := fmZoomClicked - else FrameMode := 0; - DrawView; - until not MouseEvent(Event, evMouseMove + evMouseAuto); - FrameMode := 0; - if ((Mouse.X >= Size.X - 5) and (Mouse.X <= Size.X - 3) and - (Mouse.Y = 0)) or Event.Double then - begin - Event.What := evCommand; - Event.Command := cmZoom; - Event.InfoPtr := Owner; - PutEvent(Event); - end; - ClearEvent(Event); - DrawView; - end else - if PWindow(Owner)^.Flags and wfMove <> 0 then - DragWindow(dmDragMove); - end else - if (State and sfActive <> 0) and (Mouse.X >= Size.X - 2) and - (Mouse.Y >= Size.Y - 1) then - if PWindow(Owner)^.Flags and wfGrow <> 0 then - DragWindow(dmDragGrow); - end; -end; - - -procedure TFrame.SetState(AState: Word; Enable: Boolean); -begin - TView.SetState(AState, Enable); - if AState and (sfActive + sfDragging) <> 0 then - DrawView; -end; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TScrollBar OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - - -{--TScrollBar---------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TScrollBar.Init (Var Bounds: TRect); -const - VChars: array[boolean] of TScrollChars = - (('^','V', #177, #254, #178),(#30, #31, #177, #254, #178)); - HChars: array[boolean] of TScrollChars = - (('<','>', #177, #254, #178),(#17, #16, #177, #254, #178)); -BEGIN - Inherited Init(Bounds); { Call ancestor } - PgStep := 1; { Page step size = 1 } - ArStep := 1; { Arrow step sizes = 1 } - If (Size.X = 1) Then Begin { Vertical scrollbar } - GrowMode := gfGrowLoX + gfGrowHiX + gfGrowHiY; { Grow vertically } - Chars := VChars[LowAscii]; { Vertical chars } - End Else Begin { Horizontal scrollbar } - GrowMode := gfGrowLoY + gfGrowHiX + gfGrowHiY; { Grow horizontal } - Chars := HChars[LowAscii]; { Horizontal chars } - End; -END; - -{--TScrollBar---------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } -{---------------------------------------------------------------------------} -{ This load method will read old original TV data from a stream with the } -{ scrollbar id set to zero. } -{---------------------------------------------------------------------------} -CONSTRUCTOR TScrollBar.Load (Var S: TStream); -VAR i: Integer; -BEGIN - Inherited Load(S); { Call ancestor } - S.Read(i, SizeOf(i)); Value:=i; { Read current value } - S.Read(i, SizeOf(i)); Min:=i; { Read min value } - S.Read(i, SizeOf(i)); Max:=i; { Read max value } - S.Read(i, SizeOf(i)); PgStep:=i; { Read page step size } - S.Read(i, SizeOf(i)); ArStep:=i; { Read arrow step size } - S.Read(Chars, SizeOf(Chars)); { Read scroll chars } -END; - -{--TScrollBar---------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TScrollBar.GetPalette: PPalette; -CONST P: String[Length(CScrollBar)] = CScrollBar; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Return palette } -END; - -{--TScrollBar---------------------------------------------------------------} -{ ScrollStep -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TScrollBar.ScrollStep (Part: Sw_Integer): Sw_Integer; -VAR Step: Sw_Integer; -BEGIN - If (Part AND $0002 = 0) Then Step := ArStep { Range step size } - Else Step := PgStep; { Page step size } - If (Part AND $0001 = 0) Then ScrollStep := -Step { Upwards move } - Else ScrollStep := Step; { Downwards move } -END; - -{--TScrollBar---------------------------------------------------------------} -{ ScrollDraw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScrollBar.ScrollDraw; -VAR P: PView; -BEGIN - If (Id <> 0) Then Begin - P := TopView; { Get topmost view } - NewMessage(P, evCommand, cmIdCommunicate, Id, - Value, @Self); { New Id style message } - End; - NewMessage(Owner, evBroadcast, cmScrollBarChanged, - Id, Value, @Self); { Old TV style message } -END; - - -{--TScrollBar---------------------------------------------------------------} -{ SetValue -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScrollBar.SetValue (AValue: Sw_Integer); -BEGIN - SetParams(AValue, Min, Max, PgStep, ArStep); { Set value } -END; - -{--TScrollBar---------------------------------------------------------------} -{ SetRange -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScrollBar.SetRange (AMin, AMax: Sw_Integer); -BEGIN - SetParams(Value, AMin, AMax, PgStep, ArStep); { Set range } -END; - -{--TScrollBar---------------------------------------------------------------} -{ SetStep -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScrollBar.SetStep (APgStep, AArStep: Sw_Integer); -BEGIN - SetParams(Value, Min, Max, APgStep, AArStep); { Set step sizes } -END; - -{--TScrollBar---------------------------------------------------------------} -{ SetParams -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 21Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScrollBar.SetParams (AValue, AMin, AMax, APgStep, AArStep: Sw_Integer); -var - OldValue : Sw_Integer; -BEGIN - If (AMax < AMin) Then AMax := AMin; { Max below min fix up } - If (AValue < AMin) Then AValue := AMin; { Value below min fix } - If (AValue > AMax) Then AValue := AMax; { Value above max fix } - OldValue:=Value; - If (Value <> AValue) OR (Min <> AMin) OR - (Max <> AMax) Then Begin { Something changed } - Min := AMin; { Set new minimum } - Max := AMax; { Set new maximum } - Value := AValue; { Set new value } - DrawView; - if OldValue <> AValue then - ScrollDraw; - End; - PgStep := APgStep; { Hold page step } - ArStep := AArStep; { Hold arrow step } -END; - -{--TScrollBar---------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } -{---------------------------------------------------------------------------} -{ You can save data to the stream compatable with the old original TV by } -{ temporarily turning off the ofGrafVersion making the call to this store } -{ routine and resetting the ofGrafVersion flag after the call. } -{---------------------------------------------------------------------------} -PROCEDURE TScrollBar.Store (Var S: TStream); -VAR i: Integer; -BEGIN - TView.Store(S); { TView.Store called } - i:=Value;S.Write(i, SizeOf(i)); { Write current value } - i:=Min;S.Write(i, SizeOf(i)); { Write min value } - i:=Max;S.Write(i, SizeOf(i)); { Write max value } - i:=PgStep;S.Write(i, SizeOf(i)); { Write page step size } - i:=ArStep;S.Write(i, SizeOf(i)); { Write arrow step size } - S.Write(Chars, SizeOf(Chars)); { Write scroll chars } -END; - -{--TScrollBar---------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScrollBar.HandleEvent (Var Event: TEvent); -VAR Tracking: Boolean; I, P, S, ClickPart, Iv: Sw_Integer; - Mouse: TPoint; Extent: TRect; - - FUNCTION GetPartCode: Sw_Integer; - VAR Mark, Part : Sw_Integer; - BEGIN - Part := -1; { Preset failure } - If Extent.Contains(Mouse) Then Begin { Contains mouse } - If (Size.X = 1) Then Begin { Vertical scrollbar } - Mark := Mouse.Y; { Calc position } - End Else Begin { Horizontal bar } - Mark := Mouse.X; { Calc position } - End; - If (Mark >= P) AND (Mark < P+1) Then { Within thumbnail } - Part := sbIndicator; { Indicator part } - If (Part <> sbIndicator) Then Begin { Not indicator part } - If (Mark < 1) Then Part := sbLeftArrow Else { Left arrow part } - If (Mark < P) Then Part := sbPageLeft Else { Page left part } - If (Mark < S-1) Then Part := sbPageRight Else { Page right part } - Part := sbRightArrow; { Right arrow part } - If (Size.X = 1) Then Inc(Part, 4); { Correct for vertical } - End; - End; - GetPartCode := Part; { Return part code } - END; - - PROCEDURE Clicked; - BEGIN - NewMessage(Owner, evBroadcast, cmScrollBarClicked, - Id, Value, @Self); { Old TV style message } - END; - -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - Case Event.What Of - evNothing: Exit; { Speed up exit } - evCommand: Begin { Command event } - If (Event.Command = cmIdCommunicate) AND { Id communication } - (Event.Id = Id) AND (Event.InfoPtr <> @Self) { Targeted to us } - Then Begin - SetValue(Round(Event.Data)); { Set scrollbar value } - ClearEvent(Event); { Event was handled } - End; - End; - evKeyDown: - If (State AND sfVisible <> 0) Then Begin { Scrollbar visible } - ClickPart := sbIndicator; { Preset result } - If (Size.Y = 1) Then { Horizontal bar } - Case CtrlToArrow(Event.KeyCode) Of - kbLeft: ClickPart := sbLeftArrow; { Left one item } - kbRight: ClickPart := sbRightArrow; { Right one item } - kbCtrlLeft: ClickPart := sbPageLeft; { One page left } - kbCtrlRight: ClickPart := sbPageRight; { One page right } - kbHome: I := Min; { Move to start } - kbEnd: I := Max; { Move to end } - Else Exit; { Not a valid key } - End - Else { Vertical bar } - Case CtrlToArrow(Event.KeyCode) Of - kbUp: ClickPart := sbUpArrow; { One item up } - kbDown: ClickPart := sbDownArrow; { On item down } - kbPgUp: ClickPart := sbPageUp; { One page up } - kbPgDn: ClickPart := sbPageDown; { One page down } - kbCtrlPgUp: I := Min; { Move to top } - kbCtrlPgDn: I := Max; { Move to bottom } - Else Exit; { Not a valid key } - End; - Clicked; { Send out message } - If (ClickPart <> sbIndicator) Then - I := Value + ScrollStep(ClickPart); { Calculate position } - SetValue(I); { Set new item } - ClearEvent(Event); { Event now handled } - End; - evMouseDown: Begin { Mouse press event } - Clicked; { Scrollbar clicked } - MakeLocal(Event.Where, Mouse); { Localize mouse } - Extent.A.X := 0; { Zero x extent value } - Extent.A.Y := 0; { Zero y extent value } - Extent.B.X := Size.X; { Set extent x value } - Extent.B.Y := Size.Y; { set extent y value } - P := GetPos; { Current position } - S := GetSize; { Initial size } - ClickPart := GetPartCode; { Get part code } - If (ClickPart <> sbIndicator) Then Begin { Not thumb nail } - Repeat - MakeLocal(Event.Where, Mouse); { Localize mouse } - If GetPartCode = ClickPart Then - SetValue(Value+ScrollStep(ClickPart)); { Same part repeat } - Until NOT MouseEvent(Event, evMouseAuto); { Until auto done } - Clicked; { Scrollbar clicked } - End Else Begin { Thumb nail move } - Iv := Value; { Initial value } - Repeat - MakeLocal(Event.Where, Mouse); { Localize mouse } - Tracking := Extent.Contains(Mouse); { Check contains } - If Tracking Then Begin { Tracking mouse } - If (Size.X=1) Then - I := Mouse.Y Else { Calc vert position } - I := Mouse.X; { Calc horz position } - If (I < 0) Then I := 0; { Check underflow } - If (I > S) Then I := S; { Check overflow } - End Else I := GetPos; { Get position } - If (I <> P) Then Begin - SetValue(LongInt((LongInt(I)*(Max-Min)) - +(S SHR 1)) DIV S + Min); { Set new value } - P := I; { Hold new position } - End; - Until NOT MouseEvent(Event, evMouseMove); { Until not moving } - If Tracking AND (S > 0) Then { Tracking mouse } - SetValue(LongInt((LongInt(P)*(Max-Min))+ - (S SHR 1)) DIV S + Min); { Set new value } - If (Iv <> Value) Then Clicked; { Scroll has moved } - End; - ClearEvent(Event); { Clear the event } - End; - End; -END; - -{***************************************************************************} -{ TScrollBar OBJECT PRIVATE METHODS } -{***************************************************************************} - -{--TScrollBar---------------------------------------------------------------} -{ GetPos -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TScrollBar.GetPos: Sw_Integer; -VAR R: Sw_Integer; -BEGIN - R := Max - Min; { Get full range } - If (R = 0) Then GetPos := 1 Else { Return zero } - GetPos := LongInt((LongInt(Value-Min) * (GetSize -3)) - + (R SHR 1)) DIV R + 1; { Calc position } -END; - -{--TScrollBar---------------------------------------------------------------} -{ GetSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TScrollBar.GetSize: Sw_Integer; -VAR S: Sw_Integer; -BEGIN - If Size.X = 1 Then - S:= Size.Y - else - S:= Size.X; - If (S < 3) Then S := 3; { Fix minimum size } - GetSize := S; { Return size } -END; - - -{--TScrollBar---------------------------------------------------------------} -{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScrollBar.Draw; -BEGIN - DrawPos(GetPos); { Draw position } -END; - - -procedure TScrollBar.DrawPos(Pos: Sw_Integer); -var - S: Sw_Integer; - B: TDrawBuffer; -begin - S := GetSize - 1; - MoveChar(B[0], Chars[0], GetColor(2), 1); - if Max = Min then - MoveChar(B[1], Chars[4], GetColor(1), S - 1) - else - begin - MoveChar(B[1], Chars[2], GetColor(1), S - 1); - MoveChar(B[Pos], Chars[3], GetColor(3), 1); - end; - MoveChar(B[S], Chars[1], GetColor(2), 1); - WriteBuf(0, 0, Size.X, Size.Y, B); -end; - - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TScroller OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TScroller----------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TScroller.Init (Var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar); -BEGIN - Inherited Init(Bounds); { Call ancestor } - Options := Options OR ofSelectable; { View is selectable } - EventMask := EventMask OR evBroadcast; { See broadcasts } - HScrollBar := AHScrollBar; { Hold horz scrollbar } - VScrollBar := AVScrollBar; { Hold vert scrollbar } -END; - -{--TScroller----------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } -{---------------------------------------------------------------------------} -{ This load method will read old original TV data from a stream as well } -{ as the new graphical scroller views. } -{---------------------------------------------------------------------------} -CONSTRUCTOR TScroller.Load (Var S: TStream); -VAR i: Integer; -BEGIN - Inherited Load(S); { Call ancestor } - GetPeerViewPtr(S, HScrollBar); { Load horz scrollbar } - GetPeerViewPtr(S, VScrollBar); { Load vert scrollbar } - S.Read(i, SizeOf(i)); Delta.X:=i; { Read delta x value } - S.Read(i, SizeOf(i)); Delta.Y:=i; { Read delta y value } - S.Read(i, SizeOf(i)); Limit.X:=i; { Read limit x value } - S.Read(i, SizeOf(i)); Limit.Y:=i; { Read limit y value } -END; - -{--TScroller----------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } -{---------------------------------------------------------------------------} -FUNCTION TScroller.GetPalette: PPalette; -CONST P: String[Length(CScroller)] = CScroller; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Scroller palette } -END; - -{--TScroller----------------------------------------------------------------} -{ ScrollTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScroller.ScrollTo (X, Y: Sw_Integer); -BEGIN - Inc(DrawLock); { Set draw lock } - If (HScrollBar<>Nil) Then HScrollBar^.SetValue(X); { Set horz scrollbar } - If (VScrollBar<>Nil) Then VScrollBar^.SetValue(Y); { Set vert scrollbar } - Dec(DrawLock); { Release draw lock } - CheckDraw; { Check need to draw } -END; - -{--TScroller----------------------------------------------------------------} -{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScroller.SetState (AState: Word; Enable: Boolean); - - PROCEDURE ShowSBar (SBar: PScrollBar); - BEGIN - If (SBar <> Nil) Then { Scroll bar valid } - If GetState(sfActive + sfSelected) Then { Check state masks } - SBar^.Show Else SBar^.Hide; { Draw appropriately } - END; - -BEGIN - Inherited SetState(AState, Enable); { Call ancestor } - If (AState AND (sfActive + sfSelected) <> 0) { Active/select change } - Then Begin - ShowSBar(HScrollBar); { Redraw horz scrollbar } - ShowSBar(VScrollBar); { Redraw vert scrollbar } - End; -END; - -{--TScroller----------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } -{---------------------------------------------------------------------------} -{ The scroller is saved to the stream compatable with the old TV object. } -{---------------------------------------------------------------------------} -PROCEDURE TScroller.Store (Var S: TStream); -VAR i: Integer; -BEGIN - TView.Store(S); { Call TView explicitly } - PutPeerViewPtr(S, HScrollBar); { Store horz bar } - PutPeerViewPtr(S, VScrollBar); { Store vert bar } - i:=Delta.X;S.Write(i, SizeOf(i)); { Write delta x value } - i:=Delta.Y;S.Write(i, SizeOf(i)); { Write delta y value } - i:=Limit.X;S.Write(i, SizeOf(i)); { Write limit x value } - i:=Limit.Y;S.Write(i, SizeOf(i)); { Write limit y value } -END; - -{--TScroller----------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScroller.HandleEvent (Var Event: TEvent); -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - If (Event.What = evBroadcast) AND - (Event.Command = cmScrollBarChanged) AND { Scroll bar change } - ((Event.InfoPtr = HScrollBar) OR { Our scrollbar? } - (Event.InfoPtr = VScrollBar)) Then ScrollDraw; { Redraw scroller } -END; - -{--TScroller----------------------------------------------------------------} -{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TScroller.ChangeBounds (Var Bounds: TRect); -BEGIN - SetBounds(Bounds); { Set new bounds } - Inc(DrawLock); { Set draw lock } - SetLimit(Limit.X, Limit.Y); { Adjust limits } - Dec(DrawLock); { Release draw lock } - DrawFlag := False; { Clear draw flag } - DrawView; { Redraw now } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TListViewer OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -CONST TvListViewerName = 'LISTBOX'; { Native name } - -{--TListViewer--------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TListViewer.Init (Var Bounds: TRect; ANumCols: Sw_Word; AHScrollBar, - AVScrollBar: PScrollBar); -VAR ArStep, PgStep: Sw_Integer; -BEGIN - Inherited Init(Bounds); { Call ancestor } - Options := Options OR (ofFirstClick+ofSelectable); { Set options } - EventMask := EventMask OR evBroadcast; { Set event mask } - NumCols := ANumCols; { Hold column number } - If (AVScrollBar <> Nil) Then Begin { Chk vert scrollbar } - If (NumCols = 1) Then Begin { Only one column } - PgStep := Size.Y -1; { Set page size } - ArStep := 1; { Set step size } - End Else Begin { Multiple columns } - PgStep := Size.Y * NumCols; { Set page size } - ArStep := Size.Y; { Set step size } - End; - AVScrollBar^.SetStep(PgStep, ArStep); { Set scroll values } - End; - If (AHScrollBar <> Nil) Then - AHScrollBar^.SetStep(Size.X DIV NumCols, 1); { Set step size } - HScrollBar := AHScrollBar; { Horz scrollbar held } - VScrollBar := AVScrollBar; { Vert scrollbar held } -END; - -{--TListViewer--------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TListViewer.Load (Var S: TStream); -VAR w: Word; -BEGIN - Inherited Load(S); { Call ancestor } - GetPeerViewPtr(S, HScrollBar); { Get horz scrollbar } - GetPeerViewPtr(S, VScrollBar); { Get vert scrollbar } - S.Read(w, SizeOf(w)); NumCols:=w; { Read column number } - S.Read(w, SizeOf(w)); TopItem:=w; { Read top most item } - S.Read(w, SizeOf(w)); Focused:=w; { Read focused item } - S.Read(w, SizeOf(w)); Range:=w; { Read listview range } -END; - -{--TListViewer--------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TListViewer.GetPalette: PPalette; -CONST P: String[Length(CListViewer)] = CListViewer; { Always normal string } -BEGIN - GetPalette := PPalette(@P); { Return palette } -END; - -{--TListViewer--------------------------------------------------------------} -{ IsSelected -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TListViewer.IsSelected (Item: Sw_Integer): Boolean; -BEGIN - If (Item = Focused) Then IsSelected := True Else - IsSelected := False; { Selected item } -END; - -{--TListViewer--------------------------------------------------------------} -{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } -{---------------------------------------------------------------------------} -FUNCTION TListViewer.GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; -BEGIN { Abstract method } - GetText := ''; { Return empty } -END; - -{--TListViewer--------------------------------------------------------------} -{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListViewer.Draw; -VAR I, J, ColWidth, Item, Indent, CurCol: Sw_Integer; - Color: Word; SCOff: Byte; - Text: String; B: TDrawBuffer; -BEGIN - ColWidth := Size.X DIV NumCols + 1; { Calc column width } - If (HScrollBar = Nil) Then Indent := 0 Else { Set indent to zero } - Indent := HScrollBar^.Value; { Fetch any indent } - For I := 0 To Size.Y - 1 Do Begin { For each line } - For J := 0 To NumCols-1 Do Begin { For each column } - Item := J*Size.Y + I + TopItem; { Process this item } - CurCol := J*ColWidth; { Current column } - If (State AND (sfSelected + sfActive) = - (sfSelected + sfActive)) AND (Focused = Item) { Focused item } - AND (Range > 0) Then Begin - Color := GetColor(3); { Focused colour } - SetCursor(CurCol+1,I); { Set the cursor } - SCOff := 0; { Zero colour offset } - End Else If (Item < Range) AND IsSelected(Item){ Selected item } - Then Begin - Color := GetColor(4); { Selected color } - SCOff := 2; { Colour offset=2 } - End Else Begin - Color := GetColor(2); { Normal Color } - SCOff := 4; { Colour offset=4 } - End; - MoveChar(B[CurCol], ' ', Color, ColWidth); { Clear buffer } - If (Item < Range) Then Begin { Within text range } - Text := GetText(Item, ColWidth + Indent); { Fetch text } - Text := Copy(Text, Indent, ColWidth); { Select right bit } - MoveStr(B[CurCol+1], Text, Color); { Transfer to buffer } - If ShowMarkers Then Begin - WordRec(B[CurCol]).Lo := Byte( - SpecialChars[SCOff]); { Set marker character } - WordRec(B[CurCol+ColWidth-2]).Lo := Byte( - SpecialChars[SCOff+1]); { Set marker character } - End; - End; - MoveChar(B[CurCol+ColWidth-1], #179, - GetColor(5), 1); { Put centre line marker } - End; - WriteLine(0, I, Size.X, 1, B); { Write line to screen } - End; -END; - - -{--TListViewer--------------------------------------------------------------} -{ FocusItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListViewer.FocusItem (Item: Sw_Integer); -BEGIN - Focused := Item; { Set focus to item } - If (VScrollBar <> Nil) Then - VScrollBar^.SetValue(Item); { Scrollbar to value } - If (Item < TopItem) Then { Item above top item } - If (NumCols = 1) Then TopItem := Item { Set top item } - Else TopItem := Item - Item MOD Size.Y { Set top item } - Else If (Item >= TopItem + (Size.Y*NumCols)) Then { Item below bottom } - If (NumCols = 1) Then TopItem := Item-Size.Y+1 { Set new top item } - Else TopItem := Item - Item MOD Size.Y - - (Size.Y*(NumCols-1)); { Set new top item } -END; - -{--TListViewer--------------------------------------------------------------} -{ SetTopItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Aug99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListViewer.SetTopItem (Item: Sw_Integer); -BEGIN - TopItem := Item; { Set the top item } -END; - -{--TListViewer--------------------------------------------------------------} -{ SetRange -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListViewer.SetRange (ARange: Sw_Integer); -BEGIN - Range := ARange; { Set new range } - If (VScrollBar <> Nil) Then Begin { Vertical scrollbar } - If (Focused > ARange) Then Focused := 0; { Clear focused } - VScrollBar^.SetParams(Focused, 0, ARange - 1, - VScrollBar^.PgStep, VScrollBar^.ArStep); { Set parameters } - End; -END; - -{--TListViewer--------------------------------------------------------------} -{ SelectItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListViewer.SelectItem (Item: Sw_Integer); -BEGIN - Message(Owner, evBroadcast, cmListItemSelected, - @Self); { Send message } -END; - -{--TListViewer--------------------------------------------------------------} -{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListViewer.SetState (AState: Word; Enable: Boolean); - - PROCEDURE ShowSBar(SBar: PScrollBar); - BEGIN - If (SBar <> Nil) Then { Valid scrollbar } - If GetState(sfActive) AND GetState(sfVisible) { Check states } - Then SBar^.Show Else SBar^.Hide; { Show or hide } - END; - -BEGIN - Inherited SetState(AState, Enable); { Call ancestor } - If (AState AND (sfSelected + sfActive + sfVisible) <> 0) - Then Begin { Check states } - DrawView; { Draw the view } - ShowSBar(HScrollBar); { Show horz scrollbar } - ShowSBar(VScrollBar); { Show vert scrollbar } - End; -END; - -{--TListViewer--------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListViewer.Store (Var S: TStream); -VAR w: Word; -BEGIN - TView.Store(S); { Call TView explicitly } - PutPeerViewPtr(S, HScrollBar); { Put horz scrollbar } - PutPeerViewPtr(S, VScrollBar); { Put vert scrollbar } - w:=NumCols;S.Write(w, SizeOf(w)); { Write column number } - w:=TopItem;S.Write(w, SizeOf(w)); { Write top most item } - w:=Focused;S.Write(w, SizeOf(w)); { Write focused item } - w:=Range;S.Write(w, SizeOf(w)); { Write listview range } -END; - -{--TListViewer--------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListViewer.HandleEvent (Var Event: TEvent); -CONST MouseAutosToSkip = 4; -VAR Oi, Ni: Sw_Integer; Ct, Cw: Word; Mouse: TPoint; - - PROCEDURE MoveFocus (Req: Sw_Integer); - BEGIN - FocusItemNum(Req); { Focus req item } - DrawView; { Redraw focus box } - END; - -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - Case Event.What Of - evNothing: Exit; { Speed up exit } - evKeyDown: Begin { Key down event } - If (Event.CharCode = ' ') AND (Focused < Range){ Spacebar select } - Then Begin - SelectItem(Focused); { Select focused item } - Ni := Focused; { Hold new item } - End Else Case CtrlToArrow(Event.KeyCode) Of - kbUp: Ni := Focused - 1; { One item up } - kbDown: Ni := Focused + 1; { One item down } - kbRight: If (NumCols > 1) Then - Ni := Focused + Size.Y Else Exit; { One column right } - kbLeft: If (NumCols > 1) Then - Ni := Focused - Size.Y Else Exit; { One column left } - kbPgDn: Ni := Focused + Size.Y * NumCols; { One page down } - kbPgUp: Ni := Focused - Size.Y * NumCols; { One page up } - kbHome: Ni := TopItem; { Move to top } - kbEnd: Ni := TopItem + (Size.Y*NumCols)-1; { Move to bottom } - kbCtrlPgDn: Ni := Range - 1; { Move to last item } - kbCtrlPgUp: Ni := 0; { Move to first item } - Else Exit; - End; - MoveFocus(Ni); { Move the focus } - ClearEvent(Event); { Event was handled } - End; - evBroadcast: Begin { Broadcast event } - If (Options AND ofSelectable <> 0) Then { View is selectable } - If (Event.Command = cmScrollBarClicked) AND { Scrollbar click } - ((Event.InfoPtr = HScrollBar) OR - (Event.InfoPtr = VScrollBar)) Then Select { Scrollbar selects us } - Else If (Event.Command = cmScrollBarChanged) { Scrollbar changed } - Then Begin - If (VScrollBar = Event.InfoPtr) Then Begin - MoveFocus(VScrollBar^.Value); { Focus us to item } - End Else If (HScrollBar = Event.InfoPtr) - Then DrawView; { Redraw the view } - End; - End; - evMouseDown: Begin { Mouse down event } - Cw := Size.X DIV NumCols + 1; { Column width } - Oi := Focused; { Hold focused item } - MakeLocal(Event.Where, Mouse); { Localize mouse } - If MouseInView(Event.Where) Then Ni := Mouse.Y - + (Size.Y*(Mouse.X DIV Cw))+TopItem { Calc item to focus } - Else Ni := Oi; { Focus old item } - Ct := 0; { Clear count value } - Repeat - If (Ni <> Oi) Then Begin { Item is different } - MoveFocus(Ni); { Move the focus } - Oi := Focused; { Hold as focused item } - End; - MakeLocal(Event.Where, Mouse); { Localize mouse } - If NOT MouseInView(Event.Where) Then Begin - If (Event.What = evMouseAuto) Then Inc(Ct);{ Inc auto count } - If (Ct = MouseAutosToSkip) Then Begin - Ct := 0; { Reset count } - If (NumCols = 1) Then Begin { Only one column } - If (Mouse.Y < 0) Then Ni := Focused-1; { Move up one item } - If (Mouse.Y >= Size.Y) Then - Ni := Focused+1; { Move down one item } - End Else Begin { Multiple columns } - If (Mouse.X < 0) Then { Mouse x below zero } - Ni := Focused-Size.Y; { Move down 1 column } - If (Mouse.X >= Size.X) Then { Mouse x above width } - Ni := Focused+Size.Y; { Move up 1 column } - If (Mouse.Y < 0) Then { Mouse y below zero } - Ni := Focused-Focused MOD Size.Y; { Move up one item } - If (Mouse.Y > Size.Y) Then { Mouse y above height } - Ni := Focused-Focused MOD - Size.Y+Size.Y-1; { Move down one item } - End; - End; - End Else Ni := Mouse.Y + (Size.Y*(Mouse.X - DIV Cw))+TopItem; { New item to focus } - Until NOT MouseEvent(Event, evMouseMove + - evMouseAuto); { Mouse stopped } - If (Oi <> Ni) Then MoveFocus(Ni); { Focus moved again } - If (Event.Double AND (Range > Focused)) Then - SelectItem(Focused); { Select the item } - ClearEvent(Event); { Event was handled } - End; - End; -END; - -{--TListViewer--------------------------------------------------------------} -{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListViewer.ChangeBounds (Var Bounds: TRect); -BEGIN - Inherited ChangeBounds(Bounds); { Call ancestor } - If (HScrollBar <> Nil) Then { Valid horz scrollbar } - HScrollBar^.SetStep(Size.X DIV NumCols, - HScrollBar^.ArStep); { Update horz bar } - If (VScrollBar <> Nil) Then { Valid vert scrollbar } - VScrollBar^.SetStep(Size.Y * NumCols, - VScrollBar^.ArStep); { Update vert bar } -END; - -{***************************************************************************} -{ TListViewer OBJECT PRIVATE METHODS } -{***************************************************************************} - -{--TListViewer--------------------------------------------------------------} -{ FocusItemNum -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TListViewer.FocusItemNum (Item: Sw_Integer); -BEGIN - If (Item < 0) Then Item := 0 Else { Restrain underflow } - If (Item >= Range) AND (Range > 0) Then - Item := Range-1; { Restrain overflow } - If (Range <> 0) Then FocusItem(Item); { Set focus value } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TWindow OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{--TWindow------------------------------------------------------------------} -{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -CONSTRUCTOR TWindow.Init (Var Bounds: TRect; ATitle: TTitleStr; ANumber: Sw_Integer); -BEGIN - Inherited Init(Bounds); { Call ancestor } - State := State OR sfShadow; { View is shadowed } - Options := Options OR (ofSelectable+ofTopSelect); { Select options set } - GrowMode := gfGrowAll + gfGrowRel; { Set growmodes } - Flags := wfMove + wfGrow + wfClose + wfZoom; { Set flags } - Title := NewStr(ATitle); { Hold title } - Number := ANumber; { Hold number } - Palette := wpBlueWindow; { Default palette } - InitFrame; { Initialize frame } - If (Frame <> Nil) Then Insert(Frame); { Insert any frame } - GetBounds(ZoomRect); { Default zoom rect } -END; - -{--TWindow------------------------------------------------------------------} -{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -{ This load method will read old original TV data from a stream however } -{ although a frame view is read for compatability it is disposed of. } -{---------------------------------------------------------------------------} -CONSTRUCTOR TWindow.Load (Var S: TStream); -VAR I: Integer; -BEGIN - Inherited Load(S); { Call ancestor } - S.Read(Flags, SizeOf(Flags)); { Read window flags } - S.Read(i, SizeOf(i)); Number:=i; { Read window number } - S.Read(i, SizeOf(i)); Palette:=i; { Read window palette } - S.Read(i, SizeOf(i)); ZoomRect.A.X:=i; { Read zoom area x1 } - S.Read(i, SizeOf(i)); ZoomRect.A.Y:=i; { Read zoom area y1 } - S.Read(i, SizeOf(i)); ZoomRect.B.X:=i; { Read zoom area x2 } - S.Read(i, SizeOf(i)); ZoomRect.B.Y:=i; { Read zoom area y2 } - GetSubViewPtr(S, Frame); { Now read frame object } - Title := S.ReadStr; { Read title } -END; - -{--TWindow------------------------------------------------------------------} -{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -DESTRUCTOR TWindow.Done; -BEGIN - Inherited Done; { Call ancestor } - If (Title <> Nil) Then DisposeStr(Title); { Dispose title } -END; - -{--TWindow------------------------------------------------------------------} -{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TWindow.GetPalette: PPalette; -CONST P: ARRAY [wpBlueWindow..wpGrayWindow] Of String[Length(CBlueWindow)] = - (CBlueWindow, CCyanWindow, CGrayWindow); { Always normal string } -BEGIN - GetPalette := PPalette(@P[Palette]); { Return palette } -END; - -{--TWindow------------------------------------------------------------------} -{ GetTitle -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{ Modified 31may2002 PM (No number included anymore) } -{---------------------------------------------------------------------------} -FUNCTION TWindow.GetTitle (MaxSize: Sw_Integer): TTitleStr; -VAR S: String; -BEGIN - If (Title <> Nil) Then S:=Title^ - Else S := ''; - if Length(S)>MaxSize then - GetTitle:=Copy(S,1,MaxSize) - else - GetTitle:=S; -END; - -{--TWindow------------------------------------------------------------------} -{ StandardScrollBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION TWindow.StandardScrollBar (AOptions: Word): PScrollBar; -VAR R: TRect; S: PScrollBar; -BEGIN - GetExtent(R); { View extents } - If (AOptions AND sbVertical = 0) Then - R.Assign(R.A.X+2, R.B.Y-1, R.B.X-2, R.B.Y) { Horizontal scrollbar } - Else R.Assign(R.B.X-1, R.A.Y+1, R.B.X, R.B.Y-1); { Vertical scrollbar } - S := New(PScrollBar, Init(R)); { Create scrollbar } - Insert(S); { Insert scrollbar } - If (AOptions AND sbHandleKeyboard <> 0) Then - S^.Options := S^.Options or ofPostProcess; { Post process } - StandardScrollBar := S; { Return scrollbar } -END; - -{--TWindow------------------------------------------------------------------} -{ Zoom -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TWindow.Zoom; -VAR R: TRect; Max, Min: TPoint; -BEGIN - SizeLimits(Min, Max); { Return size limits } - If ((Size.X <> Max.X) OR (Size.Y <> Max.Y)) { Larger size possible } - Then Begin - GetBounds(ZoomRect); { Get zoom bounds } - R.A.X := 0; { Zero x origin } - R.A.Y := 0; { Zero y origin } - R.B := Max; { Bounds to max size } - Locate(R); { Locate the view } - End Else Locate(ZoomRect); { Move to zoom rect } -END; - -{--TWindow------------------------------------------------------------------} -{ Close -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TWindow.Close; -BEGIN - If Valid(cmClose) Then Free; { Dispose of self } -END; - -{--TWindow------------------------------------------------------------------} -{ InitFrame -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TWindow.InitFrame; -VAR - R: TRect; -BEGIN - GetExtent(R); - Frame := New(PFrame, Init(R)); -END; - -{--TWindow------------------------------------------------------------------} -{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Mar98 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TWindow.SetState (AState: Word; Enable: Boolean); -VAR WindowCommands: TCommandSet; -BEGIN - Inherited SetState(AState, Enable); { Call ancestor } - If (AState = sfSelected) Then - SetState(sfActive, Enable); { Set active state } - If (AState = sfSelected) OR ((AState = sfExposed) - AND (State AND sfSelected <> 0)) Then Begin { View is selected } - WindowCommands := [cmNext, cmPrev]; { Set window commands } - If (Flags AND (wfGrow + wfMove) <> 0) Then - WindowCommands := WindowCommands + [cmResize]; { Add resize command } - If (Flags AND wfClose <> 0) Then - WindowCommands := WindowCommands + [cmClose]; { Add close command } - If (Flags AND wfZoom <> 0) Then - WindowCommands := WindowCommands + [cmZoom]; { Add zoom command } - If Enable Then EnableCommands(WindowCommands) { Enable commands } - Else DisableCommands(WindowCommands); { Disable commands } - End; -END; - -{--TWindow------------------------------------------------------------------} -{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Mar98 LdB } -{---------------------------------------------------------------------------} -{ You can save data to the stream compatable with the old original TV by } -{ temporarily turning off the ofGrafVersion making the call to this store } -{ routine and resetting the ofGrafVersion flag after the call. } -{---------------------------------------------------------------------------} -PROCEDURE TWindow.Store (Var S: TStream); -VAR i: Integer; -BEGIN - TGroup.Store(S); { Call group store } - S.Write(Flags, SizeOf(Flags)); { Write window flags } - i:=Number;S.Write(i, SizeOf(i)); { Write window number } - i:=Palette;S.Write(i, SizeOf(i)); { Write window palette } - i:=ZoomRect.A.X;S.Write(i, SizeOf(i)); { Write zoom area x1 } - i:=ZoomRect.A.Y;S.Write(i, SizeOf(i)); { Write zoom area y1 } - i:=ZoomRect.B.X;S.Write(i, SizeOf(i)); { Write zoom area x2 } - i:=ZoomRect.B.Y;S.Write(i, SizeOf(i)); { Write zoom area y2 } - PutSubViewPtr(S, Frame); { Write any frame } - S.WriteStr(Title); { Write title string } -END; - -{--TWindow------------------------------------------------------------------} -{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11Aug99 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TWindow.HandleEvent (Var Event: TEvent); -VAR - Min, Max: TPoint; Limits: TRect; - - PROCEDURE DragWindow (Mode: Byte); - VAR Limits: TRect; Min, Max: TPoint; - BEGIN - Owner^.GetExtent(Limits); { Get owner extents } - SizeLimits(Min, Max); { Restrict size } - DragView(Event, DragMode OR Mode, Limits, Min, - Max); { Drag the view } - ClearEvent(Event); { Clear the event } - END; - -BEGIN - Inherited HandleEvent(Event); { Call ancestor } - Case Event.What Of - evNothing: Exit; { Speeds up exit } - evCommand: { COMMAND EVENT } - Case Event.Command Of { Command type case } - cmResize: { RESIZE COMMAND } - If (Flags AND (wfMove + wfGrow) <> 0) { Window can resize } - AND (Owner <> Nil) Then Begin { Valid owner } - Owner^.GetExtent(Limits); { Owners extents } - SizeLimits(Min, Max); { Check size limits } - DragView(Event, DragMode OR (Flags AND - (wfMove + wfGrow)), Limits, Min, Max); { Drag the view } - ClearEvent(Event); { Clear the event } - End; - cmClose: { CLOSE COMMAND } - If (Flags AND wfClose <> 0) AND { Close flag set } - ((Event.InfoPtr = Nil) OR { None specific close } - (Event.InfoPtr = @Self)) Then Begin { Close to us } - ClearEvent(Event); { Clear the event } - If (State AND sfModal = 0) Then Close { Non modal so close } - Else Begin { Modal window } - Event.What := evCommand; { Command event } - Event.Command := cmCancel; { Cancel command } - PutEvent(Event); { Place on queue } - ClearEvent(Event); { Clear the event } - End; - End; - cmZoom: { ZOOM COMMAND } - If (Flags AND wfZoom <> 0) AND { Zoom flag set } - ((Event.InfoPtr = Nil) OR { No specific zoom } - (Event.InfoPtr = @Self)) Then Begin - Zoom; { Zoom our window } - ClearEvent(Event); { Clear the event } - End; - End; - evBroadcast: { BROADCAST EVENT } - If (Event.Command = cmSelectWindowNum) AND - (Event.InfoInt = Number) AND { Select our number } - (Options AND ofSelectable <> 0) Then Begin { Is view selectable } - Select; { Select our view } - ClearEvent(Event); { Clear the event } - End; - evKeyDown: Begin { KEYDOWN EVENT } - Case Event.KeyCode Of - kbTab: Begin { TAB KEY } - FocusNext(False); { Select next view } - ClearEvent(Event); { Clear the event } - End; - kbShiftTab: Begin { SHIFT TAB KEY } - FocusNext(True); { Select prior view } - ClearEvent(Event); { Clear the event } - End; - End; - End; - End; { Event.What case end } -END; - -{--TWindow------------------------------------------------------------------} -{ SizeLimits -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TWindow.SizeLimits (Var Min, Max: TPoint); -BEGIN - Inherited SizeLimits(Min, Max); { View size limits } - Min.X := MinWinSize.X; { Set min x size } - Min.Y := MinWinSize.Y; { Set min y size } -END; - - - -{--TView--------------------------------------------------------------------} -{ Exposed -> Platforms DOS/DPMI/WIN/OS2 - Checked 17Sep97 LdB } -{---------------------------------------------------------------------------} -function TView.do_ExposedRec1(x1,x2:sw_integer; p:PView):boolean; -var - G : PGroup; - dy,dx : sw_integer; -begin - while true do - begin - p:=p^.Next; - G:=p^.Owner; - if p=staticVar2.target then - begin - do_exposedRec1:=do_exposedRec2(x1,x2,G); - Exit; - end; - dy:=p^.origin.y; - dx:=p^.origin.x; - if ((p^.state and sfVisible)<>0) and (staticVar2.y>=dy) then - begin - if staticVar2.y<dy+p^.size.y then - begin - if x1<dx then - begin - if x2<=dx then - continue; - if x2>dx+p^.size.x then - begin - if do_exposedRec1(x1,dx,p) then - begin - do_exposedRec1:=True; - Exit; - end; - x1:=dx+p^.size.x; - end - else - x2:=dx; - end - else - begin - if x1<dx+p^.size.x then - x1:=dx+p^.size.x; - if x1>=x2 then - begin - do_exposedRec1:=False; - Exit; - end; - end; - end; - end; - end; -end; - - -function TView.do_ExposedRec2(x1,x2:Sw_integer; p:PView):boolean; -var - G : PGroup; - savedStat : TStatVar2; -begin - if (p^.state and sfVisible)=0 then - do_ExposedRec2:=false - else - begin - G:=p^.Owner; - if (G=Nil) or (G^.Buffer<>Nil) then - do_ExposedRec2:=true - else - begin - savedStat:=staticVar2; - inc(staticVar2.y,p^.origin.y); - inc(x1,p^.origin.x); - inc(x2,p^.origin.x); - staticVar2.target:=p; - if (staticVar2.y<G^.clip.a.y) or (staticVar2.y>=G^.clip.b.y) then - do_ExposedRec2:=false - else - begin - if (x1<G^.clip.a.x) then - x1:=G^.clip.a.x; - if (x2>G^.clip.b.x) then - x2:=G^.clip.b.x; - if (x1>=x2) then - do_ExposedRec2:=false - else - do_ExposedRec2:=do_exposedRec1(x1,x2,G^.Last); - end; - staticVar2 := savedStat; - end; - end; -end; - - -function TView.Exposed: Boolean; -var - OK : boolean; - y : sw_integer; -begin - if ((State and sfExposed)<>0) and (Size.X>0) and (Size.Y>0) then - begin - OK:=false; - y:=0; - while (y<Size.Y) and (not OK) do - begin - staticVar2.y:=y; - OK:=do_ExposedRec2(0,Size.X,@Self); - inc(y); - end; - Exposed:=OK; - end - else - Exposed:=False -end; - - -{--TView--------------------------------------------------------------------} -{ MakeLocal -> Platforms DOS/DPMI/WIN/OS2 - Checked 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.MakeLocal (Source: TPoint; Var Dest: TPoint); -var - cur : PView; -begin - cur:=@Self; - Dest:=Source; - repeat - dec(Dest.X,cur^.Origin.X); - if dest.x<0 then - break; - dec(Dest.Y,cur^.Origin.Y); - if dest.y<0 then - break; - cur:=cur^.Owner; - until cur=nil; -end; - - -{--TView--------------------------------------------------------------------} -{ MakeGlobal -> Platforms DOS/DPMI/WIN/OS2 - Checked 12Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TView.MakeGlobal (Source: TPoint; Var Dest: TPoint); -var - cur : PView; -begin - cur:=@Self; - Dest:=Source; - repeat - inc(Dest.X,cur^.Origin.X); - inc(Dest.Y,cur^.Origin.Y); - cur:=cur^.Owner; - until cur=nil; -end; - - -procedure TView.do_writeViewRec1(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); -var - G : PGroup; - c : Word; - BufPos, - SrcPos, - l,dx : Sw_integer; -begin - repeat - p:=p^.Next; - if (p=staticVar2.target) then - begin - G:=p^.Owner; - if (G^.buffer<>Nil) then - begin - BufPos:=G^.size.x * staticVar2.y + x1; - SrcPos:=x1 - staticVar2.offset; - l:=x2-x1; - if (shadowCounter=0) then - move(staticVar1^[SrcPos],PVideoBuf(G^.buffer)^[BufPos],l shl 1) - else - begin { paint with shadowAttr } - while (l>0) do - begin - c:=staticVar1^[SrcPos]; - WordRec(c).hi:=shadowAttr; - PVideoBuf(G^.buffer)^[BufPos]:=c; - inc(BufPos); - inc(SrcPos); - dec(l); - end; - end; - end; - if G^.lockFlag=0 then - do_writeViewRec2(x1,x2,G,shadowCounter); - exit; - end; { p=staticVar2.target } - - if ((p^.state and sfVisible)<>0) and (staticVar2.y>=p^.Origin.Y) then - begin - if staticVar2.y<p^.Origin.Y+p^.size.Y then - begin - if x1<p^.origin.x then - begin - if x2<=p^.origin.x then - continue; - do_writeViewRec1(x1,p^.origin.x,p,shadowCounter); - x1:=p^.origin.x; - end; - dx:=p^.origin.x+p^.size.x; - if (x2<=dx) then - exit; - if (x1<dx) then - x1:=dx; - inc(dx,shadowSize.x); - if ((p^.state and sfShadow)<>0) and (staticVar2.y>=p^.origin.y+shadowSize.y) then - if (x1>dx) then - continue - else - begin - inc(shadowCounter); - if (x2<=dx) then - continue - else - begin - do_writeViewRec1(x1,dx,p,shadowCounter); - x1:=dx; - dec(shadowCounter); - continue; - end; - end - else - continue; - end; - - if ((p^.state and sfShadow)<>0) and (staticVar2.y<p^.origin.y+p^.size.y+shadowSize.y) then - begin - dx:=p^.origin.x+shadowSize.x; - if x1<dx then - begin - if x2<=dx then - continue; - do_writeViewRec1(x1,dx,p,shadowCounter); - x1:=dx; - end; - inc(dx,p^.size.x); - if x1>=dx then - continue; - inc(shadowCounter); - if x2<=dx then - continue - else - begin - do_writeViewRec1(x1,dx,p,shadowCounter); - x1:=dx; - dec(shadowCounter); - end; - end; - end; - until false; -end; - - -procedure TView.do_writeViewRec2(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); -var - savedStatics : TstatVar2; - dx : Sw_integer; - G : PGroup; -begin - G:=P^.Owner; - if ((p^.State and sfVisible) <> 0) and (G<>Nil) then - begin - savedStatics:=staticVar2; - inc(staticVar2.y,p^.Origin.Y); - dx:=p^.Origin.X; - inc(x1,dx); - inc(x2,dx); - inc(staticVar2.offset,dx); - staticVar2.target:=p; - if (staticVar2.y >= G^.clip.a.y) and (staticVar2.y < G^.clip.b.y) then - begin - if (x1<g^.clip.a.x) then - x1 := g^.clip.a.x; - if (x2>g^.clip.b.x) then - x2 := g^.clip.b.x; - if x1<x2 then - do_writeViewRec1(x1,x2,G^.Last,shadowCounter); - end; - staticVar2 := savedStatics; - end; -end; - - -procedure TView.do_WriteView(x1,x2,y:Sw_integer; var Buf); -begin - if (y>=0) and (y<Size.Y) then - begin - if x1<0 then - x1:=0; - if x2>Size.X then - x2:=Size.X; - if x1<x2 then - begin - staticVar2.offset:=x1; - staticVar2.y:=y; - staticVar1:=@Buf; - do_writeViewRec2( x1, x2, @Self, 0 ); - end; - end; -end; - - -procedure TView.WriteBuf(X, Y, W, H: Sw_Integer; var Buf); -var - i : Sw_integer; -begin - if h>0 then - for i:= 0 to h-1 do - do_writeView(X,X+W,Y+i,TVideoBuf(Buf)[W*i]); -end; - - -procedure TView.WriteChar(X,Y:Sw_Integer; C:Char; Color:Byte; Count:Sw_Integer); -var - B : TDrawBuffer; - myChar : word; - i : Sw_integer; -begin - myChar:=MapColor(Color); - myChar:=(myChar shl 8) + ord(C); - if Count>0 then - begin - if Count>maxViewWidth then - Count:=maxViewWidth; - for i:=0 to Count-1 do - B[i]:=myChar; - do_writeView(X,X+Count,Y,B); - end; - DrawScreenBuf(false); -end; - - -procedure TView.WriteLine(X, Y, W, H: Sw_Integer; var Buf); -var - i:Sw_integer; -begin - if h>0 then - for i:=0 to h-1 do - do_writeView(x,x+w,y+i,buf); - DrawScreenBuf(false); -end; - - -procedure TView.WriteStr(X, Y: Sw_Integer; Str: String; Color: Byte); -var - l,i : Sw_word; - B : TDrawBuffer; - myColor : word; -begin - l:=length(Str); - if l>0 then - begin - if l>maxViewWidth then - l:=maxViewWidth; - MyColor:=MapColor(Color); - MyColor:=MyColor shl 8; - for i:=0 to l-1 do - B[i]:=MyColor+ord(Str[i+1]); - do_writeView(x,x+l,y,b); - end; - DrawScreenBuf(false); -end; - - -procedure TView.DragView(Event: TEvent; Mode: Byte; - var Limits: TRect; MinSize, MaxSize: TPoint); -var - P, S: TPoint; - SaveBounds: TRect; - - procedure MoveGrow(P, S: TPoint); - var - R: TRect; - begin - S.X := Min(Max(S.X, MinSize.X), MaxSize.X); - S.Y := Min(Max(S.Y, MinSize.Y), MaxSize.Y); - P.X := Min(Max(P.X, Limits.A.X - S.X + 1), Limits.B.X - 1); - P.Y := Min(Max(P.Y, Limits.A.Y - S.Y + 1), Limits.B.Y - 1); - if Mode and dmLimitLoX <> 0 then P.X := Max(P.X, Limits.A.X); - if Mode and dmLimitLoY <> 0 then P.Y := Max(P.Y, Limits.A.Y); - if Mode and dmLimitHiX <> 0 then P.X := Min(P.X, Limits.B.X - S.X); - if Mode and dmLimitHiY <> 0 then P.Y := Min(P.Y, Limits.B.Y - S.Y); - R.Assign(P.X, P.Y, P.X + S.X, P.Y + S.Y); - Locate(R); - end; - - procedure Change(DX, DY: Sw_Integer); - begin - if (Mode and dmDragMove <> 0) and (Event.KeyShift{GetShiftState} and $03 = 0) then - begin - Inc(P.X, DX); - Inc(P.Y, DY); - end else - if (Mode and dmDragGrow <> 0) and (Event.KeyShift{GetShiftState} and $03 <> 0) then - begin - Inc(S.X, DX); - Inc(S.Y, DY); - end; - end; - - procedure Update(X, Y: Sw_Integer); - begin - if Mode and dmDragMove <> 0 then - begin - P.X := X; - P.Y := Y; - end; - end; - -begin - SetState(sfDragging, True); - if Event.What = evMouseDown then - begin - if Mode and dmDragMove <> 0 then - begin - P.X := Origin.X - Event.Where.X; - P.Y := Origin.Y - Event.Where.Y; - repeat - Inc(Event.Where.X, P.X); - Inc(Event.Where.Y, P.Y); - MoveGrow(Event.Where, Size); - until not MouseEvent(Event, evMouseMove); - {We need to process the mouse-up event, since not all terminals - send drag events.} - Inc(Event.Where.X, P.X); - Inc(Event.Where.Y, P.Y); - MoveGrow(Event.Where, Size); - end else - begin - P.X := Size.X - Event.Where.X; - P.Y := Size.Y - Event.Where.Y; - repeat - Inc(Event.Where.X, P.X); - Inc(Event.Where.Y, P.Y); - MoveGrow(Origin, Event.Where); - until not MouseEvent(Event, evMouseMove); - {We need to process the mouse-up event, since not all terminals - send drag events.} - Inc(Event.Where.X, P.X); - Inc(Event.Where.Y, P.Y); - MoveGrow(Origin, Event.Where); - end; - end else - begin - GetBounds(SaveBounds); - repeat - P := Origin; - S := Size; - KeyEvent(Event); - case Event.KeyCode and $FF00 of - kbLeft: Change(-1, 0); - kbRight: Change(1, 0); - kbUp: Change(0, -1); - kbDown: Change(0, 1); - kbCtrlLeft: Change(-8, 0); - kbCtrlRight: Change(8, 0); - kbHome: Update(Limits.A.X, P.Y); - kbEnd: Update(Limits.B.X - S.X, P.Y); - kbPgUp: Update(P.X, Limits.A.Y); - kbPgDn: Update(P.X, Limits.B.Y - S.Y); - end; - MoveGrow(P, S); - until (Event.KeyCode = kbEnter) or (Event.KeyCode = kbEsc); - if Event.KeyCode = kbEsc then - Locate(SaveBounds); - end; - SetState(sfDragging, False); -end; - - -{***************************************************************************} -{ TScroller OBJECT METHODS } -{***************************************************************************} - -PROCEDURE TScroller.ScrollDraw; -VAR D: TPoint; -BEGIN - If (HScrollBar<>Nil) Then D.X := HScrollBar^.Value - Else D.X := 0; { Horz scroll value } - If (VScrollBar<>Nil) Then D.Y := VScrollBar^.Value - Else D.Y := 0; { Vert scroll value } - If (D.X<>Delta.X) OR (D.Y<>Delta.Y) Then Begin { View has moved } - SetCursor(Cursor.X+Delta.X-D.X, - Cursor.Y+Delta.Y-D.Y); { Move the cursor } - Delta := D; { Set new delta } - If (DrawLock<>0) Then DrawFlag := True { Draw will need draw } - Else DrawView; { Redraw the view } - End; -END; - -PROCEDURE TScroller.SetLimit (X, Y: Sw_Integer); -VAR PState: Word; -BEGIN - Limit.X := X; { Hold x limit } - Limit.Y := Y; { Hold y limit } - Inc(DrawLock); { Set draw lock } - If (HScrollBar<>Nil) Then Begin - PState := HScrollBar^.State; { Hold bar state } - HScrollBar^.State := PState AND NOT sfVisible; { Temp not visible } - HScrollBar^.SetParams(HScrollBar^.Value, 0, - X-Size.X, Size.X-1, HScrollBar^.ArStep); { Set horz scrollbar } - HScrollBar^.State := PState; { Restore bar state } - End; - If (VScrollBar<>Nil) Then Begin - PState := VScrollBar^.State; { Hold bar state } - VScrollBar^.State := PState AND NOT sfVisible; { Temp not visible } - VScrollBar^.SetParams(VScrollBar^.Value, 0, - Y-Size.Y, Size.Y-1, VScrollBar^.ArStep); { Set vert scrollbar } - VScrollBar^.State := PState; { Restore bar state } - End; - Dec(DrawLock); { Release draw lock } - CheckDraw; { Check need to draw } -END; - -{***************************************************************************} -{ TScroller OBJECT PRIVATE METHODS } -{***************************************************************************} -PROCEDURE TScroller.CheckDraw; -BEGIN - If (DrawLock = 0) AND DrawFlag Then Begin { Clear & draw needed } - DrawFlag := False; { Clear draw flag } - DrawView; { Draw now } - End; -END; - - - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ TGroup OBJECT METHODS } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - - - - -{--TGroup-------------------------------------------------------------------} -{ Lock -> Platforms DOS/DPMI/WIN/OS2 - Checked 23Sep97 LdB } -{---------------------------------------------------------------------------} -{$ifndef NoLock} -{$define UseLock} -{$endif ndef NoLock} -PROCEDURE TGroup.Lock; -BEGIN -{$ifdef UseLock} - {If (Buffer <> Nil) OR (LockFlag <> 0) - Then} Inc(LockFlag); { Increment count } -{$endif UseLock} -END; - -{--TGroup-------------------------------------------------------------------} -{ UnLock -> Platforms DOS/DPMI/WIN/OS2 - Checked 23Sep97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE TGroup.Unlock; -BEGIN -{$ifdef UseLock} - If (LockFlag <> 0) Then Begin - Dec(LockFlag); { Decrement count } - If (LockFlag = 0) Then DrawView; { Lock release draw } - End; -{$endif UseLock} -END; - - -{***************************************************************************} -{ INTERFACE ROUTINES } -{***************************************************************************} - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ WINDOW MESSAGE ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ Message -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION Message (Receiver: PView; What, Command: Word; - InfoPtr: Pointer): Pointer; -VAR Event: TEvent; -BEGIN - Message := Nil; { Preset nil } - If (Receiver <> Nil) Then Begin { Valid receiver } - Event.What := What; { Set what } - Event.Command := Command; { Set command } - Event.Id := 0; { Zero id field } - Event.Data := 0; { Zero data field } - Event.InfoPtr := InfoPtr; { Set info ptr } - Receiver^.HandleEvent(Event); { Pass to handler } - If (Event.What = evNothing) Then - Message := Event.InfoPtr; { Return handler } - End; -END; - -{---------------------------------------------------------------------------} -{ NewMessage -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Sep97 LdB } -{---------------------------------------------------------------------------} -FUNCTION NewMessage (P: PView; What, Command: Word; Id: Sw_Integer; - Data: Real; InfoPtr: Pointer): Pointer; -VAR Event: TEvent; -BEGIN - NewMessage := Nil; { Preset failure } - If (P <> Nil) Then Begin - Event.What := What; { Set what } - Event.Command := Command; { Set event command } - Event.Id := Id; { Set up Id } - Event.Data := Data; { Set up data } - Event.InfoPtr := InfoPtr; { Set up event ptr } - P^.HandleEvent(Event); { Send to view } - If (Event.What = evNothing) Then - NewMessage := Event.InfoPtr; { Return handler } - End; -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ NEW VIEW ROUTINES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ CreateIdScrollBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Checked 22May97 LdB } -{---------------------------------------------------------------------------} -FUNCTION CreateIdScrollBar (X, Y, Size, Id: Sw_Integer; Horz: Boolean): PScrollBar; -VAR R: TRect; P: PScrollBar; -BEGIN - If Horz Then R.Assign(X, Y, X+Size, Y+1) Else { Horizontal bar } - R.Assign(X, Y, X+1, Y+Size); { Vertical bar } - P := New(PScrollBar, Init(R)); { Create scrollbar } - If (P <> Nil) Then Begin - P^.Id := Id; { Set scrollbar id } - P^.Options := P^.Options OR ofPostProcess; { Set post processing } - End; - CreateIdScrollBar := P; { Return scrollbar } -END; - -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} -{ OBJECT REGISTRATION PROCEDURES } -{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} - -{---------------------------------------------------------------------------} -{ RegisterViews -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May97 LdB } -{---------------------------------------------------------------------------} -PROCEDURE RegisterViews; -BEGIN - RegisterType(RView); { Register views } - RegisterType(RFrame); { Register frame } - RegisterType(RScrollBar); { Register scrollbar } - RegisterType(RScroller); { Register scroller } - RegisterType(RListViewer); { Register listview } - RegisterType(RGroup); { Register group } - RegisterType(RWindow); { Register window } -END; - -END. +{$I views.inc} diff --git a/packages/rtl-console/fpmake.pp b/packages/rtl-console/fpmake.pp index 649d6b813f..7a5195a248 100644 --- a/packages/rtl-console/fpmake.pp +++ b/packages/rtl-console/fpmake.pp @@ -46,6 +46,7 @@ begin P.Description := 'Rtl-console, console abstraction'; P.NeedLibC:= false; P.Dependencies.Add('rtl-extra'); // linux,android gpm. + P.Dependencies.Add('rtl-unicode'); P.Dependencies.Add('morphunits',[morphos]); P.Dependencies.Add('arosunits',[aros]); if Defaults.CPU=m68k then @@ -78,6 +79,7 @@ begin AddInclude('nwsys.inc',[netware]); AddUnit ('mouse',AllUnixOSes); AddUnit ('video',[win16]); + AddUnit ('unixkvmbase',AllUnixOSes); end; T:=P.Targets.AddUnit('mouse.pp',MouseOSes); @@ -98,6 +100,7 @@ begin AddInclude('convert.inc',AllUnixOSes); AddInclude('nwsys.inc',[netware]); AddUnit ('mouse',[go32v2,msdos]); + AddUnit ('unixkvmbase',AllUnixOSes); end; T:=P.Targets.AddUnit('crt.pp',CrtOSes); @@ -126,6 +129,8 @@ begin AddUnit('video'); AddUnit('mouse'); end; + + T:=P.Targets.AddUnit('unixkvmbase.pp',AllUnixOSes); end end; diff --git a/packages/rtl-console/src/amicommon/keyboard.pp b/packages/rtl-console/src/amicommon/keyboard.pp index c6f5239258..6f3acb7773 100644 --- a/packages/rtl-console/src/amicommon/keyboard.pp +++ b/packages/rtl-console/src/amicommon/keyboard.pp @@ -624,6 +624,8 @@ const // TranslateKeyEvent : @SysTranslateKeyEvent; TranslateKeyEvent : Nil; TranslateKeyEventUnicode : Nil; + GetEnhancedKeyEvent : Nil; + PollEnhancedKeyEvent : Nil; ); diff --git a/packages/rtl-console/src/amicommon/video.pp b/packages/rtl-console/src/amicommon/video.pp index f591bb5690..f06e75b7b1 100644 --- a/packages/rtl-console/src/amicommon/video.pp +++ b/packages/rtl-console/src/amicommon/video.pp @@ -55,7 +55,7 @@ var implementation uses - exec, agraphics; + exec, agraphics, graphemebreakproperty, eastasianwidth, charset; procedure SysUpdateScreen(Force: Boolean); forward; @@ -849,6 +849,7 @@ end; const SysVideoDriver : TVideoDriver = ( InitDriver : @SysInitVideo; + InitEnhancedDriver : Nil; DoneDriver : @SysDoneVideo; UpdateScreen : @SysUpdateScreen; ClearScreen : @SysClearScreen; @@ -858,7 +859,11 @@ const SetCursorPos : @SysSetCursorPos; GetCursorType : @SysGetCursorType; SetCursorType : @SysSetCursorType; - GetCapabilities : @SysGetCapabilities + GetCapabilities : @SysGetCapabilities; + GetActiveCodePage : Nil; + ActivateCodePage : Nil; + GetSupportedCodePageCount : Nil; + GetSupportedCodePage : Nil; ); {$ifdef Amiga68k} function CreateRastport: PRastPort; diff --git a/packages/rtl-console/src/go32v2/keyboard.pp b/packages/rtl-console/src/go32v2/keyboard.pp index aee69f0386..829a4d070a 100644 --- a/packages/rtl-console/src/go32v2/keyboard.pp +++ b/packages/rtl-console/src/go32v2/keyboard.pp @@ -68,6 +68,8 @@ Const GetShiftState : @SysGetShiftState; TranslateKeyEvent : Nil; TranslateKeyEventUnicode : Nil; + GetEnhancedKeyEvent : Nil; + PollEnhancedKeyEvent : Nil; ); begin diff --git a/packages/rtl-console/src/go32v2/video.pp b/packages/rtl-console/src/go32v2/video.pp index 8733a162a0..52460cf85a 100644 --- a/packages/rtl-console/src/go32v2/video.pp +++ b/packages/rtl-console/src/go32v2/video.pp @@ -27,7 +27,8 @@ implementation uses mouse, - go32; + go32, + graphemebreakproperty,eastasianwidth,charset; {$i video.inc} @@ -305,17 +306,22 @@ end; Const SysVideoDriver : TVideoDriver = ( - InitDriver : @SysInitVideo; - DoneDriver : @SysDoneVideo; - UpdateScreen : @SysUpdateScreen; - ClearScreen : Nil; - SetVideoMode : @SysSetVideoMode; - GetVideoModeCount : @SysGetVideoModeCount; - GetVideoModeData : @SysGetVideoModedata; - SetCursorPos : @SysSetCursorPos; - GetCursorType : @SysGetCursorType; - SetCursorType : @SysSetCursorType; - GetCapabilities : @SysGetCapabilities + InitDriver : @SysInitVideo; + InitEnhancedDriver : Nil; + DoneDriver : @SysDoneVideo; + UpdateScreen : @SysUpdateScreen; + ClearScreen : Nil; + SetVideoMode : @SysSetVideoMode; + GetVideoModeCount : @SysGetVideoModeCount; + GetVideoModeData : @SysGetVideoModedata; + SetCursorPos : @SysSetCursorPos; + GetCursorType : @SysGetCursorType; + SetCursorType : @SysSetCursorType; + GetCapabilities : @SysGetCapabilities; + GetActiveCodePage : Nil; + ActivateCodePage : Nil; + GetSupportedCodePageCount : Nil; + GetSupportedCodePage : Nil; ); initialization diff --git a/packages/rtl-console/src/inc/keyboard.inc b/packages/rtl-console/src/inc/keyboard.inc index 5a35b53f1f..c8b3916078 100644 --- a/packages/rtl-console/src/inc/keyboard.inc +++ b/packages/rtl-console/src/inc/keyboard.inc @@ -82,6 +82,68 @@ begin end; +{ Converts an Extended 101/102-Keyboard function scan code (as returned by int + 16h, AH=10h/11h) to a standard 101/102-Keyboard function scan code (as would + be returned by int 16h, AH=00h/01h). However, keys that are not returned by + the standard keyboard function (e.g. F11, F12, etc.) are still let through. + Only those that return different codes are converted. } +function ConvertExtendedToStandardScanCode(ScanCode: Word): Word; +begin + if (ScanCode and $FF)=$E0 then + ConvertExtendedToStandardScanCode:=ScanCode and $FF00 + else + case ScanCode of + { Numpad Enter -> Regular Enter } + $E00D: + ConvertExtendedToStandardScanCode:=$1C0D; + { Ctrl + Numpad Enter -> Ctrl + Regular Enter } + $E00A: + ConvertExtendedToStandardScanCode:=$1C0A; + { Numpad '/' -> Regular '/' } + $E02F: + ConvertExtendedToStandardScanCode:=$352F; + else + ConvertExtendedToStandardScanCode:=ScanCode; + end; +end; + + +function ConvertEnhancedToLegacyShiftState(const ShiftState: TEnhancedShiftState): Byte; +begin + ConvertEnhancedToLegacyShiftState:=0; + if essAlt in ShiftState then + ConvertEnhancedToLegacyShiftState:=ConvertEnhancedToLegacyShiftState or kbAlt; + if essCtrl in ShiftState then + ConvertEnhancedToLegacyShiftState:=ConvertEnhancedToLegacyShiftState or kbCtrl; + if essShift in ShiftState then + begin + if ([essLeftShift,essRightShift]*ShiftState)=[] then + ConvertEnhancedToLegacyShiftState:=ConvertEnhancedToLegacyShiftState or kbShift + else + begin + if essLeftShift in ShiftState then + ConvertEnhancedToLegacyShiftState:=ConvertEnhancedToLegacyShiftState or kbLeftShift; + if essRightShift in ShiftState then + ConvertEnhancedToLegacyShiftState:=ConvertEnhancedToLegacyShiftState or kbRightShift; + end; + end; + { AltGr triggers both kbAlt and kbCtrl in the legacy shift state } + if essAltGr in ShiftState then + ConvertEnhancedToLegacyShiftState:=ConvertEnhancedToLegacyShiftState or (kbAlt or kbCtrl); +end; + + +function ConvertToLegacyKeyEvent(const KeyEvent: TEnhancedKeyEvent): TKeyEvent; +begin + if KeyEvent=NilEnhancedKeyEvent then + ConvertToLegacyKeyEvent:=0 + else + ConvertToLegacyKeyEvent:=(kbPhys shl 24) or + ConvertExtendedToStandardScanCode(KeyEvent.VirtualScanCode) or + (ConvertEnhancedToLegacyShiftState(KeyEvent.ShiftState) shl 16); +end; + + function GetKeyEvent: TKeyEvent; begin @@ -93,6 +155,8 @@ begin end; If Assigned(CurrentKeyBoardDriver.GetKeyEvent) Then GetKeyEvent:=CurrentKeyBoardDriver.GetKeyEvent() + else if Assigned(CurrentKeyboardDriver.GetEnhancedKeyEvent) then + GetKeyEvent:=ConvertToLegacyKeyEvent(CurrentKeyboardDriver.GetEnhancedKeyEvent()) else GetKeyEvent:=0; end; @@ -110,6 +174,8 @@ begin // PollKeyEvent procedure // to avoid problems if that procedure is called directly PM end + else if Assigned(CurrentKeyboardDriver.PollEnhancedKeyEvent) then + PollKeyEvent:=ConvertToLegacyKeyEvent(CurrentKeyboardDriver.PollEnhancedKeyEvent()) else PollKeyEvent:=0; end; @@ -154,6 +220,94 @@ begin TranslateKeyEventUnicode:=DefaultTranslateKeyEventUnicode(KeyEvent); end; +function ConvertToEnhancedKeyEvent(KeyEvent: TKeyEvent): TEnhancedKeyEvent; +var + TranslatedKeyEvent: TKeyEvent; + ShiftState: Byte; +begin + ConvertToEnhancedKeyEvent:=NilEnhancedKeyEvent; + if KeyEvent=0 then + exit; + ConvertToEnhancedKeyEvent.ShiftState:=[]; + ShiftState:=GetKeyEventShiftState(KeyEvent); + if (kbAlt and ShiftState)<>0 then + Include(ConvertToEnhancedKeyEvent.ShiftState,essAlt); + if (kbCtrl and ShiftState)<>0 then + Include(ConvertToEnhancedKeyEvent.ShiftState,essCtrl); + if (kbShift and ShiftState)<>0 then + begin + Include(ConvertToEnhancedKeyEvent.ShiftState,essShift); + if (kbLeftShift and ShiftState)<>0 then + Include(ConvertToEnhancedKeyEvent.ShiftState,essLeftShift); + if (kbRightShift and ShiftState)<>0 then + Include(ConvertToEnhancedKeyEvent.ShiftState,essRightShift); + end; + case GetKeyEventFlags(KeyEvent) of + kbASCII: + ConvertToEnhancedKeyEvent.AsciiChar:=GetKeyEventChar(KeyEvent); + kbUniCode: + ConvertToEnhancedKeyEvent.UnicodeChar:=WideChar(GetKeyEventUniCode(KeyEvent)); + kbFnKey: + ConvertToEnhancedKeyEvent.VirtualKeyCode:=GetKeyEventCode(KeyEvent); + kbPhys: + ConvertToEnhancedKeyEvent.VirtualScanCode:=KeyEvent and $ffff; + end; + TranslatedKeyEvent:=TranslateKeyEvent(KeyEvent); + case GetKeyEventFlags(TranslatedKeyEvent) of + kbASCII: + ConvertToEnhancedKeyEvent.AsciiChar:=GetKeyEventChar(TranslatedKeyEvent); + kbUniCode: + ConvertToEnhancedKeyEvent.UnicodeChar:=WideChar(GetKeyEventUniCode(TranslatedKeyEvent)); + kbFnKey: + ConvertToEnhancedKeyEvent.VirtualKeyCode:=GetKeyEventCode(TranslatedKeyEvent); + kbPhys: + ConvertToEnhancedKeyEvent.VirtualScanCode:=TranslatedKeyEvent and $ffff; + end; + { todo: set ConvertToEnhancedKeyEvent.Flags } + if (ConvertToEnhancedKeyEvent.UnicodeChar=WideChar(0)) and + (ConvertToEnhancedKeyEvent.AsciiChar>=#0) and + (ConvertToEnhancedKeyEvent.AsciiChar<=#127) then + ConvertToEnhancedKeyEvent.UnicodeChar:=WideChar(ConvertToEnhancedKeyEvent.AsciiChar); + { todo: maybe also convert extended ASCII (>=#128) codes to Unicode as well + (according to the console code page) } +end; + +function DefaultGetEnhancedKeyEvent: TEnhancedKeyEvent; +begin + DefaultGetEnhancedKeyEvent:=ConvertToEnhancedKeyEvent(GetKeyEvent); +end; + +function GetEnhancedKeyEvent: TEnhancedKeyEvent; +begin + if Assigned(CurrentKeyBoardDriver.GetEnhancedKeyEvent) then + GetEnhancedKeyEvent:=CurrentKeyBoardDriver.GetEnhancedKeyEvent() + else + GetEnhancedKeyEvent:=DefaultGetEnhancedKeyEvent; +end; + +function DefaultPollEnhancedKeyEvent: TEnhancedKeyEvent; +begin + DefaultPollEnhancedKeyEvent:=ConvertToEnhancedKeyEvent(PollKeyEvent); +end; + +function PollEnhancedKeyEvent: TEnhancedKeyEvent; +begin + if Assigned(CurrentKeyBoardDriver.PollEnhancedKeyEvent) then + PollEnhancedKeyEvent:=CurrentKeyBoardDriver.PollEnhancedKeyEvent() + else + PollEnhancedKeyEvent:=DefaultPollEnhancedKeyEvent; +end; + +operator = (const a, b: TEnhancedKeyEvent) res: Boolean; +begin + res:=(a.VirtualKeyCode = b.VirtualKeyCode) and + (a.VirtualScanCode = b.VirtualScanCode) and + (a.UnicodeChar = b.UnicodeChar) and + (a.AsciiChar = b.AsciiChar) and + (a.ShiftState = b.ShiftState) and + (a.Flags = b.Flags); +end; + type TTranslationEntry = packed record Min, Max: Byte; diff --git a/packages/rtl-console/src/inc/keybrdh.inc b/packages/rtl-console/src/inc/keybrdh.inc index 327550d4ba..5bea6d4c5a 100644 --- a/packages/rtl-console/src/inc/keybrdh.inc +++ b/packages/rtl-console/src/inc/keybrdh.inc @@ -54,8 +54,96 @@ type dependent. System dependent constants may be defined to cover those, with possibily having the same name (but different value). } -{ System independent function key codes } + TEnhancedShiftStateElement = ( + essShift, { either Left or Right Shift is pressed } + essLeftShift, + essRightShift, + essCtrl, { either Left or Right Ctrl is pressed } + essLeftCtrl, + essRightCtrl, + essAlt, { either Left or Right Alt is pressed, but *not* AltGr } + essLeftAlt, + essRightAlt, { only on keyboard layouts, without AltGr } + essAltGr, { only on keyboard layouts, with AltGr instead of Right Alt } + essCapsLockPressed, + essCapsLockOn, + essNumLockPressed, + essNumLockOn, + essScrollLockPressed, + essScrollLockOn + ); + TEnhancedShiftState = set of TEnhancedShiftStateElement; + { Note: not all consoles are able to distinguish between Left and Right Shift, + Ctrl and Alt. + + Valid examples: + [essShift] - Either Left or Right Shift is + pressed. Console is NOT able to + distinguish between Left and Right + Shift. + [essShift,essLeftShift] - Left Shift is pressed. Console CAN + distinguish between Left and Right + Shift. + [essShift,essRightShift] - Right shift is pressed. Console CAN + distinguish between Left and Right + Shift. + [essShift,essLeftShift,essRightShift] - Both Left Shift and Right Shift are + pressed. Console CAN distinguish + between Left and Right Shift. + + Invalid examples (it is a bug, if a console driver ever generates these): + [essLeftShift] - missing essShift + [essRightShift] - missing essShift + [essLeftShift,essRightShift] - missing essShift + + Exactly the same principle applies to essCtrl, essLeftCtrl and essRightCtrl. + + For Alt, it depends on whether the current keyboard layout has a Right Alt + or an AltGr key. If it's Right Alt, then essAltGr will not be seen, and the + same principle described above applies to essAlt, essLeftAlt and + essRightAlt. If the keyboard layout has an AltGr key, instead of Right Alt, + then essRightAlt is not generated. The AltGr key generates only essAltGr, + without essAlt, so for keyboards with AltGr instead of Right Alt: + + [essAltGr] - AltGr is pressed. + [essAlt,essLeftAlt] - Left Alt is pressed. + [essAlt,essLeftAlt, essAltGr] - Both Left Alt and AltGr are pressed. + [essAlt,essAltGr] - Both (usually Left) Alt and AltGr are pressed, but the + console is unable to distinguish between Left Alt and + Right Alt (if it existed and was not marked AltGr - in + theory it is possible for someone to make a keyboard + with three separate keys: Left Alt, Right Alt and AltGr). + [essAlt,essLeftAlt,essRightAlt,essAltGr] - The keyboard has three separate + keys: Left Alt, Right Alt and + AltGr and they are all pressed. + + Note that Windows handles AltGr internally as Left Ctrl+Right Alt, which we + detect and convert to essAltGr, but this makes it impossible to distinguish + between Left Ctrl+AltGr and only AltGr, since there's no way to tell whether + the Left Ctrl that Windows report is dummy or real, so we always assume it's + dummy and remove it from the shift state, if AltGr was pressed. + } + + TEnhancedKeyEvent = record + VirtualKeyCode: Word; { device-independent identifier of the key } + VirtualScanCode: Word; { device-dependent value, generated by the keyboard } + UnicodeChar: WideChar; { the translated Unicode character } + AsciiChar: Char; { the translated ASCII character } + ShiftState: TEnhancedShiftState; + Flags: Byte; + end; + const +{ The Nil value for the enhanced key event } + NilEnhancedKeyEvent: TEnhancedKeyEvent = ( + VirtualKeyCode: 0; + VirtualScanCode: 0; + UnicodeChar: #0; + AsciiChar: #0; + ShiftState: []; + Flags: 0; + ); +{ System independent function key codes } kbdF1 = $FF01; kbdF2 = $FF02; kbdF3 = $FF03; @@ -135,6 +223,8 @@ Type GetShiftState : Function : Byte; TranslateKeyEvent : Function (KeyEvent: TKeyEvent): TKeyEvent; TranslateKeyEventUniCode : Function (KeyEvent: TKeyEvent): TKeyEvent; + GetEnhancedKeyEvent : Function : TEnhancedKeyEvent; + PollEnhancedKeyEvent : Function : TEnhancedKeyEvent; end; procedure InitKeyboard; @@ -200,3 +290,15 @@ Function FunctionKeyName (KeyCode : Word) : String; Function KeyEventToString(KeyEvent : TKeyEvent) : String; { Returns a string representation of the pressed key } +function GetEnhancedKeyEvent: TEnhancedKeyEvent; +{ Returns the last keyevent, and waits for one if not available } + +function PollEnhancedKeyEvent: TEnhancedKeyEvent; +{ Checks if a keyevent is available, and returns it if one is found. If no + event is pending, it returns 0 } + +function ConvertEnhancedToLegacyShiftState(const ShiftState: TEnhancedShiftState): Byte; +{ Converts an enhanced shift state (as in TEnhancedKeyEvent.ShiftState) to a + legacy shift state (as returned by GetShiftState or GetKeyEventShiftState) } + +operator = (const a, b: TEnhancedKeyEvent) res: Boolean; diff --git a/packages/rtl-console/src/inc/video.inc b/packages/rtl-console/src/inc/video.inc index 841a56d569..110091aa59 100644 --- a/packages/rtl-console/src/inc/video.inc +++ b/packages/rtl-console/src/inc/video.inc @@ -11,6 +11,86 @@ **********************************************************************} +const + convert_lowascii_to_Unicode:array[#0..#31] of WideChar=( + #8199,#9786,#9787,#9829,#9830,#9827,#9824,#8226, + #9688,#9675,#9689,#9794,#9792,#9834,#9835,#9788, + #9658,#9668,#8597,#8252,#0182,#0167,#9644,#8616, + #8593,#8595,#8594,#8592,#8735,#8596,#9650,#9660 + ); + +{ TEnhancedVideoCell } + +operator = (const a,b : TEnhancedVideoCell) res: Boolean; +begin + res:=(a.Attribute=b.Attribute) and (a.ExtendedGraphemeCluster = b.ExtendedGraphemeCluster); +end; + +function TEnhancedVideoCell.GetAttribute: Byte; +begin + GetAttribute := Byte(FAttributes); +end; + +procedure TEnhancedVideoCell.SetAttribute(Attr: Byte); +begin + FAttributes := (FAttributes and $FF00) or Attr; +end; + +function TEnhancedVideoCell.GetExtendedGraphemeCluster: UnicodeString; +begin + if (FAttributes and $8000) = 0 then + GetExtendedGraphemeCluster := EGC_SingleChar + else + GetExtendedGraphemeCluster := UnicodeString(EGC_WideStr); +end; + +procedure TEnhancedVideoCell.SetExtendedGraphemeCluster(const AExtendedGraphemeCluster: UnicodeString); +begin + if Length(AExtendedGraphemeCluster) = 1 then + begin + if (FAttributes and $8000) <> 0 then + begin + FAttributes := FAttributes and $7FFF; + UnicodeString(EGC_WideStr) := ''; + end; + EGC_SingleChar := AExtendedGraphemeCluster[1]; + end + else + begin + if (FAttributes and $8000) = 0 then + begin + FAttributes := FAttributes or $8000; + EGC_WideStr := nil; + end; + UnicodeString(EGC_WideStr) := AExtendedGraphemeCluster; + end; +end; + +class operator TEnhancedVideoCell.Initialize(var evc: TEnhancedVideoCell); +begin + evc.FAttributes := 0; +end; + +class operator TEnhancedVideoCell.Finalize(var evc: TEnhancedVideoCell); +begin + if (evc.FAttributes and $8000) <> 0 then + UnicodeString(evc.EGC_WideStr) := ''; +end; + +Procedure fpc_UnicodeStr_Incr_Ref(S : Pointer); external name 'FPC_UNICODESTR_INCR_REF'; + +class operator TEnhancedVideoCell.AddRef(var evc: TEnhancedVideoCell); +begin + if (evc.FAttributes and $8000) <> 0 then + fpc_UnicodeStr_Incr_Ref(evc.EGC_WideStr); +end; + +class operator TEnhancedVideoCell.Copy(constref aSrc: TEnhancedVideoCell; var aDst: TEnhancedVideoCell); +begin + aDst.ExtendedGraphemeCluster := aSrc.ExtendedGraphemeCluster; + aDst.Attribute := aSrc.Attribute; +end; + Const LockUpdateScreen : Integer = 0; @@ -35,22 +115,26 @@ end; Var CurrentVideoDriver : TVideoDriver; NextVideoMode : TVideoMode; + CurrentLegacy2EnhancedTranslationCodePage: TSystemCodePage; Const VideoInitialized : Boolean = False; + EnhancedVideoInitialized : Boolean = False; DriverInitialized : Boolean = False; NextVideoModeSet : Boolean = False; Function SetVideoDriver (Const Driver : TVideoDriver) : Boolean; { Sets the videodriver to be used } begin - If Not VideoInitialized then - Begin - CurrentVideoDriver:=Driver; + if (not VideoInitialized) and (not EnhancedVideoInitialized) then + begin + CurrentVideoDriver:=Driver; DriverInitialized:=true; NextVideoModeSet:=false; - End; - SetVideoDriver:=Not VideoInitialized; + SetVideoDriver:=true; + end + else + SetVideoDriver:=false; end; Procedure GetVideoDriver (Var Driver : TVideoDriver); @@ -68,49 +152,47 @@ Procedure FreeVideoBuf; begin if (VideoBuf<>Nil) then begin - FreeMem(VideoBuf); - FreeMem(OldVideoBuf); - VideoBuf:=Nil; - OldVideoBuf:=Nil; - VideoBufSize:=0; + FreeMem(VideoBuf); + FreeMem(OldVideoBuf); + VideoBuf:=Nil; + OldVideoBuf:=Nil; + VideoBufSize:=0; end; end; -(* -Procedure AssignVideoBuf (OldCols, OldRows : Word); - -Var NewVideoBuf,NewOldVideoBuf : PVideoBuf; - I,C,R,NewVideoBufSize : longint; - s:word; +procedure FreeEnhancedVideoBuf; +begin + SetLength(EnhancedVideoBuf,0); + SetLength(OldEnhancedVideoBuf,0); +end; +procedure EnhancedVideoBufResize(var Buf: TEnhancedVideoBuf; OldCols, OldRows : Word); +var + NewVideoBufSize : SizeUInt; + NewBuf: TEnhancedVideoBuf; + Y, X, YS, XS: Integer; begin - S:=sizeOf(TVideoCell); - NewVideoBufSize:=ScreenWidth*ScreenHeight*s; - GetMem(NewVideoBuf,NewVideoBufSize); - GetMem(NewOldVideoBuf,NewVideoBufSize); - // Move contents of old videobuffers to new if there are any. - if (VideoBuf<>Nil) then + NewVideoBufSize:=ScreenWidth*ScreenHeight; + if OldCols<>ScreenWidth then begin - If (ScreenWidth<OldCols) then - C:=ScreenWidth - else - C:=OldCols; - If (ScreenHeight<OldRows) then - R:=ScreenHeight - else - R:=OldRows; - For I:=0 to R-1 do - begin - Move(VideoBuf^[I*OldCols],NewVideoBuf^[I*ScreenWidth],S*C); - Move(OldVideoBuf^[I*OldCols],NewOldVideoBuf^[I*ScreenWidth],S*C); - end; - end; - FreeVideoBuf; - VideoBufSize:=NewVideoBufSize; - VideoBuf:=NewVideoBuf; - OldVideoBuf:=NewOldVideoBuf; + SetLength(NewBuf,NewVideoBufSize); + if OldRows<ScreenHeight then + YS := OldRows + else + YS := ScreenHeight; + if OldCols<ScreenWidth then + XS := OldCols + else + XS := ScreenWidth; + for Y := 0 to YS-1 do + for X := 0 to XS-1 do + NewBuf[Y*ScreenWidth+X]:=Buf[Y*OldCols+X]; + Buf:=NewBuf; + end + else + SetLength(Buf,NewVideoBufSize); end; -*) + Procedure AssignVideoBuf (OldCols, OldRows : Word); var NewVideoBuf,NewOldVideoBuf:PVideoBuf; @@ -118,32 +200,40 @@ var NewVideoBuf,NewOldVideoBuf:PVideoBuf; NewVideoBufSize : longint; begin - NewVideoBufSize:=ScreenWidth*ScreenHeight*sizeof(TVideoCell); - GetMem(NewVideoBuf,NewVideoBufSize); - GetMem(NewOldVideoBuf,NewVideoBufSize); - {Move contents of old videobuffers to new if there are any.} - if VideoBuf<>nil then + if VideoInitialized or Assigned(CurrentVideoDriver.InitDriver) then begin - if ScreenWidth<OldCols then - OldCols:=ScreenWidth; - if ScreenHeight<OldRows then - OldRows:=ScreenHeight; - old_rowstart:=0; - new_rowstart:=0; - while oldrows>0 do + NewVideoBufSize:=ScreenWidth*ScreenHeight*sizeof(TVideoCell); + GetMem(NewVideoBuf,NewVideoBufSize); + GetMem(NewOldVideoBuf,NewVideoBufSize); + {Move contents of old videobuffers to new if there are any.} + if VideoBuf<>nil then begin - move(VideoBuf^[old_rowstart],NewVideoBuf^[new_rowstart],OldCols*sizeof(TVideoCell)); - move(OldVideoBuf^[old_rowstart],NewOldVideoBuf^[new_rowstart],OldCols*sizeof(TVideoCell)); - inc(old_rowstart,OldCols); - inc(new_rowstart,ScreenWidth); - dec(OldRows); + if ScreenWidth<OldCols then + OldCols:=ScreenWidth; + if ScreenHeight<OldRows then + OldRows:=ScreenHeight; + old_rowstart:=0; + new_rowstart:=0; + while oldrows>0 do + begin + move(VideoBuf^[old_rowstart],NewVideoBuf^[new_rowstart],OldCols*sizeof(TVideoCell)); + move(OldVideoBuf^[old_rowstart],NewOldVideoBuf^[new_rowstart],OldCols*sizeof(TVideoCell)); + inc(old_rowstart,OldCols); + inc(new_rowstart,ScreenWidth); + dec(OldRows); + end; end; + FreeVideoBuf; + { FreeVideoBuf sets VideoBufSize to 0 } + VideoBufSize:=NewVideoBufSize; + VideoBuf:=NewVideoBuf; + OldVideoBuf:=NewOldVideoBuf; + end; + if EnhancedVideoInitialized or Assigned(CurrentVideoDriver.InitEnhancedDriver) then + begin + EnhancedVideoBufResize(EnhancedVideoBuf,OldCols,OldRows); + EnhancedVideoBufResize(OldEnhancedVideoBuf,OldCols,OldRows); end; - FreeVideoBuf; - { FreeVideoBuf sets VideoBufSize to 0 } - VideoBufSize:=NewVideoBufSize; - VideoBuf:=NewVideoBuf; - OldVideoBuf:=NewOldVideoBuf; end; Procedure InitVideo; @@ -151,7 +241,12 @@ Procedure InitVideo; begin if not VideoInitialized then begin - if Assigned(CurrentVideoDriver.InitDriver) then + if Assigned(CurrentVideoDriver.InitEnhancedDriver) then + begin + CurrentLegacy2EnhancedTranslationCodePage := 437; + CurrentVideoDriver.InitEnhancedDriver; + end + else if Assigned(CurrentVideoDriver.InitDriver) then CurrentVideoDriver.InitDriver; if errorcode=viook then begin @@ -174,28 +269,194 @@ begin If Assigned(CurrentVideoDriver.DoneDriver) then CurrentVideoDriver.DoneDriver; FreeVideoBuf; + FreeEnhancedVideoBuf; VideoInitialized:=False; end; end; +procedure InitEnhancedVideo; +begin + if not EnhancedVideoInitialized then + begin + if Assigned(CurrentVideoDriver.InitEnhancedDriver) then + CurrentVideoDriver.InitEnhancedDriver + else if Assigned(CurrentVideoDriver.InitDriver) then + CurrentVideoDriver.InitDriver; + if errorcode=viook then + begin + EnhancedVideoInitialized:=true; + if NextVideoModeSet then + SetVideoMode(NextVideoMode) + else + AssignVideoBuf(0,0); + ClearScreen; + end; + end; +end; + +procedure DoneEnhancedVideo; +begin + if EnhancedVideoInitialized then + begin + if Assigned(CurrentVideoDriver.DoneDriver) then + CurrentVideoDriver.DoneDriver; + FreeVideoBuf; + FreeEnhancedVideoBuf; + EnhancedVideoInitialized:=False; + end; +end; + +function ExtendedGraphemeCluster2LegacyChar(const EGC: UnicodeString; CodePage: TSystemCodePage): Char; + + function GenConvert: Char; + var + tmpS: RawByteString; + begin + tmpS:=UTF8Encode(EGC); + System.SetCodePage(tmpS,CodePage,True); + if Length(tmpS)=1 then + Result:=tmpS[1] + else + Result:='?'; + end; + +var + Ch: Char; +begin + if (Length(EGC) = 1) then + begin + for Ch:=Low(convert_lowascii_to_Unicode) to High(convert_lowascii_to_Unicode) do + if convert_lowascii_to_Unicode[Ch]=EGC[1] then + begin + Result:=Ch; + exit; + end; + case Ord(EGC[1]) of + 32..126: + Result:=Chr(Ord(EGC[1])); + $2302: + Result:=#127; + else + Result:=GenConvert; + end + end + else + Result:=GenConvert; +end; + +function LegacyChar2ExtendedGraphemeCluster(const Ch: Char): UnicodeString; +var + tmpS: RawByteString; +begin + if Ch<=#31 then + Result:=convert_lowascii_to_Unicode[Ch] + else if Ch=#127 then + Result:=#$2302 + else + begin + SetLength(tmpS, 1); + tmpS[1]:=Ch; + System.SetCodePage(tmpS,CurrentLegacy2EnhancedTranslationCodePage,False); + Result:=tmpS; + end; +end; + +procedure Enhanced2Legacy; +var + I: Integer; + CodePage: TSystemCodePage; +begin + CodePage:=GetActiveCodePage(); + { todo: optimize this } + for I := 0 to Length(EnhancedVideoBuf)-1 do + begin + with EnhancedVideoBuf[I] do + VideoBuf^[I]:=(Attribute shl 8) or Ord(ExtendedGraphemeCluster2LegacyChar(ExtendedGraphemeCluster,CodePage)); + with OldEnhancedVideoBuf[I] do + OldVideoBuf^[I]:=(Attribute shl 8) or Ord(ExtendedGraphemeCluster2LegacyChar(ExtendedGraphemeCluster,CodePage)); + end; +end; + +procedure Legacy2Enhanced; +var + I: Integer; +begin + { todo: optimize this } + for I := 0 to Length(EnhancedVideoBuf)-1 do + begin + with EnhancedVideoBuf[I] do + begin + Attribute:=Byte(VideoBuf^[I] shr 8); + ExtendedGraphemeCluster:=LegacyChar2ExtendedGraphemeCluster(Chr(Byte(VideoBuf^[I]))); + end; + with OldEnhancedVideoBuf[I] do + begin + Attribute:=Byte(OldVideoBuf^[I] shr 8); + ExtendedGraphemeCluster:=LegacyChar2ExtendedGraphemeCluster(Chr(Byte(OldVideoBuf^[I]))); + end; + end; +end; + Procedure UpdateScreen (Force : Boolean); begin - If (LockUpdateScreen<=0) and + if (LockUpdateScreen<=0) and Assigned(CurrentVideoDriver.UpdateScreen) then + begin + if EnhancedVideoInitialized and Assigned(CurrentVideoDriver.InitDriver) then + Enhanced2Legacy + else if VideoInitialized and Assigned(CurrentVideoDriver.InitEnhancedDriver) then + Legacy2Enhanced; CurrentVideoDriver.UpdateScreen(Force); + end; end; -Procedure ClearScreen; - -begin +procedure ClearScreen; +const + DefaultChar=#32; // Should this not be the current color ? - FillWord(VideoBuf^,VideoBufSize shr 1,$0720); - If Assigned(CurrentVideoDriver.ClearScreen) then - CurrentVideoDriver.ClearScreen - else - UpdateScreen(True); - FillWord(OldVideoBuf^,VideoBufSize shr 1,$0720); + DefaultAttr=7; +var + I: Integer; +begin + if VideoInitialized then + begin + FillWord(VideoBuf^,VideoBufSize shr 1,(DefaultAttr shl 8) or Ord(DefaultChar)); + If Assigned(CurrentVideoDriver.ClearScreen) then + begin + if Assigned(CurrentVideoDriver.InitEnhancedDriver) then + Legacy2Enhanced; + CurrentVideoDriver.ClearScreen; + end + else + UpdateScreen(True); + FillWord(OldVideoBuf^,VideoBufSize shr 1,(DefaultAttr shl 8) or Ord(DefaultChar)); + end + else if EnhancedVideoInitialized then + begin + { todo: optimize } + for I:=0 to Length(EnhancedVideoBuf)-1 do + with EnhancedVideoBuf[I] do + begin + Attribute:=DefaultAttr; + ExtendedGraphemeCluster:=DefaultChar; + end; + If Assigned(CurrentVideoDriver.ClearScreen) then + begin + if Assigned(CurrentVideoDriver.InitDriver) then + Enhanced2Legacy; + CurrentVideoDriver.ClearScreen; + end + else + UpdateScreen(True); + { todo: optimize } + for I:=0 to Length(EnhancedVideoBuf)-1 do + with OldEnhancedVideoBuf[I] do + begin + Attribute:=DefaultAttr; + ExtendedGraphemeCluster:=DefaultChar; + end; + end; end; Procedure SetCursorType (NewType : Word); @@ -229,6 +490,115 @@ begin GetCapabilities:=0; end; +function ExtendedGraphemeClusterDisplayWidth(const EGC: UnicodeString): Integer; +var + FirstCodePoint: UCS4Char; +begin + if Length(EGC) > 0 then + begin + FirstCodePoint:=UCS4Char(EGC[1]); + if (FirstCodePoint>=$D800) and (FirstCodePoint<=$DBFF) and (Length(EGC)>=2) and + (Ord(EGC[2])>=$DC00) and (Ord(EGC[2])<=$DFFF) then + begin + FirstCodePoint := $10000+((FirstCodePoint-$D800) shl 10) or (Ord(EGC[2])-$DC00); + end; + { todo: handle emoji + modifiers } + case GetEastAsianWidth(FirstCodePoint) of + eawW, eawF: + Result := 2; + else + Result := 1; + end; + end + else + Result := 0; +end; + +function StringDisplayWidth(const S: UnicodeString): Integer; +var + EGC: UnicodeString; +begin + Result:=0; + for EGC in TUnicodeStringExtendedGraphemeClustersEnumerator.Create(S) do + Inc(Result, ExtendedGraphemeClusterDisplayWidth(EGC)); +end; + +function GetActiveCodePage: TSystemCodePage; +begin + if EnhancedVideoInitialized then + Result := CurrentLegacy2EnhancedTranslationCodePage + else if VideoInitialized and Assigned(CurrentVideoDriver.GetActiveCodePage) then + Result := CurrentVideoDriver.GetActiveCodePage() + else + Result := DefaultSystemCodePage; +end; + +{ disallowed codepages (variable length), code points larger than an 8-bit byte, etc. } +function IsDisallowedCodePage(CodePage: TSystemCodePage): Boolean; +const + CP_UTF32LE=12000; + CP_UTF32BE=12001; +begin + Result:=(CodePage=CP_ACP) or (CodePage=CP_OEMCP) or (CodePage=CP_NONE) or + (CodePage=CP_UTF8) or (CodePage=CP_UTF7) or + (CodePage=CP_UTF16) or (CodePage=CP_UTF16BE) or + (CodePage=CP_UTF32LE) or (CodePage=CP_UTF32BE); +end; + +procedure ActivateCodePage(CodePage: TSystemCodePage); +begin + if IsDisallowedCodePage(CodePage) then + exit; + if EnhancedVideoInitialized then + CurrentLegacy2EnhancedTranslationCodePage := CodePage + else if VideoInitialized and Assigned(CurrentVideoDriver.ActivateCodePage) then + CurrentVideoDriver.ActivateCodePage(CodePage); +end; + +var + SupportedCodePagesCount: Integer = -1; + SupportedCodePages: array of TSystemCodePage; + +procedure InitSupportedCodePages; +var + CP: TSystemCodePage; +begin + SetLength(SupportedCodePages, 0); + for CP:=Low(TSystemCodePage) to High(TSystemCodePage) do + if (not IsDisallowedCodePage(CP)) and MappingAvailable(CP) then + begin + SetLength(SupportedCodePages,Length(SupportedCodePages)+1); + SupportedCodePages[High(SupportedCodePages)]:=CP; + end; +end; + +function GetSupportedCodePageCount: Integer; +begin + if EnhancedVideoInitialized then + begin + if SupportedCodePagesCount = -1 then + InitSupportedCodePages; + Result := SupportedCodePagesCount; + end + else if VideoInitialized and Assigned(CurrentVideoDriver.GetSupportedCodePageCount) then + Result := CurrentVideoDriver.GetSupportedCodePageCount() + else + Result := 1; +end; + +function GetSupportedCodePage(Index: Integer): TSystemCodePage; +begin + if EnhancedVideoInitialized then + begin + if SupportedCodePagesCount = -1 then + InitSupportedCodePages; + Result := SupportedCodePages[Index]; + end + else if VideoInitialized and Assigned(CurrentVideoDriver.GetSupportedCodePage) then + Result := CurrentVideoDriver.GetSupportedCodePage(Index) + else + Result := DefaultSystemCodePage; +end; { --------------------------------------------------------------------- General functions @@ -251,7 +621,7 @@ begin SetVideoMode:=DriverInitialized; if not DriverInitialized then exit; - If VideoInitialized then + If VideoInitialized or EnhancedVideoInitialized then begin OldC:=ScreenWidth; OldR:=ScreenHeight; diff --git a/packages/rtl-console/src/inc/videoh.inc b/packages/rtl-console/src/inc/videoh.inc index 5ef02d20d0..8487f4fe0f 100644 --- a/packages/rtl-console/src/inc/videoh.inc +++ b/packages/rtl-console/src/inc/videoh.inc @@ -11,6 +11,9 @@ **********************************************************************} +{$mode objfpc} +{$modeswitch advancedrecords} + type PVideoMode = ^TVideoMode; TVideoMode = record @@ -25,18 +28,47 @@ type TVideoBuf = array[0..{$ifdef CPU16}16382{$else}32759{$endif}] of TVideoCell; PVideoBuf = ^TVideoBuf; + TEnhancedVideoCell = record + private + class operator Initialize(var evc: TEnhancedVideoCell); + class operator Finalize(var evc: TEnhancedVideoCell); + class operator AddRef(var evc: TEnhancedVideoCell); + class operator Copy(constref aSrc: TEnhancedVideoCell; var aDst: TEnhancedVideoCell); + function GetExtendedGraphemeCluster: UnicodeString; + procedure SetExtendedGraphemeCluster(const AExtendedGraphemeCluster: UnicodeString); + function GetAttribute: Byte; + procedure SetAttribute(Attr: Byte); + public + property ExtendedGraphemeCluster: UnicodeString read GetExtendedGraphemeCluster write SetExtendedGraphemeCluster; + property Attribute: Byte read GetAttribute write SetAttribute; + + private + FAttributes: Word; + case integer of + 0: (EGC_SingleChar: WideChar); + 1: (EGC_WideStr: Pointer); + end; + PEnhancedVideoCell = ^TEnhancedVideoCell; + + TEnhancedVideoBuf = array of TEnhancedVideoCell; + TVideoDriver = Record - InitDriver : Procedure; - DoneDriver : Procedure; - UpdateScreen : Procedure(Force : Boolean); - ClearScreen : Procedure; - SetVideoMode : Function (Const Mode : TVideoMode) : Boolean; - GetVideoModeCount : Function : Word; - GetVideoModeData : Function(Index : Word; Var Data : TVideoMode) : Boolean; - SetCursorPos : procedure (NewCursorX, NewCursorY: Word); - GetCursorType : function : Word; - SetCursorType : procedure (NewType: Word); - GetCapabilities : Function : Word; + InitDriver : Procedure; + InitEnhancedDriver : Procedure; + DoneDriver : Procedure; + UpdateScreen : Procedure(Force : Boolean); + ClearScreen : Procedure; + SetVideoMode : Function (Const Mode : TVideoMode) : Boolean; + GetVideoModeCount : Function : Word; + GetVideoModeData : Function(Index : Word; Var Data : TVideoMode) : Boolean; + SetCursorPos : procedure (NewCursorX, NewCursorY: Word); + GetCursorType : function : Word; + SetCursorType : procedure (NewType: Word); + GetCapabilities : Function : Word; + GetActiveCodePage : function : TSystemCodePage; + ActivateCodePage : procedure(CodePage: TSystemCodePage); + GetSupportedCodePageCount: function : Integer; + GetSupportedCodePage : function(Index: Integer): TSystemCodePage; end; const @@ -97,6 +129,8 @@ var OldVideoBuf : PVideoBuf; VideoBufSize : Longint; CursorLines : Byte; + EnhancedVideoBuf, + OldEnhancedVideoBuf: TEnhancedVideoBuf; const {The following constants were variables in the past. - Lowascii was set to true if ASCII characters < 32 were available @@ -112,6 +146,8 @@ const {The following constants were variables in the past. FVMaxWidth = 240; +operator = (const a,b : TEnhancedVideoCell) res: Boolean; + Procedure LockScreenUpdate; { Increments the screen update lock count with one.} Procedure UnlockScreenUpdate; @@ -127,6 +163,10 @@ procedure InitVideo; { Initializes the video subsystem } procedure DoneVideo; { Deinitializes the video subsystem } +procedure InitEnhancedVideo; +{ Initializes the enhanced (Unicode) video subsystem } +procedure DoneEnhancedVideo; +{ Deinitializes the enhanced (Unicode) video subsystem } function GetCapabilities: Word; { Return the capabilities of the current environment } procedure ClearScreen; @@ -140,6 +180,18 @@ function GetCursorType: Word; { Return the cursor type: Hidden, UnderLine or Block } procedure SetCursorType(NewType: Word); { Set the cursor to the given type } +function ExtendedGraphemeClusterDisplayWidth(const EGC: UnicodeString): Integer; +{ Returns the number of display columns needed for the given extended grapheme cluster } +function StringDisplayWidth(const S: UnicodeString): Integer; +{ Returns the number of display columns needed for the given string } +function GetActiveCodePage: TSystemCodePage; +{ Returns the current active legacy code page } +procedure ActivateCodePage(CodePage: TSystemCodePage); +{ Activates a specified legacy code page (if supported) } +function GetSupportedCodePageCount: Integer; +{ Get the number of code pages supported by this driver } +function GetSupportedCodePage(Index: Integer): TSystemCodePage; +{ Get the supported code page with index Index. Index is zero based. } procedure GetVideoMode(var Mode: TVideoMode); { Return dimensions of the current video mode } diff --git a/packages/rtl-console/src/msdos/keyboard.pp b/packages/rtl-console/src/msdos/keyboard.pp index 415f5a4a24..e132d47012 100644 --- a/packages/rtl-console/src/msdos/keyboard.pp +++ b/packages/rtl-console/src/msdos/keyboard.pp @@ -86,6 +86,8 @@ Const GetShiftState : @SysGetShiftState; TranslateKeyEvent : Nil; TranslateKeyEventUnicode : Nil; + GetEnhancedKeyEvent : Nil; + PollEnhancedKeyEvent : Nil; ); begin diff --git a/packages/rtl-console/src/msdos/video.pp b/packages/rtl-console/src/msdos/video.pp index aa7eef1e60..4677c1ae5a 100644 --- a/packages/rtl-console/src/msdos/video.pp +++ b/packages/rtl-console/src/msdos/video.pp @@ -27,7 +27,8 @@ implementation uses mouse, - dos; + dos, + graphemebreakproperty,eastasianwidth,charset; {$i video.inc} @@ -278,17 +279,22 @@ end; Const SysVideoDriver : TVideoDriver = ( - InitDriver : @SysInitVideo; - DoneDriver : @SysDoneVideo; - UpdateScreen : @SysUpdateScreen; - ClearScreen : Nil; - SetVideoMode : @SysSetVideoMode; - GetVideoModeCount : @SysGetVideoModeCount; - GetVideoModeData : @SysGetVideoModedata; - SetCursorPos : @SysSetCursorPos; - GetCursorType : @SysGetCursorType; - SetCursorType : @SysSetCursorType; - GetCapabilities : @SysGetCapabilities + InitDriver : @SysInitVideo; + InitEnhancedDriver : Nil; + DoneDriver : @SysDoneVideo; + UpdateScreen : @SysUpdateScreen; + ClearScreen : Nil; + SetVideoMode : @SysSetVideoMode; + GetVideoModeCount : @SysGetVideoModeCount; + GetVideoModeData : @SysGetVideoModedata; + SetCursorPos : @SysSetCursorPos; + GetCursorType : @SysGetCursorType; + SetCursorType : @SysSetCursorType; + GetCapabilities : @SysGetCapabilities; + GetActiveCodePage : Nil; + ActivateCodePage : Nil; + GetSupportedCodePageCount : Nil; + GetSupportedCodePage : Nil; ); initialization diff --git a/packages/rtl-console/src/netware/keyboard.pp b/packages/rtl-console/src/netware/keyboard.pp index 806e23f2d4..e15db9e82e 100644 --- a/packages/rtl-console/src/netware/keyboard.pp +++ b/packages/rtl-console/src/netware/keyboard.pp @@ -83,6 +83,8 @@ Const GetShiftState : @SysGetShiftState; TranslateKeyEvent : Nil; TranslateKeyEventUnicode : Nil; + GetEnhancedKeyEvent : Nil; + PollEnhancedKeyEvent : Nil; ); begin diff --git a/packages/rtl-console/src/netware/video.pp b/packages/rtl-console/src/netware/video.pp index 8380d87bcf..4ca10d37fd 100644 --- a/packages/rtl-console/src/netware/video.pp +++ b/packages/rtl-console/src/netware/video.pp @@ -23,7 +23,7 @@ interface implementation uses - dos; + dos,graphemebreakproperty,eastasianwidth,charset; {$i video.inc} {$i nwsys.inc} @@ -173,17 +173,22 @@ end; Const SysVideoDriver : TVideoDriver = ( - InitDriver : @SysInitVideo; - DoneDriver : @SysDoneVideo; - UpdateScreen : @SysUpdateScreen; - ClearScreen : Nil; - SetVideoMode : @SysSetVideoMode; - GetVideoModeCount : @SysGetVideoModeCount; - GetVideoModeData : @SysGetVideoModedata; - SetCursorPos : @SysSetCursorPos; - GetCursorType : @SysGetCursorType; - SetCursorType : @SysSetCursorType; - GetCapabilities : @SysGetCapabilities + InitDriver : @SysInitVideo; + InitEnhancedDriver : Nil; + DoneDriver : @SysDoneVideo; + UpdateScreen : @SysUpdateScreen; + ClearScreen : Nil; + SetVideoMode : @SysSetVideoMode; + GetVideoModeCount : @SysGetVideoModeCount; + GetVideoModeData : @SysGetVideoModedata; + SetCursorPos : @SysSetCursorPos; + GetCursorType : @SysGetCursorType; + SetCursorType : @SysSetCursorType; + GetCapabilities : @SysGetCapabilities; + GetActiveCodePage : Nil; + ActivateCodePage : Nil; + GetSupportedCodePageCount : Nil; + GetSupportedCodePage : Nil; ); diff --git a/packages/rtl-console/src/netwlibc/keyboard.pp b/packages/rtl-console/src/netwlibc/keyboard.pp index 1a546c193e..7149e2006c 100644 --- a/packages/rtl-console/src/netwlibc/keyboard.pp +++ b/packages/rtl-console/src/netwlibc/keyboard.pp @@ -125,6 +125,8 @@ Const GetShiftState : @SysGetShiftState; TranslateKeyEvent : nil; //@SysTranslateKeyEvent; TranslateKeyEventUnicode : Nil; + GetEnhancedKeyEvent : Nil; + PollEnhancedKeyEvent : Nil; ); begin diff --git a/packages/rtl-console/src/netwlibc/video.pp b/packages/rtl-console/src/netwlibc/video.pp index 99ad45ff80..600177ccd6 100644 --- a/packages/rtl-console/src/netwlibc/video.pp +++ b/packages/rtl-console/src/netwlibc/video.pp @@ -22,7 +22,7 @@ interface implementation uses - Libc; + Libc,graphemebreakproperty,eastasianwidth,charset; {$i video.inc} @@ -162,17 +162,22 @@ end; Const SysVideoDriver : TVideoDriver = ( - InitDriver : @SysInitVideo; - DoneDriver : @SysDoneVideo; - UpdateScreen : @SysUpdateScreen; - ClearScreen : Nil; - SetVideoMode : @SysSetVideoMode; - GetVideoModeCount : @SysGetVideoModeCount; - GetVideoModeData : @SysGetVideoModedata; - SetCursorPos : @SysSetCursorPos; - GetCursorType : @SysGetCursorType; - SetCursorType : @SysSetCursorType; - GetCapabilities : @SysGetCapabilities + InitDriver : @SysInitVideo; + InitEnhancedDriver : Nil; + DoneDriver : @SysDoneVideo; + UpdateScreen : @SysUpdateScreen; + ClearScreen : Nil; + SetVideoMode : @SysSetVideoMode; + GetVideoModeCount : @SysGetVideoModeCount; + GetVideoModeData : @SysGetVideoModedata; + SetCursorPos : @SysSetCursorPos; + GetCursorType : @SysGetCursorType; + SetCursorType : @SysSetCursorType; + GetCapabilities : @SysGetCapabilities; + GetActiveCodePage : Nil; + ActivateCodePage : Nil; + GetSupportedCodePageCount : Nil; + GetSupportedCodePage : Nil; ); diff --git a/packages/rtl-console/src/os2commn/keyboard.pp b/packages/rtl-console/src/os2commn/keyboard.pp index 48fe7014ef..0b778c6488 100644 --- a/packages/rtl-console/src/os2commn/keyboard.pp +++ b/packages/rtl-console/src/os2commn/keyboard.pp @@ -120,6 +120,8 @@ Const GetShiftState : @SysGetShiftState; TranslateKeyEvent : Nil; TranslateKeyEventUnicode : Nil; + GetEnhancedKeyEvent : Nil; + PollEnhancedKeyEvent : Nil; ); diff --git a/packages/rtl-console/src/os2commn/video.pp b/packages/rtl-console/src/os2commn/video.pp index 188ca9ecb1..70aee4a7d1 100644 --- a/packages/rtl-console/src/os2commn/video.pp +++ b/packages/rtl-console/src/os2commn/video.pp @@ -22,7 +22,7 @@ interface implementation uses - DosCalls, VioCalls, Mouse; + DosCalls, VioCalls, Mouse, graphemebreakproperty, eastasianwidth, charset; {$i video.inc} @@ -427,17 +427,22 @@ end; Const SysVideoDriver : TVideoDriver = ( - InitDriver : @SysInitVideo; - DoneDriver : @SysDoneVideo; - UpdateScreen : @SysUpdateScreen; - ClearScreen : @SysClearScreen; - SetVideoMode : @SysSetVideoMode; - GetVideoModeCount : @SysGetVideoModeCount; - GetVideoModeData : @SysGetVideoModedata; - SetCursorPos : @SysSetCursorPos; - GetCursorType : @SysGetCursorType; - SetCursorType : @SysSetCursorType; - GetCapabilities : @SysGetCapabilities + InitDriver : @SysInitVideo; + InitEnhancedDriver : nil; + DoneDriver : @SysDoneVideo; + UpdateScreen : @SysUpdateScreen; + ClearScreen : @SysClearScreen; + SetVideoMode : @SysSetVideoMode; + GetVideoModeCount : @SysGetVideoModeCount; + GetVideoModeData : @SysGetVideoModedata; + SetCursorPos : @SysSetCursorPos; + GetCursorType : @SysGetCursorType; + SetCursorType : @SysSetCursorType; + GetCapabilities : @SysGetCapabilities; + GetActiveCodePage : nil; + ActivateCodePage : nil; + GetSupportedCodePageCount : nil; + GetSupportedCodePage : nil; ); procedure TargetEntry; diff --git a/packages/rtl-console/src/unix/convert.inc b/packages/rtl-console/src/unix/convert.inc deleted file mode 100644 index 9307c9e58a..0000000000 --- a/packages/rtl-console/src/unix/convert.inc +++ /dev/null @@ -1,73 +0,0 @@ -const convert_linuxlowascii_to_vga:array[#0..#31] of word=( - $0020,$0001,$0002,$0003,$0004,$0005,$0006,$0007, - $00db,$0009,$00db,$000b,$006f,$0070,$006e,$002a, - $0010,$0011,$0012,$0013,$0014,$0015,$0016,$0017, - $0018,$0019,$001a,$0011,$001c,$001d,$001e,$001f - ); - convert_lowascii_to_iso01:array[#0..#31] of word=( - $0020,$006f,$006f,$006f,$006f,$006f,$006f,$0020, { $00..$07 } - $f861,$006f,$f861,$0064,$006f,$0070,$006e,$002a, { $08..$0f } - $003e,$003c,$007c,$0021,$00b6,$00a7,$005f,$007c, { $10..$18 } - $0076,$005e,$003e,$003c,$f86d,$f86e,$005e,$0076 { $18..$1f } - ); - convert_cp437_to_iso01:array[#128..#255] of word=( - $00c7,$00fc,$00e9,$00e2,$00e4,$00e0,$00e5,$00e7, { $80..$87 } - $00ea,$00eb,$00e8,$00ef,$00ee,$00ec,$00c4,$00c5, { $88..$8f } - $00c9,$00e6,$00c6,$00f4,$00f6,$00f2,$00fb,$00f9, { $90..$97 } - $00ff,$00d6,$00dc,$00a2,$00a3,$00a5,$0050,$0066, { $98..$9f } - $00e1,$00ed,$00f3,$00fa,$00f1,$00d1,$00aa,$00ba, { $a0..$a7 } - $00bf,$f86c,$00ac,$00bd,$00bc,$00a1,$00ab,$00bb, { $a8..$af } - $f861,$f861,$f861,$f878,$f875,$f875,$f875,$f86b, { $b0..$b7 } - $f86b,$f875,$f878,$f86b,$f86a,$f86a,$f86a,$f86b, { $b8..$bf } - $f86d,$f876,$f877,$f874,$f871,$f86e,$f874,$f874, { $c0..$c7 } - $f86d,$f86c,$f876,$f877,$f874,$f871,$f86e,$f876, { $c8..$cf } - $f876,$f877,$f877,$f86d,$f86d,$f86c,$f86c,$f86e, { $d0..$d7 } - $f86e,$f86a,$f86c,$f861,$f861,$f861,$f861,$f861, { $d8..$df } - $0061,$00df,$f86c,$f87b,$0053,$0073,$00b5,$0054, { $e0..$e7 } - $00d8,$0054,$004f,$0064,$0049,$00f8,$0065,$006e, { $e8..$ef } - $003d,$00b1,$f879,$f87a,$f878,$f878,$00f7,$00b1, { $f0..$f7 } - $00b0,$0078,$00b7,$0056,$006e,$00b2,$002a,$00a0 { $f8..$ff } - ); - convert_cp850_to_iso01:array[#128..#255] of word=( - $00c7,$00fc,$00e9,$00e2,$00e4,$00e0,$00e5,$00e7, { $80..$87 } - $00ea,$00eb,$00e8,$00ef,$00ee,$00ec,$00c4,$00c5, { $88..$8f } - $00c9,$00e6,$00c6,$00f4,$00f6,$00f2,$00fb,$00f9, { $90..$97 } - $00ff,$00d6,$00dc,$00a2,$00a3,$00a5,$0050,$0066, { $98..$9f } - $00e1,$00ed,$00f3,$00fa,$00f1,$00d1,$00aa,$00ba, { $a0..$a7 } - $00bf,$f86c,$00ac,$00bd,$00bc,$00a1,$00ab,$00bb, { $a8..$af } - $f861,$f861,$f861,$f878,$f875,$00c1,$00c2,$00c0, { $b0..$b7 } - $00a9,$f875,$f878,$f86b,$f86a,$00a2,$00a5,$f86b, { $b8..$bf } - $f86d,$f876,$f877,$f874,$f871,$f86e,$00e3,$00c3, { $c0..$c7 } - $f86d,$f86c,$f876,$f877,$f874,$f871,$f86e,$00a4, { $c8..$cf } - $00f0,$00d0,$00ca,$00cb,$00c8,$0069,$00cd,$00ce, { $d0..$d7 } - $00cf,$f86a,$f86c,$f861,$f861,$00a6,$00cc,$f861, { $d8..$df } - $00d3,$00df,$00d4,$00d2,$00f5,$00d5,$00b5,$00fe, { $e0..$e7 } - $00de,$00da,$00db,$00d9,$00fd,$00dd,$00af,$00b4, { $e8..$ef } - $00ad,$00b1,$f879,$00be,$00b6,$00a7,$00f7,$00b8, { $f0..$f7 } - $00b0,$00a8,$00b7,$00b9,$00b3,$00b2,$002a,$00a0 { $f8..$ff } - ); - convert_lowascii_to_UTF8:array[#0..#31] of WideChar=( - #8199,#9786,#9787,#9829,#9830,#9827,#9824,#8226, - #9688,#9675,#9689,#9794,#9792,#9834,#9835,#9788, - #9658,#9668,#8597,#8252,#0182,#0167,#9644,#8616, - #8593,#8595,#8594,#8592,#8735,#8596,#9650,#9660 - ); - convert_cp437_to_UTF8:array[#127..#255] of WideChar=( - #8962, { $7f } - #0199,#0252,#0233,#0226,#0228,#0224,#0229,#0231, { $80..$87 } - #0234,#0235,#0232,#0239,#0238,#0236,#0196,#0197, { $88..$8f } - #0201,#0230,#0198,#0244,#0246,#0242,#0251,#0249, { $90..$97 } - #0255,#0214,#0220,#0162,#0163,#0165,#8359,#0402, { $98..$9f } - #0225,#0237,#0243,#0250,#0241,#0209,#0170,#0186, { $a0..$a7 } - #0191,#8976,#0172,#0189,#0188,#0161,#0171,#0187, { $a8..$af } - #9617,#9618,#9619,#9474,#9508,#9569,#9570,#9558, { $b0..$b7 } - #9557,#9571,#9553,#9559,#9565,#9564,#9563,#9488, { $b8..$bf } - #9492,#9524,#9516,#9500,#9472,#9532,#9566,#9567, { $c0..$c7 } - #9562,#9556,#9577,#9574,#9568,#9552,#9580,#9575, { $c8..$cf } - #9576,#9572,#9573,#9561,#9560,#9554,#9555,#9579, { $d0..$d7 } - #9578,#9496,#9484,#9608,#9604,#9612,#9616,#9600, { $d8..$df } - #0945,#0223,#0915,#0960,#0931,#0963,#0181,#0964, { $e0..$e7 } - #0934,#0920,#0937,#0948,#8734,#0966,#0949,#8745, { $e8..$ef } - #8801,#0177,#8805,#8804,#8992,#8993,#0247,#8776, { $f0..$f7 } - #0176,#8729,#0183,#8730,#8319,#0178,#9632,#0160 { $f8..$ff } - ); diff --git a/packages/rtl-console/src/unix/keyboard.pp b/packages/rtl-console/src/unix/keyboard.pp index af39f4c2d2..c2d235b41f 100644 --- a/packages/rtl-console/src/unix/keyboard.pp +++ b/packages/rtl-console/src/unix/keyboard.pp @@ -38,6 +38,7 @@ type char : byte; ScanValue : byte; CharValue : byte; + ShiftValue : TEnhancedShiftState; SpecialHandler : Tprocedure; end; @@ -56,13 +57,14 @@ function AddSpecialSequence(const St : string;Proc : Tprocedure) : PTreeElement; {*****************************************************************************} uses - Mouse, Strings, + Mouse, Strings,unixkvmbase, termio,baseUnix {$ifdef linux},linuxvcs{$endif}; {$i keyboard.inc} var OldIO,StartTio : TermIos; + Utf8KeyboardInputEnabled: Boolean; {$ifdef linux} is_console:boolean; vt_switched_away:boolean; @@ -74,10 +76,12 @@ var OldIO,StartTio : TermIos; const KeyBufferSize = 20; var - KeyBuffer : Array[0..KeyBufferSize-1] of Char; + KeyBuffer : Array[0..KeyBufferSize-1] of TEnhancedKeyEvent; KeyPut, KeySend : longint; + PendingEnhancedKeyEvent: TEnhancedKeyEvent; + { Buffered Input routines } const InSize=256; @@ -177,9 +181,9 @@ type end; const - kbdchange:array[0..23] of chgentry=( + kbdchange:array[0..35] of chgentry=( {This prevents the alt+function keys from switching consoles. - We code the F1..F12 sequences into ALT+F1..ALT+12, we check + We code the F1..F12 sequences into ALT+F1..ALT+F12, we check the shiftstates separetely anyway.} (tab:8; idx:$3b; oldtab:0; oldidx:$3b; oldval:0; newval:0), (tab:8; idx:$3c; oldtab:0; oldidx:$3c; oldval:0; newval:0), @@ -191,10 +195,10 @@ const (tab:8; idx:$42; oldtab:0; oldidx:$42; oldval:0; newval:0), (tab:8; idx:$43; oldtab:0; oldidx:$43; oldval:0; newval:0), (tab:8; idx:$44; oldtab:0; oldidx:$44; oldval:0; newval:0), - (tab:8; idx:$45; oldtab:0; oldidx:$45; oldval:0; newval:0), - (tab:8; idx:$46; oldtab:0; oldidx:$46; oldval:0; newval:0), + (tab:8; idx:$57; oldtab:0; oldidx:$57; oldval:0; newval:0), + (tab:8; idx:$58; oldtab:0; oldidx:$58; oldval:0; newval:0), {This prevents the shift+function keys outputting strings, so - the kernel will the codes for the non-shifted function + the kernel will send the codes for the non-shifted function keys. This is desired because normally shift+f1/f2 will output the same string as f11/12. We will get the shift state separately.} (tab:1; idx:$3b; oldtab:0; oldidx:$3b; oldval:0; newval:0), @@ -207,8 +211,24 @@ const (tab:1; idx:$42; oldtab:0; oldidx:$42; oldval:0; newval:0), (tab:1; idx:$43; oldtab:0; oldidx:$43; oldval:0; newval:0), (tab:1; idx:$44; oldtab:0; oldidx:$44; oldval:0; newval:0), - (tab:1; idx:$45; oldtab:0; oldidx:$45; oldval:0; newval:0), - (tab:1; idx:$46; oldtab:0; oldidx:$46; oldval:0; newval:0) + (tab:1; idx:$57; oldtab:0; oldidx:$57; oldval:0; newval:0), + (tab:1; idx:$58; oldtab:0; oldidx:$58; oldval:0; newval:0), + {This maps ctrl+function keys outputting strings to the regular + F1..F12 keys also, because they no longer produce an ASCII + output at all in most modern linux keymaps. We obtain the + shift state separately.} + (tab:4; idx:$3b; oldtab:0; oldidx:$3b; oldval:0; newval:0), + (tab:4; idx:$3c; oldtab:0; oldidx:$3c; oldval:0; newval:0), + (tab:4; idx:$3d; oldtab:0; oldidx:$3d; oldval:0; newval:0), + (tab:4; idx:$3e; oldtab:0; oldidx:$3e; oldval:0; newval:0), + (tab:4; idx:$3f; oldtab:0; oldidx:$3f; oldval:0; newval:0), + (tab:4; idx:$40; oldtab:0; oldidx:$40; oldval:0; newval:0), + (tab:4; idx:$41; oldtab:0; oldidx:$41; oldval:0; newval:0), + (tab:4; idx:$42; oldtab:0; oldidx:$42; oldval:0; newval:0), + (tab:4; idx:$43; oldtab:0; oldidx:$43; oldval:0; newval:0), + (tab:4; idx:$44; oldtab:0; oldidx:$44; oldval:0; newval:0), + (tab:4; idx:$57; oldtab:0; oldidx:$57; oldval:0; newval:0), + (tab:4; idx:$58; oldtab:0; oldidx:$58; oldval:0; newval:0) ); KDGKBENT=$4B46; @@ -410,7 +430,17 @@ begin InTail:=0; end; -procedure PushKey(Ch:char); +{ returns an already read character back into InBuf } +procedure PutBackIntoInBuf(ch: Char); +begin + If InTail=0 then + InTail:=InSize-1 + else + Dec(InTail); + InBuf[InTail]:=ch; +end; + +procedure PushKey(const Ch:TEnhancedKeyEvent); var Tmp : Longint; begin @@ -425,7 +455,7 @@ begin End; -function PopKey:char; +function PopKey:TEnhancedKeyEvent; begin If KeyPut<>KeySend Then begin @@ -435,30 +465,7 @@ begin KeySend:=0; End Else - PopKey:=#0; -End; - - -procedure PushExt(b:byte); -begin - PushKey(#0); - PushKey(chr(b)); -end; - - -const - AltKeyStr : string[38]='qwertyuiopasdfghjklzxcvbnm1234567890-='; - AltCodeStr : string[38]=#016#017#018#019#020#021#022#023#024#025#030#031#032#033#034#035#036#037#038+ - #044#045#046#047#048#049#050#120#121#122#123#124#125#126#127#128#129#130#131; -function FAltKey(ch:char):byte; -var - Idx : longint; -begin - Idx:=Pos(ch,AltKeyStr); - if Idx>0 then - FAltKey:=byte(AltCodeStr[Idx]) - else - FAltKey:=0; + PopKey:=NilEnhancedKeyEvent; End; @@ -730,7 +737,7 @@ begin Pa^.Child:=newPtree; end; -function DoAddSequence(const St : String; AChar,AScan :byte) : PTreeElement; +function DoAddSequence(const St : String; AChar,AScan :byte; const AShift: TEnhancedShiftState) : PTreeElement; var CurPTree,NPT : PTreeElement; c : byte; @@ -794,6 +801,7 @@ begin {$endif DEBUG} ScanValue:=AScan; CharValue:=AChar; + ShiftValue:=AShift; end; end else with CurPTree^ do @@ -801,6 +809,7 @@ begin CanBeTerminal:=True; ScanValue:=AScan; CharValue:=AChar; + ShiftValue:=AShift; end; DoAddSequence:=CurPTree; end; @@ -808,7 +817,7 @@ end; procedure AddSequence(const St : String; AChar,AScan :byte);inline; begin - DoAddSequence(St,AChar,AScan); + DoAddSequence(St,AChar,AScan,[]); end; { Returns the Child that as c as char if it exists } @@ -829,7 +838,7 @@ function AddSpecialSequence(const St : string;Proc : Tprocedure) : PTreeElement; var NPT : PTreeElement; begin - NPT:=DoAddSequence(St,0,0); + NPT:=DoAddSequence(St,0,0,[]); NPT^.SpecialHandler:=Proc; AddSpecialSequence:=NPT; end; @@ -871,331 +880,355 @@ begin end; type key_sequence=packed record - char,scan:byte; + char:0..127; + scan:byte; + shift:TEnhancedShiftState; st:string[7]; end; -const key_sequences:array[0..297] of key_sequence=( - (char:0;scan:kbAltA;st:#27'A'), - (char:0;scan:kbAltA;st:#27'a'), - (char:0;scan:kbAltB;st:#27'B'), - (char:0;scan:kbAltB;st:#27'b'), - (char:0;scan:kbAltC;st:#27'C'), - (char:0;scan:kbAltC;st:#27'c'), - (char:0;scan:kbAltD;st:#27'D'), - (char:0;scan:kbAltD;st:#27'd'), - (char:0;scan:kbAltE;st:#27'E'), - (char:0;scan:kbAltE;st:#27'e'), - (char:0;scan:kbAltF;st:#27'F'), - (char:0;scan:kbAltF;st:#27'f'), - (char:0;scan:kbAltG;st:#27'G'), - (char:0;scan:kbAltG;st:#27'g'), - (char:0;scan:kbAltH;st:#27'H'), - (char:0;scan:kbAltH;st:#27'h'), - (char:0;scan:kbAltI;st:#27'I'), - (char:0;scan:kbAltI;st:#27'i'), - (char:0;scan:kbAltJ;st:#27'J'), - (char:0;scan:kbAltJ;st:#27'j'), - (char:0;scan:kbAltK;st:#27'K'), - (char:0;scan:kbAltK;st:#27'k'), - (char:0;scan:kbAltL;st:#27'L'), - (char:0;scan:kbAltL;st:#27'l'), - (char:0;scan:kbAltM;st:#27'M'), - (char:0;scan:kbAltM;st:#27'm'), - (char:0;scan:kbAltN;st:#27'N'), - (char:0;scan:kbAltN;st:#27'n'), - (char:0;scan:kbAltO;st:#27'O'), - (char:0;scan:kbAltO;st:#27'o'), - (char:0;scan:kbAltP;st:#27'P'), - (char:0;scan:kbAltP;st:#27'p'), - (char:0;scan:kbAltQ;st:#27'Q'), - (char:0;scan:kbAltQ;st:#27'q'), - (char:0;scan:kbAltR;st:#27'R'), - (char:0;scan:kbAltR;st:#27'r'), - (char:0;scan:kbAltS;st:#27'S'), - (char:0;scan:kbAltS;st:#27's'), - (char:0;scan:kbAltT;st:#27'T'), - (char:0;scan:kbAltT;st:#27't'), - (char:0;scan:kbAltU;st:#27'U'), - (char:0;scan:kbAltU;st:#27'u'), - (char:0;scan:kbAltV;st:#27'V'), - (char:0;scan:kbAltV;st:#27'v'), - (char:0;scan:kbAltW;st:#27'W'), - (char:0;scan:kbAltW;st:#27'w'), - (char:0;scan:kbAltX;st:#27'X'), - (char:0;scan:kbAltX;st:#27'x'), - (char:0;scan:kbAltY;st:#27'Y'), - (char:0;scan:kbAltY;st:#27'y'), - (char:0;scan:kbAltZ;st:#27'Z'), - (char:0;scan:kbAltZ;st:#27'z'), - (char:0;scan:kbAltMinus;st:#27'-'), - (char:0;scan:kbAltEqual;st:#27'='), - (char:0;scan:kbAlt0;st:#27'0'), - (char:0;scan:kbAlt1;st:#27'1'), - (char:0;scan:kbAlt2;st:#27'2'), - (char:0;scan:kbAlt3;st:#27'3'), - (char:0;scan:kbAlt4;st:#27'4'), - (char:0;scan:kbAlt5;st:#27'5'), - (char:0;scan:kbAlt6;st:#27'6'), - (char:0;scan:kbAlt7;st:#27'7'), - (char:0;scan:kbAlt8;st:#27'8'), - (char:0;scan:kbAlt9;st:#27'9'), - - (char:0;scan:kbF1;st:#27'[[A'), {linux,konsole,xterm} - (char:0;scan:kbF2;st:#27'[[B'), {linux,konsole,xterm} - (char:0;scan:kbF3;st:#27'[[C'), {linux,konsole,xterm} - (char:0;scan:kbF4;st:#27'[[D'), {linux,konsole,xterm} - (char:0;scan:kbF5;st:#27'[[E'), {linux,konsole} - (char:0;scan:kbF1;st:#27'[11~'), {Eterm,rxvt} - (char:0;scan:kbF2;st:#27'[12~'), {Eterm,rxvt} - (char:0;scan:kbF3;st:#27'[13~'), {Eterm,rxvt} - (char:0;scan:kbF4;st:#27'[14~'), {Eterm,rxvt} - (char:0;scan:kbF5;st:#27'[15~'), {xterm,Eterm,gnome,rxvt} - (char:0;scan:kbF6;st:#27'[17~'), {linux,xterm,Eterm,konsole,gnome,rxvt} - (char:0;scan:kbF7;st:#27'[18~'), {linux,xterm,Eterm,konsole,gnome,rxvt} - (char:0;scan:kbF8;st:#27'[19~'), {linux,xterm,Eterm,konsole,gnome,rxvt} - (char:0;scan:kbF9;st:#27'[20~'), {linux,xterm,Eterm,konsole,gnome,rxvt} - (char:0;scan:kbF10;st:#27'[21~'), {linux,xterm,Eterm,konsole,gnome,rxvt} - (char:0;scan:kbF11;st:#27'[23~'), {linux,xterm,Eterm,konsole,gnome,rxvt} - (char:0;scan:kbF12;st:#27'[24~'), {linux,xterm,Eterm,konsole,gnome,rxvt} - (char:0;scan:kbF1;st:#27'[M'), {FreeBSD} - (char:0;scan:kbF2;st:#27'[N'), {FreeBSD} - (char:0;scan:kbF3;st:#27'[O'), {FreeBSD} - (char:0;scan:kbF4;st:#27'[P'), {FreeBSD} - (char:0;scan:kbF5;st:#27'[Q'), {FreeBSD} - (char:0;scan:kbF6;st:#27'[R'), {FreeBSD} - (char:0;scan:kbF7;st:#27'[S'), {FreeBSD} - (char:0;scan:kbF8;st:#27'[T'), {FreeBSD} - (char:0;scan:kbF9;st:#27'[U'), {FreeBSD} - (char:0;scan:kbF10;st:#27'[V'), {FreeBSD} - (char:0;scan:kbF11;st:#27'[W'), {FreeBSD} - (char:0;scan:kbF12;st:#27'[X'), {FreeBSD} - (char:0;scan:kbF1;st:#27'OP'), {vt100,gnome,konsole} - (char:0;scan:kbF2;st:#27'OQ'), {vt100,gnome,konsole} - (char:0;scan:kbF3;st:#27'OR'), {vt100,gnome,konsole} - (char:0;scan:kbF4;st:#27'OS'), {vt100,gnome,konsole} - (char:0;scan:kbF5;st:#27'Ot'), {vt100} - (char:0;scan:kbF6;st:#27'Ou'), {vt100} - (char:0;scan:kbF7;st:#27'Ov'), {vt100} - (char:0;scan:kbF8;st:#27'Ol'), {vt100} - (char:0;scan:kbF9;st:#27'Ow'), {vt100} - (char:0;scan:kbF10;st:#27'Ox'), {vt100} - (char:0;scan:kbF11;st:#27'Oy'), {vt100} - (char:0;scan:kbF12;st:#27'Oz'), {vt100} - (char:0;scan:kbEsc;st:#27'[0~'), {if linux keyboard patched, escape - returns this} - (char:0;scan:kbIns;st:#27'[2~'), {linux,Eterm,rxvt} - (char:0;scan:kbDel;st:#27'[3~'), {linux,Eterm,rxvt} - (char:0;scan:kbHome;st:#27'[1~'), {linux} - (char:0;scan:kbHome;st:#27'[7~'), {Eterm,rxvt} - (char:0;scan:kbHome;st:#27'[H'), {FreeBSD} - (char:0;scan:kbHome;st:#27'OH'), {some xterm configurations} - (char:0;scan:kbEnd;st:#27'[4~'), {linux,Eterm} - (char:0;scan:kbEnd;st:#27'[8~'), {rxvt} - (char:0;scan:kbEnd;st:#27'[F'), {FreeBSD} - (char:0;scan:kbEnd;st:#27'OF'), {some xterm configurations} - (char:0;scan:kbPgUp;st:#27'[5~'), {linux,Eterm,rxvt} - (char:0;scan:kbPgUp;st:#27'[I'), {FreeBSD} - (char:0;scan:kbPgDn;st:#27'[6~'), {linux,Eterm,rxvt} - (char:0;scan:kbPgDn;st:#27'[G'), {FreeBSD} - (char:0;scan:kbUp;st:#27'[A'), {linux,FreeBSD,rxvt} - (char:0;scan:kbDown;st:#27'[B'), {linux,FreeBSD,rxvt} - (char:0;scan:kbRight;st:#27'[C'), {linux,FreeBSD,rxvt} - (char:0;scan:kbLeft;st:#27'[D'), {linux,FreeBSD,rxvt} - (char:0;scan:kbUp;st:#27'OA'), {xterm} - (char:0;scan:kbDown;st:#27'OB'), {xterm} - (char:0;scan:kbRight;st:#27'OC'), {xterm} - (char:0;scan:kbLeft;st:#27'OD'), {xterm} +const key_sequences:array[0..298] of key_sequence=( + (char:0;scan:kbAltA;shift:[essAlt];st:#27'A'), + (char:0;scan:kbAltA;shift:[essAlt];st:#27'a'), + (char:0;scan:kbAltB;shift:[essAlt];st:#27'B'), + (char:0;scan:kbAltB;shift:[essAlt];st:#27'b'), + (char:0;scan:kbAltC;shift:[essAlt];st:#27'C'), + (char:0;scan:kbAltC;shift:[essAlt];st:#27'c'), + (char:0;scan:kbAltD;shift:[essAlt];st:#27'D'), + (char:0;scan:kbAltD;shift:[essAlt];st:#27'd'), + (char:0;scan:kbAltE;shift:[essAlt];st:#27'E'), + (char:0;scan:kbAltE;shift:[essAlt];st:#27'e'), + (char:0;scan:kbAltF;shift:[essAlt];st:#27'F'), + (char:0;scan:kbAltF;shift:[essAlt];st:#27'f'), + (char:0;scan:kbAltG;shift:[essAlt];st:#27'G'), + (char:0;scan:kbAltG;shift:[essAlt];st:#27'g'), + (char:0;scan:kbAltH;shift:[essAlt];st:#27'H'), + (char:0;scan:kbAltH;shift:[essAlt];st:#27'h'), + (char:0;scan:kbAltI;shift:[essAlt];st:#27'I'), + (char:0;scan:kbAltI;shift:[essAlt];st:#27'i'), + (char:0;scan:kbAltJ;shift:[essAlt];st:#27'J'), + (char:0;scan:kbAltJ;shift:[essAlt];st:#27'j'), + (char:0;scan:kbAltK;shift:[essAlt];st:#27'K'), + (char:0;scan:kbAltK;shift:[essAlt];st:#27'k'), + (char:0;scan:kbAltL;shift:[essAlt];st:#27'L'), + (char:0;scan:kbAltL;shift:[essAlt];st:#27'l'), + (char:0;scan:kbAltM;shift:[essAlt];st:#27'M'), + (char:0;scan:kbAltM;shift:[essAlt];st:#27'm'), + (char:0;scan:kbAltN;shift:[essAlt];st:#27'N'), + (char:0;scan:kbAltN;shift:[essAlt];st:#27'n'), + (char:0;scan:kbAltO;shift:[essAlt];st:#27'O'), + (char:0;scan:kbAltO;shift:[essAlt];st:#27'o'), + (char:0;scan:kbAltP;shift:[essAlt];st:#27'P'), + (char:0;scan:kbAltP;shift:[essAlt];st:#27'p'), + (char:0;scan:kbAltQ;shift:[essAlt];st:#27'Q'), + (char:0;scan:kbAltQ;shift:[essAlt];st:#27'q'), + (char:0;scan:kbAltR;shift:[essAlt];st:#27'R'), + (char:0;scan:kbAltR;shift:[essAlt];st:#27'r'), + (char:0;scan:kbAltS;shift:[essAlt];st:#27'S'), + (char:0;scan:kbAltS;shift:[essAlt];st:#27's'), + (char:0;scan:kbAltT;shift:[essAlt];st:#27'T'), + (char:0;scan:kbAltT;shift:[essAlt];st:#27't'), + (char:0;scan:kbAltU;shift:[essAlt];st:#27'U'), + (char:0;scan:kbAltU;shift:[essAlt];st:#27'u'), + (char:0;scan:kbAltV;shift:[essAlt];st:#27'V'), + (char:0;scan:kbAltV;shift:[essAlt];st:#27'v'), + (char:0;scan:kbAltW;shift:[essAlt];st:#27'W'), + (char:0;scan:kbAltW;shift:[essAlt];st:#27'w'), + (char:0;scan:kbAltX;shift:[essAlt];st:#27'X'), + (char:0;scan:kbAltX;shift:[essAlt];st:#27'x'), + (char:0;scan:kbAltY;shift:[essAlt];st:#27'Y'), + (char:0;scan:kbAltY;shift:[essAlt];st:#27'y'), + (char:0;scan:kbAltZ;shift:[essAlt];st:#27'Z'), + (char:0;scan:kbAltZ;shift:[essAlt];st:#27'z'), + (char:0;scan:kbAltMinus;shift:[essAlt];st:#27'-'), + (char:0;scan:kbAltEqual;shift:[essAlt];st:#27'='), + (char:0;scan:kbAlt0;shift:[essAlt];st:#27'0'), + (char:0;scan:kbAlt1;shift:[essAlt];st:#27'1'), + (char:0;scan:kbAlt2;shift:[essAlt];st:#27'2'), + (char:0;scan:kbAlt3;shift:[essAlt];st:#27'3'), + (char:0;scan:kbAlt4;shift:[essAlt];st:#27'4'), + (char:0;scan:kbAlt5;shift:[essAlt];st:#27'5'), + (char:0;scan:kbAlt6;shift:[essAlt];st:#27'6'), + (char:0;scan:kbAlt7;shift:[essAlt];st:#27'7'), + (char:0;scan:kbAlt8;shift:[essAlt];st:#27'8'), + (char:0;scan:kbAlt9;shift:[essAlt];st:#27'9'), + + (char:0;scan:kbF1;shift:[];st:#27'[[A'), {linux,konsole,xterm} + (char:0;scan:kbF2;shift:[];st:#27'[[B'), {linux,konsole,xterm} + (char:0;scan:kbF3;shift:[];st:#27'[[C'), {linux,konsole,xterm} + (char:0;scan:kbF4;shift:[];st:#27'[[D'), {linux,konsole,xterm} + (char:0;scan:kbF5;shift:[];st:#27'[[E'), {linux,konsole} + (char:0;scan:kbF1;shift:[];st:#27'[11~'), {Eterm,rxvt} + (char:0;scan:kbF2;shift:[];st:#27'[12~'), {Eterm,rxvt} + (char:0;scan:kbF3;shift:[];st:#27'[13~'), {Eterm,rxvt} + (char:0;scan:kbF4;shift:[];st:#27'[14~'), {Eterm,rxvt} + (char:0;scan:kbF5;shift:[];st:#27'[15~'), {xterm,Eterm,gnome,rxvt} + (char:0;scan:kbF6;shift:[];st:#27'[17~'), {linux,xterm,Eterm,konsole,gnome,rxvt} + (char:0;scan:kbF7;shift:[];st:#27'[18~'), {linux,xterm,Eterm,konsole,gnome,rxvt} + (char:0;scan:kbF8;shift:[];st:#27'[19~'), {linux,xterm,Eterm,konsole,gnome,rxvt} + (char:0;scan:kbF9;shift:[];st:#27'[20~'), {linux,xterm,Eterm,konsole,gnome,rxvt} + (char:0;scan:kbF10;shift:[];st:#27'[21~'), {linux,xterm,Eterm,konsole,gnome,rxvt} + (char:0;scan:kbF11;shift:[];st:#27'[23~'), {linux,xterm,Eterm,konsole,gnome,rxvt} + (char:0;scan:kbF12;shift:[];st:#27'[24~'), {linux,xterm,Eterm,konsole,gnome,rxvt} + (char:0;scan:kbF1;shift:[];st:#27'[M'), {FreeBSD} + (char:0;scan:kbF2;shift:[];st:#27'[N'), {FreeBSD} + (char:0;scan:kbF3;shift:[];st:#27'[O'), {FreeBSD} + (char:0;scan:kbF4;shift:[];st:#27'[P'), {FreeBSD} + (char:0;scan:kbF5;shift:[];st:#27'[Q'), {FreeBSD} + (char:0;scan:kbF6;shift:[];st:#27'[R'), {FreeBSD} + (char:0;scan:kbF7;shift:[];st:#27'[S'), {FreeBSD} + (char:0;scan:kbF8;shift:[];st:#27'[T'), {FreeBSD} + (char:0;scan:kbF9;shift:[];st:#27'[U'), {FreeBSD} + (char:0;scan:kbF10;shift:[];st:#27'[V'), {FreeBSD} + (char:0;scan:kbF11;shift:[];st:#27'[W'), {FreeBSD} + (char:0;scan:kbF12;shift:[];st:#27'[X'), {FreeBSD} + (char:0;scan:kbF1;shift:[];st:#27'OP'), {vt100,gnome,konsole} + (char:0;scan:kbF2;shift:[];st:#27'OQ'), {vt100,gnome,konsole} + (char:0;scan:kbF3;shift:[];st:#27'OR'), {vt100,gnome,konsole} + (char:0;scan:kbF4;shift:[];st:#27'OS'), {vt100,gnome,konsole} + (char:0;scan:kbF5;shift:[];st:#27'Ot'), {vt100} + (char:0;scan:kbF6;shift:[];st:#27'Ou'), {vt100} + (char:0;scan:kbF7;shift:[];st:#27'Ov'), {vt100} + (char:0;scan:kbF8;shift:[];st:#27'Ol'), {vt100} + (char:0;scan:kbF9;shift:[];st:#27'Ow'), {vt100} + (char:0;scan:kbF10;shift:[];st:#27'Ox'), {vt100} + (char:0;scan:kbF11;shift:[];st:#27'Oy'), {vt100} + (char:0;scan:kbF12;shift:[];st:#27'Oz'), {vt100} + (char:27;scan:kbEsc;shift:[];st:#27'[0~'), {if linux keyboard patched, escape + returns this} + (char:0;scan:kbIns;shift:[];st:#27'[2~'), {linux,Eterm,rxvt} + (char:0;scan:kbDel;shift:[];st:#27'[3~'), {linux,Eterm,rxvt} + (char:0;scan:kbHome;shift:[];st:#27'[1~'), {linux} + (char:0;scan:kbHome;shift:[];st:#27'[7~'), {Eterm,rxvt} + (char:0;scan:kbHome;shift:[];st:#27'[H'), {FreeBSD} + (char:0;scan:kbHome;shift:[];st:#27'OH'), {some xterm configurations} + (char:0;scan:kbEnd;shift:[];st:#27'[4~'), {linux,Eterm} + (char:0;scan:kbEnd;shift:[];st:#27'[8~'), {rxvt} + (char:0;scan:kbEnd;shift:[];st:#27'[F'), {FreeBSD} + (char:0;scan:kbEnd;shift:[];st:#27'OF'), {some xterm configurations} + (char:0;scan:kbPgUp;shift:[];st:#27'[5~'), {linux,Eterm,rxvt} + (char:0;scan:kbPgUp;shift:[];st:#27'[I'), {FreeBSD} + (char:0;scan:kbPgDn;shift:[];st:#27'[6~'), {linux,Eterm,rxvt} +{$ifdef FREEBSD} + (char:0;scan:kbPgDn;shift:[];st:#27'[G'), {FreeBSD, conflicts with linux. + Note: new FreeBSD versions seem + to use xterm-like sequences, so + this one is not needed for them. + Todo: resolve conflicting sequences + according to the TERM variable, + instead of using IFDEFs, this way + it'll work over SSH across platforms + too.} +{$else FREEBSD} + (char:0;scan:kbCenter;shift:[];st:#27'[G'), {linux} +{$endif FREEBSD} + (char:0;scan:kbCenter;shift:[];st:#27'[E'), {xterm,gnome3} + (char:0;scan:kbUp;shift:[];st:#27'[A'), {linux,FreeBSD,rxvt} + (char:0;scan:kbDown;shift:[];st:#27'[B'), {linux,FreeBSD,rxvt} + (char:0;scan:kbRight;shift:[];st:#27'[C'), {linux,FreeBSD,rxvt} + (char:0;scan:kbLeft;shift:[];st:#27'[D'), {linux,FreeBSD,rxvt} + (char:0;scan:kbUp;shift:[];st:#27'OA'), {xterm} + (char:0;scan:kbDown;shift:[];st:#27'OB'), {xterm} + (char:0;scan:kbRight;shift:[];st:#27'OC'), {xterm} + (char:0;scan:kbLeft;shift:[];st:#27'OD'), {xterm} (* Already recognized above as F11! - (char:0;scan:kbShiftF1;st:#27'[23~'), {rxvt} - (char:0;scan:kbShiftF2;st:#27'[24~'), {rxvt} + (char:0;scan:kbShiftF1;shift:[essShift];st:#27'[23~'), {rxvt} + (char:0;scan:kbShiftF2;shift:[essShift];st:#27'[24~'), {rxvt} *) - (char:0;scan:kbShiftF3;st:#27'[25~'), {linux,rxvt} - (char:0;scan:kbShiftF4;st:#27'[26~'), {linux,rxvt} - (char:0;scan:kbShiftF5;st:#27'[28~'), {linux,rxvt} - (char:0;scan:kbShiftF6;st:#27'[29~'), {linux,rxvt} - (char:0;scan:kbShiftF7;st:#27'[31~'), {linux,rxvt} - (char:0;scan:kbShiftF8;st:#27'[32~'), {linux,rxvt} - (char:0;scan:kbShiftF9;st:#27'[33~'), {linux,rxvt} - (char:0;scan:kbShiftF10;st:#27'[34~'), {linux,rxvt} - (char:0;scan:kbShiftF11;st:#27'[23$'), {rxvt} - (char:0;scan:kbShiftF12;st:#27'[24$'), {rxvt} - (char:0;scan:kbShiftF1;st:#27'[11;2~'), {konsole in vt420pc mode} - (char:0;scan:kbShiftF2;st:#27'[12;2~'), {konsole in vt420pc mode} - (char:0;scan:kbShiftF3;st:#27'[13;2~'), {konsole in vt420pc mode} - (char:0;scan:kbShiftF4;st:#27'[14;2~'), {konsole in vt420pc mode} - (char:0;scan:kbShiftF5;st:#27'[15;2~'), {xterm} - (char:0;scan:kbShiftF6;st:#27'[17;2~'), {xterm} - (char:0;scan:kbShiftF7;st:#27'[18;2~'), {xterm} - (char:0;scan:kbShiftF8;st:#27'[19;2~'), {xterm} - (char:0;scan:kbShiftF9;st:#27'[20;2~'), {xterm} - (char:0;scan:kbShiftF10;st:#27'[21;2~'), {xterm} - (char:0;scan:kbShiftF11;st:#27'[23;2~'), {xterm} - (char:0;scan:kbShiftF12;st:#27'[24;2~'), {xterm} - (char:0;scan:kbShiftF1;st:#27'O2P'), {konsole,xterm} - (char:0;scan:kbShiftF2;st:#27'O2Q'), {konsole,xterm} - (char:0;scan:kbShiftF3;st:#27'O2R'), {konsole,xterm} - (char:0;scan:kbShiftF4;st:#27'O2S'), {konsole,xterm} - (char:0;scan:kbShiftF1;st:#27'[1;2P'), {xterm,gnome3} - (char:0;scan:kbShiftF2;st:#27'[1;2Q'), {xterm,gnome3} - (char:0;scan:kbShiftF3;st:#27'[1;2R'), {xterm,gnome3} - (char:0;scan:kbShiftF4;st:#27'[1;2S'), {xterm,gnome3} - (char:0;scan:kbCtrlF1;st:#27'O5P'), {konsole,xterm} - (char:0;scan:kbCtrlF2;st:#27'O5Q'), {konsole,xterm} - (char:0;scan:kbCtrlF3;st:#27'O5R'), {konsole,xterm} - (char:0;scan:kbCtrlF4;st:#27'O5S'), {konsole,xterm} - (char:0;scan:kbCtrlF1;st:#27'[1;5P'), {xterm,gnome3} - (char:0;scan:kbCtrlF2;st:#27'[1;5Q'), {xterm,gnome3} - (char:0;scan:kbCtrlF3;st:#27'[1;5R'), {xterm,gnome3} - (char:0;scan:kbCtrlF4;st:#27'[1;5S'), {xterm,gnome3} - (char:0;scan:kbCtrlF1;st:#27'[11;5~'), {none, but expected} - (char:0;scan:kbCtrlF2;st:#27'[12;5~'), {none, but expected} - (char:0;scan:kbCtrlF3;st:#27'[13;5~'), {none, but expected} - (char:0;scan:kbCtrlF4;st:#27'[14;5~'), {none, but expected} - (char:0;scan:kbCtrlF5;st:#27'[15;5~'), {xterm} - (char:0;scan:kbCtrlF6;st:#27'[17;5~'), {xterm} - (char:0;scan:kbCtrlF7;st:#27'[18;5~'), {xterm} - (char:0;scan:kbCtrlF8;st:#27'[19;5~'), {xterm} - (char:0;scan:kbCtrlF9;st:#27'[20;5~'), {xterm} - (char:0;scan:kbCtrlF10;st:#27'[21;5~'), {xterm} - (char:0;scan:kbCtrlF11;st:#27'[23;5~'), {xterm} - (char:0;scan:kbCtrlF12;st:#27'[24;5~'), {xterm} - (char:0;scan:kbCtrlF1;st:#27'[11^'), {rxvt} - (char:0;scan:kbCtrlF2;st:#27'[12^'), {rxvt} - (char:0;scan:kbCtrlF3;st:#27'[13^'), {rxvt} - (char:0;scan:kbCtrlF4;st:#27'[14^'), {rxvt} - (char:0;scan:kbCtrlF5;st:#27'[15^'), {rxvt} - (char:0;scan:kbCtrlF6;st:#27'[17^'), {rxvt} - (char:0;scan:kbCtrlF7;st:#27'[18^'), {rxvt} - (char:0;scan:kbCtrlF8;st:#27'[19^'), {rxvt} - (char:0;scan:kbCtrlF9;st:#27'[20^'), {rxvt} - (char:0;scan:kbCtrlF10;st:#27'[21^'), {rxvt} - (char:0;scan:kbCtrlF11;st:#27'[23^'), {rxvt} - (char:0;scan:kbCtrlF12;st:#27'[24^'), {rxvt} - (char:0;scan:kbShiftIns;st:#27'[2;2~'), {should be the code, but shift+ins - is paste X clipboard in many - terminal emulators :(} - (char:0;scan:kbShiftDel;st:#27'[3;2~'), {xterm,konsole} - (char:0;scan:kbCtrlIns;st:#27'[2;5~'), {xterm} - (char:0;scan:kbCtrlDel;st:#27'[3;5~'), {xterm} - (char:0;scan:kbShiftDel;st:#27'[3$'), {rxvt} - (char:0;scan:kbCtrlIns;st:#27'[2^'), {rxvt} - (char:0;scan:kbCtrlDel;st:#27'[3^'), {rxvt} - (char:0;scan:kbAltF1;st:#27#27'[[A'), - (char:0;scan:kbAltF2;st:#27#27'[[B'), - (char:0;scan:kbAltF3;st:#27#27'[[C'), - (char:0;scan:kbAltF4;st:#27#27'[[D'), - (char:0;scan:kbAltF5;st:#27#27'[[E'), - (char:0;scan:kbAltF1;st:#27#27'[11~'), {rxvt} - (char:0;scan:kbAltF2;st:#27#27'[12~'), {rxvt} - (char:0;scan:kbAltF3;st:#27#27'[13~'), {rxvt} - (char:0;scan:kbAltF4;st:#27#27'[14~'), {rxvt} - (char:0;scan:kbAltF5;st:#27#27'[15~'), {rxvt} - (char:0;scan:kbAltF6;st:#27#27'[17~'), {rxvt} - (char:0;scan:kbAltF7;st:#27#27'[18~'), {rxvt} - (char:0;scan:kbAltF8;st:#27#27'[19~'), {rxvt} - (char:0;scan:kbAltF9;st:#27#27'[20~'), {rxvt} - (char:0;scan:kbAltF10;st:#27#27'[21~'), {rxvt} - (char:0;scan:kbAltF11;st:#27#27'[23~'), {rxvt} - (char:0;scan:kbAltF12;st:#27#27'[24~'), {rxvt} - (char:0;scan:kbAltF1;st:#27#27'OP'), {xterm} - (char:0;scan:kbAltF2;st:#27#27'OQ'), {xterm} - (char:0;scan:kbAltF3;st:#27#27'OR'), {xterm} - (char:0;scan:kbAltF4;st:#27#27'OS'), {xterm} - (char:0;scan:kbAltF5;st:#27#27'Ot'), {xterm} - (char:0;scan:kbAltF6;st:#27#27'Ou'), {xterm} - (char:0;scan:kbAltF7;st:#27#27'Ov'), {xterm} - (char:0;scan:kbAltF8;st:#27#27'Ol'), {xterm} - (char:0;scan:kbAltF9;st:#27#27'Ow'), {xterm} - (char:0;scan:kbAltF10;st:#27#27'Ox'), {xterm} - (char:0;scan:kbAltF11;st:#27#27'Oy'), {xterm} - (char:0;scan:kbAltF12;st:#27#27'Oz'), {xterm} - (char:0;scan:kbAltF1;st:#27'[1;3P'), {xterm,gnome3} - (char:0;scan:kbAltF2;st:#27'[1;3Q'), {xterm,gnome3} - (char:0;scan:kbAltF3;st:#27'[1;3R'), {xterm,gnome3} - (char:0;scan:kbAltF4;st:#27'[1;3S'), {xterm,gnome3} - (char:0;scan:kbAltF1;st:#27'O3P'), {xterm on FreeBSD} - (char:0;scan:kbAltF2;st:#27'O3Q'), {xterm on FreeBSD} - (char:0;scan:kbAltF3;st:#27'O3R'), {xterm on FreeBSD} - (char:0;scan:kbAltF4;st:#27'O3S'), {xterm on FreeBSD} - (char:0;scan:kbAltF5;st:#27'[15;3~'), {xterm on FreeBSD} - (char:0;scan:kbAltF6;st:#27'[17;3~'), {xterm on FreeBSD} - (char:0;scan:kbAltF7;st:#27'[18;3~'), {xterm on FreeBSD} - (char:0;scan:kbAltF8;st:#27'[19;3~'), {xterm on FreeBSD} - (char:0;scan:kbAltF9;st:#27'[20;3~'), {xterm on FreeBSD} - (char:0;scan:kbAltF10;st:#27'[21;3~'), {xterm on FreeBSD} - (char:0;scan:kbAltF11;st:#27'[23;3~'), {xterm on FreeBSD} - (char:0;scan:kbAltF12;st:#27'[24;3~'), {xterm on FreeBSD} - - (char:0;scan:kbShiftTab;st:#27#9), {linux - 'Meta_Tab'} - (char:0;scan:kbShiftTab;st:#27'[Z'), - (char:0;scan:kbShiftUp;st:#27'[1;2A'), {xterm} - (char:0;scan:kbShiftDown;st:#27'[1;2B'), {xterm} - (char:0;scan:kbShiftRight;st:#27'[1;2C'), {xterm} - (char:0;scan:kbShiftLeft;st:#27'[1;2D'), {xterm} - (char:0;scan:kbShiftUp;st:#27'[a'), {rxvt} - (char:0;scan:kbShiftDown;st:#27'[b'), {rxvt} - (char:0;scan:kbShiftRight;st:#27'[c'), {rxvt} - (char:0;scan:kbShiftLeft;st:#27'[d'), {rxvt} - (char:0;scan:kbShiftEnd;st:#27'[1;2F'), {xterm} - (char:0;scan:kbShiftEnd;st:#27'[8$'), {rxvt} - (char:0;scan:kbShiftHome;st:#27'[1;2H'), {xterm} - (char:0;scan:kbShiftHome;st:#27'[7$'), {rxvt} - - (char:0;scan:KbCtrlShiftUp;st:#27'[1;6A'), {xterm} - (char:0;scan:KbCtrlShiftDown;st:#27'[1;6B'), {xterm} - (char:0;scan:KbCtrlShiftRight;st:#27'[1;6C'), {xterm, xfce4} - (char:0;scan:KbCtrlShiftLeft;st:#27'[1;6D'), {xterm, xfce4} - (char:0;scan:KbCtrlShiftHome;st:#27'[1;6H'), {xterm} - (char:0;scan:KbCtrlShiftEnd;st:#27'[1;6F'), {xterm} - - (char:0;scan:kbCtrlPgDn;st:#27'[6;5~'), {xterm} - (char:0;scan:kbCtrlPgUp;st:#27'[5;5~'), {xterm} - (char:0;scan:kbCtrlUp;st:#27'[1;5A'), {xterm} - (char:0;scan:kbCtrlDown;st:#27'[1;5B'), {xterm} - (char:0;scan:kbCtrlRight;st:#27'[1;5C'), {xterm} - (char:0;scan:kbCtrlLeft;st:#27'[1;5D'), {xterm} - (char:0;scan:kbCtrlUp;st:#27'[Oa'), {rxvt} - (char:0;scan:kbCtrlDown;st:#27'[Ob'), {rxvt} - (char:0;scan:kbCtrlRight;st:#27'[Oc'), {rxvt} - (char:0;scan:kbCtrlLeft;st:#27'[Od'), {rxvt} - (char:0;scan:kbCtrlEnd;st:#27'[1;5F'), {xterm} - (char:0;scan:kbCtrlEnd;st:#27'[8^'), {rxvt} - (char:0;scan:kbCtrlHome;st:#27'[1;5H'), {xterm} - (char:0;scan:kbCtrlHome;st:#27'[7^'), {rxvt} - - (char:0;scan:kbAltUp;st:#27#27'[A'), {rxvt} - (char:0;scan:kbAltDown;st:#27#27'[B'), {rxvt} - (char:0;scan:kbAltLeft;st:#27#27'[D'), {rxvt} - (char:0;scan:kbAltRight;st:#27#27'[C'), {rxvt} +(* These seem to be shifted. Probably something changed with linux's default keymaps. + (char:0;scan:kbShiftF3;shift:[essShift];st:#27'[25~'), {linux,rxvt} + (char:0;scan:kbShiftF4;shift:[essShift];st:#27'[26~'), {linux,rxvt} + (char:0;scan:kbShiftF5;shift:[essShift];st:#27'[28~'), {linux,rxvt} + (char:0;scan:kbShiftF6;shift:[essShift];st:#27'[29~'), {linux,rxvt} + (char:0;scan:kbShiftF7;shift:[essShift];st:#27'[31~'), {linux,rxvt} + (char:0;scan:kbShiftF8;shift:[essShift];st:#27'[32~'), {linux,rxvt} + (char:0;scan:kbShiftF9;shift:[essShift];st:#27'[33~'), {linux,rxvt} + (char:0;scan:kbShiftF10;shift:[essShift];st:#27'[34~'), {linux,rxvt}*) + (char:0;scan:kbShiftF1;shift:[essShift];st:#27'[25~'), {linux} + (char:0;scan:kbShiftF2;shift:[essShift];st:#27'[26~'), {linux} + (char:0;scan:kbShiftF3;shift:[essShift];st:#27'[28~'), {linux} + (char:0;scan:kbShiftF4;shift:[essShift];st:#27'[29~'), {linux} + (char:0;scan:kbShiftF5;shift:[essShift];st:#27'[31~'), {linux} + (char:0;scan:kbShiftF6;shift:[essShift];st:#27'[32~'), {linux} + (char:0;scan:kbShiftF7;shift:[essShift];st:#27'[33~'), {linux} + (char:0;scan:kbShiftF8;shift:[essShift];st:#27'[34~'), {linux} + (char:0;scan:kbShiftF11;shift:[essShift];st:#27'[23$'), {rxvt} + (char:0;scan:kbShiftF12;shift:[essShift];st:#27'[24$'), {rxvt} + (char:0;scan:kbShiftF1;shift:[essShift];st:#27'[11;2~'), {konsole in vt420pc mode} + (char:0;scan:kbShiftF2;shift:[essShift];st:#27'[12;2~'), {konsole in vt420pc mode} + (char:0;scan:kbShiftF3;shift:[essShift];st:#27'[13;2~'), {konsole in vt420pc mode} + (char:0;scan:kbShiftF4;shift:[essShift];st:#27'[14;2~'), {konsole in vt420pc mode} + (char:0;scan:kbShiftF5;shift:[essShift];st:#27'[15;2~'), {xterm} + (char:0;scan:kbShiftF6;shift:[essShift];st:#27'[17;2~'), {xterm} + (char:0;scan:kbShiftF7;shift:[essShift];st:#27'[18;2~'), {xterm} + (char:0;scan:kbShiftF8;shift:[essShift];st:#27'[19;2~'), {xterm} + (char:0;scan:kbShiftF9;shift:[essShift];st:#27'[20;2~'), {xterm} + (char:0;scan:kbShiftF10;shift:[essShift];st:#27'[21;2~'), {xterm} + (char:0;scan:kbShiftF11;shift:[essShift];st:#27'[23;2~'), {xterm} + (char:0;scan:kbShiftF12;shift:[essShift];st:#27'[24;2~'), {xterm} + (char:0;scan:kbShiftF1;shift:[essShift];st:#27'O2P'), {konsole,xterm} + (char:0;scan:kbShiftF2;shift:[essShift];st:#27'O2Q'), {konsole,xterm} + (char:0;scan:kbShiftF3;shift:[essShift];st:#27'O2R'), {konsole,xterm} + (char:0;scan:kbShiftF4;shift:[essShift];st:#27'O2S'), {konsole,xterm} + (char:0;scan:kbShiftF1;shift:[essShift];st:#27'[1;2P'), {xterm,gnome3} + (char:0;scan:kbShiftF2;shift:[essShift];st:#27'[1;2Q'), {xterm,gnome3} + (char:0;scan:kbShiftF3;shift:[essShift];st:#27'[1;2R'), {xterm,gnome3} + (char:0;scan:kbShiftF4;shift:[essShift];st:#27'[1;2S'), {xterm,gnome3} + (char:0;scan:kbCtrlF1;shift:[essCtrl];st:#27'O5P'), {konsole,xterm} + (char:0;scan:kbCtrlF2;shift:[essCtrl];st:#27'O5Q'), {konsole,xterm} + (char:0;scan:kbCtrlF3;shift:[essCtrl];st:#27'O5R'), {konsole,xterm} + (char:0;scan:kbCtrlF4;shift:[essCtrl];st:#27'O5S'), {konsole,xterm} + (char:0;scan:kbCtrlF1;shift:[essCtrl];st:#27'[1;5P'), {xterm,gnome3} + (char:0;scan:kbCtrlF2;shift:[essCtrl];st:#27'[1;5Q'), {xterm,gnome3} + (char:0;scan:kbCtrlF3;shift:[essCtrl];st:#27'[1;5R'), {xterm,gnome3} + (char:0;scan:kbCtrlF4;shift:[essCtrl];st:#27'[1;5S'), {xterm,gnome3} + (char:0;scan:kbCtrlF1;shift:[essCtrl];st:#27'[11;5~'), {none, but expected} + (char:0;scan:kbCtrlF2;shift:[essCtrl];st:#27'[12;5~'), {none, but expected} + (char:0;scan:kbCtrlF3;shift:[essCtrl];st:#27'[13;5~'), {none, but expected} + (char:0;scan:kbCtrlF4;shift:[essCtrl];st:#27'[14;5~'), {none, but expected} + (char:0;scan:kbCtrlF5;shift:[essCtrl];st:#27'[15;5~'), {xterm} + (char:0;scan:kbCtrlF6;shift:[essCtrl];st:#27'[17;5~'), {xterm} + (char:0;scan:kbCtrlF7;shift:[essCtrl];st:#27'[18;5~'), {xterm} + (char:0;scan:kbCtrlF8;shift:[essCtrl];st:#27'[19;5~'), {xterm} + (char:0;scan:kbCtrlF9;shift:[essCtrl];st:#27'[20;5~'), {xterm} + (char:0;scan:kbCtrlF10;shift:[essCtrl];st:#27'[21;5~'), {xterm} + (char:0;scan:kbCtrlF11;shift:[essCtrl];st:#27'[23;5~'), {xterm} + (char:0;scan:kbCtrlF12;shift:[essCtrl];st:#27'[24;5~'), {xterm} + (char:0;scan:kbCtrlF1;shift:[essCtrl];st:#27'[11^'), {rxvt} + (char:0;scan:kbCtrlF2;shift:[essCtrl];st:#27'[12^'), {rxvt} + (char:0;scan:kbCtrlF3;shift:[essCtrl];st:#27'[13^'), {rxvt} + (char:0;scan:kbCtrlF4;shift:[essCtrl];st:#27'[14^'), {rxvt} + (char:0;scan:kbCtrlF5;shift:[essCtrl];st:#27'[15^'), {rxvt} + (char:0;scan:kbCtrlF6;shift:[essCtrl];st:#27'[17^'), {rxvt} + (char:0;scan:kbCtrlF7;shift:[essCtrl];st:#27'[18^'), {rxvt} + (char:0;scan:kbCtrlF8;shift:[essCtrl];st:#27'[19^'), {rxvt} + (char:0;scan:kbCtrlF9;shift:[essCtrl];st:#27'[20^'), {rxvt} + (char:0;scan:kbCtrlF10;shift:[essCtrl];st:#27'[21^'), {rxvt} + (char:0;scan:kbCtrlF11;shift:[essCtrl];st:#27'[23^'), {rxvt} + (char:0;scan:kbCtrlF12;shift:[essCtrl];st:#27'[24^'), {rxvt} + (char:0;scan:kbShiftIns;shift:[essShift];st:#27'[2;2~'), {should be the code, but shift+ins + is paste X clipboard in many + terminal emulators :(} + (char:0;scan:kbShiftDel;shift:[essShift];st:#27'[3;2~'), {xterm,konsole} + (char:0;scan:kbCtrlIns;shift:[essCtrl];st:#27'[2;5~'), {xterm} + (char:0;scan:kbCtrlDel;shift:[essCtrl];st:#27'[3;5~'), {xterm} + (char:0;scan:kbShiftDel;shift:[essShift];st:#27'[3$'), {rxvt} + (char:0;scan:kbCtrlIns;shift:[essCtrl];st:#27'[2^'), {rxvt} + (char:0;scan:kbCtrlDel;shift:[essCtrl];st:#27'[3^'), {rxvt} + (char:0;scan:kbAltF1;shift:[essAlt];st:#27#27'[[A'), + (char:0;scan:kbAltF2;shift:[essAlt];st:#27#27'[[B'), + (char:0;scan:kbAltF3;shift:[essAlt];st:#27#27'[[C'), + (char:0;scan:kbAltF4;shift:[essAlt];st:#27#27'[[D'), + (char:0;scan:kbAltF5;shift:[essAlt];st:#27#27'[[E'), + (char:0;scan:kbAltF1;shift:[essAlt];st:#27#27'[11~'), {rxvt} + (char:0;scan:kbAltF2;shift:[essAlt];st:#27#27'[12~'), {rxvt} + (char:0;scan:kbAltF3;shift:[essAlt];st:#27#27'[13~'), {rxvt} + (char:0;scan:kbAltF4;shift:[essAlt];st:#27#27'[14~'), {rxvt} + (char:0;scan:kbAltF5;shift:[essAlt];st:#27#27'[15~'), {rxvt} + (char:0;scan:kbAltF6;shift:[essAlt];st:#27#27'[17~'), {rxvt} + (char:0;scan:kbAltF7;shift:[essAlt];st:#27#27'[18~'), {rxvt} + (char:0;scan:kbAltF8;shift:[essAlt];st:#27#27'[19~'), {rxvt} + (char:0;scan:kbAltF9;shift:[essAlt];st:#27#27'[20~'), {rxvt} + (char:0;scan:kbAltF10;shift:[essAlt];st:#27#27'[21~'), {rxvt} + (char:0;scan:kbAltF11;shift:[essAlt];st:#27#27'[23~'), {rxvt} + (char:0;scan:kbAltF12;shift:[essAlt];st:#27#27'[24~'), {rxvt} + (char:0;scan:kbAltF1;shift:[essAlt];st:#27#27'OP'), {xterm} + (char:0;scan:kbAltF2;shift:[essAlt];st:#27#27'OQ'), {xterm} + (char:0;scan:kbAltF3;shift:[essAlt];st:#27#27'OR'), {xterm} + (char:0;scan:kbAltF4;shift:[essAlt];st:#27#27'OS'), {xterm} + (char:0;scan:kbAltF5;shift:[essAlt];st:#27#27'Ot'), {xterm} + (char:0;scan:kbAltF6;shift:[essAlt];st:#27#27'Ou'), {xterm} + (char:0;scan:kbAltF7;shift:[essAlt];st:#27#27'Ov'), {xterm} + (char:0;scan:kbAltF8;shift:[essAlt];st:#27#27'Ol'), {xterm} + (char:0;scan:kbAltF9;shift:[essAlt];st:#27#27'Ow'), {xterm} + (char:0;scan:kbAltF10;shift:[essAlt];st:#27#27'Ox'), {xterm} + (char:0;scan:kbAltF11;shift:[essAlt];st:#27#27'Oy'), {xterm} + (char:0;scan:kbAltF12;shift:[essAlt];st:#27#27'Oz'), {xterm} + (char:0;scan:kbAltF1;shift:[essAlt];st:#27'[1;3P'), {xterm,gnome3} + (char:0;scan:kbAltF2;shift:[essAlt];st:#27'[1;3Q'), {xterm,gnome3} + (char:0;scan:kbAltF3;shift:[essAlt];st:#27'[1;3R'), {xterm,gnome3} + (char:0;scan:kbAltF4;shift:[essAlt];st:#27'[1;3S'), {xterm,gnome3} + (char:0;scan:kbAltF1;shift:[essAlt];st:#27'O3P'), {xterm on FreeBSD} + (char:0;scan:kbAltF2;shift:[essAlt];st:#27'O3Q'), {xterm on FreeBSD} + (char:0;scan:kbAltF3;shift:[essAlt];st:#27'O3R'), {xterm on FreeBSD} + (char:0;scan:kbAltF4;shift:[essAlt];st:#27'O3S'), {xterm on FreeBSD} + (char:0;scan:kbAltF5;shift:[essAlt];st:#27'[15;3~'), {xterm on FreeBSD} + (char:0;scan:kbAltF6;shift:[essAlt];st:#27'[17;3~'), {xterm on FreeBSD} + (char:0;scan:kbAltF7;shift:[essAlt];st:#27'[18;3~'), {xterm on FreeBSD} + (char:0;scan:kbAltF8;shift:[essAlt];st:#27'[19;3~'), {xterm on FreeBSD} + (char:0;scan:kbAltF9;shift:[essAlt];st:#27'[20;3~'), {xterm on FreeBSD} + (char:0;scan:kbAltF10;shift:[essAlt];st:#27'[21;3~'), {xterm on FreeBSD} + (char:0;scan:kbAltF11;shift:[essAlt];st:#27'[23;3~'), {xterm on FreeBSD} + (char:0;scan:kbAltF12;shift:[essAlt];st:#27'[24;3~'), {xterm on FreeBSD} + + (char:0;scan:kbShiftTab;shift:[essShift];st:#27#9), {linux - 'Meta_Tab'} + (char:0;scan:kbShiftTab;shift:[essShift];st:#27'[Z'), + (char:0;scan:kbShiftUp;shift:[essShift];st:#27'[1;2A'), {xterm} + (char:0;scan:kbShiftDown;shift:[essShift];st:#27'[1;2B'), {xterm} + (char:0;scan:kbShiftRight;shift:[essShift];st:#27'[1;2C'), {xterm} + (char:0;scan:kbShiftLeft;shift:[essShift];st:#27'[1;2D'), {xterm} + (char:0;scan:kbShiftUp;shift:[essShift];st:#27'[a'), {rxvt} + (char:0;scan:kbShiftDown;shift:[essShift];st:#27'[b'), {rxvt} + (char:0;scan:kbShiftRight;shift:[essShift];st:#27'[c'), {rxvt} + (char:0;scan:kbShiftLeft;shift:[essShift];st:#27'[d'), {rxvt} + (char:0;scan:kbShiftEnd;shift:[essShift];st:#27'[1;2F'), {xterm} + (char:0;scan:kbShiftEnd;shift:[essShift];st:#27'[8$'), {rxvt} + (char:0;scan:kbShiftHome;shift:[essShift];st:#27'[1;2H'), {xterm} + (char:0;scan:kbShiftHome;shift:[essShift];st:#27'[7$'), {rxvt} + + (char:0;scan:KbCtrlShiftUp;shift:[essCtrl,essShift];st:#27'[1;6A'), {xterm} + (char:0;scan:KbCtrlShiftDown;shift:[essCtrl,essShift];st:#27'[1;6B'), {xterm} + (char:0;scan:KbCtrlShiftRight;shift:[essCtrl,essShift];st:#27'[1;6C'), {xterm, xfce4} + (char:0;scan:KbCtrlShiftLeft;shift:[essCtrl,essShift];st:#27'[1;6D'), {xterm, xfce4} + (char:0;scan:KbCtrlShiftHome;shift:[essCtrl,essShift];st:#27'[1;6H'), {xterm} + (char:0;scan:KbCtrlShiftEnd;shift:[essCtrl,essShift];st:#27'[1;6F'), {xterm} + + (char:0;scan:kbCtrlPgDn;shift:[essCtrl];st:#27'[6;5~'), {xterm} + (char:0;scan:kbCtrlPgUp;shift:[essCtrl];st:#27'[5;5~'), {xterm} + (char:0;scan:kbCtrlUp;shift:[essCtrl];st:#27'[1;5A'), {xterm} + (char:0;scan:kbCtrlDown;shift:[essCtrl];st:#27'[1;5B'), {xterm} + (char:0;scan:kbCtrlRight;shift:[essCtrl];st:#27'[1;5C'), {xterm} + (char:0;scan:kbCtrlLeft;shift:[essCtrl];st:#27'[1;5D'), {xterm} + (char:0;scan:kbCtrlUp;shift:[essCtrl];st:#27'[Oa'), {rxvt} + (char:0;scan:kbCtrlDown;shift:[essCtrl];st:#27'[Ob'), {rxvt} + (char:0;scan:kbCtrlRight;shift:[essCtrl];st:#27'[Oc'), {rxvt} + (char:0;scan:kbCtrlLeft;shift:[essCtrl];st:#27'[Od'), {rxvt} + (char:0;scan:kbCtrlEnd;shift:[essCtrl];st:#27'[1;5F'), {xterm} + (char:0;scan:kbCtrlEnd;shift:[essCtrl];st:#27'[8^'), {rxvt} + (char:0;scan:kbCtrlHome;shift:[essCtrl];st:#27'[1;5H'), {xterm} + (char:0;scan:kbCtrlHome;shift:[essCtrl];st:#27'[7^'), {rxvt} + + (char:0;scan:kbAltUp;shift:[essAlt];st:#27#27'[A'), {rxvt} + (char:0;scan:kbAltDown;shift:[essAlt];st:#27#27'[B'), {rxvt} + (char:0;scan:kbAltLeft;shift:[essAlt];st:#27#27'[D'), {rxvt} + (char:0;scan:kbAltRight;shift:[essAlt];st:#27#27'[C'), {rxvt} {$ifdef HAIKU} - (char:0;scan:kbAltUp;st:#27#27'OA'), - (char:0;scan:kbAltDown;st:#27#27'OB'), - (char:0;scan:kbAltRight;st:#27#27'OC'), + (char:0;scan:kbAltUp;shift:[essAlt];st:#27#27'OA'), + (char:0;scan:kbAltDown;shift:[essAlt];st:#27#27'OB'), + (char:0;scan:kbAltRight;shift:[essAlt];st:#27#27'OC'), {$else} - (char:0;scan:kbAltUp;st:#27'OA'), - (char:0;scan:kbAltDown;st:#27'OB'), - (char:0;scan:kbAltRight;st:#27'OC'), + (char:0;scan:kbAltUp;shift:[essAlt];st:#27'OA'), + (char:0;scan:kbAltDown;shift:[essAlt];st:#27'OB'), + (char:0;scan:kbAltRight;shift:[essAlt];st:#27'OC'), {$endif} - (char:0;scan:kbAltLeft;st:#27#27'OD'), - (char:0;scan:kbAltPgUp;st:#27#27'[5~'), {rxvt} - (char:0;scan:kbAltPgDn;st:#27#27'[6~'), {rxvt} - (char:0;scan:kbAltEnd;st:#27#27'[4~'), - (char:0;scan:kbAltEnd;st:#27#27'[8~'), {rxvt} - (char:0;scan:kbAltHome;st:#27#27'[1~'), - (char:0;scan:kbAltHome;st:#27#27'[7~'), {rxvt} - (char:0;scan:kbAltIns;st:#27#27'[2~'), {rxvt} - (char:0;scan:kbAltDel;st:#27#27'[3~'), {rxvt} + (char:0;scan:kbAltLeft;shift:[essAlt];st:#27#27'OD'), + (char:0;scan:kbAltPgUp;shift:[essAlt];st:#27#27'[5~'), {rxvt} + (char:0;scan:kbAltPgDn;shift:[essAlt];st:#27#27'[6~'), {rxvt} + (char:0;scan:kbAltEnd;shift:[essAlt];st:#27#27'[4~'), + (char:0;scan:kbAltEnd;shift:[essAlt];st:#27#27'[8~'), {rxvt} + (char:0;scan:kbAltHome;shift:[essAlt];st:#27#27'[1~'), + (char:0;scan:kbAltHome;shift:[essAlt];st:#27#27'[7~'), {rxvt} + (char:0;scan:kbAltIns;shift:[essAlt];st:#27#27'[2~'), {rxvt} + (char:0;scan:kbAltDel;shift:[essAlt];st:#27#27'[3~'), {rxvt} { xterm default values } { xterm alternate default values } { ignored sequences } - (char:0;scan:0;st:#27'[?1;0c'), - (char:0;scan:0;st:#27'[?1l'), - (char:0;scan:0;st:#27'[?1h'), - (char:0;scan:0;st:#27'[?1;2c'), - (char:0;scan:0;st:#27'[?7l'), - (char:0;scan:0;st:#27'[?7h') + (char:0;scan:0;shift:[];st:#27'[?1;0c'), + (char:0;scan:0;shift:[];st:#27'[?1l'), + (char:0;scan:0;shift:[];st:#27'[?1h'), + (char:0;scan:0;shift:[];st:#27'[?1;2c'), + (char:0;scan:0;shift:[];st:#27'[?7l'), + (char:0;scan:0;shift:[];st:#27'[?7h') ); procedure LoadDefaultSequences; @@ -1209,18 +1242,18 @@ begin if copy(fpgetenv('TERM'),1,4)='cons' then begin {FreeBSD is until now only terminal that uses it for delete.} - DoAddSequence(#127,0,kbDel); {Delete} - DoAddSequence(#27#127,0,kbAltDel); {Alt+delete} + DoAddSequence(#127,0,kbDel,[]); {Delete} + DoAddSequence(#27#127,0,kbAltDel,[essAlt]); {Alt+delete} end else begin - DoAddSequence(#127,8,0); {Backspace} - DoAddSequence(#27#127,0,kbAltBack); {Alt+backspace} + DoAddSequence(#127,8,0,[]); {Backspace} + DoAddSequence(#27#127,0,kbAltBack,[essAlt]); {Alt+backspace} end; { all Esc letter } for i:=low(key_sequences) to high(key_sequences) do with key_sequences[i] do - DoAddSequence(st,char,scan); + DoAddSequence(st,char,scan,shift); end; function RawReadKey:char; @@ -1228,11 +1261,11 @@ var fdsin : tfdSet; begin {Check Buffer first} - if KeySend<>KeyPut then +{ if KeySend<>KeyPut then begin RawReadKey:=PopKey; exit; - end; + end;} {Wait for Key} if not sysKeyPressed then begin @@ -1267,25 +1300,207 @@ begin end; -function ReadKey(var IsAlt : boolean):char; +{$ifdef linux} +function ShiftState:byte; + +var arg:longint; + +begin + shiftstate:=0; + arg:=6; + if fpioctl(StdInputHandle,TIOCLINUX,@arg)=0 then + begin + if (arg and 8)<>0 then + shiftstate:=kbAlt; + if (arg and 4)<>0 then + inc(shiftstate,kbCtrl); + { 2 corresponds to AltGr so set both kbAlt and kbCtrl PM } + if (arg and 2)<>0 then + shiftstate:=shiftstate or (kbAlt or kbCtrl); + if (arg and 1)<>0 then + inc(shiftstate,kbShift); + end; +end; + +function EnhShiftState:TEnhancedShiftState; +const + KG_SHIFT = 0; + KG_CTRL = 2; + KG_ALT = 3; + KG_ALTGR = 1; + KG_SHIFTL = 4; + KG_KANASHIFT = 4; + KG_SHIFTR = 5; + KG_CTRLL = 6; + KG_CTRLR = 7; + KG_CAPSSHIFT = 8; +var + arg: longint; +begin + EnhShiftState:=[]; + arg:=6; + if fpioctl(StdInputHandle,TIOCLINUX,@arg)=0 then + begin + if (arg and (1 shl KG_ALT))<>0 then + Include(EnhShiftState,essAlt); + if (arg and (1 shl KG_CTRL))<>0 then + Include(EnhShiftState,essCtrl); + if (arg and (1 shl KG_CTRLL))<>0 then + Include(EnhShiftState,essLeftCtrl); + if (arg and (1 shl KG_CTRLR))<>0 then + Include(EnhShiftState,essRightCtrl); + if (arg and (1 shl KG_ALTGR))<>0 then + Include(EnhShiftState,essAltGr); + if (arg and (1 shl KG_SHIFT))<>0 then + Include(EnhShiftState,essShift); + if (arg and (1 shl KG_SHIFTL))<>0 then + Include(EnhShiftState,essLeftShift); + if (arg and (1 shl KG_SHIFTR))<>0 then + Include(EnhShiftState,essRightShift); + end; +end; + +procedure force_linuxtty; + +var s:string[15]; + handle:sizeint; + thistty:string; + +begin + is_console:=false; + if vcs_device<>-1 then + begin + { running on a tty, find out whether locally or remotely } + thistty:=ttyname(stdinputhandle); + if (copy(thistty,1,8)<>'/dev/tty') or not (thistty[9] in ['0'..'9']) then + begin + {Running from Midnight Commander or something... Bypass it.} + str(vcs_device,s); + handle:=fpopen('/dev/tty'+s,O_RDWR); + fpioctl(stdinputhandle,TIOCNOTTY,nil); + {This will currently only work when the user is root :(} + fpioctl(handle,TIOCSCTTY,nil); + if errno<>0 then + exit; + fpclose(stdinputhandle); + fpclose(stdoutputhandle); + fpclose(stderrorhandle); + fpdup2(handle,stdinputhandle); + fpdup2(handle,stdoutputhandle); + fpdup2(handle,stderrorhandle); + fpclose(handle); + end; + is_console:=true; + end; +end; +{$endif linux} + + +function DetectUtf8ByteSequenceStart(ch: Char): LongInt; +begin + if Ord(ch)<128 then + DetectUtf8ByteSequenceStart:=1 + else if (Ord(ch) and %11100000)=%11000000 then + DetectUtf8ByteSequenceStart:=2 + else if (Ord(ch) and %11110000)=%11100000 then + DetectUtf8ByteSequenceStart:=3 + else if (Ord(ch) and %11111000)=%11110000 then + DetectUtf8ByteSequenceStart:=4 + else + DetectUtf8ByteSequenceStart:=0; +end; + + +function IsValidUtf8ContinuationByte(ch: Char): Boolean; +begin + IsValidUtf8ContinuationByte:=(Ord(ch) and %11000000)=%10000000; +end; + + +function ReadKey:TEnhancedKeyEvent; +const + ReplacementAsciiChar='?'; var - ch : char; - fdsin : tfdSet; store : array [0..8] of char; arrayind : byte; - NPT,NNPT : PTreeElement; + SState: TEnhancedShiftState; procedure RestoreArray; var i : byte; + k : TEnhancedKeyEvent; begin for i:=0 to arrayind-1 do - PushKey(store[i]); + begin + k := NilEnhancedKeyEvent; + k.AsciiChar := store[i]; + k.VirtualScanCode := Ord(k.AsciiChar); + k.ShiftState := SState; + { todo: how to set the other fields? } + PushKey(k); + end; end; + function ReadUtf8(ch: Char): LongInt; + const + ErrorCharacter = $FFFD; { U+FFFD = REPLACEMENT CHARACTER } + var + CodePoint: LongInt; + begin + ReadUtf8:=ErrorCharacter; + case DetectUtf8ByteSequenceStart(ch) of + 1: ReadUtf8:=Ord(ch); + 2:begin + CodePoint:=(Ord(ch) and %00011111) shl 6; + ch:=ttyRecvChar; + if not IsValidUtf8ContinuationByte(ch) then + exit; + CodePoint:=(Ord(ch) and %00111111) or CodePoint; + if (CodePoint>=$80) and (CodePoint<=$7FF) then + ReadUtf8:=CodePoint; + end; + 3:begin + CodePoint:=(Ord(ch) and %00001111) shl 12; + ch:=ttyRecvChar; + if not IsValidUtf8ContinuationByte(ch) then + exit; + CodePoint:=((Ord(ch) and %00111111) shl 6) or CodePoint; + ch:=ttyRecvChar; + if not IsValidUtf8ContinuationByte(ch) then + exit; + CodePoint:=(Ord(ch) and %00111111) or CodePoint; + if ((CodePoint>=$800) and (CodePoint<=$D7FF)) or + ((CodePoint>=$E000) and (CodePoint<=$FFFF)) then + ReadUtf8:=CodePoint; + end; + 4:begin + CodePoint:=(Ord(ch) and %00000111) shl 18; + ch:=ttyRecvChar; + if not IsValidUtf8ContinuationByte(ch) then + exit; + CodePoint:=((Ord(ch) and %00111111) shl 12) or CodePoint; + ch:=ttyRecvChar; + if not IsValidUtf8ContinuationByte(ch) then + exit; + CodePoint:=((Ord(ch) and %00111111) shl 6) or CodePoint; + ch:=ttyRecvChar; + if not IsValidUtf8ContinuationByte(ch) then + exit; + CodePoint:=(Ord(ch) and %00111111) or CodePoint; + if (CodePoint>=$10000) and (CodePoint<=$10FFFF) then + ReadUtf8:=CodePoint; + end; + end; + end; + +var + ch : char; + fdsin : tfdSet; + NPT,NNPT : PTreeElement; + k: TEnhancedKeyEvent; + UnicodeCodePoint: LongInt; begin - IsAlt:=false; {Check Buffer first} if KeySend<>KeyPut then begin @@ -1299,10 +1514,47 @@ begin fpFD_SET (StdInputHandle,fdsin); fpSelect (StdInputHandle+1,@fdsin,nil,nil,nil); end; + k:=NilEnhancedKeyEvent; +{$ifdef linux} + if is_console then + SState:=EnhShiftState + else +{$endif} + SState:=[]; + k.ShiftState:=SState; ch:=ttyRecvChar; + k.AsciiChar:=ch; NPT:=RootTree[ch]; if not assigned(NPT) then - PushKey(ch) + begin + if Utf8KeyboardInputEnabled then + begin + UnicodeCodePoint:=ReadUtf8(ch); + if UnicodeCodePoint<=$FFFF then + begin + { Code point is in the Basic Multilingual Plane (BMP) + -> encode as single WideChar } + k.UnicodeChar:=WideChar(UnicodeCodePoint); + if UnicodeCodePoint<=127 then + k.AsciiChar:=Chr(UnicodeCodePoint) + else + k.AsciiChar:=ReplacementAsciiChar; + PushKey(k); + end + else if UnicodeCodePoint<=$10FFFF then + begin + { Code point from the Supplementary Planes (U+010000..U+10FFFF) + -> encode as a surrogate pair of WideChars (as in UTF-16) } + k.UnicodeChar:=WideChar(((UnicodeCodePoint-$10000) shr 10)+$D800); + k.AsciiChar:=ReplacementAsciiChar; + PushKey(k); + k.UnicodeChar:=WideChar(((UnicodeCodePoint-$10000) and %1111111111)+$DC00); + PushKey(k); + end; + end + else + PushKey(k); + end else begin fpFD_ZERO(fdsin); @@ -1322,11 +1574,7 @@ begin {Alt+O cannot be used in this situation, it can be a function key.} if not(ch in ['a'..'z','A'..'N','P'..'Z','0'..'9','-','+','_','=']) then begin - if intail=0 then - intail:=insize - else - dec(intail); - inbuf[intail]:=ch; + PutBackIntoInBuf(ch); ch:=#27; end else @@ -1342,37 +1590,37 @@ begin if NPT^.CanBeTerminal and assigned(NPT^.SpecialHandler) then break; - End; + End + else + begin + { Put that unused char back into InBuf? } + if ch<>#0 then + PutBackIntoInBuf(ch); + break; + end; if ch<>#0 then begin store[arrayind]:=ch; inc(arrayind); end; - if not assigned(NNPT) then - begin - if ch<>#0 then - begin - { Put that unused char back into InBuf } - If InTail=0 then - InTail:=InSize-1 - else - Dec(InTail); - InBuf[InTail]:=ch; - end; - break; - end; end; if assigned(NPT) and NPT^.CanBeTerminal then begin if assigned(NPT^.SpecialHandler) then begin NPT^.SpecialHandler; - PushExt(0); + k.AsciiChar := #0; + k.UnicodeChar := WideChar(#0); + k.VirtualScanCode := 0; + PushKey(k); end - else if NPT^.CharValue<>0 then - PushKey(chr(NPT^.CharValue)) - else if NPT^.ScanValue<>0 then - PushExt(NPT^.ScanValue); + else if (NPT^.CharValue<>0) or (NPT^.ScanValue<>0) then + begin + k.AsciiChar := chr(NPT^.CharValue); + k.UnicodeChar := WideChar(NPT^.CharValue); + k.VirtualScanCode := (NPT^.ScanValue shl 8) or Ord(k.AsciiChar); + PushKey(k); + end; end else RestoreArray; @@ -1384,67 +1632,13 @@ begin ReadKey:=PopKey; End; -{$ifdef linux} -function ShiftState:byte; - -var arg:longint; - -begin - shiftstate:=0; - arg:=6; - if fpioctl(StdInputHandle,TIOCLINUX,@arg)=0 then - begin - if (arg and 8)<>0 then - shiftstate:=kbAlt; - if (arg and 4)<>0 then - inc(shiftstate,kbCtrl); - { 2 corresponds to AltGr so set both kbAlt and kbCtrl PM } - if (arg and 2)<>0 then - shiftstate:=shiftstate or (kbAlt or kbCtrl); - if (arg and 1)<>0 then - inc(shiftstate,kbShift); - end; -end; - -procedure force_linuxtty; - -var s:string[15]; - handle:sizeint; - thistty:string; - -begin - is_console:=false; - if vcs_device<>-1 then - begin - { running on a tty, find out whether locally or remotely } - thistty:=ttyname(stdinputhandle); - if (copy(thistty,1,8)<>'/dev/tty') or not (thistty[9] in ['0'..'9']) then - begin - {Running from Midnight Commander or something... Bypass it.} - str(vcs_device,s); - handle:=fpopen('/dev/tty'+s,O_RDWR); - fpioctl(stdinputhandle,TIOCNOTTY,nil); - {This will currently only work when the user is root :(} - fpioctl(handle,TIOCSCTTY,nil); - if errno<>0 then - exit; - fpclose(stdinputhandle); - fpclose(stdoutputhandle); - fpclose(stderrorhandle); - fpdup2(handle,stdinputhandle); - fpdup2(handle,stdoutputhandle); - fpdup2(handle,stderrorhandle); - fpclose(handle); - end; - is_console:=true; - end; -end; -{$endif linux} { Exported functions } procedure SysInitKeyboard; begin + PendingEnhancedKeyEvent:=NilEnhancedKeyEvent; + Utf8KeyboardInputEnabled:=UnixKVMBase.UTF8Enabled; SetRawMode(true); {$ifdef logging} assign(f,'keyboard.log'); @@ -1503,7 +1697,7 @@ begin end; -function SysGetKeyEvent: TKeyEvent; +function SysGetEnhancedKeyEvent: TEnhancedKeyEvent; function EvalScan(b:byte):byte; const @@ -1562,33 +1756,34 @@ const var MyScan:byte; MyChar : char; - EscUsed,AltPrefixUsed,CtrlPrefixUsed,ShiftPrefixUsed,IsAlt,Again : boolean; - SState:byte; + MyUniChar: WideChar; + MyKey: TEnhancedKeyEvent; + EscUsed,AltPrefixUsed,CtrlPrefixUsed,ShiftPrefixUsed,Again : boolean; + SState: TEnhancedShiftState; begin {main} - MyChar:=Readkey(IsAlt); - MyScan:=ord(MyChar); -{$ifdef linux} - if is_console then - SState:=ShiftState - else -{$endif} - Sstate:=0; + if PendingEnhancedKeyEvent<>NilEnhancedKeyEvent then + begin + SysGetEnhancedKeyEvent:=PendingEnhancedKeyEvent; + PendingEnhancedKeyEvent:=NilEnhancedKeyEvent; + exit; + end; + SysGetEnhancedKeyEvent:=NilEnhancedKeyEvent; + MyKey:=ReadKey; + MyChar:=MyKey.AsciiChar; + MyUniChar:=MyKey.UnicodeChar; + MyScan:=MyKey.VirtualScanCode shr 8; + Sstate:=MyKey.ShiftState; CtrlPrefixUsed:=false; AltPrefixUsed:=false; ShiftPrefixUsed:=false; EscUsed:=false; - if IsAlt then - SState:=SState or kbAlt; repeat again:=false; if Mychar=#0 then begin - MyScan:=ord(ReadKey(IsAlt)); - if myscan=$01 then - mychar:=#27; { Handle Ctrl-<x>, but not AltGr-<x> } - if ((SState and kbCtrl)<>0) and ((SState and kbAlt) = 0) then + if (essCtrl in SState) and (not (essAlt in SState)) then case MyScan of kbShiftTab: MyScan := kbCtrlTab; kbHome..kbDel : { cArrow } @@ -1599,7 +1794,7 @@ begin {main} MyScan:=MyScan+kbCtrlF11-kbF11; end { Handle Alt-<x>, but not AltGr } - else if ((SState and kbAlt)<>0) and ((SState and kbCtrl) = 0) then + else if (essAlt in SState) and (not (essCtrl in SState)) then case MyScan of kbShiftTab: MyScan := kbAltTab; kbHome..kbDel : { AltArrow } @@ -1609,7 +1804,7 @@ begin {main} kbF11..KbF12 : { aF11-aF12 } MyScan:=MyScan+kbAltF11-kbF11; end - else if (SState and kbShift)<>0 then + else if essShift in SState then case MyScan of kbIns: MyScan:=kbShiftIns; kbDel: MyScan:=kbShiftDel; @@ -1623,28 +1818,31 @@ begin {main} if myscan <= kbShiftEnd then begin myscan:=ShiftArrow[myscan]; - sstate:=sstate or kbshift; + Include(sstate, essShift); end else begin myscan:=CtrlShiftArrow[myscan]; - sstate:=sstate or kbshift or kbCtrl; + sstate:=sstate + [essShift, essCtrl]; end; end; if myscan=kbAltBack then - sstate:=sstate or kbalt; - if (MyChar<>#0) or (MyScan<>0) or (SState<>0) then - SysGetKeyEvent:=$3000000 or ord(MyChar) or (MyScan shl 8) or (SState shl 16) - else - SysGetKeyEvent:=0; + Include(sstate, essAlt); + if (MyChar<>#0) or (MyUniChar<>WideChar(0)) or (MyScan<>0) or (SState<>[]) then + begin + SysGetEnhancedKeyEvent.AsciiChar:=MyChar; + SysGetEnhancedKeyEvent.UnicodeChar:=MyUniChar; + SysGetEnhancedKeyEvent.ShiftState:=SState; + SysGetEnhancedKeyEvent.VirtualScanCode:=(MyScan shl 8) or Ord(MyChar); + end; exit; end else if MyChar=#27 then begin if EscUsed then - SState:=SState and not kbAlt + SState:=SState-[essAlt,essLeftAlt,essRightAlt] else begin - SState:=SState or kbAlt; + Include(SState,essAlt); Again:=true; EscUsed:=true; end; @@ -1652,97 +1850,101 @@ begin {main} else if (AltPrefix<>0) and (MyChar=chr(AltPrefix)) then begin { ^Z - replace Alt for Linux OS } if AltPrefixUsed then - begin - SState:=SState and not kbAlt; - end + SState:=SState-[essAlt,essLeftAlt,essRightAlt] else begin AltPrefixUsed:=true; - SState:=SState or kbAlt; + Include(SState,essAlt); Again:=true; end; end else if (CtrlPrefix<>0) and (MyChar=chr(CtrlPrefix)) then begin if CtrlPrefixUsed then - SState:=SState and not kbCtrl + SState:=SState-[essCtrl,essLeftCtrl,essRightCtrl] else begin CtrlPrefixUsed:=true; - SState:=SState or kbCtrl; + Include(SState,essCtrl); Again:=true; end; end else if (ShiftPrefix<>0) and (MyChar=chr(ShiftPrefix)) then begin if ShiftPrefixUsed then - SState:=SState and not kbShift + SState:=SState-[essShift,essLeftShift,essRightShift] else begin ShiftPrefixUsed:=true; - SState:=SState or kbShift; + Include(SState,essShift); Again:=true; end; end; - if not again then + if again then begin - MyScan:=EvalScan(ord(MyChar)); - if ((SState and kbCtrl)<>0) and ((SState and kbAlt) = 0) then - begin - if MyChar=#9 then - begin - MyChar:=#0; - MyScan:=kbCtrlTab; - end; - end - else if ((SState and kbAlt)<>0) and ((SState and kbCtrl) = 0) then - begin - if MyChar=#9 then - begin - MyChar:=#0; - MyScan:=kbAltTab; - end - else - begin - if MyScan in [$02..$0D] then - inc(MyScan,$76); - MyChar:=chr(0); - end; - end - else if (SState and kbShift)<>0 then - if MyChar=#9 then - begin - MyChar:=#0; - MyScan:=kbShiftTab; - end; - end - else + MyKey:=ReadKey; + MyChar:=MyKey.AsciiChar; + MyUniChar:=MyKey.UnicodeChar; + MyScan:=MyKey.VirtualScanCode shr 8; + end; + until not Again; + MyScan:=EvalScan(ord(MyChar)); + if (essCtrl in SState) and (not (essAlt in SState)) then + begin + if MyChar=#9 then + begin + MyChar:=#0; + MyUniChar:=WideChar(0); + MyScan:=kbCtrlTab; + end; + end + else if (essAlt in SState) and (not (essCtrl in SState)) then + begin + if MyChar=#9 then + begin + MyChar:=#0; + MyUniChar:=WideChar(0); + MyScan:=kbAltTab; + end + else + begin + if MyScan in [$02..$0D] then + inc(MyScan,$76); + MyChar:=chr(0); + MyUniChar:=WideChar(0); + end; + end + else if essShift in SState then + if MyChar=#9 then begin - MyChar:=Readkey(IsAlt); - MyScan:=ord(MyChar); - if IsAlt then - SState:=SState or kbAlt; + MyChar:=#0; + MyUniChar:=WideChar(0); + MyScan:=kbShiftTab; end; - until not Again; - if (MyChar<>#0) or (MyScan<>0) or (SState<>0) then - SysGetKeyEvent:=$3000000 or ord(MyChar) or (MyScan shl 8) or (SState shl 16) - else - SysGetKeyEvent:=0; + if (MyChar<>#0) or (MyUniChar<>WideChar(0)) or (MyScan<>0) or (SState<>[]) then + begin + SysGetEnhancedKeyEvent.AsciiChar:=MyChar; + SysGetEnhancedKeyEvent.UnicodeChar:=MyUniChar; + SysGetEnhancedKeyEvent.ShiftState:=SState; + SysGetEnhancedKeyEvent.VirtualScanCode:=(MyScan shl 8) or Ord(MyChar); + end; end; -function SysPollKeyEvent: TKeyEvent; +function SysPollEnhancedKeyEvent: TEnhancedKeyEvent; var - KeyEvent : TKeyEvent; + KeyEvent : TEnhancedKeyEvent; begin - if keypressed then + if PendingEnhancedKeyEvent<>NilEnhancedKeyEvent then + SysPollEnhancedKeyEvent:=PendingEnhancedKeyEvent + else if keypressed then begin - KeyEvent:=SysGetKeyEvent; - PutKeyEvent(KeyEvent); - SysPollKeyEvent:=KeyEvent + KeyEvent:=SysGetEnhancedKeyEvent; + PendingEnhancedKeyEvent:=KeyEvent; + SysPollEnhancedKeyEvent:=KeyEvent; end else - SysPollKeyEvent:=0; + SysPollEnhancedKeyEvent:=NilEnhancedKeyEvent; end; @@ -1767,11 +1969,13 @@ const SysKeyboardDriver : TKeyboardDriver = ( InitDriver : @SysInitKeyBoard; DoneDriver : @SysDoneKeyBoard; - GetKeyevent : @SysGetKeyEvent; - PollKeyEvent : @SysPollKeyEvent; + GetKeyevent : Nil; + PollKeyEvent : Nil; GetShiftState : @SysGetShiftState; TranslateKeyEvent : Nil; TranslateKeyEventUnicode : Nil; + GetEnhancedKeyEvent : @SysGetEnhancedKeyEvent; + PollEnhancedKeyEvent : @SysPollEnhancedKeyEvent; ); begin diff --git a/packages/rtl-console/src/unix/unixkvmbase.pp b/packages/rtl-console/src/unix/unixkvmbase.pp new file mode 100644 index 0000000000..51d1be316a --- /dev/null +++ b/packages/rtl-console/src/unix/unixkvmbase.pp @@ -0,0 +1,51 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Florian Klaempfl + member of the Free Pascal development team + + Miscellaneous routines used by the Keyboard, Mouse and + Video units on Unix-like operating systems. + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + 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. + + **********************************************************************} +unit UnixKvmBase; + +{*****************************************************************************} + interface +{*****************************************************************************} + +function UTF8Enabled: Boolean; + +{*****************************************************************************} + implementation +{*****************************************************************************} + +uses + baseunix; + +{$ifdef BEOS} +function UTF8Enabled: Boolean; +begin + UTF8Enabled := true; +end; +{$else} +function UTF8Enabled: Boolean; +var + lang:string; +begin +{$ifdef OpenBSD} + lang:=upcase(fpgetenv('LC_CTYPE')); +{$else OpenBSD} + lang:=upcase(fpgetenv('LANG')); +{$endif OpenBSD} + UTF8Enabled := (Pos('.UTF-8', lang) > 0) or (Pos('.UTF8', lang) > 0); +end; +{$endif} + +end. diff --git a/packages/rtl-console/src/unix/video.pp b/packages/rtl-console/src/unix/video.pp index 54d3cb3b3b..7629608d21 100644 --- a/packages/rtl-console/src/unix/video.pp +++ b/packages/rtl-console/src/unix/video.pp @@ -24,57 +24,28 @@ unit video; {$i videoh.inc} -type Tencoding=(cp437, {Codepage 437} - cp850, {Codepage 850} - cp852, {Codepage 852} - cp866, {Codepage 866} - koi8r, {KOI8-R codepage} - iso01, {ISO 8859-1} - iso02, {ISO 8859-2} - iso03, {ISO 8859-3} - iso04, {ISO 8859-4} - iso05, {ISO 8859-5} - iso06, {ISO 8859-6} - iso07, {ISO 8859-7} - iso08, {ISO 8859-8} - iso09, {ISO 8859-9} - iso10, {ISO 8859-10} - iso13, {ISO 8859-13} - iso14, {ISO 8859-14} - iso15, {ISO 8859-15} - utf8); {UTF-8} - -const {Contains all code pages that can be considered a normal vga font. - Note: KOI8-R has line drawing characters in wrong place. Support - can perhaps be added, for now we'll let it rest.} - vga_codepages=[cp437,cp850,cp852,cp866]; - iso_codepages=[iso01,iso02,iso03,iso04,iso05,iso06,iso07,iso08, - iso09,iso10,iso13,iso14,iso15]; - -var internal_codepage,external_codepage:Tencoding; - - {*****************************************************************************} implementation {*****************************************************************************} -uses baseunix,termio,strings +uses baseunix,termio,strings,unixkvmbase,graphemebreakproperty,eastasianwidth + ,charset {$ifdef linux},linuxvcs{$endif}; +const + CP_ISO01 = 28591; {ISO 8859-1} + CP_ISO02 = 28592; {ISO 8859-2} + CP_ISO05 = 28595; {ISO 8859-5} + +var external_codepage:TSystemCodePage; + {$i video.inc} -{$i convert.inc} type Tconsole_type=(ttyNetwork {$ifdef linux},ttyLinux{$endif} ,ttyFreeBSD ,ttyNetBSD); - Tconversion=(cv_none, - cv_cp437_to_iso01, - cv_cp850_to_iso01, - cv_linuxlowascii_to_vga, - cv_cp437_to_UTF8); - Ttermcode=( enter_alt_charset_mode, exit_alt_charset_mode, @@ -179,8 +150,8 @@ const term_codes_ansi:Ttermcodes= term_codes_beos:Ttermcodes= (nil,//#$0E, {enter_alt_charset_mode} nil,//#$0F, {exit_alt_charset_mode} - #$1B#$5B#$48#$1B#$5B#$4A, {clear_screen} - #$1B#$5B#$48, {cursor_home} + #$1B#$5B#$48#$1B#$5B#$4A, {clear_screen} + #$1B#$5B#$48, {cursor_home} #$1B'[?25h',// nil,//#$1B#$5B#$3F#$31#$32#$6C#$1B#$5B#$3F#$32#$35#$68, {cursor_normal} nil,//#$1B#$5B#$3F#$31#$32#$3B#$32#$35#$68, {cursor visible, underline} nil,//#$1B#$5B#$3F#$31#$32#$3B#$32#$35#$68, {cursor visible, block} @@ -217,8 +188,6 @@ const terminal_names:array[0..11] of string[7]=( @term_codes_xterm, @term_codes_beos); -const convert:Tconversion=cv_none; - var LastCursorType : byte; {$ifdef linux} @@ -249,6 +218,19 @@ const TerminalSupportsHighIntensityColors: boolean = false; TerminalSupportsBold: boolean = true; +{Contains all code pages that can be considered a normal vga font. + Note: KOI8-R has line drawing characters in wrong place. Support + can perhaps be added, for now we'll let it rest.} +function is_vga_code_page(CP: TSystemCodePage): Boolean; +begin + case CP of + 437,850,852,866: + result:=true; + else + result:=false; + end; +end; + function convert_vga_to_acs(ch:char):word; {Ch contains a character in the VGA character set (i.e. codepage 437). @@ -262,43 +244,43 @@ begin case ch of #18: convert_vga_to_acs:=word('|'); - #24, #30: { } + #24, #30: {↑▲} convert_vga_to_acs:=word('^'); - #25, #31: { } + #25, #31: {↓▼} convert_vga_to_acs:=word('v'); - #26, #16: {Never introduce a ctrl-Z ... } + #26, #16: {Never introduce a ctrl-Z ... →►} convert_vga_to_acs:=word('>'); - {#27,} #17: {} + {#27,} #17: {â†â—„} convert_vga_to_acs:=word('<'); - #176, #177, #178: {°±²} + #176, #177, #178: {â–‘â–’â–“} convert_vga_to_acs:=$f800+word('a'); - #180, #181, #182, #185: {´µ¶¹} + #180, #181, #182, #185: {┤╡╢╣} convert_vga_to_acs:=$f800+word('u'); - #183, #184, #187, #191: {·¸»¿} + #183, #184, #187, #191: {â•–â••â•—â”} convert_vga_to_acs:=$f800+word('k'); - #188, #189, #190, #217: {¼½¾Ù} + #188, #189, #190, #217: {â•â•œâ•›â”˜} convert_vga_to_acs:=$f800+word('j'); - #192, #200, #211, #212: {ÀÈÓÔ} + #192, #200, #211, #212: {└╚╙╘} convert_vga_to_acs:=$f800+word('m'); - #193, #202, #207, #208: {ÁÊÏÐ} + #193, #202, #207, #208: {┴╩╧╨} convert_vga_to_acs:=$f800+word('v'); - #194, #203, #209, #210: {ÂËÑÒ} + #194, #203, #209, #210: {┬╦╤╥} convert_vga_to_acs:=$f800+word('w'); - #195, #198, #199, #204: {ÃÆÇÌ} + #195, #198, #199, #204: {├╞╟╠} convert_vga_to_acs:=$f800+word('t'); - #196, #205: {ÄÍ} + #196, #205: {─â•} convert_vga_to_acs:=$f800+word('q'); - #179, #186: {³º} + #179, #186: {│║} convert_vga_to_acs:=$f800+word('x'); - #197, #206, #215, #216: {ÅÎ×Ø} + #197, #206, #215, #216: {┼╬╫╪} convert_vga_to_acs:=$f800+word('n'); - #201, #213, #214, #218: {ÉÕÖÚ} + #201, #213, #214, #218: {╔╒╓┌} convert_vga_to_acs:=$f800+word('l'); - #254: { þ } + #254: { â– } convert_vga_to_acs:=word('*'); { Shadows for Buttons } - #220 { Ü }, - #223: { ß } + #220 { â–„ }, + #223: { â–€ } convert_vga_to_acs:=$f800+word('a'); else convert_vga_to_acs:=word(ch); @@ -503,19 +485,9 @@ end; procedure UpdateTTY(Force:boolean); -type - tchattr=packed record -{$ifdef ENDIAN_LITTLE} - ch : char; - attr : byte; -{$else} - attr : byte; - ch : char; -{$endif} - end; var outbuf : array[0..1023+255] of char; - chattr : tchattr; + chattr : tenhancedvideocell; skipped : boolean; outptr, spaces, @@ -524,160 +496,28 @@ var LastX,LastY, SpaceAttr, LastAttr : longint; - p,pold : pvideocell; LastLineWidth : Longint; + p,pold : penhancedvideocell; + LastCharWasDoubleWidth: Boolean; + CurCharWidth: Integer; - function transform_cp437_to_iso01(const st:string):string; - - var i:byte; - c:char; - converted:word; - - begin - transform_cp437_to_iso01:=''; - for i:=1 to length(st) do - begin - c:=st[i]; - case c of - #0..#31: - converted:=convert_lowascii_to_iso01[c]; - #128..#255: - converted:=convert_cp437_to_iso01[c]; - else - converted:=byte(c); - end; - if converted and $ff00=$f800 then - begin - if not in_ACS then - begin - transform_cp437_to_iso01:=transform_cp437_to_iso01+ACSIn; - in_ACS:=true; - end; - c:=char(converted and $ff); - end - else - if in_ACS then - begin - transform_cp437_to_iso01:=transform_cp437_to_iso01+ACSOut+ - Attr2Ansi(LastAttr,0); - in_ACS:=false; - end; - transform_cp437_to_iso01:=transform_cp437_to_iso01+c; - end; - end; - - function transform_cp850_to_iso01(const st:string):string; - - var i:byte; - c:char; - converted:word; - + function transform(const hstr:UnicodeString):RawByteString; begin - transform_cp850_to_iso01:=''; - for i:=1 to length(st) do - begin - c:=st[i]; - case c of - #0..#31: - converted:=convert_lowascii_to_iso01[c]; - #128..#255: - converted:=convert_cp850_to_iso01[c]; - else - converted:=byte(c); - end; - if converted and $ff00=$f800 then - begin - if not in_ACS then - begin - transform_cp850_to_iso01:=transform_cp850_to_iso01+ACSIn; - in_ACS:=true; - end; - end - else - if in_ACS then - begin - transform_cp850_to_iso01:=transform_cp850_to_iso01+ACSOut+ - Attr2Ansi(LastAttr,0); - in_ACS:=false; - end; - c:=char(converted and $ff); - transform_cp850_to_iso01:=transform_cp850_to_iso01+c; - end; + result:=Utf8Encode(hstr); + if external_codepage<>CP_UTF8 then + SetCodePage(result,external_codepage,True); end; - function transform_linuxlowascii_to_vga(const st:string):string; - - var i:byte; - c:char; - converted:word; - - begin - transform_linuxlowascii_to_vga:=''; - for i:=1 to length(st) do - begin - c:=st[i]; - case c of - #0..#31: - converted:=convert_linuxlowascii_to_vga[c]; - else - converted:=byte(c); - end; - c:=char(converted and $ff); - transform_linuxlowascii_to_vga:=transform_linuxlowascii_to_vga+c; - end; - end; - - function transform_cp437_to_UTF8(const st:string): string; - var i:byte; - c : char; - converted : WideChar; - s : WideString; - begin - s := ''; - for i:=1 to length(st) do - begin - c:=st[i]; - case c of - #0..#31: - converted:=convert_lowascii_to_UTF8[c]; - #127..#255: - converted:=convert_cp437_to_UTF8[c]; - else - begin - converted := #0; - converted := c; - end; - end; - s := s + converted; - end; - transform_cp437_to_UTF8 := Utf8Encode(s); - end; - - function transform(const hstr:string):string; - - begin - case convert of - cv_linuxlowascii_to_vga: - transform:=transform_linuxlowascii_to_vga(hstr); - cv_cp437_to_iso01: - transform:=transform_cp437_to_iso01(hstr); - cv_cp850_to_iso01: - transform:=transform_cp850_to_iso01(hstr); - cv_cp437_to_UTF8: - transform:=transform_cp437_to_UTF8(hstr); - else - transform:=hstr; - end; - end; - - procedure outdata(hstr:string); + procedure outdata(hstr:rawbytestring); begin If Length(HStr)>0 Then Begin while (eol>0) do begin - hstr:=#13#10+hstr; + outbuf[outptr]:=#13; + outbuf[outptr+1]:=#10; + inc(outptr,2); dec(eol); end; { if (convert=cv_vga_to_acs) and (ACSIn<>'') and (ACSOut<>'') then @@ -744,8 +584,8 @@ begin OutPtr:=0; Eol:=0; skipped:=true; - p:=PVideoCell(VideoBuf); - pold:=PVideoCell(OldVideoBuf); + p:=PEnhancedVideoCell(@EnhancedVideoBuf[0]); + pold:=PEnhancedVideoCell(@OldEnhancedVideoBuf[0]); { init Attr, X,Y and set autowrap off } SendEscapeSeq(#27'[0;40;37m'#27'[?7l'{#27'[H'} ); // 1.0.x: SendEscapeSeq(#27'[m'{#27'[H'}); @@ -759,56 +599,75 @@ begin LastLineWidth:=ScreenWidth; If (y=ScreenHeight) And (Console=ttyFreeBSD) {And :am: is on} Then LastLineWidth:=ScreenWidth-2; + LastCharWasDoubleWidth:=False; for x:=1 to LastLineWidth do begin - if (not force) and (p^=pold^) then - begin - if (Spaces>0) then - OutSpaces; - skipped:=true; - end + if LastCharWasDoubleWidth then + LastCharWasDoubleWidth:=false else - begin - if skipped then - begin - OutData(XY2Ansi(x,y,LastX,LastY)); - LastX:=x; - LastY:=y; - skipped:=false; - end; - chattr:=tchattr(p^); -{ if chattr.ch in [#0,#255] then - chattr.ch:=' ';} - if chattr.ch=' ' then - begin - if Spaces=0 then - SpaceAttr:=chattr.Attr; - if (chattr.attr and $f0)=(spaceattr and $f0) then - chattr.Attr:=SpaceAttr - else - begin - OutSpaces; - SpaceAttr:=chattr.Attr; - end; - inc(Spaces); - end - else - begin - if (Spaces>0) then - OutSpaces; -{ if ord(chattr.ch)<32 then + begin + CurCharWidth := ExtendedGraphemeClusterDisplayWidth(p^.ExtendedGraphemeCluster); + if (not force) and (p^=pold^) and + ((CurCharWidth <= 1) or (x=LastLineWidth) or (p[1]=pold[1])) then + begin + if (Spaces>0) then + OutSpaces; + skipped:=true; + if CurCharWidth = 2 then + LastCharWasDoubleWidth:=true; + end + else + begin + if skipped then begin - Chattr.Attr:= $ff xor Chattr.Attr; - ChAttr.ch:=chr(ord(chattr.ch)+ord('A')-1); - end;} - if LastAttr<>chattr.Attr then - OutClr(chattr.Attr); - OutData(transform(chattr.ch)); - LastX:=x+1; - LastY:=y; - end; - p^:=tvideocell(chattr); - end; + OutData(XY2Ansi(x,y,LastX,LastY)); + LastX:=x; + LastY:=y; + skipped:=false; + end; + chattr:=p^; + { if chattr.ch in [#0,#255] then + chattr.ch:=' ';} + if chattr.ExtendedGraphemeCluster=' ' then + begin + if Spaces=0 then + SpaceAttr:=chattr.Attribute; + if (chattr.Attribute and $f0)=(spaceattr and $f0) then + chattr.Attribute:=SpaceAttr + else + begin + OutSpaces; + SpaceAttr:=chattr.Attribute; + end; + inc(Spaces); + end + else + begin + if (Spaces>0) then + OutSpaces; + { if ord(chattr.ch)<32 then + begin + Chattr.Attr:= $ff xor Chattr.Attr; + ChAttr.ch:=chr(ord(chattr.ch)+ord('A')-1); + end;} + if LastAttr<>chattr.Attribute then + OutClr(chattr.Attribute); + OutData(transform(chattr.ExtendedGraphemeCluster)); + if CurCharWidth=2 then + begin + LastX:=x+2; + LastCharWasDoubleWidth:=True; + end + else + begin + LastX:=x+1; + LastCharWasDoubleWidth:=False; + end; + LastY:=y; + end; + //p^:=chattr; + end; + end; inc(p); inc(pold); end; @@ -821,24 +680,24 @@ begin end; eol:=0; {if am in capabilities? Then} - if (Console=ttyFreeBSD) and (Plongint(p)^<>plongint(pold)^) Then + if (Console=ttyFreeBSD) and (p^<>pold^) Then begin OutData(XY2Ansi(ScreenWidth,ScreenHeight,LastX,LastY)); OutData(#8); {Output last char} - chattr:=tchattr(p[1]); - if LastAttr<>chattr.Attr then - OutClr(chattr.Attr); - OutData(transform(chattr.ch)); + chattr:=p[1]; + if LastAttr<>chattr.Attribute then + OutClr(chattr.Attribute); + OutData(transform(chattr.ExtendedGraphemeCluster)); inc(LastX); // OutData(XY2Ansi(ScreenWidth-1,ScreenHeight,LastX,LastY)); // OutData(GetTermString(Insert_character)); OutData(#8+#27+'[1@'); - chattr:=tchattr(p^); - if LastAttr<>chattr.Attr then - OutClr(chattr.Attr); - OutData(transform(chattr.ch)); + chattr:=p^; + if LastAttr<>chattr.Attribute then + OutClr(chattr.Attribute); + OutData(transform(chattr.ExtendedGraphemeCluster)); inc(LastX); end; OutData(XY2Ansi(CursorX+1,CursorY+1,LastX,LastY)); @@ -958,58 +817,37 @@ begin TCSetAttr(1,TCSANOW,tio); end; -function UTF8Enabled: Boolean; -var - lang:string; -begin - {$ifdef BEOS} - UTF8Enabled := true; - exit; - {$endif} - lang:=upcase(fpgetenv('LANG')); - UTF8Enabled := (Pos('.UTF-8', lang) > 0) or (Pos('.UTF8', lang) > 0); -end; - procedure decide_codepages; var s:string; begin - if external_codepage in vga_codepages then + if is_vga_code_page(external_codepage) then begin {Possible override...} s:=upcase(fpgetenv('CONSOLEFONT_CP')); if s='CP437' then - external_codepage:=cp437 + external_codepage:=437 else if s='CP850' then - external_codepage:=cp850; + external_codepage:=850; end; {A non-vcsa Linux console can display most control characters, but not all.} - if {$ifdef linux}(console<>ttyLinux) and{$endif} - (cur_term_strings=@term_codes_linux) then - convert:=cv_linuxlowascii_to_vga; case external_codepage of - iso01: {West Europe} - begin - internal_codepage:=cp850; - convert:=cv_cp850_to_iso01; - end; - iso02: {East Europe} - internal_codepage:=cp852; - iso05: {Cyrillic} - internal_codepage:=cp866; - utf8: - begin - internal_codepage:=cp437; - convert:=cv_cp437_to_UTF8; - end; + CP_ISO01: {West Europe} + CurrentLegacy2EnhancedTranslationCodePage:=850; + CP_ISO02: {East Europe} + CurrentLegacy2EnhancedTranslationCodePage:=852; + CP_ISO05: {Cyrillic} + CurrentLegacy2EnhancedTranslationCodePage:=866; + CP_UTF8: + CurrentLegacy2EnhancedTranslationCodePage:=437; else - if internal_codepage in vga_codepages then - internal_codepage:=external_codepage + if is_vga_code_page(external_codepage) then + CurrentLegacy2EnhancedTranslationCodePage:=external_codepage else {We don't know how to convert to the external codepage. Use codepage 437 in the hope that the actual font has similarity to codepage 437.} - internal_codepage:=cp437; + CurrentLegacy2EnhancedTranslationCodePage:=437; end; end; @@ -1074,11 +912,11 @@ begin {$endif linux} Console:=TTyNetwork; {Default: Network or other vtxxx tty} cur_term_strings:=@term_codes_vt100; {Default: vt100} - external_codepage:=iso01; {Default: ISO-8859-1} + external_codepage:=CP_ISO01; {Default: ISO-8859-1} if UTF8Enabled then - external_codepage:=utf8; + external_codepage:=CP_UTF8; {$ifdef linux} - if (vcs_device>=0) and (external_codepage<>utf8) then + if (vcs_device>=0) and (external_codepage<>CP_UTF8) then begin str(vcs_device,s); fname:='/dev/vcsa'+s; @@ -1087,7 +925,7 @@ begin if ttyfd<>-1 then begin console:=ttylinux; - external_codepage:=cp437; {VCSA defaults to codepage 437.} + external_codepage:=437; {VCSA defaults to codepage 437.} end else if try_grab_vcsa then @@ -1096,7 +934,7 @@ begin if ttyfd<>-1 then begin console:=ttylinux; - external_codepage:=cp437; {VCSA defaults to codepage 437.} + external_codepage:=437; {VCSA defaults to codepage 437.} end; end; end; @@ -1142,16 +980,16 @@ begin {$endif} if cur_term_strings=@term_codes_linux then begin - if external_codepage<>utf8 then + if external_codepage<>CP_UTF8 then begin {Enable the VGA character set (codepage 437,850,....)} fpwrite(stdoutputhandle,font_vga,sizeof(font_vga)); - external_codepage:=cp437; {Now default to codepage 437.} + external_codepage:=437; {Now default to codepage 437.} end; end else begin - if external_codepage<>utf8 then + if external_codepage<>CP_UTF8 then begin {No VGA font :( } fpwrite(stdoutputhandle,font_lat1,sizeof(font_lat1)); @@ -1244,7 +1082,7 @@ begin { if we're in utf8 mode, we didn't change the font, so no need to restore anything } - if external_codepage<>utf8 then + if external_codepage<>CP_UTF8 then begin {Enable the character set set through setfont} fpwrite(stdoutputhandle,font_custom,3); @@ -1279,6 +1117,8 @@ end; procedure SysUpdateScreen(Force: Boolean); +var + I: Integer; begin {$ifdef linux} if console=ttylinux then @@ -1286,7 +1126,8 @@ begin else {$endif} updateTTY(force); - move(VideoBuf^,OldVideoBuf^,VideoBufSize); + for I := Low(EnhancedVideoBuf) to High(EnhancedVideoBuf) do + OldEnhancedVideoBuf[I] := EnhancedVideoBuf[I]; end; @@ -1364,7 +1205,8 @@ end; Const SysVideoDriver : TVideoDriver = ( - InitDriver : @SysInitVideo; + InitDriver : nil; + InitEnhancedDriver: @SysInitVideo; DoneDriver : @SysDoneVideo; UpdateScreen : @SysUpdateScreen; ClearScreen : @SysClearScreen; @@ -1375,6 +1217,10 @@ Const GetCursorType : @SysGetCursorType; SetCursorType : @SysSetCursorType; GetCapabilities : @SysGetCapabilities; + GetActiveCodePage : Nil; + ActivateCodePage : Nil; + GetSupportedCodePageCount : Nil; + GetSupportedCodePage : Nil; ); initialization diff --git a/packages/rtl-console/src/win/keyboard.pp b/packages/rtl-console/src/win/keyboard.pp index 03f1cc7115..403dbebea2 100644 --- a/packages/rtl-console/src/win/keyboard.pp +++ b/packages/rtl-console/src/win/keyboard.pp @@ -47,8 +47,13 @@ uses const MaxQueueSize = 120; FrenchKeyboard = $040C040C; +type + TFPKeyEventRecord = record + ev: TKeyEventRecord; + ShiftState: TEnhancedShiftState; + end; var - keyboardeventqueue : array[0..maxqueuesize] of TKeyEventRecord; + keyboardeventqueue : array[0..maxqueuesize] of TFPKeyEventRecord; nextkeyevent,nextfreekeyevent : longint; newKeyEvent : THandle; {sinaled if key is available} lockVar : TCriticalSection; {for queue access} @@ -90,7 +95,7 @@ end; { gets or peeks the next key from the queue, does not wait for new keys } -function getKeyEventFromQueue (VAR t : TKeyEventRecord; Peek : boolean) : boolean; +function getKeyEventFromQueue (VAR t : TFPKeyEventRecord; Peek : boolean) : boolean; begin if not Inited then begin @@ -114,7 +119,7 @@ end; { gets the next key from the queue, does wait for new keys } -function getKeyEventFromQueueWait (VAR t : TKeyEventRecord) : boolean; +function getKeyEventFromQueueWait (VAR t : TFPKeyEventRecord) : boolean; begin if not Inited then begin @@ -144,16 +149,122 @@ begin transShiftState := b; end; +procedure UpdateKeyboardLayoutInfo(Force: Boolean); +var + NewKeyboardLayout: HKL; + + procedure CheckAltGr; + var i: integer; + begin + HasAltGr:=false; + + i:=$20; + while i<$100 do + begin + // <MSDN> + // For keyboard layouts that use the right-hand ALT key as a shift key + // (for example, the French keyboard layout), the shift state is + // represented by the value 6, because the right-hand ALT key is + // converted internally into CTRL+ALT. + // </MSDN> + if (HIBYTE(VkKeyScanEx(chr(i),KeyBoardLayout))=6) then + begin + HasAltGr:=true; + break; + end; + inc(i); + end; + end; + +begin + NewKeyBoardLayout:=GetKeyboardLayout(0); + if force or (NewKeyboardLayout <> KeyBoardLayout) then + begin + KeyBoardLayout:=NewKeyboardLayout; + CheckAltGr; + end; +end; + { The event-Handler thread from the unit event will call us if a key-event is available } procedure HandleKeyboard(var ir:INPUT_RECORD); + + { translate win32 shift-state to keyboard shift state } + function transEnhShiftState (ControlKeyState : dword) : TEnhancedShiftState; + var b : TEnhancedShiftState; + begin + b := []; + { Ctrl + Right Alt = AltGr } + if HasAltGr and (ControlKeyState and RIGHT_ALT_PRESSED <> 0) and + ((ControlKeyState and LEFT_CTRL_PRESSED <> 0) or + (ControlKeyState and RIGHT_CTRL_PRESSED <> 0)) then + begin + Include(b, essAltGr); + { if it's the right ctrl key, then we know it's RightCtrl+AltGr } + if ControlKeyState and RIGHT_CTRL_PRESSED <> 0 then + b:=b+[essCtrl,essRightCtrl]; + { if it's the left ctrl key, unfortunately, we can't distinguish between + LeftCtrl+AltGr and AltGr alone, so we assume AltGr only } + end + else + begin + if ControlKeyState and LEFT_CTRL_PRESSED <> 0 then + b:=b+[essCtrl,essLeftCtrl]; + if ControlKeyState and RIGHT_ALT_PRESSED <> 0 then + b:=b+[essAlt,essRightAlt]; + if ControlKeyState and RIGHT_CTRL_PRESSED <> 0 then + b:=b+[essCtrl,essRightCtrl]; + end; + if ControlKeyState and LEFT_ALT_PRESSED <> 0 then + b:=b+[essAlt,essLeftAlt]; + if ControlKeyState and SHIFT_PRESSED <> 0 then { win32 makes no difference between left and right shift } + Include(b,essShift); + if ControlKeyState and NUMLOCK_ON <> 0 then + Include(b,essNumLockOn); + if ControlKeyState and CAPSLOCK_ON <> 0 then + Include(b,essCapsLockOn); + if ControlKeyState and SCROLLLOCK_ON <> 0 then + Include(b,essScrollLockOn); + if (GetKeyState(VK_LSHIFT) and $8000) <> 0 then + b:=b+[essShift,essLeftShift]; + if (GetKeyState(VK_RSHIFT) and $8000) <> 0 then + b:=b+[essShift,essRightShift]; + if (GetKeyState(VK_NUMLOCK) and $8000) <> 0 then + Include(b,essNumLockPressed); + if (GetKeyState(VK_CAPITAL) and $8000) <> 0 then + Include(b,essCapsLockPressed); + if (GetKeyState(VK_SCROLL) and $8000) <> 0 then + Include(b,essScrollLockPressed); + transEnhShiftState := b; + end; + var i : longint; c : word; altc : char; addThis: boolean; begin + { Since Windows supports switching between different input locales, the + current input locale might change, while the app is still running. In + fact, this is the default configuration for languages, that use a Non + Latin script (e.g. Cyrillic, Greek, etc.) - they use this feature to + switch between Latin and the Non Latin layout. But Windows in general + can be configured to switch between any number of different keyboard + layouts, so it's not a feature, limited only to Non Latin scripts. + + GUI apps get an WM_INPUTLANGCHANGE message in the case the keyboard layout + changes, but unfortunately, console apps get no such notification. Therefore + we must check and update our idea of the current keyboard layout on every + key event we receive. :( + + Note: This doesn't actually work, due to this Windows bug: + https://github.com/Microsoft/console/issues/83 + Since Microsoft considers this an open bug, and since there's no known + workaround, we still poll the keyboard layout, in hope that some day + Microsoft might fix this and issue a Windows Update. } + UpdateKeyboardLayoutInfo(False); + with ir.Event.KeyEvent do begin { key up events are ignored (except alt) } @@ -203,8 +314,10 @@ begin end; if addThis then begin - keyboardeventqueue[nextfreekeyevent]:= + keyboardeventqueue[nextfreekeyevent].ev:= ir.Event.KeyEvent; + keyboardeventqueue[nextfreekeyevent].ShiftState:= + transEnhShiftState(dwControlKeyState); incqueueindex(nextfreekeyevent); end; end; @@ -228,10 +341,11 @@ begin begin {add to queue} fillchar (ir, sizeof (ir), 0); bKeyDown := true; - AsciiChar := char (c); + UnicodeChar := WideChar (c); {and add to queue} EnterCriticalSection (lockVar); - keyboardeventqueue[nextfreekeyevent]:=ir.Event.KeyEvent; + keyboardeventqueue[nextfreekeyevent].ev:=ir.Event.KeyEvent; + keyboardeventqueue[nextfreekeyevent].ShiftState:=transEnhShiftState(dwControlKeyState); incqueueindex(nextfreekeyevent); SetEvent (newKeyEvent); {event that a new key is available} LeaveCriticalSection (lockVar); @@ -245,39 +359,12 @@ begin end; end; -procedure CheckAltGr; - -var ahkl : HKL; - i : integer; - - begin - HasAltGr:=false; - - ahkl:=GetKeyboardLayout(0); - i:=$20; - while i<$100 do - begin - // <MSDN> - // For keyboard layouts that use the right-hand ALT key as ashift key - // (for example, the French keyboard layout), the shift state is - // represented by the value 6, because the right-hand ALT key is - // converted internally into CTRL+ALT. - // </MSDN> - if (HIBYTE(VkKeyScanEx(chr(i),ahkl))=6) then - begin - HasAltGr:=true; - break; - end; - inc(i); - end; -end; - procedure SysInitKeyboard; begin - KeyBoardLayout:=GetKeyboardLayout(0); + UpdateKeyboardLayoutInfo(True); lastShiftState := 0; FlushConsoleInputBuffer(StdInputHandle); newKeyEvent := CreateEvent (nil, // address of security attributes @@ -295,7 +382,6 @@ begin nextkeyevent:=0; nextfreekeyevent:=0; - checkaltgr; SetKeyboardEventHandler (@HandleKeyboard); Inited:=true; end; @@ -641,52 +727,119 @@ CONST (n : $00; s : $0F; c : $94; a: $00)); {0F Tab } -function TranslateKey (t : TKeyEventRecord) : TKeyEvent; -var key : TKeyEvent; - ss : byte; +function WideCharToOemCpChar(WC: WideChar): Char; +var + Res: Char; +begin + if WideCharToMultiByte(CP_OEMCP,0,@WC,1,@Res,1,nil,nil)=0 then + Res:=#0; + WideCharToOemCpChar:=Res; +end; + + +function SysTranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent; +begin + if KeyEvent and $03000000 = $03000000 then + begin + if KeyEvent and $000000FF <> 0 then + begin + SysTranslateKeyEvent := KeyEvent and $00FFFFFF; + exit; + end; + {translate function-keys and other specials, ascii-codes are already ok} + case (KeyEvent AND $0000FF00) shr 8 of + {F1..F10} + $3B..$44 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $3B + $02000000; + {F11,F12} + $85..$86 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $85 + $02000000; + {Shift F1..F10} + $54..$5D : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $54 + $02000000; + {Shift F11,F12} + $87..$88 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $87 + $02000000; + {Alt F1..F10} + $68..$71 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $68 + $02000000; + {Alt F11,F12} + $8B..$8C : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $8B + $02000000; + {Ctrl F1..F10} + $5E..$67 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $5E + $02000000; + {Ctrl F11,F12} + $89..$8A : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $89 + $02000000; + + {normal,ctrl,alt} + $47,$77,$97 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdHome + $02000000; + $48,$8D,$98 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdUp + $02000000; + $49,$84,$99 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdPgUp + $02000000; + $4b,$73,$9B : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdLeft + $02000000; + $4d,$74,$9D : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdRight + $02000000; + $4f,$75,$9F : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdEnd + $02000000; + $50,$91,$A0 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdDown + $02000000; + $51,$76,$A1 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdPgDn + $02000000; + $52,$92,$A2 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdInsert + $02000000; + $53,$93,$A3 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdDelete + $02000000; + else + SysTranslateKeyEvent := KeyEvent; + end; + end else + SysTranslateKeyEvent := KeyEvent; +end; + + +function SysGetShiftState: Byte; + +begin + {may be better to save the last state and return that if no key is in buffer???} + SysGetShiftState:= lastShiftState; +end; + + +function TranslateEnhancedKeyEvent (t : TFPKeyEventRecord) : TEnhancedKeyEvent; +var key : TEnhancedKeyEvent; {$ifdef USEKEYCODES} ScanCode : byte; {$endif USEKEYCODES} b : byte; begin - Key := 0; - if t.bKeyDown then + Key := NilEnhancedKeyEvent; + if t.ev.bKeyDown then begin - { ascii-char is <> 0 if not a specal key } + { unicode-char is <> 0 if not a specal key } { we return it here otherwise we have to translate more later } - if t.AsciiChar <> #0 then + if t.ev.UnicodeChar <> WideChar(0) then begin - if (t.dwControlKeyState and ENHANCED_KEY <> 0) and - (t.wVirtualKeyCode = $DF) then + if (t.ev.dwControlKeyState and ENHANCED_KEY <> 0) and + (t.ev.wVirtualKeyCode = $DF) then begin - t.dwControlKeyState:=t.dwControlKeyState and not ENHANCED_KEY; - t.wVirtualKeyCode:=VK_DIVIDE; - t.AsciiChar:='/'; + t.ev.dwControlKeyState:=t.ev.dwControlKeyState and not ENHANCED_KEY; + t.ev.wVirtualKeyCode:=VK_DIVIDE; + t.ev.UnicodeChar:='/'; end; {drivers needs scancode, we return it here as under dos and linux with $03000000 = the lowest two bytes is the physical representation} {$ifdef USEKEYCODES} - Scancode:=KeyToQwertyScan[t.wVirtualKeyCode AND $00FF]; + Scancode:=KeyToQwertyScan[t.ev.wVirtualKeyCode AND $00FF]; If ScanCode>0 then - t.wVirtualScanCode:=ScanCode; - Key := byte (t.AsciiChar) + (t.wVirtualScanCode shl 8) + $03000000; - ss := transShiftState (t.dwControlKeyState); - key := key or (ss shl 16); - if (ss and kbAlt <> 0) and rightistruealt(t.dwControlKeyState) then - key := key and $FFFFFF00; + t.ev.wVirtualScanCode:=ScanCode; + Key.UnicodeChar := t.ev.UnicodeChar; + Key.AsciiChar := WideCharToOemCpChar(t.ev.UnicodeChar); + Key.VirtualScanCode := byte (Key.AsciiChar) + (t.ev.wVirtualScanCode shl 8); + Key.ShiftState := t.ShiftState; + if essAlt in t.ShiftState then + Key.VirtualScanCode := Key.VirtualScanCode and $FF00; {$else not USEKEYCODES} - Key := byte (t.AsciiChar) + ((t.wVirtualScanCode AND $00FF) shl 8) + $03000000; + Key.UnicodeChar := t.ev.UnicodeChar; + Key.AsciiChar := WideCharToOemCpChar(t.ev.UnicodeChar); + Key.VirtualScanCode := byte (Key.AsciiChar) + ((t.ev.wVirtualScanCode AND $00FF) shl 8); {$endif not USEKEYCODES} end else begin {$ifdef USEKEYCODES} - Scancode:=KeyToQwertyScan[t.wVirtualKeyCode AND $00FF]; + Scancode:=KeyToQwertyScan[t.ev.wVirtualKeyCode AND $00FF]; If ScanCode>0 then - t.wVirtualScanCode:=ScanCode; + t.ev.wVirtualScanCode:=ScanCode; {$endif not USEKEYCODES} - translateKey := 0; + TranslateEnhancedKeyEvent := NilEnhancedKeyEvent; { ignore shift,ctrl,alt,numlock,capslock alone } - case t.wVirtualKeyCode of + case t.ev.wVirtualKeyCode of $0010, {shift} $0011, {ctrl} $0012, {alt} @@ -701,181 +854,124 @@ begin $00DD: exit; {´ and ` : next key i.e. e is modified } end; - key := $03000000 + (t.wVirtualScanCode shl 8); { make lower 8 bit=0 like under dos } + Key.VirtualScanCode := t.ev.wVirtualScanCode shl 8; { make lower 8 bit=0 like under dos } end; { Handling of ~ key as AltGr 2 } { This is also French keyboard specific !! } { but without this I can not get a ~ !! PM } { MvdV: not rightruealtised, since it already has frenchkbd guard} - if (t.wVirtualKeyCode=$32) and + if (t.ev.wVirtualKeyCode=$32) and (KeyBoardLayout = FrenchKeyboard) and - (t.dwControlKeyState and RIGHT_ALT_PRESSED <> 0) then - key:=(key and $ffffff00) or ord('~'); + (t.ev.dwControlKeyState and RIGHT_ALT_PRESSED <> 0) then + begin + Key.UnicodeChar := '~'; + Key.AsciiChar := '~'; + Key.VirtualScanCode := (Key.VirtualScanCode and $ff00) or ord('~'); + end; { ok, now add Shift-State } - ss := transShiftState (t.dwControlKeyState); - key := key or (ss shl 16); + Key.ShiftState := t.ShiftState; { Reset Ascii-Char if Alt+Key, fv needs that, may be we need it for other special keys too 18 Sept 1999 AD: not for right Alt i.e. for AltGr+ß = \ on german keyboard } - if ((ss and kbAlt <> 0) and rightistruealt(t.dwControlKeyState)) or + if (essAlt in t.ShiftState) or (* { yes, we need it for cursor keys, 25=left, 26=up, 27=right,28=down} {aggg, this will not work because esc is also virtualKeyCode 27!!} - {if (t.wVirtualKeyCode >= 25) and (t.wVirtualKeyCode <= 28) then} + {if (t.ev.wVirtualKeyCode >= 25) and (t.ev.wVirtualKeyCode <= 28) then} no VK_ESCAPE is $1B !! there was a mistake : VK_LEFT is $25 not 25 !! *) { not $2E VK_DELETE because its only the Keypad point !! PM } - (t.wVirtualKeyCode in [$21..$28,$2C,$2D,$2F]) then - { if t.wVirtualScanCode in [$47..$49,$4b,$4d,$4f,$50..$53] then} - key := key and $FFFFFF00; + (t.ev.wVirtualKeyCode in [$21..$28,$2C,$2D,$2F]) then + { if t.ev.wVirtualScanCode in [$47..$49,$4b,$4d,$4f,$50..$53] then} + Key.VirtualScanCode := Key.VirtualScanCode and $FF00; {and translate to dos-scancodes to make fv happy, we will convert this back in translateKeyEvent} - if rightistruealt(t.dwControlKeyState) then {not for alt-gr} - if (t.wVirtualScanCode >= low (DosTT)) and - (t.wVirtualScanCode <= high (dosTT)) then - begin - b := 0; - if (ss and kbAlt) <> 0 then - b := DosTT[t.wVirtualScanCode].a - else - if (ss and kbCtrl) <> 0 then - b := DosTT[t.wVirtualScanCode].c - else - if (ss and kbShift) <> 0 then - b := DosTT[t.wVirtualScanCode].s - else - b := DosTT[t.wVirtualScanCode].n; - if b <> 0 then - key := (key and $FFFF00FF) or (cardinal (b) shl 8); - end; + if (t.ev.wVirtualScanCode >= low (DosTT)) and + (t.ev.wVirtualScanCode <= high (dosTT)) then + begin + b := 0; + if essAlt in t.ShiftState then + b := DosTT[t.ev.wVirtualScanCode].a + else + if essCtrl in t.ShiftState then + b := DosTT[t.ev.wVirtualScanCode].c + else + if essShift in t.ShiftState then + b := DosTT[t.ev.wVirtualScanCode].s + else + b := DosTT[t.ev.wVirtualScanCode].n; + if b <> 0 then + Key.VirtualScanCode := (Key.VirtualScanCode and $00FF) or (cardinal (b) shl 8); + end; - {Alt-0 to Alt-9} - if rightistruealt(t.dwControlKeyState) then {not for alt-gr} - if (t.wVirtualScanCode >= low (DosTT09)) and - (t.wVirtualScanCode <= high (dosTT09)) then - begin - b := 0; - if (ss and kbAlt) <> 0 then - b := DosTT09[t.wVirtualScanCode].a - else - if (ss and kbCtrl) <> 0 then - b := DosTT09[t.wVirtualScanCode].c - else - if (ss and kbShift) <> 0 then - b := DosTT09[t.wVirtualScanCode].s - else - b := DosTT09[t.wVirtualScanCode].n; - if b <> 0 then - key := (key and $FFFF0000) or (cardinal (b) shl 8); - end; - - TranslateKey := key; + {Alt-0 to Alt-9} + if (t.ev.wVirtualScanCode >= low (DosTT09)) and + (t.ev.wVirtualScanCode <= high (dosTT09)) then + begin + b := 0; + if essAlt in t.ShiftState then + b := DosTT09[t.ev.wVirtualScanCode].a + else + if essCtrl in t.ShiftState then + b := DosTT09[t.ev.wVirtualScanCode].c + else + if essShift in t.ShiftState then + b := DosTT09[t.ev.wVirtualScanCode].s + else + b := DosTT09[t.ev.wVirtualScanCode].n; + if b <> 0 then + Key.VirtualScanCode := cardinal (b) shl 8; + end; end; - translateKey := Key; + TranslateEnhancedKeyEvent := Key; end; -function SysGetKeyEvent: TKeyEvent; -var t : TKeyEventRecord; - key : TKeyEvent; +function SysGetEnhancedKeyEvent: TEnhancedKeyEvent; +var t : TFPKeyEventRecord; + key : TEnhancedKeyEvent; begin - key := 0; + key := NilEnhancedKeyEvent; repeat if getKeyEventFromQueueWait (t) then - key := translateKey (t); - until key <> 0; -{$ifdef DEBUG} - last_ir.Event.KeyEvent:=t; -{$endif DEBUG} - SysGetKeyEvent := key; + key := TranslateEnhancedKeyEvent (t); + until key <> NilEnhancedKeyEvent; + SysGetEnhancedKeyEvent := key; end; -function SysPollKeyEvent: TKeyEvent; -var t : TKeyEventRecord; - k : TKeyEvent; +function SysPollEnhancedKeyEvent: TEnhancedKeyEvent; +var t : TFPKeyEventRecord; + k : TEnhancedKeyEvent; begin - SysPollKeyEvent := 0; + SysPollEnhancedKeyEvent := NilEnhancedKeyEvent; if getKeyEventFromQueue (t, true) then begin { we get an enty for shift, ctrl, alt... } - k := translateKey (t); - while (k = 0) do + k := TranslateEnhancedKeyEvent (t); + while (k = NilEnhancedKeyEvent) do begin getKeyEventFromQueue (t, false); {remove it} if not getKeyEventFromQueue (t, true) then exit; - k := translateKey (t) + k := TranslateEnhancedKeyEvent (t) end; - SysPollKeyEvent := k; + SysPollEnhancedKeyEvent := k; end; end; - -function SysTranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent; -begin - if KeyEvent and $03000000 = $03000000 then - begin - if KeyEvent and $000000FF <> 0 then - begin - SysTranslateKeyEvent := KeyEvent and $00FFFFFF; - exit; - end; - {translate function-keys and other specials, ascii-codes are already ok} - case (KeyEvent AND $0000FF00) shr 8 of - {F1..F10} - $3B..$44 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $3B + $02000000; - {F11,F12} - $85..$86 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $85 + $02000000; - {Shift F1..F10} - $54..$5D : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $54 + $02000000; - {Shift F11,F12} - $87..$88 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $87 + $02000000; - {Alt F1..F10} - $68..$71 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $68 + $02000000; - {Alt F11,F12} - $8B..$8C : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $8B + $02000000; - {Ctrl F1..F10} - $5E..$67 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $5E + $02000000; - {Ctrl F11,F12} - $89..$8A : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $89 + $02000000; - - {normal,ctrl,alt} - $47,$77,$97 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdHome + $02000000; - $48,$8D,$98 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdUp + $02000000; - $49,$84,$99 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdPgUp + $02000000; - $4b,$73,$9B : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdLeft + $02000000; - $4d,$74,$9D : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdRight + $02000000; - $4f,$75,$9F : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdEnd + $02000000; - $50,$91,$A0 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdDown + $02000000; - $51,$76,$A1 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdPgDn + $02000000; - $52,$92,$A2 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdInsert + $02000000; - $53,$93,$A3 : SysTranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdDelete + $02000000; - else - SysTranslateKeyEvent := KeyEvent; - end; - end else - SysTranslateKeyEvent := KeyEvent; -end; - - -function SysGetShiftState: Byte; - -begin - {may be better to save the last state and return that if no key is in buffer???} - SysGetShiftState:= lastShiftState; -end; - Const SysKeyboardDriver : TKeyboardDriver = ( InitDriver : @SysInitKeyBoard; DoneDriver : @SysDoneKeyBoard; - GetKeyevent : @SysGetKeyEvent; - PollKeyEvent : @SysPollKeyEvent; + GetKeyevent : Nil; + PollKeyEvent : Nil; GetShiftState : @SysGetShiftState; TranslateKeyEvent : @SysTranslateKeyEvent; TranslateKeyEventUnicode : Nil; + GetEnhancedKeyEvent : @SysGetEnhancedKeyEvent; + PollEnhancedKeyEvent : @SysPollEnhancedKeyEvent; ); diff --git a/packages/rtl-console/src/win/video.pp b/packages/rtl-console/src/win/video.pp index 7a60ffbb12..577219f5a0 100644 --- a/packages/rtl-console/src/win/video.pp +++ b/packages/rtl-console/src/win/video.pp @@ -17,291 +17,16 @@ unit Video; interface {$i videoh.inc} -const - useunicodefunctions : boolean = false; - procedure VideoSetConsoleOutHandle (NewHandle: THandle); implementation uses - windows,dos; + windows,dos,graphemebreakproperty,eastasianwidth,charset; {$i video.inc} - type - tunicodecharmappingflag = (umf_noinfo,umf_leadbyte,umf_undefined, - umf_unused); - - punicodecharmapping = ^tunicodecharmapping; - tunicodecharmapping = record - unicode : word; - flag : tunicodecharmappingflag; - reserved : byte; - end; - - const - mapcp850 : array[0..255] of tunicodecharmapping = ( - (unicode : 0; flag : umf_noinfo; reserved : 0), - (unicode : 1; flag : umf_noinfo; reserved : 0), - (unicode : 2; flag : umf_noinfo; reserved : 0), - (unicode : 3; flag : umf_noinfo; reserved : 0), - (unicode : 4; flag : umf_noinfo; reserved : 0), - (unicode : 5; flag : umf_noinfo; reserved : 0), - (unicode : 6; flag : umf_noinfo; reserved : 0), - (unicode : 7; flag : umf_noinfo; reserved : 0), - (unicode : 8; flag : umf_noinfo; reserved : 0), - (unicode : 9; flag : umf_noinfo; reserved : 0), - (unicode : 10; flag : umf_noinfo; reserved : 0), - (unicode : 11; flag : umf_noinfo; reserved : 0), - (unicode : 12; flag : umf_noinfo; reserved : 0), - (unicode : 13; flag : umf_noinfo; reserved : 0), - (unicode : 14; flag : umf_noinfo; reserved : 0), - (unicode : 15; flag : umf_noinfo; reserved : 0), - (unicode : 16; flag : umf_noinfo; reserved : 0), - (unicode : 17; flag : umf_noinfo; reserved : 0), - (unicode : 18; flag : umf_noinfo; reserved : 0), - (unicode : 19; flag : umf_noinfo; reserved : 0), - (unicode : 20; flag : umf_noinfo; reserved : 0), - (unicode : 21; flag : umf_noinfo; reserved : 0), - (unicode : 22; flag : umf_noinfo; reserved : 0), - (unicode : 23; flag : umf_noinfo; reserved : 0), - (unicode : 24; flag : umf_noinfo; reserved : 0), - (unicode : 25; flag : umf_noinfo; reserved : 0), - (unicode : 26; flag : umf_noinfo; reserved : 0), - (unicode : 27; flag : umf_noinfo; reserved : 0), - (unicode : 28; flag : umf_noinfo; reserved : 0), - (unicode : 29; flag : umf_noinfo; reserved : 0), - (unicode : 30; flag : umf_noinfo; reserved : 0), - (unicode : 31; flag : umf_noinfo; reserved : 0), - (unicode : 32; flag : umf_noinfo; reserved : 0), - (unicode : 33; flag : umf_noinfo; reserved : 0), - (unicode : 34; flag : umf_noinfo; reserved : 0), - (unicode : 35; flag : umf_noinfo; reserved : 0), - (unicode : 36; flag : umf_noinfo; reserved : 0), - (unicode : 37; flag : umf_noinfo; reserved : 0), - (unicode : 38; flag : umf_noinfo; reserved : 0), - (unicode : 39; flag : umf_noinfo; reserved : 0), - (unicode : 40; flag : umf_noinfo; reserved : 0), - (unicode : 41; flag : umf_noinfo; reserved : 0), - (unicode : 42; flag : umf_noinfo; reserved : 0), - (unicode : 43; flag : umf_noinfo; reserved : 0), - (unicode : 44; flag : umf_noinfo; reserved : 0), - (unicode : 45; flag : umf_noinfo; reserved : 0), - (unicode : 46; flag : umf_noinfo; reserved : 0), - (unicode : 47; flag : umf_noinfo; reserved : 0), - (unicode : 48; flag : umf_noinfo; reserved : 0), - (unicode : 49; flag : umf_noinfo; reserved : 0), - (unicode : 50; flag : umf_noinfo; reserved : 0), - (unicode : 51; flag : umf_noinfo; reserved : 0), - (unicode : 52; flag : umf_noinfo; reserved : 0), - (unicode : 53; flag : umf_noinfo; reserved : 0), - (unicode : 54; flag : umf_noinfo; reserved : 0), - (unicode : 55; flag : umf_noinfo; reserved : 0), - (unicode : 56; flag : umf_noinfo; reserved : 0), - (unicode : 57; flag : umf_noinfo; reserved : 0), - (unicode : 58; flag : umf_noinfo; reserved : 0), - (unicode : 59; flag : umf_noinfo; reserved : 0), - (unicode : 60; flag : umf_noinfo; reserved : 0), - (unicode : 61; flag : umf_noinfo; reserved : 0), - (unicode : 62; flag : umf_noinfo; reserved : 0), - (unicode : 63; flag : umf_noinfo; reserved : 0), - (unicode : 64; flag : umf_noinfo; reserved : 0), - (unicode : 65; flag : umf_noinfo; reserved : 0), - (unicode : 66; flag : umf_noinfo; reserved : 0), - (unicode : 67; flag : umf_noinfo; reserved : 0), - (unicode : 68; flag : umf_noinfo; reserved : 0), - (unicode : 69; flag : umf_noinfo; reserved : 0), - (unicode : 70; flag : umf_noinfo; reserved : 0), - (unicode : 71; flag : umf_noinfo; reserved : 0), - (unicode : 72; flag : umf_noinfo; reserved : 0), - (unicode : 73; flag : umf_noinfo; reserved : 0), - (unicode : 74; flag : umf_noinfo; reserved : 0), - (unicode : 75; flag : umf_noinfo; reserved : 0), - (unicode : 76; flag : umf_noinfo; reserved : 0), - (unicode : 77; flag : umf_noinfo; reserved : 0), - (unicode : 78; flag : umf_noinfo; reserved : 0), - (unicode : 79; flag : umf_noinfo; reserved : 0), - (unicode : 80; flag : umf_noinfo; reserved : 0), - (unicode : 81; flag : umf_noinfo; reserved : 0), - (unicode : 82; flag : umf_noinfo; reserved : 0), - (unicode : 83; flag : umf_noinfo; reserved : 0), - (unicode : 84; flag : umf_noinfo; reserved : 0), - (unicode : 85; flag : umf_noinfo; reserved : 0), - (unicode : 86; flag : umf_noinfo; reserved : 0), - (unicode : 87; flag : umf_noinfo; reserved : 0), - (unicode : 88; flag : umf_noinfo; reserved : 0), - (unicode : 89; flag : umf_noinfo; reserved : 0), - (unicode : 90; flag : umf_noinfo; reserved : 0), - (unicode : 91; flag : umf_noinfo; reserved : 0), - (unicode : 92; flag : umf_noinfo; reserved : 0), - (unicode : 93; flag : umf_noinfo; reserved : 0), - (unicode : 94; flag : umf_noinfo; reserved : 0), - (unicode : 95; flag : umf_noinfo; reserved : 0), - (unicode : 96; flag : umf_noinfo; reserved : 0), - (unicode : 97; flag : umf_noinfo; reserved : 0), - (unicode : 98; flag : umf_noinfo; reserved : 0), - (unicode : 99; flag : umf_noinfo; reserved : 0), - (unicode : 100; flag : umf_noinfo; reserved : 0), - (unicode : 101; flag : umf_noinfo; reserved : 0), - (unicode : 102; flag : umf_noinfo; reserved : 0), - (unicode : 103; flag : umf_noinfo; reserved : 0), - (unicode : 104; flag : umf_noinfo; reserved : 0), - (unicode : 105; flag : umf_noinfo; reserved : 0), - (unicode : 106; flag : umf_noinfo; reserved : 0), - (unicode : 107; flag : umf_noinfo; reserved : 0), - (unicode : 108; flag : umf_noinfo; reserved : 0), - (unicode : 109; flag : umf_noinfo; reserved : 0), - (unicode : 110; flag : umf_noinfo; reserved : 0), - (unicode : 111; flag : umf_noinfo; reserved : 0), - (unicode : 112; flag : umf_noinfo; reserved : 0), - (unicode : 113; flag : umf_noinfo; reserved : 0), - (unicode : 114; flag : umf_noinfo; reserved : 0), - (unicode : 115; flag : umf_noinfo; reserved : 0), - (unicode : 116; flag : umf_noinfo; reserved : 0), - (unicode : 117; flag : umf_noinfo; reserved : 0), - (unicode : 118; flag : umf_noinfo; reserved : 0), - (unicode : 119; flag : umf_noinfo; reserved : 0), - (unicode : 120; flag : umf_noinfo; reserved : 0), - (unicode : 121; flag : umf_noinfo; reserved : 0), - (unicode : 122; flag : umf_noinfo; reserved : 0), - (unicode : 123; flag : umf_noinfo; reserved : 0), - (unicode : 124; flag : umf_noinfo; reserved : 0), - (unicode : 125; flag : umf_noinfo; reserved : 0), - (unicode : 126; flag : umf_noinfo; reserved : 0), - (unicode : 127; flag : umf_noinfo; reserved : 0), - (unicode : 199; flag : umf_noinfo; reserved : 0), - (unicode : 252; flag : umf_noinfo; reserved : 0), - (unicode : 233; flag : umf_noinfo; reserved : 0), - (unicode : 226; flag : umf_noinfo; reserved : 0), - (unicode : 228; flag : umf_noinfo; reserved : 0), - (unicode : 224; flag : umf_noinfo; reserved : 0), - (unicode : 229; flag : umf_noinfo; reserved : 0), - (unicode : 231; flag : umf_noinfo; reserved : 0), - (unicode : 234; flag : umf_noinfo; reserved : 0), - (unicode : 235; flag : umf_noinfo; reserved : 0), - (unicode : 232; flag : umf_noinfo; reserved : 0), - (unicode : 239; flag : umf_noinfo; reserved : 0), - (unicode : 238; flag : umf_noinfo; reserved : 0), - (unicode : 236; flag : umf_noinfo; reserved : 0), - (unicode : 196; flag : umf_noinfo; reserved : 0), - (unicode : 197; flag : umf_noinfo; reserved : 0), - (unicode : 201; flag : umf_noinfo; reserved : 0), - (unicode : 230; flag : umf_noinfo; reserved : 0), - (unicode : 198; flag : umf_noinfo; reserved : 0), - (unicode : 244; flag : umf_noinfo; reserved : 0), - (unicode : 246; flag : umf_noinfo; reserved : 0), - (unicode : 242; flag : umf_noinfo; reserved : 0), - (unicode : 251; flag : umf_noinfo; reserved : 0), - (unicode : 249; flag : umf_noinfo; reserved : 0), - (unicode : 255; flag : umf_noinfo; reserved : 0), - (unicode : 214; flag : umf_noinfo; reserved : 0), - (unicode : 220; flag : umf_noinfo; reserved : 0), - (unicode : 248; flag : umf_noinfo; reserved : 0), - (unicode : 163; flag : umf_noinfo; reserved : 0), - (unicode : 216; flag : umf_noinfo; reserved : 0), - (unicode : 215; flag : umf_noinfo; reserved : 0), - (unicode : 402; flag : umf_noinfo; reserved : 0), - (unicode : 225; flag : umf_noinfo; reserved : 0), - (unicode : 237; flag : umf_noinfo; reserved : 0), - (unicode : 243; flag : umf_noinfo; reserved : 0), - (unicode : 250; flag : umf_noinfo; reserved : 0), - (unicode : 241; flag : umf_noinfo; reserved : 0), - (unicode : 209; flag : umf_noinfo; reserved : 0), - (unicode : 170; flag : umf_noinfo; reserved : 0), - (unicode : 186; flag : umf_noinfo; reserved : 0), - (unicode : 191; flag : umf_noinfo; reserved : 0), - (unicode : 174; flag : umf_noinfo; reserved : 0), - (unicode : 172; flag : umf_noinfo; reserved : 0), - (unicode : 189; flag : umf_noinfo; reserved : 0), - (unicode : 188; flag : umf_noinfo; reserved : 0), - (unicode : 161; flag : umf_noinfo; reserved : 0), - (unicode : 171; flag : umf_noinfo; reserved : 0), - (unicode : 187; flag : umf_noinfo; reserved : 0), - (unicode : 9617; flag : umf_noinfo; reserved : 0), - (unicode : 9618; flag : umf_noinfo; reserved : 0), - (unicode : 9619; flag : umf_noinfo; reserved : 0), - (unicode : 9474; flag : umf_noinfo; reserved : 0), - (unicode : 9508; flag : umf_noinfo; reserved : 0), - (unicode : 193; flag : umf_noinfo; reserved : 0), - (unicode : 194; flag : umf_noinfo; reserved : 0), - (unicode : 192; flag : umf_noinfo; reserved : 0), - (unicode : 169; flag : umf_noinfo; reserved : 0), - (unicode : 9571; flag : umf_noinfo; reserved : 0), - (unicode : 9553; flag : umf_noinfo; reserved : 0), - (unicode : 9559; flag : umf_noinfo; reserved : 0), - (unicode : 9565; flag : umf_noinfo; reserved : 0), - (unicode : 162; flag : umf_noinfo; reserved : 0), - (unicode : 165; flag : umf_noinfo; reserved : 0), - (unicode : 9488; flag : umf_noinfo; reserved : 0), - (unicode : 9492; flag : umf_noinfo; reserved : 0), - (unicode : 9524; flag : umf_noinfo; reserved : 0), - (unicode : 9516; flag : umf_noinfo; reserved : 0), - (unicode : 9500; flag : umf_noinfo; reserved : 0), - (unicode : 9472; flag : umf_noinfo; reserved : 0), - (unicode : 9532; flag : umf_noinfo; reserved : 0), - (unicode : 227; flag : umf_noinfo; reserved : 0), - (unicode : 195; flag : umf_noinfo; reserved : 0), - (unicode : 9562; flag : umf_noinfo; reserved : 0), - (unicode : 9556; flag : umf_noinfo; reserved : 0), - (unicode : 9577; flag : umf_noinfo; reserved : 0), - (unicode : 9574; flag : umf_noinfo; reserved : 0), - (unicode : 9568; flag : umf_noinfo; reserved : 0), - (unicode : 9552; flag : umf_noinfo; reserved : 0), - (unicode : 9580; flag : umf_noinfo; reserved : 0), - (unicode : 164; flag : umf_noinfo; reserved : 0), - (unicode : 240; flag : umf_noinfo; reserved : 0), - (unicode : 208; flag : umf_noinfo; reserved : 0), - (unicode : 202; flag : umf_noinfo; reserved : 0), - (unicode : 203; flag : umf_noinfo; reserved : 0), - (unicode : 200; flag : umf_noinfo; reserved : 0), - (unicode : 305; flag : umf_noinfo; reserved : 0), - (unicode : 205; flag : umf_noinfo; reserved : 0), - (unicode : 206; flag : umf_noinfo; reserved : 0), - (unicode : 207; flag : umf_noinfo; reserved : 0), - (unicode : 9496; flag : umf_noinfo; reserved : 0), - (unicode : 9484; flag : umf_noinfo; reserved : 0), - (unicode : 9608; flag : umf_noinfo; reserved : 0), - (unicode : 9604; flag : umf_noinfo; reserved : 0), - (unicode : 166; flag : umf_noinfo; reserved : 0), - (unicode : 204; flag : umf_noinfo; reserved : 0), - (unicode : 9600; flag : umf_noinfo; reserved : 0), - (unicode : 211; flag : umf_noinfo; reserved : 0), - (unicode : 223; flag : umf_noinfo; reserved : 0), - (unicode : 212; flag : umf_noinfo; reserved : 0), - (unicode : 210; flag : umf_noinfo; reserved : 0), - (unicode : 245; flag : umf_noinfo; reserved : 0), - (unicode : 213; flag : umf_noinfo; reserved : 0), - (unicode : 181; flag : umf_noinfo; reserved : 0), - (unicode : 254; flag : umf_noinfo; reserved : 0), - (unicode : 222; flag : umf_noinfo; reserved : 0), - (unicode : 218; flag : umf_noinfo; reserved : 0), - (unicode : 219; flag : umf_noinfo; reserved : 0), - (unicode : 217; flag : umf_noinfo; reserved : 0), - (unicode : 253; flag : umf_noinfo; reserved : 0), - (unicode : 221; flag : umf_noinfo; reserved : 0), - (unicode : 175; flag : umf_noinfo; reserved : 0), - (unicode : 180; flag : umf_noinfo; reserved : 0), - (unicode : 173; flag : umf_noinfo; reserved : 0), - (unicode : 177; flag : umf_noinfo; reserved : 0), - (unicode : 8215; flag : umf_noinfo; reserved : 0), - (unicode : 190; flag : umf_noinfo; reserved : 0), - (unicode : 182; flag : umf_noinfo; reserved : 0), - (unicode : 167; flag : umf_noinfo; reserved : 0), - (unicode : 247; flag : umf_noinfo; reserved : 0), - (unicode : 184; flag : umf_noinfo; reserved : 0), - (unicode : 176; flag : umf_noinfo; reserved : 0), - (unicode : 168; flag : umf_noinfo; reserved : 0), - (unicode : 183; flag : umf_noinfo; reserved : 0), - (unicode : 185; flag : umf_noinfo; reserved : 0), - (unicode : 179; flag : umf_noinfo; reserved : 0), - (unicode : 178; flag : umf_noinfo; reserved : 0), - (unicode : 9632; flag : umf_noinfo; reserved : 0), - (unicode : 160; flag : umf_noinfo; reserved : 0) - ); - - const LastCursorType: word = crUnderline; OrigScreen: PVideoBuf = nil; @@ -318,6 +43,8 @@ var ConsoleInfo : TConsoleScreenBufferInfo; NewConsoleHandleAllocated: boolean; ConsoleOutHandle: THandle; + LineBuf: array of TCharInfo; + procedure SysInitVideo; var SecAttr: TSecurityAttributes; @@ -417,6 +144,7 @@ begin SetConsoleCursorInfo(ConsoleOutHandle, OrigConsoleCursorInfo); SetConsoleCP(OrigCP); end; + SetLength(LineBuf,0); end; @@ -598,73 +326,20 @@ begin end; procedure SysUpdateScreen(Force: Boolean); - -type WordRec = record - One, Two: Byte; - end; { wordrec } - var BufSize, BufCoord : COORD; WriteRegion : SMALL_RECT; - LineBuf : Array[0..(1024*32) - 1] of TCharInfo; BufCounter : Longint; LineCounter, ColCounter : Longint; smallforce : boolean; x1,y1,x2,y2 : longint; - p1,p2,p3 : PCardinal; - j : integer; begin if force then smallforce:=true else - begin - {$ifdef cpui386} - asm - pushl %esi - pushl %edi - movl VideoBuf,%esi - movl OldVideoBuf,%edi - movl VideoBufSize,%ecx - shrl $2,%ecx - repe - cmpsl - setne smallforce - popl %edi - popl %esi - end; - {$else} - {$ifdef cpux86_64} - asm - pushq %rsi - pushq %rdi - xorq %rcx,%rcx - movq VideoBuf(%rip),%rsi - movq OldVideoBuf(%rip),%rdi - movl VideoBufSize(%rip),%ecx - shrq $2,%rcx - repe - cmpsl - setne smallforce - popq %rdi - popq %rsi - end; - {$else} - {$INFO No optimized version for this CPU, reverting to a pascal version} - j:=Videobufsize shr 2; - smallforce:=false; - p1:=pcardinal(VideoBuf); - p2:=pcardinal(OldVideoBuf); - p3:=@pcardinal(videobuf)[j]; - while (p1<p3) and (p1^=p2^) do - begin - inc(p1); inc(p2); - end; - smallforce:=p1<>p3; - {$ENDIF} - {$endif} - end; + SmallForce:=CompareByte(EnhancedVideoBuf[0],OldEnhancedVideoBuf[0],Length(EnhancedVideoBuf)*SizeOf(TEnhancedVideoCell))<>0; if SmallForce then begin BufSize.X := ScreenWidth; @@ -684,30 +359,31 @@ begin x2:=-1; y1:=ScreenHeight+1; y2:=-1; + SetLength(LineBuf,ScreenHeight*ScreenWidth); for LineCounter := 1 to ScreenHeight do begin for ColCounter := 1 to ScreenWidth do begin - if (WordRec(VideoBuf^[BufCounter]).One<>WordRec(OldVideoBuf^[BufCounter]).One) or - (WordRec(VideoBuf^[BufCounter]).Two<>WordRec(OldVideoBuf^[BufCounter]).Two) then + if EnhancedVideoBuf[BufCounter]<>OldEnhancedVideoBuf[BufCounter] then begin - if ColCounter<x1 then - x1:=ColCounter; - if ColCounter>x2 then - x2:=ColCounter; - if LineCounter<y1 then - y1:=LineCounter; - if LineCounter>y2 then - y2:=LineCounter; + OldEnhancedVideoBuf[BufCounter]:=EnhancedVideoBuf[BufCounter]; + if ColCounter<x1 then + x1:=ColCounter; + if ColCounter>x2 then + x2:=ColCounter; + if LineCounter<y1 then + y1:=LineCounter; + if LineCounter>y2 then + y2:=LineCounter; end; - if useunicodefunctions then - LineBuf[BufCounter].UniCodeChar := Widechar(mapcp850[WordRec(VideoBuf^[BufCounter]).One].unicode) + if Length(EnhancedVideoBuf[BufCounter].ExtendedGraphemeCluster) = 1 then + LineBuf[BufCounter].UniCodeChar := EnhancedVideoBuf[BufCounter].ExtendedGraphemeCluster[1] else - LineBuf[BufCounter].UniCodeChar := Widechar(WordRec(VideoBuf^[BufCounter]).One); + LineBuf[BufCounter].UniCodeChar := ' '; { If (WordRec(VideoBuf^[BufCounter]).Two and $80)<>0 then LineBuf^[BufCounter].Attributes := $100+WordRec(VideoBuf^[BufCounter]).Two else } - LineBuf[BufCounter].Attributes := WordRec(VideoBuf^[BufCounter]).Two; + LineBuf[BufCounter].Attributes := EnhancedVideoBuf[BufCounter].Attribute; Inc(BufCounter); end; { for } @@ -742,18 +418,14 @@ begin writeln('X2: ',x2); writeln('Y2: ',y2); } - if useunicodefunctions then - WriteConsoleOutputW(ConsoleOutHandle, @LineBuf, BufSize, BufCoord, WriteRegion) - else - WriteConsoleOutput(ConsoleOutHandle, @LineBuf, BufSize, BufCoord, WriteRegion); - - move(VideoBuf^,OldVideoBuf^,VideoBufSize); + WriteConsoleOutputW(ConsoleOutHandle, @LineBuf[0], BufSize, BufCoord, WriteRegion) end; end; Const SysVideoDriver : TVideoDriver = ( - InitDriver : @SysInitVideo; + InitDriver : nil; + InitEnhancedDriver: @SysInitVideo; DoneDriver : @SysDoneVideo; UpdateScreen : @SysUpdateScreen; ClearScreen : @SysClearScreen; @@ -763,8 +435,11 @@ Const SetCursorPos : @SysSetCursorPos; GetCursorType : @SysGetCursorType; SetCursorType : @SysSetCursorType; - GetCapabilities : @SysGetCapabilities - + GetCapabilities : @SysGetCapabilities; + GetActiveCodePage : Nil; + ActivateCodePage : Nil; + GetSupportedCodePageCount : Nil; + GetSupportedCodePage : Nil; ); procedure TargetEntry; diff --git a/packages/rtl-console/src/win/winevent.pp b/packages/rtl-console/src/win/winevent.pp index 09b7f049c7..c307c9734e 100644 --- a/packages/rtl-console/src/win/winevent.pp +++ b/packages/rtl-console/src/win/winevent.pp @@ -122,7 +122,7 @@ interface } if not(ExitEventHandleThread) then begin - if ReadConsoleInput(StdInputHandle,ir[0],irsize,dwRead) then + if ReadConsoleInputW(StdInputHandle,ir[0],irsize,dwRead) then begin i:=0; EnterCriticalSection(HandlerChanging); diff --git a/packages/rtl-console/src/win16/keyboard.pp b/packages/rtl-console/src/win16/keyboard.pp index f8f18ad3e5..b0f9e2177c 100644 --- a/packages/rtl-console/src/win16/keyboard.pp +++ b/packages/rtl-console/src/win16/keyboard.pp @@ -392,6 +392,8 @@ Const GetShiftState : @SysGetShiftState; TranslateKeyEvent : Nil; TranslateKeyEventUnicode : Nil; + GetEnhancedKeyEvent : Nil; + PollEnhancedKeyEvent : Nil; ); begin diff --git a/packages/rtl-console/src/win16/video.pp b/packages/rtl-console/src/win16/video.pp index 22d656fc8a..fde5347938 100644 --- a/packages/rtl-console/src/win16/video.pp +++ b/packages/rtl-console/src/win16/video.pp @@ -31,7 +31,7 @@ var implementation uses - WinProcs; + WinProcs, graphemebreakproperty, eastasianwidth, charset; {$I video.inc} @@ -255,17 +255,22 @@ end; const SysVideoDriver: TVideoDriver = ( - InitDriver: @SysInitVideo; - DoneDriver: @SysDoneVideo; - UpdateScreen: @SysUpdateScreen; - ClearScreen: nil; - SetVideoMode: @SysSetVideoMode; - GetVideoModeCount: nil; - GetVideoModeData: nil; - SetCursorPos: @SysSetCursorPos; - GetCursorType: @SysGetCursorType; - SetCursorType: @SysSetCursorType; - GetCapabilities: @SysGetCapabilities; + InitDriver : @SysInitVideo; + InitEnhancedDriver : nil; + DoneDriver : @SysDoneVideo; + UpdateScreen : @SysUpdateScreen; + ClearScreen : nil; + SetVideoMode : @SysSetVideoMode; + GetVideoModeCount : nil; + GetVideoModeData : nil; + SetCursorPos : @SysSetCursorPos; + GetCursorType : @SysGetCursorType; + SetCursorType : @SysSetCursorType; + GetCapabilities : @SysGetCapabilities; + GetActiveCodePage : nil; + ActivateCodePage : nil; + GetSupportedCodePageCount : nil; + GetSupportedCodePage : nil; ); begin diff --git a/packages/rtl-console/tests/bios/kbd_us.ods b/packages/rtl-console/tests/bios/kbd_us.ods Binary files differnew file mode 100644 index 0000000000..f11575c4d3 --- /dev/null +++ b/packages/rtl-console/tests/bios/kbd_us.ods diff --git a/packages/rtl-console/tests/bios/us101.bios.txt b/packages/rtl-console/tests/bios/us101.bios.txt new file mode 100644 index 0000000000..327ee6176f --- /dev/null +++ b/packages/rtl-console/tests/bios/us101.bios.txt @@ -0,0 +1,101 @@ +283 0 +15104 0 +15360 0 +15616 0 +15872 0 +16128 0 +16384 0 +16640 0 +16896 0 +17152 0 +17408 0 +34048 0 +34304 0 +-1 -1 +-1 -1 +-1 -1 +10592 0 +561 0 +818 0 +1075 0 +1332 0 +1589 0 +1846 0 +2103 0 +2360 0 +2617 0 +2864 0 +3117 0 +3389 0 +3592 0 +3849 0 +4209 0 +4471 0 +4709 0 +4978 0 +5236 0 +5497 0 +5749 0 +5993 0 +6255 0 +6512 0 +6747 0 +7005 0 +11100 0 +-1 -1 +7777 0 +8051 0 +8292 0 +8550 0 +8807 0 +9064 0 +9322 0 +9579 0 +9836 0 +10043 0 +10279 0 +7181 0 +-1 -1 +11386 0 +11640 0 +11875 0 +12150 0 +12386 0 +12654 0 +12909 0 +13100 0 +13358 0 +13615 0 +-1 -1 +-1 -1 +-1 -1 +14624 0 +-1 -1 +-1 -1 +21216 128 +18400 128 +18912 128 +21472 128 +20448 128 +20960 128 +18656 128 +19424 128 +20704 128 +19936 128 +-1 -1 +57391 128 +14122 128 +18989 128 +18176 128 +18432 128 +18688 128 +19200 128 +19456 128 +19712 128 +20224 128 +20480 128 +20736 128 +20992 0 +21248 0 +20011 0 +57357 0 diff --git a/packages/rtl-console/tests/bios/us101_capslock.bios.txt b/packages/rtl-console/tests/bios/us101_capslock.bios.txt new file mode 100644 index 0000000000..57641207a5 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_capslock.bios.txt @@ -0,0 +1,101 @@ +283 64 +15104 64 +15360 64 +15616 64 +15872 64 +16128 64 +16384 64 +16640 64 +16896 64 +17152 64 +17408 64 +34048 64 +34304 64 +-1 -1 +-1 -1 +-1 -1 +10592 64 +561 64 +818 64 +1075 64 +1332 64 +1589 64 +1846 64 +2103 64 +2360 64 +2617 64 +2864 64 +3117 64 +3389 64 +3592 64 +3849 64 +4177 64 +4439 64 +4677 64 +4946 64 +5204 64 +5465 64 +5717 64 +5961 64 +6223 64 +6480 64 +6747 64 +7005 64 +11100 64 +-1 -1 +7745 64 +8019 64 +8260 64 +8518 64 +8775 64 +9032 64 +9290 64 +9547 64 +9804 64 +10043 64 +10279 64 +7181 64 +-1 -1 +11354 64 +11608 64 +11843 64 +12118 64 +12354 64 +12622 64 +12877 64 +13100 64 +13358 64 +13615 64 +-1 -1 +-1 -1 +-1 -1 +14624 64 +-1 -1 +-1 -1 +21216 192 +18400 192 +18912 192 +21472 192 +20448 192 +20960 192 +18656 192 +19424 192 +20704 192 +19936 192 +-1 -1 +57391 192 +14122 192 +18989 192 +18176 192 +18432 192 +18688 192 +19200 192 +19456 192 +19712 192 +20224 192 +20480 192 +20736 192 +20992 64 +21248 64 +20011 64 +57357 64 diff --git a/packages/rtl-console/tests/bios/us101_capslock_lshift.bios.txt b/packages/rtl-console/tests/bios/us101_capslock_lshift.bios.txt new file mode 100644 index 0000000000..536e4c7350 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_capslock_lshift.bios.txt @@ -0,0 +1,101 @@ +283 66 +21504 66 +21760 66 +22016 66 +22272 66 +22528 66 +22784 66 +23040 66 +23296 66 +23552 66 +23808 66 +34560 66 +34816 66 +-1 -1 +-1 -1 +-1 -1 +10622 66 +545 66 +832 66 +1059 66 +1316 66 +1573 66 +1886 66 +2086 66 +2346 66 +2600 66 +2857 66 +3167 66 +3371 66 +3592 66 +3840 66 +4209 66 +4471 66 +4709 66 +4978 66 +5236 66 +5497 66 +5749 66 +5993 66 +6255 66 +6512 66 +6779 66 +7037 66 +11132 66 +-1 -1 +7777 66 +8051 66 +8292 66 +8550 66 +8807 66 +9064 66 +9322 66 +9579 66 +9836 66 +10042 66 +10274 66 +7181 66 +-1 -1 +11386 66 +11640 66 +11875 66 +12150 66 +12386 66 +12654 66 +12909 66 +13116 66 +13374 66 +13631 66 +-1 -1 +-1 -1 +-1 -1 +14624 66 +-1 -1 +-1 -1 +21216 194 +18400 194 +18912 194 +21472 194 +20448 194 +20960 194 +18656 194 +19424 194 +20704 194 +19936 194 +-1 -1 +57391 194 +14122 194 +18989 194 +18231 194 +18488 194 +18745 194 +19252 194 +19509 194 +19766 194 +20273 194 +20530 194 +20787 194 +21040 194 +21294 194 +20011 194 +57357 194 diff --git a/packages/rtl-console/tests/bios/us101_lalt.bios.txt b/packages/rtl-console/tests/bios/us101_lalt.bios.txt new file mode 100644 index 0000000000..6927ce8f14 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_lalt.bios.txt @@ -0,0 +1,101 @@ +256 520 +26624 520 +26880 520 +27136 520 +27392 520 +27648 520 +27904 520 +28160 520 +28416 520 +28672 520 +28928 520 +35584 520 +35840 520 +-1 -1 +-1 -1 +-1 -1 +10496 520 +30720 520 +30976 520 +31232 520 +31488 520 +31744 520 +32000 520 +32256 520 +32512 520 +32768 520 +33024 520 +33280 520 +33536 520 +3584 520 +42240 520 +4096 520 +4352 520 +4608 520 +4864 520 +5120 520 +5376 520 +5632 520 +5888 520 +6144 520 +6400 520 +6656 520 +6912 520 +11008 520 +-1 -1 +7680 520 +7936 520 +8192 520 +8448 520 +8704 520 +8960 520 +9216 520 +9472 520 +9728 520 +9984 520 +10240 520 +7168 520 +-1 -1 +11264 520 +11520 520 +11776 520 +12032 520 +12288 520 +12544 520 +12800 520 +13056 520 +13312 520 +13568 520 +-1 -1 +-1 -1 +-1 -1 +14624 520 +-1 -1 +-1 -1 +41472 520 +38656 520 +39168 520 +41728 520 +40704 520 +41216 520 +38912 520 +39680 520 +40960 520 +40192 520 +-1 -1 +41984 520 +14080 520 +18944 520 +7 0 +8 0 +9 0 +4 0 +5 0 +6 0 +1 0 +2 0 +3 0 +-1 -1 +-1 -1 +19968 520 +42496 520 diff --git a/packages/rtl-console/tests/bios/us101_lalt_lctrl.bios.txt b/packages/rtl-console/tests/bios/us101_lalt_lctrl.bios.txt new file mode 100644 index 0000000000..5fd4251e92 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_lalt_lctrl.bios.txt @@ -0,0 +1,101 @@ +256 780 +26624 780 +26880 780 +27136 780 +27392 780 +27648 780 +27904 780 +28160 780 +28416 780 +28672 780 +28928 780 +35584 780 +35840 780 +-1 -1 +-1 -1 +0 4876 +10496 780 +30720 780 +30976 780 +31232 780 +31488 780 +31744 780 +32000 780 +32256 780 +32512 780 +32768 780 +33024 780 +33280 780 +33536 780 +3584 780 +42240 780 +4096 780 +4352 780 +4608 780 +4864 780 +5120 780 +5376 780 +5632 780 +5888 780 +6144 780 +6400 780 +6656 780 +6912 780 +11008 780 +-1 -1 +7680 780 +7936 780 +8192 780 +8448 780 +8704 780 +8960 780 +9216 780 +9472 780 +9728 780 +9984 780 +10240 780 +7168 780 +-1 -1 +11264 780 +11520 780 +11776 780 +12032 780 +12288 780 +12544 780 +12800 780 +13056 780 +13312 780 +13568 780 +-1 -1 +-1 -1 +-1 -1 +14624 780 +-1 -1 +-1 -1 +41472 780 +38656 780 +39168 780 +-1 -1 +40704 780 +41216 780 +38912 780 +39680 780 +40960 780 +40192 780 +-1 -1 +41984 812 +14080 812 +18944 812 +7 292 +8 292 +9 292 +4 292 +5 292 +6 32 +1 292 +2 292 +3 292 +-1 -1 +-1 -1 +19968 812 +42496 812 diff --git a/packages/rtl-console/tests/bios/us101_lalt_lctrl_lshift.bios.txt b/packages/rtl-console/tests/bios/us101_lalt_lctrl_lshift.bios.txt new file mode 100644 index 0000000000..2f062ba948 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_lalt_lctrl_lshift.bios.txt @@ -0,0 +1,101 @@ +256 782 +26624 782 +26880 782 +27136 782 +27392 782 +27648 782 +27904 782 +28160 782 +28416 782 +28672 782 +28928 782 +35584 782 +35840 782 +-1 -1 +-1 -1 +0 4878 +10496 782 +30720 782 +30976 782 +31232 782 +31488 782 +31744 782 +32000 782 +32256 782 +32512 782 +32768 782 +33024 782 +33280 782 +33536 782 +3584 782 +42240 782 +4096 782 +4352 782 +4608 782 +4864 782 +5120 782 +5376 782 +5632 782 +5888 782 +6144 782 +6400 782 +6656 782 +6912 782 +11008 782 +-1 -1 +7680 782 +7936 782 +8192 782 +8448 782 +8704 782 +8960 782 +9216 782 +9472 782 +9728 782 +9984 782 +10240 782 +7168 782 +-1 -1 +11264 782 +11520 782 +11776 782 +12032 782 +12288 782 +12544 782 +12800 782 +13056 782 +13312 782 +13568 782 +-1 -1 +-1 -1 +-1 -1 +14624 782 +-1 -1 +-1 -1 +41472 782 +38656 782 +39168 782 +-1 -1 +40704 782 +41216 782 +38912 782 +39680 782 +40960 782 +40192 782 +-1 -1 +41984 782 +14080 782 +18944 782 +7 0 +8 0 +9 0 +4 260 +5 0 +6 0 +1 0 +2 0 +3 0 +-1 -1 +-1 -1 +19968 782 +42496 782 diff --git a/packages/rtl-console/tests/bios/us101_lalt_lshift.bios.txt b/packages/rtl-console/tests/bios/us101_lalt_lshift.bios.txt new file mode 100644 index 0000000000..d25edc5c44 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_lalt_lshift.bios.txt @@ -0,0 +1,101 @@ +256 522 +26624 522 +26880 522 +27136 522 +27392 522 +27648 522 +27904 522 +28160 522 +28416 522 +28672 522 +28928 522 +35584 522 +35840 522 +-1 -1 +-1 -1 +-1 -1 +10496 522 +30720 522 +30976 522 +31232 522 +31488 522 +31744 522 +32000 522 +32256 522 +32512 522 +32768 522 +33024 522 +33280 522 +33536 522 +3584 522 +42240 522 +4096 522 +4352 522 +4608 522 +4864 522 +5120 522 +5376 522 +5632 522 +5888 522 +6144 522 +6400 522 +6656 522 +6912 522 +11008 522 +-1 -1 +7680 522 +7936 522 +8192 522 +8448 522 +8704 522 +8960 522 +9216 522 +9472 522 +9728 522 +9984 522 +10240 522 +7168 522 +-1 -1 +11264 522 +11520 522 +11776 522 +12032 522 +12288 522 +12544 522 +12800 522 +13056 522 +13312 522 +13568 522 +-1 -1 +-1 -1 +-1 -1 +14624 522 +-1 -1 +-1 -1 +41472 522 +38656 522 +39168 522 +41728 522 +40704 522 +41216 522 +38912 522 +39680 522 +40960 522 +40192 522 +-1 -1 +41984 522 +14080 522 +18944 522 +7 0 +8 0 +9 0 +4 0 +5 0 +6 0 +1 0 +2 0 +3 0 +-1 -1 +-1 -1 +19968 522 +42496 522 diff --git a/packages/rtl-console/tests/bios/us101_lctrl.bios.txt b/packages/rtl-console/tests/bios/us101_lctrl.bios.txt new file mode 100644 index 0000000000..a4a51e8baa --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_lctrl.bios.txt @@ -0,0 +1,101 @@ +283 260 +24064 260 +24320 260 +24576 260 +24832 260 +25088 260 +25344 260 +25600 260 +25856 260 +26112 260 +26368 260 +35072 260 +35328 260 +29184 260 +-1 -1 +0 4356 +-1 -1 +-1 -1 +768 260 +-1 -1 +-1 -1 +-1 -1 +1822 260 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +3103 260 +-1 -1 +3711 260 +37888 260 +4113 260 +4375 260 +4613 260 +4882 260 +5140 260 +5401 260 +5653 260 +5897 260 +6159 260 +6416 260 +6683 260 +6941 260 +11036 260 +-1 -1 +7681 260 +7955 260 +8196 260 +8454 260 +8711 260 +8968 260 +9226 260 +9483 260 +9740 260 +-1 -1 +-1 -1 +7178 260 +-1 -1 +11290 260 +11544 260 +11779 260 +12054 260 +12290 260 +12558 260 +12813 260 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +14624 260 +-1 -1 +-1 -1 +37600 260 +30688 260 +34016 260 +37856 260 +30176 260 +30432 260 +36320 260 +29664 260 +37344 260 +29920 260 +-1 -1 +38144 260 +38400 260 +36352 260 +30464 260 +36096 260 +33792 260 +29440 260 +36608 260 +29696 260 +29952 260 +37120 260 +30208 260 +37376 260 +37632 260 +36864 260 +57354 260 diff --git a/packages/rtl-console/tests/bios/us101_lctrl_lshift.bios.txt b/packages/rtl-console/tests/bios/us101_lctrl_lshift.bios.txt new file mode 100644 index 0000000000..ea50bb2ac7 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_lctrl_lshift.bios.txt @@ -0,0 +1,101 @@ +283 262 +24064 262 +24320 262 +24576 262 +24832 262 +25088 262 +25344 262 +25600 262 +25856 262 +26112 262 +26368 262 +35072 262 +35328 262 +29184 262 +-1 -1 +0 4358 +-1 -1 +-1 -1 +768 262 +-1 -1 +-1 -1 +-1 -1 +1822 262 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +3103 262 +-1 -1 +3711 262 +37888 262 +4113 262 +4375 262 +4613 262 +4882 262 +5140 262 +5401 262 +5653 262 +5897 262 +6159 262 +6416 262 +6683 262 +6941 262 +11036 262 +-1 -1 +7681 262 +7955 262 +8196 262 +8454 262 +8711 262 +8968 262 +9226 262 +9483 262 +9740 262 +-1 -1 +-1 -1 +7178 262 +-1 -1 +11290 262 +11544 262 +11779 262 +12054 262 +12290 262 +12558 262 +12813 262 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +14624 262 +-1 -1 +-1 -1 +37600 262 +30688 262 +34016 262 +37856 262 +30176 262 +30432 262 +36320 262 +29664 262 +37344 262 +29920 262 +-1 -1 +38144 262 +38400 262 +36352 262 +30464 262 +36096 262 +33792 262 +29440 262 +36608 262 +29696 262 +29952 262 +37120 262 +30208 262 +37376 262 +37632 262 +36864 262 +57354 262 diff --git a/packages/rtl-console/tests/bios/us101_lshift.bios.txt b/packages/rtl-console/tests/bios/us101_lshift.bios.txt new file mode 100644 index 0000000000..87087a7cdb --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_lshift.bios.txt @@ -0,0 +1,101 @@ +283 2 +21504 2 +21760 2 +22016 2 +22272 2 +22528 2 +22784 2 +23040 2 +23296 2 +23552 2 +23808 2 +34560 2 +34816 2 +-1 -1 +-1 -1 +-1 -1 +10622 2 +545 2 +832 2 +1059 2 +1316 2 +1573 2 +1886 2 +2086 2 +2346 2 +2600 2 +2857 2 +3167 2 +3371 2 +3592 2 +3840 2 +4177 2 +4439 2 +4677 2 +4946 2 +5204 2 +5465 2 +5717 2 +5961 2 +6223 2 +6480 2 +6779 2 +7037 2 +11132 2 +-1 -1 +7745 2 +8019 2 +8260 2 +8518 2 +8775 2 +9032 2 +9290 2 +9547 2 +9804 2 +10042 2 +10274 2 +7181 2 +-1 -1 +11354 2 +11608 2 +11843 2 +12118 2 +12354 2 +12622 2 +12877 2 +13116 2 +13374 2 +13631 2 +-1 -1 +-1 -1 +-1 -1 +14624 2 +-1 -1 +-1 -1 +21216 130 +18400 130 +18912 130 +21472 130 +20448 130 +20960 130 +18656 130 +19424 130 +20704 130 +19936 130 +-1 -1 +57391 130 +14122 130 +18989 130 +18231 130 +18488 130 +18745 130 +19252 130 +19509 130 +19766 130 +20273 130 +20530 130 +20787 130 +21040 130 +21294 130 +20011 130 +57357 130 diff --git a/packages/rtl-console/tests/bios/us101_numlock.bios.txt b/packages/rtl-console/tests/bios/us101_numlock.bios.txt new file mode 100644 index 0000000000..78849c73d2 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_numlock.bios.txt @@ -0,0 +1,101 @@ +283 32 +15104 32 +15360 32 +15616 32 +15872 32 +16128 32 +16384 32 +16640 32 +16896 32 +17152 32 +17408 32 +34048 32 +34304 32 +-1 -1 +-1 -1 +-1 -1 +10592 32 +561 32 +818 32 +1075 32 +1332 32 +1589 32 +1846 32 +2103 32 +2360 32 +2617 32 +2864 32 +3117 32 +3389 32 +3592 32 +3849 32 +4209 32 +4471 32 +4709 32 +4978 32 +5236 32 +5497 32 +5749 32 +5993 32 +6255 32 +6512 32 +6747 32 +7005 32 +11100 32 +-1 -1 +7777 32 +8051 32 +8292 32 +8550 32 +8807 32 +9064 32 +9322 32 +9579 32 +9836 32 +10043 32 +10279 32 +7181 32 +-1 -1 +11386 32 +11640 32 +11875 32 +12150 32 +12386 32 +12654 32 +12909 32 +13100 32 +13358 32 +13615 32 +-1 -1 +-1 -1 +-1 -1 +14624 32 +-1 -1 +-1 -1 +21216 160 +18400 160 +18912 160 +21472 160 +20448 160 +20960 160 +18656 160 +19424 160 +20704 160 +19936 160 +-1 -1 +57391 160 +14122 160 +18989 160 +18231 160 +18488 160 +18745 160 +19252 160 +19509 160 +19766 160 +20273 160 +20530 160 +20787 160 +21040 160 +21294 160 +20011 160 +57357 160 diff --git a/packages/rtl-console/tests/bios/us101_numlock_lshift.bios.txt b/packages/rtl-console/tests/bios/us101_numlock_lshift.bios.txt new file mode 100644 index 0000000000..c7602b13b0 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_numlock_lshift.bios.txt @@ -0,0 +1,101 @@ +283 34 +21504 34 +21760 34 +22016 34 +22272 34 +22528 34 +22784 34 +23040 34 +23296 34 +23552 34 +23808 34 +34560 34 +34816 34 +-1 -1 +-1 -1 +-1 -1 +10622 34 +545 34 +832 34 +1059 34 +1316 34 +1573 34 +1886 34 +2086 34 +2346 34 +2600 34 +2857 34 +3167 34 +3371 34 +3592 34 +3840 34 +4177 34 +4439 34 +4677 34 +4946 34 +5204 34 +5465 34 +5717 34 +5961 34 +6223 34 +6480 34 +6779 34 +7037 34 +11132 34 +-1 -1 +7745 34 +8019 34 +8260 34 +8518 34 +8775 34 +9032 34 +9290 34 +9547 34 +9804 34 +10042 34 +10274 34 +7181 34 +-1 -1 +11354 34 +11608 34 +11843 34 +12118 34 +12354 34 +12622 34 +12877 34 +13116 34 +13374 34 +13631 34 +-1 -1 +-1 -1 +-1 -1 +14624 34 +-1 -1 +-1 -1 +21216 162 +18400 162 +18912 162 +21472 162 +20448 162 +20960 162 +18656 162 +19424 162 +20704 162 +19936 162 +-1 -1 +57391 162 +14122 162 +18989 162 +18176 162 +18432 162 +18688 162 +19200 162 +19456 162 +19712 162 +20224 162 +20480 162 +20736 162 +20992 34 +21248 34 +20011 34 +57357 34 diff --git a/packages/rtl-console/tests/bios/us101_ralt.bios.txt b/packages/rtl-console/tests/bios/us101_ralt.bios.txt new file mode 100644 index 0000000000..e09c9c7c69 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_ralt.bios.txt @@ -0,0 +1,101 @@ +256 2056 +26624 2056 +26880 2056 +27136 2056 +27392 2056 +27648 2056 +27904 2056 +28160 2056 +28416 2056 +28672 2056 +28928 2056 +35584 2056 +35840 2056 +-1 -1 +-1 -1 +-1 -1 +10496 2056 +30720 2056 +30976 2056 +31232 2056 +31488 2056 +31744 2056 +32000 2056 +32256 2056 +32512 2056 +32768 2056 +33024 2056 +33280 2056 +33536 2056 +3584 2056 +42240 2056 +4096 2056 +4352 2056 +4608 2056 +4864 2056 +5120 2056 +5376 2056 +5632 2056 +5888 2056 +6144 2056 +6400 2056 +6656 2056 +6912 2056 +11008 2056 +-1 -1 +7680 2056 +7936 2056 +8192 2056 +8448 2056 +8704 2056 +8960 2056 +9216 2056 +9472 2056 +9728 2056 +9984 2056 +10240 2056 +7168 2056 +-1 -1 +11264 2056 +11520 2056 +11776 2056 +12032 2056 +12288 2056 +12544 2056 +12800 2056 +13056 2056 +13312 2056 +13568 2056 +-1 -1 +-1 -1 +-1 -1 +14624 2056 +-1 -1 +-1 -1 +41472 2056 +38656 2056 +39168 2056 +41728 2056 +40704 2056 +41216 2056 +38912 2056 +39680 2056 +40960 2056 +40192 2056 +-1 -1 +41984 2056 +14080 2056 +18944 2056 +7 0 +8 0 +9 0 +4 0 +5 0 +6 0 +1 0 +2 0 +3 0 +-1 -1 +-1 -1 +19968 2056 +42496 2056 diff --git a/packages/rtl-console/tests/bios/us101_rctrl.bios.txt b/packages/rtl-console/tests/bios/us101_rctrl.bios.txt new file mode 100644 index 0000000000..b287fa9880 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_rctrl.bios.txt @@ -0,0 +1,101 @@ +283 1028 +24064 1028 +24320 1028 +24576 1028 +24832 1028 +25088 1028 +25344 1028 +25600 1028 +25856 1028 +26112 1028 +26368 1028 +35072 1028 +35328 1028 +29184 1028 +-1 -1 +0 5124 +-1 -1 +-1 -1 +768 1028 +-1 -1 +-1 -1 +-1 -1 +1822 1028 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +3103 1028 +-1 -1 +3711 1028 +37888 1028 +4113 1028 +4375 1028 +4613 1028 +4882 1028 +5140 1028 +5401 1028 +5653 1028 +5897 1028 +6159 1028 +6416 1028 +6683 1028 +6941 1028 +11036 1028 +-1 -1 +7681 1028 +7955 1028 +8196 1028 +8454 1028 +8711 1028 +8968 1028 +9226 1028 +9483 1028 +9740 1028 +-1 -1 +-1 -1 +7178 1028 +-1 -1 +11290 1028 +11544 1028 +11779 1028 +12054 1028 +12290 1028 +12558 1028 +12813 1028 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +14624 1028 +-1 -1 +-1 -1 +37600 1028 +30688 1028 +34016 1028 +37856 1028 +30176 1028 +30432 1028 +36320 1028 +29664 1028 +37344 1028 +29920 1028 +-1 -1 +38144 1028 +38400 1028 +36352 1028 +30464 1028 +36096 1028 +33792 1028 +29440 1028 +36608 1028 +29696 1028 +29952 1028 +37120 1028 +30208 1028 +37376 1028 +37632 1028 +36864 1028 +57354 1028 diff --git a/packages/rtl-console/tests/bios/us101_rshift.bios.txt b/packages/rtl-console/tests/bios/us101_rshift.bios.txt new file mode 100644 index 0000000000..44412c3bf9 --- /dev/null +++ b/packages/rtl-console/tests/bios/us101_rshift.bios.txt @@ -0,0 +1,101 @@ +283 1 +21504 1 +21760 1 +22016 1 +22272 1 +22528 1 +22784 1 +23040 1 +23296 1 +23552 1 +23808 1 +34560 1 +34816 1 +-1 -1 +-1 -1 +-1 -1 +10622 1 +545 1 +832 1 +1059 1 +1316 1 +1573 1 +1886 1 +2086 1 +2346 1 +2600 1 +2857 1 +3167 1 +3371 1 +3592 1 +3840 1 +4177 1 +4439 1 +4677 1 +4946 1 +5204 1 +5465 1 +5717 1 +5961 1 +6223 1 +6480 1 +6779 1 +7037 1 +11132 1 +-1 -1 +7745 1 +8019 1 +8260 1 +8518 1 +8775 1 +9032 1 +9290 1 +9547 1 +9804 1 +10042 1 +10274 1 +7181 1 +-1 -1 +11354 1 +11608 1 +11843 1 +12118 1 +12354 1 +12622 1 +12877 1 +13116 1 +13374 1 +13631 1 +-1 -1 +-1 -1 +-1 -1 +14624 1 +-1 -1 +-1 -1 +21216 129 +18400 129 +18912 129 +21472 129 +20448 129 +20960 129 +18656 129 +19424 129 +20704 129 +19936 129 +-1 -1 +57391 129 +14122 129 +18989 129 +18231 129 +18488 129 +18745 129 +19252 129 +19509 129 +19766 129 +20273 129 +20530 129 +20787 129 +21040 129 +21294 129 +20011 129 +57357 129 diff --git a/packages/rtl-console/tests/fpc-3.0.4-win64/us101-bgph1-cp866.dmp b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-bgph1-cp866.dmp new file mode 100644 index 0000000000..e2485d148e --- /dev/null +++ b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-bgph1-cp866.dmp @@ -0,0 +1,101 @@ +50331931 283 +50346752 33619713 +50347008 33619714 +50347264 33619715 +50347520 33619716 +50347776 33619717 +50348032 33619718 +50348288 33619719 +50348544 33619720 +50348800 33619721 +50349056 33619722 +50365696 33619723 +50365952 33619724 +-1 -1 +-1 -1 +-1 -1 +50342375 10727 +50332209 561 +50332466 818 +50332723 1075 +50332980 1332 +50333237 1589 +50333494 1846 +50333751 2103 +50334008 2360 +50334265 2617 +50334512 2864 +50334765 3117 +50335037 3389 +50335240 3592 +50335497 3849 +50335983 4335 +50336162 4514 +50336421 4773 +50336736 5088 +50336994 5346 +50337258 5610 +50337507 5859 +50337704 6056 +50337966 6318 +50338223 6575 +50338536 6888 +50338793 7145 +50342894 11246 +-1 -1 +50339488 7840 +50339809 8161 +50340004 8356 +50340324 8676 +50340515 8867 +50340837 9189 +50341033 9385 +50341290 9642 +50341547 9899 +50341691 10043 +50341927 10279 +50338829 7181 +-1 -1 +50343079 11431 +50343404 11756 +50343654 12006 +50343846 12198 +50344097 12449 +50344365 12717 +50344620 12972 +50344748 13100 +50345006 13358 +50345263 13615 +-1 -1 +-1 -1 +-1 -1 +50346272 14624 +-1 -1 +-1 -1 +50352640 33619753 +50349824 33619744 +50350336 33619746 +50352896 33619754 +50351872 33619750 +50352384 33619752 +50350080 33619745 +50350848 33619747 +50352128 33619751 +50351360 33619749 +-1 -1 +50345263 13615 +50345770 14122 +50350637 18989 +50349824 33619744 +50350080 33619745 +50350336 33619746 +50350848 33619747 +50351104 50351104 +50351360 33619749 +50351872 33619750 +50352128 33619751 +50352384 33619752 +50352640 33619753 +50352896 33619754 +50351659 20011 +50338829 7181 diff --git a/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-lalt.dmp b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-lalt.dmp new file mode 100644 index 0000000000..68572ced18 --- /dev/null +++ b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-lalt.dmp @@ -0,0 +1,101 @@ +-1 -1 +50882560 34144001 +50882816 34144002 +50883072 34144003 +50883328 34144004 +50883584 34144005 +50883840 34144006 +50884096 34144007 +50884352 34144008 +50884608 34144009 +50884864 34144010 +50891520 34144011 +50891776 34144012 +-1 -1 +-1 -1 +-1 -1 +50866432 50866432 +50886656 50886656 +50886912 50886912 +50887168 50887168 +50887424 50887424 +50887680 50887680 +50887936 50887936 +50888192 50888192 +50888448 50888448 +50888704 50888704 +50888960 50888960 +50889216 50889216 +50859264 50859264 +50859520 50859520 +-1 -1 +50860032 50860032 +50860288 50860288 +50860544 50860544 +50860800 50860800 +50861056 50861056 +50861312 50861312 +50861568 50861568 +50861824 50861824 +50862080 50862080 +50862336 50862336 +50862592 50862592 +50862848 50862848 +50866944 50866944 +-1 -1 +50863616 50863616 +50863872 50863872 +50864128 50864128 +50864384 50864384 +50864640 50864640 +50864896 50864896 +50865152 50865152 +50865408 50865408 +50865664 50865664 +50865920 50865920 +50866176 50866176 +-1 -1 +-1 -1 +50867200 50867200 +50867456 50867456 +50867712 50867712 +50867968 50867968 +50868224 50868224 +50868480 50868480 +50868736 50868736 +50868992 50868992 +50869248 50869248 +50869504 50869504 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +50897408 34144041 +50894592 34144032 +50895104 34144034 +50897664 34144042 +50896640 34144038 +50897152 34144040 +50894848 34144033 +50895616 34144035 +50896896 34144039 +50896128 34144037 +-1 -1 +50869504 50869504 +50870016 50870016 +50874880 50874880 +50331655 7 +50331656 8 +50331657 9 +50331652 4 +50331653 5 +50331654 6 +50331649 1 +50331650 2 +50331651 3 +50331648 50331648 +50897664 34144042 +50875904 50875904 +-1 -1 diff --git a/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-lctrl.dmp b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-lctrl.dmp new file mode 100644 index 0000000000..9292c1fb7b --- /dev/null +++ b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-lctrl.dmp @@ -0,0 +1,101 @@ +-1 -1 +50617856 33881857 +50618112 33881858 +50618368 33881859 +50618624 33881860 +50618880 33881861 +50619136 33881862 +50619392 33881863 +50619648 33881864 +50619904 33881865 +50620160 33881866 +50628864 33881867 +50629120 33881868 +-1 -1 +-1 -1 +-1 -1 +50604288 50604288 +50594304 50594304 +50594560 50594560 +50594816 50594816 +50595072 50595072 +50595328 50595328 +50595584 50595584 +50595840 50595840 +50596096 50596096 +50596352 50596352 +50596608 50596608 +50596864 50596864 +50597120 50597120 +50597503 265855 +50631680 50631680 +50597905 266257 +50598167 266519 +50598405 266757 +50598674 267026 +50598932 267284 +50599193 267545 +50599445 267797 +50599689 268041 +50599951 268303 +50600208 268560 +50600475 268827 +50600733 269085 +50604828 273180 +-1 -1 +50601473 269825 +50601747 270099 +50601988 270340 +50602246 270598 +50602503 270855 +50602760 271112 +50603018 271370 +50603275 271627 +50603532 271884 +50603776 50603776 +50604032 50604032 +50600970 269322 +-1 -1 +50605082 273434 +50605336 273688 +-1 -1 +50605846 274198 +50606082 274434 +50606350 274702 +50606605 274957 +50606848 50606848 +50607104 50607104 +50607360 50607360 +-1 -1 +-1 -1 +-1 -1 +50608416 276768 +-1 -1 +-1 -1 +50631168 33881897 +50624256 33881888 +50627584 33881890 +50631424 33881898 +50623744 33881894 +50624000 33881896 +50629888 33881889 +50623232 33881891 +50630912 33881895 +50623488 33881893 +-1 -1 +50607360 50607360 +50607872 50607872 +50630144 50630144 +50624256 33881888 +50629888 33881889 +50627584 33881890 +50623232 33881891 +50613248 50613248 +50623488 33881893 +50623744 33881894 +50630912 33881895 +50624000 33881896 +50631168 33881897 +50631424 33881898 +50630656 50630656 +50600970 269322 diff --git a/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-lshift.dmp b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-lshift.dmp new file mode 100644 index 0000000000..98391a98e2 --- /dev/null +++ b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-lshift.dmp @@ -0,0 +1,101 @@ +50528539 196891 +50549760 33816321 +50550016 33816322 +50550272 33816323 +50550528 33816324 +50550784 33816325 +50551040 33816326 +50551296 33816327 +50551552 33816328 +50551808 33816329 +50552064 33816330 +50562816 33816331 +50563072 33816332 +-1 -1 +-1 -1 +-1 -1 +50538878 207230 +50528801 197153 +50529088 197440 +50529315 197667 +50529572 197924 +50529829 198181 +50530142 198494 +50530342 198694 +50530602 198954 +50530856 199208 +50531113 199465 +50531423 199775 +50531627 199979 +50530560 50530560 +50532096 50532096 +50532433 200785 +50532695 201047 +50532933 201285 +50533202 201554 +50533460 201812 +50533721 202073 +50533973 202325 +50534217 202569 +50534479 202831 +50534736 203088 +50535035 203387 +50535293 203645 +50539388 207740 +-1 -1 +50536001 204353 +50536275 204627 +50536516 204868 +50536774 205126 +50537031 205383 +50537288 205640 +50537546 205898 +50537803 206155 +50538060 206412 +50538298 206650 +50538530 206882 +50535437 203789 +-1 -1 +50539610 207962 +50539864 208216 +50540099 208451 +50540374 208726 +50540610 208962 +50540878 209230 +50541133 209485 +50541372 209724 +50541630 209982 +50541887 210239 +-1 -1 +-1 -1 +-1 -1 +50542880 211232 +-1 -1 +-1 -1 +50549248 33816361 +50546432 33816352 +50546944 33816354 +50549504 33816362 +50548480 33816358 +50548992 33816360 +50546688 33816353 +50547456 33816355 +50548736 33816359 +50547968 33816357 +-1 -1 +50541871 210223 +50542378 210730 +50547245 215597 +50546432 33816352 +50546688 33816353 +50546944 33816354 +50547456 33816355 +50547712 50547712 +50547968 33816357 +50548480 33816358 +50548736 33816359 +50548992 33816360 +50549248 33816361 +50549504 33816362 +50548267 216619 +50535437 203789 diff --git a/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-numlock.dmp b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-numlock.dmp new file mode 100644 index 0000000000..a58b60f14a --- /dev/null +++ b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-numlock.dmp @@ -0,0 +1,101 @@ +50331931 283 +50346752 33619713 +50347008 33619714 +50347264 33619715 +50347520 33619716 +50347776 33619717 +50348032 33619718 +50348288 33619719 +50348544 33619720 +50348800 33619721 +50349056 33619722 +50365696 33619723 +50365952 33619724 +-1 -1 +-1 -1 +-1 -1 +50342240 10592 +50332209 561 +50332466 818 +50332723 1075 +50332980 1332 +50333237 1589 +50333494 1846 +50333751 2103 +50334008 2360 +50334265 2617 +50334512 2864 +50334765 3117 +50335037 3389 +50335240 3592 +50335497 3849 +50335857 4209 +50336119 4471 +50336357 4709 +50336626 4978 +50336884 5236 +50337145 5497 +50337397 5749 +50337641 5993 +50337903 6255 +50338160 6512 +50338395 6747 +50338653 7005 +50342748 11100 +-1 -1 +50339425 7777 +50339699 8051 +50339940 8292 +50340198 8550 +50340455 8807 +50340712 9064 +50340970 9322 +50341227 9579 +50341484 9836 +50341691 10043 +50341927 10279 +50338829 7181 +-1 -1 +50343034 11386 +50343288 11640 +50343523 11875 +50343798 12150 +50344034 12386 +50344302 12654 +50344557 12909 +50344748 13100 +50345006 13358 +50345263 13615 +-1 -1 +-1 -1 +-1 -1 +50346272 14624 +-1 -1 +-1 -1 +50352640 33619753 +50349824 33619744 +50350336 33619746 +50352896 33619754 +50351872 33619750 +50352384 33619752 +50350080 33619745 +50350848 33619747 +50352128 33619751 +50351360 33619749 +-1 -1 +50345263 13615 +50345770 14122 +50350637 18989 +50333751 2103 +50334008 2360 +50334265 2617 +50332980 1332 +50333237 1589 +50333494 1846 +50332209 561 +50332466 818 +50332723 1075 +50334512 2864 +50352942 21294 +50351659 20011 +50338829 7181 diff --git a/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-ralt.dmp b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-ralt.dmp new file mode 100644 index 0000000000..68572ced18 --- /dev/null +++ b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-ralt.dmp @@ -0,0 +1,101 @@ +-1 -1 +50882560 34144001 +50882816 34144002 +50883072 34144003 +50883328 34144004 +50883584 34144005 +50883840 34144006 +50884096 34144007 +50884352 34144008 +50884608 34144009 +50884864 34144010 +50891520 34144011 +50891776 34144012 +-1 -1 +-1 -1 +-1 -1 +50866432 50866432 +50886656 50886656 +50886912 50886912 +50887168 50887168 +50887424 50887424 +50887680 50887680 +50887936 50887936 +50888192 50888192 +50888448 50888448 +50888704 50888704 +50888960 50888960 +50889216 50889216 +50859264 50859264 +50859520 50859520 +-1 -1 +50860032 50860032 +50860288 50860288 +50860544 50860544 +50860800 50860800 +50861056 50861056 +50861312 50861312 +50861568 50861568 +50861824 50861824 +50862080 50862080 +50862336 50862336 +50862592 50862592 +50862848 50862848 +50866944 50866944 +-1 -1 +50863616 50863616 +50863872 50863872 +50864128 50864128 +50864384 50864384 +50864640 50864640 +50864896 50864896 +50865152 50865152 +50865408 50865408 +50865664 50865664 +50865920 50865920 +50866176 50866176 +-1 -1 +-1 -1 +50867200 50867200 +50867456 50867456 +50867712 50867712 +50867968 50867968 +50868224 50868224 +50868480 50868480 +50868736 50868736 +50868992 50868992 +50869248 50869248 +50869504 50869504 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +-1 -1 +50897408 34144041 +50894592 34144032 +50895104 34144034 +50897664 34144042 +50896640 34144038 +50897152 34144040 +50894848 34144033 +50895616 34144035 +50896896 34144039 +50896128 34144037 +-1 -1 +50869504 50869504 +50870016 50870016 +50874880 50874880 +50331655 7 +50331656 8 +50331657 9 +50331652 4 +50331653 5 +50331654 6 +50331649 1 +50331650 2 +50331651 3 +50331648 50331648 +50897664 34144042 +50875904 50875904 +-1 -1 diff --git a/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-rctrl.dmp b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-rctrl.dmp new file mode 100644 index 0000000000..9292c1fb7b --- /dev/null +++ b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-rctrl.dmp @@ -0,0 +1,101 @@ +-1 -1 +50617856 33881857 +50618112 33881858 +50618368 33881859 +50618624 33881860 +50618880 33881861 +50619136 33881862 +50619392 33881863 +50619648 33881864 +50619904 33881865 +50620160 33881866 +50628864 33881867 +50629120 33881868 +-1 -1 +-1 -1 +-1 -1 +50604288 50604288 +50594304 50594304 +50594560 50594560 +50594816 50594816 +50595072 50595072 +50595328 50595328 +50595584 50595584 +50595840 50595840 +50596096 50596096 +50596352 50596352 +50596608 50596608 +50596864 50596864 +50597120 50597120 +50597503 265855 +50631680 50631680 +50597905 266257 +50598167 266519 +50598405 266757 +50598674 267026 +50598932 267284 +50599193 267545 +50599445 267797 +50599689 268041 +50599951 268303 +50600208 268560 +50600475 268827 +50600733 269085 +50604828 273180 +-1 -1 +50601473 269825 +50601747 270099 +50601988 270340 +50602246 270598 +50602503 270855 +50602760 271112 +50603018 271370 +50603275 271627 +50603532 271884 +50603776 50603776 +50604032 50604032 +50600970 269322 +-1 -1 +50605082 273434 +50605336 273688 +-1 -1 +50605846 274198 +50606082 274434 +50606350 274702 +50606605 274957 +50606848 50606848 +50607104 50607104 +50607360 50607360 +-1 -1 +-1 -1 +-1 -1 +50608416 276768 +-1 -1 +-1 -1 +50631168 33881897 +50624256 33881888 +50627584 33881890 +50631424 33881898 +50623744 33881894 +50624000 33881896 +50629888 33881889 +50623232 33881891 +50630912 33881895 +50623488 33881893 +-1 -1 +50607360 50607360 +50607872 50607872 +50630144 50630144 +50624256 33881888 +50629888 33881889 +50627584 33881890 +50623232 33881891 +50613248 50613248 +50623488 33881893 +50623744 33881894 +50630912 33881895 +50624000 33881896 +50631168 33881897 +50631424 33881898 +50630656 50630656 +50600970 269322 diff --git a/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-rshift.dmp b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-rshift.dmp new file mode 100644 index 0000000000..98391a98e2 --- /dev/null +++ b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us-rshift.dmp @@ -0,0 +1,101 @@ +50528539 196891 +50549760 33816321 +50550016 33816322 +50550272 33816323 +50550528 33816324 +50550784 33816325 +50551040 33816326 +50551296 33816327 +50551552 33816328 +50551808 33816329 +50552064 33816330 +50562816 33816331 +50563072 33816332 +-1 -1 +-1 -1 +-1 -1 +50538878 207230 +50528801 197153 +50529088 197440 +50529315 197667 +50529572 197924 +50529829 198181 +50530142 198494 +50530342 198694 +50530602 198954 +50530856 199208 +50531113 199465 +50531423 199775 +50531627 199979 +50530560 50530560 +50532096 50532096 +50532433 200785 +50532695 201047 +50532933 201285 +50533202 201554 +50533460 201812 +50533721 202073 +50533973 202325 +50534217 202569 +50534479 202831 +50534736 203088 +50535035 203387 +50535293 203645 +50539388 207740 +-1 -1 +50536001 204353 +50536275 204627 +50536516 204868 +50536774 205126 +50537031 205383 +50537288 205640 +50537546 205898 +50537803 206155 +50538060 206412 +50538298 206650 +50538530 206882 +50535437 203789 +-1 -1 +50539610 207962 +50539864 208216 +50540099 208451 +50540374 208726 +50540610 208962 +50540878 209230 +50541133 209485 +50541372 209724 +50541630 209982 +50541887 210239 +-1 -1 +-1 -1 +-1 -1 +50542880 211232 +-1 -1 +-1 -1 +50549248 33816361 +50546432 33816352 +50546944 33816354 +50549504 33816362 +50548480 33816358 +50548992 33816360 +50546688 33816353 +50547456 33816355 +50548736 33816359 +50547968 33816357 +-1 -1 +50541871 210223 +50542378 210730 +50547245 215597 +50546432 33816352 +50546688 33816353 +50546944 33816354 +50547456 33816355 +50547712 50547712 +50547968 33816357 +50548480 33816358 +50548736 33816359 +50548992 33816360 +50549248 33816361 +50549504 33816362 +50548267 216619 +50535437 203789 diff --git a/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us.dmp b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us.dmp new file mode 100644 index 0000000000..61e2d65c7c --- /dev/null +++ b/packages/rtl-console/tests/fpc-3.0.4-win64/us101-us.dmp @@ -0,0 +1,101 @@ +50331931 283 +50346752 33619713 +50347008 33619714 +50347264 33619715 +50347520 33619716 +50347776 33619717 +50348032 33619718 +50348288 33619719 +50348544 33619720 +50348800 33619721 +50349056 33619722 +50365696 33619723 +50365952 33619724 +-1 -1 +-1 -1 +-1 -1 +50342240 10592 +50332209 561 +50332466 818 +50332723 1075 +50332980 1332 +50333237 1589 +50333494 1846 +50333751 2103 +50334008 2360 +50334265 2617 +50334512 2864 +50334765 3117 +50335037 3389 +50335240 3592 +50335497 3849 +50335857 4209 +50336119 4471 +50336357 4709 +50336626 4978 +50336884 5236 +50337145 5497 +50337397 5749 +50337641 5993 +50337903 6255 +50338160 6512 +50338395 6747 +50338653 7005 +50342748 11100 +-1 -1 +50339425 7777 +50339699 8051 +50339940 8292 +50340198 8550 +50340455 8807 +50340712 9064 +50340970 9322 +50341227 9579 +50341484 9836 +50341691 10043 +50341927 10279 +50338829 7181 +-1 -1 +50343034 11386 +50343288 11640 +50343523 11875 +50343798 12150 +50344034 12386 +50344302 12654 +50344557 12909 +50344748 13100 +50345006 13358 +50345263 13615 +-1 -1 +-1 -1 +-1 -1 +50346272 14624 +-1 -1 +-1 -1 +50352640 33619753 +50349824 33619744 +50350336 33619746 +50352896 33619754 +50351872 33619750 +50352384 33619752 +50350080 33619745 +50350848 33619747 +50352128 33619751 +50351360 33619749 +-1 -1 +50345263 13615 +50345770 14122 +50350637 18989 +50349824 33619744 +50350080 33619745 +50350336 33619746 +50350848 33619747 +50351104 50351104 +50351360 33619749 +50351872 33619750 +50352128 33619751 +50352384 33619752 +50352640 33619753 +50352896 33619754 +50351659 20011 +50338829 7181 diff --git a/packages/rtl-console/tests/kbd1.pp b/packages/rtl-console/tests/kbd1.pp new file mode 100644 index 0000000000..b5b82085a3 --- /dev/null +++ b/packages/rtl-console/tests/kbd1.pp @@ -0,0 +1,54 @@ +program kbd1; + +uses + keyboard; + +procedure ShowASCIIKey(C: Char); +begin + Write('ASCII key #', Ord(C), ' - #$', HexStr(Ord(C), 2)); + if C = '''' then + Write(' - ''''''''') + else if (C >= #32) and (C <= #126) then + Write(' - ''', C, '''') + else if C < #32 then + Write(' - ^', Chr(Ord(C) + Ord('@'))); + Writeln; +end; + +procedure ShowUnicodeKey(WC: WideChar); +begin + Writeln('Unicode key #', Ord(WC)); +end; + +procedure ShowKeyEvent(K: TKeyEvent); +begin + case GetKeyEventFlags(K) and 3 of + kbASCII: + ShowASCIIKey(GetKeyEventChar(K)); + kbUniCode: + ShowUnicodeKey(WideChar(GetKeyEventUniCode(K))); + kbFnKey: + Writeln('Function key ', FunctionKeyName(GetKeyEventCode(K))); + kbPhys: + Writeln('Physical key ', K and $FFFF, ' - $' + HexStr(K and $FFFF, 4)); + end; + Writeln('Shift state: ', ShiftStateToString(K, True)); + if (GetKeyEventFlags(K) and kbReleased) <> 0 then + Writeln('Released key event'); +end; + +var + K: TKeyEvent; +begin + InitKeyboard; + Writeln('Press keys, press "q" to end.'); + repeat + K:=GetKeyEvent; + Write('Before translation: '); + ShowKeyEvent(K); + K:=TranslateKeyEvent(K); + Write('After translation: '); + ShowKeyEvent(K); + until (GetKeyEventChar(K)='q'); + DoneKeyboard; +end. diff --git a/packages/rtl-console/tests/kbd2.pp b/packages/rtl-console/tests/kbd2.pp new file mode 100644 index 0000000000..4cb3381a07 --- /dev/null +++ b/packages/rtl-console/tests/kbd2.pp @@ -0,0 +1,61 @@ +program kbd2; + +uses + keyboard; + +procedure ShowASCIIKey(C: Char); +begin + Write('ASCII key #', Ord(C), ' - #$', HexStr(Ord(C), 2)); + if C = '''' then + Write(' - ''''''''') + else if (C >= #32) and (C <= #126) then + Write(' - ''', C, '''') + else if C < #32 then + Write(' - ^', Chr(Ord(C) + Ord('@'))); +end; + +procedure ShowUnicodeKey(WC: WideChar); +begin + Write('Unicode key #', Ord(WC)); +end; + +function EnhancedShiftStateToString(const ShiftState: TEnhancedShiftState): string; +var + S: TEnhancedShiftStateElement; + FirstElement: Boolean = True; +begin + EnhancedShiftStateToString := '['; + for S in TEnhancedShiftStateElement do + if S in ShiftState then + begin + if FirstElement then + WriteStr(EnhancedShiftStateToString, EnhancedShiftStateToString, S) + else + WriteStr(EnhancedShiftStateToString, EnhancedShiftStateToString, ',', S); + FirstElement := False; + end; + EnhancedShiftStateToString := EnhancedShiftStateToString + ']'; +end; + +procedure ShowKeyEvent(const K: TEnhancedKeyEvent); +begin + ShowASCIIKey(K.AsciiChar); + Write(', '); + ShowUnicodeKey(K.UnicodeChar); + Write(', Virtual Scan Code ', K.VirtualScanCode, ' - $' + HexStr(K.VirtualScanCode, 4), + ', Function key ', FunctionKeyName(K.VirtualKeyCode), + ', Shift state: ', EnhancedShiftStateToString(K.ShiftState)); + Writeln; +end; + +var + K: TEnhancedKeyEvent; +begin + InitKeyboard; + Writeln('Press keys, press "q" to end.'); + repeat + K:=GetEnhancedKeyEvent; + ShowKeyEvent(K); + until K.AsciiChar='q'; + DoneKeyboard; +end. diff --git a/packages/rtl-console/tests/kbdbdump.pp b/packages/rtl-console/tests/kbdbdump.pp new file mode 100644 index 0000000000..9a64df387d --- /dev/null +++ b/packages/rtl-console/tests/kbdbdump.pp @@ -0,0 +1,116 @@ +{ Keyboard BIOS dump tool. Dumps all keys and shift states using BIOS Int 16h + function calls. This tool runs in DOS only. } + +program kbdbdump; + +{$MODE objfpc}{$H+} + +uses + Video, Mouse, kbdutil, vidutil, Dos; + +procedure ShowShiftState; + + function BitAttr(var W: Word; bit: Integer): Byte; + begin + if (W and (1 shl bit)) <> 0 then + BitAttr := $70 + else + BitAttr := $07; + end; + +var + Regs: Registers; +begin + Regs.AH := $12; { get extended shift states } + Intr($16, Regs); + TextOut( 1, 16, 'SysReq', BitAttr(Regs.AX, 15)); + TextOut( 8, 16, 'Caps_Lock', BitAttr(Regs.AX, 14)); + TextOut(18, 16, 'Num_Lock', BitAttr(Regs.AX, 13)); + TextOut(27, 16, 'Scroll_Lock', BitAttr(Regs.AX, 12)); + TextOut(39, 16, 'Right_Alt', BitAttr(Regs.AX, 11)); + TextOut(49, 16, 'Right_Ctrl', BitAttr(Regs.AX, 10)); + TextOut(60, 16, 'Left_Alt', BitAttr(Regs.AX, 9)); + TextOut(69, 16, 'Left_Ctrl', BitAttr(Regs.AX, 8)); + + TextOut( 1, 17, 'Insert', BitAttr(Regs.AX, 7)); + TextOut( 8, 17, 'CapsLock', BitAttr(Regs.AX, 6)); + TextOut(17, 17, 'NumLock', BitAttr(Regs.AX, 5)); + TextOut(25, 17, 'ScrollLock', BitAttr(Regs.AX, 4)); + TextOut(36, 17, 'Alt', BitAttr(Regs.AX, 3)); + TextOut(40, 17, 'Ctrl', BitAttr(Regs.AX, 2)); + TextOut(45, 17, 'Left_Shift', BitAttr(Regs.AX, 1)); + TextOut(56, 17, 'Right_Shift', BitAttr(Regs.AX, 0)); +end; + +procedure SampleAllKeys(const Kbd: TKeyboard; const OutFileName: string); +var + I: Integer; + Regs: Registers; + M: TMouseEvent; + OutF: TextFile; +begin + AssignFile(OutF, OutFileName); + Rewrite(OutF); + for I := Low(kbd.Keys) to High(kbd.Keys) do + begin + DrawKey(kbd.Keys[I], $17); + UpdateScreen(False); + + repeat + ShowShiftState; + UpdateScreen(False); + Regs.AH := $11; { check for enhanced keystroke } + Intr($16, Regs); + if PollMouseEvent(M) then + GetMouseEvent(M); + until ((fZero and Regs.Flags) = 0) or ((GetMouseButtons and MouseRightButton) <> 0); + if ((fZero and Regs.Flags) = 0) then + begin + Regs.AH := $10; { get enhanced keystroke } + Intr($16, Regs); + Write(OutF, Regs.AX, ' '); + Regs.AH := $12; { get extended shift states } + Intr($16, Regs); + Writeln(OutF, Regs.AX); + end + else + begin + Writeln(OutF, '-1 -1'); + while (GetMouseButtons and MouseRightButton) <> 0 do + begin + if PollMouseEvent(M) then + GetMouseEvent(M); + end; + end; + + DrawKey(kbd.Keys[I], $70); + UpdateScreen(False); + end; + CloseFile(OutF); +end; + +var + kbd: TKeyboard; +begin + if ParamCount <> 2 then + begin + Writeln('Usage: ', ParamStr(0), ' <kbd_file> <output_file>'); + Halt(1); + end; + + + InitVideo; + InitMouse; + + kbd := ReadKeyboardFromFile(ParamStr(1)); + DrawKeyboard(kbd); + UpdateScreen(False); + + TextOut(1, 20, 'Press the highlighted key. Use the right mouse button to skip if the key', $07); + TextOut(1, 21, 'cannot be detected.', $07); + UpdateScreen(False); + SampleAllKeys(kbd, ParamStr(2)); + + DoneMouse; + DoneVideo; +end. diff --git a/packages/rtl-console/tests/kbddump.pp b/packages/rtl-console/tests/kbddump.pp new file mode 100644 index 0000000000..37faf4eb83 --- /dev/null +++ b/packages/rtl-console/tests/kbddump.pp @@ -0,0 +1,76 @@ +program kbddump; + +{$MODE objfpc}{$H+} + +uses + Video, Keyboard, Mouse, kbdutil, vidutil; + +procedure SampleAllKeys(const Kbd: TKeyboard; const OutFileName: string); +var + I: Integer; + K: TKeyEvent; + M: TMouseEvent; + OutF: TextFile; +begin + AssignFile(OutF, OutFileName); + Rewrite(OutF); + for I := Low(kbd.Keys) to High(kbd.Keys) do + begin + DrawKey(kbd.Keys[I], $17); + UpdateScreen(False); + + repeat + K := PollKeyEvent; + if PollMouseEvent(M) then + GetMouseEvent(M); + until (K <> 0) or ((GetMouseButtons and MouseRightButton) <> 0); + if K <> 0 then + begin + K := GetKeyEvent; + Write(OutF, K, ' '); + K:=TranslateKeyEvent(K); + Writeln(OutF, K); + end + else + begin + Writeln(OutF, '-1 -1'); + while (GetMouseButtons and MouseRightButton) <> 0 do + begin + if PollMouseEvent(M) then + GetMouseEvent(M); + end; + end; + + DrawKey(kbd.Keys[I], $70); + UpdateScreen(False); + end; + CloseFile(OutF); +end; + +var + kbd: TKeyboard; +begin + if ParamCount <> 2 then + begin + Writeln('Usage: ', ParamStr(0), ' <kbd_file> <output_file>'); + Halt(1); + end; + + + InitVideo; + InitKeyboard; + InitMouse; + + kbd := ReadKeyboardFromFile(ParamStr(1)); + DrawKeyboard(kbd); + UpdateScreen(False); + + TextOut(1, 20, 'Press the highlighted key. Use the right mouse button to skip if the key', $07); + TextOut(1, 21, 'cannot be detected.', $07); + UpdateScreen(False); + SampleAllKeys(kbd, ParamStr(2)); + + DoneMouse; + DoneKeyboard; + DoneVideo; +end. diff --git a/packages/rtl-console/tests/kbdtest.pp b/packages/rtl-console/tests/kbdtest.pp new file mode 100644 index 0000000000..c508f91211 --- /dev/null +++ b/packages/rtl-console/tests/kbdtest.pp @@ -0,0 +1,100 @@ +program KbdTest; + +{$MODE objfpc}{$H+} + +uses + Video, Keyboard, Mouse, kbdutil, vidutil; + +const + LastPressedAttr = $E0; + PreviouslyPressedAttr = $0F; + NotPressedAttr = $6F; + NotAvailableAttr = $08; +var + kbd: TKeyboard; + KbdEventMap: array of array [0..1] of TKeyEvent; + KeyHasBeenPressed: array of Boolean; + DumpF: TextFile; + I: Integer; + a1, a2: Int64; + K, TK: TKeyEvent; + M: TMouseEvent; + FoundKey: Boolean; +begin + if ParamCount <> 2 then + begin + Writeln('Usage: ', ParamStr(0), ' <kbd_file> <dump_file>'); + Halt(1); + end; + + + InitVideo; + InitKeyboard; + InitMouse; + + kbd := ReadKeyboardFromFile(ParamStr(1)); + SetLength(KbdEventMap, Length(kbd.Keys)); + SetLength(KeyHasBeenPressed, Length(kbd.Keys)); + AssignFile(DumpF, ParamStr(2)); + Reset(DumpF); + for I := Low(kbd.Keys) to High(kbd.Keys) do + begin + KeyHasBeenPressed[I] := False; + Readln(DumpF, a1, a2); + if (a1 = -1) or (a2 = -1) then + begin + KbdEventMap[I][0] := 0; + KbdEventMap[I][1] := 0; + DrawKey(kbd.Keys[I], NotAvailableAttr); + end + else + begin + KbdEventMap[I][0] := a1; + KbdEventMap[I][1] := a2; + DrawKey(kbd.Keys[I], NotPressedAttr); + end; + end; + CloseFile(DumpF); + + TextOut(1, 20, 'Press each of the highlighted keys.', $07); + TextOut(1, 21, 'Click the right mouse button to exit.', $07); + UpdateScreen(False); + + repeat + repeat + K := PollKeyEvent; + if PollMouseEvent(M) then + GetMouseEvent(M); + until (K <> 0) or ((GetMouseButtons and MouseRightButton) <> 0); + if K <> 0 then + begin + K := GetKeyEvent; + TK := TranslateKeyEvent(K); + + FoundKey := False; + for I := Low(kbd.Keys) to High(kbd.Keys) do + if (KbdEventMap[I][0] = K) and (KbdEventMap[I][1] = TK) then + begin + FoundKey := True; + KeyHasBeenPressed[I] := True; + DrawKey(kbd.Keys[I], LastPressedAttr); + end + else if KeyHasBeenPressed[I] then + DrawKey(kbd.Keys[I], PreviouslyPressedAttr) + else if KbdEventMap[I][0] <> 0 then + DrawKey(kbd.Keys[I], NotPressedAttr) + else + DrawKey(kbd.Keys[I], NotAvailableAttr); + + if not FoundKey then + begin + TextOut(1, 18, 'Unknown key code.', $04); + end; + UpdateScreen(False); + end; + until (GetMouseButtons and MouseRightButton) <> 0; + + DoneMouse; + DoneKeyboard; + DoneVideo; +end. diff --git a/packages/rtl-console/tests/kbdutil.pp b/packages/rtl-console/tests/kbdutil.pp new file mode 100644 index 0000000000..b335ac34c8 --- /dev/null +++ b/packages/rtl-console/tests/kbdutil.pp @@ -0,0 +1,73 @@ +unit kbdutil; + +{$MODE objfpc}{$H+} + +interface + +type + TKey = record + X, Y: Integer; + YTop, YBottom: Integer; + KeyLabel: string; + end; + TKeys = array of TKey; + TKeyboard = record + Keys: TKeys; + end; + +function ReadKeyboardFromFile(const FileName: string): TKeyboard; + +implementation + +function ReadKeyboardFromFile(const FileName: string): TKeyboard; +var + SaveCtrlZMarksEOF: Boolean; + InF: TextFile; + KeyX, KeyY, KeyY1, KeyY2: Integer; + KeyStr: string; +begin + SaveCtrlZMarksEOF := CtrlZMarksEOF; + try + CtrlZMarksEOF := False; + FillChar(Result, SizeOf(Result), 0); + AssignFile(InF, FileName); + Reset(InF); + while not EoF(InF) do + begin + Read(InF, KeyX); + if KeyX <> -1 then + begin + Readln(InF, KeyY, KeyStr); + Delete(KeyStr, 1, 1); + SetLength(Result.Keys, Length(Result.Keys) + 1); + with Result.Keys[High(Result.Keys)] do + begin + X := KeyX; + Y := KeyY; + YTop := KeyY; + YBottom := KeyY; + KeyLabel := KeyStr; + end; + end + else + begin + Readln(InF, KeyX, KeyY1, KeyY2, KeyY, KeyStr); + Delete(KeyStr, 1, 1); + SetLength(Result.Keys, Length(Result.Keys) + 1); + with Result.Keys[High(Result.Keys)] do + begin + X := KeyX; + Y := KeyY; + YTop := KeyY1; + YBottom := KeyY2; + KeyLabel := KeyStr; + end; + end; + end; + CloseFile(InF); + finally + CtrlZMarksEOF := SaveCtrlZMarksEOF; + end; +end; + +end. diff --git a/packages/rtl-console/tests/us101.txt b/packages/rtl-console/tests/us101.txt new file mode 100644 index 0000000000..ed69ff9891 --- /dev/null +++ b/packages/rtl-console/tests/us101.txt @@ -0,0 +1,101 @@ +3 0 Esc +9 0 F1 +12 0 F2 +15 0 F3 +18 0 F4 +22 0 F5 +25 0 F6 +28 0 F7 +31 0 F8 +35 0 F9 +38 0 10 +41 0 11 +44 0 12 +48 0 PSc +52 0 SLk +56 0 Pau +3 3 ` +6 3 1 +9 3 2 +12 3 3 +15 3 4 +18 3 5 +21 3 6 +24 3 7 +27 3 8 +30 3 9 +33 3 0 +36 3 - +39 3 = +42 3 -BS +3 5 Tab +7 5 Q +10 5 W +13 5 E +16 5 R +19 5 T +22 5 Y +25 5 U +28 5 I +31 5 O +34 5 P +37 5 [ +40 5 ] +43 5 \ +3 7 Caps +8 7 A +11 7 S +14 7 D +17 7 F +20 7 G +23 7 H +26 7 J +29 7 K +32 7 L +35 7 ; +38 7 ' +41 7 Enter +3 9 Shift +9 9 Z +12 9 X +15 9 C +18 9 V +21 9 B +24 9 N +27 9 M +30 9 , +33 9 . +36 9 / +39 9 Shift +3 11 Ctrl +10 11 Alt +15 11 Space Bar +35 11 Alt +42 11 Ctrl +48 3 Ins +52 3 Hom +56 3 PgU +48 5 Del +52 5 End +56 5 PgD +52 9 +48 11 +52 11 +56 11 +61 3 NL +64 3 / +67 3 * +70 3 - +61 5 7 +64 5 8 +67 5 9 +61 7 4 +64 7 5 +67 7 6 +61 9 1 +64 9 2 +67 9 3 +61 11 0 +67 11 . +-1 70 5 7 6 + +-1 70 9 11 10 Ù diff --git a/packages/rtl-console/tests/video1.pp b/packages/rtl-console/tests/video1.pp new file mode 100644 index 0000000000..bf72d5ed97 --- /dev/null +++ b/packages/rtl-console/tests/video1.pp @@ -0,0 +1,24 @@ +program video1; + +uses + video, keyboard; + +var + k: TKeyEvent; + X, Y: Integer; +begin + InitKeyboard; + InitVideo; + repeat + for X := 0 to ScreenWidth - 1 do + for Y := 0 to ScreenHeight - 1 do + VideoBuf^[Y * ScreenWidth + X] := ((X + Y) mod 256) or $0700; + UpdateScreen(False); + + k := GetKeyEvent; + k := TranslateKeyEvent(k); + until GetKeyEventChar(k) = 'q'; + DoneVideo; + DoneKeyboard; +end. + diff --git a/packages/rtl-console/tests/video1_unix.lpi b/packages/rtl-console/tests/video1_unix.lpi new file mode 100644 index 0000000000..9df8c841d5 --- /dev/null +++ b/packages/rtl-console/tests/video1_unix.lpi @@ -0,0 +1,71 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="11"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + <MainUnitHasScaledStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="video1"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <Units Count="4"> + <Unit0> + <Filename Value="video1.pp"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="../src/unix/video.pp"/> + <IsPartOfProject Value="True"/> + </Unit1> + <Unit2> + <Filename Value="../src/inc/video.inc"/> + <IsPartOfProject Value="True"/> + </Unit2> + <Unit3> + <Filename Value="../src/inc/videoh.inc"/> + <IsPartOfProject Value="True"/> + </Unit3> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="video1_unix"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir);../src/inc"/> + <OtherUnitFiles Value="../src/unix"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/rtl-console/tests/video1_windows.lpi b/packages/rtl-console/tests/video1_windows.lpi new file mode 100644 index 0000000000..c2a568308d --- /dev/null +++ b/packages/rtl-console/tests/video1_windows.lpi @@ -0,0 +1,85 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="11"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + <MainUnitHasScaledStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="video1"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <Units Count="4"> + <Unit0> + <Filename Value="video1.pp"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="../src/inc/video.inc"/> + <IsPartOfProject Value="True"/> + </Unit1> + <Unit2> + <Filename Value="../src/inc/videoh.inc"/> + <IsPartOfProject Value="True"/> + </Unit2> + <Unit3> + <Filename Value="../src/win/video.pp"/> + <IsPartOfProject Value="True"/> + </Unit3> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="video1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir);../src/inc"/> + <OtherUnitFiles Value="../src/win;../../rtl-unicode/src/inc"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <IncludeAssertionCode Value="True"/> + </SyntaxOptions> + </Parsing> + <CodeGeneration> + <Checks> + <IOChecks Value="True"/> + <RangeChecks Value="True"/> + <OverflowChecks Value="True"/> + <StackChecks Value="True"/> + </Checks> + <VerifyObjMethodCallValidity Value="True"/> + </CodeGeneration> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/rtl-console/tests/video2.pp b/packages/rtl-console/tests/video2.pp new file mode 100644 index 0000000000..26d3c6e1c2 --- /dev/null +++ b/packages/rtl-console/tests/video2.pp @@ -0,0 +1,28 @@ +program video2; + +uses + video, keyboard; + +var + k: TKeyEvent; + X, Y: Integer; +begin + InitKeyboard; + InitEnhancedVideo; + repeat + for X := 0 to ScreenWidth - 1 do + for Y := 0 to ScreenHeight - 1 do + with EnhancedVideoBuf[Y * ScreenWidth + X] do + begin + Attribute := $07; + ExtendedGraphemeCluster := WideChar(X + Y); + end; + UpdateScreen(False); + + k := GetKeyEvent; + k := TranslateKeyEvent(k); + until GetKeyEventChar(k) = 'q'; + DoneEnhancedVideo; + DoneKeyboard; +end. + diff --git a/packages/rtl-console/tests/video2_unix.lpi b/packages/rtl-console/tests/video2_unix.lpi new file mode 100644 index 0000000000..7acf1e0837 --- /dev/null +++ b/packages/rtl-console/tests/video2_unix.lpi @@ -0,0 +1,71 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="11"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + <MainUnitHasScaledStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="video2"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <Units Count="4"> + <Unit0> + <Filename Value="video2.pp"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="../src/unix/video.pp"/> + <IsPartOfProject Value="True"/> + </Unit1> + <Unit2> + <Filename Value="../src/inc/video.inc"/> + <IsPartOfProject Value="True"/> + </Unit2> + <Unit3> + <Filename Value="../src/inc/videoh.inc"/> + <IsPartOfProject Value="True"/> + </Unit3> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="video2"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir);../src/inc"/> + <OtherUnitFiles Value="../src/unix"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/rtl-console/tests/video2_windows.lpi b/packages/rtl-console/tests/video2_windows.lpi new file mode 100644 index 0000000000..deb64b3a6c --- /dev/null +++ b/packages/rtl-console/tests/video2_windows.lpi @@ -0,0 +1,86 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="11"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + <MainUnitHasScaledStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="video2"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <Units Count="4"> + <Unit0> + <Filename Value="video2.pp"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="../src/inc/video.inc"/> + <IsPartOfProject Value="True"/> + </Unit1> + <Unit2> + <Filename Value="../src/inc/videoh.inc"/> + <IsPartOfProject Value="True"/> + </Unit2> + <Unit3> + <Filename Value="../src/win/video.pp"/> + <IsPartOfProject Value="True"/> + <UnitName Value="Video"/> + </Unit3> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="video2"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir);../src/inc"/> + <OtherUnitFiles Value="../src/win;../../rtl-unicode/src/inc"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <IncludeAssertionCode Value="True"/> + </SyntaxOptions> + </Parsing> + <CodeGeneration> + <Checks> + <IOChecks Value="True"/> + <RangeChecks Value="True"/> + <OverflowChecks Value="True"/> + <StackChecks Value="True"/> + </Checks> + <VerifyObjMethodCallValidity Value="True"/> + </CodeGeneration> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/rtl-console/tests/vidutil.pp b/packages/rtl-console/tests/vidutil.pp new file mode 100644 index 0000000000..3939ac1608 --- /dev/null +++ b/packages/rtl-console/tests/vidutil.pp @@ -0,0 +1,52 @@ +unit VidUtil; + +{$MODE objfpc}{$H+} + +interface + +uses + KbdUtil; + +procedure TextOut(X, Y: Integer; const S: string; TextAttr: Byte); +procedure DrawKey(const Key: TKey; TextAttr: Byte); +procedure DrawKeyboard(const Kbd: TKeyboard); + +implementation + +uses + Video; + +procedure TextOut(X, Y: Integer; const S: string; TextAttr: Byte); +var + W, P, I, M: Integer; +begin + P := ((X-1)+(Y-1)*ScreenWidth); + M := Length(S); + if (P+M) > ScreenWidth*ScreenHeight then + M := ScreenWidth*ScreenHeight-P; + for I := 1 to M do + VideoBuf^[P+I-1] := Ord(S[I]) + (TextAttr shl 8); +end; + +procedure DrawKey(const Key: TKey; TextAttr: Byte); +var + Y: Integer; +begin + for Y := Key.YTop to Key.YBottom do + begin + if Y = Key.Y then + TextOut(Key.X + 1, Y + 1, Key.KeyLabel, TextAttr) + else + TextOut(Key.X + 1, Y + 1, StringOfChar(' ', Length(Key.KeyLabel)), TextAttr); + end; +end; + +procedure DrawKeyboard(const Kbd: TKeyboard); +var + I: Integer; +begin + for I := Low(kbd.Keys) to High(kbd.Keys) do + DrawKey(kbd.Keys[I], $70); +end; + +end. diff --git a/packages/rtl-extra/src/inc/objects.pp b/packages/rtl-extra/src/inc/objects.pp index 5d44da5674..e31bc4833e 100644 --- a/packages/rtl-extra/src/inc/objects.pp +++ b/packages/rtl-extra/src/inc/objects.pp @@ -315,6 +315,8 @@ TYPE FUNCTION GetPos: Longint; Virtual; FUNCTION GetSize: Longint; Virtual; FUNCTION ReadStr: PString; + FUNCTION ReadRawByteString: RawByteString; + FUNCTION ReadUnicodeString: UnicodeString; PROCEDURE Open (OpenMode: Word); Virtual; PROCEDURE Close; Virtual; PROCEDURE Reset; @@ -323,6 +325,8 @@ TYPE PROCEDURE Put (P: PObject); PROCEDURE StrWrite (P: PChar); PROCEDURE WriteStr (P: PString); + PROCEDURE WriteRawByteString (Const S: RawByteString); + PROCEDURE WriteUnicodeString (Const S: UnicodeString); PROCEDURE Seek (Pos: LongInt); Virtual; PROCEDURE Error (Code, Info: Integer); Virtual; PROCEDURE Read (Var Buf; Count: LongInt); Virtual; @@ -489,6 +493,32 @@ TYPE PStringCollection = ^TStringCollection; {---------------------------------------------------------------------------} +{ TRawByteStringCollection OBJECT - RAW BYTE STRING COLLECTION OBJECT } +{---------------------------------------------------------------------------} +TYPE + TRawByteStringCollection = OBJECT (TSortedCollection) + FUNCTION GetItem (Var S: TStream): Pointer; Virtual; + FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer; Virtual; + PROCEDURE FreeItem (Item: Pointer); Virtual; + PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual; + PROCEDURE AtInsert (Index: Sw_Integer; const Item: RawByteString); + END; + PRawByteStringCollection = ^TRawByteStringCollection; + +{---------------------------------------------------------------------------} +{ TUnicodeStringCollection OBJECT - RAW BYTE STRING COLLECTION OBJECT } +{---------------------------------------------------------------------------} +TYPE + TUnicodeStringCollection = OBJECT (TSortedCollection) + FUNCTION GetItem (Var S: TStream): Pointer; Virtual; + FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer; Virtual; + PROCEDURE FreeItem (Item: Pointer); Virtual; + PROCEDURE PutItem (Var S: TStream; Item: Pointer); Virtual; + PROCEDURE AtInsert (Index: Sw_Integer; const Item: UnicodeString); + END; + PUnicodeStringCollection = ^TUnicodeStringCollection; + +{---------------------------------------------------------------------------} { TStrCollection OBJECT - STRING COLLECTION OBJECT } {---------------------------------------------------------------------------} TYPE @@ -1226,6 +1256,35 @@ BEGIN END; {--TStream------------------------------------------------------------------} +{ ReadRawByteString } +{---------------------------------------------------------------------------} +FUNCTION TStream.ReadRawByteString: RawByteString; +VAR CP: TSystemCodePage; L: LongInt; +BEGIN + Read(CP, SizeOf(CP)); + Read(L, SizeOf(L)); + If (L <= 0) Then ReadRawByteString := '' Else Begin + SetLength(ReadRawByteString, L); + SetCodePage(ReadRawByteString, CP, False); + Read(ReadRawByteString[1], L); + End; +END; + +{--TStream------------------------------------------------------------------} +{ ReadUnicodeString } +{---------------------------------------------------------------------------} +FUNCTION TStream.ReadUnicodeString: UnicodeString; +VAR L: LongInt; S: UTF8String; +BEGIN + Read(L, SizeOf(L)); + If (L <= 0) Then ReadUnicodeString := '' Else Begin + SetLength(S, L); + Read(S[1], L); + ReadUnicodeString := S; + End; +END; + +{--TStream------------------------------------------------------------------} { GetPos -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } {---------------------------------------------------------------------------} FUNCTION TStream.GetPos: LongInt; @@ -1342,6 +1401,33 @@ BEGIN END; {--TStream------------------------------------------------------------------} +{ WriteRawByteString } +{---------------------------------------------------------------------------} +PROCEDURE TStream.WriteRawByteString (Const S: RawByteString); +VAR CP: TSystemCodePage; L: LongInt; +BEGIN + CP := StringCodePage(S); + L := Length(S); + Write(CP, SizeOf(CP)); + Write(L, SizeOf(L)); + if L > 0 then + Write((@S[1])^, L); +END; + +{--TStream------------------------------------------------------------------} +{ WriteUnicodeString } +{---------------------------------------------------------------------------} +PROCEDURE TStream.WriteUnicodeString (Const S: UnicodeString); +VAR L: LongInt; SU: UTF8String; +BEGIN + SU := S; + L := Length(SU); + Write(L, SizeOf(L)); + if L > 0 then + Write(SU[1], L); +END; + +{--TStream------------------------------------------------------------------} { Open -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB } {---------------------------------------------------------------------------} PROCEDURE TStream.Open (OpenMode: Word); @@ -2493,6 +2579,134 @@ BEGIN END; {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TRawByteStringCollection OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TRawByteStringCollection-------------------------------------------------} +{ GetItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRawByteStringCollection.GetItem (Var S: TStream): Pointer; +BEGIN + GetItem := nil; + RawByteString(GetItem) := S.ReadRawByteString; { Get new item } +END; + +{--TRawByteStringCollection-------------------------------------------------} +{ Compare -> Platforms DOS/DPMI/WIN/OS2 - Checked 21Aug97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRawByteStringCollection.Compare (Key1, Key2: Pointer): Sw_Integer; +VAR I, J: Sw_Integer; P1, P2: RawByteString; +BEGIN + P1 := RawByteString(Key1); { String 1 pointer } + P2 := RawByteString(Key2); { String 2 pointer } + If (Length(P1)<Length(P2)) Then J := Length(P1) + Else J := Length(P2); { Shortest length } + I := 1; { First character } + While (I<J) AND (P1[I]=P2[I]) Do Inc(I); { Scan till fail } + If (I=J) Then Begin { Possible match } + { * REMARK * - Bug fix 21 August 1997 } + If (P1[I]<P2[I]) Then Compare := -1 Else { String1 < String2 } + If (P1[I]>P2[I]) Then Compare := 1 Else { String1 > String2 } + If (Length(P1)>Length(P2)) Then Compare := 1 { String1 > String2 } + Else If (Length(P1)<Length(P2)) Then { String1 < String2 } + Compare := -1 Else Compare := 0; { String1 = String2 } + { * REMARK END * - Leon de Boer } + End Else If (P1[I]<P2[I]) Then Compare := -1 { String1 < String2 } + Else Compare := 1; { String1 > String2 } +END; + +{--TRawByteStringCollection-------------------------------------------------} +{ FreeItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRawByteStringCollection.FreeItem (Item: Pointer); +BEGIN + RawByteString(Item):=''; { Dispose item } +END; + +{--TRawByteStringCollection-------------------------------------------------} +{ PutItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRawByteStringCollection.PutItem (Var S: TStream; Item: Pointer); +BEGIN + S.WriteRawByteString(RawByteString(Item)); { Write string } +END; + +{--TRawByteStringCollection-------------------------------------------------} +{ AtInsert } +{---------------------------------------------------------------------------} +PROCEDURE TRawByteStringCollection.AtInsert (Index: Sw_Integer; const Item: RawByteString); +VAR TmpRef: Pointer; +BEGIN + TmpRef:=Nil; + RawByteString(TmpRef) := Item; + TCollection.AtInsert(Index, Pointer(Item)); +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TUnicodeStringCollection OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TRawByteStringCollection-------------------------------------------------} +{ GetItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION TUnicodeStringCollection.GetItem (Var S: TStream): Pointer; +BEGIN + GetItem := nil; + UnicodeString(GetItem) := S.ReadUnicodeString; { Get new item } +END; + +{--TRawByteStringCollection-------------------------------------------------} +{ Compare -> Platforms DOS/DPMI/WIN/OS2 - Checked 21Aug97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TUnicodeStringCollection.Compare (Key1, Key2: Pointer): Sw_Integer; +VAR I, J: Sw_Integer; P1, P2: UnicodeString; +BEGIN + P1 := UnicodeString(Key1); { String 1 pointer } + P2 := UnicodeString(Key2); { String 2 pointer } + If (Length(P1)<Length(P2)) Then J := Length(P1) + Else J := Length(P2); { Shortest length } + I := 1; { First character } + While (I<J) AND (P1[I]=P2[I]) Do Inc(I); { Scan till fail } + If (I=J) Then Begin { Possible match } + { * REMARK * - Bug fix 21 August 1997 } + If (P1[I]<P2[I]) Then Compare := -1 Else { String1 < String2 } + If (P1[I]>P2[I]) Then Compare := 1 Else { String1 > String2 } + If (Length(P1)>Length(P2)) Then Compare := 1 { String1 > String2 } + Else If (Length(P1)<Length(P2)) Then { String1 < String2 } + Compare := -1 Else Compare := 0; { String1 = String2 } + { * REMARK END * - Leon de Boer } + End Else If (P1[I]<P2[I]) Then Compare := -1 { String1 < String2 } + Else Compare := 1; { String1 > String2 } +END; + +{--TRawByteStringCollection-------------------------------------------------} +{ FreeItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TUnicodeStringCollection.FreeItem (Item: Pointer); +BEGIN + UnicodeString(Item):=''; { Dispose item } +END; + +{--TRawByteStringCollection-------------------------------------------------} +{ PutItem -> Platforms DOS/DPMI/WIN/OS2 - Checked 22May96 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TUnicodeStringCollection.PutItem (Var S: TStream; Item: Pointer); +BEGIN + S.WriteUnicodeString(UnicodeString(Item)); { Write string } +END; + +{--TRawByteStringCollection-------------------------------------------------} +{ AtInsert } +{---------------------------------------------------------------------------} +PROCEDURE TUnicodeStringCollection.AtInsert (Index: Sw_Integer; const Item: UnicodeString); +VAR TmpRef: Pointer; +BEGIN + TmpRef:=Nil; + UnicodeString(TmpRef) := Item; + TCollection.AtInsert(Index, Pointer(Item)); +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} { TStrCollection OBJECT METHODS } {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} diff --git a/tests/test/tcase49.pp b/tests/test/tcase49.pp index 33b491e9e5..ab48d38c36 100644 --- a/tests/test/tcase49.pp +++ b/tests/test/tcase49.pp @@ -1,3 +1,3 @@ -{ %OPT=-O2 }
-{ this benchmark can be used also as a test case }
-{$I ../bench/bcase.pp}
+{ %OPT=-O2 } +{ this benchmark can be used also as a test case } +{$I ../bench/bcase.pp} diff --git a/tests/test/units/objects/testobj3.pp b/tests/test/units/objects/testobj3.pp new file mode 100644 index 0000000000..c34a9dfa11 --- /dev/null +++ b/tests/test/units/objects/testobj3.pp @@ -0,0 +1,49 @@ +program testobj3; +uses + Objects; + +function GetRefCount(const S: RawByteString): SizeInt; +begin + GetRefCount:=PSizeInt(PByte(S)-2*SizeOf(SizeInt))^; +end; + +procedure Error(ErrNo: Integer); +begin + Writeln('Error! ', ErrNo); + Halt(1); +end; + +procedure Test1; +var + coll: PRawByteStringCollection; + S, S2: AnsiString; +begin + Writeln('Test1'); + SetLength(S, 5); + S[1] := 'H'; + S[2] := 'e'; + S[3] := 'l'; + S[4] := 'l'; + S[5] := 'o'; + if GetRefCount(S)<>1 then + Error(1); + coll := New(PRawByteStringCollection, Init(100, 100)); + coll^.AtInsert(0, S); + if GetRefCount(S)<>2 then + Error(2); + S2 := RawByteString(coll^.At(0)); + if GetRefCount(S)<>3 then + Error(3); + if S2<>'Hello' then + Error(4); + if RawByteString(coll^.At(0))<>'Hello' then + Error(5); + Dispose(coll, Done); + if GetRefCount(S)<>2 then + Error(6); +end; + +begin + Test1; + Writeln('Ok!'); +end. |