home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / bbs_door / ebank10.arj / EARNBANK.PAS < prev   
Pascal/Delphi Source File  |  1992-04-08  |  7KB  |  258 lines
  1.  
  2. (*
  3.  * Copyright 1987, 1992 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13. {!!!IMPORTANT!!! F5 WON'T WORK WITHOUT THE FOLLOWING LINE}
  14. {$M 9000,18000,18000}  {Stack, minheap, maxheap}
  15. {$S-,R-}
  16. {$L+,D+}
  17. {$V-}
  18.  
  19. Program earnings_bank_door;
  20.  
  21. Uses
  22.    Dos,
  23.    MiniCrt,    {BIOS-only crt functions}
  24.    OpenShare,  {Shared text files}
  25.    MdosIO,     {Dos-level random access files}
  26.    BufIO,      {Buffered record i/o}
  27.    qRead,      {Quick string qReadLn procedure}
  28.    Tools,      {Various utilities}
  29.    ProBye,
  30.    ProData,    {ProDoor/pcboard data}
  31.    ProRoot,    {ProKit main support library}
  32.    ProSysf,    {ProKit Status display, function keys, system functions}
  33.    ProScan,    {File display and colorization}
  34.    ProUtil,    {ProKit utility library #1}
  35.    ProUtil2,   {proKit utility library #2}
  36.    KitInit;    {ProKit initialization/deinit}
  37.  
  38. const
  39.    door_version = 'Earned K Bytes Banking Door 1.0 (04-07-92)';
  40.  
  41. type
  42.    bank_rec = record
  43.       name1:   char25;
  44.       balance: longint;
  45.       spare:   char35;
  46.    end;
  47.  
  48. var
  49.    bankfd:  file of bank_rec;
  50.    bankrec: bank_rec;
  51.    bankrn:  longint;
  52.  
  53. const
  54.    bankfile = 'EARNBANK.DAT';
  55.  
  56.  
  57. (* ---------------------------------------------------------------- *)
  58. procedure locate_record;
  59. begin
  60.    pdisp('$YELLOW$Searching for '+username+' in EARNBANK file ...');
  61.  
  62.    seek(bankfd,0);
  63.    while not eof(bankfd) do
  64.    begin
  65.       read(bankfd,bankrec);
  66.       if bankrec.name1 = pcbsys.name then
  67.       begin
  68.          displn(' Found!');
  69.          exit;
  70.       end;
  71.    end;
  72.  
  73.    displn(' Not found!');
  74.    displn('A new EARNBANK record will now be created...');
  75.    fillchar(bankrec,sizeof(bankrec),0);
  76.    bankrec.name1 := pcbsys.name;
  77.    write(bankfd,bankrec);
  78. end;
  79.  
  80. (* ---------------------------------------------------------------- *)
  81. procedure update_record;
  82. begin
  83.    seek(bankfd,filepos(bankfd)-1);
  84.    write(bankfd,bankrec);
  85. end;
  86.  
  87. (* ---------------------------------------------------------------- *)
  88. procedure load_config;
  89. var
  90.    fd:   text;
  91.  
  92. begin
  93.    assignText(fd,config_file);
  94.    reset(fd);
  95.    readln(fd);
  96.    close(fd);
  97. end;
  98.  
  99.  
  100. (* ---------------------------------------------------------------- *)
  101. procedure do_deposit;
  102. var
  103.    max_amt: longint;
  104.    amt:     longint;
  105.    i:       integer;
  106. begin
  107.    max_amt := user.earned_k;
  108.    if max_amt = 0 then
  109.    begin
  110.       displn('No K Bytes available to deposit!');
  111.       exit;
  112.    end;
  113.  
  114.    if length(cmdline) = 0 then
  115.       get_def('K Bytes to deposit, up to '+ltoa(max_amt)+': ',enter_eq_none);
  116.  
  117.    get_nextpar;
  118.    if (par <> '') and (par[1] >= '0') and (par[1] <= '9') then
  119.    begin
  120.       val(par,amt,i);
  121.       if amt > max_amt then
  122.          amt := max_amt;
  123.       if (i = 0) and (amt > 0) then
  124.       begin
  125.          bankrec.balance := bankrec.balance + amt;
  126.          user.earned_k := user.earned_k - amt;
  127.          make_log_entry('EarnBank Deposit: '+ltoa(amt)+', Balance: '+ltoa(bankrec.balance),true);
  128.       end;
  129.    end;
  130.  
  131. end;
  132.  
  133. (* ---------------------------------------------------------------- *)
  134. procedure do_withdrawal;
  135. var
  136.    max_amt: longint;
  137.    amt:     longint;
  138.    i:       integer;
  139. begin
  140.    max_amt := $FFFF - user.earned_k;
  141.    if max_amt > bankrec.balance then
  142.       max_amt := bankrec.balance;
  143.  
  144.    if (max_amt = 0) then
  145.    begin
  146.       displn('No K bytes available to withdraw!');
  147.       exit;
  148.    end;
  149.  
  150.    if (max_amt = $FFFF) then
  151.    begin
  152.       displn('You are already at the K byte limit!');
  153.       exit;
  154.    end;
  155.  
  156.    if length(cmdline) = 0 then
  157.       get_def('K Bytes to withdraw, up to '+ltoa(max_amt)+': ',enter_eq_none);
  158.  
  159.    get_nextpar;
  160.    if (par <> '') and (par[1] >= '0') and (par[1] <= '9') then
  161.    begin
  162.       val(par,amt,i);
  163.       if amt > max_amt then
  164.          amt := max_amt;
  165.  
  166.       if (i = 0) and (amt > 0) then
  167.       begin
  168.          bankrec.balance := bankrec.balance - amt;
  169.          user.earned_k := user.earned_k + amt;
  170.          make_log_entry('EarnBank Withdrawal: '+ltoa(amt)+', Balance: '+ltoa(bankrec.balance),true);
  171.       end;
  172.    end;
  173.  
  174. end;
  175.  
  176. (* ---------------------------------------------------------------- *)
  177. procedure command_menu;
  178. begin
  179.    repeat
  180.  
  181.       {prompt for input only if there is not a stacked command pending}
  182.       if length(cmdline) = 0 then
  183.       begin
  184.          newline;
  185.          pdispln(   '$YELLOW$Welcome to EarnBank, the Earned-K Banking Door!');
  186.          newline;
  187.          pdispln(   '$GREEN$   Current K bytes available = $WHITE$'+ltoa(user.earned_k));
  188.          pdispln(   '$GREEN$   Current K bytes in bank   = $WHITE$'+ltoa(bankrec.balance));
  189.          newline;
  190.          pdispln(   '$YELLOW$Banking Commands: ');
  191.          pdispln(   '$WHITE$   (D)  $GREEN$Deposit K bytes for later use');
  192.          pdispln(   '$WHITE$   (W)  $GREEN$Withdraw K bytes to use now');
  193.          pdispln(   '$WHITE$   (Q)  $GREEN$Return to BBS');
  194.          newline;
  195.  
  196.          repeat
  197.             display_time_left;
  198.             pdisp('$YELLOW$Command? ');
  199.             get_cmdline;              {get cmdline, map to upper case}
  200.             newline;
  201.          until dump_user or (length(cmdline) > 0);
  202.       end;
  203.  
  204.       if dump_user then exit;   {leave menu if carrier lost}
  205.       get_nextpar;              {scan next parameter from cmdline into par}
  206.  
  207.       if par<> '' then
  208.       case par[1] of
  209.          'D':  do_deposit;
  210.          'W':  do_withdrawal;
  211.          'Q':  ;
  212.          else  displn('What?  Please re-enter command!');
  213.       end;
  214.    until (par[1] = 'Q');
  215. end;
  216.  
  217. (* ---------------------------------------------------------------- *)
  218. procedure main;
  219. begin
  220.    load_config;
  221.    cmdline := getenv('PCBDOOR');
  222.  
  223.    assign(bankfd,bankfile);
  224.    {$i-} reset(bankfd); {$i+}
  225.    if ioresult <> 0 then
  226.    begin
  227.       rewrite(bankfd);
  228.       close(bankfd);
  229.       reset(bankfd);
  230.    end;
  231.  
  232.    locate_record;
  233.  
  234.    command_menu;
  235.  
  236.    if not dump_user then
  237.       update_record;
  238.  
  239.    close(bankfd);
  240. end;
  241.  
  242. (* ---------------------------------------------------------------- *)
  243.  
  244. begin  {main block}
  245.    init;     {must be first - opens com port, loads setup and user data}
  246.    progname := 'EarnBank';        {program name on status line}
  247.  
  248.    newline;
  249.    displn(door_version);
  250.    displn('Copyright 1992 Samuel H. Smith');
  251.    newline;
  252.  
  253.    main;
  254.  
  255.    uninit;   {must be last - closes com port and updates database}
  256. end.
  257.  
  258.