synhighlighteruri.pas

用delphi写的delphi源代码 用delphi写的delphi源代码 用delphi写的delphi源代码 用delphi写的delphi源代码

  inc(Run);
end;

procedure TSynURISyn.NullProc;
begin
  if Run < Length(fLineStr) then
  begin
    inc(Run);
    fTokenID := tkNullChar;
  end
  else
    fTokenID := tkNull
end;

procedure TSynURISyn.SpaceProc;
begin
  inc(Run);
  fTokenID := tkSpace;
  while FLine[Run] in [#1..#9, #11, #12, #14..#32] do inc(Run);
end;

procedure TSynURISyn.UnknownProc;
begin
  if IsValidEmailAddress then
    fTokenID := tkMailtoLink
  else
  begin
    {$IFDEF SYN_MBCSSUPPORT}
    if FLine[Run] in LeadBytes then
      Inc(Run, 2)
    else
    {$ENDIF}
      inc(Run);
    fTokenID := tkUnknown;
  end;
end;

procedure TSynURISyn.Next;
begin
  fTokenPos := Run;
  fProcTable[fLine[Run]];
end;

function TSynURISyn.GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;
begin
  case Index of
    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;
    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;
    SYN_ATTR_URI: Result := fURIAttri;
    SYN_ATTR_VISITEDURI: Result := fVisitedURIAttri;
  else
    Result := nil;
  end;
end;

function TSynURISyn.GetEol: Boolean;
begin
  Result := fTokenID = tkNull;
end;

function TSynURISyn.GetToken: string;
var
  Len: LongInt;
begin
  Len := Run - fTokenPos;
  SetString(Result, (FLine + fTokenPos), Len);
end;

function TSynURISyn.GetTokenAttribute: TSynHighlighterAttributes;
var
  Visited: Boolean;
begin
  case GetTokenID of
    tkSpace: Result := fSpaceAttri;
    tkFtpLink, tkGopherLink, tkHttpLink, tkHttpsLink, tkMailtoLink, tkNewsLink,
    tkNntpLink, tkProsperoLink, tkTelnetLink, tkWaisLink, tkWebLink:
    begin
      Visited := False;
      if Assigned(FAlreadyVisitedURI) then
        Visited := FAlreadyVisitedURI(GetToken);
      if Visited then
        Result := fVisitedURIAttri
      else
        Result := fURIAttri;
    end;
    tkUnknown: Result := fIdentifierAttri;
    else Result := nil;
  end;
end;

function TSynURISyn.GetTokenID: TtkTokenKind;
begin
  Result := fTokenId;
end;

function TSynURISyn.GetTokenKind: Integer;
begin
  Result := Ord(fTokenId);
end;

function TSynURISyn.GetTokenPos: Integer;
begin
  Result := fTokenPos;
end;

function TSynURISyn.GetIdentChars: TSynIdentChars;
begin
  Result := TSynValidStringChars + [#0];
end;

class function TSynURISyn.GetLanguageName: string;
begin
  Result := SYNS_LangURI;
end;

function TSynURISyn.GetSampleSource: string;
begin
  Result := 'Universal Resource Identifier highlighting'#13#10#13#10 +
            'http://www.somewhere.org'#13#10 +
            'ftp://superhost.org/downloads/gems.zip'#13#10 +
            'www.w3c.org'#13#10 +
            'mailto:[e-mail]'#13#10 +
            '[e-mail]'#13#10 +
            'news:comp.lang.pascal.borland';
end;

function TSynURISyn.IsFilterStored: Boolean;
begin
  Result := fDefaultFilter <> SYNS_FilterURI;
end;

procedure TSynURISyn.SetAlreadyVisitedURIFunc(Value: TAlreadyVisitedURIFunc);
begin
  FAlreadyVisitedURI := Value;
end;

procedure TSynURISyn.SetURIAttri(const Value: TSynHighlighterAttributes);
begin
  fURIAttri.Assign(Value);
end;

procedure TSynURISyn.SetVisitedURIAttri(const Value: TSynHighlighterAttributes);
begin
  fVisitedURIAttri.Assign(Value);
end;

function TSynURISyn.IsValidEmailAddress: Boolean;
var
  StartPos, AtPos, DotPos: Integer;
begin     
  StartPos := Run;

  AtPos := -1;
  DotPos := -1;
  while fLine[Run] in EMailAddressChars do
  begin
    if fLine[Run] = '@' then
      AtPos := Run
    else if fLine[Run] = '.' then
      // reject array of dots: "neighbour" dots are not allowed
      if (Run = StartPos) or (DotPos >= 0) and (DotPos = Run - 1) then
        break
      else
        DotPos := Run;
    Inc(Run);
  end;

  while (Run > StartPos) and (fLine[Run - 1] in NeverAtEMailAddressEnd) do
    dec(Run);

  while (DotPos >= Run) or (DotPos > -1) and (fLine[DotPos] <> '.') do
    Dec(DotPos);

  Result := (StartPos < AtPos) and (AtPos < Run - 1) and (DotPos > AtPos + 1);
  if not Result then Run := StartPos;
end;

function TSynURISyn.IsValidURI: Boolean;
var
  ProtocolEndPos, DotPos: Integer;

  function IsRelativePath: Boolean;
  begin
    Result := (DotPos - 1 >= 0) and
      ((fLine[DotPos - 1] = '/') and (fLine[DotPos + 2] = '/')) or
      ((fLine[DotPos - 1] = '\') and (fLine[DotPos + 2] = '\'));
  end;

begin
  ProtocolEndPos := Run;

  DotPos := -1;
  while fLine[Run] in URIChars do
  begin
    if fLine[Run] = '.' then
      // reject array of dots: "neighbour" dots are not allowed
      if (DotPos >= 0) and (DotPos = Run - 1) and not IsRelativePath then
        break
      else
        DotPos := Run;
    inc(Run);
  end;

  while (Run > ProtocolEndPos) and (fLine[Run - 1] in NeverAtEnd) do
    dec(Run);

  Result := Run > ProtocolEndPos;
end;

function TSynURISyn.IsValidWebLink: Boolean;
var
  WWWEndPos, DotPos, SecondDotPos: Integer;

  function IsRelativePath: Boolean;
  begin
    Result := (DotPos - 1 >= 0) and
      ((fLine[DotPos - 1] = '/') and (fLine[DotPos + 2] = '/')) or
      ((fLine[DotPos - 1] = '\') and (fLine[DotPos + 2] = '\'));
  end;

begin
  WWWEndPos := Run;

  DotPos := -1;
  SecondDotPos := -1;
  while fLine[Run] in URIChars do
  begin
    if fLine[Run] = '.' then
      // reject array of dots: "neighbour" dots are not allowed
      if (DotPos >= 0) and (DotPos = Run - 1) and not IsRelativePath then
        break
      else
      begin
        DotPos := Run;
        if SecondDotPos = -2 then SecondDotPos := DotPos;
        if SecondDotPos = -1 then SecondDotPos := -2;
      end;
    inc(Run);
  end;

  while (Run > WWWEndPos) and (fLine[Run - 1] in NeverAtEnd) do
    dec(Run);

  Result := (Run > WWWEndPos) and (fLine[WWWEndPos] = '.') and
            (SecondDotPos > WWWEndPos + 1) and (SecondDotPos < Run);
end;

procedure TSynURISyn.ProtocolProc;
var
  HashKey: Integer;
begin
  if IsValidEmailAddress then
    fTokenID := tkMailtoLink
  else
  begin
    fMayBeProtocol := fLine + Run;
    HashKey := KeyHash(fMayBeProtocol);
    inc(Run, fStringLen);

    if HashKey <= 97 then
      fTokenID := fIdentFuncTable[HashKey]
    else
      fTokenID := tkUnknown;
  end;
end;

function TSynURISyn.FtpFunc: TtkTokenKind;
begin
  if KeyComp('ftp://') and IsValidURI then
    Result := tkFtpLink
  else
    Result := tkUnknown;
end;

function TSynURISyn.GopherFunc: TtkTokenKind;
begin
  if KeyComp('gopher://') and IsValidURI then
    Result := tkGopherLink
  else
    Result := tkUnknown;
end;

function TSynURISyn.HttpFunc: TtkTokenKind;
begin
  if KeyComp('http://') and IsValidURI then
    Result := tkHttpLink
  else
    Result := tkUnknown;
end;

function TSynURISyn.HttpsFunc: TtkTokenKind;
begin
  if KeyComp('https://') and IsValidURI then
    Result := tkHttpsLink
  else
    Result := tkUnknown;
end;

function TSynURISyn.MailtoFunc: TtkTokenKind;
begin
  if KeyComp('mailto:') and IsValidURI then
    Result := tkMailtoLink
  else
    Result := tkUnknown;
end;

function TSynURISyn.NewsFunc: TtkTokenKind;
begin
  if KeyComp('news:') and IsValidURI then
    Result := tkNewsLink
  else
    Result := tkUnknown;
end;

function TSynURISyn.NntpFunc: TtkTokenKind;
begin
  if KeyComp('nntp://') and IsValidURI then
    Result := tkNntpLink
  else
    Result := tkUnknown;
end;

function TSynURISyn.ProsperoFunc: TtkTokenKind;
begin
  if KeyComp('prospero://') and IsValidURI then
    Result := tkProsperoLink
  else
    Result := tkUnknown;
end;

function TSynURISyn.TelnetFunc: TtkTokenKind;
begin
  if KeyComp('telnet://') and IsValidURI then
    Result := tkTelnetLink
  else
    Result := tkUnknown;
end;

function TSynURISyn.WaisFunc: TtkTokenKind;
begin
  if KeyComp('wais://') and IsValidURI then
    Result := tkWaisLink
  else
    Result := tkUnknown;
end;

function TSynURISyn.WebFunc: TtkTokenKind;
begin
  if KeyComp('www') and IsValidWebLink then
    Result := tkWebLink
  else
    Result := tkUnknown;
end;


initialization
  MakeHashTable;
{$IFNDEF SYN_CPPB_1}
  RegisterPlaceableHighlighter(TSynURISyn);
{$ENDIF}
end.