home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / msdos / pascal / bbskt30a / host.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-11-10  |  14.3 KB  |  563 lines
  1. {
  2.   Host.Pas
  3.  
  4.   A sample host BBS for BBSkit.
  5.  
  6.   Version 1.2, updated for BBSkit 3.0.
  7.  
  8.   Written by Steve Madsen.
  9.  
  10.   NOTE: intended to be compiled using the registered version of BBSkit.  If
  11.   you wish to recompile with a demo copy, remove the space before the $ in
  12.   the following $DEFINE.
  13. }
  14.  
  15. { $DEFINE DEMO}
  16.  
  17. {$X+,V-}
  18.  
  19. PROGRAM Host12;
  20.  
  21. {$DEFINE NOBSP}
  22.  
  23. Uses DOS, CRT, BBSkit, Comm, Util, Protocol, MTask;
  24.  
  25. Const
  26.   Version = '1.2';
  27.  
  28. Type
  29.   THost = object(TBBS)
  30.     Password   : String[20];
  31.     ChatReason : String[40];
  32.     InChat     : Boolean;
  33.     PromptSt   : String[80];
  34.  
  35.     CONSTRUCTOR Init;
  36.     PROCEDURE Run; VIRTUAL;
  37.     DESTRUCTOR Done; VIRTUAL;
  38.     FUNCTION Chat : Boolean;
  39.     FUNCTION HandleVirtualKey(Code : Char) : Boolean; VIRTUAL;
  40.     PROCEDURE UserSession;
  41.     FUNCTION Menu : Boolean;
  42.     PROCEDURE ListFiles;
  43.     PROCEDURE ShowFile;
  44.     PROCEDURE Upload;
  45.     PROCEDURE Download;
  46.     PROCEDURE ChatRequest;
  47.   end;
  48.  
  49. Var
  50.   Host : THost;
  51.  
  52. {********************************************************************}
  53.  
  54.   {
  55.   *  PROCEDURE GetScreenStr
  56.   *
  57.   *  Gets a string of text (no attributes) from the screen and stores
  58.   *  it in Strn.
  59.   }
  60.  
  61. PROCEDURE GetScreenStr(X, Y, Len : Byte; var Strn : String);
  62.  Var
  63.    Idx  : Byte;
  64.    Ch   : Char;
  65.    Attr : Byte;
  66.  
  67.  begin
  68.    Strn := '';
  69.    for Idx := X to X + Len - 1 do
  70.     begin
  71.       GetScreenWord(Idx, Y, Ch, Attr);
  72.       Strn := Strn + Ch;
  73.     end;
  74.  end;
  75.  
  76. {--------------------------------------------------------------------}
  77.  
  78. PROCEDURE Usage;
  79.  begin
  80.    WriteLn;
  81.    WriteLn('Host usage:');
  82.    WriteLn;
  83.    WriteLn('HOST <comport> <baudrate>');
  84.    WriteLn;
  85.    WriteLn(' <comport> can be 1, 2, 3 or 4.');
  86.    WriteLn(' <baudrate> can be 300, 1200, 2400, 4800, 9600, 19200 or 38400.');
  87.    WriteLn;
  88.    WriteLn('example: HOST 2 2400    { com2, at 2400bps }');
  89.    WriteLn('         HOST 1 9600    { com1, at 9600bps }');
  90.  end;
  91.  
  92. {--------------------------------------------------------------------}
  93.  
  94. CONSTRUCTOR THost.Init;
  95.  Var
  96.    Ch : Char;
  97.  
  98.  begin
  99.    TBBS.Init;
  100.    if (not Exist('FILES')) then
  101.     begin
  102.       vcWriteLn('');
  103.       vcWriteLn('Subdirectory "FILES" not found.');
  104.       vcWriteLn('');
  105.       vcWrite('Create or quit program? (C/Q): ');
  106.       Repeat
  107.         Ch := UpCase(ReadKey);
  108.       Until (Ch = 'C') or (Ch = 'Q');
  109.       if (Ch = 'C') then
  110.        begin
  111.          vcWriteLn('Create');
  112.          MkDir('FILES');
  113.        end
  114.       else
  115.        begin
  116.          vcWriteLn('Quit');
  117.          Halt(1);
  118.        end;
  119.     end;
  120.    OpenPort(StrToInt(ParamStr(1)));
  121.    SetAnswerMode(Answer);
  122.    SetOutput(True, False);
  123.    SetInput(True, False);
  124.    SetFlowControl(PortIdx, True, False);
  125.    ClearIntChars;
  126.    AddIntChar(' ');
  127.    SetVirtualKeys(True);
  128.    ClearVirtualKeys;
  129.    AddVirtualKey(#46);  { alt-C, chat enter/exit }
  130.    vcWriteLn('');
  131.    vcWrite('Today''s password: ');
  132.    ComReadLn(Password, 20);
  133.    Password := Upper(Password);
  134.    ChatReason := '';
  135.    InChat := False;
  136.  end;
  137.  
  138. {--------------------------------------------------------------------}
  139.  
  140. PROCEDURE THost.Run;
  141.  Var
  142.    Quit : Boolean;
  143.  
  144.  begin
  145.    Quit := False;
  146.    ClrScr;
  147.    while (not Quit) do
  148.     begin
  149.       SetBpsRate(PortIdx, StrToInt(ParamStr(2)));
  150.       vcWriteLn('');
  151.       vcWriteLn('Host: Waiting For Call   [SPC] for local login   [Q] to quit');
  152.       while (not LineRinging(PortIdx)) and (not Keypressed) do ;
  153.       if (Keypressed) then
  154.        begin
  155.          case UpCase(ReadKey) of
  156.            ' ' : begin
  157.                    SetInput(True, False);
  158.                    SetOutput(True, False);
  159.                    UserSession;
  160.                  end;
  161.            'Q' : Quit := True;
  162.          end;
  163.        end
  164.       else
  165.        begin
  166.          PickupPhone;
  167.          if (WaitFor('C', 30)) then ;
  168.          if (Carrier(PortIdx)) then
  169.           begin
  170.             SetOutput(True, True);
  171.             SetInput(True, True);
  172.             UserSession;
  173.           end;
  174.        end;
  175.     end;
  176.  end;
  177.  
  178. {--------------------------------------------------------------------}
  179.  
  180. DESTRUCTOR THost.Done;
  181.  begin
  182.    ClosePort(True);
  183.    TBBS.Done;
  184.  end;
  185.  
  186. {--------------------------------------------------------------------}
  187.  
  188. FUNCTION THost.Chat : Boolean;  { chat with user }
  189.  Var
  190.    St       : String;
  191.    Wrap     : String;
  192.  
  193.  begin
  194.    if (not InChat) then
  195.     begin
  196.       InChat := True;
  197.       ChatReason := '';
  198.       PromptSt := '';
  199.       GetScreenStr(1, WhereY, WhereX - 1, PromptSt);
  200.       ComWriteLn('');
  201.       ComWriteLn('');
  202.       ComWrite('Sysop has entered chat mode.');
  203.       vcWrite('  (Sysop: Alt-C to exit)');
  204.       ComWriteLn('');
  205.       ComWriteLn('');
  206.       Wrap := '';
  207.       while (InChat) do
  208.          ComReadLnWrap(St, 79, Wrap);
  209.       Chat := False;
  210.     end
  211.    else
  212.     begin
  213.       InChat := False;
  214.       ComWriteLn('');
  215.       ComWriteLn('');
  216.       ComWriteLn('Sysop has exited chat mode.');
  217.       ComWriteLn('');
  218.       ComWrite(PromptSt);
  219.       Chat := True;
  220.     end;
  221.  end;
  222.  
  223. {--------------------------------------------------------------------}
  224.  
  225. FUNCTION THost.HandleVirtualKey(Code : Char) : Boolean;
  226.  begin
  227.    case Code of
  228.      #46 : HandleVirtualKey := Chat;
  229.    end;
  230.  end;
  231.  
  232. {--------------------------------------------------------------------}
  233.  
  234. PROCEDURE THost.UserSession;
  235.  Var
  236.    Pass : String[20];
  237.    Try  : Byte;
  238.  
  239.  begin
  240.    SetLF(True);
  241.    ComWriteLn('');
  242.    ComWriteLn('BBSkit Host v' + Version);
  243.    Try := 0;
  244.    Pass := '';
  245.    while (Try < 4) and (Pass <> Password) do
  246.     begin
  247.       Inc(Try);
  248.       ComWriteLn('');
  249.       ComWrite('Password: ');
  250.       SetEcho('*');
  251.       ComReadLn(Pass, 20);
  252.       SetEcho(#0);
  253.       Pass := Upper(Pass);
  254.       ComWriteLn('');
  255.       if (Pass <> Password) then ComWriteLn('Incorrect.');
  256.     end;
  257.    if (Pass = Password) then
  258.     begin
  259.       ComWriteLn('');
  260.       ComWriteLn('Welcome to BBSkit Host.');
  261.       ComWriteLn('');
  262.       while (Menu) do ;
  263.     end;
  264.    Hangup;
  265.  end;
  266.  
  267. {--------------------------------------------------------------------}
  268.  
  269. FUNCTION THost.Menu : Boolean;
  270.  Var
  271.    Cmd : Char;
  272.  
  273.  begin
  274.    Menu := True;
  275.    vcWrite('Sysop: Alt-C enters chat mode');
  276.    if (ChatReason <> '') then
  277.       vcWrite('   WANTS CHAT: ' + ChatReason);
  278.    vcWriteLn('');
  279.    ComWrite('[L]ist files  [T]ype file  [U]pload  [D]ownload  [C]hat  [G]oodbye: ');
  280.    Cmd := UpCase(ComReadKey);
  281.    ComWriteLn(Cmd);
  282.    case Cmd of
  283.      'L' : ListFiles;
  284.      'T' : ShowFile;
  285.      'U' : Upload;
  286.      'D' : Download;
  287.      'C' : ChatRequest;
  288.      'G' : begin
  289.              ComWriteLn('');
  290.              ComWrite('Sure? ');
  291.              Repeat
  292.                Cmd := UpCase(ComReadKey);
  293.              Until (Cmd = 'Y') or (Cmd = 'N');
  294.              ComWriteLn(Cmd);
  295.              if (Cmd = 'Y') then
  296.               begin
  297.                 Menu := False;
  298.                 ComWriteLn('');
  299.                 ComWriteLn('Goodbye...');
  300.               end;
  301.              ComWriteLn('');
  302.            end;
  303.    end;
  304.  end;
  305.  
  306. {--------------------------------------------------------------------}
  307.  
  308. PROCEDURE THost.ListFiles;
  309.  Var
  310.    FInfo : SearchRec;
  311.    FTime : DateTime;
  312.    Name  : String[8];
  313.    Ext   : String[3];
  314.  
  315.  begin
  316.    ComWriteLn('');
  317.    ComWriteLn('Listing of all available files:');
  318.    ComWriteLn('');
  319.    FindFirst('FILES\*.*', Archive OR ReadOnly, FInfo);
  320.    while (DOSError = 0) do
  321.     begin
  322.       Name := Copy(FInfo.Name, 1, Pos('.', FInfo.Name) - 1);
  323.       Ext := Copy(FInfo.Name, Pos('.', FInfo.Name) + 1, 3);
  324.       UnpackTime(FInfo.Time, FTime);
  325.       ComWrite(Left(Name, 8) + '.' + Left(Ext, 3) + '    ');
  326.       ComWrite(Right(IntToStr(FInfo.Size), 7) + ' bytes    ');
  327.       if (FTime.Hour < 10) then ComWrite('0');
  328.       ComWrite(IntToStr(FTime.Hour) + ':');
  329.       if (FTime.Min < 10) then ComWrite('0');
  330.       ComWriteLn(IntToStr(FTime.Min));
  331.       FindNext(FInfo);
  332.     end;
  333.    ComWriteLn('');
  334.  end;
  335.  
  336. {--------------------------------------------------------------------}
  337.  
  338. PROCEDURE THost.ShowFile;
  339.  Var
  340.    Fname : String[12];
  341.  
  342.  begin
  343.    ComWriteLn('');
  344.    ComWrite('Filename: ');
  345.    ComReadLn(Fname, 12);
  346.    ComWriteLn('');
  347.    if (not Exist('FILES\' + Fname)) then
  348.       ComWriteLn('Could not find file.')
  349.    else
  350.     begin
  351.       ComWriteLn('Press SPACE to abort, ^S to pause (^Q restarts).');
  352.       ComWriteLn('');
  353.       TypeFile('FILES\' + Fname);
  354.     end;
  355.    ComWriteLn('');
  356.  end;
  357.  
  358. {--------------------------------------------------------------------}
  359.  
  360. PROCEDURE THost.Download;
  361.  Var
  362.    Ch    : Char;
  363.    Fname : String;
  364.    Good  : TError;
  365.    Match : Byte;
  366.    FInfo : SearchRec;
  367.  
  368.  begin
  369.    ComWriteLn('');
  370. {$IFNDEF DEMO}
  371.    ComWriteLn('Send mode: [X]modem, Xmodem-[C]RC, Xmodem-[1]K,');
  372.    ComWrite('           [Y]modem, Ymodem-[G]? ');
  373. {$ELSE}
  374.    ComWrite('Send mode: [X]modem, Xmodem-[C]RC, Xmodem-[1]K? ');
  375. {$ENDIF}
  376.    Ch := UpCase(ComReadKey);
  377.    ComWriteLn(Ch);
  378. {$IFNDEF DEMO}
  379.    if (Pos(Ch, 'XC1YG') > 0) then
  380. {$ELSE}
  381.    if (Pos(Ch, 'XC1') > 0) then
  382. {$ENDIF}
  383.     begin
  384.       case Ch of
  385.         'X',
  386.         'C',
  387.         '1' : begin
  388.                 ComWriteLn('');
  389.                 ComWrite('File: ');
  390.                 ComReadLn(Fname, 12);
  391.                 if (Fname <> '') then
  392.                  begin
  393.                    ComWriteLn('');
  394.                    ComWriteLn('Begin receiving now, or press ^X several times to abort.');
  395.                    Fname := 'FILES\' + Fname;
  396.                    case Ch of
  397.                      'X' : Good := SendXmodem(Checksum, Fname);
  398.                      'C' : Good := SendXmodem(CRC, Fname);
  399.                      '1' : Good := SendXmodem(OneK, Fname);
  400.                    end;
  401.                  end;
  402.               end;
  403. {$IFNDEF DEMO}
  404.         'Y',
  405.         'G' : begin
  406.                 ComWriteLn('');
  407.                 ComWriteLn('Batch download: enter each file on a line by itself. A blank line');
  408.                 ComWriteLn('exits batch entry.');
  409.                 ComWriteLn('');
  410.                 ClearBatch;
  411.                 Repeat
  412.                   ComReadLn(Fname, 12);
  413.                   if (Fname <> '') then
  414.                      AddBatch('FILES\' + Fname);
  415.                 Until (Fname = '');
  416.                 if (FilesInBatch > 0) then
  417.                  begin
  418.                    ComWriteLn('');
  419.                    ComWriteLn('Begin receiving now, or press ^X several times to abort.');
  420.                    case Ch of
  421.                      'Y' : Good := SendYmodem(Normal);
  422.                      'G' : Good := SendYmodem(Streaming);
  423.                    end;
  424.                  end;
  425.               end;
  426. {$ENDIF}
  427.       end;
  428.       ComWriteLn('');
  429.       ComWriteLn('');
  430.       if (Good = NoError) then ComWriteLn('Transfer was successful.')
  431.       else ComWriteLn('Transfer failed.');
  432.     end;
  433.  end;
  434.  
  435. {--------------------------------------------------------------------}
  436.  
  437. PROCEDURE THost.Upload;
  438.  Var
  439.    Ch    : Char;
  440.    Dir   : String;
  441.    Fname : String;
  442.    Ext   : String;
  443.    Good  : TError;
  444.    F     : Text;
  445.    Index : Byte;
  446.  
  447.  begin
  448.    ComWriteLn('');
  449. {$IFNDEF DEMO}
  450.    ComWriteLn('Receive mode: [X]modem, Xmodem-[C]RC, Xmodem-[1]K,');
  451.    ComWrite('              [Y]modem, Ymodem-[G]? ');
  452. {$ELSE}
  453.    ComWrite('Receive mode: [X]modem, Xmodem-[C]RC, Xmodem-[1]K? ');
  454. {$ENDIF}
  455.    Ch := UpCase(ComReadKey);
  456.    ComWriteLn(Ch);
  457. {$IFNDEF DEMO}
  458.    if (Pos(Ch, 'XC1YG') > 0) then
  459. {$ELSE}
  460.    if (Pos(Ch, 'XC1') > 0) then
  461. {$ENDIF}
  462.     begin
  463.       case Ch of
  464.         'X',
  465.         'C',
  466.         '1' : begin
  467.                 ComWriteLn('');
  468.                 ComWrite('File to receive: ');
  469.                 ComReadLn(Fname, 12);
  470.                 if (not Exist('FILES\' + Fname)) then
  471.                  begin
  472.                    ComWriteLn('');
  473.                    ComWriteLn('Begin upload now, or press ^X several times to abort.');
  474.                    case Ch of
  475.                      'X' : Good := ReceiveXmodem(Checksum, 'FILES\' + Fname);
  476.                      'C' : Good := ReceiveXmodem(CRC, 'FILES\' + Fname);
  477.                      '1' : Good := ReceiveXmodem(OneK, 'FILES\' + Fname);
  478.                    end;
  479.                  end
  480.                 else
  481.                  begin
  482.                    ComWriteLn('');
  483.                    ComWriteLn('File already exists!');
  484.                    Good := NoError;
  485.                  end;
  486.               end;
  487. {$IFNDEF DEMO}
  488.         'Y',
  489.         'G' : begin
  490.                 ComWriteLn('');
  491.                 ComWriteLn('Begin batch upload now, or press ^X several times to abort.');
  492.                 case Ch of
  493.                   'Y' : Good := ReceiveYmodem(Normal, 'FILES\');
  494.                   'G' : Good := ReceiveYmodem(Streaming, 'FILES\');
  495.                 end;
  496.               end;
  497. {$ENDIF}
  498.       end;
  499.       ComWriteLn('');
  500.       ComWriteLn('');
  501.       if (Good = NoError) then ComWriteLn('Transfer was successful.')
  502.       else
  503.        begin
  504.          ComWriteLn('Transfer failed.');
  505.          if (Pos(Ch, 'XC1') <> 0) then
  506.           begin
  507.             if (Exist('FILES\' + Fname)) then
  508.              begin
  509.                Assign(F, 'FILES\' + Fname);
  510.                Erase(F);
  511.              end;
  512. {$IFNDEF DEMO}
  513.           end
  514.          else
  515.           begin
  516.             Fname := BatchFile(FilesInBatch);
  517.             if (Exist(Fname)) then
  518.              begin
  519.                Assign(F, Fname);
  520.                Erase(F);
  521.              end;
  522.             if (FilesInBatch > 1) then
  523.              begin
  524.                ComWriteLn('');
  525.                if (FilesInBatch = 2) then
  526.                   ComWriteLn('The following file was received successfully:')
  527.                else
  528.                   ComWriteLn('The following files were received successfully:');
  529.                ComWriteLn('');
  530.                for Index := 1 to FilesInBatch - 1 do
  531.                 begin
  532.                   FSplit(BatchFile(Index), Dir, Fname, Ext);
  533.                   ComWriteLn(Fname + Ext);
  534.                 end;
  535.              end;
  536. {$ENDIF}
  537.           end;
  538.        end;
  539.     end;
  540.  end;
  541.  
  542. {--------------------------------------------------------------------}
  543.  
  544. PROCEDURE THost.ChatRequest;
  545.  begin
  546.    ComWriteLn('');
  547.    ComWrite('Reason for chat: ');
  548.    ComReadLn(ChatReason, 40);
  549.  end;
  550.  
  551. {********************************************************************}
  552.  
  553. BEGIN
  554.   if (ParamCount <> 2) then Usage
  555.   else
  556.    begin
  557.      Host.Init;
  558.      Host.Run;
  559.      Host.Done;
  560.    end;
  561. END.
  562.  
  563.