////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// URI parsing routines according to RFC-3986. Also Percent-Encode/Decode.    //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20250806 - Created by A.K.                                                 //
////////////////////////////////////////////////////////////////////////////////

unit _crw_uri; //  URI parsing according to RFC-3986 and Percent-Encode/Decode

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math,
 _crw_alloc, _crw_str, _crw_fio, _crw_rtc, _crw_ef,
 _crw_hl, _crw_sect, _crw_regexp, _crw_apputils;

const // RFC-3986 Percent-Encoding constants, see chapter 2.1-2.4
 RFC3986_gen_delims=[':','/','?','#','[',']','@'];
 RFC3986_sub_delims=['!','$','&',Apostrophe,'(',')','*','+',',',';','='];
 RFC3986_reserved=RFC3986_gen_delims+RFC3986_sub_delims;
 RFC3986_PCT=['%'];
 RFC3986_DIGIT=['0'..'9'];
 RFC3986_ALPHA=['A'..'Z','a'..'z'];
 RFC3986_HEXDIG_UPPER='0123456789ABCDEF';
 RFC3986_HEXDIG_LOWER='0123456789abcdef';
 RFC3986_unreserved=RFC3986_ALPHA+RFC3986_DIGIT+['-','.','_','~'];
 RFC3986_def_query_delims=['&',';'];
 Pct_DropChars_Default=RFC3986_reserved+JustSpaces+RFC3986_PCT;
 Pct_DropChars_Maximal=[#0..#255]-RFC3986_unreserved;
 Pct_DropChars_Minimal=RFC3986_PCT;

 {
 TUriManager - the URI manager class.
 Uses for URI parsing according to RFC-3986 and Percent-Encode/Decode.
 }
type
 TUriManager = class(TMasterObject)
 private
  myServices:THashList;
  myHexTab:packed array[Char] of Byte;
  myPortList:LongString;
 private
  procedure InitHexTab;
 public
  constructor Create;
  destructor  Destroy; override;
 public
  {
  Parse URI by RFC-3986, Appendix B
   scheme://authority/path?query#fragment
  Note:
   The lead '/' char will be included in path.
   The pct-decode don't applied to URI components. Do it yourself.
   Return False and non-empty string (errors) on URI format error.
  }
  function  Parse_URI(const URI:LongString; out scheme,authority,path,query,fragment,errors:LongString):Boolean;
  {
  Parse URI of database like:
   provider://[user[:pass]@][host[:port]][/dbname][?[query][#fragment]]
   where query is name=value[&...]
  For example:
   provider://user:pass@host:port/dbname?par1=val1&par2=val2#example
   firebird://SYSDBA:masterkey@localhost:3050/employee.fdb?Charset=utf8&PageSize=8192#example
  Note:
   The lead '/' char will be excluded from dbname.
   The pct-decode don't applied to URI components. Do it yourself.
   Return False and non-empty string (errors) on URI format error.
  }
  function  Parse_DB_URI(const URI:LongString; out provider,user,pass,host,port,dbname,query,fragment,errors:LongString):Boolean;
  {
  Parse URI of database like:
   provider://user:pass@host:port/dbname?query#fragment
   where query as key=value[&...]
  Return URI as cookies, i.e. list of parameters (Params) as key=value[;..].
  Use CookieScan to extract PROVIDER,USERNAME,PASSWORD,HOSTNAME,PORT,DATABASE
  and list of parameters from ?query.
  Note:
   The lead '/' char will be excluded from dbname.
   The pct-decode is applied to URI components. Fragment ignored.
   Return False and non-empty string (errors) on URI format error.
  }
  function  Parse_DB_URI_As_Cookies(
   const URI:LongString;    // provider://user:pass@host:port/dbname?p1=v1&p2=v2..
     out params:LongString; // Return PROVIDER=provider;USERNAME=username;...
     out errors:LongString; // Return error string if something wrong
         del:TCharSet=[];   // Query delimeters, default is [&;]
         sep:LongString=''; // Separator for Params, default is ';'
         opt:LongString=''  // Options: list of params to pct-decode
         ):Boolean;         // True if URI satisfy template
 public
  {
  Preliminary Arg detection as URI:
  1. The Arg is non-empty, has no spaces.
  2. The Arg contains "://" substring as URI sign.
  3. Scheme (ahead of ":" char) is a valid name (lex_Name).
  4. String Arg is match to regular expression of URI (lex_UriAddr).
  }
  function  Looks_Like_URI(const Arg:LongString):Boolean;
  {
  Detect Arg is valid DB URI or not.
  Convert DB URI to Params (as cookies).
  Result should be like cookies (key=value;...).
  }
  function Copy_DB_URI_As_Params(
   const Arg:LongString;    // Connection string as Params or as DB URI
   out   Errors:LongString; // Error string on URI format error(s)
   const del:TCharSet=[];   // Query delimeters, default is [&;]
   const sep:LongString=''; // Separator for Params, default is ';'
   const opt:LongString=''  // Options: list of params to pct-decode
         ):LongString;      // Connections string as Params only
 public // Check URI and Fetch URI components
  function  Valid_URI(const URI:LongString):Boolean;
  function  Fetch_URI_Scheme(const URI:LongString):LongString;
  function  Fetch_URI_Authority(const URI:LongString):LongString;
  function  Fetch_URI_Path(const URI:LongString):LongString;
  function  Fetch_URI_Query(const URI:LongString):LongString;
  function  Fetch_URI_Fragment(const URI:LongString):LongString;
 public // pct-encode/decode - Percent Encode/Decode
  function  Pct_Encode(const S:LongString; const Reserved:TCharSet=[]):LongString;
  function  Pct_Decode(const S:LongString; const Errors:PInteger=nil):LongString;
 public // Auxiliary routines
  procedure Pct_Set_DropChars(out DropChars:TCharSet; const Reserved:TCharSet=[]);
  procedure ApplyPctDecode(var Item,errors:LongString; note:LongString);
  procedure AddErrors(var errors:LongString; error:LongString);
 public // Port services resolver from /etc/services
  function  FindServicePort(const service:LongString; const protocol:LongString='tcp'):Integer;
  function  ServicePortInfo(port:Integer; const protocol:LongString='tcp'):LongString;
  function  ServicePortName(port:Integer; const protocol:LongString='tcp'; num:Integer=1):LongString;
  function  ServicePortList(Reset:Boolean=False):LongString;
  function  InitServices(Reset:Boolean=False):Boolean;
  function  ValidPortNumber(aPort:Integer):Boolean;
  function  EtcServicesFile:LongString;
 public // Test routines
  procedure Test_Pct_Encode_Decode(NumIter:Integer=100; MinLen:Integer=0; MaxLen:Integer=40; Echo:TEchoProcedure=nil);
  function  TestParseRfcUri(uri:LongString; Echo:TEchoProcedure=nil):Boolean;
  function  TestParseDbUri(uri:LongString; Echo:TEchoProcedure=nil):Boolean;
  procedure TestParseDbUris(Echo:TEchoProcedure=nil);
 end;

 {
 The only one URI Manager instance.
 }
function UriMan:TUriManager;

 {
 Percent encode string S using Reserved chars (to be %-escaped).
 }
function percent_encode(const S:LongString; const Reserved:TCharSet=[]):LongString;

 {
 Percent decode string S, use Errors counter if one assigned.
 }
function percent_decode(const S:LongString; const Errors:PInteger=nil):LongString;

 {
 Percent encoder control to get/set Reserved chars and Errors.
 when arg is
  Reserved      - get string Reserved chars
  Reserved=rc   - set Reserved chars from string (rc)
  Errors        - get Errors as string
  Errors=n      - set Errors from string
 }
function percent_encoder_ctrl(const arg:LongString; var Reserved:TCharSet; var Errors:Integer):LongString;

 {
 Initialize services - procedure for InitSubSystems.
 }
procedure UriMan_InitServices;

implementation

/////////////////////
// auxiliary routines
/////////////////////

function percent_encode(const S:LongString; const Reserved:TCharSet=[]):LongString;
begin
 Result:=UriMan.Pct_Encode(S,Reserved);
end;

function percent_decode(const S:LongString; const Errors:PInteger=nil):LongString;
begin
 Result:=UriMan.Pct_Decode(S,Errors);
end;

function percent_encoder_ctrl(const arg:LongString; var Reserved:TCharSet; var Errors:Integer):LongString;
var p:Integer; sn,sv:LongString; rc:TCharSet;
begin
 Result:=''; sn:=''; sv:=''; rc:=[];
 p:=ExtractNameValuePair(arg,sn,sv,'=',0);
 if (p=0) then begin sn:=arg; sv:=''; end;
 if SameText(sn,'Reserved') then begin
  UriMan.Pct_Set_DropChars(rc,Reserved);
  Result:=SetOfCharsToString(rc);
  if (p>0) then Reserved:=StringToSetOfChars(sv);
 end else
 if SameText(sn,'Errors') then begin
  Result:=IntToStr(Errors);
  if (p>0) then Errors:=StrToIntDef(sv,Errors);
 end;
end;

 /////////////////////////////
 // TUriManager implementation
 /////////////////////////////

constructor TUriManager.Create;
begin
 inherited Create;
 myServices:=NewHashList(false,HashList_DefaultHasher);
 myServices.Master:=@myServices;
 myPortList:='';
 InitHexTab;
end;

destructor TUriManager.Destroy;
begin
 myPortList:='';
 Kill(myServices);
 inherited Destroy;
end;

procedure TUriManager.InitHexTab;
const HexCharUp:PChar=RFC3986_HEXDIG_UPPER;
const HexCharLo:PChar=RFC3986_HEXDIG_LOWER;
var i:Byte;
begin
 if Assigned(Self) then begin
  for i:=0 to 255 do myHexTab[Chr(i)]:=255;
  for i:=0 to 15 do myHexTab[HexCharUp[i]]:=i;
  for i:=0 to 15 do myHexTab[HexCharLo[i]]:=i;
 end;
end;

procedure TUriManager.Pct_Set_DropChars(out DropChars:TCharSet; const Reserved:TCharSet=[]);
begin
 if (Reserved<>[])
 then DropChars:=Reserved
 else DropChars:=Pct_DropChars_Default;
 Include(DropChars,'%'); // Always MUST be in set
end;

function TUriManager.Pct_Encode(const S:LongString; const Reserved:TCharSet=[]):LongString;
var PS,PE,PT,PR:PChar; Target:LongString; L:SizeInt; DropChars:TCharSet;
const HexChar:PChar=RFC3986_HEXDIG_UPPER;
begin
 Result:='';
 if (S<>'') then
 if Assigned(Self) then
 try
  DropChars:=Default(TCharSet);
  pct_set_DropChars(DropChars,Reserved);
  L:=Length(S);
  PS:=PChar(S); PE:=PS+L;
  Target:=StringBuffer(L*3);
  PT:=PChar(Target); PR:=PT;
  if (PR=nil) then Exit;
  while (PS<PE) do begin
   if (PS[0] in DropChars) then begin
    PR[0]:='%';
    Inc(PR); PR[0]:=HexChar[Byte(PS[0]) shr 4];
    Inc(PR); PR[0]:=HexChar[Byte(PS[0]) and $F];
   end else PR[0]:=PS[0];
   Inc(PR);
   Inc(PS);
  end;
  L:=(PR-PT);
  Result:=Copy(Target,1,L);
 except
  on E:Exception do BugReport(E,Self,'pct_encode');
 end;
end;

function TUriManager.Pct_Decode(const S:LongString; const Errors:PInteger=nil):LongString;
var PS,PE,PT,PR:PChar; Target:LongString; L:SizeInt; cl,ch:Byte;
begin
 Result:='';
 if (S<>'') then
 if Assigned(Self) then
 try
  L:=Length(S);
  PS:=PChar(S); PE:=PS+L;
  Target:=StringBuffer(L);
  PT:=PChar(Target); PR:=PT;
  while (PS<PE) do begin
   if (PS[0]='%') then begin
    if (PS+1<PE) then ch:=myHexTab[PS[1]] else ch:=255;
    if (PS+2<PE) then cl:=myHexTab[PS[2]] else cl:=255;
    if (cl>15) or (ch>15) then begin
     if (Errors<>nil) then Inc(Errors^);
     PR[0]:=PS[0];
    end else begin
     PR[0]:=Chr((ch shl 4) or cl);
     Inc(PS,2);
    end;
   end else PR[0]:=PS[0];
   Inc(PR);
   Inc(PS);
  end;
  L:=(PR-PT);
  Result:=Copy(Target,1,L);
 except
  on E:Exception do BugReport(E,Self,'pct_decode');
 end;
end;

procedure TUriManager.Test_Pct_Encode_Decode(NumIter:Integer=100; MinLen:Integer=0; MaxLen:Integer=40; Echo:TEchoProcedure=nil);
var iter,errors,i,len:Integer; st,se,sd:LongString;
 function crand(n:Integer=10):Integer;
 var i:Integer;
 begin
  Exit(Round(Math.RandG(64,32)));
  Result:=0;
  for i:=1 to n do Inc(Result,Random(256));
  Result:=(Result div n);
 end;
begin
 if Assigned(Self) then
 try
  errors:=0;
  if not Assigned(Echo) then Echo:=SystemEchoProcedure;
  Echo('Test pct_encode/decode:'+EOL);
  for iter:=1 to NumIter do begin
   len:=MinLen+Random(MaxLen-MinLen+1);
   st:=''; for i:=1 to len do st:=st+Chr(crand);
   se:=pct_encode(st,Pct_DropChars_Maximal); sd:=pct_decode(se,@errors);
   Echo(Format('%-5d  %-5s  %s',[iter,BoolToStr(st=sd,'True','False'),se])+EOL);
   if (st<>sd) then inc(errors);
  end;
  Echo(Format('%d error(s) found',[errors])+EOL);
 except
  on E:Exception do BugReport(E,Self,'test_pct_encode_decode');
 end;
end;

function TUriManager.Parse_URI(const URI:LongString; out scheme,authority,path,query,fragment,errors:LongString):Boolean;
const rxpatorig='/^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?/'; // RFC-3986 Appendix B
const rxpat='/^(([^:\/?#]+):)?(\/\/([^\/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?/'; // RFC Errata 2624
const ischeme=2; iauthority=4; ipath=5; iquery=7; ifragment=9;
var rex:Integer;
begin
 Result:=False;
 scheme:=''; authority:=''; path:=''; query:=''; fragment:=''; errors:='';
 if HasChars(URI,JustSpaces) then begin errors:='Spaces in URI.'; Exit; end;
 if Assigned(Self) then
 try
  rex:=regexp_init(0,rxpat,'');
  if (rex<>0) then
  try
   if regexp_exec(rex,URI)=1 then begin
    scheme    := regexp_matchstr(rex,1,ischeme);
    authority := regexp_matchstr(rex,1,iauthority);
    path      := regexp_matchstr(rex,1,ipath);
    query     := regexp_matchstr(rex,1,iquery);
    fragment  := regexp_matchstr(rex,1,ifragment);
   end else AddErrors(errors,'URI not satisfy RFC3986.');
   FakeNop(rxpatorig); // To avoid hints
   Result:=(errors='');
  finally
   regexp_free(rex);
  end;
 except
  on E:Exception do BugReport(E,Self,'parse_uri');
 end;
end;

procedure TUriManager.ApplyPctDecode(var Item,errors:LongString; note:LongString);
var nErrors:Integer;
begin
 nErrors:=0;
 if Assigned(Self) then
 if HasChars(Item,['%']) then begin
  Item:=Pct_Decode(Item,@nErrors);
  if (nErrors>0) then AddErrors(errors,'Bad pct-decode '+note+'.');
 end;
end;

procedure TUriManager.AddErrors(var errors:LongString; error:LongString);
begin
 if (Self=nil) or (error='') then Exit;
 if (errors<>'') then errors:=errors+EOL;
 errors:=errors+error;
end;

function TUriManager.Parse_DB_URI(const URI:LongString; out provider,user,pass,host,port,dbname,query,fragment,errors:LongString):Boolean;
var scheme,authority,path,up,hp,un,pw,hn,pn:LongString;
begin
 Result:=False;
 up:=''; hp:=''; un:=''; pw:=''; hn:=''; pn:='';
 provider:=''; user:=''; pass:=''; host:=''; port:=''; dbname:='';
 scheme:=''; authority:=''; path:=''; query:=''; fragment:=''; errors:='';
 if (URI<>'') then
 if Assigned(Self) then
 try
  if Parse_URI(URI,scheme,authority,path,query,fragment,errors) then begin
   provider:=scheme;
   if (authority<>'') then begin
    if (ExtractNameValuePair(authority,up,hp,'@')=0)
    then begin up:=''; hp:=authority; end;
    if (ExtractNameValuePair(up,un,pw,':')>0)
    then begin user:=un; pass:=pw; end
    else begin user:=up; pass:=''; end;
    if (ExtractNameValuePair(hp,hn,pn,':')>0)
    then begin host:=hn; port:=pn; end
    else begin host:=hp; port:=''; end;
   end;
   dbname:=path;
   if StartsText('/',dbname) then Delete(dbname,1,1);
  end else Exit;
  Result:=(errors='');
 except
  on E:Exception do BugReport(E,Self,'parse_db_uri');
 end;
end;

function TUriManager.Parse_DB_URI_As_Cookies(
 const URI:LongString;    // provider://user:pass@host:port/dbname?p1=v1&p2=v2..
   out params:LongString; // Return URI_SCHEME=scheme;URI_AUTHORITY=authority;..
   out errors:LongString; // Return error string if something wrong
       del:TCharSet=[];   // Query delimeters, default is [&;]
       sep:LongString=''; // Separator for Params, default is ';'
       opt:LongString=''  // Options: list of params to pct-decode
       ):Boolean;         // True if URI satisfy template
var pr,un,pw,hn,pn,db,qu,fr,pl,sn,sv:LongString; Lines:TStringList; ip,np:Integer;
 function IsOptPct(s:LongString):Boolean;
 begin // Option to apply pct-decode
  Result:=(WordIndex(s,CookieScan(opt,'Pct',Ord(';')),ScanSpaces)>0);
 end;
 function IsOptChk(s:LongString):Boolean;
 begin // Option to check parameter
  Result:=(WordIndex(s,CookieScan(opt,'Chk',Ord(';')),ScanSpaces)>0);
 end;
begin
 Result:=False;
 params:=''; errors:='';
 pr:=''; un:=''; pw:=''; hn:=''; pn:='';
 db:=''; qu:=''; fr:=''; pl:=''; sn:=''; sv:='';
 if HasChars(uri,JustSpaces) then begin errors:='Spaces in URI.'; Exit; end;
 if Assigned(Self) then
 try
  if (sep='') then sep:=';';
  if (del=[]) then del:=RFC3986_def_query_delims;
  if (opt='') then opt:='Pct=PASSWORD,DATABASE,KEY,VALUE;Chk=USERNAME,HOSTNAME,PORT;';
  if parse_db_uri(uri,pr,un,pw,hn,pn,db,qu,fr,errors) then begin
   Lines:=TStringList.Create;
   try
    if IsOptPct('PROVIDER') then ApplyPctDecode(pr,errors,'URI PROVIDER');
    if IsOptPct('USERNAME') then ApplyPctDecode(un,errors,'URI USERNAME');
    if IsOptPct('PASSWORD') then ApplyPctDecode(pw,errors,'URI PASSWORD');
    if IsOptPct('HOSTNAME') then ApplyPctDecode(hn,errors,'URI HOSTNAME');
    if IsOptPct('PORT')     then ApplyPctDecode(pn,errors,'URI PORT');
    if IsOptPct('DATABASE') then ApplyPctDecode(db,errors,'URI DATABASE');
    if IsOptChk('PROVIDER') then begin
     if (pr<>'') and not IsLexeme(pr,lex_name)
     then AddErrors(errors,'Bad provider format.');
    end;
    if IsOptChk('USERNAME') then begin
     if (un<>'') and not IsLexeme(un,lex_domuser)
     then AddErrors(errors,'Bad username format.');
    end;
    if IsOptChk('HOSTNAME') then begin
     if (hn<>'') and not IsLexeme(hn,lex_dnshost)
     then AddErrors(errors,'Bad hostname format.');
    end;
    if IsOptChk('PORT') then begin
     if (pn<>'') and not IsLexeme(pn,lex_digit) then begin
      np:=FindServicePort(pn); if (np>=0) then pn:=IntToStr(np);
     end;
     if (pn<>'') and not ValidPortNumber(StrToIntDef(pn,-1))
     then AddErrors(errors,'Bad portnumber format.');
   end;
    if (pr<>'') then Lines.Values['PROVIDER']:=pr;
    if (un<>'') then Lines.Values['USERNAME']:=un;
    if (pw<>'') then Lines.Values['PASSWORD']:=pw;
    if (hn<>'') then Lines.Values['HOSTNAME']:=hn;
    if (pn<>'') then Lines.Values['PORT'    ]:=pn;
    if (db<>'') then Lines.Values['DATABASE']:=db;
    for ip:=1 to WordCount(qu,del) do begin
     pl:=ExtractWord(ip,qu,del);
     if ExtractNameValuePair(pl,sn,sv)>0 then begin
      if IsOptPct('KEY')   then ApplyPctDecode(sn,errors,'URI QUERY KEY');
      if IsOptPct('VALUE') then ApplyPctDecode(sv,errors,'URI QUERY VALUE');
      Lines.Values[sn]:=sv;
     end;
    end;
    Params:=Lines.Text;
    Result:=(Lines.Count>0) and (errors='');
    if (sep<>EOL) then Params:=StringReplace(Params,EOL,sep,[rfReplaceAll]);
   finally
    Kill(Lines);
   end;
  end;
 except
  on E:Exception do BugReport(E,nil,'parse_database_uri');
 end;
end;

function TUriManager.Looks_Like_URI(const Arg:LongString):Boolean;
begin
 Result:=False;
 if (Arg='') then Exit;
 if not Assigned(Self) then Exit;
 if (Pos('://',Arg)=0) then Exit;
 if HasChars(Arg,JustSpaces) then Exit;
 if not IsLexeme(Arg,lex_UriAddr) then Exit;
 if not IsLexeme(StrAheadOf(Arg,':'),lex_Name) then Exit;
 Result:=True;
end;

function TUriManager.Copy_DB_URI_As_Params(
   const Arg:LongString;    // Connection string as Params or as DB URI
   out   Errors:LongString; // Error string on URI format error(s)
   const del:TCharSet=[];   // Query delimeters, default is [&;]
   const sep:LongString=''; // Separator for Params, default is ';'
   const opt:LongString=''  // Options: list of params to pct-decode
         ):LongString;      // Connections string as Params only
var Params:LongString;
begin
 Result:=Arg;
 Errors:=''; Params:='';
 if IsEmptyStr(Arg) then Exit;
 if not Assigned(Self) then Exit;
 if not Looks_Like_URI(Arg) then Exit;
 if not Parse_DB_URI_As_Cookies(Arg,Params,Errors,del,sep,opt) then Exit;
 Result:=Params; Errors:='';
end;

function TUriManager.Valid_URI(const URI:LongString):Boolean;
var sc,au,pa,qu,fr,er:LongString;
begin
 Result:=False;
 if Self=nil then Exit;
 sc:=''; au:=''; pa:='';
 qu:=''; fr:=''; er:='';
 Result:=Parse_URI(URI,sc,au,pa,qu,fr,er);
end;

function TUriManager.Fetch_URI_Scheme(const URI:LongString):LongString;
var sc,au,pa,qu,fr,er:LongString;
begin
 Result:='';
 if Self=nil then Exit;
 sc:=''; au:=''; pa:='';
 qu:=''; fr:=''; er:='';
 if Parse_URI(URI,sc,au,pa,qu,fr,er)
 then Result:=sc;
end;

function TUriManager.Fetch_URI_Authority(const URI:LongString):LongString;
var sc,au,pa,qu,fr,er:LongString;
begin
 Result:='';
 if Self=nil then Exit;
 sc:=''; au:=''; pa:='';
 qu:=''; fr:=''; er:='';
 if Parse_URI(URI,sc,au,pa,qu,fr,er)
 then Result:=au;
end;

function TUriManager.Fetch_URI_Path(const URI:LongString):LongString;
var sc,au,pa,qu,fr,er:LongString;
begin
 Result:='';
 if Self=nil then Exit;
 sc:=''; au:=''; pa:='';
 qu:=''; fr:=''; er:='';
 if Parse_URI(URI,sc,au,pa,qu,fr,er)
 then Result:=pa;
end;

function TUriManager.Fetch_URI_Query(const URI:LongString):LongString;
var sc,au,pa,qu,fr,er:LongString;
begin
 Result:='';
 if Self=nil then Exit;
 sc:=''; au:=''; pa:='';
 qu:=''; fr:=''; er:='';
 if Parse_URI(URI,sc,au,pa,qu,fr,er)
 then Result:=qu;
end;

function TUriManager.Fetch_URI_Fragment(const URI:LongString):LongString;
var sc,au,pa,qu,fr,er:LongString;
begin
 Result:='';
 if Self=nil then Exit;
 sc:=''; au:=''; pa:='';
 qu:=''; fr:=''; er:='';
 if Parse_URI(URI,sc,au,pa,qu,fr,er)
 then Result:=fr;
end;

function TUriManager.EtcServicesFile:LongString;
begin
 Result:='';
 if IsUnix then begin
  Result:='/etc/services';
  if FileIsReadable(Result) then Exit;
  Result:='';
 end;
 if IsWindows then begin
  Result:=ExpEnv('%SystemRoot%\System32\drivers\etc\services');
  if FileIsReadable(Result) then Exit;
  Result:='';
 end;
 if ReadIniFilePath(SysIniFile,SectSystem(1),'EtcServicesFallback',HomeDir,Result) then
 if FileIsReadable(Result) then Exit;
 Result:='';
end;

function TUriManager.ValidPortNumber(aPort:Integer):Boolean;
begin
 Result:=InRange(aPort,0,High(Word));
end;

function TUriManager.InitServices(Reset:Boolean=False):Boolean;
var Lines:TStringList; i,j:Integer; Line,sn,sp,sa,sc,sl,pn,pr,fn:LongString;
 procedure AddService(key,alias,note:LongString);
 var value:LongString;
 begin
  if (key<>'') then begin
   value:=Format('%s # %s',[alias,note]);
   myServices.KeyedParams[key]:=value;
  end;
 end;
begin
 Result:=False;
 if Assigned(Self) then
 try
  if Reset then myServices.Clear;
  if (myServices.Count=0) then begin
   Line:=''; sn:=''; sp:=''; sa:='';
   sc:='';   sl:=''; pn:=''; pr:='';
   fn:=EtcServicesFile;
   if IsEmptyStr(fn) then Exit;
   if not FileIsReadable(fn) then Exit;
   Lines:=TStringList.Create;
   try
    StringsLoadFromFile(Lines,fn);
    for i:=0 to Lines.Count-1 do begin
     Line:=Trim(Lines[i]);
     if (Line='') then continue;
     if (ExtractNameValuePair(Line,sn,sc,'#')>0)
     then Line:=Trim(sn) else sc:='';
     if (Line='') then continue;
     sn:=ExtractWord(1,Line,ScanSpaces); // service name
     sp:=ExtractWord(2,Line,ScanSpaces); // port/protocol
     sa:=SkipWords(2,Line,ScanSpaces);   // alias list
     sl:=sn;
     for j:=1 to WordCount(sa,ScanSpaces)
     do sl:=sl+' '+ExtractWord(j,sa,ScanSpaces);
     if IsEmptyStr(sn) then continue;
     if IsEmptyStr(sp) then continue;
     if (ExtractNameValuePair(sp,pn,pr,'/')=0) then continue;
     if not ValidPortNumber(StrToIntDef(pn,-1)) then continue;
     if not IsLexeme(pr,lex_name) then continue;
     AddService(sp,sl,sc);
     for j:=1 to WordCount(sl,ScanSpaces) do begin
      sn:=ExtractWord(j,sl,ScanSpaces);
      AddService(sn+'/'+pr,sp,sc);
     end;
    end;
   finally
    Kill(Lines);
   end;
  end;
  Result:=(myServices.Count>0);
 except
  on E:Exception do BugReport(E,Self,'InitServices');
 end;
end;

function TUriManager.FindServicePort(const service:LongString; const protocol:LongString='tcp'):Integer;
var np:Integer; sx,pn,pr,key:LongString;
begin
 Result:=-1;
 if (service<>'') then
 if Assigned(Self) then
 try
  sx:=''; pn:=''; pr:=''; key:='';
  np:=StrToIntDef(Trim(service),-1);
  if ValidPortNumber(np) then Exit(np);
  if (myServices.Count=0) then Exit;
  key:=Trim(service)+'/'+Trim(protocol);
  sx:=myServices.KeyedParams[key];
  sx:=ExtractWord(1,sx,ScanSpaces);
  if (ExtractNameValuePair(sx,pn,pr,'/')>0) then
  if SameText(pr,protocol) then begin
   np:=StrToIntDef(pn,-1);
   if ValidPortNumber(np)
   then Result:=np;
  end;
 except
  on E:Exception do BugReport(E,Self,'FindServicePort');
 end;
end;

function TUriManager.ServicePortInfo(port:Integer; const protocol:LongString='tcp'):LongString;
var key:LongString;
begin
 Result:='';
 if Assigned(Self) then
 if ValidPortNumber(port) then
 try
  key:='';
  if (myServices.Count=0) then Exit;
  key:=IntToStr(port)+'/'+Trim(protocol);
  Result:=Trim(myServices.KeyedParams[key]);
 except
  on E:Exception do BugReport(E,Self,'ServicePortInfo');
 end;
end;

function TUriManager.ServicePortName(port:Integer; const protocol:LongString='tcp'; num:Integer=1):LongString;
var info,sl,sc:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  info:=ServicePortInfo(port,protocol);
  if (ExtractNameValuePair(info,sl,sc,'#')>0) then info:=sl;
  Result:=ExtractWord(num,info,ScanSpaces);
 except
  on E:Exception do BugReport(E,Self,'ServicePortName');
 end;
end;

function PortOrder(List:TStringList; Index1,Index2:Integer):Integer;
var port1,port2:Integer; w1,w2:LongString;
begin
 port1:=StrToIntDef(StrAheadOf(List[Index1],'/'),0);
 port2:=StrToIntDef(StrAheadOf(List[Index2],'/'),0);
 Result:=Sign(port1-port2); if (Result<>0) then Exit;
 w1:=ExtractWord(1,List[Index1],ScanSpaces);
 w2:=ExtractWord(1,List[Index2],ScanSpaces);
 Result:=Sign(AnsiCompareStr(w1,w2));
end;

function TUriManager.ServicePortList(Reset:Boolean=False):LongString;
var Lines:TStringList; i,kl,al,iter:Integer; key,par,line,sn,sp,sa,sc:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  key:=''; par:=''; line:='';
  sn:=''; sp:=''; sa:=''; sc:='';
  if (myServices.Count=0) then Exit;
  if Reset then myPortList:='';
  if (myPortList<>'') then Exit(myPortList);
  Lines:=TStringList.Create;
  try
   kl:=0; al:=0;
   for iter:=1 to 2 do
   for i:=0 to myServices.Count-1 do begin
    key:=myServices.Keys[i];
    if (ExtractNameValuePair(key,sn,sp,'/')>0) then
    if ValidPortNumber(StrToIntDef(sn,-1)) then begin
     par:=myServices.Params[i];
     if (ExtractNameValuePair(par,sa,sc,'#')=0) then continue;
     if (iter=1) then begin
      kl:=Max(kl,Length(key));
      al:=Max(al,Length(sa));
     end else begin
      line:=Format('%-*s = %-*s # %s',[kl,key,al,sa,sc]);
      Lines.Add(line);
     end;
    end;
   end;
   Lines.CustomSort(PortOrder);
   Result:=Lines.Text;
   myPortList:=Result;
  finally
   Kill(Lines);
  end;
 except
  on E:Exception do BugReport(E,Self,'ServicePortList');
 end;
end;

function TUriManager.TestParseRfcUri(uri:LongString; Echo:TEchoProcedure=nil):Boolean;
var sc,au,pt,qu,fr,err:LongString;
 function par:LongString;
 begin
  Result:='SCHEME='+sc+';AUTHORITY='+au+';PATH='+pt+';QUERY='+qu+';FRAGMENT='+fr;
 end;
begin
 if not Assigned(Self) then Exit;
 if not Assigned(Echo) then Echo:=SystemEchoProcedure;
 if parse_uri(uri,sc,au,pt,qu,fr,err)
 then Echo('Fine URI '+uri+EOL+par+EOL)
 else Echo('Fail URI '+uri+EOL+err+EOL);
 Result:=(err='');
end;

function TUriManager.TestParseDbUri(uri:LongString; Echo:TEchoProcedure=nil):Boolean;
var par,err:LongString;
begin
 par:=''; err:='';
 if not Assigned(Self) then Exit;
 if not Assigned(Echo) then Echo:=SystemEchoProcedure;
 if parse_db_uri_as_cookies(uri,par,err)
 then Echo('Fine URI '+uri+EOL+par+EOL)
 else Echo('Fail URI '+uri+EOL+err+EOL);
 Result:=(err='');
end;

procedure TUriManager.TestParseDbUris(Echo:TEchoProcedure=nil);
begin
 if not Assigned(Self) then Exit;
 if not Assigned(Echo) then Echo:=SystemEchoProcedure;
 TestParseDbUri('ib://user:pass@host:mail/dbname?par1=val1',Echo);
 TestParseDbUri('protocol://user:pass@host:port/dbname?par1=val1&par2=val2',Echo);
 TestParseDbUri('protocol://user:pass@host:1234/dbname?par1=val1&par2=val2',Echo);
 TestParseDbUri('ib://',Echo);
 TestParseDbUri('ib:///dbname',Echo);
 TestParseDbUri('ib://user@/dbname?',Echo);
 TestParseDbUri('ib://user@host/dbname?par1=val1&',Echo);
 TestParseDbUri('ib://user@host/dbname?par1=val1&par2=val2',Echo);
 TestParseDbUri('ib://user:pass@host/dbname?par1=val1&',Echo);
 TestParseDbUri('ib://user:pass@host:1234/dbname?par1=val1',Echo);
 TestParseDbUri('ib://user:pass@host:1234/dbname?par1=val1&port=4321',Echo);
 TestParseDbUri('ib://username@host-name.com/db%20name?par1=val%201&par2=val%202',Echo);
 TestParseRfcUri('ib://user:pass@host:1234/dbname?query#par1=val1#port=4321',Echo);
 TestParseRfcUri('i%20b://user%40:pass%20word@host%20name:1234/db%20name?query%20text#par1=val%201#port=4321',Echo);
end;

procedure UriMan_InitServices;
begin
 UriMan.InitServices;
end;

 ////////////////////////
 // UriMan implementation
 ////////////////////////
function UriMan:TUriManager;
const Man:TUriManager=nil;
begin
 if not Assigned(Man) then begin
  Man:=TUriManager.Create;
  Man.Master:=@Man;
 end;
 Result:=Man;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_uri;
begin
 UriMan.Ok;
 InitSubSystems.Add(UriMan_InitServices);
end;

procedure Free_crw_uri;
begin
 UriMan.Free;
end;

initialization

 Init_crw_uri;

finalization

 Free_crw_uri;

end.

//////////////
// END OF FILE
//////////////

