home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 341.img / TCS161S.ZIP / FLAGS.PAS < prev    next >
Pascal/Delphi Source File  |  1989-02-24  |  1KB  |  61 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit flags;
  5.  
  6. interface
  7.  
  8. uses gentypes,subs1;
  9.  
  10. const accessstr:array [accesstype] of string[8]=
  11.         ('By level','Keep out','Let in','');
  12.  
  13. procedure setuseraccflag (var u:userrec; bn:integer; ac:accesstype);
  14. function getuseraccflag (var u:userrec; bn:integer):accesstype;
  15. procedure setallflags (bn:integer; ac:accesstype);
  16. procedure setalluserflags (var u:userrec; ac:accesstype);
  17.  
  18. implementation
  19.  
  20. procedure setuseraccflag (var u:userrec; bn:integer; ac:accesstype);
  21. begin
  22.   if (ord(ac) and 1)=1
  23.     then u.access1:=u.access1+[bn]
  24.     else u.access1:=u.access1-[bn];
  25.   if (ord(ac) and 2)=2
  26.     then u.access2:=u.access2+[bn]
  27.     else u.access2:=u.access2-[bn]
  28. end;
  29.  
  30. function getuseraccflag (var u:userrec; bn:integer):accesstype;
  31. var ac:accesstype;
  32. begin
  33.   getuseraccflag:=accesstype(ord(bn in u.access1) or
  34.                              (ord(bn in u.access2) shl 1))
  35. end;
  36.  
  37. procedure setallflags (bn:integer; ac:accesstype);
  38. var cnt:integer;
  39.     u:userrec;
  40. begin
  41.   for cnt:=1 to filesize(ufile)-1 do begin
  42.     seek (ufile,cnt);
  43.     read (ufile,u);
  44.     setuseraccflag (u,bn,ac);
  45.     seek (ufile,cnt);
  46.     write (ufile,u)
  47.   end
  48. end;
  49.  
  50. procedure setalluserflags (var u:userrec; ac:accesstype);
  51. var b1,b2:byte;
  52. begin
  53.   b1:=(ord(ac) and 1)*255;
  54.   b2:=((ord(ac) and 2) shr 1)*255;
  55.   fillchar (u.access1,32,b1);
  56.   fillchar (u.access2,32,b2)
  57. end;
  58.  
  59. begin
  60. end.
  61.