highlightxml.pas

Delphi VCL Component Pack

procedure THighlightXML.CDATAProc;
begin
   fTokenID := tkCDATA;
   if (fLine[Run] in [#0, #10, #13]) then
      begin
         fProcTable[fLine[Run]];
         Exit;
      end;

   while not (fLine[Run] in [#0, #10, #13]) do
      begin
         if (fLine[Run] = '>') and (fLine[Run - 1] = ']')
            then
            begin
               fRange := rsText;
               Inc(Run);
               break;
            end;
         Inc(Run);
      end;
end;

procedure THighlightXML.ElementProc;
begin
   if fLine[Run] = '/' then
      Inc(Run);
   while (fLine[Run] in NameChars) do
      Inc(Run);
   fRange := rsAttribute;
   fTokenID := tkElement;
end;

procedure THighlightXML.AttributeProc;
begin
  //Check if we are starting on a closing quote
   if (fLine[Run] in [#34, #39]) then
      begin
         fTokenID := tkSymbol;
         fRange := rsAttribute;
         Inc(Run);
         Exit;
      end;
  //Read the name
   while (fLine[Run] in NameChars) do
      Inc(Run);
  //Check if this is an xmlns: attribute
   if (Pos('xmlns', GetToken) > 0) then
      begin
         fTokenID := tknsAttribute;
         fRange := rsnsEqual;
      end
   else
      begin
         fTokenID := tkAttribute;
         fRange := rsEqual;
      end;
end;

procedure THighlightXML.EqualProc;
begin
   if fRange = rsnsEqual then
      fTokenID := tknsEqual
   else
      fTokenID := tkEqual;

   while not (fLine[Run] in [#0, #10, #13]) do
      begin
         if (fLine[Run] = '/') then
            begin
               fTokenID := tkSymbol;
               fRange := rsElement;
               Inc(Run);
               Exit;
            end
         else
            if (fLine[Run] = #34) then
               begin
                  if fRange = rsnsEqual then
                     fRange := rsnsQuoteAttrValue
                  else
                     fRange := rsQuoteAttrValue;
                  Inc(Run);
                  Exit;
               end
            else
               if (fLine[Run] = #39) then
                  begin
                     if fRange = rsnsEqual then
                        fRange := rsnsAPosAttrValue
                     else
                        fRange := rsAPosAttrValue;
                     Inc(Run);
                     Exit;
                  end;
         Inc(Run);
      end;
end;

procedure THighlightXML.QAttributeValueProc;
begin
   if fRange = rsnsQuoteAttrValue then
      fTokenID := tknsQuoteAttrValue
   else
      fTokenID := tkQuoteAttrValue;

   while not (fLine[Run] in [#0, #10, #13, '&', #34]) do
      Inc(Run);

   if fLine[Run] = '&' then
      begin
         if fRange = rsnsQuoteAttrValue then
            fRange := rsnsQuoteEntityRef
         else
            fRange := rsQuoteEntityRef;
         Exit;
      end
   else
      if fLine[Run] <> #34 then
         begin
            Exit;
         end;

   fRange := rsAttribute;
end;

procedure THighlightXML.AAttributeValueProc;
begin
   if fRange = rsnsAPosAttrValue then
      fTokenID := tknsAPosAttrValue
   else
      fTokenID := tkAPosAttrValue;

   while not (fLine[Run] in [#0, #10, #13, '&', #39]) do
      Inc(Run);

   if fLine[Run] = '&' then
      begin
         if fRange = rsnsAPosAttrValue then
            fRange := rsnsAPosEntityRef
         else
            fRange := rsAPosEntityRef;
         Exit;
      end
   else
      if fLine[Run] <> #39 then
         begin
            Exit;
         end;

   fRange := rsAttribute;
end;

procedure THighlightXML.TextProc;
const
   StopSet = [#0..#31, '<', '&'];
begin
   if fLine[Run] in (StopSet - ['&']) then
      begin
         fProcTable[fLine[Run]];
         exit;
      end;

   fTokenID := tkText;
   while not (fLine[Run] in StopSet) do
      Inc(Run);

   if (fLine[Run] = '&') then
      begin
         fRange := rsEntityRef;
         Exit;
      end;
end;

procedure THighlightXML.EntityRefProc;
begin
   fTokenID := tkEntityRef;
   fRange := rsEntityRef;
   while not (fLine[Run] in [#0..#32, ';']) do
      Inc(Run);
   if (fLine[Run] = ';') then
      Inc(Run);
   fRange := rsText;
end;

procedure THighlightXML.QEntityRefProc;
begin
   if fRange = rsnsQuoteEntityRef then
      fTokenID := tknsQuoteEntityRef
   else
      fTokenID := tkQuoteEntityRef;

   while not (fLine[Run] in [#0..#32, ';']) do
      Inc(Run);
   if (fLine[Run] = ';') then
      Inc(Run);

   if fRange = rsnsQuoteEntityRef then
      fRange := rsnsQuoteAttrValue
   else
      fRange := rsQuoteAttrValue;
end;

procedure THighlightXML.AEntityRefProc;
begin
   if fRange = rsnsAPosEntityRef then
      fTokenID := tknsAPosEntityRef
   else
      fTokenID := tkAPosEntityRef;

   while not (fLine[Run] in [#0..#32, ';']) do
      Inc(Run);
   if (fLine[Run] = ';') then
      Inc(Run);

   if fRange = rsnsAPosEntityRef then
      fRange := rsnsAPosAttrValue
   else
      fRange := rsAPosAttrValue;
end;

procedure THighlightXML.IdentProc;
begin
   case fRange of
      rsElement: ElementProc;
      rsAttribute: AttributeProc;
      rsEqual, rsnsEqual: EqualProc;
      rsQuoteAttrValue, rsnsQuoteAttrValue: QAttributeValueProc;
      rsAposAttrValue, rsnsAPosAttrValue: AAttributeValueProc;
      rsQuoteEntityRef, rsnsQuoteEntityRef: QEntityRefProc;
      rsAposEntityRef, rsnsAPosEntityRef: AEntityRefProc;
      rsEntityRef:
         begin
            EntityRefProc;
         end;
      else
         ;
   end;
end;

procedure THighlightXML.Next;
begin
   fTokenPos := Run;
   case fRange of
      rsText: TextProc;
      rsComment: CommentProc;
      rsProcessingInstruction: ProcessingInstructionProc;
      rsDocType: DocTypeProc;
      rsCDATA: CDATAProc;
      else
         fProcTable[fLine[Run]];
   end;
end;

function THighlightXML.NextTokenIs(T: string): Boolean;
var
   I, Len: Integer;
begin
   Result := True;
   Len := Length(T);
   for I := 1 to Len do
      if (fLine[Run + I] <> T[I]) then
         begin
            Result := False;
            Break;
         end;
end;

function THighlightXML.GetEol: Boolean;
begin
   Result := fTokenId = tkNull;
end;

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

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

function THighlightXML.GetTokenAttribute: integer;
begin
   case fTokenID of
      tkElement: Result := 1; //fElementAttri;
      tkAttribute: Result := 2; //fAttributeAttri;
      tknsAttribute: Result := 3; //fnsAttributeAttri;
      tkEqual: Result := 4; //fSymbolAttri;
      tknsEqual: Result := 5; //fSymbolAttri;
      tkQuoteAttrValue: Result := 6; //fAttributeValueAttri;
      tkAPosAttrValue: Result := 7; //fAttributeValueAttri;
      tknsQuoteAttrValue: Result := 8; //fnsAttributeValueAttri;
      tknsAPosAttrValue: Result := 9; //fnsAttributeValueAttri;
      tkText: Result := 10; //fTextAttri;
      tkCDATA: Result := 11; //fCDATAAttri;
      tkEntityRef: Result := 1; //fEntityRefAttri;
      tkQuoteEntityRef: Result := 2; //fEntityRefAttri;
      tkAposEntityRef: Result := 3; //fEntityRefAttri;
      tknsQuoteEntityRef: Result := 4; //fEntityRefAttri;
      tknsAposEntityRef: Result := 5; //fEntityRefAttri;
      tkProcessingInstruction: Result := 6; //fProcessingInstructionAttri;
      tkComment: Result := 7; //fCommentAttri;
      tkDocType: Result := 8; //fDocTypeAttri;
      tkSymbol: Result := 9; //fSymbolAttri;
      tkSpace: Result := 10; //fSpaceAttri;
      else
         Result := 1; //nil;
   end;
end;

function THighlightXML.GetTokenKind: integer;
begin
   Result := Ord(fTokenId);
end;

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

function THighlightXML.GetRange: Pointer;
begin
   Result := Pointer(fRange);
end;

procedure THighlightXML.SetRange(Value: Pointer);
begin
   fRange := TRangeState(Value);
end;

procedure THighlightXML.ReSetRange;
begin
   fRange := rsText;
end;

function THighlightXML.PrepareOutput(Attr: integer; AToken: string): string;
var
   A: integer;
begin
   A := Attr;
   if Pos('//', Trim(AToken)) = 1 then
      A := 2;
   if ((Attr = 10) and (Pos('"', AToken) = 1)) then
      A := 6;
   Result := Format('\cf%d %s', [A, AToken]);
end;

procedure THighlightXML.PrepareToken(var AToken: string);
begin
   AToken := StringReplace(AToken, '\', '\\', [rfReplaceAll]);
end;

procedure THighlightXML.SetupDefaultColors;
begin
   CreateColorTable([clGreen, //1
      clMaroon, //2
         clBlack, //3
         clBlue, //4
         clBlack, //5
         clGreen, //6
         clBlue, //7
         clBlack, //8
         clRed, //9
         clBlack, //10
         clBlack]); //11
end;

end.