mORMot Open Source

unit FileTables;

interface

{$I Synopse.inc} 

type
  TSQLFile = Class
  ...
  end;
  TSQLUser = class(TSQLFile)
  ...
  end;
   
  
  TSQLBaseReport = class(TSQLFile)
  private
    fUser: TSQLUserReports;
  public
	function HasUser(ClientDB: TSQLRestClientUri; const AUserName: RawUTF8;
      const AUserID: Integer = -1): Boolean; overload;
    // returned aRowID is an ID of row in PIVOT TABLE !!!
    // so that we can access additional data stored in pivot connection
    function HasUser(ClientDB: TSQLRestClientUri; const AUserName: RawUTF8;
      const AUserID: Integer; var ARowID: Integer): Boolean; overload;virtual;Abstract;
   
  published
    property User: TSQLUserReports read fUser;
  end;
    
  
  TSQLUserBaseReports = class(TSQLRecordMany)
  private
    fSource: TSQLUser;
    fDest: TSQLBaseReport;
  published
    property Source: TSQLUser read fSource;
    property Dest: TSQLBaseReport read fDest;

  end;

  TSQLUserPDFReports = class(TSQLUserBaseReports)
   private
    fSource: TSQLUser;
    fDest: TSQLPDFReport;
  published
    property Source: TSQLUser read fSource;
    property Dest: TSQLPDFReport read fDest;

  end; 

  TSQLUserXLSReports = class(TSQLUserBaseReports)
   private
    fSource: TSQLUser;
    fDest: TSQLXLSReport;
  published
    property Source: TSQLUser read fSource;
    property Dest: TSQLXLSReport read fDest;

  end;   
 
TSQLPDFReport = class(TSQLBaseReport)
  private
    fUsers: TSQLUserPDFReports;
  published
    property Users: TSQLUserPDFReports read fUsers;
  
  end;
  
  TSQLXLSReport = class(TSQLBaseReport)
  private
    fUsers: TSQLUserXLSReports;
  published
    property Users: TSQLUserXLSReports read fUsers;
  
  end;
...  
implementation
...  
function TSQLBaseReport.HasUser(ClientDB: TSQLRestClientUri;
  const AUserName: RawUTF8; const AUserID: Integer = -1): Boolean;
var
  dummy: Integer;
begin
  result := HasUser(ClientDB, AUserName, AUserID, dummy);
end;

function TSQLBaseReport.HasUser(ClientDB: TSQLRestClientUri;
  const AUserName: RawUTF8; const AUserID: Integer;
  var ARowID: Integer): Boolean;
var
  User: TSQLUser;
begin
  result := false;
  ARowID := -1;
  
  fUsers.FillMany(ClientDB, fID);

  while fUsers.FillOne do
  begin
    if fUsers.Dest <> nil then
      try
        User := TSQLUser.Create(ClientDB, Integer(fUsers.Dest));
        if ((AUserID = -1) and (User.Name = AUserName)) or
          ((AUserID > -1) and (User.ID = AUserID)) then
        begin
          result := True; 
          ARowID := fUsers.ID;
          break;
        end;
      finally
        FreeAndNil(User);
      end;
  end;

  
end;

Uses FileTables;

.... 
procedure TForm1.Button1Click(Sender: TObject);
var
 ARec : TSQLXLSReport;
 k:Integer;
begin
try
   ARec := TSQLXLSReport.Create(ClientDB, 1);
   if ARec.ID>0 then
   begin
     if ARec.HasUser(ClientDB,'John')>0 then
	   Showmessage('the 1 report is assigned to John');	  
   end; 	 	   
finally

end;

end;

unit mORMot;
...
uses
...
  Generics.Collections;

...

procedure TSQLTableToObjectGenericList(aRecordClass: TSQLRecordClass;
  aSourceTable: TSQLTable; aDestList: TObjectList<TSQLRecord>);
var R: TSQLRecord;
    V: ^TSQLRecord;
    Row: PPUtf8Char;
    i: integer;
begin
  R := aRecordClass.Create;
  try
    R.FillPrepare(aSourceTable);
    aDestList.Count := aSourceTable.RowCount; // faster than manual Add()
    V := @aDestList.List[0];
    Row := @aSourceTable.fResults[aSourceTable.FieldCount]; // R^ points to first row of data
    for i := 1 to aSourceTable.RowCount do begin
      V^ := aRecordClass.Create; // TObjectList will free each instance
      R.fFill.Fill(pointer(Row),V^);
      Inc(Row,aSourceTable.FieldCount);
      inc(V);
    end;
  finally
    R.Free;
  end;
end;

function TSQLRest.RetrieveGenericList(Table: TSQLRecordClass; FormatSQLWhere: PUTF8Char;
  const BoundsSQLWhere: array of const; const aCustomFieldsCSV: RawUTF8=''): TObjectList<TSQLRecord>;
var SQL: RawUTF8;
    T: TSQLTable;
begin
  result := nil;
  if (self=nil) or (Table=nil) then
    exit;
  SQL := FormatUTF8(FormatSQLWhere,[],BoundsSQLWhere);
  if aCustomFieldsCSV<>'' then
    T := InternalListJSON(Table,aCustomFieldsCSV,SQL) else
    T := InternalListRecordsJSON(Table,SQL);
  if T<>nil then
  try
    result := TObjectList<TSQLRecord>.Create;
    TSQLTableToObjectGenericList(Table,T,result);
  finally
    T.Free;
  end;
end;

type
  /// here we declare the class containing the data
  // - it just has to inherits from TSQLRecord, and the published
  // properties will be used for the ORM (and all SQL creation)
  // - the beginning of the class name must be 'TSQL' for proper table naming
  // in client/server environnment
  TSQLSampleRecord = class(TSQLRecord)
  private
    fQuestion: RawUTF8;
    fName: RawUTF8;
    fTime: TModTime;
  public
    constructor Create(const AName, AQuestion: String); overload;
  published
    property Time: TModTime read fTime write fTime;
    property Name: RawUTF8 read fName write fName;
    property Question: RawUTF8 read fQuestion write fQuestion;
  end;

/// an easy way to create a database model for client and server
function CreateSampleModel: TSQLModel;


implementation

function CreateSampleModel: TSQLModel;
begin
  result := TSQLModel.Create([TSQLSampleRecord]);
end;

constructor TSQLSampleRecord.Create(const AName, AQuestion: String);
begin
  inherited Create;
  FName := AName;
  FQuestion := AQuestion;
end;

...
private
    MyPeople :TObjectList<TSQLRecord>;
....

procedure TForm1.Button1Click(Sender: TObject);
var
  LSQLSampleRecord: TSQLSampleRecord;
begin
  LSQLSampleRecord := TSQLSampleRecord.Create('John', 'Anders');
  Database.Add(LSQLSampleRecord,true);
  LSQLSampleRecord := TSQLSampleRecord.Create('toni', 'zzzz');
  Database.Add(LSQLSampleRecord,true);
  LSQLSampleRecord := TSQLSampleRecord.Create('bepi', 'xxxx');
  Database.Add(LSQLSampleRecord,true);

  MyPeople := TObjectList<TSQLRecord>.Create;

  MyPeople := Database.RetrieveGenericList(TSQLSampleRecord,'',[]);

  AdapterBindSource1.Adapter := TListBindSourceAdapter<TSQLSampleRecord>.Create(self, TObjectList<TSQLSampleRecord>(MyPeople), True);
  AdapterBindSource1.Active := true;
end;

if FHttpDatabase.URI(format('%s/%s',[FHttpDatabase.Model.Root,StringtoUTF8('XMLAsData')])+UrlEncode(['filename',StringtoUTF8(sfilename)]),'PUT',@aResponse,nil,@aData).Lo=200 then

function TFileServer.XMLAsData(var aParams: TSQLRestServerCallBackParams): Integer;
var //aData: TSQLRawBlob;
   sfilename:RawUTF8;
   XmlDoc: TNativeXml;
   aData: RawUTF8 ;
   Node: TXmlNode;
begin
  //writeln('Start XMLAsData');
  if not UrlDecodeNeedParameters(aParams.Parameters,'FILENAME') then begin
    result := 404; // invalid Request
   {$ifNdef SERVICE}
    writeln('invalid Request');
    {$ENDIF}
    exit;
  end;
  while aParams.Parameters<>nil do begin
    UrlDecodeValue(aParams.Parameters,'FILENAME=',sfilename,@aParams.Parameters);
  end;
   {$ifNdef SERVICE}
  writeln(format('filename: %s',[sfilename]));
   {$ENDIF}

  if length(aParams.SentData)>0 then
  begin
    {$ifNdef SERVICE}
    if DebugHook<>0 then
     writeln(format('Exist data: %s',[aParams.SentData]));
    {$ENDIF}
     try
        XmlDoc := TNativeXml.Create(nil);
        XmlDoc.ReadFromString(UTF8ToString(aParams.SentData));

        XmlDoc.SaveToFile(sfilename);
    {$ifNdef SERVICE}
        writeln(format('Exist data: %s',[sfilename]));
    {$ENDIF}
     except
      on E: Exception do
      begin
     {$ifNdef SERVICE}
         writeln('Error launching the server' +#10+E.Message);
     {$ENDIF}
         result := 404; // invalid Request
         exit; // we need a valid record and its ID
      end;
     end;
     XmlDoc.Free;
  end
  else
   begin
    result := 404; // invalid Request
    exit; // we need a valid record and its ID
   end;

  aParams.Resp := JSONEncodeResult([sfilename]);

  //aResp := JSONEncodeResult([SynCommons.BinToHex(aData)]);
  // idem: aResp := JSONEncode(['result',BinToHex(aRecord.fData)],TempMemoryStream);
  result := 200; // success
end;

aResponse := FHttpDatabase.CallBackGetResult('XMLAsData',['filename',StringtoUTF8(sfilename),'XML',aData]);

function TFileServer.XMLAsData(var aParams: TSQLRestServerCallBackParams): Integer;
var //aData: TSQLRawBlob;
   sfilename:RawUTF8;
   XmlDoc: TNativeXml;
   aData: RawUTF8 ;
   Node: TXmlNode;
   sXML:RawUTF8;
begin
  //writeln('Start XMLAsData');
  if not UrlDecodeNeedParameters(aParams.Parameters,'FILENAME') then begin
    result := 404; // invalid Request
   {$ifNdef SERVICE}
    writeln('invalid Request');
    {$ENDIF}
    exit;
  end;
  if not UrlDecodeNeedParameters(aParams.Parameters,'XML') then begin
    result := 404; // invalid Request
   {$ifNdef SERVICE}
    writeln('invalid Request');
    {$ENDIF}
    exit;
  end;

  while aParams.Parameters<>nil do begin
    UrlDecodeValue(aParams.Parameters,'FILENAME=',sfilename,@aParams.Parameters);
    UrlDecodeValue(aParams.Parameters,'XML=',sXML,@aParams.Parameters);
  end;
   {$ifNdef SERVICE}
  writeln(format('filename: %s',[sfilename]));
   {$ENDIF}


  if length(sXML)>0 then
  begin
    {$ifNdef SERVICE}
    if DebugHook<>0 then
     writeln(format('Exist data: %s',[sXML]));
    {$ENDIF}
     try
        XmlDoc := TNativeXml.Create(nil);
        XmlDoc.ReadFromString(UTF8ToString(sXML));

        XmlDoc.SaveToFile(sfilename);
    {$ifNdef SERVICE}
        writeln(format('Exist data: %s',[sfilename]));
    {$ENDIF}
     except
      on E: Exception do
      begin
     {$ifNdef SERVICE}
         writeln('Error launching the server' +#10+E.Message);
     {$ENDIF}
         result := 404; // invalid Request
         exit; // we need a valid record and its ID
      end;
     end;
     XmlDoc.Free;
  end
  else
   begin
    result := 404; // invalid Request
    exit; // we need a valid record and its ID
   end;

  aParams.Results([sfilename]);

  //aResp := JSONEncodeResult([SynCommons.BinToHex(aData)]);
  // idem: aResp := JSONEncode(['result',BinToHex(aRecord.fData)],TempMemoryStream);
  result := 200; // success
end;