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 / TBBS22.LBR / TBBSCOM.IQC / TBBSCOM.INC
Text File  |  2000-06-30  |  8KB  |  299 lines
  1. { TBBSCOM.INC - Turbo Bulletin Board System common subroutines }
  2.  
  3. var
  4.   DatF: DataFile;
  5.   IdxF: IndexFile;
  6.  
  7. procedure GetTAD(var t: tad_array); {** THIS ROUTINE IS SYSTEM DEPENDENT **}
  8. { Return a 6 element integer array of the current system time in
  9.   seconds, minutes, hours, day, month, and year. }
  10. var
  11.   i: integer;
  12. begin
  13.   for i := 0 to 5 do
  14.     t[i] := mem[i + $FF7C];
  15.   t[3] := succ(t[3]);
  16.   t[4] := succ(t[4])
  17. end;
  18.  
  19. function intstr(n: integer): StdStr;
  20. { Convert integer to string }
  21. var
  22.   s: StdStr;
  23. begin
  24.   str(n, s);
  25.   intstr := s
  26. end;
  27.  
  28. function intstr0(n: integer): StdStr;
  29. { Convert integer to string - leading '0' }
  30. var
  31.   s: StdStr;
  32. begin
  33.   str(n, s);
  34.   if (length(s) = 1)
  35.     then s := '0' + s;
  36.   intstr0 := s
  37. end;
  38.  
  39. function strint(st: StdStr): integer;
  40. { Convert string to integer }
  41. var
  42.   x, code: integer;
  43. begin
  44.   if st[1] = '+'
  45.     then delete(st, 1, 1);
  46.   if st = ''
  47.     then code := 1
  48.     else val(st, x, code);
  49.   if code = 0
  50.     then strint := x
  51.     else strint := maxint       {error, so return error}
  52. end;
  53.  
  54. function zeller(day, month, year: integer): integer;
  55. { Compute the day of the week using Zeller's Congruence }
  56. var
  57.   century: integer;
  58. begin
  59.   if month > 2
  60.     then month := month - 2
  61.     else
  62.       begin
  63.         month := month + 10;
  64.         year := year - 1
  65.       end;
  66.   century := year div 100;
  67.   year := year mod 100;
  68.   zeller := (day - 1 + ((13 * month - 1) div 5) + (5 * year div 4) +
  69.             century div 4 - 2 * century + 1) mod 7;
  70. end;
  71.  
  72. function systad(t: tad_array): StdStr;
  73. { Format the time and date }
  74. const
  75.   day: array [0..6] of string[6] =
  76.     ('Sun','Mon','Tues','Wednes','Thurs','Fri','Satur');
  77.   month: array [1..12] of string[3] =
  78.     ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
  79. begin
  80.   if t[4] > 0
  81.     then systad := intstr0(t[2]) + ':' + intstr0(t[1]) + '  ' +
  82.       day[zeller(t[3], t[4], t[5] + 1900)] + 'day  ' +
  83.       intstr(t[3]) + '-' + month[t[4]] + '-' + intstr0(t[5])
  84.     else systad := ''
  85. end;
  86.  
  87. procedure getkey(var ch: char; shiftlock: boolean);
  88. { Get key typed at keyboard, no echo }
  89. begin
  90.   read(kbd, ch);
  91.   if eoln(kbd)
  92.     then ch := CR
  93.     else if shiftlock and (ch in ['a'..'z'])
  94.       then ch := UpCase(ch)
  95. end;
  96.  
  97. procedure getstring(var inpstr: StdStr; maxlen: integer; mode: StdStr);
  98. { Get a valid input string from the user }
  99. const
  100.   editset: charset = [BS, RUB, CAN, TAB];
  101.   termset: charset = [LF, CR];
  102.   dispset: charset = [' '..'~'];
  103. var
  104.   autotab, echo, shiftlock: boolean;
  105.   ch: char;
  106.   i, len: integer;
  107. begin
  108.   if maxlen > Max_Str                { ensure length of field is not too big }
  109.     then maxlen := Max_Str;
  110.   autotab   := (pos('A', mode) > 0);
  111.   echo      := (pos('E', mode) > 0);
  112.   shiftlock := (pos('S', mode) > 0);
  113.   inpstr := '';
  114.   len := 0;
  115.   repeat
  116.     getkey(ch, shiftlock);
  117.     if (ch in dispset) and (len <= maxlen)
  118.       then
  119.         begin
  120.           inpstr := inpstr + ch;
  121.           if echo
  122.             then write(ch)
  123.         end
  124.     else if ch = TAB
  125.       then
  126.         repeat
  127.           inpstr := inpstr + ' ';
  128.           if echo
  129.             then write(' ')
  130.         until (0 = length(inpstr) mod 8) or (length(inpstr) >= maxlen)
  131.     else if ((ch = RUB) or (ch = BS)) and (len > 0)
  132.       then
  133.         begin
  134.           delete(inpstr, len, 1);
  135.           if echo
  136.             then write(BS, ' ', BS)
  137.         end
  138.     else if ch = CAN
  139.       then
  140.         begin
  141.           inpstr := '';
  142.           if echo
  143.             then for i := 1 to len do
  144.                    write(BS, ' ', BS)
  145.         end;
  146.     len := length(inpstr)
  147.   until (ch in termset) or ((len >= maxlen) and autotab)
  148.         or ((ch = ' ') and (len >= (maxlen - 6)) and autotab);
  149.   writeln
  150. end;
  151.  
  152. function prompt(st: StdStr; len: integer; mode: StdStr): StdStr;
  153. { Prompt user and get response }
  154. var
  155.   reply: StdStr;
  156. begin
  157.   write(st);
  158.   if bel
  159.     then write(^G);
  160.   getstring(reply, len, mode);
  161.   prompt := reply
  162. end;
  163.  
  164. function ask(st: StdStr): boolean;
  165. { Ask yes-or-no question and return 'true' for 'Y', 'false' otherwise }
  166. begin
  167.   writeln;
  168.   ask := (prompt(st + ' [Y/N]? ', 1, 'AES') = 'Y')
  169. end;
  170.  
  171. procedure pause;
  172. { Pause for user response before continuing }
  173. var
  174.   temp: StdStr;
  175. begin
  176.   writeln;
  177.   temp := prompt('Press any key to continue', 1, 'A')
  178. end;
  179.  
  180. function brk: boolean;
  181. { Check for break or pause. }
  182. var
  183.   ch: char;
  184. begin
  185.   brk := FALSE;
  186.   if keypressed
  187.     then
  188.       begin
  189.         read(Kbd, ch);
  190.         if ch = ^C
  191.           then brk := TRUE
  192.         else if ch = ^S
  193.           then
  194.             repeat
  195.             until keypressed
  196.       end
  197. end;
  198.  
  199. function trim(st: StdStr): StdStr;
  200. { Trim leading and trailing blanks }
  201. var
  202.  i, j: integer;
  203. begin
  204.   i := 1;
  205.   j := length(st);
  206.   while (st[i] = ' ') and (i <= j) do
  207.     i := succ(i);
  208.   while (st[j] = ' ') and (j >= i) do
  209.     j := pred(j);
  210.   trim := copy(st, i, j - i + 1)
  211. end;
  212.  
  213. function pad(line: StdStr; i: integer): StdStr;
  214. { Pad line with spaces to length of i }
  215. begin
  216.   while length(line) < i do
  217.     line := line + ' ';
  218.   pad := line
  219. end;
  220.  
  221. function find_user(fn: firstname; ln: lastname): integer;
  222. { Find location of user in user file.  Return -1 if not found. }
  223. var
  224.   i: integer;
  225. begin
  226.   st := pad(ln, len_ln) + pad(fn, len_fn);
  227.   FindKey(IdxF, i, st);
  228.   if OK
  229.     then find_user := i
  230.     else find_user := -1
  231. end;
  232.  
  233. procedure get_user;
  234. { Get user data from disk }
  235. begin
  236.   GetRec(DatF, user_loc, user_rec);
  237.   with user_rec do
  238.     begin
  239.       used       := user_used;
  240.       fn         := user_firstname;
  241.       ln         := user_lastname;
  242.       ad         := user_address;
  243.       pw         := user_pw;
  244.       bbs_stat   := user_bbs_stat;
  245.       maxdrv     := user_maxdrv;
  246.       maxusr     := user_maxusr;
  247.       status     := user_sys_stat;
  248.       nulls      := user_nulls;
  249.       case_sw    := user_case_sw;
  250.       laston     := user_laston;
  251.       time_today := user_time_today;
  252.       time_total := user_time_total;
  253.       lasthi     := user_lasthi;
  254.       upload     := user_up;
  255.       download   := user_down
  256.     end
  257. end;
  258.  
  259. procedure put_user;
  260. { Put user data to disk }
  261. begin
  262.   with user_rec do
  263.     begin
  264.       user_used       := used;
  265.       user_firstname  := fn;
  266.       user_lastname   := ln;
  267.       user_address    := ad;
  268.       user_pw         := pw;
  269.       user_bbs_stat   := bbs_stat;
  270.       user_maxdrv     := maxdrv;
  271.       user_maxusr     := maxusr;
  272.       user_sys_stat   := status;
  273.       user_nulls      := nulls;
  274.       user_case_sw    := case_sw;
  275.       user_laston     := laston;
  276.       user_time_today := time_today;
  277.       user_time_total := time_total;
  278.       user_lasthi     := lasthi;
  279.       user_up         := upload;
  280.       user_down       := download
  281.     end;
  282.   PutRec(DatF, user_loc, user_rec);
  283.   CloseFile(DatF);           { in case user hangs up }
  284.   OpenFile(DatF, user_data + ext, SizeOf(user_rec))
  285. end;
  286.  
  287. procedure add_user;
  288. { Add dummy user record to disk }
  289. begin
  290.   AddRec(DatF, user_loc, user_rec);
  291.   AddKey(IdxF, user_loc, st);
  292.   CloseIndex(IdxF);          { in case user hangs up }
  293.   CloseFile(DatF);
  294.   InitIndex;                 { not documented, but seems necessary }
  295.   OpenFile(DatF, user_data + ext, SizeOf(user_rec));
  296.   if OK
  297.     then OpenIndex(IdxF, user_indx + ext, len_ln + len_fn, 0)
  298. end;
  299.