unit uParseURL;
{<
@abstract(URL-Parser)
}
{.$DEFINE SERV_DEFAULT_PORT}
interface
type
// @abstract(Zerlegen und Zusammensetzen von URL-Pfaden)
//
// @noautolink(Aufbau einer Standard-URL:)
// @code(Serv)@code(:)@code(//)@code(User)@code(:)@code(Pass)@code(@@)@code(Host)@code(:) @code(Port)@code(/)@code(Path)@code(?)@code(Parm)
//
// Wird der URL-Wert gesetzt, so wird diese wie folgt in ihre Einzelteile zerlegt:
// @table(
// @rowHead( @cell(URL) @cell(Serv) @cell(User) @cell(Pass) @cell(Host) @cell(Port) @cell(Path) @cell(Parm) )
// @row( @cell([url]http://www.google.de[/url]) @cell(http) @cell() @cell() @cell([url]www.google.de[/url]) @cell(80) @cell() @cell() )
// @row( @cell([url]http://www.google.de/imghp?hl=de&tab=vw[/url]) @cell(http) @cell() @cell() @cell([url]www.google.de[/url]) @cell(80) @cell(imghp) @cell(hl=de&tab=vw) )
// )
// Werden die Einzelteile gesetzt, so wird die URL wie folgt zusammengesetzt:
// @table(
// @rowHead( @cell(Serv) @cell(User) @cell(Pass) @cell(Host) @cell(Port) @cell(Path) @cell(Parm) @cell(URL) )
// @row( @cell(http) @cell() @cell() @cell([url]www.google.de[/url]) @cell(80) @cell() @cell() @cell([url]http://www.google.de[/url]) )
// @row( @cell(http) @cell() @cell() @cell([url]www.google.de[/url]) @cell(8080) @cell() @cell() @cell([url]http://www.google.de:8080[/url]) )
// @row( @cell(http) @cell() @cell() @cell([url]www.google.de[/url]) @cell(80) @cell(imghp) @cell(hl=de&tab=vw) @cell([url]http://www.google.de/imghp?hl=de&tab=vw[/url]) )
// )
// Ist der angegebene Port der Default-Port des Service, dann wird dieser in der URL nicht ausgegeben. @br
// Ist in der übergebenen URL kein Port angegeben, so wird als Port der Default-Port für den Service verwendet. @br
// Diese Informationen werden aus der Datei "services" (Pfad: "%system%\drivers\etc\") gelesen.
TParseURL =
class
private
FPath :
string;
FPort : integer;
FPass :
string;
FServ :
string;
FHost :
string;
FUser :
string;
FParm :
string;
FValid : boolean;
function GetURL :
string;
procedure SetURL(
const Value :
string );
procedure SetHost(
const Value :
string );
procedure SetPass(
const Value :
string );
procedure SetPath(
const Value :
string );
procedure SetPort(
const Value : integer );
procedure SetServ(
const Value :
string );
procedure SetUser(
const Value :
string );
procedure SetParm(
const Value :
string );
function GetPort : integer;
public
// URL-Pfad
//
// @code(Serv)@code(:)@code(//)@code(User)@code(:)@code(Pass)@code(@@)@code(Host)@code(:) @code(Port)@code(/)@code(Path)@code(?)@code(Parm)
property URL :
string read GetURL
write SetURL;
// Service (ftp, http, etc.)
//
// @code(@bold(Serv))@code(:)@code(//)@code(User)@code(:)@code(Pass)@code(@@)@code(Host)@code(:) @code(Port)@code(/)@code(Path)@code(?)@code(Parm)
property Serv :
string read FServ
write SetServ;
// Benutzer
//
// @code(Serv)@code(:)@code(//)@code(@bold(User))@code(:)@code(Pass)@code(@@)@code(Host)@code(:) @code(Port)@code(/)@code(Path)@code(?)@code(Parm)
property User :
string read FUser
write SetUser;
// Kennwort
//
// @code(Serv)@code(:)@code(//)@code(User)@code(:)@code(@bold(Pass))@code(@@)@code(Host)@code(:) @code(Port)@code(/)@code(Path)@code(?)@code(Parm)
property Pass :
string read FPass
write SetPass;
// Host-Name
//
// @code(Serv)@code(:)@code(//)@code(User)@code(:)@code(Pass)@code(@@)@code(@bold(Host))@code(:) @code(Port)@code(/)@code(Path)@code(?)@code(Parm)
property Host :
string read FHost
write SetHost;
// Anschluss-Port
//
// @code(Serv)@code(:)@code(//)@code(User)@code(:)@code(Pass)@code(@@)@code(Host) @code(:)@code(@bold(Port))@code(/)@code(Path)@code(?)@code(Parm)
property Port : integer
read GetPort
write SetPort;
// Pfad
//
// @code(Serv)@code(:)@code(//)@code(User)@code(:)@code(Pass)@code(@@)@code(Host)@code(:) @code(Port)@code(/)@code(@bold(Path))@code(?)@code(Parm)
property Path :
string read FPath
write SetPath;
// Parameter
//
// @code(Serv)@code(:)@code(//)@code(User)@code(:)@code(Pass)@code(@@)@code(Host)@code(:) @code(Port)@code(/)@code(Path)@code(?)@code(@bold(Parm))
property Parm :
string read FParm
write SetParm;
// Ist die URL gültig
property Valid : boolean
read FValid;
// Löscht alle Werte in @classname
procedure Clear;
// Erzeugt eine neue Instanz von @classname
constructor Create;
end;
implementation
uses
{$IFDEF SERV_DEFAULT_PORT}
ActiveX,
ShlObj,
Windows,
{$ENDIF SERV_DEFAULT_PORT}
WinInet,
SysUtils,
Classes;
{$IFDEF SERV_DEFAULT_PORT}
const
PathToServices = '
\drivers\etc\services';
var
ServList : TStringList;
{$ENDIF SERV_DEFAULT_PORT}
type
TEasyURLComponents =
record
Scheme, HostName :
string;
Port : integer;
User, Password, UrlPath, ExtraInfo :
string;
end;
function CrackURL(
const URL :
string; decode, escape : boolean;
var data : TEasyURLComponents ) : boolean;
var
uc : TURLComponents;
flags : Cardinal;
begin
ZeroMemory( @uc, sizeof( uc ) );
uc.dwStructSize := sizeof( TURLComponents );
with data
do
begin
SetLength( Scheme, 10 );
uc.lpszScheme := PChar( Scheme );
uc.dwSchemeLength := Length( Scheme );
SetLength( HostName, 200 );
uc.lpszHostName := PChar( HostName );
uc.dwHostNameLength := Length( HostName );
SetLength( User, 200 );
uc.lpszUserName := PChar( User );
uc.dwUserNameLength := Length( User );
SetLength( Password, 200 );
uc.lpszPassword := PChar( Password );
uc.dwPasswordLength := Length( Password );
SetLength( UrlPath, 1000 );
uc.lpszUrlPath := PChar( UrlPath );
uc.dwUrlPathLength := Length( UrlPath );
SetLength( ExtraInfo, 2000 );
uc.lpszExtraInfo := PChar( ExtraInfo );
uc.dwExtraInfoLength := Length( ExtraInfo );
end;
flags := 0;
// Converts encoded characters back to their normal form.
if decode
then
flags := flags
or ICU_DECODE;
// Converts all escape sequences (%xx) to their corresponding characters.
if escape
then
flags := flags
or ICU_ESCAPE;
RESULT := InternetCrackUrl( PChar(
URL ), Length(
URL ), flags, uc );
with data
do
begin
SetLength( Scheme, uc.dwSchemeLength );
SetLength( HostName, uc.dwHostNameLength );
SetLength( User, uc.dwUserNameLength );
SetLength( Password, uc.dwPasswordLength );
SetLength( UrlPath, uc.dwUrlPathLength );
SetLength( ExtraInfo, uc.dwExtraInfoLength );
Port := uc.nPort;
end;
end;
function StrBefore(
const SubStr, S :
string ) :
string;
begin
if Pos( SubStr, S ) > 0
then
RESULT := Copy( S, 1, Pos( SubStr, S ) - 1 )
else
RESULT := '
';
end;
function StrAfter(
const SubStr, S :
string ) :
string;
begin
if Pos( SubStr, S ) > 0
then
RESULT := Copy( S, Pos( SubStr, S ) + Length( SubStr ), Length( S ) )
else
RESULT := S;
end;
{$IFDEF SERV_DEFAULT_PORT}
function GetSpecialFolder( hWindow : HWND; Folder : integer ) :
String;
var
pMalloc : IMalloc;
pidl : PItemIDList;
Path : PChar;
begin
// Get IMalloc interface pointer
if ( SHGetMalloc( pMalloc ) = S_OK )
then
begin
// retrieve path
SHGetSpecialFolderLocation( hWindow, Folder, pidl );
GetMem( Path, MAX_PATH );
SHGetPathFromIDList( pidl, Path );
RESULT := Path;
if RESULT <> '
'
then
RESULT := ExcludeTrailingPathDelimiter( RESULT );
FreeMem( Path );
// free memory allocated by SHGetSpecialFolderLocation
pMalloc.Free( pidl );
end
else
RESULT := '
';
end;
procedure BuildServList;
var
idx : integer;
begin
ServList.Clear;
ServList.Sorted := False;
with TStringList.Create
do
try
LoadFromFile( GetSpecialFolder( 0, CSIDL_SYSTEM ) + PathToServices );
idx := 0;
while ( idx < Count )
do
begin
if ( Pos( '
#', Trim( Strings[ idx ] ) ) = 1 )
or
( Trim( StrBefore( '
/tcp', Strings[ idx ] ) ) = '
' )
then
Delete( idx )
else
inc( idx );
end;
idx := 0;
while ( idx < Count )
do
begin
ServList.Values[ Trim( StrBefore( '
', Strings[ idx ] ) ) ] := Trim
( StrBefore( '
/tcp', StrAfter( '
', Strings[ idx ] ) ) );
inc( idx );
end;
finally
Free;
end;
ServList.Sort;
ServList.Sorted := True;
end;
function GetServDefaultPort(
const Serv :
string ) : integer;
begin
RESULT := StrToIntDef( ServList.Values[ Serv ], 0 );
end;
{$ENDIF SERV_DEFAULT_PORT}
{ TParseURL }
procedure TParseURL.Clear;
begin
FServ := '
';
FUser := '
';
FPass := '
';
FHost := '
';
FPort := 0;
FPath := '
';
FParm := '
';
FValid := False;
end;
constructor TParseURL.Create;
begin
inherited;
Clear;
end;
function TParseURL.GetPort : integer;
begin
RESULT := FPort;
{$IFDEF SERV_DEFAULT_PORT}
if ( FPort = 0 )
then
RESULT := GetServDefaultPort( FServ );
{$ENDIF SERV_DEFAULT_PORT}
end;
function TParseURL.GetURL :
string;
var
data : TEasyURLComponents;
begin
RESULT := '
';
if ( FUser <> '
' )
then
begin
RESULT := RESULT + FUser;
end;
if ( FPass <> '
' )
then
RESULT := RESULT + '
:' + FPass;
if ( FUser <> '
' )
or ( FPass <> '
' )
then
RESULT := RESULT + '
@';
if ( FHost <> '
' )
then
RESULT := RESULT + Host;
if ( FPort <> 0 )
{$IFDEF SERV_DEFAULT_PORT}
and ( FPort <> GetServDefaultPort( FServ ) )
{$ENDIF SERV_DEFAULT_PORT}
then
RESULT := RESULT + '
:' + IntToStr( FPort );
if ( FPath <> '
' )
then
RESULT := RESULT + FPath;
if ( FParm <> '
' )
then
RESULT := RESULT + FParm;
if ( FServ <> '
' )
then
begin
if ( RESULT <> '
' )
then
RESULT := '
//' + RESULT;
RESULT := FServ + '
:' + RESULT;
end;
FValid := CrackURL( RESULT, False, False, data );
if not FValid
then
RESULT := '
';
end;
procedure TParseURL.SetHost(
const Value :
string );
begin
FHost := LowerCase( Value );
GetURL;
end;
procedure TParseURL.SetParm(
const Value :
string );
begin
FParm := Value;
GetURL;
end;
procedure TParseURL.SetPass(
const Value :
string );
begin
FPass := Value;
GetURL;
end;
procedure TParseURL.SetPath(
const Value :
string );
begin
FPath := Value;
GetURL;
end;
procedure TParseURL.SetPort(
const Value : integer );
begin
FPort := Value;
GetURL;
end;
procedure TParseURL.SetServ(
const Value :
string );
begin
FServ := LowerCase( Value );
GetURL;
end;
procedure TParseURL.SetURL(
const Value :
string );
var
data : TEasyURLComponents;
begin
Clear;
if CrackURL( Value, False, False, data )
then
begin
FServ := data.Scheme;
FUser := data.User;
FPass := data.Password;
FHost := data.HostName;
FPort := data.Port;
FPath := data.UrlPath;
FParm := data.ExtraInfo;
FValid := True;
end;
end;
procedure TParseURL.SetUser(
const Value :
string );
begin
FUser := Value;
GetURL;
end;
{$IFDEF SERV_DEFAULT_PORT}
initialization
ServList := TStringList.Create;
BuildServList;
finalization
ServList.Free;
{$ENDIF SERV_DEFAULT_PORT}
end.