source: cprs/trunk/VA/VA508Accessibility/VA508AccessibilityRouter.pas@ 1672

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: PChar; var Value: PChar; var Data: PChar; var ControlType: PChar;
    var State: PChar; var Instructions: PChar; var ItemInstructions: PChar) 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 RegisterDictionaryChange(Before, After: string); virtual; abstract;
    procedure RegisterCustomKeyMapping(Key: string; proc: TKeyMapProcedure;
                              shortDescription, longDescription: string); virtual; abstract;
  end;

function GetScreenReader: TVA508ScreenReader;

{ 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. }
function ScreenReaderSystemActive: 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;

type
  TNullScreenReader = class(TVA508ScreenReader)
  public
    procedure Speak(Text: string); 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;
  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;
  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;
    procedure HandleSRException(E: Exception);
    procedure Speak(Text: string); 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;
  CheckScreenReaderSystemActive: boolean = TRUE;
  uScreenReaderSystemActive: boolean = FALSE;
  uPostScreenReaderActivationTimer: TTimer = nil;

const
// 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' + CRLF +
    'reader if the screen reader is running before you start this application.'+ CRLF +
    'Please restart %s to take advantage of the enhanced'+ CRLF +
    '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;

procedure PostScreenReaderCheckEvent(Self: TObject; Sender: TObject);
var
  AppName, ext, error: string;
begin
  if ScreenReaderActive then
  begin
    FreeAndNil(uPostScreenReaderActivationTimer);
    if IsScreenReaderSupported(TRUE) then
    begin
      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;
end;

function ScreenReaderSystemActive: boolean;

  procedure CreateTimer;
  var
    ptr: TMethod;
  begin
    uPostScreenReaderActivationTimer := TTimer.Create(nil);
    with uPostScreenReaderActivationTimer do
    begin
      Enabled := FALSE;
      Interval := 1000 * POST_SCREEN_READER_ACTIVATION_CHECK_SECONDS;
      ptr.Code := @PostScreenReaderCheckEvent;
      ptr.Data := @ptr;
      OnTimer := TNotifyEvent(ptr);
      Enabled := TRUE;
    end;
  end;

begin
  if CheckScreenReaderSystemActive then
  begin
    CheckScreenReaderSystemActive := FALSE;
    // prevent Delphi IDE from running DLL 
    if LowerCase(ExtractFileName(ParamStr(0))) <> 'bds.exe' then
      uScreenReaderSystemActive := ScreenReaderDLLsExist;
    if uScreenReaderSystemActive then
    begin
      if ScreenReaderSupportEnabled then
      begin
        if IsScreenReaderSupported(FALSE) then
          uScreenReaderSystemActive := InitializeScreenReaderLink
        else
          uScreenReaderSystemActive := FALSE;
      end
      else
      begin
        uScreenReaderSystemActive := FALSE;
        CreateTimer;
      end;
    end;
  end;
  Result := uScreenReaderSystemActive;
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
  CloseScreenReaderLink;
  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;
  p2: PChar;
  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
        if Str2 = '' then
          p2 := nil
        else
          p2 := PChar(Str2);
        SRRegisterCustomBehavior(Action, PChar(Str1), P2);
      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;
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
              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
                end;
              finally
                Reader.Free;
              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);
          SRRegisterCustomBehavior(Action, PChar(Before), PChar(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
  if (not assigned(SRSpeakText)) or (Text = '') then exit;
  try
    SRSpeakText(PChar(Text));
  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: PChar;
  Value: PChar;
  Data: PChar;
  ControlType: PChar;
  State: PChar;
  Instructions: PChar;
  ItemInstructions: PChar;
  DataStatus: LongInt;

  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;
        Caption := nil;
        Value := nil;
        Data := nil;
        ControlType := nil;
        State := nil;
        Instructions := nil;
        ItemInstructions := nil;
        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);
          inc(i);
        end;
        SRComponentData(WindowHandle, DataStatus, Caption, Value, Data, ControlType, State, Instructions, ItemInstructions);
      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;

initialization
  SaveInitProc := InitProc;
  InitProc := @VA508RouterInitProc;

finalization
  if assigned(ActiveScreenReader) then
    FreeAndNil(ActiveScreenReader);
  if assigned(uNonDialogClassNames) then
    FreeAndNil(uNonDialogClassNames);
  if assigned(uPostScreenReaderActivationTimer) then
    FreeAndNil(uPostScreenReaderActivationTimer);    

end.