Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/INTR_DMO.ZIP/PLS-INP.INC

Text File | 1985-10-01 | 14.4 KB | 378 lines

{ CDS-INP.INC Input routines for CDS sysem. }

   procedure Display_Prompt(line    : Byte;
                            prompt  : Str_10;
                            msg_str : Str_80); forward;


   procedure Read_Kbd(var inchr,inctl: Char);
      var ms_reg     : RegPack;

      begin
        inctl := NULL_CHR;               { Initialize inctl to NULL_CHR.  }
        FillChar(ms_reg,SizeOf(ms_reg),ZERO);
        with ms_reg do
        begin
          ax := ZERO;                    { ah = 0 for read next kbd char.   }
          Intr($16,ms_reg);              { Call keyboard interrupt routine. }
          inchr := Chr(al);              { Convert result to Char.          }
          if (inchr = #00) then          { If function/special key pressed  }
            inctl := Chr(ah)             { put scan code in inctl.          }
          else                                { Otherwise trap conventional }
            if (inchr in [#1..#31,DEL]) then  { control codes as scan codes.}
              inctl := inchr;
        end; {with}
      end; { Read_Kbd }

  function Valid_Key(valid_keys: Any_Char): Char;
    var inchr, inctl : Char;

     begin
       repeat
         Read_Kbd(inchr,inctl);        { Wait for a key to be pressed. }
         if (inctl = NULL_CHR) then
           begin                       { If it is not a control key    }
             inchr := UpCase(inchr);   { force it to upper case and    }
             Write(inchr,BS);          { display it, restoring cursor. }
           end
         else                          { If it is a control key then   }
           inchr := inctl;             { pass it through for testing.  }
         if (not (inchr in valid_keys)) then
           Beep;                       { Beep if it's not valid.       }
       until (inchr in valid_keys);
       Valid_Key := inchr;             { Return the valid character.   }
     end; { Valid_Key }

  procedure Init_Field (init_char : Char;
                        var parms : Fld_Parms;
                        attribute : Byte);
    var  i, hold_attr : Byte;

    begin
      with parms do
      begin
        GoTo_XY(xloc,yloc);                 { Position cursor. }
        hold_attr := vid_attr; vid_attr := attribute;
        Repeat_Usr_Char(init_char,fld_len); { Init field with init_char. }
        GoToXY(xloc,yloc); vid_attr := hold_attr;
      end;
    end; { Init_Field }

  procedure Get_Field_Input(var parms    : Fld_Parms;
                            var chr_set  : Printable_Char;
                            var ctrl_set : Control_Char);

    var   count      : Integer;
          hold_attr  : Byte;
          exit,
          altered    : Boolean;

    procedure Clr_Eof;
      begin
        GoTo_XY(parms.xloc + count,parms.yloc);
        Repeat_Usr_Char(SPACE,(parms.fld_len - count));
      end; { Clr_Eof }

    procedure Process_Control_Character;
      var i, xpos, ypos  : Byte;

      procedure Backspace(fill: Char);

        begin
          if (count > ZERO) then
            begin
              Write(BS,fill,BS);      { Destructive backspace to video.     }
              inp_str[count] := SPACE;{ Insert space in input string.       }
              count := Pred(count);   { Decrement characters entered count. }
            end
          else
            Beep;                     { Beep if count = ZERO initially.     }
        end; { Backspace }

      procedure Clear_Field;
        var i : Byte;

        begin
          Init_Field(SPACE,parms,parms.disp_attr); { Clear video field. }
          with parms do
            FillChar(inp_str,fld_len + 1,ZERO);    { Clear inp_str. }
          count := ZERO;                           { Reset count to ZERO. }
        end; { Clear_Field }

      begin { Process_Control_Character }
        with parms do
        case inctl of
          BACKSP     : Backspace(SPACE);
          ENTER      : exit := TRUE;
          QUIT       : begin
                         esc_flag := TRUE;
                         exit := TRUE;
                       end;
          ALT_RIGHT,
          CUR_RIGHT  : if count < fld_len then
                         begin
                           count := count + 1;
                           GoToXY(WhereX + 1,WhereY);
                         end
                       else Beep;
          ALT_LEFT,
          CUR_LEFT   : if count > ZERO then
                         begin
                           GoToXY(WhereX - 1, WhereY); count := count - 1;
                          end
                       else Beep;
          ALT_INS,
          INS_CHAR   : begin
                         Strip_Trailing(fld_len);
                         Insert(SPACE,inp_str,count + 1);
                         if length(inp_str) > fld_len then
                            inp_str[ZERO] := chr(fld_len);
                         GoTo_XY(xloc,yloc); Write_Usr_Str(inp_str);
                         GoToXY(xloc + count,yloc);
                       end;
          ALT_DEL,
          DEL_CHAR   : begin
                         Strip_Trailing(fld_len);
                         if (length(inp_str) > ZERO) and
                            (count <= length(inp_str)) then
                           begin
                             Delete(inp_str,count + 1,1);
                             GoTo_XY(xloc,yloc); Write_Usr_Str(inp_str);
                             Write(Usr,SPACE);
                             inp_str[length(inp_str) + 1] := SPACE;
                             GoToXY(xloc + count,yloc);
                           end;
                       end;
          ALT_PREV,
          PREV_FLD   : begin
                         Clear_Field;
                         direction := DECR;
                         exit := TRUE;
                       end;
          CLEAR_FLD  : begin
                         Clear_Field;
                         exit := TRUE;
                       end;
          MSG_SWITCH : begin
                         xpos := WhereX; ypos := WhereY;
                         hold_attr := vid_attr;
                         vid_attr := DIM_VID;
                         if msg_on then
                           begin
                             GoTo_XY(7,PROMPT_LINE);
                             Repeat_Usr_Char(SPACE,65);
                             msg_on := FALSE;
                           end
                         else
                           begin
                             GoTo_XY(7,PROMPT_LINE);
                             Write_Usr_Str(fld_msg[msg_ptr]);
                             msg_on := TRUE;
                           end;
                         GoToXY(xpos,ypos);
                         vid_attr := hold_attr;
                       end;
          HELP       : begin
                         help_flag := TRUE;
                         exit := TRUE;
                       end;
         ACCEPT      : begin
                         accepted := True;
                         exit := True;
                       end;
             else      Beep;
        end; {case}
      end; { Process_Control_Character }

    procedure Accept_Valid_Character;

      begin
        with parms do
        begin
          if (fld_type = UC_TEXT) then
            inchr := UpCase(inchr);
          if (inchr in chr_set) and (count < fld_len) then
            begin
              Write(inchr);
              count := Succ(count);
              inp_str[count] := inchr;
              if (exit_type = AUTOMATIC) and (count = fld_len) then
                begin
                  exit := TRUE; inctl := CR;
                end;
              if (count = 1) and (not altered) then
                begin
                  Clr_Eof;
                  FillChar(inp_str,parms.fld_len,SPACE); inp_str[1] := inchr;
                end;
            end
          else
            Beep;
        end;
      end; { Accept_Valid_Character }

    begin { Get_Field_Input }
      count := ZERO;
      esc_flag := FALSE; exit := FALSE;
      direction := INCR;
      TextColor(Fgnd(parms.inp_attr));
      TextBackground(Bgnd(parms.inp_attr));
      FillChar(inp_str,SizeOf(inp_str),SPACE); inp_str[0] := Chr(0);
      if (mode = UPDATE) then
        inp_str := default;
      altered := FALSE;
      if (msg_on and (parms.msg_ptr < 41)) then
        begin
          vid_attr := DIM_VID;
          GoTo_XY(7,PROMPT_LINE);
          Write_Usr_Str(fld_msg[parms.msg_ptr]);
        end;
      vid_attr := REVERSE_VID;
      GoToXY(parms.xloc,parms.yloc);
      repeat
        Read_Kbd(inchr,inctl);
        if (inctl in ctrl_set) then
          Process_Control_Character
        else
          Accept_Valid_Character;
        altered := TRUE;
      until exit;
      Strip_Inp_Str(parms.fld_len);
      vid_attr := BRIGHT_VID;
      Clr_Eof;
      Norm_Video;
    end; { Get_Field_Input }

  function Valid_Str(var parms: Fld_Parms): Str_80;
    const ctrl_set    : Control_Char   = [CR,BS,CLEAR_FLD,QUIT,PREV_FLD,
                                          ALT_PREV,CUR_LEFT,ALT_LEFT,
                                          CUR_RIGHT,ALT_RIGHT,HELP,ACCEPT,
                                          ALT_INS,ALT_DEL,INS_CHAR,DEL_CHAR,
                                          MSG_SWITCH];

    var chr_set : Printable_Char;

    begin
      Valid_Str := default;    { Returns default if no value is entered. }
      case parms.fld_type of
         TEXT_FLD : chr_set := [' '..'~'];
         UC_TEXT  : chr_set := [SPACE,',','-'..'9','A'..'Z'];
         NUMERIC  : chr_set := ['0'..'9','-','.'];
         else       chr_set := [];
      end; {case}
      Get_Field_Input(parms,chr_set,ctrl_set);
      if ((inctl = CR) and (Length(inp_str) > ZERO)) or
         (inctl = CLEAR_FLD) then
        Valid_Str := inp_str;
    end; { Valid_Str }

  function Valid_Real(var parms   : Fld_Parms;
                          point   : Byte;
                          min,max : Real): Real;

    const chr_set     : Printable_Char = ['0'..'9','-','.'];
          ctrl_set    : Control_Char   = [CR,BS,CLEAR_FLD,QUIT,PREV_FLD,
                                          ALT_PREV,CUR_LEFT,ALT_LEFT,
                                          CUR_RIGHT,ALT_RIGHT,HELP,ACCEPT,
                                          ALT_INS,ALT_DEL,INS_CHAR,DEL_CHAR,
                                          MSG_SWITCH];


    var   real_val    : Real;
          min_str,
          max_str     : Str_20;
          err_msg     : Str_80;
          temp_str    : Str_255;

    begin { Valid_Real }
      inp_str := default; Strip_Inp_Str(Length(inp_str));
      Val(inp_str,real_val,io_status);
      if io_status <> ZERO then  { If default is a bad numeric value      }
        real_val := min;         { then return minimum.                   }
      Valid_Real := real_val;    { Return default if no value is entered. }
      Get_Field_Input(parms,chr_set,ctrl_set);
      if ((inctl = CR) and (Length(inp_str) > ZERO)) or
         (inctl = CLEAR_FLD) then
        begin
          if (inctl = CLEAR_FLD) then
            inp_str := '0.00';
          Val(inp_str,real_val,io_status);
          if (io_status = ZERO) and
             ((real_val >= min) and (real_val <= max)) then
            Valid_Real := real_val
          else
            begin
              Str(min:parms.fld_len:point,min_str); { The point parameter    }
              Str(max:parms.fld_len:point,max_str); { indicates the position }
              err_msg := 'Value must be from '      { of the decimal point.  }
                          + min_str + ' through ' + max_str + SPACE;
              Disp_Error_Msg(err_msg);
              direction := ZERO;            { Force re-entry of field. }
            end;
        end;
    end; { Valid_Real}

  function Valid_Int(var parms   : Fld_Parms;
                         min,max : Integer): Integer;

    const chr_set     : Printable_Char = ['0'..'9','-'];
          ctrl_set    : Control_Char   = [CR,BS,CLEAR_FLD,QUIT,PREV_FLD,
                                          ALT_PREV,CUR_LEFT,ALT_LEFT,
                                          CUR_RIGHT,ALT_RIGHT,HELP,ACCEPT,
                                          ALT_INS,ALT_DEL,INS_CHAR,DEL_CHAR,
                                          MSG_SWITCH];

    var   int_val     : Integer;
          min_str,
          max_str     : Str_20;
          err_msg     : Str_80;

    begin { Valid_Int }
      inp_str := default; Strip_Inp_Str(Length(inp_str));
      Val(inp_str,int_val,io_status);
      if io_status <> ZERO then { If default is a bad numeric value      }
        int_val := min;         { then return minimum value.             }
      Valid_Int := int_val;     { Return default if no value is entered. }
      Get_Field_Input(parms,chr_set,ctrl_set);
      if ((inctl = CR) and (Length(inp_str) > ZERO)) or
         (inctl = CLEAR_FLD) then
        begin
          if (inctl = CLEAR_FLD) then
            Valid_Int := ZERO
          else
            begin
              Strip_Inp_Str(Length(inp_str));
              Val(inp_str,int_val,io_status);
              if (io_status = ZERO) and
                 ((int_val >= min) and (int_val <= max)) then
                Valid_Int := int_val
              else
                begin
                  Str(min:parms.fld_len,min_str);
                  Str(max:parms.fld_len,max_str);
                  err_msg := 'Value must be from ' + min_str +
                             ' through ' + max_str + SPACE;
                  Disp_Error_Msg(err_msg);
                  direction := ZERO;             { Forces re-entry of field. }
                end;
            end;
        end;
    end; { Valid_Int }

  function Valid_Chr(var parms     : Fld_Parms;
                         valid_set : Printable_Char): Char;

    const ctrl_set    : Control_Char   = [CR,BS,CLEAR_FLD,QUIT,PREV_FLD,
                                          ALT_PREV,CUR_LEFT,ALT_LEFT,
                                          CUR_RIGHT,ALT_RIGHT,HELP,ACCEPT,
                                          ALT_INS,ALT_DEL,INS_CHAR,DEL_CHAR,
                                          MSG_SWITCH];

    begin  { Valid_Chr }
      Valid_Chr := default[1]; { Returns default if no value is entered. }
      Get_Field_Input(parms,valid_set,ctrl_set);
      if ((inctl = CR) and (Length(inp_str) > ZERO)) or
         (inctl = CLEAR_FLD) then
        Valid_Chr := inp_str[1]
    end; { Valid_Chr }