/packages/fcl-net/examples/rpcserv.pp

https://github.com/slibre/freepascal · Puppet · 73 lines · 60 code · 13 blank · 0 comment · 1 complexity · 1309faa79b9c62f2eb50bf302355dcd5 MD5 · raw file

  1. program RPCServ;
  2. uses SysUtils, Classes, fpAsync, HTTPSvlt, svrclass, svrclass_XMLRPC;
  3. type
  4. TServerApplication = class(TComponent)
  5. private
  6. EventLoop: TEventLoop;
  7. HttpServer: THttpServer;
  8. ServerClass: TServerClass;
  9. XMLRPCServlet: TServerClassXMLRPCServlet;
  10. procedure OnKeyboardData(Sender: TObject);
  11. public
  12. constructor Create;
  13. destructor Destroy; override;
  14. procedure Run;
  15. end;
  16. constructor TServerApplication.Create;
  17. begin
  18. inherited Create(nil);
  19. EventLoop := TEventLoop.Create;
  20. ServerClass := TServerClass.Create;
  21. XMLRPCServlet := TServerClassXMLRPCServlet.Create(Self);
  22. XMLRPCServlet.Name := 'XMLRPCServlet';
  23. XMLRPCServlet.ServerClass := ServerClass;
  24. HttpServer := THttpServer.Create(Self);
  25. HttpServer.EventLoop := EventLoop;
  26. if ParamCount = 2 then
  27. HttpServer.Port := StrToInt(ParamStr(1))
  28. else
  29. HttpServer.Port := 12345;
  30. HTTPServer.AddServlet(XMLRPCServlet, '/xmlrpc');
  31. WriteLn('Listening on port ', HttpServer.Port);
  32. end;
  33. destructor TServerApplication.Destroy;
  34. begin
  35. HTTPServer.Free;
  36. XMLRPCServlet.Free;
  37. ServerClass.Free;
  38. EventLoop.Free;
  39. inherited Destroy;
  40. end;
  41. procedure TServerApplication.Run;
  42. begin
  43. EventLoop.SetDataAvailableNotify(StdInputHandle, @OnKeyboardData, nil);
  44. HttpServer.Active := True;
  45. EventLoop.Run;
  46. end;
  47. procedure TServerApplication.OnKeyboardData(Sender: TObject);
  48. begin
  49. EventLoop.Break;
  50. end;
  51. var
  52. App: TServerApplication;
  53. begin
  54. App := TServerApplication.Create;
  55. try
  56. App.Run;
  57. finally
  58. App.Free;
  59. end;
  60. end.