freepascal.compiler/packages/fv/src/inplong.inc

{
    This file is part of the Free Vision package

    A longint version of TInputline

    Copyright (c) 1999-2022 by Peter Vreman

    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.

 **********************************************************************}

{$IFNDEF FPC_DOTTEDUNITS}
{$ifdef FV_UNICODE}
Unit UInpLong;
{$else FV_UNICODE}
Unit InpLong;
{$endif FV_UNICODE}
{$ENDIF FPC_DOTTEDUNITS}

(*--
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

{$IFDEF FPC_DOTTEDUNITS}
uses System.Objects,
{$ifdef FV_UNICODE}
  FreeVision.Udrivers, FreeVision.Uviews, FreeVision.Udialogs, FreeVision.Umsgbox, FreeVision.Ufvcommon,
{$else FV_UNICODE}
  FreeVision.Drivers, FreeVision.Views, FreeVision.Dialogs, FreeVision.Msgbox, FreeVision.Fvcommon,
{$endif FV_UNICODE}
  FreeVision.Fvconsts;
{$ELSE FPC_DOTTEDUNITS}
uses objects,
{$ifdef FV_UNICODE}
  udrivers, uviews, udialogs, umsgbox, ufvcommon,
{$else FV_UNICODE}
  drivers, views, dialogs, msgbox, fvcommon,
{$endif FV_UNICODE}
  fvconsts;
{$ENDIF FPC_DOTTEDUNITS}

{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 AnsiChar = '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.