<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)
    LogListBox: TListBox;
    StatusBar1: TStatusBar;
    Timer1: TTimer;
    UpdateButton: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure UpdateButtonClick(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\';

{$R *.DFM}

const
  XSkriptVersion = 915;

var
  g_comp: TPSPascalCompiler;

function GetFileName(Page: String): String;
begin
  result := Directory + Page + '.pasi';
end;

procedure WriteDeclFile(page, text: String);
var
  FileList: TStringList;
  FileName: String;
begin
  FileName := GetFileName(page);
  FileList := TStringList.Create;
  FileList.Text := text;
  FileList.SaveToFile(FileName);
  FileList.Free;
  ReferenzCreatorMainForm.LogListBox.Items.Add('Update: ' + FileName);
  ReferenzCreatorMainForm.StatusBar1.SimpleText := 'Update: ' + FileName;
  Application.ProcessMessages;
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 Proc.Decl.result = nil then
  begin ParamStr := 'procedure ' end
  else
  begin ParamStr := 'function ' end;

  ParamStr := ParamStr + Proc.OrgName + GetParamStr(Proc.Decl) + ';';
  WriteDeclFile(Proc.OrgName + '.func', ParamStr);
end;

procedure CreateTypSite(Typ: TPSType);
var
  Name: String;
  Text: String;
  PageName: String;
  Page: TStringList;

  function GetTypePage(Typ: TPSType): String;
  begin
    if Typ is TPSTypeLink then
    begin result := script_utils_GetTypeName(
        TPSTypeLink(Typ).LinkTypeNo) end
    else
    begin result := script_utils_GetTypeName(Typ) end;
    result := result + '.type';
  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) + ';';
          List.Add(Name);
        end;
      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 + ': ' +
            GetTypeName(Cl.Items[Dummy].Decl.result);

          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;
          List.Add(Name);
        end
      end;
    end;

  begin
    List.Add('type');
    if Typ.ClassType = TPSType then
    begin
      List.Add('  ' + Name);
    end
    else
    if Typ is TPSRecordType then
    begin
      List.Add('  ' + Name + ' = record');
      for Dummy := 0 to TPSRecordType(Typ).RecValCount - 1 do
      begin
        Name1 := TPSRecordType(Typ).RecVal(Dummy).FieldOrgName;
        List.Add('    ' + Name1 + ': ' +
          GetTypeName(TPSRecordType(Typ).RecVal(Dummy).aType) + ';');
      end;
      List.Add('  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) + ');';
      List.Add('  ' + 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;

      List.Add('  ' + Name + ' = ' + Name1);

      AddMethods(ClassTyp.Cl);
      AddPropertys(ClassTyp.Cl);

      List.Add('  end;');
    end
    else
    if Typ is TPSSetType then
    begin List.Add('  ' + Name + ' = set of ' +
        GetTypeName(TPSSetType(Typ).SetType) + ';') end
    else
    if Typ is TPSArrayType then
    begin List.Add('  ' + 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);
      List.Add(Name + ';')
    end
    else
    begin List.Add('%%% Typ konnte nicht serialisiert werden') end;
  end;

begin
  Name := script_utils_GetTypeName(Typ);
  PageName := GetTypePage(Typ);
  Page := TStringList.Create;

  if not (Typ is TPSTypeLink) then
  begin
    AddTypeDeclaration(Page, Typ);
    WriteDeclFile(PageName, Page.Text);
  end;
  Page.Free;
end;

procedure CreateConstantSite(Constants: TList);
var
  Name: String;
  Text: String;
  Kat: String;
  PageName: String;
  ParamStr: String;
  Page: 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;

  PageName := Name + '.consts';

  Page := TStringList.Create;
  Dummy := 0;

  while (Dummy < Constants.Count) do
  begin
    if TPSConstant(Constants[Dummy]).Value.FType = Constant.Value.FType then
    begin
      Page.Add('const ' + TPSConstant(Constants[Dummy]).OrgName + ' : ' + Name);
      Constants.Delete(Dummy);
    end
    else
    begin Inc(Dummy) end;
  end;

  WriteDeclFile(PageName, Page.Text);
  Page.Free;
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.FormCreate(Sender: TObject);
var
  Tmp: Array[0..200] of Char;
  Str: String;
  reg: TRegistry;
begin
  GetEnvironmentVariable('TEMP', tmp, 200);

  if Directory = '' then
  begin
    Str := StringReplace(tmp, '/', '\', [rfReplaceAll]);
    Directory := IncludeTrailingBackslash(Str) + 'referenz\';
  end;
  Directory := IncludeTrailingBackslash(Directory);

  Reg := OpenXForceRegistry('', false);
end;

procedure TReferenzCreatorMainForm.Timer1Timer(Sender: TObject);
begin
  LogListBox.ItemIndex := LogListBox.Items.Count - 1;
end;

end.