home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 December / simtel1292_SIMTEL_1292_Walnut_Creek.iso / msdos / turbopas / turbogen.arc / LIBRARY2.GEN < prev    next >
Text File  |  1988-01-27  |  22KB  |  589 lines
  1. (*-----------------------------------------------------------------*)
  2. (*         Beep  --- Make some noise                               *)
  3. (*-----------------------------------------------------------------*)
  4.  
  5. Procedure Beep(numbertodo,pitch, duration:Integer);
  6. Const
  7. delaylength  = 200;
  8. defaultnumb  = 3;
  9. defaultpitch = 448;
  10. defaultdur   = 250;
  11.  
  12. Var
  13. j : Integer;
  14.  
  15. Begin
  16.    If numbertodo < 1 Then numbertodo := defaultnumb;
  17.    If pitch < 1 Then pitch := defaultpitch;
  18.    If duration < 1 Then duration:=defaultdur;
  19.    If numbertodo > 0 Then For j := 1 To numbertodo Do
  20.    Begin
  21.       Sound(pitch);
  22.       Delay(duration);
  23.       Nosound;
  24.       Delay(delaylength)
  25.    End
  26. End;
  27.  
  28. (*-----------------------------------------------------------------*)
  29. (*               Ljust --- Left Justify string (same length)       *)
  30. (*-----------------------------------------------------------------*)
  31.  
  32. FUNCTION Ljust( S : AnyStr ) : AnyStr;
  33.  
  34. (*-----------------------------------------------------------------*)
  35. (*                                                                 *)
  36. (*     Purpose:    Set data field characters to left of string     *)
  37. (*                 for getstring input utility                     *)
  38. (*                                                                 *)
  39. (*     Calling sequence:                                           *)
  40. (*                                                                 *)
  41. (*         LJust_S := Ljust( S );                                  *)
  42. (*                                                                 *)
  43. (*            S           --- the string to be trimmed             *)
  44. (*                                                                 *)
  45. (*     Calls:  None                                                *)
  46. (*                                                                 *)
  47. (*     Remarks:                                                    *)
  48. (*                                                                 *)
  49. (*        Using same string on each side of calling arg will alter *)
  50. (*        source using different name will leave source unchanged  *)
  51. (*-----------------------------------------------------------------*)
  52.  
  53. VAR
  54.    I:       INTEGER;
  55.    Trimmed: BOOLEAN;
  56.    L:       INTEGER;
  57.  
  58. BEGIN (* Ljust *)
  59.    Ljust := '';
  60.    IF LENGTH( S ) > 0 THEN
  61.       BEGIN
  62.          I       := 0;
  63.          L       := LENGTH( S );
  64.          Trimmed := FALSE;
  65.          REPEAT
  66.             I := I + 1;
  67.             IF ( I <= L ) THEN
  68.                Trimmed := S[I] <> ' '
  69.             ELSE
  70.                Trimmed := TRUE;
  71.          UNTIL Trimmed;
  72.          IF ( ( L - I + 1 ) > 0 ) THEN
  73.             Ljust := concat( Copy( S,I,L-I+1), Copy( S,1,I-1));
  74.       END;
  75. END   (* Ljust *);
  76.  
  77.  
  78. (*-----------------------------------------------------------------*)
  79. (*               Trim --- Drop trailing spaces from anystring var  *)
  80. (*-----------------------------------------------------------------*)
  81. Function Trim(var S:anystr):anystr;
  82.  
  83. begin
  84.   I := length(s);
  85.   while (I > 0) and (s[i] = ' ') do
  86.     i := i-1;
  87.     if i = 0 then trim := '' else trim := copy(s,1,i);
  88. end;
  89.  
  90.  
  91. (*-----------------------------------------------------------------*)
  92. (*                                                                 *)
  93. (*    copyright (C) 1984 by Neil J. Rubenking                      *)
  94. (*                                                                 *)
  95. (* The purchaser of these procedures and functions may include     *)
  96. (* them in COMPILED programs freely, but may not sell or give away *)
  97. (* the source text.                                                *)
  98. (*                                                                 *)
  99. (* This function uses the keyboard BIOS interrupt $16 (decimal 22).*)
  100. (* If "action" is 'W', the function WAITS until a key is pressed   *)
  101. (* and then returns it.  If action is 'N' there is NO WAIT, and a  *)
  102. (* character is returned only if there is one in the buffer.       *)
  103. (* (This is more-or-less equivalent to using TURBO's boolean       *)
  104. (* "keypressed" function and "read(Kbd)". If the key pressed has   *)
  105. (* an "extended" scan code (e.g., function keys, arrow keys) the   *)
  106. (* ASCIIcode will be 0.                                            *)
  107. (*                                                                 *)
  108. (* This function does NOT recognize characters generated by        *)
  109. (* pressing the ALT key and typing in numbers.                     *)
  110. (*                                                                 *)
  111. (* NOTE that any program that INCLUDEs this file MUST also include *)
  112. (* the type declarations contained in Globtype.gen                 *)
  113. (*                                                                 *)
  114. (*-----------------------------------------------------------------*)
  115. (*                                                                 *)
  116. (*  Modifications of 7/87 to allow real time function key event    *)
  117. (*  processing. (Bob Logan)                                        *)
  118. (*                                                                 *)
  119. (*-----------------------------------------------------------------*)
  120.  
  121. function KeyBoard(action : char):integer;
  122.  
  123. var
  124.   registers : regpack;
  125.   temp      : integer;
  126. begin
  127.   with registers do
  128.     begin
  129.       case UpCase(action) of
  130.         'W': AX := 0 ;
  131.         'N': AX := 1 shl 8;
  132.       end;
  133.     intr($16,registers);
  134.     if action = 'N' then
  135.       if flags and 64 = 64 then  {zero flag set means no character}
  136.         temp := 0
  137.       else temp := KeyBoard('W')
  138.     else temp := AX;
  139.     KeyBoard := temp;
  140.   end;
  141. end;
  142.  
  143. (*-----------------------------------------------------------------*)
  144. (*  READS AND RETURNS A STRING NAMING THE KEY PRESSED              *)
  145. (*-----------------------------------------------------------------*)
  146.  
  147. type
  148.   KeyType = string[12];
  149.  
  150. Const
  151.   funcount  = 47;
  152.   funkeys             : Array[1..funcount] of KeyType =
  153.                 ('F1','F2','F3','F4','F5','F6','F7','F8','F9','F10',
  154.                  'Ctrl-F1','Ctrl-F2','Ctrl-F3','Ctrl-F4','Ctrl-F5',
  155.                  'Ctrl-F6','Ctrl-F7','Ctrl-F8','Ctrl-F9','Ctrl-F10',
  156.                  'Shift-F1','Shift-F2','Shift-F3','Shift-F4','Shift-F5',
  157.                  'Shift-F6','Shift-F7','Shift-F8','Shift-F9','Shift-F10',
  158.                  'Alt-F1','Alt-F2','Alt-F3','Alt-F4','Alt-F5',
  159.                  'Alt-F6','Alt-F7','Alt-F8','Alt-F9','Alt-F10','End',
  160.                  'Up','Home','Ctrl-Home','Crtl-PrtSc','Esc','Return'
  161.                 );
  162.  
  163. var
  164.   KeyValue            : integer;
  165.   ASCIIcode, ScanCode : byte;
  166.   Result              : KeyType;
  167.  
  168.  
  169. Function Is_funkey : Boolean;
  170.  Var i : integer;
  171. begin
  172.   Is_Funkey := False;
  173.   For i := 1 to funcount do
  174.    if result = funkeys[I] then
  175.    Is_Funkey := True;
  176. end;
  177.  
  178.  
  179. function Read_Keyboard(wait_flag:char): KeyType;
  180. var
  181.   TempRead : KeyType;
  182.   P        : integer; {error pos on val call in function handler }
  183.  
  184. function SpecialKey(Code:byte):KeyType;
  185. const
  186.   Row0 : KeyType = '1234567890-=';
  187.   Row1 : KeyType = 'QWERTYUIOP';
  188.   Row2 : KeyType = 'ASDFGHJKL';
  189.   Row3 : KeyType = 'ZXCVBNM';
  190. var
  191.   temp : KeyType;
  192. begin
  193. case code of
  194.        14: temp := 'BackSpace';
  195.        15: temp := 'Back Tab';
  196.    16..25: temp := 'Alt-' + Row1[code-15];
  197.    30..38: temp := 'Alt-' + Row2[code-29];
  198.    44..50: temp := 'Alt-' + Row3[code-43];
  199.  120..131: temp := 'Alt-' + Row0[code-119];
  200.    59..67: temp := 'F' + chr(code - 10);
  201.        68: temp := 'F10';
  202.    84..92: temp := 'Shift F' + chr(code-35);
  203.        93: temp := 'Shift F10';
  204.   94..102: temp := 'Ctrl-F' + chr(code-45);
  205.       103: temp := 'Ctrl-F10';
  206.  104..112: temp := 'Alt-F' + chr(code-55);
  207.       113: temp := 'Alt-F10';
  208.        71: temp := 'Home';
  209.        72: temp := 'Up';
  210.        73: temp := 'PgUp';
  211.        75: temp := 'Left';
  212.        77: temp := 'Right';
  213.        79: temp := 'End';
  214.        80: temp := 'Down';
  215.        81: temp := 'PgDn';
  216.        82: temp := 'Ins';
  217.        83: temp := 'Del';
  218.       114: temp := 'Ctrl-PrtSc';
  219.       115: temp := 'Ctrl-Left';
  220.       116: temp := 'Ctrl-Right';
  221.       117: temp := 'Ctrl-End';
  222.       118: temp := 'Ctrl-PgDn';
  223.       119: temp := 'Ctrl-Home';
  224.       132: temp := 'Ctrl-PgUp';
  225.  else
  226.    temp := 'Ctrl-Break';
  227.  end;  {case}
  228. SpecialKey := temp;
  229. end;
  230.  
  231. function SpecChr(code:byte):KeyType;
  232.  
  233. begin
  234.   case code of
  235.      0..26 : SpecChr := 'Ctrl-' + chr(code + 64);
  236.         27 : SpecChr := 'Esc';
  237.    28..255 : SpecChr := chr(code);
  238.   end;
  239. end;
  240.  
  241. begin
  242.     KeyValue  := KeyBoard(Wait_Flag);
  243.     ScanCode  := KeyValue shr 8;
  244.     ASCIICode := (KeyValue shl 8) shr 8;
  245.        {The special keys that have no ASCII character generate }
  246.        {a zero in place of the code.  However, there are three }
  247.        {non-printable characters that DO have an ASCII code.   }
  248.        {Their scan codes are 14, 15, and 28.  We provide for   }
  249.        {them below.                                            }
  250.  
  251.     if (not (ScanCode in [14,15,28])) and (ASCIICode <> 0)  then
  252.       TempRead := SpecChr(ASCIICode)
  253.     else
  254.       begin
  255. if ASCIICode <> 0 then
  256.   begin
  257.     case ScanCode of
  258.       14: TempRead := 'BackSpace';
  259.       15: TempRead := 'Tab';
  260.       28: TempRead := 'Return';
  261.     end;  {case}
  262.   end  {second if}
  263.       else
  264.     TempRead := SpecialKey(ScanCode);
  265.       end;  {the upper else}
  266.    Read_Keyboard := TempRead;
  267. end;
  268.  
  269. Procedure Show_Error( Error_Number:integer);
  270.   { this is still a good idea it just has gotten out of hand }
  271.  
  272.  
  273. (*--------------------------------------------------------------------------*)
  274. (*                                                                          *)
  275. (*     Procedure: Show_Error                                                *)
  276. (*                                                                          *)
  277. (*     Purpose:    Display user generated error conditions during           *)
  278. (*                 data entry                                               *)
  279. (*                                                                          *)
  280. (*     Calling sequence:                                                    *)
  281. (*                                                                          *)
  282. (*        Show_Error ( Error_Number : Integer );                            *)
  283. (*                                                                          *)
  284. (*                                                                          *)
  285. (*     Calls:  Beep                                                         *)
  286. (*             Save_Screen                                                  *)
  287. (*             Draw_menu_Frame                                              *)
  288. (*             Restore_Screen                                               *)
  289. (*                                                                          *)
  290. (*     Remarks:                                                             *)
  291. (*             Error list:                                                  *)
  292. (*                         1 : Past end of field length                     *)
  293. (*                         2 : Non_Numeric character during numeric entry   *)
  294. (*                         3 : Past beginning of field on left              *)
  295. (*                         4                                                *)
  296. (*                         5                                                *)
  297. (*                         6                                                *)
  298. (*                         7                                                *)
  299. (*                         8                                                *)
  300. (*                         9                                                *)
  301. (*                                                                          *)
  302. (*     As you have already noted justd add to the list below for your       *)
  303. (*     application dependent errors and call here                           *)
  304. (*                                                                          *)
  305. (*--------------------------------------------------------------------------*)
  306.  
  307. VAR
  308.        title    : String[30];
  309.        msg      : string[78];
  310.        I        : BYTE;
  311.        J        : BYTE;
  312.        save_C25 : PACKED ARRAY[1..80] OF CHAR;
  313.        save_A25 : PACKED ARRAY[1..80] OF INTEGER;
  314.        cx,cy    : integer;
  315.  
  316. BEGIN {Show_Error}
  317.  
  318. Case error_number of
  319.   20 : title := 'Status Report';
  320.   12 : title := 'Attention';
  321. ELSE
  322.        title := 'Data Entry Error ';
  323. END;
  324.  
  325. case error_number of
  326.   1: msg:= 'Attempt to move past end of field ';
  327.   2: msg:= 'Bad Key Stroke Numeric data only';
  328.   3: msg:= 'Attempt to move past start of field';
  329.   5: msg:= 'Zero is not acceptable';
  330.  15: msg:= 'Unable to figure cost per ton...Please enter...';
  331.  20: msg:= 'Selected Process is complete....';
  332. ELSE
  333.   msg:='Unknown data entry error';
  334. END {case};
  335.    cx := WhereX;
  336.    cy := WhereY;
  337.    msg := Title +'-->'+msg+' Press <Esc>';
  338.                             (* Line 25, Column 1 *)
  339.    Turbo_window(1,1,80,25);
  340.    GotoXY(1,25); ClrEol; GotoXy(Trunc((80-Length(Msg))/2),25);
  341.    textColor(White+Blink);
  342.    Write(msg);
  343.    Reset_Global_Colors;
  344.    beep(1,600,150);
  345.    repeat until Read_Keyboard('W') = 'Esc';
  346.                             (* Restore previous text *)
  347.    gotoXY(1,25);
  348.    clrEol;
  349.    Turbo_window(Upper_Left_Column, Upper_Left_Row, Lower_Right_Column, Lower_right_Row);
  350.    gotoXY(Cx,Cy);
  351. END {Get_Error};
  352.  
  353.  
  354. function Ioerror :byte;
  355.  
  356. Var
  357.   Code:byte;
  358.   Msg :string[40];
  359.  
  360. begin
  361.   Code := ioresult;
  362.   if Code = 0 then
  363.     begin
  364.        IoError := Code;
  365.        exit;
  366.     end;
  367.  
  368.   case Code of
  369.     $01 : Msg := 'File not found.';
  370.     $02 : Msg := 'File not open for reading.';
  371.     $03 : Msg := 'File not open for writing.';
  372.     $04 : Msg := 'File not reset or rewriten.';
  373.     $10 : Msg := 'Illegal numeric format in data.';
  374.     $20 : Msg := 'illegal operation for a logical device.';
  375.     $21 : Msg := 'Illegal operation in direct mode. ';
  376.     $22 : Msg := 'Illegal to assign to standard file';
  377.     $90 : Msg := 'unmatched record lengths.';
  378.     $91 : Msg := 'End of file encountered.';
  379.     $99 : Msg := 'Unexpected End of file encountered.';
  380.     $F0 : Msg := 'Disk Full.';
  381.     $F1 : Msg := 'Directory Full.';
  382.     $F2 : Msg := 'File Size overrun(65535 records)';
  383.     $F3 : Msg := 'To many files open.';
  384.     $F4 : Msg := 'File no longer in directory....';
  385.   else
  386.      Msg := '** unknown I/O error encountered **'
  387.   end;
  388.   (*  modify to use windows like above *)
  389.   writeln('** I/O error encountered. **');
  390.   writeln('** error code = ',COde);
  391.   writeln('** ', Msg);
  392.   IoError := Code
  393. end;
  394.  
  395. (*-----------------------------------------------------------------*)
  396. (*                                                                 *)
  397. (*  GetString   : all purpose data entry utility                   *)
  398. (*                                                                 *)
  399. (*  This utility is used to interface with the user. It allows     *)
  400. (*  event trapping during entry of all data type for pascal.       *)
  401. (*  Cursor movement is controled (within the current data item)    *)
  402. (*  Screen highlighting is controled by colors passed to utility.  *)
  403. (*  Forcing the operator to signal entry complete is controled by  *)
  404. (*  the confirm flag. set true to force user to press RETURN or    *)
  405. (*  TAB to exit current field otherwise field is exited when n     *)
  406. (*  allowable charcters are entered. User may press RETURN or TAB  *)
  407. (*  at any time before n chars are input.  The current field       *)
  408. (*  contents are displayed and if RETURN or TAB ar pressed first   *)
  409. (*  the current contents are left untouched.                       *)
  410. (*                                                                 *)
  411. (*  Cursor control keys are:                                       *)
  412. (*           Left one character  : Left Arrrow,Backspace,Del       *)
  413. (*                                 (non-destructive)               *)
  414. (*           Right one character : Right Arrow                     *)
  415. (*           Clear field (from current cursor location to end      *)
  416. (*                        of field )  : Ctrl-End                   *)
  417. (*                                                                 *)
  418. (*-----------------------------------------------------------------*)
  419. (*  This utility was adabted from COMPLETE TURBO PASCAL  by        *)
  420. (*                                Jeff Duntemann                   *)
  421. (*                                                                 *)
  422. (*    CALLS:  After modification by Bob Logan the utility makes    *)
  423. (*            the folowing calls:                                  *)
  424. (*                                                                 *)
  425. (*              Ljust        - Left justify a string               *)
  426. (*              Read_Keyboard- FancyKey-Public Domain utility by   *)
  427. (*                             Neil J. Rubenfing which returns the *)
  428. (*                             name of keypressed                  *)
  429. (*              Show_Error   - Displays error condition (Windows)  *)
  430. (*                                                                 *)
  431. (*  Note : You must have delcared a string type of str80 which is  *)
  432. (*         string[80].                                             *)
  433. (*                                                                 *)
  434. (*-----------------------------------------------------------------*)
  435. (*  7/87  function key support (see read_keyboard) modifications-- *)
  436. (*   pressing any function key has same effect on field contents   *)
  437. (*   as pressing TAB.  Calling proc then tests for functions as it *)
  438. (*   sees fit.   If function key created exit from field then same *)
  439. (*   field should be reentered after processing function key.      *)
  440. (*-----------------------------------------------------------------*)
  441.  
  442. Procedure getstring(
  443. x,y            : Integer ;  (* x y screen cords *)
  444. Var  xstring   : str80   ;  (* default string   *)
  445. maxlen         : Integer ;  (* number of keystrokes to allow *)
  446. capslock       : Boolean ;  (* force to uppercase YN *)
  447. numeric        : Boolean ;  (* string or numeric result *)
  448. get_real       : Boolean ;  (* if numeric real or integer result *)
  449. Var rvalue     : Real    ;  (* real value *)
  450. Var ivalue     : Integer ;  (* integer value *)
  451. Var error      : Integer ;  (* string to numeric error location *)
  452. active_color   : Integer ;  (* input string color *)
  453. inactive_color : Integer ;  (* color for field after input *)
  454. dec            : Integer ;  (* number of decimals for real values *)
  455. confirm        : Boolean    (* force return - or count chars for done *)
  456. );
  457.  
  458. Var
  459. i           : Integer;
  460. ch          : Char;
  461. fill        : Char;
  462. clearit     : str80;
  463. worker      : str80;
  464. printables  : Set Of Char;
  465. lowercase   : Set Of Char;
  466. numerics    : Set Of Char;
  467. cr,do_ins   : Boolean;
  468.  
  469. Begin
  470.    printables := [' '..'}'];
  471.    lowercase  := ['a'..'z'];
  472.    do_ins := false;
  473.    If get_real Then numerics := ['-','.','0'..'9','E','e']
  474.    Else numerics := ['-','0'..'9'];
  475.    fill   := '_';
  476.    cr     := False;
  477.  
  478.    For i := 1 To maxlen Do clearit[i] := fill;
  479.  
  480.    clearit[0] := Chr(maxlen);
  481.    If Length(xstring) > maxlen Then xstring[0] := Chr(maxlen);
  482.    If numeric Then
  483.    If get_real Then
  484.    Str(rvalue:maxlen:dec,xstring)
  485.    Else
  486.    Str(ivalue:maxlen,xstring);
  487.    xstring:=ljust(xstring);
  488.  
  489.    Textcolor(active_color);
  490.    Gotoxy(x,y); Write(clearit);
  491.    Gotoxy(x,y); Write(xstring);
  492.    Gotoxy(x,y);
  493.    worker := '';
  494.  
  495.    Repeat
  496.       ch:=Chr(0);
  497.       result := read_keyboard('W');
  498.       If Length(result) = 1 Then
  499.       ch:= result[1];
  500.       i:= wherex;
  501.       If ch In printables Then
  502.       If Length(worker) >= maxlen Then
  503.       show_error(1)
  504.       Else
  505.       If numeric And (Not (ch In numerics)) Then
  506.       show_error(2)
  507.       Else
  508.       Begin
  509.          If ch In lowercase Then
  510.          If capslock Then
  511.          ch := Chr(Ord(ch)-32);
  512.          if not do_ins then delete(worker,wherex-x+1,1);
  513.          insert(ch,worker,wherex-x+1);
  514.          Gotoxy(x,y);Write(worker);
  515.          gotoxy(i+1,y);
  516.          If (Length(worker) = maxlen) And (Not confirm) Then cr := True;
  517.       End
  518.       Else { CHAR NOT IN PRINTABLES}
  519.  
  520.       If (result = 'Left') or (result = 'Backspace')then
  521.       begin
  522.        If Wherex = x then
  523.         result := 'Up'
  524.        else
  525.         GotoXY(wherex-1,y);
  526.       end;
  527.  
  528.       If Result = 'Ins' then  do_ins := (not do_ins);
  529.  
  530.       If (result = 'Del') and (Length(worker) > 0) Then
  531.       Begin
  532.          Delete(worker,i-x+1,1) ;
  533.          Gotoxy(x,y); Write(clearit);
  534.          Gotoxy(x,y);
  535.          Write(worker);
  536.          Gotoxy(i,y);
  537.       End;
  538.  
  539. {                  Now check for tab or special function key and }
  540. {                  force carriage return if so                   }
  541.  
  542.       If (is_funkey) or (result = 'Tab') or (result = 'Down')  Then
  543.       Begin
  544.         if    worker = '' then worker := xstring;
  545.         cr := True;
  546.       End;
  547.  
  548.       If result = 'Ctrl-End' Then
  549.       Begin         { CTRL-END - BLANK OUT THE FIELD }
  550.          {           from current cursor position to }
  551.          {           end of field                    }
  552.          if i > x then worker[0] := chr(i-x) else worker[0] := chr(0);
  553.          xstring := worker;
  554.          Gotoxy(x,y); Write(clearit);
  555.          Gotoxy(x,y); Write(worker); Gotoxy(i,y);
  556.       End;
  557.  
  558.       If result = 'Right' Then
  559.       If (Length(worker)>=maxlen) Then
  560.       begin
  561.         if    worker = '' then worker := xstring;
  562.         if Not Confirm then cr := true;
  563.       End Else
  564.       Begin
  565.          i:= Length(worker)+1;
  566.          worker := Concat(worker,xstring[i]);
  567.          Gotoxy(Wherex+1,y)
  568.       End;
  569.    Until cr;
  570.  
  571.    Textcolor(inactive_color);
  572.    Gotoxy(x,y); Write(clearit);
  573.    Gotoxy(x,y); Write(worker);
  574.    If cr Then
  575.    Begin
  576.       xstring := ljust(worker);
  577.       If numeric Then
  578.       Case get_real Of
  579.          True  : Val(worker,rvalue,error);
  580.          False : Val(worker,ivalue,error)
  581.       End {CASE}
  582.    End
  583.    Else
  584.    Begin
  585.       rvalue := 0.0;
  586.       ivalue := 0
  587.    End;
  588. End; {GETSTRING}
  589.