doublecmd/src/uwdxmodule.pas
2011-06-07 23:13:28 +00:00

1166 lines
35 KiB
ObjectPascal

{
Double Commander
-------------------------------------------------------------------------
WDX-API implementation.
(TC WDX-API v1.5)
Copyright (C) 2008 Dmitry Kolomiets (B4rr4cuda@rambler.ru)
Some ideas were found in sources of WdxGuide by Alexey Torgashin
and SuperWDX by Pavel Dubrovsky and Dmitry Vorotilin.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit uWDXModule;
{$mode delphi}{$H+}
interface
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
Classes, SysUtils, uClassesEx,
uWdxPrototypes, WdxPlugin,
dynlibs, uDCUtils, uOSUtils,
uDetectStr, lua, LCLProc, uFile, uXmlConfig;
type
{ TWdxField }
TWdxField = class
FName: String;
FUnits: String;
FType: Integer;
function GetUnitIndex(UnitName: String): Integer;
end;
{ TWDXModule }
TWDXModule = class
private
function GetAName: String; virtual; abstract;
function GetAFileName: String; virtual; abstract;
function GetADetectStr: String; virtual; abstract;
procedure SetAName(AValue: String); virtual; abstract;
procedure SetAFileName(AValue: String); virtual; abstract;
procedure SetADetectStr(const AValue: String); virtual; abstract;
public
//---------------------
function LoadModule: Boolean; virtual; abstract;
procedure UnloadModule; virtual; abstract;
function IsLoaded: Boolean; virtual; abstract;
//---------------------
function FieldList: TStringList; virtual; abstract;
function WdxFieldType(n: Integer): String;
function GetFieldIndex(FieldName: String): Integer; virtual; abstract;
function FileParamVSDetectStr(const aFile: TFile): Boolean; virtual; abstract;
//------------------------------------------------------
procedure CallContentGetSupportedField; virtual; abstract;
procedure CallContentSetDefaultParams; virtual; abstract;
procedure CallContentStopGetValue(FileName: String); virtual; abstract;
//---------------------
function CallContentGetDefaultSortOrder(FieldIndex: Integer): Boolean; virtual; abstract;
function CallContentGetDetectString: String; virtual; abstract;
function CallContentGetValue(FileName: String; FieldName: String; UnitName: String; flags: Integer): String; overload; virtual; abstract;
function CallContentGetValue(FileName: String; FieldIndex, UnitIndex: Integer; flags: Integer): String; overload; virtual; abstract;
function CallContentGetSupportedFieldFlags(FieldIndex: Integer): Integer; virtual; abstract;
{ContentSetValue
ContentEditValue
ContentSendStateInformation}
//------------------------------------------------------
property Name: String read GetAName write SetAName;
property FileName: String read GetAFileName write SetAFileName;
property DetectStr: String read GetADetectStr write SetADetectStr;
//---------------------
end;
{ TPluginWDX }
TPluginWDX = class(TWDXModule)
private
FFieldsList: TStringList;
FModuleHandle: TLibHandle; // Handle to .DLL or .so
FForce: Boolean;
FParser: TParserControl;
FName: String;
FFileName: String;
FDetectStr: String;
function GetAName: String; override;
function GetAFileName: String; override;
function GetADetectStr: String; override;
procedure SetAName(AValue: String); override;
procedure SetAFileName(AValue: String); override;
procedure SetADetectStr(const AValue: String); override;
protected
//a) Mandatory (must be implemented)
ContentGetSupportedField: TContentGetSupportedField;
ContentGetValue: TContentGetValue;
//b) Optional (must NOT be implemented if unsupported!)
ContentGetDetectString: TContentGetDetectString;
ContentSetDefaultParams: TContentSetDefaultParams;
ContentStopGetValue: TContentStopGetValue;
ContentGetDefaultSortOrder: TContentGetDefaultSortOrder;
ContentPluginUnloading: TContentPluginUnloading;
ContentGetSupportedFieldFlags: TContentGetSupportedFieldFlags;
ContentSetValue: TContentSetValue;
ContentEditValue: TContentEditValue;
ContentSendStateInformation: TContentSendStateInformation;
//c) Unicode
ContentGetValueW: TContentGetValueW;
ContentStopGetValueW: TContentStopGetValueW;
ContentSetValueW: TContentSetValueW;
ContentSendStateInformationW: TContentSendStateInformationW;
public
//---------------------
constructor Create;
destructor Destroy; override;
//---------------------
function LoadModule: Boolean; override;
procedure UnloadModule; override;
function IsLoaded: Boolean; override;
//---------------------
function FieldList: TStringList; override;
function GetFieldIndex(FieldName: String): Integer; override;
function FileParamVSDetectStr(const aFile: TFile): Boolean; override;
//------------------------------------------------------
procedure CallContentGetSupportedField; override;
procedure CallContentSetDefaultParams; override;
procedure CallContentStopGetValue(FileName: String); override;
//---------------------
function CallContentGetDefaultSortOrder(FieldIndex: Integer): Boolean; override;
function CallContentGetDetectString: String; override;
function CallContentGetValue(FileName: String; FieldName: String; UnitName: String; flags: Integer): String; overload; override;
function CallContentGetValue(FileName: String; FieldIndex, UnitIndex: Integer; flags: Integer): String; overload; override;
function CallContentGetSupportedFieldFlags(FieldIndex: Integer): Integer; override;
{ContentSetValue
ContentEditValue
ContentSendStateInformation}
//------------------------------------------------------
property ModuleHandle: TLibHandle read FModuleHandle write FModuleHandle;
property Force: Boolean read FForce write FForce;
property Name: String read GetAName write SetAName;
property FileName: String read GetAFileName write SetAFileName;
property DetectStr: String read GetADetectStr write SetADetectStr;
//---------------------
end;
{ TLuaWdx }
TLuaWdx = class(TWdxModule)
private
L: Plua_State;
FFieldsList: TStringList;
FForce: Boolean;
FParser: TParserControl;
FName: String;
FFileName: String;
FDetectStr: String;
function GetAName: String; override;
function GetAFileName: String; override;
function GetADetectStr: String; override;
procedure SetAName(AValue: String); override;
procedure SetAFileName(AValue: String); override;
procedure SetADetectStr(const AValue: String); override;
function DoScript(AName: String): Integer;
function WdxLuaContentGetSupportedField(Index: Integer; var xFieldName, xUnits: String): Integer;
procedure WdxLuaContentPluginUnloading;
public
constructor Create;
destructor Destroy; override;
//---------------------
function LoadModule: Boolean; override;
procedure UnloadModule; override;
function IsLoaded: Boolean; override;
//---------------------
function FieldList: TStringList; override;
function GetFieldIndex(FieldName: String): Integer; override;
function FileParamVSDetectStr(const aFile: TFile): Boolean; override;
//------------------------------------------------------
procedure CallContentGetSupportedField; override;
procedure CallContentSetDefaultParams; override;
procedure CallContentStopGetValue(FileName: String); override;
//---------------------
function CallContentGetDefaultSortOrder(FieldIndex: Integer): Boolean; override;
function CallContentGetDetectString: String; override;
function CallContentGetValue(FileName: String; FieldName: String; UnitName: String; flags: Integer): String; overload; override;
function CallContentGetValue(FileName: String; FieldIndex, UnitIndex: Integer; flags: Integer): String; overload; override;
function CallContentGetSupportedFieldFlags(FieldIndex: Integer): Integer; override;
//---------------------
property Force: Boolean read FForce write FForce;
property Name: String read GetAName write SetAName;
property FileName: String read GetAFileName write SetAFileName;
property DetectStr: String read GetADetectStr write SetADetectStr;
end;
{ TWDXModuleList }
TWDXModuleList = class
private
Flist: TStringList;
function GetCount: Integer;
public
//---------------------
constructor Create;
destructor Destroy; override;
//---------------------
procedure Assign(Source: TWDXModuleList);
procedure Clear;
procedure Load(Ini: TIniFileEx); overload;
procedure Load(AConfig: TXmlConfig; ANode: TXmlNode); overload;
procedure Save(Ini: TIniFileEx); overload;
procedure Save(AConfig: TXmlConfig; ANode: TXmlNode); overload;
procedure DeleteItem(Index: Integer);
//---------------------
function Add(Item: TWDXModule): Integer; overload;
function Add(FileName: String): Integer; overload;
function Add(AName, FileName, DetectStr: String): Integer; overload;
function IsLoaded(AName: String): Boolean; overload;
function IsLoaded(Index: Integer): Boolean; overload;
function LoadModule(AName: String): Boolean; overload;
function LoadModule(Index: Integer): Boolean; overload;
function GetWdxModule(Index: Integer): TWDXModule; overload;
function GetWdxModule(AName: String): TWDXModule; overload;
//---------------------
//property WdxList:TStringList read Flist;
property Count: Integer read GetCount;
end;
implementation
uses
StrUtils, uGlobs, uGlobsPaths, FileUtil, uDebug;
const
WdxIniFileName = 'wdx.ini';
{ TWDXModuleList }
function TWDXModuleList.GetCount: Integer;
begin
if Assigned(Flist) then
Result := Flist.Count
else
Result := 0;
end;
constructor TWDXModuleList.Create;
begin
Flist := TStringList.Create;
end;
destructor TWDXModuleList.Destroy;
begin
Clear;
FreeAndNil(Flist);
inherited Destroy;
end;
procedure TWDXModuleList.Assign(Source: TWDXModuleList);
var
I: Integer;
begin
if Assigned(Source) then
begin
Clear;
for I := 0 to Source.Flist.Count - 1 do
begin
with TWdxModule(Source.Flist.Objects[I]) do
Add(Name, FileName, DetectStr);
end;
end;
end;
procedure TWDXModuleList.Clear;
var
i: Integer;
begin
for i := 0 to Flist.Count - 1 do
TWDXModule(Flist.Objects[i]).Free;
Flist.Clear;
end;
procedure TWDXModuleList.Load(Ini: TIniFileEx);
var
Count, I: Integer;
tmp, tp: String;
begin
Self.Clear;
Count := Ini.ReadInteger('Content Plugins', 'PluginCount', 0);
if Count = 0 then
Exit;
For i := 0 to Count - 1 do
begin
tmp := Ini.ReadString('Content Plugins', 'Plugin' + IntToStr(I + 1) + 'Name', '');
// читать FileName - читать расширение и создавать нужный обьект
tp := GetCmdDirFromEnvVar(Ini.ReadString('Content Plugins', 'Plugin' + IntToStr(I + 1) + 'Path', ''));
DCDebug('WDX:LOAD:' + tp);
if upcase(ExtractFileExt(tp)) = '.WDX' then
Flist.AddObject(UpCase(tmp), TPluginWDX.Create)
else {иначе проверка на скрипт}
if upcase(ExtractFileExt(tp)) = '.LUA' then
Flist.AddObject(UpCase(tmp), TLuaWdx.Create);
TWDXModule(Flist.Objects[I]).Name := tmp;
TWDXModule(Flist.Objects[I]).DetectStr := Ini.ReadString('Content Plugins', 'Plugin' + IntToStr(I + 1) + 'Detect', '');
TWDXModule(Flist.Objects[I]).FileName := tp;//GetCmdDirFromEnvVar(Ini.ReadString('Content Plugins','Plugin'+IntToStr(I+1)+'Path',''));
end;
end;
procedure TWDXModuleList.Load(AConfig: TXmlConfig; ANode: TXmlNode);
var
AName, APath: String;
AWdxModule: TWDXModule;
begin
Self.Clear;
ANode := ANode.FindNode('WdxPlugins');
if Assigned(ANode) then
begin
ANode := ANode.FirstChild;
while Assigned(ANode) do
begin
if ANode.CompareName('WdxPlugin') = 0 then
begin
if AConfig.TryGetValue(ANode, 'Name', AName) and
AConfig.TryGetValue(ANode, 'Path', APath) then
begin
// Create a correct object based on plugin file extension.
APath := GetCmdDirFromEnvVar(APath);
DCDebug('WDX: LOAD: ' + APath);
if UpCase(ExtractFileExt(APath)) = '.WDX' then
AWdxModule := TPluginWDX.Create
else if UpCase(ExtractFileExt(APath)) = '.LUA' then
AWdxModule := TLuaWdx.Create
else
raise Exception.Create('Invalid WDX plugin: ' + APath);
AWdxModule.Name := AName;
AWdxModule.FileName := APath;
AWdxModule.DetectStr := AConfig.GetValue(ANode, 'DetectString', '');
Flist.AddObject(UpCase(AName), AWdxModule);
end
else
DCDebug('Invalid entry in configuration: ' + AConfig.GetPathFromNode(ANode) + '.');
end;
ANode := ANode.NextSibling;
end;
end;
end;
procedure TWDXModuleList.Save(Ini: TIniFileEx);
var
i: Integer;
begin
Ini.EraseSection('Content Plugins');
Ini.WriteInteger('Content Plugins', 'PluginCount', Flist.Count);
For i := 0 to Flist.Count - 1 do
begin
Ini.WriteString('Content Plugins', 'Plugin' + IntToStr(I + 1) + 'Name', TWDXModule(Flist.Objects[I]).Name);
Ini.WriteString('Content Plugins', 'Plugin' + IntToStr(I + 1) + 'Detect', TWDXModule(Flist.Objects[I]).DetectStr);
Ini.WriteString('Content Plugins', 'Plugin' + IntToStr(I + 1) + 'Path', SetCmdDirAsEnvVar(TWDXModule(Flist.Objects[I]).FileName));
end;
end;
procedure TWDXModuleList.Save(AConfig: TXmlConfig; ANode: TXmlNode);
var
i: Integer;
SubNode: TXmlNode;
begin
ANode := AConfig.FindNode(ANode, 'WdxPlugins', True);
AConfig.ClearNode(ANode);
For i := 0 to Flist.Count - 1 do
begin
SubNode := AConfig.AddNode(ANode, 'WdxPlugin');
AConfig.AddValue(SubNode, 'Name', TWDXModule(Flist.Objects[I]).Name);
AConfig.AddValue(SubNode, 'Path', SetCmdDirAsEnvVar(TWDXModule(Flist.Objects[I]).FileName));
AConfig.AddValue(SubNode, 'DetectString', TWDXModule(Flist.Objects[I]).DetectStr);
end;
end;
procedure TWDXModuleList.DeleteItem(Index: Integer);
begin
if (Index > -1) and (Index < Flist.Count) then
begin
TWDXModule(Flist.Objects[Index]).Free;
Flist.Delete(Index);
end;
end;
function TWDXModuleList.Add(Item: TWDXModule): Integer;
begin
Result := Flist.AddObject(UpCase(item.Name), Item);
end;
function TWDXModuleList.Add(FileName: String): Integer;
var
s: String;
begin
Result := -1;
s := ExtractFileName(FileName);
if pos('.', s) > 0 then
Delete(s, pos('.', s), length(s));
if upcase(ExtractFileExt(FileName)) = '.WDX' then
Result := Flist.AddObject(UpCase(s), TPluginWDX.Create)
else {иначе проверка на скрипт}
if upcase(ExtractFileExt(FileName)) = '.LUA' then
Result := Flist.AddObject(UpCase(s), TLuaWdx.Create);
if Result <> -1 then
begin
TWDXModule(Flist.Objects[Result]).Name := s;
TWDXModule(Flist.Objects[Result]).FileName := FileName;
if TWDXModule(Flist.Objects[Result]).LoadModule then
begin
TWDXModule(Flist.Objects[Result]).DetectStr := TWDXModule(Flist.Objects[Result]).CallContentGetDetectString;
TWDXModule(Flist.Objects[Result]).UnloadModule;
end;
end;
end;
function TWDXModuleList.Add(AName, FileName, DetectStr: String): Integer;
begin
if upcase(ExtractFileExt(FileName)) = '.WDX' then
Result := Flist.AddObject(UpCase(AName), TPluginWDX.Create)
else {иначе проверка на скрипт}
if upcase(ExtractFileExt(FileName)) = '.LUA' then
Result := Flist.AddObject(UpCase(AName), TLuaWdx.Create);
// Result:=Flist.AddObject(UpCase(AName),TWDXModule.Create);
TWDXModule(Flist.Objects[Result]).Name := AName;
TWDXModule(Flist.Objects[Result]).DetectStr := DetectStr;
TWDXModule(Flist.Objects[Result]).FileName := FileName;
end;
function TWDXModuleList.IsLoaded(AName: String): Boolean;
var
x: Integer;
begin
x := Flist.IndexOf(AName);
if x = -1 then
Result := False
else
begin
Result := GetWdxModule(x).IsLoaded;
end;
end;
function TWDXModuleList.IsLoaded(Index: Integer): Boolean;
begin
Result := GetWdxModule(Index).IsLoaded;
end;
function TWDXModuleList.LoadModule(AName: String): Boolean;
var
x: Integer;
begin
x := Flist.IndexOf(UpCase(AName));
if x = -1 then
Result := False
else
begin
Result := GetWdxModule(x).LoadModule;
end;
end;
function TWDXModuleList.LoadModule(Index: Integer): Boolean;
begin
Result := GetWdxModule(Index).LoadModule;
end;
function TWDXModuleList.GetWdxModule(Index: Integer): TWDXModule;
begin
if (Flist.Objects[Index] is TPluginWDX) then
Result := TPluginWDX(Flist.Objects[Index])
else
if (Flist.Objects[Index] is TLuaWdx) then
Result := TLuaWdx(Flist.Objects[Index]);
end;
function TWDXModuleList.GetWdxModule(AName: String): TWDXModule;
var
tmp: Integer;
begin
tmp := Flist.IndexOf(upcase(AName));
if tmp > -1 then
begin
if (Flist.Objects[tmp] is TPluginWDX) then
Result := TPluginWDX(Flist.Objects[tmp])
else
if (Flist.Objects[tmp] is TLuaWdx) then
Result := TLuaWdx(Flist.Objects[tmp]);
end;
end;
{ TPluginWDX }
function TPluginWDX.IsLoaded: Boolean;
begin
Result := FModuleHandle <> 0;
end;
function TPluginWDX.FieldList: TStringList;
begin
Result := FFieldsList;
end;
function TPluginWDX.GetADetectStr: String;
begin
Result := FDetectStr;
end;
function TPluginWDX.GetAName: String;
begin
Result := FName;
end;
function TPluginWDX.GetAFileName: String;
begin
Result := FFileName;
end;
procedure TPluginWDX.SetADetectStr(const AValue: String);
begin
FDetectStr := AValue;
end;
procedure TPluginWDX.SetAName(AValue: String);
begin
FName := AValue;
end;
procedure TPluginWDX.SetAFileName(AValue: String);
begin
FFileName := AValue;
end;
constructor TPluginWDX.Create;
begin
FFieldsList := TStringList.Create;
FParser := TParserControl.Create;
end;
destructor TPluginWDX.Destroy;
var
i: Integer;
begin
if assigned(FParser) then
FParser.Free;
if assigned(FFieldsList) then
begin
for i := 0 to FFieldsList.Count - 1 do
TWdxField(FFieldsList.Objects[i]).Free;
FFieldsList.Free;
end;
Self.UnloadModule;
inherited Destroy;
end;
function TPluginWDX.LoadModule: Boolean;
begin
FModuleHandle := mbLoadLibrary(Self.FileName);
Result := (FModuleHandle <> 0);
if FModuleHandle = 0 then
exit;
{ Mandatory }
ContentGetSupportedField := TContentGetSupportedField(GetProcAddress(FModuleHandle, 'ContentGetSupportedField'));
ContentGetValue := TContentGetValue(GetProcAddress(FModuleHandle, 'ContentGetValue'));
{ Optional (must NOT be implemented if unsupported!) }
ContentGetDetectString := TContentGetDetectString(GetProcAddress(FModuleHandle, 'ContentGetDetectString'));
ContentSetDefaultParams := TContentSetDefaultParams(GetProcAddress(FModuleHandle, 'ContentSetDefaultParams'));
ContentStopGetValue := TContentStopGetValue(GetProcAddress(FModuleHandle, 'ContentStopGetValue'));
ContentGetDefaultSortOrder := TContentGetDefaultSortOrder(GetProcAddress(FModuleHandle, 'ContentGetDefaultSortOrder'));
ContentPluginUnloading := TContentPluginUnloading(GetProcAddress(FModuleHandle, 'ContentPluginUnloading'));
ContentGetSupportedFieldFlags := TContentGetSupportedFieldFlags(GetProcAddress(FModuleHandle, 'ContentGetSupportedFieldFlags'));
ContentSetValue := TContentSetValue(GetProcAddress(FModuleHandle, 'ContentSetValue'));
ContentEditValue := TContentEditValue(GetProcAddress(FModuleHandle, 'ContentEditValue'));
ContentSendStateInformation := TContentSendStateInformation(GetProcAddress(FModuleHandle, 'ContentSendStateInformation'));
{ Unicode }
ContentGetValueW := TContentGetValueW(GetProcAddress(FModuleHandle, 'ContentGetValueW'));
ContentStopGetValueW := TContentStopGetValueW(GetProcAddress(FModuleHandle, 'ContentStopGetValueW'));
ContentSetValueW := TContentSetValueW(GetProcAddress(FModuleHandle, 'ContentSetValueW'));
ContentSendStateInformationW := TContentSendStateInformationW(GetProcAddress(FModuleHandle, 'ContentSendStateInformationW'));
CallContentSetDefaultParams;
CallContentGetSupportedField;
if Length(Self.DetectStr) = 0 then
Self.DetectStr := CallContentGetDetectString;
end;
procedure TPluginWDX.CallContentSetDefaultParams;
var
dps: tContentDefaultParamStruct;
begin
if assigned(ContentSetDefaultParams) then
begin
dps.DefaultIniName := gpCfgDir + WdxIniFileName;
dps.PluginInterfaceVersionHi := 1;
dps.PluginInterfaceVersionLow := 50;
dps.size := SizeOf(tContentDefaultParamStruct);
ContentSetDefaultParams(@dps);
end;
end;
procedure TPluginWDX.CallContentStopGetValue(FileName: String);
begin
if Assigned(ContentStopGetValueW) then
ContentStopGetValueW(PWideChar(UTF8Decode(FileName)))
else if Assigned(ContentStopGetValue) then
ContentStopGetValue(PAnsiChar(UTF8ToSys(FileName)));
end;
function TPluginWDX.CallContentGetDefaultSortOrder(FieldIndex: Integer): Boolean;
var
x: Integer;
begin
if Assigned(ContentGetDefaultSortOrder) then
begin
x := ContentGetDefaultSortOrder(FieldIndex);
case x of
1: Result := False; //a..z 1..9
-1: Result := True; //z..a 9..1
end;
end;
end;
procedure TPluginWDX.UnloadModule;
begin
if assigned(ContentPluginUnloading) then
ContentPluginUnloading;
{$IF (not DEFINED(LINUX)) or ((FPC_VERSION > 2) or ((FPC_VERSION=2) and (FPC_RELEASE >= 5)))}
if FModuleHandle <> 0 then
FreeLibrary(FModuleHandle);
{$ENDIF}
FModuleHandle := 0;
{ Mandatory }
ContentGetSupportedField := nil;
ContentGetValue := nil;
{ Optional (must NOT be implemented if unsupported!) }
ContentGetDetectString := nil;
ContentSetDefaultParams := nil;
ContentStopGetValue := nil;
ContentGetDefaultSortOrder := nil;
ContentPluginUnloading := nil;
ContentGetSupportedFieldFlags := nil;
ContentSetValue := nil;
ContentEditValue := nil;
ContentSendStateInformation := nil;
{ Unicode }
ContentGetValueW := nil;
ContentStopGetValueW := nil;
ContentSetValueW := nil;
ContentSendStateInformationW := nil;
end;
procedure TPluginWDX.CallContentGetSupportedField;
var
Index,
MaxLen,
I,
Rez: Integer;
xFieldName: PAnsiChar;
xUnits: PAnsiChar;
sFieldName: UTF8String;
begin
if not Assigned(ContentGetSupportedField) then
Exit;
Index := 0;
GetMem(xFieldName, MAX_PATH);
GetMem(xUnits, MAX_PATH);
maxlen := MAX_PATH;
repeat
Rez := ContentGetSupportedField(Index, xFieldName, xUnits, MaxLen);
if Rez <> ft_nomorefields then
begin
sFieldName := SysToUTF8(StrPas(xFieldName));
I := FFieldsList.AddObject(sFieldName, TWdxField.Create);
with TWdxField(FFieldsList.Objects[I]) do
begin
FName := sFieldName;
FUnits := xUnits;
FType := Rez;
end;
end;
Inc(Index);
until Rez = ft_nomorefields;
FreeMem(xFieldName);
FreeMem(xUnits);
end;
function TPluginWDX.CallContentGetDetectString: String;
var
pacDetectString: PAnsiChar;
begin
if Assigned(ContentGetDetectString) then
begin
GetMem(pacDetectString, MAX_PATH);
FillChar(pacDetectString^, MAX_PATH, #0);
ContentGetDetectString(pacDetectString, MAX_PATH);
Result := StrPas(pacDetectString);
FreeMem(pacDetectString);
end
else
Result := '';
end;
function TPluginWDX.CallContentGetValue(FileName: String; FieldName: String; UnitName: String; flags: Integer): String;
var
FieldIndex,
UnitIndex: Integer;
begin
FieldIndex := GetFieldIndex(FieldName);
if FieldIndex <> -1 then
begin
UnitIndex := TWdxField(FieldList.Objects[FieldIndex]).GetUnitIndex(UnitName);
Result := CallContentGetValue(FileName, FieldIndex, UnitIndex, flags);
end
else
Result := EmptyStr;
end;
function TPluginWDX.CallContentGetValue(FileName: String; FieldIndex, UnitIndex: Integer; flags: Integer): String;
var
Rez: Integer;
Buf: array[0..2 * 1024] of char;
fnval: Integer absolute buf;
fnval64: Int64 absolute buf;
ffval: Double absolute buf;
fdate: TDateFormat absolute buf;
ftime: TTimeFormat absolute buf;
{$IF DEFINED(MSWINDOWS)}
xtime: Windows.FILETIME absolute buf;
{$ELSEIF DEFINED(UNIX)}
dtime: TDateTime absolute buf;
{$ENDIF}
stime: TSystemTime;
begin
if Assigned(ContentGetValueW) then
Rez := ContentGetValueW(PWideChar(UTF8Decode(FileName)), FieldIndex, UnitIndex, @Buf, SizeOf(buf), flags)
else if Assigned(ContentGetValue) then
Rez := ContentGetValue(PAnsiChar(UTF8ToSys(FileName)), FieldIndex, UnitIndex, @Buf, SizeOf(buf), flags);
case Rez of
ft_fieldempty: Result := '';
ft_numeric_32: Result := IntToStr(fnval);
ft_numeric_64: Result := IntToStr(fnval64);
ft_numeric_floating: Result := FloatToStr(ffval);
ft_date: Result := Format('%2.2d.%2.2d.%4.4d', [fdate.wDay, fdate.wMonth, fdate.wYear]);
ft_time: Result := Format('%2.2d:%2.2d:%2.2d', [ftime.wHour, ftime.wMinute, ftime.wSecond]);
ft_datetime:
begin
{$IF DEFINED(MSWINDOWS)}
Windows.FileTimeToSystemTime(xtime, stime);
Result := Format('%2.2d.%2.2d.%4.4d %2.2d:%2.2d:%2.2d', [stime.wDay, stime.wMonth, stime.wYear, stime.wHour, stime.wMinute, stime.wSecond]);
{$ELSEIF DEFINED(UNIX)}
DateTimeToSystemTime(dtime, stime);
Result := Format('%2.2d.%2.2d.%4.4d %2.2d:%2.2d:%2.2d', [stime.Day, stime.Month, stime.Year, stime.Hour, stime.Minute, stime.Second]);
{$ENDIF}
end;
ft_boolean: if fnval = 0 then
Result := 'FALSE'
else
Result := 'TRUE';
ft_multiplechoice,
ft_string,
ft_fulltext: Result := SysToUTF8(StrPas(Buf));
ft_stringw: Result := UTF8Encode(WideString(Buf));
//TODO: FT_DELAYED,ft_ondemand
else
Result := '';
end;
end;
function TPluginWDX.CallContentGetSupportedFieldFlags(FieldIndex: Integer): Integer;
begin
if assigned(ContentGetSupportedFieldFlags) then
Result := ContentGetSupportedFieldFlags(FieldIndex);
end;
function TPluginWDX.GetFieldIndex(FieldName: String): Integer;
begin
Result := FFieldsList.IndexOf(FieldName);
end;
function TPluginWDX.FileParamVSDetectStr(const aFile: TFile): Boolean;
begin
FParser.DetectStr := Self.DetectStr;
Result := FParser.TestFileResult(aFile);
end;
{ TLuaWdx }
function TLuaWdx.GetAName: String;
begin
Result := FName;
end;
function TLuaWdx.GetAFileName: String;
begin
Result := FFileName;
end;
function TLuaWdx.GetADetectStr: String;
begin
Result := FDetectStr;
end;
procedure TLuaWdx.SetAName(AValue: String);
begin
FName := AValue;
end;
procedure TLuaWdx.SetAFileName(AValue: String);
begin
FFileName := AValue;
end;
procedure TLuaWdx.SetADetectStr(const AValue: String);
begin
FDetectStr := AValue;
end;
function TLuaWdx.DoScript(AName: String): Integer;
begin
Result := LUA_ERRRUN;
if not assigned(L) then
exit;
Result := luaL_dofile(L, PChar(AName));
end;
constructor TLuaWdx.Create;
begin
if not IsLuaLibLoaded then
LoadLuaLib(gLuaLib); //Todo вынести загрузку либы в VmClass
FFieldsList := TStringList.Create;
FParser := TParserControl.Create;
end;
destructor TLuaWdx.Destroy;
begin
if Assigned(FParser) then
FParser.Free;
if Assigned(FFieldsList) then
begin
while FFieldsList.Count > 0 do
begin
TWdxField(FFieldsList.Objects[0]).Free;
FFieldsList.Delete(0);
end;
FreeAndNil(FFieldsList);
end;
Self.UnloadModule;
//UnloadLuaLib; //Todo вынести выгрузку либы в VmClass
inherited Destroy;
end;
function TLuaWdx.LoadModule: Boolean;
begin
Result := False;
if not IsLuaLibLoaded then
exit;
L := lua_open;
if not Assigned(L) then
exit;
luaL_openlibs(L);
if DoScript(Self.FFileName) = 0 then
Result := True
else
Result := False;
CallContentSetDefaultParams;
CallContentGetSupportedField;
if Length(Self.DetectStr) = 0 then
Self.DetectStr := CallContentGetDetectString;
end;
procedure TLuaWdx.UnloadModule;
begin
WdxLuaContentPluginUnloading;
if Assigned(L) then
begin
lua_close(L);
L := nil;
end;
end;
function TLuaWdx.IsLoaded: Boolean;
begin
Result := IsLuaLibLoaded and Assigned(Self.L);
end;
function TLuaWdx.FieldList: TStringList;
begin
Result := FFieldsList;
end;
function TLuaWdx.GetFieldIndex(FieldName: String): Integer;
begin
Result := FFieldsList.IndexOf(FieldName);
end;
function TLuaWdx.FileParamVSDetectStr(const aFile: TFile): Boolean;
begin
FParser.DetectStr := Self.DetectStr;
Result := FParser.TestFileResult(aFile);
end;
function TLuaWdx.WdxLuaContentGetSupportedField(Index: Integer; var xFieldName, xUnits: String): Integer;
begin
Result := ft_nomorefields;
if not assigned(L) then
exit;
lua_getglobal(L, 'ContentGetSupportedField');
if not lua_isfunction(L, -1) then
exit;
lua_pushinteger(L, Index);
lua_call(L, 1, 3);
xFieldName := lua_tostring(L, -3);
xUnits := lua_tostring(L, -2);
Result := lua_tointeger(L, -1);
lua_pop(L, 3);
end;
procedure TLuaWdx.WdxLuaContentPluginUnloading;
begin
if not assigned(L) then
exit;
lua_getglobal(L, 'ContentPluginUnloading');
if not lua_isfunction(L, -1) then
exit;
lua_call(L, 0, 0);
end;
procedure TLuaWdx.CallContentGetSupportedField;
var
Index, Rez, tmp: Integer;
xFieldName, xUnits: String;
begin
Index := 0;
repeat
Rez := WdxLuaContentGetSupportedField(Index, xFieldName, xUnits);
DCDebug('WDX:CallGetSupFields:' + IntToStr(Rez));
if Rez <> ft_nomorefields then
begin
tmp := FFieldsList.AddObject(xFieldName, TWdxField.Create);
TWdxField(FFieldsList.Objects[tmp]).FName := xFieldName;
TWdxField(FFieldsList.Objects[tmp]).FUnits := xUnits;
TWdxField(FFieldsList.Objects[tmp]).FType := Rez;
end;
Inc(Index);
until Rez = ft_nomorefields;
end;
procedure TLuaWdx.CallContentSetDefaultParams;
begin
if not assigned(L) then
exit;
lua_getglobal(L, 'ContentSetDefaultParams');
if not lua_isfunction(L, -1) then
exit;
lua_pushstring(L, PChar(gpCfgDir + WdxIniFileName));
lua_pushinteger(L, 1);
lua_pushinteger(L, 50);
lua_call(L, 3, 0);
end;
procedure TLuaWdx.CallContentStopGetValue(FileName: String);
begin
if not assigned(L) then
exit;
lua_getglobal(L, 'ContentStopGetValue');
if not lua_isfunction(L, -1) then
exit;
lua_pushstring(L, PChar(FileName));
lua_call(L, 1, 0);
end;
function TLuaWdx.CallContentGetDefaultSortOrder(FieldIndex: Integer): Boolean;
var
x: Integer;
begin
Result := False;
if not assigned(L) then
exit;
lua_getglobal(L, 'ContentGetDefaultSortOrder');
if not lua_isfunction(L, -1) then
exit;
lua_pushinteger(L, FieldIndex);
lua_call(L, 1, 1);
x := lua_tointeger(L, -1);
case x of
1: Result := False; //a..z 1..9
-1: Result := True; //z..a 9..1
end;
lua_pop(L, 1);
end;
function TLuaWdx.CallContentGetDetectString: String;
begin
Result := '';
if not assigned(L) then
exit;
lua_getglobal(L, 'ContentGetDetectString');
if not lua_isfunction(L, -1) then
exit;
lua_call(L, 0, 1);
Result := lua_tostring(L, -1);
lua_pop(L, 1);
end;
function TLuaWdx.CallContentGetValue(FileName: String; FieldName: String; UnitName: String; flags: Integer): String;
var
FieldIndex,
UnitIndex: Integer;
begin
FieldIndex := GetFieldIndex(FieldName);
if FieldIndex <> -1 then
begin
UnitIndex := TWdxField(FieldList.Objects[FieldIndex]).GetUnitIndex(UnitName);
Result := CallContentGetValue(FileName, FieldIndex, UnitIndex, flags);
end
else
Result := EmptyStr;
end;
function TLuaWdx.CallContentGetValue(FileName: String; FieldIndex, UnitIndex: Integer; flags: Integer): String;
begin
Result := '';
if not assigned(L) then
exit;
lua_getglobal(L, 'ContentGetValue');
if not lua_isfunction(L, -1) then
exit;
lua_pushstring(L, PChar(FileName));
lua_pushinteger(L, FieldIndex);
lua_pushinteger(L, UnitIndex);
lua_pushinteger(L, flags);
lua_call(L, 4, 1);
Result := lua_tostring(L, -1);
lua_pop(L, 1);
end;
function TLuaWdx.CallContentGetSupportedFieldFlags(FieldIndex: Integer): Integer;
begin
Result := 0;
if not assigned(L) then
exit;
lua_getglobal(L, 'ContentGetSupportedFieldFlags');
if not lua_isfunction(L, -1) then
exit;
lua_pushinteger(L, FieldIndex);
lua_call(L, 1, 1);
Result := lua_tointeger(L, -1);
lua_pop(L, 1);
end;
{ TWDXModule }
function TWDXModule.WdxFieldType(n: Integer): String;
begin
case n of
FT_NUMERIC_32: Result := 'FT_NUMERIC_32';
FT_NUMERIC_64: Result := 'FT_NUMERIC_64';
FT_NUMERIC_FLOATING: Result := 'FT_NUMERIC_FLOATING';
FT_DATE: Result := 'FT_DATE';
FT_TIME: Result := 'FT_TIME';
FT_DATETIME: Result := 'FT_DATETIME';
FT_BOOLEAN: Result := 'FT_BOOLEAN';
FT_MULTIPLECHOICE: Result := 'FT_MULTIPLECHOICE';
FT_STRING: Result := 'FT_STRING';
FT_FULLTEXT: Result := 'FT_FULLTEXT';
FT_NOSUCHFIELD: Result := 'FT_NOSUCHFIELD';
FT_FILEERROR: Result := 'FT_FILEERROR';
FT_FIELDEMPTY: Result := 'FT_FIELDEMPTY';
FT_DELAYED: Result := 'FT_DELAYED';
else
Result := '?';
end;
end;
{ TWdxField }
function TWdxField.GetUnitIndex(UnitName: String): Integer;
var
sUnits: String;
begin
Result := -1;
sUnits := FUnits;
while sUnits <> EmptyStr do
begin
Inc(Result);
if SameText(UnitName, Copy2SymbDel(sUnits, '|')) then
Exit;
end;
Result := 0;
end;
end.