unit model.main;
{$mode ObjFPC}{$H+}
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}
{-$define dbg}
interface /// locked 211225 /bc
uses classes, sysutils, bufdataset, istrlist, model.decl, model.intf, cdbc.litedb;
const MinIStreamsVersion = 0290126 ; { ~ 0.29.01.2026 }
type
{$Region 'TModelMainH'}
{ TModelMain }
TModelMain = class(TObject,IModelMain)
private { remember to use 'RegisterSection' in units, you want to add to 'Sects' :o) }
const Sects: TStringArray = ('[view.main]'); { very necessary, because we need it at idx 0 }
var
fInSection: boolean; { used while searching static text sections }
fSecId: integer; { tmp id while searching }
fSectMaxIdx: integer; { used while searching static text sections, limits to 1 section }
{ we need a filter to compare against; NO filter (='') means ALL FILES ARE ALLOWED!!! }
function IsInFilter(aNode: PFSNode; aFilter: string): boolean;
function Obj: TObject;
protected
fDb: TLiteDb;
fLookUp: TBufDataset;
fPresenter: IPresenterMain;
fRoot: shortstring;
fSection: string; // for use in getting static texts
fTarget: integer; // for targetting the right result in view
fTextCache: IStringList;
{ used while searching static text sections, new implementation ;) }
procedure DoEach(const aValue: string; const {%H-}anIdx: ptrint; {%H-}anObj: TObject; aData: pointer);
procedure CheckAndInitDb; //=^
function FetchDirNames: boolean;
function LeftWord(const aStr: string): string; // used while searching static text sections
public
constructor Create(aPresenter: IPresenterMain;const aRoot: shortstring = ''); overload;
destructor Destroy; override;
{ returns the ID of the 'aDirName', existing or new }
function AppendDirectory(const aDirName, aRootDir: string): ptrint; { returns the ID of the 'aDirName' }
function AppendFile(const aPath,aFilename: string;anID: ptrint): boolean; { uses the ID of the 'aDirName' }
function GetBackendVersion: string;
function GetStaticTexts(const aSection: string; out aTarget: integer): IStringList;
procedure RefreshSections;
procedure ReloadTextCache;
function UploadBlobDir(aDir: INodeList;aFilter: string;out aLogRes: string): ptrint; { returns -1 on error }
end;
{$EndRegion 'TModelMainH'}
{ datastore factory, its intended use is in scenarios, where the 'viewmodel' / 'presenter'
does NOT OWN the 'model' and thus doesn't free it on end of use...,
in other words:
"if you create your 'model' with this factory-function then DON'T FREE IT!" just := nil }
function gModelMain(aPresenter: IPresenterMain;const aRoot: shortstring): IModelMain;
implementation
uses common.consts, obs_prosu, strutils, db, istreams, model.base; /// , baseunix , dateutils,
const {$i model.sql.inc}
var Singleton: TModelMain = nil;
{ ModelMain factory }
function gModelMain(aPresenter: IPresenterMain; const aRoot: shortstring): IModelMain;
begin
if not Assigned(Singleton) then Singleton:= TModelMain.Create(aPresenter,aRoot);
Result:= Singleton;
end;
{$Region 'TModelMain'}
{$Region 'boilerplate' -fold}
{ TModelMain }
function TModelMain.IsInFilter(aNode: PFSNode; aFilter: string): boolean;
var lext: string = '';
begin
Result:= false;
if aNode = nil then exit;
if aNode^.fnType <> 0 then exit(false); { NO DIRS!!! 0 = file, 1 = directory }
if not aNode^.fnInclude then exit(false); { excluded beforehand!!! }
{ we need a filter to compare against; NO filter means ALL FILES ARE ALLOWED!!! }
if aFilter <> '' then aFilter:= LowerCase(aFilter) else exit(true);
with aNode^ do begin
lext:= LowerCase(ExtractFileExt(fnFile)); { only file-extensions, can be empty ==> returns false!!! }
Result:= (pos(lext,aFilter) > 0); { works like a goddamn charm \o/\ö/\o/ }
end;
end;
function TModelMain.Obj: TObject;
begin
Result:= Self;
end;
procedure TModelMain.DoEach(const aValue: string; const anIdx: ptrint;
anObj: TObject; aData: pointer);
var ls: string; lid: integer;
begin
if fSecId = -1 then exit;
ls:= LeftWord(aValue);
lid:= IndexText(ls,Sects);
if lid = fSecId then begin
IStringList(aData).Append(aValue); //<- new feature <aData> typecast :o)
fInSection:= true;
end else begin
if fInSection then begin
if ((lid >= 0) and (lid <= fSectMaxIdx)) then fInSection:= false; /// 250824 /bc
if fInSection then IStringList(aData).Append(aValue); //<- new feature <aData>
end;
end;
end;
procedure TModelMain.CheckAndInitDb; //=^
var lbd: boolean = false; lbdn: boolean = false;
begin
with fDb.QuickConnect do try { no param = start transaction }
Query.SQL.Text:= checkBlobTable; { consults "sqlite_schema" table }
Query.Open;
while not Query.EOF do begin
if Query.FieldByName('name').AsString = 'blobdata' then lbd:= true;
if Query.FieldByName('name').AsString = 'blobdirnames' then lbdn:= true;
Query.Next;
end;
if not lbdn then begin
Exec.SQL.Text:= CreBlobDirNames; { 1.st setup master }
Exec.ExecSQL;
lbdn:= true;
end;
if not lbd then begin
Exec.SQL.Text:= CreBlobData; { 2.nd setup detail }
Exec.ExecSQL;
lbd:= true;
end;
finally QuickDisConnect; end; { no param = commit transaction }
if lbdn and lbd then
fPresenter.Provider.NotifySubscribers(prStatus,nil,Str2Pch('(i) Datastore initialized OK'));
end;
function TModelMain.FetchDirNames: boolean;
begin
Result:= fDb.QuerySQL(SelBlobDirNames,fLookUp)
end;
function TModelMain.LeftWord(const aStr: string): string;
var li: integer = 1;
begin { pick the left-most word in a string }
Result:= aStr;
if Result = '' then exit;
while ((li <= Length(aStr)) and (not (Result[li] in [#9,#13,#10,' ']))) do inc(li);
SetLength(Result,li-1);
end;
{$EndRegion 'boilerplate'}
constructor TModelMain.Create(aPresenter: IPresenterMain; const aRoot: shortstring);
var ltxt: IStringList; ldummy: integer = -1;
begin
inherited Create;
if Vers2Int(istVersion) < MinIStreamsVersion then
aPresenter.Provider.NotifySubscribers(prErrorFile,nil,Str2Pch('(!) WARNING! "istreams.pas" is too old, must be >= 0.29.01.2026! Go to Gitlab'));
fPresenter:= aPresenter;
fRoot:= aRoot;
UpdateSections(Sects); { <- fetch our registered sections, v- i18n }
fTextCache:= CreStrListFromFile(format(mvpTexts,[fRoot,Lang])); ///<- i18n
{ we need the model, this is a minor flaw if it fails, because then the }
if fTextCache.Count = 0 then { user will see a view filled with 'dummy' ;) }
fPresenter.Provider.NotifySubscribers(prStatus,nil,Str2Pch('(!) ERROR: Could NOT retrieve static texts!'));
ltxt:= GetStaticTexts(ClassName,ldummy);
fDb:= LiteDb; { get a hold of the global singleton }
fDb.DbName:= ltxt.Values['DbName']; { fetch our db-name }
CheckAndInitDb; /// temporary ?!? why ///
fLookUp:= TBufDataset.Create(nil){%H-};
end; /// the above text can't be translated in the i18n'ed mvptexts, the count is 0! ///
destructor TModelMain.Destroy;
begin
fLookUp.Clear;
fLookUp.Free; { class }
fTextCache:= nil; // com-object
fPresenter:= nil;
fDb:= nil; { just unref it }
inherited Destroy;
end;
function TModelMain.AppendDirectory(const aDirName, aRootDir: string): ptrint;
begin { first see if it's already there? }
if FetchDirNames then begin
if fLookUp.Locate('directory_bdn',aDirName,[loCaseInsensitive{,loPartialKey}]) then
Result:= fLookUp.FieldByName('id_bdn').AsLargeInt
else Result:= -1;
end else Result:= -1;
if Result = -1 then begin { ok, it wasn't, so we'll append it to the table }
with fDb.QuickConnect do try
Exec.Close;
Exec.SQL.Text:= InsBlobDirNames;
Exec.ParamByName('pdate').AsLargeInt:= Dati2Int(NowUTC); { calls internally 'DateTimeToUnix();' }
Exec.ParamByName('pdirectory').AsString:= aDirName;
Exec.ParamByName('prootdir').AsString:= aRootDir;
{ Exec.ParamByName('preserved').AsString:= 'reserved'; }
Exec.ExecSQL;
Result:= LastInsertedId; { return the newly created ID }
finally QuickDisConnect; end;
end;
end;
function TModelMain.AppendFile(const aPath,aFilename: string; anID: ptrint): boolean;
var lst: IMemoryStream;
begin
if not FileExists(aPath+aFilename) then exit(false);
lst:= CreMemStream;
lst.LoadFromFile(aPath+aFilename);
lst.Position:= 0;
with fDb.QuickConnect do try
Exec.Close;
Exec.SQL.Text:= insBlobData;
Exec.ParamByName('pfk_idbdn').AsLargeInt:= anID;
Exec.ParamByName('pfilename').AsString:= aFilename;
Exec.ParamByName('pfiletype').AsString:= ExtractFileExt(aFilename);
Exec.ParamByName('pdate').AsLargeInt:= Dati2Int(NowUTC+0.041666666667);
Exec.ParamByName('pblob').AsBytes:= lst.AsBytes; { new feature in IStreamFP }
Exec.ParamByName('pflag').AsInteger:= -1; { not used -- for now }
Exec.ParamByName('preserved').AsString:= 'reserved'; { here's room for a shortstring }
Exec.ExecSQL;
Result:= true;
finally QuickDisConnect; end;
end;
function TModelMain.GetBackendVersion: string;
begin
Result:= fDb.LibVersion;
end;
function TModelMain.GetStaticTexts(const aSection: string; out aTarget: integer): IStringList;
begin { we use the [] here, because it fits in with standard ini-file format, nifty huh?!? }
if aSection = '' then exit(nil);
fSection:= '['+aSection+']'; fSecId:= IndexText(fSection,sects); { iterator-search }
fSectMaxIdx:= high(Sects); { iterator-search, sets up the section 'break-off' maxidx }
if fTextCache.Count = 0 then begin
fPresenter.Provider.NotifySubscribers(prStatus,nil,Str2Pch('(!) ERROR: Could NOT retrieve static texts!'));
exit(nil); /// the above text can't be translated in the i18n'ed mvptexts, the count is 0! ///
end;
Result:= CreateStrList; { create our resulting stringlist }
fTextCache.ForEach(@DoEach,Result);{ iterate over the source-list items, sending 'Result' along }
aTarget:= fSecId; { for the presenter to differentiate between views }
end;
procedure TModelMain.RefreshSections;
begin
UpdateSections(Sects);
end;
procedure TModelMain.ReloadTextCache;
begin
fTextCache.Clear;
fTextCache.LoadFromFile(format(mvpTexts,[fRoot,Lang]));
end;
function TModelMain.UploadBlobDir(aDir: INodeList; aFilter: string; out aLogRes: string): ptrint;
const OldCount: ptrint = 0; { static var }
var lf0,lfn: PFSNode; lcurr, lcurroo, ldir, lroot: string; ldbID, lidx: ptrint; lprg: TUploadProgress;
begin
Result:= -1; aLogRes:= '';
if aDir = nil then begin aLogRes+= '(X) ERROR! IModelMain.UploadBlobDir: "aDir: INodeList = NIL"'; exit; end;
lf0:= aDir.Items[0]; { items[0] = clean 'root' and 'dir', no subdirs-chickey-mickey -- yet }
ldir:= PickLastDir(lf0^.fnDir); { in nodelist, directory ALWAYS comes first, before files!!! }
lroot:= BackUpOneDir(lf0^.fnDir); inc(Result); /// 0
aLogRes+= '(+) Uploading "' + ldir + '":'; lidx:= 0;
lprg.upDirectory:= ldir; lprg.upMin:= 0; lprg.upMax:= aDir.Count-1; lprg.upPos:= 0; lprg.upPct:= 0.0;
fPresenter.Provider.NotifySubscribers(prProgressInit,nil,@lprg);
for lfn in aDir do with lfn^ do begin { we'll do this here, before the }
inc(lprg.upPos); lprg.upPct:= (lprg.upPos / lprg.upMax) * 100; { possible }
fPresenter.Provider.NotifySubscribers(prProgressUpd,nil,@lprg); { 'continue' }
if not fnInclude then continue; { decided beforehand }
if fnType = 1 then begin { fnType = 1 => directory }
lcurr:= IPD(PickLastDir(fnDir)); { last dir + include-trailing-path-delimiter }
if fnLevel > 0 then lcurroo:= BackUpOneDir(IPD(AMinusB(fnDir,lroot)))
else lcurroo:= ''; /// BackupOneDir(fnDir); { new root for subdir }
ldbID:= AppendDirectory(lcurroo+lcurr,lroot); /// maybe aLogRes += ?!?;
end else begin { fnType = 0 => file }
if IsInFilter(lfn,aFilter) then begin
if AppendFile(lroot+lcurroo+lcurr,fnFile,ldbID) then begin
inc(Result); { counting items :o) }
aLogRes+= LE+'· Uploaded: "'+lcurr+fnFile+'" to db.';
end; { AppendFile }
end; { IsInFilter }
end; { fnType = 0 => file }
end; { lfn in aDir do }
fPresenter.Provider.NotifySubscribers(prProgressFini,nil,nil);
OldCount:= Result; { preserve the count for the next time round...S }
end;
{$EndRegion 'TModelMain'}
initialization
RegisterSection(TModelMain.ClassName);
finalization
if Assigned(Singleton) then FreeAndNil(Singleton); { checks for nil explicitly, freeandnil doesn't! }
end.
Recent
