unit VA508AccessibilityRouter;

interface

uses
  SysUtils,
  Windows,
  Registry,
  StrUtils,
  Classes,
  Controls,
  Dialogs,
  Contnrs,
  DateUtils,
  Forms,
  ExtCtrls;

type
  TComponentDataNeededEvent = procedure(const WindowHandle: HWND;
    var DataStatus: LongInt; var Caption: string; var Value: string;
    var Data: string; var ControlType: string; var State: string;
    var Instructions: string; var ItemInstructions: string; var Hint: string;
    var AControlGroupName: string)
    of object;

  TKeyMapProcedure = procedure;

  TVA508ScreenReader = class(TObject)
  protected
    procedure RegisterCustomClassBehavior(Before, After: string);
      virtual; abstract;
    procedure RegisterClassAsMSAA(ClassName: string); virtual; abstract;
    procedure AddComponentDataNeededEventHandler
      (event: TComponentDataNeededEvent); virtual; abstract;
    procedure RemoveComponentDataNeededEventHandler
      (event: TComponentDataNeededEvent); virtual; abstract;
  public
    procedure Speak(Text: string); virtual; abstract;
    procedure StopSpeech; virtual; abstract;
    procedure RegisterDictionaryChange(Before, After: string); virtual;
      abstract;
    procedure RegisterCustomKeyMapping(Key: string; proc: TKeyMapProcedure;
      shortDescription, longDescription: string); virtual; abstract;
  end;

function GetScreenReader: TVA508ScreenReader;

// Is the screen reader installed
function ScreenReaderInstalled(OnDemand: Boolean = False): Boolean;

// Is the screen reader currently running
function ScreenReaderActive(OnDemand: Boolean = False): Boolean;

// Is the VA 508 Framework active
function ScreenReaderSystemActive: Boolean;

function ScreenReaderSystemDLLExist: Boolean;

// Only guaranteed to be valid if called in an initialization section
// all other components stored as .dfm files will be registered as a dialog
// using the RegisterCustomClassBehavior
procedure SpecifyFormIsNotADialog(FormClass: TClass);

// do not call this routine - called by screen reader DLL
procedure ComponentDataRequested(WindowHandle: HWND;
  DataRequest: LongInt); stdcall;

implementation

uses VAUtils, VA508ScreenReaderDLLLinker, VAClasses, VA508AccessibilityConst,
  Generics.Collections, Generics.Defaults;

type
  TNullScreenReader = class(TVA508ScreenReader)
  public
    procedure Speak(Text: string); override;
    procedure StopSpeech; override;
    procedure RegisterDictionaryChange(Before, After: string); override;
    procedure RegisterCustomClassBehavior(Before, After: string); override;
    procedure RegisterClassAsMSAA(ClassName: string); override;
    procedure RegisterCustomKeyMapping(Key: string; proc: TKeyMapProcedure;
      shortDescription, longDescription: string); override;
    procedure AddComponentDataNeededEventHandler
      (event: TComponentDataNeededEvent); override;
    procedure RemoveComponentDataNeededEventHandler
      (event: TComponentDataNeededEvent); override;
  end;

  TMasterScreenReader = class(TVA508ScreenReader)
  strict private
    FEventHandlers: TVAMethodList;
    FCustomBehaviors: TStringList;
    FInternalRegistration: Boolean;
    FDataHasBeenRegistered: Boolean;
    FTrying2Register: Boolean;
    FKeyProc: TList;
    class var fCheckedInstalled: Boolean;
    class var fCheckedActive: Boolean;
    class var fCheckedSystemActive: Boolean;
    class var fIsInstalled: Boolean;
    class var fIsActive: Boolean;
    class var fIsSupportEnabled: Boolean;
    class var fPostActivationTimer: TTimer;
    class function GetIsActive(OnDemand: Boolean): Boolean; static;
    class function GetIsInstalled(OnDemand: Boolean): Boolean; static;
    class function GetIsSystemActive: Boolean; static;
  private
    function EncodeBehavior(Before, After: string; Action: integer): string;
    procedure DecodeBehavior(code: string; var Before, After: string;
      var Action: integer);
    function RegistrationAllowed: Boolean;
    procedure RegisterCustomData;
    class procedure DoTimer(Sender: TObject);
    class function GetDoesDLLExist: Boolean; static;
  protected
    procedure RegisterCustomBehavior(Str1, Str2: String; Action: integer;
      CheckIR: Boolean = False);
    procedure ProcessCustomKeyCommand(DataRequest: integer);
    property EventHandlers: TVAMethodList read FEventHandlers;
  public
    constructor Create;
    destructor Destroy; override;
    class function OnIsActive: Boolean;
    // Returns true is a screen reader is installed
    class property IsInstalled[OnDemand: Boolean]: Boolean read GetIsInstalled;
    // Returns true if a screen reader programm is running
    class property IsActive[OnDemand: Boolean]: Boolean read GetIsActive;
    // returns true is the screen reader framework was loaded
    class property IsSystemActive: Boolean read GetIsSystemActive;
    class property DoesDLLExist: Boolean read GetDoesDLLExist;
    class property PostActivationTimer: TTimer read fPostActivationTimer
      write fPostActivationTimer;
    procedure HandleSRException(E: Exception);
    procedure Speak(Text: string); override;
    procedure StopSpeech; override;
    procedure RegisterDictionaryChange(Before, After: string); override;
    procedure RegisterCustomClassBehavior(Before, After: string); override;
    procedure RegisterClassAsMSAA(ClassName: string); override;
    procedure RegisterCustomKeyMapping(Key: string; proc: TKeyMapProcedure;
      shortDescription, longDescription: string); override;
    procedure AddComponentDataNeededEventHandler
      (event: TComponentDataNeededEvent); override;
    procedure RemoveComponentDataNeededEventHandler
      (event: TComponentDataNeededEvent); override;
  end;

var
  ActiveScreenReader: TVA508ScreenReader = nil;
  MasterScreenReader: TMasterScreenReader = nil;
  uNonDialogClassNames: TStringList = nil;
  SaveInitProc: Pointer = nil;
  Need2RegisterData: Boolean = False;
  OK2RegisterData: Boolean = False;

const
  JAWS_EXENAME = 'jfw.exe';
  JAWS_FORCED = 'FORCEJAWS';
  JAWS_CL_EXE_SW = 'SCREADER';
  // number of seconds between checks for a screen reader
  POST_SCREEN_READER_ACTIVATION_CHECK_SECONDS = 30;

  POST_SCREEN_READER_INFO_MESSAGE = ERROR_INTRO +
    'The Accessibility Framework can only communicate with the screen' +
    'reader if the screen reader is running before you start this application.'
    + 'Please restart %s to take advantage of the enhanced' +
    'accessibility features offered by the Accessibility Framework.';

procedure VA508RouterInitProc;
begin
  if assigned(SaveInitProc) then
    TProcedure(SaveInitProc);
  OK2RegisterData := TRUE;
  if Need2RegisterData then
  begin
    Need2RegisterData := False;
    if ScreenReaderSystemActive then
    begin
      TMasterScreenReader(GetScreenReader).RegisterCustomData;
    end;
  end;
end;

function GetScreenReader: TVA508ScreenReader;
begin
  if not assigned(ActiveScreenReader) then
  begin
    if ScreenReaderSystemActive then
    begin
      MasterScreenReader := TMasterScreenReader.Create;
      ActiveScreenReader := MasterScreenReader;
    end
    else
      ActiveScreenReader := TNullScreenReader.Create;
  end;
  Result := ActiveScreenReader;
end;

function ScreenReaderInstalled(OnDemand: Boolean = False): Boolean;
begin
  Result := TMasterScreenReader.IsInstalled[OnDemand];
end;

function ScreenReaderActive(OnDemand: Boolean = False): Boolean;
begin
  Result := TMasterScreenReader.IsActive[OnDemand];
end;

function ScreenReaderSystemActive: Boolean;
begin
  Result := TMasterScreenReader.IsSystemActive;
end;

function ScreenReaderSystemDLLExist: Boolean;
begin
  Result := TMasterScreenReader.DoesDLLExist;
end;

procedure SpecifyFormIsNotADialog(FormClass: TClass);
var
  lc: string;
begin
  if ScreenReaderSystemActive then
  begin
    lc := lowercase(FormClass.ClassName);
    if not assigned(uNonDialogClassNames) then
      uNonDialogClassNames := TStringList.Create;
    if uNonDialogClassNames.IndexOf(lc) < 0 then
      uNonDialogClassNames.Add(lc);
    if assigned(MasterScreenReader) then
      MasterScreenReader.RegisterCustomBehavior(FormClass.ClassName, '',
        BEHAVIOR_REMOVE_COMPONENT_CLASS, TRUE);
  end;
end;

{ TMasterScreenReader }

procedure TMasterScreenReader.AddComponentDataNeededEventHandler
  (event: TComponentDataNeededEvent);
begin
  FEventHandlers.Add(TMethod(event));
end;

constructor TMasterScreenReader.Create;
begin
  FEventHandlers := TVAMethodList.Create;
  FCustomBehaviors := TStringList.Create;
  FInternalRegistration := False;
  FDataHasBeenRegistered := False;
  FKeyProc := TList.Create;
end;

procedure TMasterScreenReader.DecodeBehavior(code: string;
  var Before, After: string; var Action: integer);

  function Decode(var MasterString: string): string;
  var
    CodeLength: integer;
    hex: string;

  begin
    Result := '';
    if length(MasterString) > 1 then
    begin
      hex := copy(MasterString, 1, 2);
      CodeLength := FastHexToByte(hex);
      Result := copy(MasterString, 3, CodeLength);
      delete(MasterString, 1, CodeLength + 2);
    end;
  end;

begin
  Action := StrToIntDef(Decode(code), 0);
  Before := Decode(code);
  After := Decode(code);
  if code <> '' then
    Raise TVA508Exception.Create('Corrupted Custom Behavior');
end;

destructor TMasterScreenReader.Destroy;
begin
  FreeAndNil(FEventHandlers);
  FreeAndNil(FCustomBehaviors);
  FreeAndNil(FKeyProc);
  inherited;
end;

function TMasterScreenReader.EncodeBehavior(Before, After: string;
  Action: integer): string;

  function Coded(str: string): string;
  var
    len: integer;
  begin
    len := length(str);
    if len > 255 then
      Raise TVA508Exception.Create
        ('RegisterCustomBehavior parameter can not be more than 255 characters long');
    Result := HexChars[len] + str;
  end;

begin
  Result := Coded(IntToStr(Action)) + Coded(Before) + Coded(After);
end;

procedure TMasterScreenReader.HandleSRException(E: Exception);
begin
  if not E.ClassNameIs(TVA508Exception.ClassName) then
    raise E;
end;

procedure TMasterScreenReader.ProcessCustomKeyCommand(DataRequest: integer);
var
  idx: integer;
  proc: TKeyMapProcedure;
begin
  idx := (DataRequest AND DATA_CUSTOM_KEY_COMMAND_MASK) - 1;
  if (idx < 0) or (idx >= FKeyProc.count) then
    exit;
  proc := TKeyMapProcedure(FKeyProc[idx]);
  proc;
end;

procedure TMasterScreenReader.RegisterClassAsMSAA(ClassName: string);
begin
  RegisterCustomBehavior(ClassName, '', BEHAVIOR_ADD_COMPONENT_MSAA, TRUE);
  RegisterCustomBehavior(ClassName, '', BEHAVIOR_REMOVE_COMPONENT_CLASS, TRUE);
end;

procedure TMasterScreenReader.RegisterCustomBehavior(Str1, Str2: String;
  Action: integer; CheckIR: Boolean = False);
var
  code: string;
  idx: integer;
  ok: Boolean;
begin
  code := EncodeBehavior(Str1, Str2, Action);
  idx := FCustomBehaviors.IndexOf(code);
  if idx < 0 then
  begin
    FCustomBehaviors.Add(code);
    ok := RegistrationAllowed;
    if ok and CheckIR then
      ok := (not FInternalRegistration);
    if ok then
    begin
      try
        FrameworkRegisterBehavior(Action, Str1, Str2);
      except
        on E: Exception do
          HandleSRException(E);
      end;
    end;
  end;
end;

procedure TMasterScreenReader.RegisterCustomClassBehavior(Before,
  After: string);
begin
  RegisterCustomBehavior(Before, After, BEHAVIOR_ADD_COMPONENT_CLASS, TRUE);
  RegisterCustomBehavior(Before, After, BEHAVIOR_REMOVE_COMPONENT_MSAA, TRUE);
end;

function EnumResNameProc(module: HMODULE; lpszType: PChar; lpszName: PChar;
  var list: TStringList): BOOL; stdcall;
var
  name: string;

begin
  name := lpszName;
  list.Add(name);
  Result := TRUE;
end;

procedure TMasterScreenReader.RegisterCustomData;
const
  rErrMsg = 'READ ERROR: %s';
var
  i, Action: integer;
  Before, After, code: string;

  procedure EnsureDialogAreSpecified;
  var
    list: TStringList;
    i: integer;
    stream: TResourceStream;
    Reader: TReader;
    ChildPos: integer;
    Flags: TFilerFlags;
    clsName: string;
    ok: Boolean;
  begin
    FInternalRegistration := TRUE;
    try
      list := TStringList.Create;
      try
        if EnumResourceNames(HInstance, RT_RCDATA, @EnumResNameProc,
          integer(@list)) then
        begin
          for i := 0 to list.count - 1 do
          begin
            stream := TResourceStream.Create(HInstance, list[i], RT_RCDATA);
            try
              if TestStreamFormat(stream) = sofBinary then
              begin
                Reader := TReader.Create(stream, 512);
                try
                  try
                    Reader.ReadSignature;
                    Reader.ReadPrefix(Flags, ChildPos);
                    clsName := Reader.ReadStr;
                    ok := not assigned(uNonDialogClassNames);
                    if not ok then
                      ok := (uNonDialogClassNames.IndexOf
                        (lowercase(clsName)) < 0);
                    if ok then
                      RegisterCustomClassBehavior(clsName,
                        CLASS_BEHAVIOR_DIALOG);
                  except
{$WARN SYMBOL_PLATFORM OFF}
                    if DebugHook <> 0 then
                      OutputDebugString(PwideChar(Format(rErrMsg, [list[i]])));
{$WARN SYMBOL_PLATFORM ON}
                  end;
                finally
                  Reader.Free;
                end;
              end;
            finally
              stream.Free;
            end;
          end;
        end;
      finally
        list.Free;
      end;
    finally
      FInternalRegistration := False;
    end;
  end;

begin
  if FTrying2Register then
    exit;
  FTrying2Register := TRUE;
  try
    if OK2RegisterData then
    begin
      try
        EnsureDialogAreSpecified;
        RegisterCustomBehavior('', '',
          BEHAVIOR_PURGE_UNREGISTERED_KEY_MAPPINGS);
        for i := 0 to FCustomBehaviors.count - 1 do
        begin
          code := FCustomBehaviors[i];
          DecodeBehavior(code, Before, After, Action);
          FrameworkRegisterBehavior(Action, Before, After);
        end;
        FDataHasBeenRegistered := TRUE;
      except
        on E: Exception do
          HandleSRException(E);
      end;
    end
    else
      Need2RegisterData := TRUE;
  finally
    FTrying2Register := False;
  end;
end;

procedure TMasterScreenReader.RegisterCustomKeyMapping(Key: string;
  proc: TKeyMapProcedure; shortDescription, longDescription: string);
var
  idx: string;

  procedure AddDescription(DescType, Desc: string);
  var
    temp: string;
  begin
    temp := DescType + idx + '=' + Desc;
    if length(temp) > 255 then
      raise TVA508Exception.Create('Key Mapping description for ' + Key +
        ' exceeds 255 characters');
    RegisterCustomBehavior(DescType + idx, Desc,
      BEHAVIOR_ADD_CUSTOM_KEY_DESCRIPTION);
  end;

begin
  FKeyProc.Add(@proc);
  idx := IntToStr(FKeyProc.count);
  RegisterCustomBehavior(Key, idx, BEHAVIOR_ADD_CUSTOM_KEY_MAPPING);
  AddDescription('short', shortDescription);
  AddDescription('long', longDescription);
end;

procedure TMasterScreenReader.RegisterDictionaryChange(Before, After: string);
begin
  RegisterCustomBehavior(Before, After, BEHAVIOR_ADD_DICTIONARY_CHANGE);
end;

function TMasterScreenReader.RegistrationAllowed: Boolean;
begin
  Result := FDataHasBeenRegistered;
  if not Result then
  begin
    RegisterCustomData;
    Result := FDataHasBeenRegistered;
  end;
end;

procedure TMasterScreenReader.RemoveComponentDataNeededEventHandler
  (event: TComponentDataNeededEvent);
begin
  FEventHandlers.Remove(TMethod(event));
end;

procedure TMasterScreenReader.Speak(Text: string);
begin
  try
    FrameworkSpeakText(Text);
  except
    on E: Exception do
      HandleSRException(E);
  end;
end;

procedure TMasterScreenReader.StopSpeech;
begin
  try
    FrameworkStopSpeech;
  except
    on E: Exception do
      HandleSRException(E);
  end;
end;

// need to post a message here - can't do direct call - this message is called before mouse
// process messages are called that change a check box state
procedure ComponentDataRequested(WindowHandle: HWND;
  DataRequest: LongInt); stdcall;
var
  i: integer;
  Handle: HWND;
  Caption: string;
  Value: string;
  Data: string;
  ControlType: string;
  State: string;
  Instructions: string;
  ItemInstructions: string;
  DataStatus: LongInt;
  Hint: string;
  ControlGroupName: string;

  handler: TComponentDataNeededEvent;

begin
  if assigned(MasterScreenReader) then
  begin
    try
      if (DataRequest AND DATA_CUSTOM_KEY_COMMAND) <> 0 then
        MasterScreenReader.ProcessCustomKeyCommand(DataRequest)
      else
      begin
        Handle := WindowHandle;
        DataStatus := DataRequest;
        i := 0;
        while (i < MasterScreenReader.EventHandlers.count) do
        begin
          handler := TComponentDataNeededEvent
            (MasterScreenReader.EventHandlers.Methods[i]);
          if assigned(handler) then
            handler(Handle, DataStatus, Caption, Value, Data, ControlType,
              State, Instructions, ItemInstructions, Hint, ControlGroupName);
          inc(i);
        end;
        FrameworkComponentData(WindowHandle, Caption, Value, Data, ControlType,
          State, Instructions, ItemInstructions, Hint, ControlGroupName, DataStatus);
      end;
    except
      on E: Exception do
        MasterScreenReader.HandleSRException(E);
    end;
  end;
end;

{ TNullScreenReader }

procedure TNullScreenReader.AddComponentDataNeededEventHandler
  (event: TComponentDataNeededEvent);
begin
end;

procedure TNullScreenReader.RegisterClassAsMSAA(ClassName: string);
begin
end;

procedure TNullScreenReader.RegisterCustomClassBehavior(Before, After: string);
begin
end;

procedure TNullScreenReader.RegisterCustomKeyMapping(Key: string;
  proc: TKeyMapProcedure; shortDescription, longDescription: string);
begin

end;

procedure TNullScreenReader.RegisterDictionaryChange(Before, After: string);
begin
end;

procedure TNullScreenReader.RemoveComponentDataNeededEventHandler
  (event: TComponentDataNeededEvent);
begin
end;

procedure TNullScreenReader.Speak(Text: string);
begin
end;

procedure TNullScreenReader.StopSpeech;
begin
end;

class procedure TMasterScreenReader.DoTimer(Sender: TObject);
var
  AppName, ext, error: string;
begin
  // ensure we check again on the next run through
  if IsActive[TRUE] then
  begin
    FreeAndNil(TMasterScreenReader.PostActivationTimer);
    AppName := ExtractFileName(ParamStr(0));
    ext := ExtractFileExt(AppName);
    AppName := LeftStr(AppName, length(AppName) - length(ext));
    error := Format(POST_SCREEN_READER_INFO_MESSAGE, [AppName]);
    MessageBox(0, PChar(error), 'Accessibility Component Information',
      MB_OK or MB_ICONINFORMATION or MB_TASKMODAL or MB_TOPMOST);
  end;
end;

class function TMasterScreenReader.GetDoesDLLExist: Boolean;
begin
  Result := FrameworkDLLsExist;
end;

class function TMasterScreenReader.GetIsActive(OnDemand: Boolean): Boolean;
var
  JawsParam: String;
  b: Boolean;
begin
  // we only want to do this check once unless forced
  b := fIsActive;
  if (not fCheckedActive) or (OnDemand) then
  begin
    fCheckedActive := TRUE;
    b := FindCmdLineSwitch(JAWS_FORCED, TRUE);
    if not b then
    begin
      b := VAUtils.ProcessExists(JAWS_EXENAME);
      if not b then
      begin
        FindCmdLineSwitch(JAWS_CL_EXE_SW, JawsParam, TRUE, [clstValueAppended]);
        JawsParam := trim(JawsParam);

        if JawsParam <> '' then
          b := ProcessExists(JawsParam);
      end;
    end;
    if not OnDemand then
      fIsActive := b;
  end;
  if not OnDemand then
    Result := fIsActive
  else
    Result := b;
end;

class function TMasterScreenReader.GetIsInstalled(OnDemand: Boolean): Boolean;
const
  JAWS_REGROOT = 'SOFTWARE\Freedom Scientific\JAWS';
var
  reg: TRegistry;
  b: Boolean;
begin
  b := fIsInstalled;
  if (not fCheckedInstalled) or (OnDemand) then
  begin
    fCheckedInstalled := TRUE; // we only want to do this check once.

    // check if JAWS has been installed by looking at the registry
    reg := TRegistry.Create(KEY_READ or KEY_WOW64_64KEY);
    try
      reg.RootKey := HKEY_LOCAL_MACHINE;
      b := reg.KeyExists(JAWS_REGROOT);
    finally
      reg.Free;
    end;
    if not OnDemand then
      fIsInstalled := b;
  end;
  if not OnDemand then
    Result := fIsInstalled
  else
    Result := b;
end;

class function TMasterScreenReader.GetIsSystemActive: Boolean;
{ TODO -oJeremy Merrill -c508 :
  if ScreenReaderSystemActive is false, but there are valid DLLs, add a recheck every 30 seconds
  to see if the screen reader is running.  in the timer event, see if DLL.IsRunning is running is true.
  if it is then pop up a message to the user (only once) and inform them that if they restart the app
  with the screen reader running it will work better.  After the popup disable the timer event. }
const
  JAWS_FRAMEWORK_MISSING = ERROR_INTRO +
    ' The application was unable to locate and load the Accessibility Framework.'
    + CRLF + 'This application will not be fully 508 compliant and may not read correctly.'
    + CRLF + 'Please contact your local help desk for assistance.';

  procedure CreateTimer;
  begin
    fPostActivationTimer := TTimer.Create(nil);
    fPostActivationTimer.OnTimer := DoTimer;
    with fPostActivationTimer do
    begin
      Enabled := False;
      Interval := 1000 * POST_SCREEN_READER_ACTIVATION_CHECK_SECONDS;
      OnTimer := DoTimer;
      Enabled := TRUE;
    end;
  end;

  Function OpeningIDE: Boolean;
  begin
    Result := lowercase(ExtractFileName(ParamStr(0))) = 'bds.exe';
  end;

begin
  if not fCheckedSystemActive then
  begin
    fCheckedSystemActive := TRUE;
    if not assigned(VAUtils.TScreenReaderCallback.OnIsActive) then
      VAUtils.TScreenReaderCallback.OnIsActive := TMasterScreenReader.OnIsActive;
    // prevent Delphi IDE from running DLL
    if (not OpeningIDE) then
    begin
      if ScreenReaderActive then
      begin
        fIsSupportEnabled := FrameWorkStart;
        if not FrameworkDLLsExist then
          ShowMessage(JAWS_FRAMEWORK_MISSING);
      end
      else
      begin
        fIsSupportEnabled := False;
        if ScreenReaderInstalled then
          CreateTimer;
      end;
    end;
  end;
  Result := fIsSupportEnabled;
end;

class function TMasterScreenReader.OnIsActive: Boolean;
begin
  Result := IsActive[False];
end;

initialization

SaveInitProc := InitProc;
InitProc := @VA508RouterInitProc;
if not assigned(VAUtils.TScreenReaderCallback.OnIsActive) then
  VAUtils.TScreenReaderCallback.OnIsActive := TMasterScreenReader.OnIsActive;
if not assigned(TVA508ManagerCallback.OnDataRequest) then
  TVA508ManagerCallback.OnDataRequest := ComponentDataRequested;

finalization

if assigned(ActiveScreenReader) then
  FreeAndNil(ActiveScreenReader);
if assigned(uNonDialogClassNames) then
  FreeAndNil(uNonDialogClassNames);
if assigned(TMasterScreenReader.PostActivationTimer) then
  FreeAndNil(TMasterScreenReader.PostActivationTimer);

end.
