Delphi VCL

Development Platform:
Delphi

URLParse.pas：Code Content
							unit URLParse;
interface
const
  PortDefault = '80'; {HTTP}
  SchemeDefault = 'http:'; {HTTP}
  NumberOfSchemes = 16;
var
  PORTS: array[1..NumberOfSchemes, 1..2] of string = (
    ('ftp:', '21'),
    ('telnet:', '23'),
    ('smtp:', '25'),
    ('whois:', '43'),
    ('whois++:', '63'),
    ('gopher:', '70'),
    ('http:', '80'),
    ('pop3:', '110'),
    ('nntp:', '119'),
    ('news:', '119'),
    ('imap2:', '143'),
    ('irc:', '194'),
    ('wais:', '210'),
    ('imap3:', '220'),
    ('ldap:', '389'),
    ('https:', '443'));
procedure ParseURL(URL: string; var FScheme, FUser, FPassword, FNetworkLocation, FPort, FPath, FResource, FParameters, FQuery, FFragment: string);
function DefaultPort(const FScheme: string): string;
implementation
uses
  SysUtils;
function DefaultPort(const FScheme: string): string;
var
  i: Integer;
begin
  Result := PortDefault;
  if FScheme <> '' then
    for i := 1 to NumberOfSchemes do
      if AnsiCompareText(FScheme, PORTS[i, 1]) = 0 then
      begin
        Result := PORTS[i, 2];
        Break;
      end;
end;
function GetToEnd(const FindChar: Char; var ParseString: string; const KeepFirst: Boolean): string;
var
  i, II: Integer;
begin
  Result := '';
  if ParseString <> '' then
  begin
    i := Pos(FindChar, ParseString);
    if i > 0 then
    begin
      II := Length(ParseString) - i + 1;
      Result := Copy(ParseString, i, II);
      Delete(ParseString, i, II);
    end;
    if not KeepFirst then
      Delete(Result, 1, 1);
  end;
end;
function ParseFragment(var ParseString: string): string;
begin
  Result := GetToEnd('#', ParseString, TRUE);
end;
function ParseScheme(var ParseString: string): string;
var
  Temp: string;
  SPtr, EPtr: PChar;
begin
  Result := SchemeDefault;
  if ParseString <> '' then
  begin
      //  Temp := ParseString;
    SetString(Temp, PChar(ParseString), Length(ParseString));
    SPtr := PChar(Temp);
    EPtr := SPtr;
    while EPtr^ in ['1'..'0', 'A'..'Z', 'a'..'z', '+', '.', '-'] do
      Inc(EPtr);
    if (EPtr^ = ':') and ((EPtr + 1)^ = '/') then
    begin
      Inc(EPtr);
      EPtr^ := #0;
      Result := string(SPtr);
      Delete(ParseString, 1, EPtr - SPtr);
    end;
  end;
end;
function ParseNetworkLocation(var ParseString: string): string;
var
  Temp: string;
  SPtr, EPtr: PChar;
  i: Integer;
begin
  Result := '';
  if ParseString <> '' then
  begin
    SetString(Temp, PChar(ParseString), Length(ParseString));
    SPtr := PChar(Temp);
    EPtr := SPtr;
    if (EPtr^ = '/') and ((EPtr + 1)^ = '/') then
    begin
      Inc(EPtr, 2);
      while not (EPtr^ in [#0, '/']) do
        Inc(EPtr);
      EPtr^ := #0;
      Result := string(SPtr + 2);
      Delete(ParseString, 1, EPtr - SPtr);
    end
    else
    begin
      i := Pos('/', ParseString);
      if i > 1 then
      begin
        Result := Copy(ParseString, 1, i - 1);
        Delete(ParseString, 1, i - 1);
      end
      else if i = 0 then
      begin
        Result := ParseString;
        ParseString := '';
      end
    end;
  end;
end;
function ParseQuery(var ParseString: string): string;
begin
  Result := GetToEnd('?', ParseString, TRUE);
end;
function ParseParameters(var ParseString: string): string;
begin
  Result := GetToEnd(';', ParseString, TRUE);
end;
function ParseResource(var ParseString: string): string;
var
  SPtr: PChar;
  rPtr: PChar;
begin
  if ParseString <> '' then
  begin
    SPtr := PChar(ParseString);
    if StrPos(SPtr, '.') <> nil then // If there is no dot, no resource
    begin
      rPtr := StrRScan(SPtr, '/');
      rPtr^ := #0;
      Inc(rPtr);
      Result := string(rPtr);
      Dec(rPtr);
      rPtr^ := '/';
      Inc(rPtr);
      rPtr^ := #0;
      SetLength(ParseString, StrLen(SPtr));
    end
    else
      Result := '';
  end;
end;
function ParsePath(var ParseString: string): string;
begin
  Result := ParseString;
end;
function ParsePassword(var ParseString: string): string;
begin
  Result := GetToEnd(':', ParseString, FALSE);
end;
function ParseUserPassword(var ParseString: string): string;
var
  i: Integer;
begin
  Result := '';
  if ParseString <> '' then
  begin
    i := Pos('@', ParseString);
    if i > 0 then
    begin
      Result := Copy(ParseString, 1, i - 1);
      Delete(ParseString, 1, i);
    end;
  end;
end;
function ParsePort(var ParseString: string): string;
begin
  Result := GetToEnd(':', ParseString, TRUE);
end;
procedure ParseURL(URL: string; var FScheme, FUser, FPassword, FNetworkLocation, FPort, FPath, FResource, FParameters, FQuery, FFragment: string);
var
  ParseString: string;
begin
  ParseString := URL;
  FFragment := ParseFragment(ParseString);
  FScheme := ParseScheme(ParseString);
  FNetworkLocation := ParseNetworkLocation(ParseString);
  FQuery := ParseQuery(ParseString);
  FParameters := ParseParameters(ParseString);
  FResource := ParseResource(ParseString);
  FPath := ParsePath(ParseString);
  if FPath = '' then
    FPath := '/';
  if FNetworkLocation <> '' then
  begin
    FUser := ParseUserPassword(FNetworkLocation);
    FPassword := ParsePassword(FUser);
    FPort := ParsePort(FNetworkLocation);
  end
  else
  begin
    FUser := '';
    FPassword := '';
  end;
end;
end.

						