fork download
copy 
  1. Program testping;
  2.  
  3. {$MODE DELPHI}
  4.  
  5. uses
  6.  pingsend, sysutils, httpsend, classes, fpjson, jsonparser, fphttpclient;
  7.  
  8. type
  9.   TMyHTTPResult = record
  10.     Result: Integer;
  11.     Notes: TStringList;
  12.   end;
  13.  
  14.   TMyPingResult = record
  15.     Result: Boolean;
  16.     Attempts: Integer;
  17.     Successes: Integer;
  18.     Failures: Integer;
  19.     Average: Integer;
  20.   end;
  21.  
  22. const
  23.   MAX_REDIRECTS = 5;
  24.   PING_COUNT = 5;
  25.  
  26. function CheckHTTPServer(Location: String; Attempts: Integer = 0): Boolean;
  27. var
  28.   HTTP: THTTPSend;
  29.   S, NewLocation: String;
  30.   P: PChar;
  31.   Count: Integer;
  32. begin
  33.   // Instantiate the HTTP Cleint
  34.   HTTP := THTTPSend.Create;
  35.   try
  36.     if not HTTP.HTTPMethod('GET', Location) then
  37.       // There is an error.
  38.       Result := False
  39.     else
  40.       // Check to see if the location has been moved
  41.       case (HTTP.ResultCode) of
  42.       // HTTP 200 OK
  43.       200:
  44.         Result := True;
  45.       // HTTP 301/302 Moved
  46.       301, 302:
  47.         begin
  48.           // First, see if we've reached the maximum number of redirect attempts
  49.           if Attempts >= MAX_REDIRECTS then
  50.             Result := false
  51.           else
  52.           // If not, cycle through each of the headers sent to find where the
  53.           // object was moved too
  54.           for Count := HTTP.Headers.Count - 1  downto 0 do
  55.           begin
  56.             { This is a lot of nonsense to find the correct header.
  57.               Essentially, a new pointer is created to the string and then
  58.               the "pointer" is examined to see if contains the Location header
  59.             }
  60.             P := StrAlloc(Length(HTTP.Headers[Count]) + 1);
  61.             StrPCopy(P, HTTP.Headers[Count]);
  62.             if StrPos(P, 'Location:') <> nil then
  63.             begin
  64.               S := Trim(HTTP.Headers[Count]);
  65.               NewLocation := Copy(S, 10, Length(S));
  66.               NewLocation := Trim(NewLocation);
  67.               // Recursively try to find the object originally requested
  68.               Result := CheckHTTPServer(NewLocation, Attempts + 1);
  69.             end;
  70.           end;
  71.  
  72.         end;
  73.       // I'm not dealing with it...
  74.       Otherwise
  75.         Result := False;
  76.       end;
  77.   finally
  78.     HTTP.Free;
  79.   end;
  80. end;
  81.  
  82. function CheckPing(Location: String; Attempts: Integer = 5): TMyPingResult;
  83. var
  84.   PingClient:TPingSend;
  85.   I, Acc: Integer;
  86.   MyPingResult: TMyPingResult;
  87. begin
  88.   PingClient := TPingSend.Create;
  89.   MyPingResult.Result := False;
  90.   MyPingResult.Attempts := Attempts;
  91.   MyPingResult.Successes := 0;
  92.   MyPingResult.Failures := 0;
  93.  
  94.   // set the accumulator
  95.   Acc := 0;
  96.   try
  97.     for I := 1 to Attempts do begin
  98.       PingClient.Ping(Location);
  99.       if PingClient.PingTime > -1 then
  100.       begin
  101.         Inc(MyPingResult.Successes);
  102.         Acc := Acc + PingClient.PingTime;
  103.         MyPingResult.Result := True;
  104.       end
  105.       else
  106.         Inc(MyPingResult.Failures);
  107.  
  108.       // Wait just a tad
  109.       Sleep(10);
  110.     end;
  111.   finally
  112.     PingClient.Free;
  113.   end;
  114.  
  115.   if MyPingResult.Result then
  116.     MyPingResult.Average:= Acc div Attempts;
  117.  
  118.   Result := MyPingResult;
  119. end;
  120.  
  121. var
  122.   PingResult: TMyPingResult;
  123.   J: TJSONData;
  124.   O, SubObj: TJSONObject;
  125.   f: tjsonarray;
  126.   json: String;
  127.    Parser:TJSONParser;
  128.   Arr:TJSONArray;
  129.   i: Integer;
  130.   Str: STring;
  131. begin
  132.   (*
  133.   try
  134.     // Parse JSON Data to TJSONData
  135.     Str := TFPCustomHTTPClient.SimpleGet('****.txt');
  136.   Parser := TJSONParser.Create(Str);
  137.   Arr := Parser.Parse as TJSONArray;
  138.   // We send our JSON data to TJSONData. This is line 1 of our code.
  139.        for i := 0 to Arr.Count - 1 do
  140.   begin
  141.     SubObj := Arr.Objects[i];
  142.     WriteLn(i+1, ': ', SubObj.Strings['url'], ', ', SubObj.Strings['http']);
  143.   end;
  144.  
  145.   except
  146.     on E: Exception do WriteLn('Error finding path!');
  147.  
  148.   end;
  149.   (*
  150.   WriteLn(J.FindPath('tests').AsString);
  151.   *)
  152.   WriteLn('Welcome to Pinger!');
  153.   PingResult := CheckPing('example.com');
  154.   //if PingResult.Result then
  155.   //begin
  156.     WriteLn('Server responded in ' + IntToStr(PingResult.Average) + 'ms');
  157.     WriteLn(IntToStr(PingResult.Successes) + '/' + IntToStr(PingResult.Attempts) + ' ok');
  158.     if CheckHTTPServer('obviouslyfakewebsite.faketld') then
  159.       WriteLn('HTTP server gave acceptable response')
  160.     else
  161.       WriteLn('HTTP server appears down.');
  162.   //end
  163.   //else
  164.   //  WriteLn('Ping Failure');
  165.  
  166.   ReadLn;
  167. end.
  168.  
Compilation error #stdin compilation error #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
compilation info 
Free Pascal Compiler version 2.6.4+dfsg-6 [2015/05/31] for i386
Copyright (c) 1993-2014 by Florian Klaempfl and others
Target OS: Linux for i386
Compiling prog.pas
prog.pas(6,2) Fatal: Can't find unit pingsend used by testping
Fatal: Compilation aborted
Error: /usr/bin/ppc386 returned an error exitcode (normal if you did not specify a source file to be compiled)
stdout
copy 
Standard output is empty
https://ideone.com/q7PyrW
language:
Pascal (fpc 3.0.4)
created:
7 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!