home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcpipvp2.zip / TIMSERV2.PAS < prev    next >
Pascal/Delphi Source File  |  1996-10-10  |  5KB  |  146 lines
  1. program TimServ;
  2.  
  3. uses OS2Def,OS2Base,DOS,VPUtils,
  4.      Socket,U_DateTime;
  5.  
  6. {$L IBMTCPIP.LIB}
  7.  
  8. const
  9.   Version     = '0.90';
  10.   StackSize   = 64*1024;
  11.   TimServPort: ULong  = 10037;
  12.   UseString:   string = '@(#)time server for OS/2'+#0;
  13.   CopyRight1:  string = '@(#)timeserver2 Version '+Version+' - 10.10.96'+#0;
  14.   CopyRight2:  string = '@(#)(C) Chr.Hohmann BfS ST2.2 1996'+#0;
  15. var
  16.   mrc:      ApiRet;
  17.   TCPTh:    TID;
  18.   ValError: longint;
  19.   TempStr:  string;
  20.   (***************************************************************************)
  21. {$S-}
  22.   function TCP_Timeserver(P: pointer): ULong;
  23.   var
  24.     Ended:    boolean;
  25.     rc:       ApiRet;
  26.     BufFlag:  ULong;
  27.     SDescr,
  28.     CDescr:   longint;
  29.     TempDT:   OS2Base.DateTime;
  30.     SAddr,
  31.     CAddr:    SockAddr_In_Ptr;
  32.     Client:   string;
  33.     ValStr:   string[ 3];
  34.   begin
  35.     new(SAddr);
  36.     new(CAddr);
  37.     fillchar(SAddr^,sizeof(SAddr^),#0);
  38.     fillchar(CAddr^,sizeof(CAddr^),#0);
  39.     rc := socksocket(AF_INET,SOCK_STREAM,IPPROTO_NULL);
  40.     if (rc <> -1) then begin
  41.       SDescr                 := rc;
  42.       SAddr^.Sin_Addr.IPAddr := InAddr_Any;
  43.       SAddr^.Sin_Port        := htons(TimServPort);
  44.       SAddr^.Sin_Family      := AF_INET;
  45.       rc := SockBind(SDescr,
  46.                      SAddr,
  47.                      SockAddr_Len);
  48.       if (rc <> -1) then begin
  49.         rc := SockListen(SDescr,5);
  50.         CDescr := SDescr;
  51.         if (rc <> -1) then begin
  52.           Ended := false;
  53.           writeln('Startup TCP using Port ',TimServPort,' complete  -  waiting for clients.');
  54.           write  ('--------------------------------------------------------------------------------');
  55.           repeat
  56.             CDescr := SockAccept(SDescr,
  57.                                  CAddr,
  58.                                  SockAddr_Len);
  59.             Client := SockGetHostNameByAddr(@CAddr^.Sin_Addr);
  60.             if (rc = -1) then Client := 'unknown host';
  61.             str(CAddr^.Sin_Addr.ClassA,ValStr);
  62.             while (length(ValStr) <  3) do ValStr := '0'+ValStr;
  63.             Client := Client+' ('+ValStr+'.';
  64.             str(CAddr^.Sin_Addr.ClassB,ValStr);
  65.             while (length(ValStr) <  3) do ValStr := '0'+ValStr;
  66.             Client := Client+ValStr+'.';
  67.             str(CAddr^.Sin_Addr.ClassC,ValStr);
  68.             while (length(ValStr) <  3) do ValStr := '0'+ValStr;
  69.             Client := Client+ValStr+'.';
  70.             str(CAddr^.Sin_Addr.ClassD,ValStr);
  71.             while (length(ValStr) <  3) do ValStr := '0'+ValStr;
  72.             Client := Client+ValStr+')';
  73.             write('TCP: request from ',Client);
  74.             rc := DosGetDateTime(TempDT);
  75.             if (rc = 0) then begin
  76.               BufFlag  := 0;
  77.               rc := SockSend(CDescr,
  78.                              @TempDT,
  79.                              sizeof(TempDT),
  80.                              BufFlag);
  81.               if (rc = sizeof(TempDT)) then
  82.                 writeln(' - ',Long_DateString(Default,TempDT),' - OK.')
  83.               else
  84.                 writeln(' - socket send rc: ',rc);
  85.               rc := SockShutdown(CDescr,BufFlag);
  86.               if (rc <> 0) then begin
  87.                 writeln('Socket shutdown failed - rc: ',rc);
  88.               end;
  89.             end else begin
  90.               writeln(' DosGetDateTime failed');
  91.             end;
  92.           until (rc = -1);
  93.           (*  hope we never come here, but ... *)
  94.           rc := SockClose(SDescr);
  95.           writeln('TCP  close rc: ',rc:12,'  errno: ',sockerrno);
  96.           dispose(CAddr);
  97.           dispose(SAddr);
  98.         end else begin
  99.           writeln('TCP socket rc: ',SDescr:12);
  100.           writeln('    listen rc: ',rc:12,'  errno: ',sockerrno);
  101.           writeln;
  102.           writeln('program aborted');
  103.           halt(99);
  104.         end;
  105.       end else  begin
  106.         writeln('TCP socket rc: ',SDescr:12);
  107.         writeln('    bind   rc: ',rc:12,'  errno: ',sockerrno);
  108.         writeln;
  109.         writeln('program aborted');
  110.         halt(99);
  111.       end;
  112.     end else begin
  113.       writeln('TCP socket rc: ',rc:12,'  errno: ',SockErrNo);
  114.       writeln;
  115.       writeln('program aborted');
  116.       halt(99);
  117.     end;
  118.   end;
  119. {$S+}
  120.   (***************************************************************************)
  121. begin
  122.   TempStr := getenv('TimeService2');
  123.   if (TempStr > '') then begin
  124.     val(TempStr,TimServPort,ValError);
  125.     if (ValError <> 0) and (TimServPort > 0) then begin
  126.       writeln('timserv2 error - not a value ',TempStr);
  127.       halt(99);
  128.     end;
  129.   end;
  130.   write  ('--------------------------------------------------------------------------------');
  131.   writeln('Timeservice for OS/2  Version ',Version,'  -  by Christian Hohmann  -  bugs@bga.de');
  132.   write  ('--------------------------------------------------------------------------------');
  133.  
  134.   mrc := BeginThread(nil,16*1024,TCP_Timeserver,pointer(0),0,TCPTh);
  135.   if (mrc <> -1) then begin
  136.     mrc := DosSleep(-1);
  137.   end else begin
  138.     writeln;
  139.     writeln('can'+#39+'t start TCP-thread - program aborted');
  140.     halt(99);
  141.   end;
  142.   UseString  := UseString;
  143.   CopyRight1 := CopyRight1;
  144.   CopyRight2 := CopyRight2;
  145. end.
  146.