mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-07-12 04:06:00 +02:00
109 lines
2.4 KiB
ObjectPascal
109 lines
2.4 KiB
ObjectPascal
program httpget;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
uses
|
|
SysUtils, Classes, fphttpclient, sslsockets, fpopenssl;
|
|
|
|
Type
|
|
|
|
{ TTestApp }
|
|
|
|
TTestApp = Class(Tobject)
|
|
procedure DoProgress(Sender: TObject; Const ContentLength, CurrentPos : Int64);
|
|
procedure DoHeaders(Sender : TObject);
|
|
procedure DoPassword(Sender: TObject; var RepeatRequest: Boolean);
|
|
procedure ShowRedirect(ASender : TObject; Const ASrc : String; Var ADest : String);
|
|
Procedure Run;
|
|
end;
|
|
|
|
procedure TTestApp.DoHeaders(Sender : TObject);
|
|
|
|
Var
|
|
I : Integer;
|
|
|
|
begin
|
|
Writeln('Response headers received:');
|
|
With (Sender as TFPHTTPClient) do
|
|
For I:=0 to ResponseHeaders.Count-1 do
|
|
Writeln(ResponseHeaders[i]);
|
|
end;
|
|
|
|
procedure TTestApp.DoProgress(Sender: TObject; const ContentLength, CurrentPos: Int64);
|
|
begin
|
|
If (ContentLength=0) then
|
|
Writeln('Reading headers : ',CurrentPos,' Bytes.')
|
|
else If (ContentLength=-1) then
|
|
Writeln('Reading data (no length available) : ',CurrentPos,' Bytes.')
|
|
else
|
|
Writeln('Reading data : ',CurrentPos,' Bytes of ',ContentLength);
|
|
end;
|
|
|
|
procedure TTestApp.DoPassword(Sender: TObject; var RepeatRequest: Boolean);
|
|
|
|
Var
|
|
H,UN,PW : String;
|
|
P : Integer;
|
|
begin
|
|
With TFPHTTPClient(Sender) do
|
|
begin
|
|
H:=GetHeader(ResponseHeaders,'WWW-Authenticate');
|
|
end;
|
|
P:=Pos('realm',LowerCase(H));
|
|
if (P>0) then
|
|
begin
|
|
P:=Pos('"',H);
|
|
Delete(H,1,P);
|
|
P:=Pos('"',H);
|
|
H:=Copy(H,1,Pos('"',H)-1);
|
|
end;
|
|
Writeln('Authorization required. Remote site says: ',H);
|
|
Write('Enter username (empty quits): ');
|
|
ReadLn(UN);
|
|
RepeatRequest:=(UN<>'');
|
|
if RepeatRequest then
|
|
begin
|
|
Write('Enter password: ');
|
|
Readln(PW);
|
|
TFPHTTPClient(Sender).UserName:=UN;
|
|
TFPHTTPClient(Sender).Password:=PW;
|
|
end;
|
|
end;
|
|
|
|
procedure TTestApp.ShowRedirect(ASender: TObject; const ASrc: String;
|
|
var ADest: String);
|
|
|
|
begin
|
|
Writeln('Following redirect from ',ASrc,' ==> ',ADest);
|
|
end;
|
|
|
|
procedure TTestApp.Run;
|
|
|
|
begin
|
|
if (ParamCount<>2) then
|
|
begin
|
|
writeln('Usage : ',ExtractFileName(ParamStr(0)), 'URL filename');
|
|
Halt(1);
|
|
end;
|
|
With TFPHTTPClient.Create(Nil) do
|
|
try
|
|
AllowRedirect:=True;
|
|
OnRedirect:=@ShowRedirect;
|
|
OnPassword:=@DoPassword;
|
|
OnDataReceived:=@DoProgress;
|
|
OnHeaders:=@DoHeaders;
|
|
Get(ParamStr(1),ParamStr(2));
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
With TTestApp.Create do
|
|
try
|
|
Run;
|
|
finally
|
|
Free;
|
|
end;
|
|
end.
|