dedepproject.pas

dede 的源代码 3.10b

unit DeDePProject;

interface

uses Classes, SysUtils;

const IDENT_STRING = 'DeDeDOI';
      PREFIX_EVENTHANDLER = 'Btn_';
      PREFIX_TYPEDECLR    = 'Typ_';
      PREFIX_CUSTTYPE     = 'Cust_';
      PREFIX_ARRAY_OF     = 'ArrOf_';
      NEW_UNIT_STR        = 'Unit _DOI_;'#13#10'interface'#13#10;
      BEG_STR             = 'Type TDOIForm = class(TForm)'#13#10'published'#13#10;

procedure InitNewProject;
procedure EndProject(sFileName : String);
function StartNewClass(sClassName, sInheritsClass  : String) : Boolean;
procedure EndClass;
procedure Add(sIdent, sData : String);
procedure AddMethod(sDeclaration : String);
procedure AddProperty(sDeclaration : String);
procedure PrepareToSave(sINIT_DIR : String);

var VarTypesList : TStringList;
    CodeList : TStringList;
    PublishedMethList : TStringList;
    PublishedFieldList : TStringList;
    ImplementationList : TStringList;
    DFMStream : TMemoryStream;

    USES_LIST  : String          = '';
    INIT_DIR   : String;
    GlobClassName : String;

    GlobTypeFIXList : TStringList;
    GlobTypeFIXEDList : TStringList;
    GlobTypeSKIPList : TStringList;
    GlobClassSKIPList : TStringList;

implementation

var sClassDecl : String;
    sCustomTypes : String;
    SizePos : Integer;

Function GetTypeVarName(sTypeName : String) : String;
var s : String;
    i : Integer;
begin
  For i:=1 to Length(sTypeName) do
    if not (sTypeName[i] in [';',':']) then s:=s+sTypeName[i];
  s:=Trim(s);
  sTypeName:=s;
  Result:='';
  if s='' then Exit;

  s:=LowerCase(s);

  //0..41
  if Pos('..',s)<>0 then
     begin
       i:=Pos('..',s);
       s:=Copy(s,i+2,Length(s)-1);s:=Trim(s);
       i:=Pos(#32,s);
       if i<>0 then s:=copy(s,1,i-1);
       Result:=s;
       Exit;
     end;

  if Copy(s,1,9)='array of '
     then begin
       sTypeName:=Copy(sTypeName,10,Length(sTypeName)-9);
       s:=PREFIX_TYPEDECLR+sTypeName+' : '+sTypeName+';';
       if sTypeName<>'const' then
          begin
           s:=PREFIX_TYPEDECLR+PREFIX_ARRAY_OF+sTypeName+' : array of '+sTypeName+';';
           if VarTypesList.IndexOf(s)=-1 then VarTypesList.Add(s);
           Result:=PREFIX_TYPEDECLR+PREFIX_ARRAY_OF+sTypeName;
          end
          else Result:='[0]'; {Array of const}
     end
     else begin
        i:=GlobTypeFIXList.IndexOf(s);
        if i<>-1 then sTypeName:=GlobTypeFIXEDList[i];

        i:=GlobTypeSKIPList.IndexOf(s);
        if i<>-1 then Exit;

        s:=PREFIX_TYPEDECLR+sTypeName+' : '+sTypeName+';';
        if VarTypesList.IndexOf(s)=-1 then VarTypesList.Add(s);
        Result:=PREFIX_TYPEDECLR+sTypeName;
     end;
end;

procedure InitNewProject;
var b : String;
begin
  VarTypesList.Clear;
  PublishedFieldList.Clear;
  PublishedMethList.Clear;
  DFMStream.Clear;

  b:=#$FF#$0A#$00;
  DFMStream.WriteBuffer(b[1],3);
  b:='TDOIFORM';
  DFMStream.WriteBuffer(b[1],length(b));
  b:=#$00#$30#$10#$00#$00#$00#$00;
  DFMStream.WriteBuffer(b[1],7);
  SizePos:=DFMStream.Position-4;
  b:='TPF0'+Chr(Length('TDOIForm'))+'TDOIForm'+Chr(Length('DOIForm'))+'DOIForm';
  DFMStream.WriteBuffer(b[1],length(b));
  b:=#$04#$4C#$65#$66#$74#$03#$D5#$00#$03#$54+
     #$6F#$70#$02#$6B#$05#$57#$69#$64#$74#$68+
     #$03#$B8#$02#$06#$48#$65#$69#$67#$68#$74+
     #$03#$E0#$01#$07#$43#$61#$70#$74#$69#$6F+
     #$6E#$06#$05#$46#$6F#$72#$6D#$31#$05#$43+
     #$6F#$6C#$6F#$72#$07#$09#$63#$6C#$42#$74+
     #$6E#$46#$61#$63#$65#$0C#$46#$6F#$6E#$74+
     #$2E#$43#$68#$61#$72#$73#$65#$74#$07#$0F+
     #$44#$45#$46#$41#$55#$4C#$54#$5F#$43#$48+
{10} #$41#$52#$53#$45#$54#$0A#$46#$6F#$6E#$74+
     #$2E#$43#$6F#$6C#$6F#$72#$07#$0C#$63#$6C+
     #$57#$69#$6E#$64#$6F#$77#$54#$65#$78#$74+
     #$0B#$46#$6F#$6E#$74#$2E#$48#$65#$69#$67+
     #$68#$74#$02#$F5#$09#$46#$6F#$6E#$74#$2E+
     #$4E#$61#$6D#$65#$06#$0D#$4D#$53#$20#$53+
     #$61#$6E#$73#$20#$53#$65#$72#$69#$66#$0A+
     #$46#$6F#$6E#$74#$2E#$53#$74#$79#$6C#$65+
     #$0B#$00#$0E#$4F#$6C#$64#$43#$72#$65#$61+
     #$74#$65#$4F#$72#$64#$65#$72#$08#$0D#$50+
{20} #$69#$78#$65#$6C#$73#$50#$65#$72#$49#$6E+
     #$63#$68#$02#$60#$0A#$54#$65#$78#$74#$48+
     #$65#$69#$67#$68#$74#$02#$0D;
  DFMStream.WriteBuffer(b[1],217);
  sCustomTypes:='type'#13#10;
end;

procedure EndProject(sFileName : String);
var sz : LongWord;
    b,s : String;
    i,counter : Integer;
begin
  CodeList.Clear;
  CodeList.Add(NEW_UNIT_STR);
  s:='';b:='';
  For i:=1 To Length(USES_LIST) Do
    begin
     if USES_LIST[i]=',' then
       begin
         inc(counter);
         if counter mod 5 = 0 then b:=','#13#10
                              else b:=',';
       end
       else b:=USES_LIST[i];
       s:=s+b;
    end;
  USES_LIST:=s;
  CodeList.Add(USES_LIST);

  CodeList.Add(BEG_STR);
  CodeList.Add(PublishedFieldList.Text);
  CodeList.Add(PublishedMethList.Text);
  CodeList.Add('end;'#13#10'var'#13#10);
  CodeList.Add(VarTypesList.Text);
  CodeList.Add(sCustomTypes);
  CodeList.Add(#13#10'var DOIForm : TDOIForm;');
  CodeList.Add(#13#10'implementation'#13#10'{$R *.DFM}'#13#10);
  CodeList.Add(ImplementationList.Text);
  CodeList.Add(#13#10'end.');

  CodeList.SaveToFile(sFileName);

  // Update Length
  b:=#$00#$00;
  DFMStream.WriteBuffer(b[1],2);
  sz:=DFMStream.Size-SizePos-4;
  DFMStream.Seek(SizePos,soFromBeginning);
  DFMStream.WriteBuffer(sz,4);
  DFMStream.SaveToFile(ChangeFileExt(sFileName,'.dfm'));
end;

function StartNewClass(sClassName, sInheritsClass : String) : Boolean;
var s,b : String;
begin
  Result:=False;
  sClassName:=Trim(sClassName);
  if sClassName='' then Exit;

  Result:=True;
  GlobClassName:=sClassName;

  if GlobClassSKIPList.IndexOf(sClassName)<>-1 then Exit;
  sClassDecl:='';

  s:=PREFIX_EVENTHANDLER+sClassName+' : TButton;';
  PublishedFieldList.Add(s);
  s:='procedure '+PREFIX_EVENTHANDLER+sClassName+'Click(Sender : TObject);';
  PublishedMethList.Add(s);

  sCustomTypes:=sCustomTypes+PREFIX_CUSTTYPE+sClassName+' = Class ('+sClassName+');'#13#10;

  sClassDecl:='procedure TDOIForm.'+PREFIX_EVENTHANDLER+sClassName+'Click(Sender : TObject);'+
     #13#10'var s : String;'#13#10'inst : '+PREFIX_CUSTTYPE+sClassName+';'#13#10'begin'#13#10+
     's:='''+sInheritsClass+''';'+#13#10;



  b:=#$00;
  DFMStream.WriteBuffer(b[1],1);
  b:=#$07'TButton';
  DFMStream.WriteBuffer(b[1],length(b));
  b:=CHR(Length(PREFIX_EVENTHANDLER+sClassName))+PREFIX_EVENTHANDLER+sClassName;
  DFMStream.WriteBuffer(b[1],length(b));
  b:=#$04#$4C#$65#$66#$74#$02#$08#$03#$54#$6F#$70#$02#$10#$05#$57#$69#$64#$74#$68#$02#$71#$06#$48#$65#$69#$67#$68#$74#$02#$19#$08#$54#$61#$62#$4F#$72#$64#$65#$72#$02#$00;
  DFMStream.WriteBuffer(b[1],41);
  b:=#$07'OnClick'#$07;
  DFMStream.WriteBuffer(b[1],length(b));
  b:=PREFIX_EVENTHANDLER+sClassName+'Click';
  b:=CHR(Length(b))+b;
  DFMStream.WriteBuffer(b[1],length(b));
  b:=#$00;
  DFMStream.WriteBuffer(b[1],1);
end;

procedure EndClass;
begin
  sClassDecl:=sClassDecl+'end;'#13#10;
  ImplementationList.Add(sClassDecl);
end;

procedure Add(sIdent, sData : String);
var iPos : Integer;
    Sp, Stp : String;
Begin
  sp:='';
  For iPos:=1 to Length(sData) Do
      if not (sData[iPos] in [#1..#31]) then sp:=sp+sData[iPos];
  sData:=sp;

  iPos:=Pos(#32,sIdent);
  sp:=Copy(sIdent,1,iPos-1);
  stp:=Copy(sIdent,iPos+1,Length(sIdent)-iPos);
  if sp='private' then exit;
  if iPos=0 then stp:='';
  if (stp='') or (stp='property')
     then AddProperty(sData)
     else AddMethod(sData);
End;

procedure AddCode(s,s1 : String; bProp : Boolean = False);
var sProto, st, s_r, s_w : String;
    iPos : Integer;

    procedure ParseReadWrite(var s:String; var Rs,Ws : String);
    var rPos, wPos, iPos, dPos, sPos : Integer;
        s1 : String;
    begin
      s1:=LowerCase(s);

      iPos:=Pos(' index ',s1);
      rPos:=Pos(' read ',s1);
      wPos:=Pos(' write ',s1);
      sPos:=Pos(' stored ',s1);
      dPos:=Pos(' default ',s1);


      if rPos<>0
         then if wPos<>0
           then begin