unit fs01ef_main;
interface
uses
//-----------------------------
//FastScript
fs_iinterpreter,
fs_synmemo,
fs_ipascal,
fs_iclassesrtti,
//-----------------------------
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Buttons, Vcl.StdCtrls, Vcl.ExtCtrls,
Vcl.ComCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
fsScript1: TfsScript;
fsPascal1: TfsPascal;
fsClassesRTTI1: TfsClassesRTTI;
Panel2: TPanel;
Panel3: TPanel;
SpeedButton1: TSpeedButton;
GroupBox1: TGroupBox;
fsSyntaxMemo1: TfsSyntaxMemo;
Panel_fsSyntMemo: TPanel;
procedure FormCreate(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
//функция (метод) формы, где реализована обработка вызова функции/процедуры
function fsCallMethod(Instance: TObject;
ClassType: TClass;
const MethodName: String;
var Params: Variant): Variant;
end;
var
Form1: TForm1;
function MyFunc_AddToFS(fsScr: TfsScript; //компонент fsScript
sWhat:string; //вид: procedure или function
sFuncRes:string; //тип возвр. значения для function или пустая строка для procedure
sListFuncNames:string; //перечень (через точку с запятой) идентификаторов (наименований) фукции/процедуры
sFuncScript:string; //текст "объявления" функции/процедуры (без окаймляющих скобок)
fCallMethod:TfsCallMethodEvent //функция формы(TForm), где реализована обработка вызова функции/процедуры
):boolean;
//Добавить в FastScript новую процедуру/функцию на "нескольких языках"
implementation
{$R *.dfm}
function Get_Word_From_String(
Sx : String;
NumWord : integer;
UnChar: String=' ';
YesAllTrim_Before: boolean=true
) : String;
//Получить слово из строки Sx по номеру NumWord. UnChar - множество разделителей
//YesAllTrim_Before - если TRUE, то перед анализом удалить из строки левые и правые пробелы
Var
InWord : byte;
NumWordCur, i : integer;
begin
Result:='';
if YesAllTrim_Before then Sx:=trim(Sx);
if length(Sx)>0 then begin
if NumWord>0 then begin
InWord := 0;
NumWordCur:=0;
i:=0;
while i<length(Sx) do
begin
i:=i+1;
if POS(Sx[i],UnChar)<=0 then begin //этот символ - НЕ разделитель
if InWord<=0 then NumWordCur:=NumWordCur+1; //мы - на начале слова
InWord:=1; //Мы внутри слова
if NumWordCur=NumWord then begin //Это - наше слово
Result:=Result+Sx[i]; //и мы его выдираем из строки
end;
end
else begin //этот символ - разделитель
InWord:=0; //Мы снаружи слова
if NumWordCur=NumWord then begin //Это было - наше слово
i:=length(Sx)+1; //поэтому, выходим из цикла и функции
end;
end;
end;
end;
end;
end;
function Get_CountWords_In_String(
Sx : String;
UnChar: String=' ';
YesAllTrim_Before: boolean=true
) : integer;
//Определить кол-во слов в строке Sx. UnChar - множество разделителей
var
InWord : byte;
i : integer;
begin
Result:=0;
if YesAllTrim_Before then Sx:=trim(Sx);
if length(Sx)>0 then begin
InWord := 0;
i:=0;
while i<length(Sx) do
begin
i:=i+1;
if POS(Sx[i],UnChar)<=0 then begin //этот символ - НЕ разделитель
if InWord<=0 then Result:=Result+1; //переход на начало слова
InWord:=1; //Мы внутри слова
end
else begin //этот символ - разделитель
InWord:=0; //Мы снаружи слова
end;
end;
end;
end;
procedure Screen_Cursor_Set(sCurs:string='crDefault');
//"Назначить" курсор на экране
Var
Yes:boolean;
begin
sCurs:=trim(sCurs);
Yes:=false;
if sCurs='' then sCurs:='crDefault';
if AnsiUpperCase(sCurs)=AnsiUpperCase('crDefault') then begin
Yes:=true;
Screen.Cursor:=crDefault;
end;
if AnsiUpperCase(sCurs)=AnsiUpperCase('crHourGlass') then begin
Yes:=true;
Screen.Cursor:=crHourGlass;
end;
if AnsiUpperCase(sCurs)=AnsiUpperCase('crSQLWait') then begin
Yes:=true;
Screen.Cursor:=crSQLWait;
end;
if AnsiUpperCase(sCurs)=AnsiUpperCase('crAppStart') then begin
Yes:=true;
Screen.Cursor:=crAppStart;
end;
if AnsiUpperCase(sCurs)=AnsiUpperCase('crHandPoint') then begin
Yes:=true;
Screen.Cursor:=crHandPoint;
end;
if AnsiUpperCase(sCurs)=AnsiUpperCase('crArrow') then begin
Yes:=true;
Screen.Cursor:=crArrow;
end;
if AnsiUpperCase(sCurs)=AnsiUpperCase('crNo') then begin
Yes:=true;
Screen.Cursor:=crNo;
end;
if not Yes then begin
Screen.Cursor:=crDefault;
end;
end;
function Files_ToStrings(List: TStrings;
FullNameMask:string = '*.*';
YesFileNamesOnly:boolean=true
):integer;
// Прочитать список файлов по маске в TStrings
Var
sDir,sMask,NameF: string;
DirInfo: TSearchRec;
Err: integer;
begin
Result := 0;
if Assigned(List) then begin
List.Clear;
FullNameMask := trim(FullNameMask);
if FullNameMask<>'' then begin
sDir:=trim(ExtractFilePath(FullNameMask));
if DirectoryExists(sDir) then begin
sMask := trim(ExtractFileName(FullNameMask));
if sMask='' then sMask := '*.*';
Err := 0;
Err := FindFirst(sDir + sMask, { faArchive } faAnyFile, DirInfo);
while Err = 0 do
begin
NameF := DirInfo.Name;
if FileExists(sDir + NameF) then begin
if YesFileNamesOnly then begin
List.Add(NameF);
end
else begin
List.Add(sDir+NameF);
end;
end;
Err := FindNext(DirInfo);
Application.ProcessMessages;
end;
FindClose(DirInfo);
Result := List.Count;
end;
end;
end;
end;
function MyFunc_AddToFS(fsScr: TfsScript; //компонент fsScript
sWhat:string; //вид: procedure или function
sFuncRes:string; //тип возвр. значения для function или пустая строка для procedure
sListFuncNames:string; //перечень (через точку с запятой) идентификаторов (наименований) фукции/процедуры
sFuncScript:string; //текст "объявления" функции/процедуры (без окаймляющих скобок)
fCallMethod:TfsCallMethodEvent //функция формы(TForm), где реализована обработка вызова функции/процедуры
):boolean;
//Добавить в FastScript новую процедуру/функцию на "нескольких языках"
Var
sNameFunc:string;
i,c:integer;
Sx:string;
s222:string;
begin
Result:=false;
if Assigned(fsScr) then begin
if Assigned(fCallMethod) then begin
sWhat:=trim(sWhat);
if length(sWhat)>0 then begin
sListFuncNames:=trim(sListFuncNames);
if length(sListFuncNames)>0 then begin
s222:='';
sFuncRes:=trim(sFuncRes);
if AnsiUpperCase(sWhat)='PROCEDURE' then sFuncRes:='';
if sFuncRes<>'' then begin
s222:=':';
if sFuncRes[length(sFuncRes)]<>';' then begin
sFuncRes:=sFuncRes+';';
end;
end
else begin
sFuncRes:=';';
end;
sFuncScript:=trim(sFuncScript);
//s222:='';
if sFuncScript<>'' then begin
if sFuncScript[length(sFuncScript)]=';' then begin
sFuncScript[length(sFuncScript)]:=' ';
end;
end;
sFuncScript:=trim(sFuncScript);
c:=Get_CountWords_In_String(
sListFuncNames,
#32+#9+';'
);
if c>0 then begin
Result:=true;
i:=0;
while i<c do
begin
i:=i+1;
sNameFunc:=trim(
Get_Word_From_String(
sListFuncNames,
i,
#32+#9+';'
)
);
if length(sNameFunc)>0 then begin
if length(sFuncScript)>0 then begin
Sx:=sWhat+' '+sNameFunc+'('+sFuncScript+')'+s222+sFuncRes;
end
else begin
Sx:=sWhat+' '+sNameFunc+s222+sFuncRes;
end;
fsScr.AddMethod(Sx, fCallMethod);
end
else begin
Result:=false;
i:=c+1;
end;
end;
end;
end;
end;
end;
end;
end;
function MyConst_AddToFS(fsScr: TfsScript;
sListConstNames:string;
sConstType:string;
sConstVal:string
):boolean;
//Добавить в FastScript новую константу на "двух языках"
Var
sNameConst:string;
i,c:integer;
begin
Result:=false;
if Assigned(fsScr) then begin
sListConstNames:=trim(sListConstNames);
sConstType:=trim(sConstType);
sConstVal:=trim(sConstVal);
if (sListConstNames<>'') and (sConstType<>'') and (sConstVal<>'') then begin
c:=Get_CountWords_In_String(sListConstNames, #32+#9+';');
if c>0 then begin
Result:=true;
i:=0;
while i<c do
begin
i:=i+1;
sNameConst:=trim(Get_Word_From_String(sListConstNames, i, #32+#9+';'));
if sNameConst<>'' then begin
fsScr.AddConst(sNameConst, sConstType, sConstVal);
end
else begin
Result:=false;
i:=c+1;
end;
end;
end;
end;
end;
end;
function TForm1.fsCallMethod(Instance: TObject;
ClassType: TClass;
const MethodName: String;
var Params: Variant): Variant;
//функция (метод) формы, где реализована обработка вызова функции/процедуры
Var
B:boolean;
begin
Result:=0;
//-------------------------------
if POS(AnsiUpperCase(';'+MethodName+';'),
AnsiUpperCase(';'+'Экран_Курсор;Screen_Cursor'+';')
)>0 then begin
Screen_Cursor_Set(trim(Params[0]));
Application.ProcessMessages;
end;
//-------------------------------
//-------------------------------
if POS(AnsiUpperCase(';'+MethodName+';'),
AnsiUpperCase(';'+'Файлы_Список_Получить;Files_List_Get'+';')
)>0 then begin
B:=Params[2];
Result:=Files_ToStrings(
POINTER(Integer(Params[0])), //List:TStrings
trim(Params[1]), //FullNameMask
B //YesFileNamesOnly
);
Application.ProcessMessages;
end;
//-------------------------------
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
fsSyntaxMemo1.Parent := Panel_fsSyntMemo;
fsSyntaxMemo1.Align := alClient;
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
Application.ProcessMessages;
//---------------------
fsScript1.Clear;
fsScript1.Lines.Text := fsSyntaxMemo1.Lines.Text;
fsScript1.Parent := fsGlobalUnit;
fsScript1.SyntaxType := 'PascalScript';
//---------------------
//---------------------
MyFunc_AddToFS(fsScript1,
'procedure','',
'Экран_Курсор;Screen_Cursor',
'sCursor:string='+#39+'crDefault'+#39,
fsCallMethod);
MyFunc_AddToFS(fsScript1,
'function', 'integer',
'Файлы_Список_Получить;Files_List_Get',
'List: TStrings;'
+' FullNameMask: string='+#39+'*.*'+#39+';'
+' YesFileNamesOnly: boolean=true'
,
fsCallMethod);
//---------------------
//---------------------
MyConst_AddToFS(fsScript1,
'Ускорение_свободного_падения',
'real',
'9.8'
);
MyConst_AddToFS(fsScript1,
'Скорость_света;Speed_of_light',
'extended',
'299792458.0'
);
//---------------------
//---------------------
if fsScript1.Compile then begin
fsScript1.Execute;
end
else begin
ShowMessage('Ошибка компиляции скрипта: '+fsScript1.ErrorMsg);
end;
//---------------------
end;
end.