<br />
<b>Warning</b>:  ob_start(): function 'compress_handler' not found or invalid function name in <b>/www/htdocs/xfmantis/core.php</b> on line <b>18</b><br />
<p style="color:red">SYSTEM WARNING: Cannot modify header information - headers already sent by (output started at /www/htdocs/xfmantis/core.php:18)</p><p style="color:red">SYSTEM WARNING: Cannot modify header information - headers already sent by (output started at /www/htdocs/xfmantis/core.php:18)</p><p style="color:red">SYSTEM WARNING: Cannot modify header information - headers already sent by (output started at /www/htdocs/xfmantis/core.php:18)</p><p style="color:red">SYSTEM WARNING: Cannot modify header information - headers already sent by (output started at /www/htdocs/xfmantis/core.php:18)</p><p style="color:red">SYSTEM WARNING: Cannot modify header information - headers already sent by (output started at /www/htdocs/xfmantis/core.php:18)</p><p style="color:red">SYSTEM WARNING: Cannot modify header information - headers already sent by (output started at /www/htdocs/xfmantis/core.php:18)</p><p style="color:red">SYSTEM WARNING: Cannot modify header information - headers already sent by (output started at /www/htdocs/xfmantis/core.php:18)</p><p style="color:red">SYSTEM WARNING: Cannot modify header information - headers already sent by (output started at /www/htdocs/xfmantis/core.php:18)</p>unit frmMain;

interface

uses
  Classes, ComCtrls, Controls, ExtCtrls, Forms, IdBaseComponent, IdComponent,
  IdExplicitTLSClientServerBase, IdFTP, IdFTPList, IdIOHandler,
  IdIOHandlerSocket, IdIOHandlerStack, IdSSL, IdSSLOpenSSL, IdTCPClient,
  IdTCPConnection, StdCtrls, DXContainer;

type
  TReferenzCreatorMainForm = class(TForm)
    DownloadButton: TButton;
    IdFTP1: TIdFTP;
    IdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL;
    LogListBox: TListBox;
    StatusBar1: TStatusBar;
    Timer1: TTimer;
    UpdateButton: TButton;
    UploadButton: TButton;
    procedure DownloadButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure IdFTP1AfterClientLogin(Sender: TObject);
    procedure IdFTP1Status(ASender: TObject; const AStatus: TIdStatus;
      const AStatusText: string);
    procedure IdSSLIOHandlerSocketOpenSSL1Status(ASender: TObject;
      const AStatus: TIdStatus; const AStatusText: string);
    procedure IdSSLIOHandlerSocketOpenSSL1StatusInfo(Msg: string);
    procedure Timer1Timer(Sender: TObject);
    procedure UpdateButtonClick(Sender: TObject);
    procedure UploadButtonClick(Sender: TObject);
  private
    procedure GenerateWikiSites;
  end;

var
  ReferenzCreatorMainForm: TReferenzCreatorMainForm;

implementation

uses
  Defines, Dialogs, FileCtrl, IniFiles, register_scripttypes, script_utils,
  SysUtils, uPSCompiler, Windows, Registry, KD4Utils, uPSUtils;

const
  Directory: String = 'C:\xforce\api\';
  Kategorie = 'XSkriptReferenz';

{$R *.DFM}

const
  XSkriptVersion = 915;

var
  g_comp: TPSPascalCompiler;

function GetFileName(Page: String): String;
begin
  result := Directory + Page + '.pasi';
end;

function LoadWikiSite(FileName: String): TStringList;
var
  FileList: TStringList;
  NewLine: String;
  Text: String;
begin
  FileList := TStringList.Create;
  FileList.LoadFromFile(GetFileName(FileName));
  result := TStringList.Create;
  Text := FileList.Values['text'];
  NewLine := FileList.Values['newline'];
  result.Text := StringReplace(Text, NewLine, #13#10, [rfReplaceAll]);
  FileList.Free;
end;

procedure SaveWikiText(FileName: String; Text: String);
var
  FileList: TStringList;
  NewLine: String;
begin
  FileList := TStringList.Create;
  FileList.LoadFromFile(GetFileName(FileName));
  NewLine := FileList.Values['newline'];
  FileList.Values['text'] :=
    StringReplace(Text, #13#10, NewLine, [rfReplaceAll]);
  FileList.SaveToFile(GetFileName(FileName));
  FileList.Free;

  ReferenzCreatorMainForm.LogListBox.Items.Add('Update: ' + FileName);
  ReferenzCreatorMainForm.StatusBar1.SimpleText := 'Update: ' + FileName;
  Application.ProcessMessages;
end;

procedure CreateNewPage(Template: String; FileName: String; PageTitle: String);
var
  FileList: TStringList;
begin
  FileName[1] := Uppercase(FileName[1])[1];
  FileList := TStringList.Create;
  FileList.Values['pagetitle'] := PageTitle;
  FileList.Values['name'] := FileName + '.pasi';
  FileList.SaveToFile(GetFileName(FileName));
  FileList.Free;
end;

procedure ClearTextBetweenComments(List: TStringList);
var
  Dummy: Integer;
  Del: Boolean;
begin
  Del := false;
  Dummy := 0;
  while (Dummy < List.Count) do
  begin
    if (Copy(List[Dummy], 1, 10) = '%comment% ') and
      (Copy(List[Dummy], 11, 8) <> 'Version:') and
      (Copy(List[Dummy], 11, 4) <> 'done') then
    begin Del := not Del end;

    if Del then
    begin
      if Copy(List[Dummy], 1, 10) <> '%comment% ' then
      begin List.Delete(Dummy) end
      else
      begin inc(Dummy) end;
    end
    else
    begin inc(Dummy) end;
  end;
end;

function AddBeforeComment(List: TStringList; Comment, Text: String): Boolean;
var
  Dummy: Integer;
begin
  Comment := '%comment% ' + Comment;
  result := false;
  for Dummy := 0 to List.Count - 1 do
  begin
    if StrLComp(PChar(Comment), PChar(List[Dummy]), length(Comment)) = 0 then
    begin
      List.Insert(Dummy, Text);
      result := true;
      exit;
    end;
  end;
end;

function GetTypeName(Typ: TPSType): String;
begin
  if Typ is TPSArrayType then
  begin
    result := 'Array of ' + script_utils_GetTypeName(
      TPSArrayType(Typ).ArrayTypeNo)
  end
  else
  begin
    result := script_utils_GetTypeName(Typ)
  end;
end;

function GetParamStr(Decl: TPSParametersDecl): String;
var
  Dummy: Integer;
begin
  Assert(Decl <> nil);
  result := '(';
  for Dummy := 0 to Decl.ParamCount - 1 do
  begin
    if Dummy <> 0 then
    begin result := result + '; ' end;

    if (Decl.Params[Dummy].Mode = pmOut) then
    begin result := result + 'out ' end;
    if (Decl.Params[Dummy].Mode = pmInOut) then
    begin result := result + 'var ' end;

    result := result + Decl.Params[Dummy].OrgName;

    if Decl.Params[Dummy].aType <> nil then
    begin result := result + ': ' +
        GetTypeName(Decl.Params[Dummy].aType) end;
  end;
  result := result + ')';

  if Decl.result <> nil then
  begin result := result + ': ' + GetTypeName(Decl.result) end;
end;

procedure CreateFunctionSite(Proc: TPSRegProc);
var
  Name: String;
  Text: String;
  Kat: String;
  PageName: String;
  ParamStr: String;
  FuncSite: TStringList;
begin
  Name := Proc.OrgName;
  if pos('_', Proc.OrgName) <> 0 then
  begin
    Kat := Lowercase(Copy(Proc.OrgName, 1, Pos('_', Proc.OrgName) - 1));
  end
  else
  begin Kat := 'Standardfunktionen' end;

  PageName := StringReplace(Name, '_', '', [rfReplaceAll]);
  if not FileExists(GetFileName(PageName)) then
  begin
    CreateNewPage('ProcTemplate', PageName, Name);
  end;

  FuncSite := LoadWikiSite(PageName);
  ClearTextBetweenComments(FuncSite);

  if Proc.Decl.result = nil then
  begin ParamStr := 'procedure ' end
  else
  begin ParamStr := 'function ' end;

  ParamStr := ParamStr + Proc.OrgName + GetParamStr(Proc.Decl);
end;

procedure CreateTypSite(Typ: TPSType);
var
  Name: String;
  Text: String;
  PageName: String;
  FuncSite: TStringList;

  function GetTypePage(Typ: TPSType; out PageName: String): String;
  var
    Name: String;
  begin
    Name := script_utils_GetTypeName(Typ);
    if Typ is TPSTypeLink then
    begin PageName := StringReplace(script_utils_GetTypeName(
        TPSTypeLink(Typ).LinkTypeNo), '_', '', [rfReplaceAll]) end
    else
    begin PageName := StringReplace(Name, '_', '', [rfReplaceAll]) end;

    PageName := 'Typ' + PageName;

    result := '[[{{' + PageName + '}} ' + Name + ']]';
  end;

  procedure AddTypeDeclaration(List: TStringList; Typ: TPSType);
  var
    Dummy: Integer;
    Name1: String;
    Cons: TPSConstant;
    ClassTyp: TPSClassType;

    procedure AddMethods(Cl: TPSCompileTimeClass);
    var
      Dummy: Integer;
      First: Boolean;
    begin
      First := true;

      // Zuerst die Proceduren/Funktionen
      for Dummy := 0 to Cl.Count - 1 do
      begin
        if Cl.Items[Dummy] is TPSDelphiClassItemMethod then
        begin
          if Cl.Items[Dummy] is TPSDelphiClassItemConstructor then
          begin Name := 'constructor ' end
          else
          if Cl.Items[Dummy].Decl.result = nil then
          begin Name := 'procedure ' end
          else
          begin Name := 'function ' end;

          Name := Name + Cl.Items[Dummy].OrgName;
          Name := Name + GetParamStr(Cl.Items[Dummy].Decl) + ';' + #13#10;
          AddBeforeComment(List, 'typ-declaration-end', Name);
        end;
      end;

      if Cl.ClassInheritsFrom <> nil then
      begin AddMethods(Cl.ClassInheritsFrom) end;

    end;

    function ParentHasProperty(ClassItem: TPSDelphiClassItem): Boolean;
    var
      Dummy: Integer;
      Cl: TPSCompileTimeClass;
    begin
      result := false;
      if ClassItem.Owner.ClassInheritsFrom = nil then
      begin exit end;

      Cl := ClassItem.Owner.ClassInheritsFrom;

      for Dummy := 0 to Cl.Count - 1 do
      begin
        if (Cl.Items[Dummy].NameHash = ClassItem.NameHash) and
          (Cl.Items[Dummy].OrgName = ClassItem.OrgName) then
        begin
          result := true;
          exit;
        end;
      end;
    end;

    procedure AddPropertys(cl: TPSCompileTimeClass);
    var
      Dummy: Integer;
      First: Boolean;
    begin
      First := true;
      // dann die Eigenschaften
      for Dummy := 0 to Cl.Count - 1 do
      begin
        if (Cl.Items[Dummy] is TPSDelphiClassItemProperty) and
          not (ParentHasProperty(Cl.Items[Dummy])) then
        begin
          Name := 'property ' + Cl.Items[Dummy].OrgName +
            GetParamStr(Cl.Items[Dummy].Decl);

          case TPSDelphiClassItemProperty(Cl.Items[Dummy]).AccessType of
            iptRW:
            begin Name := Name + '; read / write;' end;
            iptR:
            begin Name := Name + '; read;' end;
            iptW:
            begin Name := Name + '; write;' end;
          end;
          AddBeforeComment(List, 'typ-declaration-end', Name + #13#10);
        end
      end;
    end;

  begin
    AddBeforeComment(List, 'typ-declaration-end', 'type' + #13#10);
    if Typ.ClassType = TPSType then
    begin
      AddBeforeComment(List, 'typ-declaration-end', '  ' + Name);
    end
    else
    if Typ is TPSRecordType then
    begin
      AddBeforeComment(List, 'typ-declaration-end',
        '  ' + Name + ' = record' + #13#10);
      for Dummy := 0 to TPSRecordType(Typ).RecValCount - 1 do
      begin
        Name1 := TPSRecordType(Typ).RecVal(Dummy).FieldOrgName;
        AddBeforeComment(List, 'typ-declaration-end',
          '    ' + Name1 + ': ' +
          GetTypeName(TPSRecordType(Typ).RecVal(Dummy).aType) + ';' + #13#10);
      end;
      AddBeforeComment(List, 'typ-declaration-end',
        'end');
    end
    else
    if Typ is TPSEnumType then
    begin
      Name1 := '(';
      for Dummy := 0 to g_comp.GetConstCount - 1 do
      begin
        Cons := TPSConstant(g_comp.GetConst(Dummy));
        if Cons.Value.FType = Typ then
        begin Name1 := Name1 + Cons.OrgName + ', ' end;
      end;
      Name1 := Copy(Name1, 1, length(Name1) - 2) + ');';
      AddBeforeComment(List, 'typ-declaration-end',
        '  ' + Name + ' = ' + Name1);
    end
    else
    if Typ is TPSClassType then
    begin
      ClassTyp := TPSClassType(Typ);
      if ClassTyp.Cl.ClassInheritsFrom <> nil then
      begin Name1 := 'class(' +
          GetTypeName(ClassTyp.Cl.ClassInheritsFrom.aType) + ')' end
      else
      begin Name1 := 'class' end;

      AddBeforeComment(List, 'typ-declaration-end',
        '  ' + Name + ' = ' + Name1 + #13#10);

      AddMethods(ClassTyp.Cl);
      AddPropertys(ClassTyp.Cl);

      AddBeforeComment(List, 'typ-declaration-end',
        '  end;');
    end
    else
    if Typ is TPSSetType then
    begin AddBeforeComment(List, 'typ-declaration-end',
        '  ' + Name + ' = set of ' +
        GetTypeName(TPSSetType(Typ).SetType) + ';') end
    else
    if Typ is TPSArrayType then
    begin AddBeforeComment(List, 'typ-declaration-end',
        '  ' + Name + ' = array of ' +
        GetTypeName(TPSArrayType(Typ).ArrayTypeNo) + ';') end
    else
    if Typ is TPSProceduralType then
    begin
      Name := '  ' + Name + ' = ';
      if TPSProceduralType(Typ).ProcDef.result = nil then
      begin Name := Name + 'procedure' end
      else
      begin Name := Name + 'function' end;

      Name := Name + GetParamStr(TPSProceduralType(Typ).ProcDef);
      AddBeforeComment(List, 'typ-declaration-end', Name + ';')
    end
    else
    begin AddBeforeComment(List, 'typ-declaration-end',
        '%%% Typ konnte nicht serialisiert werden') end;
  end;

begin
  Name := script_utils_GetTypeName(Typ);
  GetTypePage(Typ, PageName);

  if not FileExists(GetFileName(PageName)) then
  begin
    CreateNewPage('TypTemplate', PageName, Name);
  end;

  FuncSite := LoadWikiSite(PageName);

  if not (Typ is TPSTypeLink) then
  begin
    ClearTextBetweenComments(FuncSite);
    AddTypeDeclaration(FuncSite, Typ);
  end;
end;

procedure CreateConstantSite(Constants: TList);
var
  Name: String;
  Text: String;
  Kat: String;
  PageName: String;
  ParamStr: String;
  FuncSite: TStringList;
  Constant: TPSConstant;
  Dummy: Integer;
begin
  Assert(Constants.Count > 0);

  Constant := TPSConstant(Constants[0]);

  if Constant.Value.FType.BaseType = btEnum then
  begin
    Constants.Delete(0);
    Exit;
  end;

  Name := Constant.Value.FType.OriginalName;
  Kat := 'Standardkonstanten';

  PageName := 'Konstanten' + StringReplace(Name, '_', '', [rfReplaceAll]);
  if not FileExists(GetFileName(PageName)) then
  begin
    CreateNewPage('KonstantenTemplate', PageName, Name);
  end;

  FuncSite := LoadWikiSite(PageName);
  Dummy := 0;

  while (Dummy < Constants.Count) do
  begin
    if TPSConstant(Constants[Dummy]).Value.FType = Constant.Value.FType then
    begin
      if Pos('%comment% ' + TPSConstant(Constants[Dummy]).OrgName,
        FuncSite.Text) = 0 then
      begin
        AddBeforeComment(FuncSite, 'constant-new-declaration',
          'const ' + TPSConstant(Constants[Dummy]).OrgName + Name);
        AddBeforeComment(FuncSite, 'constant-new-declaration-end',
          '%comment% ' + TPSConstant(Constants[Dummy]).OrgName);
      end;
      Constants.Delete(Dummy);
    end
    else
    begin Inc(Dummy) end;
  end;

  SaveWikiText(PageName, FuncSite.Text);
end;

procedure CreateFunctionSites;
var
  Dummy: Integer;
  Func: TPSRegProc;
  List: TStringList;
begin
  for Dummy := 0 to g_comp.GetRegProcCount - 1 do
  begin
    Func := g_comp.GetRegProc(Dummy);
    if Func is TPSRegProc then
    begin
      if (length(Func.Name) > 0) and (Func.Name[1] <> '!') then
      begin
        CreateFunctionSite(Func);
      end;
    end
    else
    begin Assert(false, 'Unbekannte Klasse: ' + Func.ClassName) end;
  end;
end;

procedure CreateTypesSites;
var
  Dummy: Integer;
  Typ: TPSType;
  List: TStringList;
begin
  for Dummy := 0 to g_comp.GetTypeCount - 1 do
  begin
    Typ := g_comp.GetType(Dummy);
    if (length(Typ.Name) > 0) and (Typ.Name[1] <> '!') then
    begin
      CreateTypSite(Typ);
    end;
  end;
end;

procedure CreateConstantSites;
var
  Dummy: Integer;
  Cons: TPSConstant;
  List: TStringList;
  Constants: TList;
begin
  Constants := TList.Create;

  for Dummy := 0 to g_comp.GetConstCount - 1 do
  begin Constants.Add(g_comp.GetConst(Dummy)) end;

  while Constants.Count > 0 do
  begin
    CreateConstantSite(Constants);
  end;
  Constants.Free;
end;

function BuildWikiSites(Sender: TPSPascalCompiler): Boolean;
begin
  g_comp := Sender;
  CreateFunctionSites;
  CreateTypesSites;
  CreateConstantSites;
  // TODO was f?r Ergebniswert soll diese Routine zur?ckgeben? -> umsetzen
end;

procedure TReferenzCreatorMainForm.UpdateButtonClick(Sender: TObject);
begin
  GenerateWikiSites;
  // UploadButton.Enabled := true; // Besser nicht, wiki ist gut so ;)
end;

procedure TReferenzCreatorMainForm.GenerateWikiSites;
var
  Comp: TPSPascalCompiler;
begin
  StatusBar1.SimpleText := 'GenerateWikiSites...';
  Application.ProcessMessages;

  Comp := TPSPascalCompiler.Create;
  try
    Comp.AllowNoBegin := true;
    Comp.BooleanShortCircuit := true;
    Comp.OnUses := RegisterCompiler;

    Comp.OnBeforeOutput := BuildWikiSites;

    Comp.Compile('program test; end.');
  finally
    Comp.Free;
    StatusBar1.SimpleText := '';
  end;
end;

procedure TReferenzCreatorMainForm.DownloadButtonClick(Sender: TObject);
var
  FindData: TSearchRec;
begin
  if FindFirst(Directory + '.*', faAnyFile, FindData) = 0 then
  begin
    repeat
      if (FindData.Name <> '.') and (FindData.Name <> '..') then
      begin SysUtils.DeleteFile(Directory + FindData.Name) end;
    until FindNext(FindData) <> 0;
  end;

  LogListBox.Items.Clear;
  StatusBar1.SimpleText := 'Connecting...';
  LogListBox.Items.Add('Connecting...');
  IdFTP1.OnAfterClientLogin := IdFTP1AfterClientLogin;
  IdFTP1.Connect;
  IdFTP1.OnAfterClientLogin := nil;
end;

procedure TReferenzCreatorMainForm.FormCreate(Sender: TObject);
var
  Tmp: Array[0..200] of Char;
  Str: String;
  reg: TRegistry;
begin
  GetEnvironmentVariable('TEMP', tmp, 200);

  with TIniFile.Create(ChangeFileExt(ParamStr(0), '.ini')) do
  begin try
      IdFTP1.Host := ReadString('Connection', 'Host', '');
      IdFTP1.Username := ReadString('Connection', 'Username', '');
      IdFTP1.Password := ReadString('Connection', 'Password', '');
      Directory := ReadString('Settings', 'tmpDir', '');
      if not ReadBool('Connection', 'UseSSL', false) then
      begin IdFTP1.UseTLS := utNoTLSSupport end;
    finally
      Free;
    end end;

  if Directory = '' then
  begin
    Str := StringReplace(tmp, '/', '\', [rfReplaceAll]);
    Directory := IncludeTrailingBackslash(Str) + 'referenz\';
  end;
  Directory := IncludeTrailingBackslash(Directory);

  Reg := OpenXForceRegistry('', false);

  if reg <> nil then
  begin SetCurrentDirectory(PChar(Reg.ReadString('InstallDir'))) end;

end;

procedure TReferenzCreatorMainForm.UploadButtonClick(Sender: TObject);
var
  FindData: TSearchRec;
begin
  if not IdFTP1.Connected then
  begin
    IdFTP1.OnAfterClientLogin := nil;
    IdFTP1.Connect;
    IdFTP1.ChangeDir('ger_wiki.d');
  end;

  if FindFirst(Directory + '.*', faAnyFile, FindData) = 0 then
  begin
    repeat
      if IdFTP1.FileDate(FindData.Name) > 0 then
      begin IdFTP1.Delete(FindData.Name) end;
      StatusBar1.SimpleText := 'Uploading ' + FindData.Name;
      Application.ProcessMessages;
      IdFTP1.Put(Directory + FindData.Name, FindData.Name);
    until FindNext(FindData) <> 0;
  end;

  // Cache leeren

  UpdateButton.Enabled := false;
  UploadButton.Enabled := false;
  Application.MessageBox('Arbeit abgeschlossen', PChar(Self.Caption), MB_OK);
  StatusBar1.SimpleText := '';
end;

procedure TReferenzCreatorMainForm.Timer1Timer(Sender: TObject);
begin
  LogListBox.ItemIndex := LogListBox.Items.Count - 1;
end;

procedure TReferenzCreatorMainForm.IdFTP1Status(ASender: TObject;
  const AStatus: TIdStatus; const AStatusText: string);
begin
  LogListBox.Items.Add(AStatusText);
end;

procedure TReferenzCreatorMainForm.IdFTP1AfterClientLogin(Sender: TObject);
var
  Dummy: Integer;
begin
  IdFTP1.ChangeDir('ger_wiki.d');

  IdFTP1.List('', false);

  ForceDirectories(Directory);

  LogListBox.Items.AddStrings(IdFTP1.ListResult);

  try
    for Dummy := 0 to IdFTP1.ListResult.Count - 1 do
    begin
      if Copy(IdFTP1.ListResult[Dummy], 1, 15) = Kategorie then
      begin
        StatusBar1.SimpleText := 'Getting ' + IdFTP1.ListResult[Dummy];
        Application.ProcessMessages;
        IdFTP1.Get(IdFTP1.ListResult[Dummy], Directory +
          IdFTP1.ListResult[Dummy], true);
      end;
    end;
  finally
    StatusBar1.SimpleText := '';
  end;

  UpdateButton.Enabled := true;
end;

procedure TReferenzCreatorMainForm.IdSSLIOHandlerSocketOpenSSL1Status(
  ASender: TObject; const AStatus: TIdStatus; const AStatusText: string);
begin
  LogListBox.Items.Add('SSL: ' + AStatusText);
end;

procedure TReferenzCreatorMainForm.IdSSLIOHandlerSocketOpenSSL1StatusInfo(
  Msg: string);
begin
  LogListBox.Items.Add('SSL: ' + Msg);
end;

end.