home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / TP-UTIL.ARK / GETSTRIN.SRC < prev    next >
Text File  |  1986-01-06  |  4KB  |  107 lines
  1. PROCEDURE GETSTRING(    X,Y      : INTEGER;
  2.                     VAR XSTRING  : STRING80;
  3.                         MAXLEN   : INTEGER;
  4.                         CAPSLOCK : BOOLEAN;
  5.                         NUMERIC  : BOOLEAN;
  6.                         GET_REAL : BOOLEAN;
  7.                     VAR RVALUE   : REAL;
  8.                     VAR IVALUE   : INTEGER;
  9.                     VAR ERROR    : INTEGER;
  10.                     VAR ESCAPE   : BOOLEAN);
  11.  
  12.  
  13. VAR I,J        : INTEGER;
  14.     CH         : CHAR;
  15.     CURSOR     : CHAR;
  16.     DOT        : CHAR;
  17.     BLENGTH    : BYTE;
  18.     CLEARIT    : STRING80;
  19.     WORKER     : STRING80;
  20.     PRINTABLES : SET OF CHAR;
  21.     LOWERCASE  : SET OF CHAR;
  22.     NUMERICS   : SET OF CHAR;
  23.     CR         : BOOLEAN;
  24.  
  25.  
  26. BEGIN
  27.   PRINTABLES := [' '..'}'];               { Init sets }
  28.   LOWERCASE  := ['a'..'z'];
  29.   IF GET_REAL THEN NUMERICS := ['-','.','0'..'9','E','e']
  30.     ELSE NUMERICS := ['-','0'..'9'];
  31.   CURSOR := '_'; DOT := '.';
  32.   CR := FALSE; ESCAPE := FALSE;
  33.   FILLCHAR(CLEARIT,SIZEOF(CLEARIT),'.');  { Filex clear string  }
  34.   CLEARIT[0] := CHR(MAXLEN);              { Set clear string to MAXLEN }
  35.  
  36.                                 { Convert numbers to string if required:  }
  37.   IF NUMERIC THEN               { Convert zero values to null string: }
  38.     IF (GET_REAL AND (RVALUE = 0.0)) OR
  39.        (NOT GET_REAL AND (IVALUE = 0)) THEN XSTRING := ''
  40.     ELSE                        { Convert nonzero values to string equiv: }
  41.       IF GET_REAL THEN STR(RVALUE:MAXLEN,XSTRING)
  42.         ELSE STR(IVALUE:MAXLEN,XSTRING);
  43.  
  44.                                           { Truncate string value to MAXLEN }
  45.   IF LENGTH(XSTRING) > MAXLEN THEN XSTRING[0] := CHR(MAXLEN);
  46.   GOTOXY(X,Y); WRITE('|',CLEARIT,'|');    { Draw the field  }
  47.   GOTOXY(X+1,Y); WRITE(XSTRING);
  48.   IF LENGTH(XSTRING)<MAXLEN THEN
  49.     BEGIN
  50.       GOTOXY(X + LENGTH(XSTRING) + 1,Y);
  51.       WRITE(CURSOR)                       { Draw the cursor }
  52.     END;
  53.   WORKER := XSTRING;      { Fill work string with input string     }
  54.  
  55.   REPEAT                  { Until ESC or (CR) entered }
  56.                           { Wait here for keypress:   }
  57.     WHILE NOT KEYSTAT(CH) DO BEGIN {NULL} END;
  58.  
  59.     IF CH IN PRINTABLES THEN              { If CH is printable... }
  60.       IF LENGTH(WORKER) >= MAXLEN THEN BEEP ELSE
  61.         IF NUMERIC AND (NOT (CH IN NUMERICS)) THEN BEEP ELSE
  62.           BEGIN
  63.             IF CH IN LOWERCASE THEN IF CAPSLOCK THEN CH := CHR(ORD(CH)-32);
  64.             WORKER := CONCAT(WORKER,CH);
  65.             GOTOXY(X+1,Y); WRITE(WORKER);
  66.             IF LENGTH(WORKER) < MAXLEN THEN WRITE(CURSOR)
  67.           END
  68.     ELSE   { If CH is NOT printable... }
  69.       CASE ORD(CH) OF
  70.        8,127 : IF LENGTH(WORKER) <= 0 THEN BEEP ELSE
  71.                   BEGIN
  72.                     DELETE(WORKER,LENGTH(WORKER),1);
  73.                     GOTOXY(X+1,Y); WRITE(WORKER,CURSOR);
  74.                     IF LENGTH(WORKER)<MAXLEN-1 THEN WRITE(DOT);
  75.                   END;
  76.  
  77.        13 : CR := TRUE;          { Carriage return }
  78.  
  79.        24 : BEGIN                { CTRL-X : Blank the field }
  80.               GOTOXY(X+1,Y); WRITE(CLEARIT);
  81.               WORKER := '';      { Blank out work string }
  82.             END;
  83.  
  84.        27 : ESCAPE := TRUE;      { ESC }
  85.        ELSE BEEP                 { CASE ELSE }
  86.     END; { CASE }
  87.  
  88.   UNTIL CR OR ESCAPE;            { Get keypresses until (CR) or }
  89.                                  { ESC pressed }
  90.   GOTOXY(X+1,Y); WRITE(CLEARIT);
  91.   GOTOXY(X+1,Y); WRITE(WORKER);
  92.   IF CR THEN                     { Don't update XSTRING if ESC hit }
  93.     BEGIN
  94.       XSTRING := WORKER;
  95.       IF NUMERIC THEN            { Convert string to numeric values }
  96.         CASE GET_REAL OF
  97.           TRUE  : VAL(WORKER,RVALUE,ERROR);
  98.           FALSE : VAL(WORKER,IVALUE,ERROR)
  99.         END { CASE }
  100.       ELSE
  101.         BEGIN
  102.           RVALUE := 0.0;
  103.           IVALUE := 0
  104.         END
  105.     END
  106.  
  107. END;  { GETSTRING }O_S