mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-25 14:29:13 +02:00
309 lines
7.6 KiB
ObjectPascal
309 lines
7.6 KiB
ObjectPascal
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;
|
||
|
||
{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: 711;
|
||
VmtLink: Ofs(Typeof(TInputLong)^);
|
||
Load : @TInputLong.Load;
|
||
Store : @TInputLong.Store);
|
||
|
||
Implementation
|
||
|
||
uses
|
||
FVConsts;
|
||
|
||
{-----------------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.
|