Skip to content
Permalink
Browse files

add some missing files

  • Loading branch information
Arnaud Bouchez
Arnaud Bouchez committed Feb 6, 2020
1 parent 59ae905 commit 66829e236906aa9d417114fd381a1a48528f2798
Showing with 116 additions and 91 deletions.
  1. +23 −19 SQLite3/Samples/30 - MVC Server/MVCViewModel.pas
  2. +20 −21 SQLite3/mORMot.pas
  3. +13 −5 SynCommons.pas
  4. +60 −46 SynCrtSock.pas
@@ -174,7 +174,7 @@ procedure TBlogApplication.ComputeMinimalData;
if not RestModel.Retrieve('',info) then begin // retrieve first item
tmp := StringFromFile('/home/ab/Downloads/2020-01-16-a8003957c2ae6bde5be6ea279c9c9ce4-backup.txt');
info.Language := 'en';
if tmp<>'' then begin
if tmp<>'' then begin
info.Title := 'Synopse Blog';
info.Description := 'Articles, announcements, news, updates and more '+
'about our Open Source projects';
@@ -255,17 +255,20 @@ function TBlogApplication.GetLoggedAuthorID(Right: TSQLAuthorRight;
end;
end;

function TBlogApplication.GetViewInfo(MethodIndex: integer): variant;
procedure TBlogApplication.GetViewInfo(MethodIndex: integer; out info: variant);
var archives: variant; // needed to circumvent memory leak bug on FPC
begin
result := inherited GetViewInfo(MethodIndex);
inherited GetViewInfo(MethodIndex,info);
_ObjAddProps(['blog',fBlogMainInfo,
'session',CurrentSession.CheckAndRetrieveInfo(TypeInfo(TCookieData))],result);
if not fDefaultData.AddExistingProp('archives',result) then
fDefaultData.AddNewProp('archives',RestModel.RetrieveDocVariantArray(
'session',CurrentSession.CheckAndRetrieveInfo(TypeInfo(TCookieData))],info);
if not fDefaultData.AddExistingProp('archives',info) then begin
archives := RestModel.RetrieveDocVariantArray(
TSQLArticle,'','group by PublishedMonth order by PublishedMonth desc limit 100',[],
'distinct(PublishedMonth),max(RowID)+1 as FirstID'),result);
if not fDefaultData.AddExistingProp('tags',result) then
fDefaultData.AddNewProp('tags',fTagsLookup.GetAsDocVariantArray,result);
'distinct(PublishedMonth),max(RowID)+1 as FirstID');
fDefaultData.AddNewProp('archives',archives,info);
end;
if not fDefaultData.AddExistingProp('tags',info) then
fDefaultData.AddNewProp('tags',fTagsLookup.GetAsDocVariantArray,info);
end;

procedure TBlogApplication.FlushAnyCache;
@@ -300,8 +303,7 @@ procedure TBlogApplication.Default(var Scope: variant);
whereClause := 'join (select docid,rank(matchinfo(ArticleSearch),1.0,0.7,0.5) as rank '+
'from ArticleSearch where ArticleSearch match ? '+whereClause+
'order by rank desc'+ARTICLE_DEFAULT_LIMIT+')as r on (r.docid=Article.id)';
articles := RestModel.RetrieveDocVariantArray(
TSQLArticle,'',whereClause,[match,rank],
articles := RestModel.RetrieveDocVariantArray(TSQLArticle,'',whereClause,[match,rank],
'id,title,tags,author,authorname,createdat,abstract,contenthtml,rank');
with _Safe(articles)^ do
if (Kind=dvArray) and (Count>0) then
@@ -319,15 +321,17 @@ procedure TBlogApplication.Default(var Scope: variant);
end;
SetVariantNull(Scope);
if (lastID=0) and (tag=0) then begin // use simple cache if no parameters
if not fDefaultData.AddExistingProp('Articles',Scope) then
fDefaultData.AddNewProp('Articles',RestModel.RetrieveDocVariantArray(
TSQLArticle,'',ARTICLE_DEFAULT_ORDER,[],
ARTICLE_FIELDS,nil,@fDefaultLastID),Scope);
if not fDefaultData.AddExistingProp('Articles',Scope) then begin
articles := RestModel.RetrieveDocVariantArray(TSQLArticle,'',
ARTICLE_DEFAULT_ORDER,[],ARTICLE_FIELDS,nil,@fDefaultLastID);
fDefaultData.AddNewProp('Articles',articles,Scope);
end;
lastID := fDefaultLastID;
end else // use more complex request using lastID + tag parameters
scope := _ObjFast(['Articles',RestModel.RetrieveDocVariantArray(
TSQLArticle,'',whereClause+ARTICLE_DEFAULT_ORDER,[lastID,tag],
ARTICLE_FIELDS,nil,@lastID)]);
end else begin // use more complex request using lastID + tag parameters
articles := RestModel.RetrieveDocVariantArray(TSQLArticle,'',
whereClause+ARTICLE_DEFAULT_ORDER,[lastID,tag],ARTICLE_FIELDS,nil,@lastID);
scope := _ObjFast(['Articles',articles]);
end;
if lastID>1 then
_ObjAddProps(['lastID',lastID, 'tag',tag],Scope);
end;
@@ -6610,7 +6610,7 @@ TSQLRestServerURIContext = class
// - caller can set Handle304NotModified=TRUE for Status=HTTP_SUCCESS
procedure Returns(const NameValuePairs: array of const; Status: integer=HTTP_SUCCESS;
Handle304NotModified: boolean=false; HandleErrorAsRegularResult: boolean=false;
const CustomHeader: RawUTF8=''); overload;
const CustomHeader: RawUTF8=''); overload;
/// use this method to send back any object as JSON document to the caller
// - this method will call ObjectToJson() to compute the returned content
// - you can customize SQLRecordOptions, to force the returned JSON
@@ -6619,7 +6619,7 @@ TSQLRestServerURIContext = class
procedure Returns(Value: TObject; Status: integer=HTTP_SUCCESS;
Handle304NotModified: boolean=false;
SQLRecordOptions: TJSONSerializerSQLRecordOptions=[];
const CustomHeader: RawUTF8=''); overload;
const CustomHeader: RawUTF8=''); overload;
/// use this method to send back any variant as JSON to the caller
// - this method will call VariantSaveJSON() to compute the returned content
procedure ReturnsJson(const Value: variant; Status: integer=HTTP_SUCCESS;
// - the data will be converted to variants and TDocVariant following the
// TSQLRecord layout, so complex types like dynamic array will be returned
// as a true array of values (in contrast to the RetrieveListJSON method)
// - warning: under FPC, we observed that assigning the result of this
// method to a local variable may circumvent a memory leak FPC bug
function RetrieveDocVariantArray(Table: TSQLRecordClass;
const ObjectName, CustomFieldsCSV: RawUTF8; FirstRecordID: PID=nil;
LastRecordID: PID=nil): variant; overload;
// - the data will be converted to variants and TDocVariant following the
// TSQLRecord layout, so complex types like dynamic array will be returned
// as a true array of values (in contrast to the RetrieveListJSON method)
function RetrieveDocVariantArray(Table: TSQLRecordClass;
const ObjectName: RawUTF8;
// - warning: under FPC, we observed that assigning the result of this
// method to a local variable may circumvent a memory leak FPC bug
function RetrieveDocVariantArray(Table: TSQLRecordClass; const ObjectName: RawUTF8;
const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const;
const CustomFieldsCSV: RawUTF8; FirstRecordID: PID=nil;
LastRecordID: PID=nil): variant; overload;
SetLength(fFieldNames,fFieldCount); // share one TRawUTF8DynArray
for f := 0 to fFieldCount-1 do begin
P := Get(0,f);
if IsRowID(P) then // normalize RowID field name to ID
if IsRowID(P) then // normalize RowID field name to 'ID'
fFieldNames[f] := 'ID' else
fFieldNames[f] := P;
FastSetString(fFieldNames[f],P,StrLen(P));
end;
end;

options: TDocVariantOptions; expandTimeLogAsText,expandEnumsAsText,
expandHugeIDAsUniqueIdentifier: boolean);
var f: integer;
v: PVariantArray; // low-level trick for write access to read-only properties
n: PRawUTF8Array;
docv: TDocVariantData absolute doc;
v: TVariantDynArray;
begin
if (self=nil) or (Row<1) or (Row>fRowCount) then
exit; // out of range
docv.InitFast(fFieldCount,dvObject);
docv.SetCount(fFieldCount);
v := pointer(docv.Values);
SetLength(v,fFieldCount);
for f := 0 to fFieldCount-1 do
GetAsVariant(Row,f,v^[f],expandTimeLogAsText,expandEnumsAsText,expandHugeIDAsUniqueIdentifier,options);
GetAsVariant(Row,f,v[f],expandTimeLogAsText,expandEnumsAsText,
expandHugeIDAsUniqueIdentifier,options);
if length(fFieldNames)<>fFieldCount then
InitFieldNames;
n := pointer(docv.Names);
for f := 0 to fFieldCount-1 do
n^[f] := fFieldNames[f]; // no direct assign to protect fFieldNames[]
TDocVariantData(doc).InitObjectFromVariants(fFieldNames,v,JSON_OPTIONS_FAST);
end;

procedure TSQLTable.ToDocVariant(out docs: TVariantDynArray; readonly: boolean);
T := MultiFieldValues(Table,CustomFieldsCSV,FormatSQLWhere,BoundsSQLWhere);
if T<>nil then
try
T.ToDocVariant(res,false); // readonly=false -> TDocVariant dvArray
T.ToDocVariant(res,{readonly=}false); // not readonly -> TDocVariant dvArray
if FirstRecordID<>nil then
FirstRecordID^ := T.IDColumnHiddenValue(1);
if LastRecordID<>nil then
(callback.Factory.MethodIndexCurrentFrameCallback>=0) then begin
frames := FindIniNameValue(pointer(Ctxt.InHead),'SEC-WEBSOCKET-FRAME: ');
end;
split(interfmethod,'.',interf,method);
Split(interfmethod,'.',interf,method);
methodIndex := callback.Factory.FindMethodIndex(method);
if methodIndex<0 then
exit;
end;
{$ifdef DOMAINAUTH} // try Windows/GSSAPI authentication with the current logged user
result := true;
if ((trim(aUserName)='') or (PosExChar({$ifdef GSSAPIAUTH}'@'{$else}'\'{$endif},aUserName)>0)) and
if (IsVoid(aUserName) or (PosExChar({$ifdef GSSAPIAUTH}'@'{$else}'\'{$endif},aUserName)>0)) and
TSQLRestServerAuthenticationSSPI.ClientSetUser(self,aUserName,aPassword,passKerberosSPN) then
exit;
{$endif DOMAINAUTH}
procedure TSQLRestServerURIContext.RetrieveCookies;
var n: integer;
P: PUTF8Char;
cn,cv: RawUTF8;
cookie,cn,cv: RawUTF8;
begin
fInputCookiesRetrieved := true;
P := pointer(FindIniNameValue(pointer(Call.InHead),'COOKIE:'));
cookie := FindIniNameValue(pointer(Call.InHead),'COOKIE:');
P := pointer(cookie);
n := 0;
while P<>nil do begin
GetNextItemTrimed(P,'=',cn);
@@ -5795,8 +5795,8 @@ TSynHash = record
TDynArrayHashed = record
// pseudo inheritance for most used methods
private
function GetCount: PtrInt; inline;
procedure SetCount(aCount: PtrInt) ; inline;
function GetCount: PtrInt; inline;
procedure SetCount(aCount: PtrInt) ; inline;
procedure SetCapacity(aCapacity: PtrInt); inline;
function GetCapacity: PtrInt; inline;
public
function Split(const Str, SepStr: RawUTF8; StartPos: integer): RawUTF8;
var i: integer;
begin
i := PosEx(SepStr,Str,StartPos);
{$ifdef FPC} // to use fast FPC SSE version
if (StartPos=1) and (length(SepStr)=1) then
i := PosExChar(SepStr[1],Str) else
{$endif FPC}
i := PosEx(SepStr,Str,StartPos);
if i>0 then
result := Copy(Str,StartPos,i-StartPos) else
if StartPos=1 then
var i: integer;
tmp: RawUTF8; // may be called as Split(Str,SepStr,Str,RightStr)
begin
i := PosEx(SepStr,Str);
{$ifdef FPC} // to use fast FPC SSE version
if length(SepStr)=1 then
i := PosExChar(SepStr[1],Str) else
{$endif FPC}
i := PosEx(SepStr,Str);
if i=0 then begin
LeftStr := Str;
RightStr := '';
result := true;
if high(UpperValues)>=0 then
while (P<>nil) and (P^<>'[') do begin
if P^=' ' then repeat inc(P) until P^<>' '; // trim left ' '
if P^=' ' then repeat inc(P) until P^<>' '; // trim left ' '
PBeg := P;
if IdemPChar(PBeg,pointer(UpperName)) then begin
inc(PBeg,length(UpperName));

0 comments on commit 66829e2

Please sign in to comment.
You can’t perform that action at this time.