$ Include ../cdefines.inc}
Unit curl;
{}
{Url utilities 3.07}
{}
{THIS UNIT IS COPYRIGHT? 2000-2004 by David J Butler}
{}
{THIS UNIT IS Part of Delphi Fundamentals.
{ITS Original File Name is curl.pas}
{The Latest Version IS Available from The Fundamentals Home Page}
{Http://fundementals.sourceforge.net/}
{}
{I invite you to use this unit, free of charge.
{I invite you to distibute this unit, but it must be for free.
{I also invite you to controle to its development,}
{But do not distribute a modified copy of this file.
{}
{A forum is available on sourceforge for general discussion}
{Http://sourceforge.net/forum/forum.php?forum_id=2117}
{}
{Revision History:}
{17/10/2000 1.01 Unit CinternetStandards.
{22/12/2001 1.02 Unit cmime.} {12/12/2002 3.03 Unit CinternetUtils.
{21/02/2004 3.04 Added Url Protocol base class.
{22/02/2004 3.05 Added URL File Protocol Implement Class.}
{05/03/2004 3.06 Unit curl.
{12/03/2004 3.07 Added Asynchronous URL Content functions.
{}
Interface
Uses
{DELPHI}
SYSUTILS,
{Fundamentals}
Creaders,
CTHREADS;
{}
{Url protocol}
{URL Protocol Implementations Must Use Aurlprotocol As Their Base Class.}
{URL Protocol Implementations Must Call RegisterURLPROTOCOL to register}
{The.}
{}
Type
AURLPROTOCOL =
Class
public
{Url}
Function Decodeurl
Const URL:
String;
Var Protocol, Host, Path:
String):
Boolean;
Virtual;
{Content}
Function iscontentSupported
Const Protocol, Host, Path:
String):
Boolean;
Virtual;
Function GetContentReader
Const Protocol, Host, Path:
String;
VAR ContentType:
String): areaderex;
Virtual;
Function getContentString
Const Protocol, Host, Path:
String;
VAR Content, ContentType:
String):
Boolean;
Virtual;
END;
EurlProtocol =
Class (Exception);
Procedure RegisterURLPROTOCOL
Const Handler: AURLPROTOCOL);
{} {Url string}
{}
Const
protohttp =
'http';
ProtonNTP =
'news';
ProtoftP =
'ftp';
Protogopher =
'gopher';
Protoemail =
'Mailto ';
Protohttps =
'https';
Protoirc =
'IRC';
Protofile =
'file';
Prototelnet =
'telnet';
Procedure decodeURL
Const URL:
String;
Var Protocol, Host, Path:
String);
Function encodeurl
Const Protocol, Host, Path:
String):
String;
{}
{URL Content (Blocking functions)}
{}
Function geturlprotocolcontentReader
Const Protocol, Host, Path:
String;
VAR ContentType:
String): areaderex;
Function geturlprotocolcontentstring
Const Protocol, Host, Path:
String;
VAR Content, ContentType:
String):
Boolean;
Function geturlContentReader
Const URL:
String;
VAR ContentType:
String): areaderex;
Function geturlcontentstring
Const URL:
String;
VAR Content, ContentType:
String):
Boolean;
Function RequireurlProtocolContentReader
Const Protocol, Host, Path:
String;
VAR ContentType:
String): areaderex;
Function RequireurlProtocolContentString (
Const Protocol, Host, Path:
String;
VAR ContentType:
String):
String;
Function RequireurlContentReader
Const URL:
String;
VAR ContentType:
String): areaderex;
Function RequireurlContentString (Const URL:
String;
VAR ContentType:
String):
String;
{}
{URL Content (asynchronous functions)}
{Call geturlcontentasync to retrieve url content asynchronously.}
{Caller Must Free The Returned TurlContentasync Object.
{}
Type
TurlContentasync =
Class;
TurlContentNotifyEvent =
PROCEDURE
Const UrlContent: TurlContentAsync;
Const Data: Pointer)
Of Object;
TurlContentProgressEvent =
PROCEDURE
Const UrlContent: TurlContentAsync;
Const Data: Pointer;
CONST BUFFER;
Const size:
Integer;
VAR ABORT:
Boolean)
Of Object;
TurlContentMode =
UcgetContentString,
// Return Content in ContentString Property
UcsaveContentFile,
// Save Content to ContentFileName
UcNotifyContentBlocks;
// Call onprogress with content blocks
TurlContentasync =
Class (TTHREADEX)
Private
FPROTOCOL:
String;
FHOST:
String;
FPATH:
String;
FcontentMode: TurlContentMode;
FcontentFileName:
String;
FDATA: POINTER;
FONPROGRESS: TURLCONTENTPROGRESSEVENT;
Fonfinished: TurlContentNotifyEvent;
Ffinished:
Boolean;
Fsuccess:
Boolean;
FerrorMessage:
String;
Fcontentsize:
Integer;
FcontentProgress:
Integer;
FcontentType:
String;
FcontentString:
String;
protected
Procedure TriggerProgress
CONST BUFFER;
Const size:
Integer;
VAR ABORT:
Boolean;
Virtual;
Procedure triggerfinished;
Virtual;
Procedure execute;
OVERRIDE;
public
Constructor Create
Const Protocol, Host, Path:
String;
Const ContentMode: TurlContentMode = UcgetContentString;
Const ContentFileName:
String =
'';
Const data: Pointer = NIL;
Const Onprogress: TurlContentProgressEvent = NIL;
Const onfinished: TurlContentNotifyEvent = nil);
Property Protocol:
String read fprotocol;
Property Host:
String read fhost;
Property Path:
String read fpath;
Property ContentMode: TurlContentMode Read FcontentMode;
Property ContentFileName:
String read fcontentfilename;
Property Data: Pointer Read FDATA;
Property finished:
Boolean Read FFINISHED;
Property Success:
Boolean read fsuccess;
Property ErrorMessage:
String Read feerrorMessage;
Property Contentsize:
Integer read fcontentsize;
Property ContentProgress:
Integer read fcontentprogress;
Property ContentType:
String read fcontettype;
Property ContentString:
String read fcontentstring;
END;
Function geturlprotocolContentasync (
Const Protocol, Host, Path:
String;
Const ContentMode: TurlContentMode = UcgetContentString;
Const ContentFileName:
String =
'';
Const data: Pointer = NIL;
Const Onprogress: TurlContentProgressEvent = NIL;
Const onfinished: TurlContentNotifyEvent = NIL): TurlContentasync;
Function geturlContentasync (
Const URL:
String;
Const ContentMode: TurlContentMode = UcgetContentString;
Const ContentFileName:
String =
'';
Const data: Pointer = NIL;
Const Onprogress: TurlContentProgressEvent = NIL;
Const onfinished: TurlContentNotifyEvent = NIL): TurlContentasync;
{}
{URL FILE Protocol} {}
Type
TurlfileProtocol =
Class (Aurlprotocol)
public
Function iscontentSupported
Const Protocol, Host, Path:
String):
Boolean;
OVERRIDE;
Function GetContentReader
Const Protocol, Host, Path:
String;
VAR ContentType:
String): areaderex;
OVERRIDE;
Function getContentString
Const Protocol, Host, Path:
String;
VAR Content, ContentType:
String):
Boolean;
OVERRIDE;
END;
Procedure registerarchfileprotocol;
{}
{Self-testing code}
{}
Procedure Selftest;
IMPLEMENTATION
Uses
{Fundamentals}
CUTILS,
CStrings,
CWRITERS,
CStreams,
CfileUtils,
CinternetUtils;
{}
{Aurlprotocol}
{}
Function aurlprotocol.decodeurl
Const URL:
String;
Var Protocol, Host, Path:
String):
Boolean;
Begin
Protocol: =
'';
Host: =
'';
PATH: =
'';
Result: =
False;
END;
Function aurlprotocol.iscontentsupported
Const Protocol, Host, Path:
String):
Boolean;
Begin
Result: =
False;
END;
Function Aurlprotocol.getContentReader
Const Protocol, Host, Path:
String;
VAR ContentType:
String): areaderex;
Begin
ContentType: =
'';
Result: = NIL;
End; function aurlprotocol.getContentString (
Const Protocol, Host, Path:
String;
VAR Content, ContentType:
String):
Boolean;
Begin
Content: =
'';
ContentType: =
'';
Result: =
False;
END;
{}
{URL Protocol Implementations}
{}
VAR
URLPROTOCOLS:
Array
OF AURLPROTOCOL = NIL;
Procedure RegisterURLPROTOCOL
Const Handler: AURLPROTOCOL);
Begin
IF
Not assigned (Handler)
THEN
Raise eurlprotocol.create
'URL Protocol Handler Required';
Append (ObjectArray (UrlProtocols), Handler;
END;
{}
{URL STRING}
{}
Function urldecodehttp (
Const S:
String;
Var Protocol, Host, Path:
String):
Boolean;
Var i, J:
Integer;
Begin
Protocol: =
'';
Host: =
'';
PATH: =
'';
IF strmatchleft (s,
'http:',
False)
THEN
Protocol: = protohttp
Else
IF strmatchleft (s,
'https:',
False)
THEN
Protocol: = protohttps;
Result: = protocol <>
'';
IF
NOT RESULT
THEN
EXIT;
I: = poschar
':', S);
Assert (i>
0,
'I> 0');
IF strmatch (s,
'//', i
1)
THEN
INC (i,
2);
J: = POSCHAR
'/', S, i
1);
IF j =
0
THEN
Host: = CopyFrom (S, I
1)
Else
Begin
Host: = CopyRange (S, I
1, J -
1);
PATH: = CopyFrom (s, j);
END;
END;
Function Urldecodeemail (
Const S:
String;
Var Protocol, Host, Path:
String):
Boolean;
Begin
Protocol: =
'';
Host: =
'';
PATH: =
'';
IF strmatchleft (s,
'Mailto:',
False)
THEN
Begin
Protocol: = Protoemail;
Host: = CopyFrom (s,
8);
end
Else
IF (Poschar)
':',
'/',
'/'], S) =
0)
and
(Poschar)
'@', S)>
1)
THEN
Begin
Protocol: = Protoemail;
Host: = S;
END;
Result: = protocol <>
'';
IF
NOT RESULT
THEN
EXIT;
TriminPlace (Host, Space);
END;
Function Urldecodefile
Const S:
String;
Var Protocol, Host, Path:
String):
Boolean;
Begin
Protocol: =
'';
Host: =
'';
PATH: =
'';
IF s <>
'' '
THEN
IF strmatchleft (s,
'file:',
False)
THEN
Begin
Protocol: = protofile;
PATH: = CopyFrom (s,
6);
end
Else
IF (pchar (s) ^ =
'/')
oral
(PATHHASDRIVELETER (S)
And strmatch (s,
'/',
3))
THEN
Begin
Protocol: = protofile;
PATH: = S;
END;
Result: = protocol <>
'';
END;
Function URLDECodeknownProtocol
Const S:
String;
Var Protocol, Host, Path:
String):
Boolean;
Begin
Result: = Urldecodehttp (S, Protocol, Host, Path);
IF Result
THEN
EXIT;
Result: = UrldecodeEmail (s, protocol, host, path);
IF Result
THEN
EXIT;
Result: = URLDECodefile (s, protocol, host, path);
IF Result
THEN
EXIT;
END;
Function UrldecodePath (
Const S:
String;
Var Protocol, Host, Path:
String):
Boolean;
VAR i:
Integer;
Begin
Protocol: =
'';
Host: =
'';
PATH: =
'';
Result: = FALSE;
// Special Cases
IF (s =
')
OR (s =
'*')
OR (s =
'/')
THEN
Begin
PATH: = S;
Result: =
True;
end
Else
// Relative Path
IF strmatchleft (s,
'../')
OR strmatchleft (s,
'./')
THEN
Begin
PATH: = S;
Result: =
True;
end
Else
// "/" prefix
IF pchar (s) ^ =
'/'
THEN
Begin
IF strmatchleft (s,
'//')
THEN
Begin
// "//" Host ["/" PATH]
I: = poschar
'/', S,
3);
IF i =
0
THEN
// "//" Host
Host: = CopyFrom (s,
3)
Else
Begin
// "//" Host "/" PATH
Host: = CopyRange (s,
3, I -
1);
PATH: = CopyFrom (S, I);
END;
end
Else
// "/" PATH
PATH: = S;
Result: =
True;
END;
END;
Procedure UrldecodeGeneral
Const S:
String;
Var Protocol, Host, Path:
String);
Var i, J:
Integer;
T:
String;
Begin
Protocol: =
'';
Host: =
'';
PATH: =
'';
I: = POSSTR
': //', s);
J: = POSCHAR
'/', S);
IF (i>
0)
And (j = i
1)
THEN
Begin
// protocol ": //"
Protocol: = Trim (Copyleft (S, I -
1), Space);
J: = POSCHAR
'/', S, i
3);
IF j =
0
THEN
Begin
Host: = Trim (CopyFrom (S, I
3), Space);
PATH: =
'';
end
Else
Begin
Host: = Trim (CopyRange (S, I
3, J -
1), Space);
PATH: = TRIM (CopyFrom (S, J), Space;
END;
EXIT;
END;
I: = poschar
':', S);
IF (i =
0)
OR ((i>
0)
And (j>
0)
And (j THEN Begin // no proteocol PATH: = S; EXIT; END; // Check text Between ":" and "/" IF j> 0 THEN T: = CopyRange (s, i 1, J - 1) Else T: = CopyFrom (S, I 1); IF strisnumeric (t) THEN Begin // Address ":" Port / path IF j = 0 THEN Host: = S Else Begin Host: = COPYLT (S, J - 1); PATH: = CopyFrom (s, j); END; EXIT; END; // protocol ":" Host "/" PATH Protocol: = Trim (Copyleft (S, I - 1), Space); IF j = 0 THEN Host: = CopyFrom (S, I 1) Else Begin Host: = CopyRange (S, I 1, J - 1); PATH: = CopyFrom (s, j); END; END; Procedure decodeURL Const URL: String; Var Protocol, Host, Path: String); Const knownprotocols = 3; KnownProtocol: Array [ 1..knownprotocols] Of String = (Protoemail, ProtonNTP, Protofile; Var S: String; I: Integer; Begin Protocol: = ''; Host: = ''; PATH: = ''; // Clean URL S: = Trim (URL, Space); IF s = '' ' THEN EXIT; // Check if Url is a path only IF UrldecodePath (S, Protocol, Host, PATH) THEN EXIT; // Check Url Protocol Handlers For i: = 0 To Length (Urlprotocols) - 1 DO IF urlprotocols [i] .decodeURL (URL, Protocol, Host, Path) THEN EXIT; // Check Known Protocol IF UrldecodeknownProtocol (s, protocol, host, path) THEN EXIT; // Check General Format UrldecodeGeneral (s, protocol, host, path); END; Function encodeurl Const Protocol, Host, Path: String): String; Begin Result: = ''; IF protocol <> '' ' THEN IF strequalnocase (protohttp, protocol) oral Strequalnocase (Protohttps, Protocol) THEN Result: = protocol ': //' Else Result: = protocol ':'; Result: = Result Host; IF path <> '' ' THEN IFNOT (PATH [ 1] in ':', '/', '/', '@', ',']) THEN Result: = Result '/' Path Else Result: = Result path; END; {} {URL Content (Blocking functions)} {} Function geturlprotocolcontentReader Const Protocol, Host, Path: String; VAR ContentType: String): areaderex; VAR i: Integer; P: aurlprotocol; S: String; Begin For i: = 0 To Length (Urlprotocols) - 1 DO Begin P: = urlprotocols [i]; IF P.iscontentSupported (Protocol, Host, PATH) THEN Begin Result: = P.GetContentReader (Protocol, Host, Path, ContentType); IF assigned (result) THEN EXIT; IF P.GetContentString (Protocol, Host, Path, S, ContentType) THEN Begin Result: = TSTRINGReader.create (s); EXIT; END; END; END; ContentType: = ''; Result: = NIL; END; Function geturlprotocolcontentstring Const Protocol, Host, Path: String; VAR Content, ContentType: String): Boolean; VAR i: Integer; P: aurlprotocol; R: areaderex; Begin For i: = 0 To Length (Urlprotocols) - 1 DO Begin P: = urlprotocols [i]; IF P.iscontentSupported (Protocol, Host, PATH) THEN Begin Result: = P.GetContentString (Protocol, Host, Path, Content, ContentType); IF Result THEN EXIT; R: = P.GetContentReader (Protocol, Host, Path, ContentType); IF assigned (r) THEN Begin Try Content: = R.Gettoeof; Finally R.Free; END; Result: = True; EXIT; END; END; END; Content: = ''; ContentType: = ''; Result: = False; END; Function geturlContentReader Const URL: String; VAR ContentType: String): areaderex; Var Protocol, Host, Path: String; Begin IF URL = '' ' THEN Raise eurlprotocol.create 'URL Required'); DecodeURL (URL, Protocol, Host, Path); Result: = geturlProtocolContentReader (Protocol, Host, Path, ContentType); END; Function geturlcontentstring Const URL: String; VAR Content, ContentType: String): Boolean; Var Protocol, Host, Path: String; Begin IF URL = '' ' THEN Raise eurlprotocol.create 'URL Required'); DecodeURL (URL, Protocol, Host, Path); Result: = geturlprotocolContentString (Protocol, Host, Path, Content, ContentType); END; Function RequireurlProtocolContentReader Const Protocol, Host, Path: String; VAR ContentType: String): areaderex; Begin Result: = geturlProtocolContentReader (Protocol, Host, Path, ContentType); IF NOT ASSIGNED (RESULT) THEN Raise eurlprotocol.create 'URL NOT Supported'; END; Function RequireurlProtocolContentString ( Const Protocol, Host, Path: String; VAR ContentType: String): String; Begin IF Not geturlprotocolcontentstring (Protocol, Host, Path, Result, ContentType) THEN Raise eurlprotocol.create 'URL NOT Supported'; END; Function RequireurlContentReader Const URL: String; VAR ContentType: String): areaderex; Begin Result: = geturlContentReader (URL, ContentType); IF NOT ASSIGNED (RESULT) THEN Raise eurlprotocol.create 'URL NOT Supported'; END; Function RequireurlContentString Const URL: String; VAR ContentType: String): String; Begin IF Not geturlContentString (URL, Result, ContentType) THEN Raise EURLPROTOCOL.CREATE ('URL NOT Supported "; END; {} {URL Content (asynchronous functions)} {} Const ProgressBlocksize = 4096; Constructor TurlContentasync.create Const Protocol, Host, Path: String; Const ContentMode: TurlContentMode; Const ContentFileName: String; Const Data: Pointer; Const Onprogress: TurlContentProgress; Const onfinished: TurlContentNotifyEvent; Begin FPROTOCOL: = Protocol; FHOST: = Host; FPATH: = PATH; FcontentMode: = contentMode; FcontentFileName: = ContentFileName; FDATA: = DATA; FONPROGRESS: = OnProgress; FONFINIShed: = onfinished; FreeOnterminate: = False; Inherited Create FALSE); END; Procedure TurlContentasync.triggerProgress ( CONST BUFFER; Const size: Integer; VAR ABORT: Boolean; Begin IF Assigned (FONPROGRESS) THEN FONPROGRESS (SELF, FDATA, BUFFER, SIZE, ABORT) END; Procedure TurlContentasync.triggerfinished; Begin IF assigned (fonfinished) THEN Fonfinished (Self, FDATA); END; Procedure TurlContentasync.execute; Var Reader: areaderex; Writer: tfilewriter; BUF: Array [ 0..progressblocksize - 1] Of Byte; I: Integer; A: Boolean; Begin FerrorMessage: = ''; Try Try IF fcontentmode = ucgetcontentstring THEN Begin FcontentString: = RequireurlProtocolContentString (FProtocol, fHOST, FPATH, FCONTENTTYPE); Fcontentsize: = Length (fcontentString); Fsuccess: = True; end Else IF fcontentmode In [UcNotifyContentBlocks, ucsavecontentfile] Thenbegin Reader: = RequireurlProtocolContentReader (FPROTOCOL, FHOST, FPATH, FCONTENTTYPE); Try Fcontentsize: = reader.size; IF fcontentmode = ucsavecontentfile THEN Begin if fcontentFileName = '' ' THEN Raise eurlprotocol.create 'Filename reguous'; Writer: = tfilewriter.create (fcontentFileName, FWOMCREATE) end Else Writer: = NIL; Try A: = False; While NOT Reader.eof and NOT TERMINATED DO Begin I: = reader.read (buf [ 0], progravelblocksize; IF (i = 0) and NOT Reader.eof THEN Raise eurlprotocol.create 'Read error'); INC (FContentProgress, i); IF Terminated THEN EXIT; TriggerProgress (BUF " 0], i, a); IF a THEN Raise eurlprotocol.create 'Aborted'); IF Assigned (Writer) THEN Writer.writebuffer (BUF " 0], i); END; Finally Writer.free; END; Finally Reader.Free; END; FContentSize: = fcontentProgress; Fsuccess: = True; END; Except ON E: Exception DO FerrorMessage: = E.MESSAGE; END; Finally FFINISHED: = True; Triggerfinished; END; END; Function geturlprotocolContentasync ( Const Protocol, Host, Path: String; Const ContentMode: TurlContentMode; Const ContentFileName: String; Const Data: Pointer; Const Onprogress: TurlContentProgress; Const onfinished: TurlContentNotifyEvent: TurlContentAsync; Begin Result: = TurlContentasync.create (Protocol, Host, Path, ContentMode, ContentFileName, Data, Onprogress, onfinished; END; Function geturlContentasync ( Const URL: String; Const ContentMode: TurlContentMode; Const ContentFileName: String; Const Data: Pointer; Const Onprogress: TurlContentProgress; Const onfinished: TurlContentNotifyEvent: TurlContentAsync; Var Protocol, Host, Path: String; Begin DecodeURL (URL, Protocol, Host, Path); Result: = geturlprotocolContentasync (Protocol, Host, Path, ContentMode, ContentFileName, Data, Onprogress, onfinished; END; {} {URL FILE Protocol} {} Function TurlfileProtocol.isContentSupported Const Protocol, Host, Path: String): Boolean; Begin Result: = strequalnocase (Protocol, Protofile) And (Host = ') AND (Path <> '); END; Function TurlfileProtocol.getContentReader Const Protocol, Host, Path: String; VAR ContentType: String): areaderex; Begin ContentType: = MimeContentTypeFromExtens (ExtractFileExt (PATH)); Result: = TfileReader.create (path); END; Function TurlfileProtocol.getContentString ( Const Protocol, Host, Path: String; VAR Content, ContentType: String): Boolean; Begin Content: = ReadFileToStr (PATH); ContentType: = MimeContentTypeFromExtens (ExtractFileExt (PATH)); Result: = True; END; VAR URLFILEPROTOCOL: AURLPROTOCOL = NIL; Procedure registerarchfileprotocol; Begin IF Assigned (UrlfileProtocol) THEN EXIT; URLFILEPROTOCOL: = TurlfileProtocol.create; RegisterURLPROTOCOL (URLFileProtocol); END; {} {Self-testing code} {} {$ Assertions on} procedure selftest; Var P, M, u: String; Begin {Decodeurl} DecodeURL 'http://abc.com/index.html', p, m, u); Assert (p = protohttp) And (m = 'abc.com') And (u = '/index.html'), 'Decodeurl'); DecodeURL 'a: //b.c/1/2/3', p, m, u); AskERT ((p = 'a') And (m = 'b.c') And (u = '/ 1/2/3'), 'Decodeurl'); DecodeURL 'http: // b: 80 / i.html', p, m, u); Assert (p = protohttp) And (m = 'b: 80') And (u = '/i.html'), 'Decodeurl'); DecodeURL 'Mailto: a @ b', p, m, u); Assert (p = protoemail) And (m = 'a @ b') And (u = '), 'Decodeurl'); {ENCodeURL} Assert (Encodeurl) 'http', 'abc.com', '/') = 'http://abc.com/', 'Encodeurl'); Assert (Encodeurl) 'news', 'a.b', ') = 'news: a.b', 'Encodeurl'); Assert (Encodeurl) 'https', 'abc.com', '/') = 'https://abc.com/', 'Encodeurl'); END; INITIALIZATION Finalization Freeandnil (UrlfileProtocol); End.
