rtcfunction.pas

Delphi快速开发Web Server

  end;

procedure TRtcAbsFunction.SetHelperGroup(const Value: TRtcFunctionGroup);
  var
    MyGroup:TRtcFunctionGroup;
  begin
  if Value<>FHelperGroup then
    begin
    if assigned(FHelperGroup) then
      begin
      FHelperGroup.RemoveGlobalFunction(self);
      FHelperGroup:=nil;
      end;

    if assigned(Value) then
      begin
      // Check for simple circular reference before assigning!
      if Value=FGroup then
        raise Exception.Create('Can not use same Group as ParentGroup and HelperGroup.');
      MyGroup:=Value;
      while (MyGroup<>nil) do
        begin
        if (MyGroup=self) or
           (MyGroup.ParentGroup=self) or
           (MyGroup.HelperGroup=self) then
          raise Exception.Create('Circular FunctionGroup reference!');
        MyGroup:=MyGroup.ParentGroup;
        end;

      FHelperGroup:=Value;
      FHelperGroup.AddGlobalFunction(self);
      end;
    end;
  end;

{ TRtcFunctionGroup }

constructor TRtcFunctionGroup.Create(AOwner: TComponent);
  begin
  inherited Create(AOwner);
  FFunctions:=TRtcFunctionList.Create;
  FGlobalUse:=TRtcFunctionList.Create;
  end;

destructor TRtcFunctionGroup.Destroy;
  begin
  RemoveAllFunctions;
  FFunctions.Free;
  FFunctions:=nil;
  RemoveAllGlobalFunctions;
  FGlobalUse.Free;
  FGlobalUse:=nil;
  inherited;
  end;

procedure TRtcFunctionGroup.AddFunction(Value: TRtcAbsFunction);
  begin
  FFunctions.Add(Value);
  end;

procedure TRtcFunctionGroup.RemoveFunction(Value: TRtcAbsFunction);
  begin
  FFunctions.Remove(Value);
  end;

procedure TRtcFunctionGroup.RemoveAllFunctions;
  var
    Func:TRtcAbsFunction;
  begin
  while FFunctions.Count>0 do
    begin
    Func:=TRtcAbsFunction(FFunctions.Get(0));
    Func.SetGroup(nil);
    end;
  end;

procedure TRtcFunctionGroup.AddGlobalFunction(Value: TRtcAbsFunction);
  begin
  FGlobalUse.Add(Value);
  end;

procedure TRtcFunctionGroup.RemoveGlobalFunction(Value: TRtcAbsFunction);
  begin
  FGlobalUse.Remove(Value);
  end;

procedure TRtcFunctionGroup.RemoveAllGlobalFunctions;
  var
    Func:TRtcAbsFunction;
  begin
  while FGlobalUse.Count>0 do
    begin
    Func:=TRtcAbsFunction(FGlobalUse.Get(0));
    Func.SetHelperGroup(nil);
    end;
  end;

function TRtcFunctionGroup.Call_Execute(const CmdInfo: TRtcCommandInfo; const Param: TRtcFunctionInfo; const Res: TRtcValue):boolean;
  var
    idx:integer;
    Func:TRtcAbsFunction;
  begin
  Result:=False;
  for idx:=0 to FFunctions.Count-1 do
    begin
    Func:=FFunctions.Get(idx);
    if assigned(Func) then
      if Func.Call_Execute(CmdInfo, Param, Res) then
        begin
        Result:=True;
        Break;
        end;
    end;
  if not Result and assigned(HelperGroup) then
    Result:=HelperGroup.Call_Execute(CmdInfo, Param, Res);
  end;

function TRtcFunctionGroup.Function_Exists(const Function_Name: string): boolean;
  var
    idx:integer;
    Func:TRtcAbsFunction;
  begin
  Result:=False;
  for idx:=0 to FFunctions.Count-1 do
    begin
    Func:=FFunctions.Get(idx);
    if assigned(Func) then
      if Func.Function_Exists(Function_Name) then
        begin
        Result:=True;
        Break;
        end;
    end;
  if not Result and assigned(HelperGroup) then
    Result:=HelperGroup.Function_Exists(Function_Name);
  end;

function TRtcFunctionGroup.CallFunction(CmdInfo: TRtcCommandInfo; Call: TRtcFunctionInfo;
                                        Res: TRtcValue; recursive:boolean=False):boolean;
  var
    idx2:integer;
    field:string;
    obj,xres:TRtcValueObject;
  begin
  { Prepare all parameters before execution.
    It is of utmost importance to do this in reverse order,
    because fields could dissapear after their execution and
    corrupt the FieldCount property. }
  for idx2:=Call.FieldCount-1 downto 0 do
    begin
    field:=Call.FieldName[idx2];
    obj:=Call.asObject[field];
    if not isSimpleValue(obj) then
      begin
      xres:=CmdInfo.Group.ExecuteData(CmdInfo, obj, recursive);
      if obj<>xres then
        begin
        Call.isNull[field]:=true;
        Call.asObject[field]:=xres;
        end;
      end;
    end;
  Result:=Call_Execute(CmdInfo, Call, Res);
  end;

function TRtcFunctionGroup.ExecuteData(CmdInfo: TRtcCommandInfo; Data: TRtcValueObject;
                                       recursive:boolean=False): TRtcValueObject;
  var
    idx,row:integer;
    obj,res:TRtcValueObject;
    field:string;
  begin
  if Data=nil then
    Result:=nil
  else if Data is TRtcFunctionInfo then
    begin
    Result:=TRtcValue.Create;
    try
      if assigned(CmdInfo.Command) then
        begin
        if CmdInfo.Command.Function_Exists(TRtcFunctionInfo(Data).FunctionName) then
          CmdInfo.Command.Call_Execute(CmdInfo, TRtcFunctionInfo(Data), TRtcValue(Result))
        else if not CallFunction(CmdInfo, TRtcFunctionInfo(Data), TRtcValue(Result), recursive) then
          raise Exception.Create('Function or Command "'+TRtcFunctionInfo(Data).FunctionName+'" not found.');
        end
      else if not CallFunction(CmdInfo, TRtcFunctionInfo(Data), TRtcValue(Result), recursive) then
        raise Exception.Create('Function "'+TRtcFunctionInfo(Data).FunctionName+'" not found.');
    except
      Result.Free;
      raise;
      end;
    { Do not release "Data" object here.
      It will be released by the function which called ExecuteData. }

    { If our function call ended with a complex structure as a result,
      we need to check the result structure for recursive function calls. }
    if recursive and not isSimpleValue(Result) then
      begin
      { We don't need the Data pointer anymore,
        we can use it to call ExecuteData recursively. }
      Data:=Result;
      try
        Result:=CmdInfo.Group.ExecuteData(CmdInfo,Data,recursive); // Recursive call! This will Execute all function calls
      except
        Data.Free;
        raise;
        end;
      { Since we have called ExecuteData here,
        we need to release the old Result,
        in case we got another object in return. }
      if Data<>Result then Data.Free; // Release the old Result
      end;
    end
  else if Data is TRtcRecord then
    begin
    { It is of utmost importance to do this in reverse order,
      because fields could dissapear after their execution,
      corrupting the FieldCount property. }
    for idx:=TRtcRecord(Data).FieldCount-1 downto 0 do
      begin
      field:=TRtcRecord(Data).FieldName[idx];
      obj:=TRtcRecord(Data).asObject[field];
      if not isSimpleValue(obj) then
        begin
        res:=CmdInfo.Group.ExecuteData(CmdInfo, obj, recursive);
        if obj<>res then
          begin
          TRtcRecord(Data).isNull[field]:=true;
          TRtcRecord(Data).asObject[field]:=res;
          end;
        end;
      end;
    Result:=Data;
    end
  else if Data is TRtcArray then
    begin
    for idx:=0 to TRtcArray(Data).FieldCount-1 do
      begin
      obj:=TRtcArray(Data).asObject[idx];
      if not isSimpleValue(obj) then
        begin
        res:=CmdInfo.Group.ExecuteData(CmdInfo, obj, recursive);
        if obj<>res then
          begin
          TRtcArray(Data).isNull[idx]:=true;
          TRtcArray(Data).asObject[idx]:=res;
          end;
        end;
      end;
    Result:=Data;
    end
  else if Data is TRtcDataSet then
    begin
    for row:=0 to TRtcDataSet(Data).RowCount-1 do
      begin
      TRtcDataSet(Data).Row:=row;
      { It is of utmost importance to do this in reverse order,
        because fields could dissapear after their execution,
        corrupting the FieldCount property. }
      for idx:=TRtcDataSet(Data).FieldCount-1 downto 0 do
        begin
        field:=TRtcDataSet(Data).FieldName[idx];
        obj:=TRtcDataSet(Data).asObject[field];
        if not isSimpleValue(obj) then
          begin
          res:=CmdInfo.Group.ExecuteData(CmdInfo, obj, recursive);
          if obj<>res then
            begin
            TRtcDataSet(Data).isNull[field]:=true;
            TRtcDataSet(Data).asObject[field]:=res;
            end;
          end;
        end;
      end;
    Result:=Data;
    end
  else if Data is TRtcValue then
    begin
    res:=CmdInfo.Group.ExecuteData(CmdInfo, TRtcValue(Data).asObject, recursive);
    if res<>TRtcValue(Data).asObject then
      begin
      TRtcValue(Data).isNull:=True;
      TRtcValue(Data).asObject:=res;
      end;
    Result:=Data;
    end
  else if isSimpleValue(Data) then
    Result:=Data
  else
    raise Exception.Create('Unsupported Data Type.');
  end;

function TRtcFunctionGroup.ExecuteData(Sender: TRtcConnection; Data: TRtcValueObject;
                                       recursive:boolean=False): TRtcValueObject;
  var
    CmdInfo:TRtcCommandInfo;
  begin
  CmdInfo:=TRtcCommandInfo.Create;
  CmdInfo.Sender:=Sender;
  CmdInfo.Group:=self;
  try
    Result:=ExecuteData(CmdInfo, Data, recursive);
  finally
    CmdInfo.Free;
    end;
  end;

function TRtcFunctionGroup.FunctionExists(const FunctionName: string): boolean;
  begin
  Result:=Function_Exists(FunctionName);
  end;

{ TRtcFunction }

function TRtcFunction.Call_Execute(const CmdInfo: TRtcCommandInfo;
                                   const Param: TRtcFunctionInfo;
                                   const Res: TRtcValue):boolean;
  begin
  if (CompareText(Param.FunctionName,FunctionName)=0) then
    begin
    Result:=True;
    if assigned(FOnExecute) then
      FOnExecute(CmdInfo.Sender,Param,Res)
    else
      raise Exception.Create('OnExecute event missing for function "'+FunctionName+'".');
    end
  else
    Result:=False;
  end;

function TRtcFunction.Function_Exists(const Function_Name: string): boolean;
  begin
  Result:= CompareText(FunctionName, Function_Name)=0;
  end;

function TRtcFunction.GetFuncName: string;
  begin
  Result:=FFuncName;
  end;

procedure TRtcFunction.SetFuncName(const Value: string);
  begin
  FFuncName:=Value;
  end;

{ TRtcResult }

var
  List:tBinList;
  CS:TRtcCritSec;

procedure AddObj(o:TObject);
  begin
  CS.Enter;
  try
    List.insert(longword(o),1);
  finally
    CS.Leave;
    end;
  end;

procedure DelObj(o:TObject);
  begin
  CS.Enter;
  try
    List.remove(longword(o));
  finally
    CS.Leave;
    end;
  end;

function HaveObj(o:TObject):boolean;
  begin
  CS.Enter;
  try
    Result:=List.search(longword(o))>0;
  finally
    CS.Leave;
    end;
  end;

procedure TRtcResult.Call_Aborted(Sender: TRtcConnection; Data,Result: TRtcValue);
  begin
  if HaveObj(self) then
    if assigned(FOnAborted) then
      FOnAborted(Sender,Data,Result);
  end;

procedure TRtcResult.Call_Return(Sender: TRtcConnection; Data,Result: TRtcValue);
  begin
  if HaveObj(self) then
    if assigned(FOnReturn) then
      FOnReturn(Sender,Data,Result);
  end;

function TRtcResult.Valid: boolean;
  begin
  Result:=HaveObj(self);
  end;

constructor TRtcResult.Create(AOwner:TComponent);
  begin
  inherited Create(AOwner);
  AddObj(self);
  end;

destructor TRtcResult.Destroy;
  begin
  DelObj(self);
  inherited;
  end;

{ TRtcCommandInfo }

constructor TRtcCommandInfo.Create;
  begin
  inherited;
  Sender:=nil;
  Command:=nil;
  Group:=nil;
  end;

initialization
CS:=TRtcCritSec.Create;
List:=tBinList.Create(128);
finalization
Garbage(List);
Garbage(CS);
end.