accidenceblock.pas

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

unit AccidenceBlock;

{**************Original*********************
 * brief: 词法分析单元
 * autor: linzhenqun
 * date: 2005-10-24
 * email: [e-mail]
 * blog: http://blog.csdn.net/linzhengqun
********************************************}
{----------------改版-----------------------
 - auhtor   :liqj
 - modi date:2006-07-13
 - email    :[e-mail]
 - blog     : http://blog.csdn.net/liqj
 - M Content:改变转换生成结果算法
--------------------------------------------}


interface
uses
  Windows, Classes, Config,Forms;

type
  { 转换建造基类 }
  TConvBuilder  = class
  protected
    FDes: TStrings;      // 结果
    FAcciConfig: TAccidenceConfig;  //配置类->对应配置文件.xml
    FLStr: string;       // 当前行内容
    FLastLine: Integer;  // 当前行
    FLineDigit: Integer; // 行数的位数
    FLineCount: Integer; // 结果行数  <只是内容>
    FIsInit :boolean;    // 是否已初始化
    procedure SetLineCount(AValue :Integer);
    function GetContent:TStrings;virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    (* 输出 *)
    procedure SaveToFile(FileName: string);virtual;
    procedure SaveToStream(var Stream :TStream);virtual;
    (* 初始化目标文件 *)
    procedure Init(Lines: Integer; AcciConfig: TAccidenceConfig); virtual;
    {* 创建文件头 *}
    procedure BuildHead; virtual;
    function GetHead:string;virtual; abstract;  //真正实现生成的函数
    {* 创建文件尾 *}
    procedure BuildEnd; virtual;
    function GetEnd:string;virtual; abstract;
    (* 初始化行的头 *)
    procedure StartLine; virtual;
    (* 结束化行的尾 *)
    procedure EndLine; virtual;
    (* 加进一个字符 *)
    procedure AddChar(C: Char; FontConfig: TFontConfig); virtual; abstract;
    (* 加进一个字符串 *)
    procedure AddString(S: string; FontConfig: TFontConfig); virtual; abstract;    
    
    property Content : TStrings read GetContent ;     //直接访问结果
    property AcciConfig :TAccidenceConfig read FAcciConfig;
    property IsInit : boolean read FIsInit;
    property LineCount :Integer read FLineCount write SetLineCount;
    property LineDigit :Integer read FLineDigit;
  end;

  { HTML转换类 }
  TConvHTML = class(TConvBuilder)
  private
    FTitle : string;                // 标题
    FStyles: TStrings;              // 样式
    FStyle : string;                // 样式串 初始化时生成
    FTmp   : string;                // 普通字符
    //FStyleToken :string;          // 内容标记 行<span> or 段<div>
    FSpace : Boolean;               // 空格全转 ' ' -> &nbsp;
    FUsesPreToken :Boolean;         // 是否使用<pre>标记 ,默认使用
    FCharSet :string;               // 使用字符集
  protected
    (* 转化一些特殊的字符串 *)
    procedure ChangeSpeString(var S: string);
    (* 改变一些特殊的字符 *)
    function ChangeSpeChar(C: Char): string;
    function CreateStyle(AFontConfig :TFontConfig;IsDocInner:Boolean=False):string;
    function GetStyles(Index :integer):string;
    procedure setUsesPreToken(Value :boolean);
    function GetContent:TStrings;override;
  public
    constructor Create; override;
    destructor Destroy; override;
    Procedure Init(Lines: Integer; AcciConfig: TAccidenceConfig); override;
    function GetHead:string; override;
    function GetEnd:string; override;
    procedure SaveToFile(FileName: string);override;
    procedure StartLine; override;
    procedure EndLine; override;
    procedure AddChar(C: Char; FontConfig: TFontConfig); override;
    procedure AddString(S: string; FontConfig: TFontConfig); override;

    property Space : Boolean read FSpace write FSpace;
    property UsesPreToken :Boolean read FUsesPreToken write setUsesPreToken;
    property Title : string read FTitle write FTitle;
  end;

  {RTF转换类}
  TConvRTF = class(TConvBuilder)
  private
    FTable: TStrings;            // 字体格式表
    FFontConfig : TFontConfig ;  // 上一块数据使用的字体格式
    FFontIndex  : Integer;       // 上一块数据使用的字体格式索引
  protected
    (* 转化一些特殊的字符串 *)
    procedure ChangeSpeString(var S: string);
    (* 改变一些特殊的字符 *)
    function ChangeSpeChar(C: Char): string;
    {* 处理宽字符在RTF格式中的表示法,分为二位的16进制 *}
    function ToRTFWideString(s :string) :string;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Init(Lines: Integer; AcciConfig: TAccidenceConfig); override;
    function GetHead:string; override;
    function GetEnd:string; override;
    procedure StartLine; override;
    procedure EndLine; override;
    procedure AddChar(C: Char; FontConfig: TFontConfig); override;
    procedure AddString(S: String; FontConfig: TFontConfig); override;
  end;

  TConvType = (ctHTML, ctRTF);
  { 转换事件类型 }
  TOnConvert = procedure (Sender:TObject; Count: Integer) of object;

  { 转换词法类 }
  TAccidence = class
  private
    FAcciConfig: TAccidenceConfig;  // 词法配置类 ->对应配置文件.xml
    FConvBuilder: TConvBuilder;     // 结果类
    FSrc: TStrings;                 // 源内容
    FSymbolSort: TStrings;          // 符号表中按开始长度排序列表[升序]，用来查询
    FSymbolFirstSet: set of Char;   // 定义符号第一字个字母集合
    FIsEach :Boolean;               // 每块 Token 都用样式处理
    FAttrNoHight :Boolean;          // 属性中是否也高亮，只对属性中使用 '.' 引用
                                    // 指<关键字>

    FOnBeforeConvert: TOnConvert;   // 转换触发事件: 转换前
    FOnConvProgress: TOnConvert;    //               每10行一次
    FOnAfterConvert: TOnConvert;    //               转换后

    procedure DoConvProgress(Sender:TObject; Progress: Integer);
    procedure DoBeforeConvert(Sender:TObject; Count: Integer);
    procedure DoAfterConvert(Sender:TObject; Count: Integer);

    function GetTarget:TStrings;
    function getShowLine:Boolean;
    procedure setShowLine(AValue :Boolean);
    function getUsesPreToken:Boolean;
    procedure setUsesPreToken(Value :Boolean);
    procedure setIsEach(Value :boolean);
  protected
    // 按转换类型建立转换类实例
    function CreateConvBuilder(ConvType: TConvType): TConvBuilder;
  public
    constructor Create(AcciName: string; ConvType: TConvType);
    destructor Destroy; override;

    procedure LoadFromFile(Src: string);          // 从文件得到要转换内容
    procedure SaveToFile(Des: string);            // 把转换后内容保存到文件

    procedure BeginConv;                          // 开始转换
    procedure EndConv;                            // 结束转换
    procedure ConversionContent;                  // 转换内容
    function GetConvHead:string;                  // 转换类中的头部
    function GetConvEnd: string;                  // 转换类中的尾部
    procedure Conversion(AIsAll :boolean = True); // 转换过程
    procedure ConversionToFile(SrcFileName,DesFileName:string);// 文件转换到文件

    // 转换过程事件，之前，正在处理...(第10行一次)，结束。
    property OnBeforeConvert: TOnConvert read FOnBeforeConvert
      write FOnBeforeConvert;
    property OnConvProgress: TOnConvert read FOnConvProgress
      write FOnConvProgress;
    property OnAfterConvert: TOnConvert read FOnAfterConvert
      write FOnAfterConvert;

    // 是否显示行号
    property ShowLine :Boolean read getShowLine write setShowLine;
    // 是否每行都写 默认网页时不是
    property IsEach :Boolean read FIsEach write setIsEach;
    // 属性是否高亮 只对使用 '.' 引用
    property AttrNoHight: Boolean read FAttrNoHight write FAttrNoHight;
    // 转HTML 格式时是否使用 <pre> 标记
    property HTMLUsesPreToken :Boolean read getUsesPreToken write setUsesPreToken;
    property ConvClass :TConvBuilder read FConvBuilder; // 转换类
    property Source :TStrings read FSrc write FSrc; // 直接操作转换源数据
    property Target :TStrings read GetTarget;       // 读取结果 +

        
  end;


// 转换源代码文件，目标文件名为空直接保存到源代码文件的目录中
procedure ConvertSourceFile(SrcFileName,DesFileName,
  AcciFile: string; DestType:TConvType;HTMLTitle:string='');

// 转换字串到指定格式高亮格式字串
function ConvertSource(const ASrcStr,AcciFile:string;ADestType :TConvType;
  AIsAll:Boolean = True;HTMLTitle:string=''):string;

function ConvertToHead(const AAcciFile:string;ADestType:TConvType):string;
function ConvertToEnd(const AAcciFile:string;ADestType:TConvType):string;

function RemoveLinesInHTML(ASrc :TStrings):TStrings;


// 下面几个函数可以按指定目录下的文件转换到 高亮的 html/rtf 格式
function GetDirFiles(const Dir ,Exts :string):TStrings;

function ConvertFiles(const SrcFiles :TStrings;AccFileName:string;
  ConvType:TConvType):boolean;overload;
function ConvertFiles(var SrcRootDir,DesRootDir,AccFileName :String;
  ConvType:TConvType;SrcFiles :TStrings;var ProessCount:integer;
  var aSrcFileName,aDesFileName:string;
  const IsCreateHTMLToTxt:Boolean=False;  
  const IsCopySrcFile:Boolean=False):boolean;overload;

function ConvertFilesOfDir(const Dir,Exts,AccFileName:string;
  ConvType:TConvType;var Count:integer):boolean; 
function ConvertFilesToDir(var Dir,Exts,ToDir,AccFileName:string;
  ConvType:TConvType;var Count:integer;const IsCopySrcFile:Boolean=False):boolean; 
   

// HTML源码转到 系统剪贴板格式
procedure ConvertHTMLToClipBoardHtml(inStr:string; outStream: TMemoryStream);
// 将字符串转换成 UTF8 格式
procedure WideStringToUTF8(Buf: WideString; Len: Integer; outStream: TStream);
// 复制HTML源码到 系统剪贴板
procedure CopyHTMLToClipBoard(HtmlStrBuf: PChar;SizeH: Integer;
  StrBuf: PChar; SizeT: Integer);

implementation
uses
  SysUtils, CommonUtils, Graphics, StrUtils ,Clipbrd,SHDocVw;//, FastStrings,

// 参考 cnpack 专家中的 pas2htm相关
// 复制HTML源码到 系统剪贴板  HTML Format/CF_TEXT
procedure CopyHTMLToClipBoard(HtmlStrBuf: PChar;
  SizeH: Integer; StrBuf: PChar; SizeT: Integer);
var
  Fmt: UINT;
  DataH, DataT: THandle;
  DataHPtr, DataTPtr: Pointer;
begin
  Clipboard.Open;
  EmptyClipboard;
  try
    if (HtmlStrBuf <>nil) and (SizeH >0) then      // 先复制HTML格式
    begin
      Fmt := RegisterClipboardFormat('HTML Format');
      DataH := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, SizeH +1);
      try
        DataHPtr := GlobalLock(DataH);
        try
          Move(HtmlStrbuf^,DataHPtr^,SizeH +1);
          SetClipboardData(Fmt,DataH);
        finally
          GlobalUnlock(DataH);
        end;
      except
        GlobalFree(DataH);
        raise;
      end;
    end;

    if (StrBuf <>nil) and (SizeT >0) then          // 也写TEXT格式
    begin
      DataT := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, SizeT + 1);
      try
        DataTPtr := GlobalLock(DataT);
        try
          Move(StrBuf^,DataTPtr^,SizeT +1);
          SetClipboardData(CF_TEXT ,DataT);
        finally
          GlobalUnlock(DataT);
        end;
      except
        GlobalFree(DataT);
        raise;
      end;
    end;
  finally
    Clipboard.Close;
  end;
end;

// HTML源码转到 系统剪贴板格式
//procedure ConvertHTMLToClipBoardHtml(inStream, outStream: TMemoryStream);
procedure ConvertHTMLToClipBoardHtml(inStr:string; outStream: TMemoryStream);
const
  ClipHead =
    'Version:1.0' + #13#10 +           // 1.0 版本
    'StartHTML:%.9d' + #13#10 +        // 从第一字符到 DocHand前一字符数量 00000174
    'EndHTML:%.9d' + #13#10 +          // 整个内容数量
    'StartFragment:%.9d' + #13#10 +    // 第一个字符到 <!--StartFragment--> 后 数量
    'EndFragment:%.9d' + #13#10 +      // 第一个字符到 <!--EndFragment--> 前 数量
    'StartSelection:%.9d' + #13#10 +   // =StartFragment
    'EndSelection:%.9d' + #13#10+      // =EndFragment
    'SourceURL:about:blank'+#13#10;    // 来源地址 http://xx.xx.xx/xxx.htm
  DocHead =                            // html 文档中开始  -- 假设原来还没有
    '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">'#13#10;

  StartFragment = '<!--StartFragment-->';
  EndFragment   = '<!--EndFragment-->';
var
  //tmpoutStream :TMemoryStream;
  BodyPosStart ,BodyPosEnd ,
  StartPos, EndPos, HeadLen :Integer;
  PCh : PAnsiChar;
  HeadStr :AnsiString;
  Utf8Str :UTF8String;
  P :Pointer;
begin
  if (inStr='') or (outStream=nil) then Exit;

  //tmpoutStream := TMemoryStream.Create;
  try
    { 在 MSDN 中查找：HTML Clipboard Format
      内容是UTF8格式
      HeadStr              -> ClipHead
      DocHead              -> HTML First Row
      <html>             |
      <head>             |
      <title></title>    | -> HTMLHead
      <mete ....         |
      </head>            |
      <body class="g1">  |
      <!--StartFragment-->
      <pre>              |
      <div ...           | -> HTMLBody
      </pre>             |
      <!--EndFragment-->
      </body>            | -> HTMLEnd
      </html>            |
    }

    outStream.Clear;
    
    //WideStringToUTF8(StrPas(inStream.Memory),inStream.Size,tmpoutStream);
    //CharsetToIdent() 
    if getCharSet <> 'UTF-8' then
      Utf8Str :=Utf8Encode(inStr)//Copy(StrPas(inStream.Memory),1,inStream.Size-1));
    else
      Utf8Str := inStr;  
    //tmpoutStream.Write(Utf8Str[1],Length(Utf8Str));

    HeadStr := Format(ClipHead,[0,0,0,0,0,0,0]);  // 先留位置
    HeadLen := Length(HeadStr);
    outStream.Write(HeadStr[1],HeadLen);          // 写格式头

    // ----标记全为小写时 定位内容位置
    BodyPosEnd := Pos('</body>',LowerCase(Utf8Str){StrPas(tmpoutStream.Memory)});
    if BodyPosEnd =-1 then BodyPosEnd := Length(Utf8Str);//tmpoutStream.Size ;

    //PCh := PChar(tmpoutStream.Memory);
    BodyPosStart := Pos('<body',LowerCase(Utf8Str){StrPas(tmpoutStream.Memory)});
    while (BodyPosStart< BodyPosEnd) and ({PCh}Utf8Str[BodyPosStart]<>'>') do