unit unitFunc; interface uses Windows, Messages, SysUtils, Classes; type TFunc = class(TPersistent) private obj_name: string; obj_desc: string; obj_type: string; in_list: TStrings; out_list: TStrings; dispose: string; Cs: TStrings; procedure Init; procedure Clear; function GetPkg(): TStrings; procedure Comment(const ct: WideString); procedure Paramater(const ct: WideString); function GetType(const ct: WideString): Boolean; function GetPc(const ct: WideString): string; public constructor Create; destructor Destroy; override; function GetSamplePkg(mm: TStrings): TStrings; end; function SingleFunc(): TFunc; resourcestring cmt = '<tr><td>%s</td><td>%s</td></tr>'; implementation var fFunc: TFunc; { TFunc } function SingleFunc(): TFunc; begin if not Assigned(fFunc) then fFunc := TFunc.Create; result := fFunc; end; constructor TFunc.Create; begin init; end; destructor TFunc.Destroy; begin in_list.Free; out_list.Free; cs.Free; inherited; end; function TFunc.GetSamplePkg(mm: TStrings): TStrings; var i: Integer; bool: Boolean; str: string; begin Clear; bool := False; for i := 0 to mm.Count - 1 do begin str := UpperCase(mm[i]); if Pos(':', str) > 0 then Comment(str); if not bool then bool := GetType(str); if bool then Paramater(str); end; Result := GetPkg; end; function TFunc.GetPkg: TStrings; begin Result := TStringList.Create; Result.Add('<table border=1>'); Result.Add(Format(cmt, ['对象名称', obj_type + obj_name])); Result.Add(Format(cmt, ['对象描述', obj_desc])); Result.Add(Format(cmt, ['输入', in_list.Text])); Result.Add(Format(cmt, ['输出', out_list.Text])); Result.Add(Format(cmt, ['处理', self.dispose])); Result.Add('</table>'); end; procedure TFunc.Comment(const ct: WideString); var p: Integer; ls, rs: WideString; begin p := Pos(':', ct); ls := UpperCase(Trim(Copy(ct, 5, p - 5))); rs := Trim(Copy(ct, p + 1, Length(ct))); if SameText(ls, 'NAME') then obj_name := rs else if SameText(ls, 'DESCRIPTION') then obj_desc := rs; end; procedure TFunc.Init; begin in_list := TStringList.Create; out_list := TStringList.Create; Cs := TStringList.Create; Cs.Add('NAME=对象名称'); Cs.Add('DESCRIPTION=对象描述'); Cs.Add('DISPOSE=处理'); end; procedure TFunc.Clear; begin obj_name := ''; obj_desc := ''; obj_type := ''; in_list.Clear; out_list.Clear; end; function TFunc.GetType(const ct: WideString): Boolean; begin Result := Pos('PROCEDURE', ct) > 0; if Result then obj_type := '过程' else if (Pos('FUNCTION', ct) > 0) then begin Result := True; obj_type := '函数'; end; end; procedure TFunc.Paramater(const ct: WideString); var l, p: Integer; begin p := Pos(' IN ', ct); if (p > 0) then begin l := Pos('(', ct) + 1; in_list.Add(Trim(Copy(ct, l, p - l)) + GetPc(ct) + '<br />'); end else begin p := Pos(' OUT ', ct); if (p > 0) then out_list.Add(Trim(Copy(ct, 1, p)) + '<br />'); end; end; function TFunc.GetPc(const ct: WideString): string; var p: Integer; begin p := Pos('--', ct); if p = 0 then Result := '' else Result := ' ' + Trim(Copy(ct, p + 2, Length(ct))); end; end.
