accidenceblock.pas

一个可以把源代码以语法高亮的形式转换成HTML格式或RTF格式。

          if Not DirectoryExists(DesPath) then
            //ToDo: 自己做一个自动建立多级目录的子过各
            //  DesPath 要 \ 结尾
            if Not CreateMoreDir(DesPath) then
            begin
              //application.MessageBox ('创建目录失败！','提示');
              ShowDlg(pubGet('Err_CreateDirectory'),MB_OK,MB_ICONERROR);
              Exit;
            end;  
        end;
        
        DesFileName :=ChangeFileExt(DesFileName,OutExt);
        Application.ProcessMessages;  // 别让程序没响应     
        aSrcFileName := SrcFileName;
        if IsCopySrcFile then
        begin
          aDesFileName := ChangeFileExt(DesFileName,ExtractFileExt(SrcFileName));
          //if CompareText(SrcFileName,sDesFileName)=0 and fileex... then  // 源与目的相同？
          CopyFile(PChar(SrcFileName),PChar(aDesFileName),True); // 自动覆盖         
          aDesFileName := aDesFileName + #13#10 + DesFileName ;          
        end    
        else
          aDesFileName := DesFileName;

        if gAppConfig.Terminate then Exit; 
                       
        Acc.ConversionToFile(SrcFileName,DesFileName);
        WriteWebBrowser(getMainWeb,Acc.Target.Text);      // 源码写到 WebBrowser
        sleep(100);    // 测试
        if IsCreateHTMLToTxt then
        begin
          aDesFileName := aDesFileName + #13#10 +            
             ChangeFileExt(DesFileName,'_html.txt');  
          Str.Clear;
          Str.Add(GetWebSource(getMainWeb,False));        // 从 WebBrowser 取到文本
          Len := Length(ExtractFileName(DesFileName)) -4; // 从下个字符取 (相当于点的位置)
          Str.Text := Copy(Str.Text,Len,MaxInt);          // 去标题
          Str.SaveToFile(ChangeFileExt(DesFileName,'_html.txt'));
          if IsCopySrcFile then
            StrCMD.Add(format('fc /N /C "%s" "%s" >>curdir_fc_comp_info.txt',[
              ChangeFileExt(DesFileName,ExtractFileExt(SrcFileName)),            
              ChangeFileExt(DesFileName,'_html.txt')]));
            // fc /N -- 比较显示行数, /C -- 不区分大小写   
        end;
        Inc(ProessCount);    
      end;  
    end;    // for end.
    if IsCreateHTMLToTxt and IsCopySrcFile and (StrCMD.Count >0) then
      StrCMD.SaveToFile(DesRootDir + 'fs_comp_info.txt'); 
  finally
    Acc.Free;
    if IsCreateHTMLToTxt then
    begin
//      aWeb.Free;
      Str.Free;
      if IsCreateHTMLToTxt and IsCopySrcFile then StrCMD.Free;
    end;
  end;
  Result := True;
end;

function ConvertFilesOfDir(const Dir,Exts,AccFileName:string;
  ConvType:TConvType;var Count:integer):boolean;
var
  Str :TStrings;   
begin
  Str := GetDirFiles(Dir,Exts);
  try
    Count := Str.Count ;
    Result :=ConvertFiles(Str,AccFileName,ConvType); 
  finally
    Str.Free;
  end;   
end;  

function ConvertFilesToDir(var Dir,Exts,ToDir,AccFileName:string;
  ConvType:TConvType;var Count:integer;const IsCopySrcFile:Boolean):boolean;
var
  i :integer;
  s :string;
  Str :TStrings;
begin
  Str := GetDirFiles(Dir,Exts);
  try
    Count := Str.Count ;
    Result :=ConvertFiles(Dir,ToDir,AccFileName,ConvType,Str,i,s,s,IsCopySrcFile);
  finally
    Str.Free;
  end;  
end;  

{ TAccidence }

// 数字排序
function IntListCompareStrings(List: TStringList; Index1, Index2: Integer): Integer;
var M,N :Integer;
begin
  M := StrToInt(List[Index1]);
  N := StrToInt(List[Index2]);
  if M >N then
    Result := 1
  else if M<N then
    Result := -1
  else
    Result := 0;
end;

constructor TAccidence.Create(AcciName: string; ConvType: TConvType);
var
  //AcciItem: PItemRec;
  FilePath: string;
  I :Integer;
begin
  FSrc := TStringList.Create;
  FAcciConfig := TAccidenceConfig.Create(AcciName);
  // 关键：根据名称得到xml文件名称
  //AcciItem := gSourceToConfig.GetItemByName(AcciName);
  //FilePath := GetAbsolutePath(AcciItem^.FilePath);     // 相对exe文件的绝对路径
  FilePath := GetAbsolutePath(gAppConfig.GetAccidenceFilePath(AcciName));
   
  if not FileExists(FilePath) then
    raise Exception.Create(pubGet('Info_FileNoFound'));
  FAcciConfig.LoadFromFile(FilePath);
  FConvBuilder := CreateConvBuilder(ConvType);
//FIsEach := FConvBuilder Is TConvRTF; //RTF 格式每一块都要写格式,至少不同时改变
                                       //HTM 格式常规可以统一把格式写在开头
  if ConvType = ctHTML then
  begin
    FIsEach := Not TConvHTML(FConvBuilder).FUsesPreToken;  // 是否要使用 <pre> 标记
  end
  else
    FIsEach := True;
  //FIsEver := True;
  FAttrNoHight := True ; // 属性中不高亮 <关键字>  如: VarObj.Write 中的 Write 不高亮
  
  // 符号初始化
  FSymbolFirstSet :=[];
  FSymbolSort := TStringList.Create ;
  for I :=0 to FAcciConfig.Symbols.Count -1 do
  with TSymbolConfig(FAcciConfig.Symbols.Items[i]) do
  begin
    Include(FSymbolFirstSet ,Char(BeginValue[1]));// 如集合中存在则不再加
                                                  // 或者说替换了，应比再判断好吧？
    FSymbolSort.AddObject(IntToStr(Length(BeginValue)),
      FAcciConfig.Symbols.Items[i]);
  end;
  TStringList(FSymbolSort).CustomSort(IntListCompareStrings); // 按数字大小排序

end;

destructor TAccidence.Destroy;
begin
  FSrc.Free;
  FAcciConfig.Free;
  FConvBuilder.Free;
  if Assigned(FSymbolSort) then FSymbolSort.Free;
  inherited;
end;

function TAccidence.CreateConvBuilder(ConvType: TConvType): TConvBuilder;
begin
  Result := nil;
  case ConvType of
  ctHTML: Result := TConvHTML.Create;
  ctRTF: Result := TConvRTF.Create;
  end;
end;

function TAccidence.GetTarget: TStrings;
begin
  Result := FConvBuilder.Content ;
end;

function TAccidence.getShowLine: Boolean;
begin
  Result :=FAcciConfig.GeneralConfig.ShowLine ;
end;

procedure TAccidence.setShowLine(AValue: Boolean);
begin
  if AValue <> ShowLine then
    FAcciConfig.GeneralConfig.ShowLine := AValue;
end;

function TAccidence.getUsesPreToken: Boolean;
begin
  Result := False;
  if FConvBuilder is TConvHTML then
    Result := TConvHTML(FConvBuilder).UsesPreToken ;
end;

procedure TAccidence.setUsesPreToken(Value: Boolean);
begin
  if FConvBuilder is TConvHTML then
  begin
    TConvHTML(FConvBuilder).UsesPreToken := Value;
    if Not Value then FIsEach := True;
  end;
end;

procedure TAccidence.setIsEach(Value: boolean);
begin
  if (Value<>FIsEach) then
    if FConvBuilder is TConvHTML then
    begin
      // 使用 <pre> 时才能设置
     if TConvHTML(FConvBuilder).UsesPreToken then
       FIsEach := Value;
    end
    else
      FIsEach := Value;
end;

function TAccidence.GetConvHead:string;
begin
  if Assigned(FConvBuilder) then
  begin
    if Not FConvBuilder.IsInit then
      FConvBuilder.Init(FSrc.Count ,FAcciConfig);
    Result := FConvBuilder.GetHead;
  end;
end;
function TAccidence.GetConvEnd: string;
begin
  if Assigned(FConvBuilder) then
  begin
    //if Not FConvBuilder.IsInit then FConvBuilder.Init(0,FAcciConfig);
    Result := FConvBuilder.GetEnd ;
  end;
end;

procedure TAccidence.LoadFromFile(Src: string);
begin
  FSrc.LoadFromFile(Src);
end;

procedure TAccidence.SaveToFile(Des: string);
begin
  FConvBuilder.SaveToFile(Des);
end;

procedure TAccidence.Conversion(AIsAll :boolean = True);
begin
  BeginConv;
  try
    if AIsAll then FConvBuilder.BuildHead ;
    ConversionContent ;
    if AIsAll then FConvBuilder.BuildEnd;
  finally
    EndConv;
  end;
end;

procedure TAccidence.BeginConv;
begin
  if Not FConvBuilder.IsInit then
    FConvBuilder.Init(FSrc.Count, FAcciConfig)
  else if ShowLine then
    FConvBuilder.LineCount := FSrc.Count ;
  DoBeforeConvert(self,0);
end;

procedure TAccidence.EndConv;
begin
  DoAfterConvert(self,FSrc.Count);
end;

procedure TAccidence.ConversionToFile(SrcFileName, DesFileName: string);
begin
  // ToDo : Check Params Vaild    
  // 使用此过程，当一次转一批时不用每个文件创建一个 TAccidence 实例
  
  FSrc.Clear;
  FConvBuilder.FDes.Clear;       // 不能少，否则会与之前的重叠 (批时)
  
  FSrc.LoadFromFile(SrcFileName);

  BeginConv;
  try
    FConvBuilder.BuildHead;
    ConversionContent;
    FConvBuilder.BuildEnd ;
  finally
    EndConv;
  end;

  FConvBuilder.SaveToFile(DesFileName);

end;

procedure TAccidence.ConversionContent;
var                              // 参数 AIsAll 是否生成头和尾
  Row, Col,                      // 源数据行数，当前某行的列数(固定指向下一字符)
  SI, Len,                       // 块开始位置，当前行长度
  iHighLight,                    // 符号的高亮范围 : 0'Both', 1'Symbol', 2'Content'
  iRange,                        // 符号的范围:  0'None', 1'OneWord, 2'SingleLine', 3'MultiLine'
  EIndex, BValueLen,             // 符号开始位置，符号开始长度
  EValueLen: Integer;            // 符号结束长度
  LS, Token ,                    // LS 每行数据,Token 每块数据
  {sRange,}EValue,               // 符号的范围字串 , 符号结束符
  PrveToken: string;             // PrveToken 字体相同块累计 -- 常规串
  CurFontConfig: TFontConfig;    // 当前字体配置
  IsDoubleSM,                    // 是否忽略大小写 , 是否双符号
  NoIsKeyWord,                   // 不是关键字
  IsMoreMuil:Boolean;            // 是否处理多行符号内容
  cESC           : Char;         // 转义符 没有则为 #0
                                 // 下面二个已做 本类成员变量
  //SymbolFirstSet : Set of char;// 定义符号第一字个字母集合 
  //SymbolSort     : TStrings;   // 符号表中按开始长度排序列表[升序]，用来查询

  function LocalIsSymbol :boolean;       // 是否存在已定义的符号
  var I :integer;
  begin
    Result := False;
    for I := FSymbolSort.Count -1 downto 0 do     // 要从长度最长的开始比较，否则
    with TSymbolConfig(FSymbolSort.Objects[i]),   // 会让第一符号相同的短字符先查到
         FAcciConfig do
    begin
      BValueLen := StrToInt(FSymbolSort[i]);      // 符号开始长度
      if (Col+BValueLen)-1>Len then Continue ;    // 剩余长度不够比较，继续
      if (GeneralConfig.IgnoreCase and            // 可能要分大小写 (非第一字符允许字母)
           (0=CompareText(Copy(LS,Col,BValueLen), BeginValue))) or
         (Not GeneralConfig.IgnoreCase and
           (0=CompareStr(Copy(LS,Col,BValueLen), BeginValue))) then
      begin
        EValue := EndValue;
        CurFontConfig := FontConfig ;         // 充当当前字体配置 
        IsDoubleSM := DoubleSymbol;           // 是否双符号
        EValueLen := Length(EValue);          // 结束符长度
        //sRange := Range;                    // 范围
        //  AnsiIndexText -- 不区分大小写的比较
        iRange := AnsiIndexText(Range, 
              ['None', 'OneWord','SingleLine', 'MultiLine']);                                               
        iHighLight := AnsiIndexText(HightLight, 
              ['Both', 'Symbol', 'Content']); // 高亮范围        
        if ESC<>''then
          cESC := ESC[1]                      // 转义符 只能第一个字符
        else
          cESC :=#0;
        Result := True;
        Exit;
      end;
    end;
  end;   // Local
  function SymbolEndPos: Integer;
  var
    LPos,LCol :Integer;    
  begin
    Result := -1;   // 未找到标志
    LCol := Col ;   // Col 指向开始符号 下一个字符
    if LCol<=1 then // 多行符号的非开始行时，从头找
      LPos := Pos(EValue,LS)
    else
      LPos := Pos(EValue,Copy(LS,LCol,MaxInt)) ;
    if LPos =0 then  Exit;

    if LCol<=1 then
      LCol := LPos
    else
      LCol := LCol + LPos -1;    // 指向结束符开头
      
    // 处理转义符   
    //   注：处于行尾的字符不能被转义符 转义
    //       即没有找到结束符则 按从开始符号至行尾属于符号范围