Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/GET10.ZIP/GET.PAS

Pascal/Delphi Source File | 1988-11-09 | 20.5 KB | 811 lines

{$B-,D-,F-,I-,L+,N-,R-,S-,T-,V+} {TP4 directives}
{
  This set of data entry routines provides dynamic validation capabilities.
  Note that dynamic validation of numbers is not attempted unless the range
  indicated for checking includes the number 0; these numbers are validated
  after they have been entered.

  Paul O'Nolan, CIS 72007,242 November 1988

}
Unit get;

Interface

Uses Crt, Qwik, Dos, GetFns, Getvars;

{ Note Crt is only used for: sound, nosound, delay }


function EditingField: boolean;
function brighten (instr: string): string;

procedure altwrite

   (row,col,                   {coordinates}
    attr1,attr2: byte;         {attributes}
    sentinel:    char;         {sentinel character}
    altstr:      screen_text); {message}

procedure bell; {may or may not be sounded, depending on SoundOn}
procedure beep; {user cannot disable}
procedure info (infomsg: screen_text);
procedure info2 (infomsg: screen_text);
procedure error (errormsg: screen_text);
procedure error2 (errormsg: screen_text);
procedure clearerror;
procedure clearerror2;
procedure getboolean

   (char_prompt:   screen_text;
    atr,atc,                 {co-ordinates}
    cursor_attr,
    pattr,dattr:   byte;     {attributes}
var response:      boolean);

procedure getbool

   (char_prompt:   screen_text;
    atr,atc:       byte;     {co-ordinates}
var response:      boolean);

procedure getchar

   (char_prompt:   screen_text;
    atr,atc,                 {co-ordinates}
    cursor_attr,
    pattr,chattr:  byte;     {attributes}
var response:      char;
    valid_keys:    ok_keys;
    nullok:        boolean;
    default_ch:    char);    {default response}

procedure getresponse

   (char_prompt: screen_text;
    valid_keys:  ok_keys;
    atr,atc:     byte;    {screen co-ords}
    makesure:    boolean; {confirm with Y/N?}
var response:    char;
    default_ch:  char);   {default response}

procedure getdigit

   (atr,atc:  byte;
    nattr:    integer);

procedure getnumber

   (num_prompt:   screen_text;
    atr,atc:      byte;        {screen co-ords}
    low,high:     longint;     {not checked if equal}
    pattr,nattr:  byte;        {attributes}
var number:       longint;
    maxvalue:     longint;     {implied type}
    default:      numstring);

procedure getreal

   (num_prompt:       screen_text;
    atr,atc:          byte;        {screen co-ords}
    low,high:         real;        {not checked if equal}
    decimal_places:   integer;     {or UserFormat number if negative}
    pattr,nattr:      byte;        {attributes}
var number:           real;
    default:          numstring);


procedure getlongint

   (num_prompt:       screen_text;
    atr,atc:          byte;       {screen co-ords}
    low,high:         integer;
    pattr,nattr:      byte;
var number:           longint;
    default:          numstring);

procedure getinteger

   (num_prompt:       screen_text;
    atr,atc:          byte;       {screen co-ords}
    low,high:         integer;
    pattr,nattr:      byte;
var number:           integer;
    default:          numstring);

procedure getshortint

   (num_prompt:       screen_text;
    atr,atc:          byte;       {screen co-ords}
    low,high:         integer;
    pattr,nattr:      byte;
var number:           shortint;
    default:          numstring);

procedure getword

   (num_prompt:       screen_text;
    atr,atc:          byte;        {screen co-ords}
    low,high:         integer;
    pattr,nattr:      byte;
var number:           word;
    default:          numstring);

procedure getbyte

   (num_prompt:       screen_text;
    atr,atc:          byte;        {screen co-ords}
    low,high:         integer;
    pattr,nattr:      byte;
var number:           byte;
    default:          numstring);

procedure getstring

   (str_prompt:       string;
    pattr,                      {prompt attribute}
    atr,atc,                    {row,col}
    attr,cursor_attr: byte;     {string & cursor attributes}
var instr:            string;   {string to edit}
    picture:          string;   {input picture/mask}
    maxstrlen:        plusbyte; {maximum length of string}
    status:           byte);

procedure getstr                {getstring with default attributes}

   (str_prompt:       string;
    atr,atc:          byte;     {row,col}
var instr:            string;   {string to edit}
    picture:          string;   {input picture/mask}
    maxstrlen:        plusbyte; {maximum length of string, 1..255}
    status:           byte);

procedure getdatestring

   (date_prompt:      screen_text;
    pattr:            byte;        {prompt attribute}
    atr,atc,                       {screen co-ords}
    dattr,                         {attribute}
    cursor_attr,                   {cursor attribute}
    separator_attr:   byte;        {date subfield separator attribute}
var datestr:          string;
    status:           byte);

procedure getdatestr

   (date_prompt:      screen_text;
    atr,atc:          byte;        {screen co-ords}
var datestr:          string;
    status:           byte);

procedure gettimestring

   (time_prompt:      screen_text;
    pattr,                         {prompt attribute}
    atr,atc,                       {screen co-ords}
    tattr,                         {time attribute}
    cursor_attr,                   {date and cursor attributes}
    separator_attr:   byte;        {time subfield separator attribute}
var timestr:          string;
    status:           byte);       {bit 2: use system time (hh:mm) as default}

procedure gettimestr

   (time_prompt:      screen_text;
    atr,atc:          byte;        {screen co-ords}
var timestr:          string;
    status:           byte);       {bit 2: use system time (hh:mm) as default}


Implementation

function EditingField: boolean;
begin
  EditingField := not PaintingFields;
end;


function brighten (instr: string): string;
{
  Attaches DefaultAltSwitch before and after a string. Used to trigger
  hightlighting in messages, e.g. error(text + brighten(text) + text);
}
begin
  if length(instr) < 254 then
    instr := DefaultAltSwitch + instr + DefaultAltSwitch;
  brighten := instr;
end;


procedure altwrite

   (row,col,                   {coordinates}
    attr1,attr2: byte;         {attributes}
    sentinel:    char;         {sentinel character}
    altstr:      screen_text); {message}

{
  Displays text in two attributes alternated by means of a switch passed as a
  parameter and embedded within text. Then pads rest of the line with spaces
  using the attribute in effect at the end of the string. Typical altstr:

  Delete ^ALL^ files? ^Y^/^N^?
}
var I,J,attr:   byte;
begin
  if length(altstr) > 0 then
    begin
      attr := attr1; J := 0;
      for I := 1 to length(altstr) do
        if altstr[I] = sentinel then
          if attr = attr2 then
            attr := attr1
          else attr := attr2
        else
          begin
            Qwrite(row,col + J,attr,altstr[I]); inc(J);
          end;
{
  Now fill to end of screen line with spaces using attr
}
      Qfill(row,col + J,1,CRTcols - pred(col) - J,attr,' ');
    end;
end;


procedure bell; {may or may not be sounded, depending on SoundOn}
begin
  if SoundOn then
    begin
      sound(belltone);
      delay(75);
      nosound;
    end;
end;


procedure beep; {user cannot disable}
begin
  sound(belltone);
  delay(75);
  nosound;
end;


procedure info (infomsg: screen_text);
begin
  altwrite(pred(CRTrows),1,AttrNM,AttrBO,DefaultAltSwitch,infomsg);
end;


procedure info2 (infomsg: screen_text);
begin
  altwrite(CRTrows,1,AttrNM,AttrBO,DefaultAltSwitch,infomsg);
end;


procedure error (errormsg: screen_text);
{
  No message is output unless the error line is clear. This prevents
  output of multiple error messages. Error line must be cleared with
  Clearerror.
}
begin
 if ErrorLineClear then
   begin
     info(errormsg);
     beep;
     ErrorLineClear := false;
   end;
end;


procedure error2 (errormsg: screen_text);
{
  No output unless error2 line is clear
}
begin
  if Error2LineClear then
    begin
      info2(errormsg);
      beep;
      Error2LineClear := false;
    end;
end;


procedure clearerror;
begin
  qfill(pred(CRTrows),1,1,CRTcols,AttrNM,' ');
  ErrorLineClear := true;
end;

procedure clearerror2;
begin
  qfill(CRTrows,1,1,CRTcols,AttrNM,' ');
  Error2LineClear := true;
end;


procedure display_prompt

   (char_prompt:   screen_text;
    atr:           byte;
var atc:           byte;     {co-ordinates}
    pattr,                   {attribute}
    field_size:    byte);

{
  This procedure displays a prompt for a field of a given size, performing
  any necessary adjustments to the positioning and size of the prompt to
  make it fit on the screen. The prompt is not redisplayed when input is
  sought for a field unless RedisplayPrompts is true.
}

begin
  if length(char_prompt) > CRTcols - field_size then {truncate prompt}
    char_prompt := copy(char_prompt,1,CRTcols - field_size);
{
  prompt + field will now fit on a line, move backwards until a home is found
}
  while
    (length(char_prompt) + field_size > CRTcols - pred(atc)) and (atc > 1)
  do
    dec(atc);
{
  Output prompt string at atr,atc.
}

  if PaintingFields or RedisplayPrompts then
    Qwrite(atr,atc,pattr,char_prompt);
  atc := atc + length(char_prompt);
end;


procedure getchar

   (char_prompt:   screen_text;
    atr,atc,                 {co-ordinates}
    cursor_attr,
    pattr,chattr:  byte;     {attributes}
var response:      char;
    valid_keys:    ok_keys;
    nullok:        boolean;
    default_ch:    char);    {default response}

const

    field_size:    byte = 1; {used for readability and consistency}

var CheckSet:             CharacterSetType;
    old_response:         char;
    BooleanInputExpected,
    finished:             boolean;
    TypeExpectedWord:     string;

procedure show_character;
var fattr: byte; {field attribute}
begin
  if EditingField and not finished then
    if FieldCursor <> 0 then
       fattr := FieldCursor
    else fattr := cursor_attr
  else fattr := chattr;

  if BooleanInputExpected then {translate response}
    begin
      if pos(response,TrueChars + BooleanTrueChar) > 0 then
        response := BooleanTrueChar
      else response := BooleanFalseChar;
    end;

  Qwrite(atr,atc,fattr,response);
end;

procedure validate_response;
begin
  if response in valid_keys then
    finished := true
  else
    begin
      if TypeExpectedWord <> '' then
        error2(TypeExpectedWord + InputWord + RequiredWord);

      if error2lineclear then
        bell; {some other character set}
    end;
end;

begin
  escaped := false;
  finished := false;
  old_response := response;
  TypeExpectedWord := '';

  display_prompt(char_prompt,atr,atc,pattr,field_size);

{
  Determine if input type expected is one of the predefined types.
}

  for CheckSet := Alphabetic to TrueOrFalse do
    with CharacterSet[CheckSet] do
      if valid_keys = CharSet then
        TypeExpectedWord := CharacterSetName; {set up for error message}

  BooleanInputExpected := valid_keys = CharacterSet[TrueOrFalse].CharSet;

  SetCursor(CursorOn or CursorUnderline);
  gotorc(atr,atc); {position cursor for input}

  if EditingField then
  repeat

    show_character;
    command := extendkey;
    action := get_edit(command);
    response := chr(asciicode);
    clearerror2;

    case action of

      help,
      abort:           begin
                         response := old_response;
                         finished := true;
                       end;

      tabover,
      tabback,
      upchar,
      downchar,
      leftchar,
      rightchar,
      pageup,
      pagedown,
      scrollup,
      scrolldown,
      goto_top,
      goto_bottom,
      exit_screen,
      quit:            begin
                         response := old_response;
                         validate_response; {sets finished true if ok}
                       end;

      enter_default,
      carriage_return: if default_ch in valid_keys then
                         response := default_ch
                       else if nullok and (chr(0) in valid_keys) then
                              response := chr(0)
                            else validate_response; {^J,^M?}

      escapefrom:     begin
                         response := old_response;
                         escaped := true;
                       end;
    else
      validate_response;
    end; {case}

  until (response in valid_keys) or escaped or finished;

  finished := true;
  show_character;
  clearerror2;
  SetCursor(CursorOff);
end;


procedure getresponse

   (char_prompt: screen_text;
    valid_keys:  ok_keys;
    atr,atc:     byte;    {screen co-ords}
    makesure:    boolean; {confirm with Y/N?}
var response:    char;
    default_ch:  char);   {default response}

{
  This procedure returns a single character in the variable 'response'.
  If the value of response is y or Y and 'makesure' is true then the
  response to 'Sure Y/N' is elicited via a recursive call. This is handy
  for getting answers to questions such as 'Delete all files.' Confirmation
  of responses other than y/Y is not possible with this procedure.

  Input is solicited immediately after the prompt, so the prompt should end
  with a space to separate the two fields.

  No recourse to help or function keys is allowed. The user is expected
  to enter a character from a selection displayed, end of story.

  The prompt string is displayed with the procedure AltWrite and so may
  contain DefaultAltSwitch to trigger highlighting. Note that the
  attributes for this string are the defaults for AttrNM and AttrBO.

  It is assumed that the prompt output will normally be at the start of a
  line.
}

var CheckSet:         CharacterSetType;
    output_char,
    old_response:     char;
    TypeExpectedWord: string;
    action:           edit;
    prompt_length:    byte;

begin
  escaped := false;
  old_response := response;
  TypeExpectedWord := '';

  prompt_length := length_without_tears(char_prompt,DefaultAltSwitch);

  if prompt_length >= CRTcols then
    begin
      prompt_length := pred(CRTcols);
      char_prompt[0] := chr(prompt_length);
    end;

  if prompt_length > 0 then
    begin
      if atc + prompt_length >= CRTcols then
        atc := 1;
      altwrite(atr,atc,AttrNM,AttrBO,DefaultAltSwitch,char_prompt);
      atc := atc + prompt_length;
    end;

{
  Determine if input type expected is one of the predefined types.
}

  for CheckSet := Alphabetic to TrueOrFalse do
    with CharacterSet[CheckSet] do
      if valid_keys = CharSet then
        TypeExpectedWord := CharacterSetName; {set up for error message}

  SetCursor(CursorOn or CursorUnderline);
  gotorc(atr,atc);
  response := default_ch;

  repeat
    if not (response in valid_keys) then
      output_char := default_ch {was ' '}
    else output_char := response;
    Qwrite(atr,atc,AttrBO,output_char); {highlight/blank input}

    command := extendkey;
    action := get_edit(command);
    response := chr(asciicode);
    clearerror2;

    case action of
      carriage_return: if default_ch in valid_keys then
                         response := default_ch;
      escapefrom: begin
                    response := old_response;
                    escaped := true;
                  end;
       else
         if not (response in valid_keys) then
           begin
             error2(TypeExpectedWord + InputWord + RequiredWord);

             if error2lineclear then
               bell; {some other character set}
           end;

    end; {case}

    if response in valid_keys then
      begin
        Qwrite(atr,atc,AttrBO,response); {echo it}

        if (upcase(response) = YesLetter) and makesure then
          getresponse(SureYN,CharacterSet[YesAndNo].CharSet,
                      atr,atc + 2,false,response,' ');
      end;

  until (response in valid_keys) or escaped;

  clearerror2;
  SetCursor(CursorOff);
end;


procedure getboolean

   (char_prompt:   screen_text;
    atr,atc,                 {co-ordinates}
    cursor_attr,
    pattr,dattr:   byte;     {prompt and data attributes}
var response:      boolean);

var
    response_ch,
    default_ch:    char;
{
  Cannot be a default value for response, as it must be true or false (i.e.
  no 'blank' state).
}
begin
  response_ch := chr(ord(response) + $30); {convert to '0'/'1'}

  getchar(char_prompt,atr,atc,cursor_attr,pattr,dattr,response_ch,
          CharacterSet[TrueOrFalse].CharSet,false,response_ch);

  if not escaped then
    response := pos(response_ch,Truechars + BooleanTrueChar) > 0;
end;


procedure getbool

   (char_prompt:   screen_text;
    atr,atc:       byte;     {co-ordinates}
var response:      boolean);

begin
  getboolean(char_prompt,atr,atc,Default_cursor_attr,
             Default_pattr,Default_dattr,response);
end;


procedure getdigit

   (atr,atc:  byte;
    nattr:    integer);

{
  Get any of the following characters: ^H,^I,^J,^M,^[,^Y,^U,'-','+','.', ","
  Echo using nattr attribute if nattr > 0.

  This procedure is used in procedures getnumber and getreal.
}
var
    figure, result: integer;
    action: edit;
begin
  repeat
    gotorc(atr,atc);
    command := extendkey;

    if scancode = 0 then {not an extended key}

      begin
        if not (chr(asciicode) in [^H,^I,^J,^M,^[,^Y,^U,'-','+','.',',']) then
          begin
            val(chr(asciicode),figure,result);
            if not (result = 0) then
              error2(Press_a_numeric_key)
            else if nattr > 0 then
              Qwrite(atr,atc,nattr,chr(asciicode));
          end
        else result := 0;
      end;

  until (result = 0) or (scancode <> 0);
end;



{$I getnum.pas}
{$I getreal.pas}


procedure getlongint

   (num_prompt:       screen_text;
    atr,atc:          byte;        {screen co-ords}
    low,high:         integer;
    pattr,nattr:      byte;
var number:           longint;
    default:          numstring);

begin
  getnumber(num_prompt,atr,atc,low,high,pattr,nattr,number,maxlongint,default);
end;


procedure getinteger

   (num_prompt:       screen_text;
    atr,atc:          byte;        {screen co-ords}
    low,high:         integer;
    pattr,nattr:      byte;
var number:           integer;
    default:          numstring);

var longI:            longint;

begin
  longI := number;
  getnumber(num_prompt,atr,atc,low,high,pattr,nattr,longI,maxint,default);
  number := longI;
end;


procedure getshortint

   (num_prompt:       screen_text;
    atr,atc:          byte;        {screen co-ords}
    low,high:         integer;
    pattr,nattr:      byte;
var number:           shortint;
    default:          numstring);

var shortI:           longint;

begin
  shortI := number;
  getnumber(num_prompt,atr,atc,low,high,pattr,nattr,shortI,maxshortint,default);
  number := shortI;
end;


procedure getword

   (num_prompt:       screen_text;
    atr,atc:          byte;        {screen co-ords}
    low,high:         integer;
    pattr,nattr:      byte;
var number:           word;
    default:          numstring);

var wordI:           longint;

begin
  wordI := number;
  getnumber(num_prompt,atr,atc,low,high,pattr,nattr,wordI,maxword,default);
  number := wordI;
end;


procedure getbyte

   (num_prompt:       screen_text;
    atr,atc:          byte;        {screen co-ords}
    low,high:         integer;
    pattr,nattr:      byte;
var number:           byte;
    default:          numstring);

var byteI:           longint;

begin
  byteI := number;
  getnumber(num_prompt,atr,atc,low,high,pattr,nattr,byteI,maxbyte,default);
  number := byteI;
end;


{$I getstr.pas}
{$I getdate.pas}
{$I gettime.pas}

{ check for 80 col screen mode if not set then force it }

begin
  LastVideoMode := QVideoMode;
  VideoModeNow  := QVideoMode;

  case VideoModeNow of
    BW40: VideoModeNow := BW80;
    CO40: VideoModeNow := CO80;
  end;

  if VideoModeNow <> QVideoMode then
    begin
      TextMode (VideoModeNow + hi(LastMode));
      Qinit;
    end;

  if QVideoMode = Mono then
    begin
      RedAttr             := 120;
      PicCursor           := 7;
      FieldCursor         := 9;
      Default_cursor_attr := 112;
    end;
end. {end of unit}