Пример использования FastScript

amonra

Пример использования FastScript.
Управление правами доступа.

Для организации прав доступа в программе использую FastScript.

CREATE TABLE CLASS_USERRIGHTS (
    ID            INTEGER NOT NULL,
    ID_USERRIGHT  INTEGER NOT NULL,
    CLASSNAME     VARCHAR(84) DEFAULT '' NOT NULL,
    PARAMS        BLOB SUB_TYPE 1 SEGMENT SIZE 256,
    PROJECT       VARCHAR(84) DEFAULT '' NOT NULL
);

ALTER TABLE CLASS_USERRIGHTS ADD CONSTRAINT PK_CLASS_USERRIGHTS PRIMARY KEY (ID);

ID_USERRIGHT - Роль
CLASSNAME - Class формы
PARAMS - Описание прав
PROJECT - Т.к. с базой могут работать разные EXE, а названия форм могут пресекаться

Программная часть

В каждой форме проекта есть такой обработчик

procedure TForm.FormCreate(Sender: TObject);
var i: integer;
begin
  RegisterClass(TComponentClass(Self.ClassType));
  DM.LoadUserRights(Self);
end;

Точнее он только на базовой форме, остальные наследуются от нее.

Основные операции вынесены в DataModule

---

unit UDM;

type
  TDM = class(TDataModule)
    procedure DataModuleCreate(Sender: TObject);
    ...
  protected
    procedure StartLogin;  // Проверка 
    procedure LoadAllUserRithts(Form: TComponent; compClass: TClass);
  public
    IDUser,Prava : integer;
    Password, UserName :string;
    Project: string;
    procedure LoadUserRights(Form: TComponent);
  end;

implementation

procedure TDM.DataModuleCreate(Sender: TObject);
begin
  Project := UpperCase(ExtractFileName(Application.ExeName));

  StartLogin;
end;

procedure TDM.StartLogin;
var
  i, PaswordYN: integer;
  s, sw: string;
begin
  try
    DBD.Close;
    DBD.DBParams.Values['user_name']:='LOGINUSER';
    DBD.DBParams.Values['password'] :='12345';
    DBD.Open;
  except
    on e: Exception do
    begin
      ErrorMessage('Не могу открыть базу данных.'+CRLF+'Обратитесь к администратору.');
      Application.Terminate;
      Exit;
    end;
  end;

// function PasswordQuery: boolean;
// Запрос Имени/Пароля, и в случае успеха заолняется 
// IDUser, Prava, Password, UserName

  if not PasswordQuery then  
  begin
    Application.Terminate;
    Exit;
  end;

  try
    DBD.Close;
    DBD.DBParams.Values['user_name']:=UserName;
    DBD.DBParams.Values['password'] :=Password;
    DBD.Open;
  except
    on e: Exception do
    begin
      ErrorMessage('Не могу открыть базу данных.'+CRLF+'Обратитесь к администратору.');
      WriteError(dbd,e, 'DataModuleCreate');
      Application.Terminate;
      Exit;
    end;
  end;
end;

procedure TDM.LoadUserRights(Form: TComponent);
begin
  LoadAllUserRithts(Form, Form.ClassType);
end;

procedure TDM.LoadAllUserRithts(Form: TComponent; compClass: TClass);
var
  fScript: TMyFsScript;
  s: string;
  i: integer;
begin
  RegisterClass(TComponentClass(compClass));
  if IDUser = 0 then exit;

  if (compClass = nil) or (compClass = TCustomForm) then exit;
  with GetQSQL do
  try
    SQL.Text := 'select params from CLASS_USERRIGHTS where ID_USERRIGHT = :i and UPPER(CLASSNAME) = UPPER(:f) and PROJECT = :p';
    ExecWP([Prava, compClass.ClassName, Project]);
    if RecordCount > 0 then
      s:= Fields[0].AsString
    else
      s := 'begin'#13'  inherited;'#13#13'end.';
  finally
    Close;
  end;

  fScript := TMyFsScript.Create(Application);
  try
    fScript.Parent := fsGlobalUnit;
    fScript.AddClass(Form.ClassType, TForm.ClassName);
    fScript.AddObject('Self',Form);
    fScript.FCurrentClass := compClass;
    fScript.FCurrentComponent := Form;
    fScript.FInheritedProc := LoadAllUserRithts;

    fScript.AddVariable('UserName', 'String', UserName);
    fScript.AddVariable('Password', 'String', Password);
    fScript.AddVariable('Prava', 'Integer', Prava);
    fScript.AddVariable('IDUser', 'Integer', IDUser);

    for i:=0 to Form.ComponentCount-1 do
    begin
      if Form.Components[i].Name <> '' then
      begin
        fScript.AddObject(Form.Components[i].Name, Form.Components[i]);
      end;
    end;

    fScript.AddMethod('procedure inherited', fScript.ScriptInherited);

    fScript.Lines.Text := s;
    if not fScript.Run then
      ShowMessage(fScript.ErrorMsg);
  finally
    fScript.Free;
  end;
end;

---

unit UMyFsScript;

interface

uses
  classes, fs_iinterpreter;

type
  TInheritedProc = procedure (Form: TComponent; compClass: TClass) of object;

  TMyFsScript = class(TfsScript)
  public
    FCurrentClass: TClass;
    FCurrentComponent: TComponent;
    FInheritedProc: TInheritedProc;
  published
    function ScriptInherited(Instance: TObject; ClassType: TClass;
      const MethodName: String; var Params: Variant): Variant;
  end;

implementation

{ TMyFsScript }

function TMyFsScript.ScriptInherited(Instance: TObject; ClassType: TClass;
  const MethodName: String; var Params: Variant): Variant;
begin
  Result := 0;
  if MethodName = 'INHERITED' then
  begin
    if @FInheritedProc <> nil then
      FInheritedProc(FCurrentComponent, FCurrentClass.ClassParent);
  end;
end;

end.

Теперь в для каждой формы проекта могу задать обработчик, в котором описать действия для каждого пользователя или группы пользователей, например

---

var i: integer;
begin
  inherited;

  ToolBar.AutoSize := false;
  DetailNavigator.Visible := false;
  for i:=0 to ActionList.ActionCount-1 do
  begin
    ActionList[i].visible := false;
  end;
  AMenuSpr.Visible := true;
  ASprItem.Visible := true;
  AClose.Visible := true;

  Panel2.Caption := '';
  btnNextFirme.Visible := false;

  ToolBar.AutoSize := true;
end.

или

begin
  inherited;
  if UserName <> 'USR101' then
  begin
    Edit1.Visible := false;
    Edit2.Readonly := true;
  end;
  Self.Caption := 'Главное меню';
end.

Описал, конечно сумбурно. Если есть вопросы задавайте