[Back to OOP SWAG index] [Back to Main SWAG index] [Original]

    {*******************************************************}
    {                                                       }
    {       Turbo Pascal Version 6.0                        }
    {       Optional FormLine Unit                          }
    {       for use with Turbo Vision                       }
    {                                                       }
    {       Copyright (c) 1991  J. John Sprenger            }
    {                                                       }
    {*******************************************************}

    unit FormLine;

    {$O+,F+,S+}

    interface

    uses

      {Turbo Pascal Run-Time Library Units}

      Crt,

      {Turbo Vision Standard Units}

      Objects, Drivers, Views, Dialogs, App,

      {Turbo Vision Accessory Units}

      StdDlg, MsgBox;

    const

      { flError, flCharOk and flFormatOK are constants used  }
      { by tFormatLine.CheckPicture.  flError is returned    }
      { when an error is found.  flCharOk when an character  }
      { is found to be appropriate.  And flFormatOk when the }
      { entire input string is found acceptable.             }

      flError    = $0000;
      flCharOK   = $0001;
      flFormatOK = $0002;

      { flCharError is passed to tFormatLine.ReportError     }
      { when a character does not fit the proper form.       }
      { flFormatError is used when the format is not         }
      { satisfied even though input so far is acceptable.    }

      flCharError   = 1;
      flFormatError = 2;

      { CommandSet represents the characters used in Format  }
      { Line Pictures.  These match those used by Paradox.   }

      CommandSet = ['[','{','?','&','@','!','#','{',',',']',
      '}','*'];

    type

      { tFormatLine }

      { tFormatLine is the improved tInputLine object which  }
      { accepts Paradox-form Picture strings to ensure that  }
      { data will be entered in an acceptable form.          }

      pFormatLine = ^tFormatLine;
      tFormatLine = object( tInputLine)
        Picture : string;
        constructor Init(var Bounds : tRect; AMaxLen
          : integer; Pic : string);
        function Valid(command : word) : boolean; virtual;
        procedure HandleEvent(var Event : tEvent); virtual;
        function CheckPicture(var s, Pic : string;
          var CPos : integer):word;
        procedure ReportError( kind : word); virtual;
      end;

      { tMoneyFormatLine }

      { tMoneyFormatLine is an input line intended for use   }
      { real number fields associated with money.  Input is  }
      { preceded with a "$" sign and terminated with a "."   }
      { followed by the appropriate fractional value.        }

      pMoneyFormatLine = ^tMoneyFormatLine;
      tMoneyFormatLine = object( tFormatLine )
        constructor Init(var Bounds : tRect; AMaxlen :
          integer);
        procedure SetData(var Rec); virtual;
        procedure GetData(var Rec); virtual;
        function DataSize : word; virtual;
      end;

      { tPhoneFormatLine }

      { tPhoneFormatLine is for phone number fields. Normal  }
      { 10-digit numbers are entered in the following form   }
      { (###) ###-####.  International numbers are entered   }
      { digit after digit with spaces and hyphens where the  }
      { user deems appropriate.                              }

      pPhoneFormatLine = ^tPhoneFormatLine;
      tPhoneFormatLine = object( tFormatLine )
        constructor Init(var Bounds : tRect; AMaxLen :
          integer);
        procedure SetData(var Rec); virtual;
        procedure GetData(var Rec); virtual;
      end;

      { tRealFormatLine }

      { tRealFormatLine is used for real number fields.  It  }
      { can handle both decimal and scientific notations.    }

      pRealFormatLine = ^tRealFormatLine;
      tRealFormatLine = object ( tFormatLine )
        constructor Init(var Bounds : tRect; AMaxLen :
          integer);
        procedure SetData(var Rec); virtual;
        procedure GetData(var Rec); virtual;
        function DataSize : word; virtual;
      end;

      { tIntegerFormatLine }

      { tIntegerFormatLine is used for integer fields.  It   }
      { accepts signed integers.                             }

      pIntegerFormatLine = ^tIntegerFormatLine;
      tIntegerFormatLine = object( tFormatLine )
        constructor Init(var Bounds : tRect; AMaxLen :
          integer);
        procedure SetData(var Rec); virtual;
        procedure GetData(var Rec); virtual;
        function DataSize : word; virtual;
      end;

      { tNameFormatLine }

      { tNameFormatLine accepts words and capitalizes the    }
      { first character of each word.  This would be used    }
      { proper names and addresses.                          }

      pNameFormatLine = ^tNameFormatLine;
      tNameFormatLine = object( tFormatLine )
        constructor Init(var Bounds : tRect; AMaxLen :
          integer);
      end;

      { tZipFormatLine }

      { tZipFormatLine is used for ZIP and Postal Code       }
      { fields.  It handles U.S. and Canadian format codes.  }

      pZipFormatLine = ^tZipFormatLine;
      tZipFormatLine = object( tFormatLine )
        constructor Init(var Bounds : tRect; AMaxLen :
          integer);
        end;

    implementation

    { Function Copy represents a bit of syntatic sugar for   }
    { the benefit of the author.  It changes the Copy func.  }
    { so that its parameters represent start and end points  }
    { rather than a start point followed by a quantity.      }

    function Copy(s : string; start, stop : integer) : string;
    begin
      if stop < start then Copy:=''
      else Copy:=System.Copy(s,start,stop-start+1);
    end;

    { Function FindMatch recursively locates the matching   }
    { grouping characters for "{" and "[".                  }

    function FindMatch(P : string) : integer;
    var
      i:integer;
      match:boolean;
      c:char;
    begin
      i:=2;
      match:=false;
      while (i<=length(P)) and not match do
        begin
          if ((p[i]=']') and (p[1]='[')) or ((p[i]='}') and
            (p[1]='{')) then
            match:=true;
          if p[i]='{' then
            i:=i+FindMatch(Copy(p,i,length(p)))
          else if p[i]='[' then
            i:=i+FindMatch(Copy(p,i,length(P)))
          else inc(i);
        end;
      FindMatch:=i-1;
    end;

    { tFormatLine.ReportError handles errors found when the  }
    { user keys inappropriate characters or presses ENTER    }
    { when input is incomplete.                              }

    procedure tFormatLine.ReportError(kind:word);
    var
      w   : word;
      Pic : pstring;
    begin
      Pic:=newstr(Picture);
      case kind of
        flCharError :
          begin
            sound(220);
            delay(200);
            nosound;
          end;
        flFormatError :
          begin
            w:=MessageBox('Error in Formatted Input Line'+
              '                      '+
              '%s'+
              '                      '+
              '(Using Paradox Picture Format)',
              @Pic,mfError+mfOkButton);
          end;
        end;
      DisposeStr(Pic);
    end;

    { tFormatLine.Valid overrides TView's Valid and reports  }
    { any format errors if the user accepts the input string }
    { before the entire format requirements have been met.   }

    function tFormatLine.Valid(command: word):boolean;
    var
      result:word;
    begin
      result:=CheckPicture(Data^,Picture,CurPos);
      if (result and flFormatOK)=0 then
        begin
          ReportError(flFormatError);
          Select;
          DrawView;
          Valid:=false;
        end
      else Valid:=true;
    end;

    { tFormatLine.CheckPicture is the function that inspects }
    { the input string passed as S against the Pic string    }
    { which holds the Paradox-form Picture.  If an error is  }
    { found the position of the error is placed in CPos.     }

    function tFormatLine.CheckPicture(var s, Pic : string;
      var CPos : integer) : word;
    var
      Resolved  : integer;
      TempIndex : integer;

    { Function CP is the heart of tFormatLine.  It           }
    { determines if the string, s passed to it fits the      }
    { requirements of the picture, Pic.  The number of       }
    { characters successful resolved is returned in the      }
    { parameter resolved. When groups or repetitions are     }
    { encountered CP will call itself recursively.           }

    function CP(var s : string; Pic : string; var CPos :
      integer; var Resolved : integer) : word;
    const
       CharMatchSet = ['#','?','&','@','!'];
    var
      i          : integer;
      index      : integer;
      result     : word;
      commit     : boolean;
      Groupcount : integer;

    { Procedure Succeed resolves defaults and <Space>        }
    { default requests                                       }

      procedure Succeed;
      var
        t     : integer;
        found : boolean;
      begin
      if (s[i]=' ') and (Pic[index]<>' ') and
        (Pic[index]<>',') then
        begin
          t:=index;
          found:=false;
          while (t<=length(pic)) and not found do
            begin
            if not (Pic[t] in (CharMatchSet+
              ['*','[','{',',',']','}'])) then
              begin
                if pic[t]=';' then inc(t);
                s[i]:=Pic[t];
                found:=true;
              end;
              inc(t);
            end;
        end;
      if (i>length(s)) then
        while not (Pic[index] in
          (CharMatchSet+['*','[','{',',',']','}'])) and
          (index<=length(Pic)) and
          not(Pic[index-1] in ['}',',',']']) do
          begin
            if Pic[index]=';' then inc(index);
            s[i]:=Pic[index];
            if i>length(s) then
              begin
                CPos:=i;
                s[0]:=char(i);
              end;
            inc(i);
            inc(index);
          end;
      end;

    { Function AnyLeft returns true if their are no required }
    { characters left in the Picture string.                 }

      function AnyLeft : boolean;
      var TempIndex : integer;
      begin
        TempIndex:=index;
        while ((Pic[TempIndex]='[') or (Pic[TempIndex]='*'))
          and (TempIndex<=Length(Pic)) and
          (Pic[TempIndex]<>',') do
          begin
            if Pic[TempIndex]='[' then
              Tempindex:=Tempindex+FindMatch(Copy(Pic,index,
                Length(Pic)))
            else begin
              if not (Pic[TempIndex+1] in ['0'..'9']) then
                begin
                  inc(TempIndex);
                  if Pic[TempIndex] in ['{','['] then
                    tempIndex:=TempIndex+
                      FindMatch(Copy(pic,index,length(pic)))
                  else inc(TempIndex);
                end;
            end;
          end;
        AnyLeft:=(TempIndex<=length(Pic)) and
         (Pic[TempIndex]<>',');
      end;

    { Function CharMatch determines if the current character }
    { matches the corresponding character mask in the        }
    { Picture string. Alters the character if necessary.     }

      function CharMatch : word;
      var result : word;
      begin
        result:=flError;
        case Pic[index] of
          '#': if s[i] in ['0'..'9'] then result:=flCharOk;
          '?': if s[i] in ['A'..'Z','a'..'z'] then
            result:=flCharOk;
          '&': if s[i] in ['A'..'Z','a'..'z'] then
            begin
              result:=flCharOk;
              s[i]:=upcase(s[i]);
            end;
          '@': result:=flCharOk;
          '!':
            begin
             result:=flCharOk;
             s[i]:=upcase(s[i]);
            end;
          end;
        if result<>flError then commit:=true;
        CharMatch:=result;
      end;

    { Function Literal handles characters which are needed   }
    { by the picture by otherwise used as format specifiers. }
    { All such characters are preceded by the ';' in the     }
    { picture string.                                        }

      function Literal : word;
      var result : word;
      begin
        inc(index);
        if s[i]=Pic[index] then result:=flCharOk
        else result:=flError;
        if result<>flError then commit:=true;
        Literal:=result;
      end;

    { Function Group handles required and optional groups    }
    { in the picture string.  These are designated by the    }
    (* "{","}" and "[","]" character pairs.                 *)

      function Group:word;
      var
        result: word;
        TempS: string;
        TempPic: string;
        TempCPos: integer;
        PicEnd: integer;
        TempIndex: integer;
        SwapIndex:integer;
        SwapPic : string;
      begin
        TempPic:=Copy(Pic,index,length(Pic));
        PicEnd:=FindMatch(TempPic);
        TempPic:=Copy(TempPic,2,PicEnd-1);
        TempS:=Copy(s,i,length(s));
        TempCPos:=1;

        result:=CP(TempS,TempPic,TempCPos,TempIndex);

        if result=flCharOK then inc(GroupCount);
        if (result=flFormatOK) and (groupcount>0) then
          dec(GroupCount);
        if result<>flError then result:=flCharOk;

        SwapIndex:=index;
        index:=TempIndex;
        SwapPic:=Pic;
        Pic:=TempPic;
        if not AnyLeft then result:=flCharOk;
        pic:=SwapPic;
        index:=SwapIndex;

        if i>1 then s:=copy(s,1,i-1)+TempS else s:=TempS;

        CPos:=Cpos+TempCPos-1;
        if Pic[index]='[' then
          begin
          if result<>flError then
             i:=i+TempCPos-1
          else dec(i);
          result:=flCharOK;
          end
        else i:=i+TempCPos-1;
        index:=index+PicEnd-1;
        Group:=result;
      end;

    { Function Repetition handles repeated that may be       }
    { repeated in the input string.  The picture string      }
    { indicates this possiblity with "*" character.          }

      function Repetition:word;
      var
        result:word;
        count:integer;
        TempPic:string;
        TempS:string;
        TempCPos:integer;
        TempIndex:integer;
        SwapIndex:integer;
        SwapPic:string;
        PicEnd:integer;
        commit:boolean;

        procedure MakeCount;
        var nstr:string;
            code:integer;
        begin
          if Pic[index] in ['0'..'9'] then
            begin
              nstr:='';
              repeat
                nstr:=nstr+Pic[index];
                inc(index);
              until not(Pic[index] in ['0'..'9']);
              val(nstr,count,code);
            end
          else count:=512;
        end;

        procedure MakePic;
        begin
        if Pic[index] in ['{','['] then
          begin
            TempPic:=copy(Pic,index,length(Pic));
            PicEnd:=FindMatch(TempPic);
            TempPic:=Copy(TempPic,2,PicEnd-1);
          end
        else
          begin
            if Pic[index]<>';' then
              begin
                TempPic:=''+Pic[index];
                PicEnd:=3;
                if index=1 then pic:='{'+pic[index]+'}'+
                  copy(pic,index+1,length(pic))
                else pic:=copy(pic,1,index-1)+
                  '{'+pic[index]+'}'+
                  copy(pic,index+1,length(pic));
              end
            else
              begin
                TempPic:=Pic[index]+Pic[index+1];
                PicEnd:=4;
                if index=1 then pic:='{'+pic[index]+
                  pic[index+1]+'}'+
                  copy(pic,index+1,length(pic))
                else pic:=copy(pic,1,index-1)+'{'+pic[index]+
                  pic[index+1]+'}'+copy(pic,index+1,
                  length(pic));
              end;
            end;
        end;

      begin
        inc(index);
        MakeCount;
        MakePic;
        result:=flCharOk;
        while (count<>0) and (result<>flError) and
          (i<=length(s)) do
          begin
            commit:=false;
            TempS:=Copy(s,i,length(s));
            TempCPos:=1;

            result:=CP(TempS,TempPic,TempCPos,TempIndex);

            if result=flCharOK then inc(GroupCount);
            if (result=flFormatOK) and
               (groupcount > 0)  then dec(GroupCount);
            if result<>flError then result:=flCharOk;

            SwapIndex:=Index;
            Index:=TempIndex;
            SwapPic:=Pic;
            Pic:=TempPic;
            if (not AnyLeft) then result:=flCharOk;
            Pic:=SwapPic;
            index:=SwapIndex;
            if i>1 then s:=copy(s,1,i-1)+TempS else s:=TempS;
            Cpos:=Cpos+TempCpos-1;
            if (count>255) then
               begin
               if result<>flError then
                  begin
                  i:=i+TempCpos-1;
                  if not commit then commit:=true;
                  result:=flCharOk;
                  end
               else dec(i);
               end
            else i:=i+TempCPos-1;
            inc(i);
            dec(count);
          end;
        dec(i);
        index:=index+PicEnd-1;
        if result=flError then
           if (count>255) and not commit
             then result:=flCharOk;
        repetition:=result;
      end;

      begin{ of function CP}
        i:=1;
        index:=1;
        result:=flCharOk;
        commit:=false;
        Groupcount:=0;
        while (i<=length(s)) and (result<>flError) do
          begin
            if index>length(Pic) then result:=flError else
              begin
                if s[i]=' ' then Succeed;
                if Pic[index] in CharMatchSet then
                  result:=CharMatch else
                if Pic[index]=';' then
                  result:=Literal else
                if (Pic[index]='{') or (Pic[index]='[') then
                  result:=Group else
                if Pic[index]='*' then
                  result:=Repetition else
                if Pic[index] in [',','}',']'] then
                  result:=flError else
                if Pic[index]=s[i] then
                  begin
                    result:=flCharOk;
                    commit:=true;
                  end
                else result:=flError;
                if (result = flError) and not commit then
                  begin
                    TempIndex:=Index;
                    while (TempIndex<=length(Pic)) and
                      ((Pic[TempIndex]<>',') and
                      (Pic[TempIndex-1]<>';'))  do
                      begin
                       if (Pic[TempIndex]='{') or
                         (Pic[TempIndex]=']')
                       then Index:=FindMatch( Copy( Pic,
                         TempIndex,length(Pic)))+TempIndex-1;
                       inc(TempIndex);
                     end;
                   if Pic[TempIndex]=',' then
                     begin
                       if Pic[TempIndex-1]<>';' then
                         begin
                           result:=flCharOk;
                           index:=TempIndex;
                           inc(index);
                         end;
                     end;
                  end
                else if result<>flError then
                  begin
                    inc(i);
                    inc(index);
                    Succeed;
                  end;

              end;
          end;
        Resolved:=index;

        if (result=flCharOk) and
          (GroupCount=0) and
          (not AnyLeft or ((Pic[index-1]=',') and
          (Pic[index-2]<>';')))
        then result:=flFormatOk;

        CPos:=i-1;
        CP:=result;
      end;

    begin{ of function CheckPicture}
    Resolved:=1;
    CheckPicture:=CP(s,Pic,CPos,Resolved);
    end;

    { tFormatLine.Init simply sets up the inputline and then }
    { sets up the Picture string for use by CheckPicture.    }

    constructor tFormatLine.Init(var Bounds: tRect;
      AMaxLen: integer; Pic : string);
    begin
      tInputLine.Init(Bounds,AMaxLen);
      Picture:=Pic;
    end;

    { tFormatLine.HandleEvent intercepts character key       }
    { presses and handles inserting these characters into    }
    { Data field.  Insertion only occures if a call to       }
    { tFormatLine.CheckPicture is successful else            }
    { tFormatLine.ReportError is called.  All other events   }
    { are passed on to tInputLine.HandleEvent.               }

    procedure TFormatLine.HandleEvent(var Event: TEvent);
    var TempData   : string;
        TempCurPos : integer;
        I          : integer;
    begin
    if State and sfSelected <> 0 then
       if Event.What=evKeyDown then
          if Event.CharCode in [' '..#255] then
             begin
             TempData:=Data^;
             if State and sfCursorIns<>0 then
                Delete(TempData,CurPos+1,1)
             else begin
                  if SelStart<>SelEnd then
                     begin
                     Delete(TempData,SelStart+1
                       ,SelEnd-SelStart);
                     CurPos:=SelStart;
                     end;
                  end;
             if Length(TempData)<MaxLen then
                begin
                inc(CurPos);
                insert(Event.CharCode,TempData,CurPos);
                if CheckPicture(TempData,Picture,CurPos)=flError then
                   ReportError(flCharError)
                else Data^:=TempData;
                SelStart:=0;
                SelEnd:=0;
                if FirstPos> CurPos then FirstPos:=CurPos;
                I:=CurPos-Size.X+2;
                if FirstPos<I then FirstPos:=I;
                DrawView;
                ClearEvent(Event);
                end;
             end;
    tInputLine.HandleEvent(Event);
    end;

    constructor tMoneyFormatLine.Init;
    begin
    tFormatLine.Init(Bounds,AMaxLen,'$#[#][#]*{;,###}.##');
    end;

    procedure tMoneyFormatLine.GetData;
    var Figure : real absolute Rec;
        TempData : string;
        i : integer;
        code : integer;
    begin
      TempData:=Data^;
      for i:=length(TempData) downto 1 do
          if TempData[i] in ['$',','] then
            Delete(TempData,i,1);
      val(TempData,Figure,code);
      if code<>0 then ReportError(flFormatError);
    end;

    procedure tMoneyFormatLine.SetData;
    var Figure : real absolute Rec;
        TempData : string;
        i,decimal, count : integer;
    begin
      str(Figure:0:2,TempData);
      i:=pos('.',TempData);
      count:=0;
      while (i<>1) do
        begin
        inc(count);
        dec(i);
        if count=3 then
          begin
          insert(',',TempData,i);
          count:=0;
          end;
        end;
      if TempData[1]=',' then delete(TempData,1,1);
      Data^:='$'+TempData;
    end;

    function tMoneyFormatLine.DataSize : word;
    begin
    DataSize:=sizeof(real);
    end;

    constructor tPhoneFormatLine.Init;
    begin
    tFormatLine.Init(Bounds,AMaxLen,
      '(###) ###-####,#*{#, ,-#}');
    end;

    procedure tPhoneFormatLine.GetData;
    var i : integer;
        Default : string absolute Rec;
    begin
      for i:=length(Data^) downto 1 do
        if Data^[i] in [' ','-','(',')'] then Delete(Data^,i,1);
    Default:=Data^;
    end;

    procedure tPhoneFormatLine.SetData;
    var i:integer;
        Default : string absolute Rec;
    begin
    if length(Default)=10 then
      Default:='('+Copy(Default,1,3)+') '+Copy(Default,4,6)+
        '-'+Copy(Default,7,10);
    Data^:=Default;
    end;

    constructor tRealFormatLine.Init;
    begin
    tFormatLine.Init(Bounds, AMaxLen,
      '[+,-]#*#[[.*#][{E,e}[+,-]#[#][#][#]]]');
    end;

    procedure tRealFormatLine.GetData;
    var Result : real absolute Rec;
        code : integer;
    begin
      val(Data^, Result, code);
      if code<>0 then ReportError(flFormatError);
    end;

    procedure tRealFormatLine.SetData;
    var Default : real absolute Rec;
    begin
      if Default>1E6 then
        str(Default,Data^)
      else str(Default:0:8,Data^);
    end;

    function tRealFormatLine.DataSize : word;
    begin
    DataSize:=sizeof(Real);
    end;

    constructor tIntegerFormatLine.Init;
    begin
    tFormatLine.Init(Bounds,AMaxLen,'[+,-]#*#');
    end;

    procedure tIntegerFormatLine.SetData;
    var Default : integer absolute Rec;
    begin
    str(Default,Data^);
    end;

    procedure tIntegerFormatLine.GetData;
    var Result : integer absolute Rec;
        code : integer;
    begin
    val(Data^,Result,code);
    if code<>0 then ReportError(flFormatError);
    end;

    function tIntegerFormatLine.DataSize : word;
    begin
    DataSize:=sizeof(integer);
    end;

    constructor tNameFormatLine.Init;
    begin
    tFormatLine.Init(Bounds,AMaxLen,'*[![*?][@][ ]]');
    end;

    constructor tZipFormatLine.Init;
    begin
    tFormatLine.Init(Bounds,AMaxLen,'#####[-####],&#& #&#');
    end;

    end.

[Back to OOP SWAG index] [Back to Main SWAG index] [Original]