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

Pascal/Delphi Source File | 1988-11-09 | 21.1 KB | 789 lines

procedure getstr

   (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);

begin

  getstring(str_prompt,Default_pattr,atr,atc,Default_dattr,
            Default_cursor_attr,instr,picture,maxstrlen,status);
end;


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, 1..255}
    status:           byte);

{
  This procedure gets a string from the screen. A variety of editing commands
  are supported. The string need not be contiguous, it may contain embedded
  characters on display and can be validated on character by character basis.
}

var
    I,
    NumberOfCharacters,
    NumberOfMarkers: integer;

    SizeOfSubstring1,
    oldcp:           byte; {type byte to enable use of 0 as signal value}

    breaks,line_offset: byte;

    firstcp,
    fromcp:          plusbyte; {cursor position: 1..255}

    original_string: string;

    lettertype,
    picsel,                {not to be confused with pixel!}
    letter:          char;

    mandatory,
    fixed_length,
    StringIsContiguous,
    ValidateOff,
    PictureAllX,
    OldOverwrite,
    LocalInsLock,
    finished:        boolean;

    charpos:         array [1..255] of byte;
    chartype:        array [1..255] of CharacterSetType;
    charcase:        array [1..255] of boolean;

    fmarray:         array [1..255] of record
                       location:   byte; {screen location}
                       markerchar: char; {field marker}
                     end;

procedure gotocp (newcp: byte);
{
  This procedure can use an unblinking cursor made using a video attribute
  or the "real thing." Both are used if overwrite is on and a video cursor
  is in use.
}
var fattr: byte;

procedure position_real_cursor;
begin
  gotorc(atr,charpos[newcp]);
end;

begin
  if (FieldCursor <> 0) then
    fattr := FieldCursor
  else fattr := attr;

  if cursor_attr <> attr then {using video attibute for cursor}

    begin
      if oldcp <> newcp then
        begin
          if oldcp <> 0 then {remove old cursor}
            Qattr(atr,charpos[oldcp],1,1,fattr);
          if not finished then  {make a new one}
            Qattr(atr,charpos[newcp],1,1,cursor_attr);
        end;

      if overwrite then
        position_real_cursor;
    end

  else position_real_cursor;

  oldcp := cp;
  cp := newcp;
end;


procedure show_string;
var I,
    fattr,
    PicAttr,
    strlen: byte;

function StringIsUnbroken: boolean;
begin
  StringIsUnbroken := (NumberOfMarkers = 0) and StringIsContiguous;
end;

begin
  oldcp := 0;

  if EditingField and not (finished or escaped) then
    begin
      if FieldCursor <> 0 then
        fattr := FieldCursor;
      if PicCursor <> 0 then
        PicAttr := PicCursor;
      end
  else
    begin
      fattr := attr;
      PicAttr := fattr;
    end;

{
  Output field markers
}

  I := 1;
  while fmarray[I].location <> 0 do
    begin
      Qwrite(atr,fmarray[I].location,PicAttr,fmarray[I].markerchar);
      inc(I);
    end;

{
  Blank from end of string to end of field
}

  strlen := length(instr);
  if StringIsUnbroken then
    Qfill(atr,atc + strlen,1,maxstrlen - strlen,fattr,' ')
  else if strlen < maxstrlen then
    for I := succ(strlen) to maxstrlen do
      Qwrite(atr,charpos[I],fattr,' ');

{
  Output string
}

  if PasswordField then
    for I := 1 to length(instr) do
      Qwrite(atr,charpos[I],fattr,PasswordChar)
  else
    begin
      if StringIsUnbroken then

       if not top_n_tail and (instr = original_string) then    {needn't rewrite}
          Qattr(atr,charpos[1],1,ord(instr[0]),fattr)          {... change attr}
       else QwriteA(atr,charpos[1],fattr,ord(instr[0]),instr[1])

      else {string contains field markers or is not contiguous}

        for I := 1 to length(instr) do
           Qwrite(atr,charpos[I],fattr,instr[I]);

(*
        To show duff characters in string using RedAttr:

        begin
          if (instr[I] in CharacterSet[chartype[I]].CharSet) or
            (chartype[I] = AnyCharacter) then
            chattr := fattr
          else chattr := RedAttr;
          Qwrite(atr,pred(atc) + charpos[I],chattr,instr[I]);
        end;
*)
    end;
end;


procedure show_cursor;
{
 Sets cursor type. See GET.DOC.
}
begin
  gotocp(cp);
  if overwrite then
    SetCursor(CursorOn or CursorUnderline)
  else {insert}
    if cursor_attr = attr then
      SetCursor(CursorOn or CursorBlock)   {not using video cursor}
    else ModCursor(CursorOff); {using video cursor}
end;


procedure restore_string;
begin
  instr := original_string;
  show_string;
end;


procedure validate_field;

procedure check_character_types;
var I: byte;
begin
  I := 1;
  while (I <= length(instr)) and Error2LineClear do
    if (instr[I] in CharacterSet[chartype[I]].CharSet) or
      (chartype[I] = AnyCharacter) then
      inc(I)
    else
      begin
        error2(CharacterSet[chartype[I]].CharacterSetName
               + CharacterWord + RequiredWord);
        cp := I; {put the cursor on the bad character}
      end;
end;

begin
  finished := PasswordField or ValidateOff;
  if not finished then
    begin
      clearerror2;
      if not PictureAllX then
        check_character_types;

      if Error2LineClear then

        if (instr = '') then
          if not mandatory then
            finished := true
          else error2(Null_input_not_allowed)
        else if fixed_length and (ord(instr[0]) <> maxstrlen) then
               error2(Fixed_length_input_required)
             else finished := true;
    end;
end;


procedure enter_a_letter (letter: char);
{
  Fixed length fields are completed automatically when a character is
  entered in the last character position, but not otherwise -- even
  if the field is full (i.e., insertion of characters before the end
  of the field will not effect field completion).

  validate_field is executed in case a field has been moved into with the
  cursor on the last character position and a character entered. E.g.,
  cursor moves from field 2 here to field 1:

          field 1       field 2
 content   ABC_      <- anything
 picture   999X         XXXXXXXX

 Note that the contents of field 1 are invalid

}
begin
  if ForceUppercase then
    letter := upcase(letter);

  if cp > length(instr) then {pad with spaces}
    begin
      while length(instr) < pred(cp) do
        instr := instr + ' ';
      instr[cp] := letter;
      instr[0] := chr(cp); {set length}
    end
  else
    begin
      if overwrite then
        instr[cp] := letter
      else {insert}
        begin
          if length(instr) = maxstrlen then
            instr[0] := chr(pred(maxstrlen));
          insert(letter,instr,cp);
        end;
    end;

  if cp < maxstrlen then
    inc(cp)
  else if (length(instr) = maxstrlen) and
         (fixed_length or StringFieldWrap) then
           begin
             validate_field; {sets finished true or false}
             if finished then
               cp := 1;
           end;

  show_string;
end;


procedure setup_picture_attributes;
var LastLineStart,
    last_picture_index,
    repeat_count,
    I,J,K,L:          integer;

    AttributeSet,
    Duplicate,
    Shift,
    CopyLiteral:        boolean;

function transfer: boolean;
{ just used to make inline code a little more readable }
begin
  transfer := (picture[I] in CharacterSet[FieldMarkers].CharSet) or
              (CopyLiteral and (picture[I] <> DefaultAltSwitch));
end;

function PicType (picchar: char): CharacterSetType;
begin
  case upcase(picchar) of
    'A': PicType := Alphabetic;
    'C': PicType := Alphanumeric;
    'P': PicType := Printable;
    '9': PicType := Numeric;
  else
    PicType := AnyCharacter;
  end; {case}
end;

procedure enter_a_field_marker_or_literal;
begin
  if picture[I] = 'B' then
    picsel := ' '
  else picsel := chr(ord(picture[I])); {TP v4.0 enforced conversion}

  fmarray[K].markerchar := picsel; {field marker}
  fmarray[K].location := L;        {screen location}
  inc(K);
  inc(L);
end;

procedure set_attribute (picture_index: integer);
begin
  chartype[J] := PicType(picture[picture_index]);
  PictureAllX := PictureAllX and (chartype[J] = AnyCharacter);

  if J > 1 then {set Insert lock on if character type changes}
    LocalInsLock := LocalInsLock or (chartype[J] <> chartype[pred(J)]);

  charpos[J] := L;
  charcase[J] := picture[picture_index] in ['A'..'Z'];
  inc(J);
  inc(L);

  last_picture_index  := picture_index;
  AttributeSet := true;
end;

begin
  if length(picture) = 0 then
    picture := 'x';

  fillchar(fmarray,sizeof(fmarray),0);
  StringIsContiguous := true;
  SizeOfSubstring1 := 0;
  Duplicate := false;
  Shift := false;
  AttributeSet := false;
  PictureAllX := true;
  CopyLiteral := false;
  LocalInsLock := InsLock or PasswordField;
{
  Local Insert not locked unless > 1 type in string or InsLock already set
  or PasswordField is true.
}

  L := 0; {screen location: offset for now, convert to absolute location later}
  J := 1; {character index}
  K := 1; {marker index}
  LastLineStart := L;

  I := 1;
  repeat
    begin

      if picture[I] = DefaultAltSwitch then
        CopyLiteral := not CopyLiteral;


      if Duplicate then
        begin
          repeat_count := ord(picture[I]);
          while (repeat_count > 0) and (J > 0) do {J will wrap to 0 after 255}
            begin
              set_attribute(last_picture_index);
              dec(repeat_count);
            end;
          Duplicate := false;
        end

      else if Shift then
        begin
          if picture[I] = 'N' then
            L := LastLineStart + CRTcols
          else inc(L,ord(picture[I]));
          LastLineStart := L;
          Shift := false;
        end

      else if transfer then
             enter_a_field_marker_or_literal

      else if picture[I] = ShiftCharacter then
        begin
          Shift := true;
          StringIsContiguous :=  false;
          if SizeOfSubstring1 = 0 then
            SizeOfSubstring1 := pred(I);
        end

      else if (picture[I] = RepeatCharacter) and AttributeSet then
             Duplicate := true

      else if picture[I] <> DefaultAltSwitch then
             set_attribute(I);

      inc(I);
    end;
  until (I > length(picture)) or (J = 0) {wrap: 255 + 1 = 0};


  while J <= maxstrlen do
    begin
      if J = 1 then { picture had only field markers... assume PIC X}
        begin
          chartype[1] := AnyCharacter;
          charcase[1] := false;
        end
      else
        begin
          chartype[J] := chartype[pred(J)]; {copy the last character type}
          charcase[J] := charcase[pred(J)]; { and case}
        end;

      charpos[J] := L;
      inc(J);
      inc(L);
    end;

  NumberOfMarkers    := pred(K);
  NumberOfCharacters := pred(J);

end;


function EditingString: boolean;
{
  This function is used to prevent editing of a field full of markers
}
begin
  EditingString := EditingField and (NumberOfCharacters > 0);
end;


procedure restore_and_validate;
begin
  restore_string;
  validate_field;
end;


procedure get_input;
var I: byte;
begin
  command := extendkey;
  action := get_edit(command);

  clearerror2;

  case action of

    goto_start:

                 cp := 1;

    goto_end:

                 if length(instr) > 0 then
                   if length(instr) = maxstrlen then
                     cp := maxstrlen
                   else cp := succ(length(instr))
                 else cp := 1;

    leftchar:    if cp > 1 then
                   dec(cp)
                 else if StringFieldWrap then
                   begin
                     validate_field;           {sets finished true or false}
                     if finished then
                       cp := 255;      {force to end of any previous string}
                   end;

    rightchar:   if cp < maxstrlen then
                   inc(cp)
                 else if StringFieldWrap then
                   begin
                     validate_field;           {sets finished true or false}
                     if finished then
                       cp := 1;     {force to start of any following string}
                   end;

    toggle_mode: if not LocalInsLock then
                   begin
                     overwrite := not overwrite;
                     show_cursor;
                   end;

    del_to_end:  {delete to end of line}
                 begin
                   instr := copy(instr,1,pred(cp));
                   show_string;
                 end;

    del_to_start: {delete to start of line}
                 begin
                   delete(instr,1,pred(cp));
                   show_string;
                   cp := 1;
                 end;

    del_line:   {delete line}
                 begin
                   instr := '';
                   show_string;
                   cp := 1;
                 end;

    oops:        {restore original string and cursor position}
                 begin
                   restore_string;
                   cp := firstcp;
                   show_cursor;
                 end;

    tabover:     {enter spaces to the next tab stop -- defined by tabsize}
                 if tabsize > 0 then
                   for I := 1 to tabsize - (cp mod tabsize) do
                     enter_a_letter(' ')
                 else validate_field;

    leftword:    {word left}
                 if (cp > 1) and (length(instr) > 1) then
                   begin
                     dec(cp);
                     while (cp >= 1) and (instr[cp] = ' ') do
                       dec(cp); {skip over whitespace}
                     while (cp >= 1) and (instr[cp] <> ' ') do
                       dec(cp); {skip over text}
                     inc(cp);
                   end;

    rightword:   {word right}
                 if cp <= length(instr) then
                   begin
                     while (cp < length(instr)) and (instr[cp] <> ' ') do
                       inc(cp); {skip over text}
                     if cp < maxstrlen then
                       inc(cp); {skip over space}
                     while (cp < length(instr)) and (instr[cp] = ' ') do
                       inc(cp); {skip over whitespace}
                   end;

    del_word:    {delete next word}
                 begin
                   fromcp := cp;
                     while (cp <= length(instr)) and (instr[cp] <> ' ') do
                       inc(cp); {skip over text}
                     while (cp <= length(instr)) and (instr[cp] = ' ') do
                       inc(cp); {skip over whitespace}
                   delete(instr,fromcp,cp - fromcp);
                   cp := fromcp;
                   show_string;
                 end;

    backspace:   {delete the previous character}
                 if cp > 1 then
                   begin
                     dec(cp);
                     delete(instr,cp,1);
                     show_string;
                   end;

    del_char:    {delete character}
                 begin
                   delete(instr,cp,1);
                   show_string;
                 end;

    escapefrom:  begin
                   escaped := true;
                   restore_string;
                   cp := firstcp;
                   show_cursor;
                 end;

    carriage_return: begin
                       validate_field;
                       if finished then
                         cp := 1;
                     end;

    reset:       If ValidationOverride then
                   begin
                     for I := 1 to maxstrlen do
                       chartype[I] := AnyCharacter;
                     mandatory := false;
                     fixed_length := false;
                     {or.. ValidateOff := true}
                     info2(Validation_suspended)
                   end
                 else error2(No_privilege);

    post_letter: begin
                   letter := chr(asciicode);

                   if charcase[cp] then
                     letter := upcase(letter);

                   if (letter in CharacterSet[chartype[cp]].CharSet) or
                     (chartype[cp] = AnyCharacter) or PasswordField then
                     enter_a_letter(letter)
                   else error2(CharacterSet[chartype[cp]].CharacterSetName
                               + CharacterWord + RequiredWord);
                 end;

    enter_default: validate_field;

{
  Customise the following list as required
}
    help,
    abort:       begin
                   restore_string;
                   finished := true;
                 end;

    upchar:      if not StringIsContiguous and (cp > 1) then
                   begin
                     breaks := 0;
                     line_offset := 0;

                     while (cp > 1) and (breaks < 2) do
                       begin
                         if charpos[cp] - charpos[pred(cp)] > 1 then
                            inc(breaks)
                         else if breaks = 0 then
                           inc(line_offset);
                         if breaks < 2 then
                           dec(cp);
                       end;

                     if breaks > 0 then
                       while line_offset > 0 do
                         begin
                           inc(cp);
                           dec(line_offset);
                         end;

                   end

                 else restore_and_validate;


    downchar:    if not StringIsContiguous and (cp < maxstrlen) then
                   begin
                     breaks := 0;
                     line_offset := 0;

                     while (cp < maxstrlen) and (breaks < 2) do
                       begin
                         if charpos[succ(cp)] - charpos[cp] > 1 then
                            inc(breaks)
                         else if breaks = 0 then
                           inc(line_offset);
                         if breaks < 2 then
                           inc(cp);
                       end;

                     if breaks > 0 then
                       while line_offset > 0 do
                         begin
                           dec(cp);
                           dec(line_offset);
                         end;

                   end

                 else restore_and_validate;


    pageup,
    scrollup,
    goto_top:      restore_and_validate;

    pagedown,
    scrolldown,
    goto_bottom:   restore_and_validate;

    tabback,
    del_block,
    restore_block,
    exit_screen,
    quit:
                   restore_and_validate; {cp unchanged}
  end; {case}

  if (cp <> oldcp) or (attr <> cursor_attr) then
    gotocp(cp); {move cursor}
  oldcp := cp;
end;


begin {getstring}

  instr := copy(instr,1,maxstrlen); {discard anything beyond max string length}
  setup_picture_attributes;  {locks insert if validation is position dependent}

  display_prompt(str_prompt,atr,atc,pattr,minW(SizeOfSubstring1,maxstrlen));

{
  turn locations from offsets to absolute values for speed
}

  for I := 1 to maxstrlen do
    inc(charpos[I],atc);

  for I := 1 to NumberOfMarkers do
    inc(fmarray[I].location,atc);

  finished := false; { used in show_string must be initialized }
  escaped  := false; { ditto }

  if EditingString then {prevents resetting cp when just painting fields}
     begin
       original_string := '';
       show_string; {oldcp set to 0 here forces cursor position update}

       mandatory    := (status and $01) > 0;
       fixed_length := (status and $02) > 0;
       ValidateOff  := (not mandatory) and (not fixed_length) and PictureAllX;

       original_string := instr;  {backup, NB must follow show_string above}
       OldOverwrite := overwrite; { " }
       overwrite := overwrite or LocalInsLock;

       if (cp > length(instr)) or (cp > maxstrlen) then
         {set cp to 1 if instr is blank, else set cp to length + 1 if possible}
         cp := minW( maxW(succ(length(instr)),1), maxstrlen);
       {else cp unchanged}
       show_cursor;
       firstcp := cp; {this should follow preceding if}

       repeat
         get_input
       until finished or escaped;

      if (not escaped) and top_n_tail then
        instr := trim(instr);

      overwrite := OldOverwrite;
    end;

  show_string; {needed even if string unchanged, to change attribute}

  clearerror2;
  SetCursor(CursorOff);
end;