View Issue Details

IDProjectCategoryView StatusLast Update
0035468FPCCompilerpublic2020-05-19 13:03
ReporterMarco van de Voort Assigned ToMarco van de Voort  
PrioritynormalSeverityminorReproducibilityhave not tried
Status feedbackResolutionopen 
Platformwin32 
Product Version3.3.1 
Summary0035468: Compiler raises exception. Probably generics related
DescriptionThe compiler has an exception on the attached code. The code looks horrible, and the last line mentioned in the log reads

 TPusherClient.Instance.FSubscribed[StrPas(Channel)][StrPas(EventName)](StrPas(Message));

where fsubscribed of type tsubscribelist:

  TEventCallback = TDictionary<string, TCallbackProcedure>;
  TSubscribeList = TObjectDictionary<string, TEventCallback>;
Steps To ReproduceFPC -Sd with 3.3.1 as of today.
Additional Informationgenerics.dictionaries.inc(190,92) Warning: Constructing a class "TCustomDictionaryEnumerator$4$crc6DCA93A3" with abstract method "
DoMoveNext"
generics.dictionaries.inc(190,92) Warning: Constructing a class "TCustomDictionaryEnumerator$4$crc6DCA93A3" with abstract method "
GetCurrent"
generics.dictionaries.inc(190,92) Warning: Constructing a class "TCustomDictionaryEnumerator$4$crc513CF468" with abstract method "
DoMoveNext"
generics.dictionaries.inc(190,92) Warning: Constructing a class "TCustomDictionaryEnumerator$4$crc513CF468" with abstract method "
GetCurrent"
pusherclient.pp(62,56) Error: Compilation raised exception internally
Fatal: Compilation aborted
An unhandled exception occurred at $006BD1EC:
EAccessViolation: Access violation
  $006BD1EC
  $0051198F SECONDPASS, line 208 of pass_2.pas
TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget-
Attached Files

Activities

Marco van de Voort

2019-04-29 12:24

manager  

pusherclient.pp (5,443 bytes)   
unit PusherClient;

interface

uses
  SysUtils,
  ComObj,
  Generics.Collections;

type
  TCallbackProcedure =  procedure(message: string);
  TEventCallback = TDictionary<string, TCallbackProcedure>;
  TSubscribeList = TObjectDictionary<string, TEventCallback>;
  TConnectionOptions = set of (coUseSSL);

  TPusherClient = class
  strict private
    class var FInstance : TPusherClient;
  private
    FOnLog: TCallbackProcedure;
    FOnError: TCallbackProcedure;
    FOnConnectionStateChange: TCallbackProcedure;
    FSubscribed: TSubscribeList;
    PusherClientNative: OleVariant;
    class procedure ReleaseInstance();
    constructor Create;
    procedure Error(Message: string);
    procedure Log(Message: string);
    procedure ConnectionStateChange(Message: string);
  public
    class function Instance(): TPusherClient;
    procedure Connect(Key: string; CustomHost: string = ''; Options: TConnectionOptions = [coUseSSL]);
    procedure Disconnect();
    procedure Subscribe(Channel, EventName: String; Callback: TCallbackProcedure);
    property OnError: TCallbackProcedure read FOnError write FOnError;
    property OnLog: TCallbackProcedure read FOnLog write FOnLog;
    property OnConnectionStateChange: TCallbackProcedure read FOnConnectionStateChange
      write FOnConnectionStateChange;
    destructor Destroy; override;
  end;


implementation

{ TPusherClient }

procedure OnLogStdCall(Message: pchar); stdcall;
begin
  TPusherClient.Instance.Log(StrPas(Message));
end;

procedure OnErrorStdCall(message: pchar); stdcall;
begin
  TPusherClient.Instance.Error(StrPas(Message));
end;

procedure OnSubscribeEventStdCall(Channel: pchar; EventName: pchar; Message: pchar); stdcall;
var
  ErrorMessage: string;
begin
  try
    TPusherClient.Instance.FSubscribed[StrPas(Channel)][StrPas(EventName)](StrPas(Message));
  except
    on E:Exception do
    begin
      ErrorMessage := Format(
        'A Subscribed Event Message has been received but can''t be delivered.'
        + sLineBreak + '[Channel][Event]: Message: [%s][%s]: [%s]'
        + sLineBreak + 'Error: [%s]',
        [StrPas(Channel), StrPas(EventName), StrPas(Message), E.Message]);
      TPusherClient.Instance.Error(ErrorMessage);
      TPusherClient.Instance.Log(ErrorMessage);
    end;
  end;
end;

procedure OnConnectionStateChangeStdCall(message: pchar); stdcall;
begin
  TPusherClient.Instance.ConnectionStateChange(StrPas(Message));
end;

procedure TPusherClient.Connect(Key, CustomHost: string; Options: TConnectionOptions);
begin
  PusherClientNative.InitializePusherClient(Key, coUseSSL in Options, CustomHost);

  PusherClientNative.RegisterOnErrorCallback(LongInt(@OnErrorStdCall));
  PusherClientNative.RegisterLogCallback(LongInt(@OnLogStdCall));
  PusherClientNative.RegisterOnConnectionStateChangeCallback(LongInt(@OnConnectionStateChangeStdCall));
  PusherClientNative.RegisteronSubscribedEventMessageCallback(LongInt(@OnSubscribeEventStdCall));

  PusherClientNative.Connect;
end;

constructor TPusherClient.Create;
begin
  FSubscribed := TSubscribeList.Create([doOwnsValues]);

  PusherClientNative := CreateOleObject('PusherClientNative.Pusher');
end;

destructor TPusherClient.Destroy;
begin
  PusherClientNative := varNull;
  FSubscribed.Free;
  inherited;
end;

procedure TPusherClient.Disconnect;
begin
  PusherClientNative.Disconnect;
end;

class function TPusherClient.Instance: TPusherClient;
begin
  if not Assigned(Self.FInstance) then
    self.FInstance := TPusherClient.Create;
  Result := Self.FInstance;
end;

procedure TPusherClient.ConnectionStateChange(Message: string);
begin
  try
    if Assigned(FOnConnectionStateChange) then
      FOnConnectionStateChange(Message);
  except
    on E:Exception do
      Error('An error occurred while calling the event OnConnectionStateChange: ' + e.message)
  end;
end;

procedure TPusherClient.Error(Message: string);
begin
  try
    if Assigned(FOnError) then
      FOnError(Message);
  except
    // This method cannot fail under any circumstances. It is called by the ComObj callback.
    // if some of the others callbacks (OnLog, OnConnectionStateChange) fails they will call this
    // method to try to inform the client application about the problem, but, if this method
    // fails, there are nothing we can do.
  end;
end;

procedure TPusherClient.Log(Message: string);
begin
  try
    if Assigned(FOnLog) then
      FOnLog(Message);
  except
    on E:Exception do
      Error('An error occurred while calling the event OnLog: ' + e.message)
  end;
end;

class procedure TPusherClient.ReleaseInstance;
begin
  if Assigned(Self.FInstance) then
    Self.FInstance.Free;
end;

procedure TPusherClient.Subscribe(Channel, EventName: String;
  Callback: TCallbackProcedure);
var
  EventCallback: TEventCallback;
begin
  if FSubscribed.ContainsKey(Channel) then
    EventCallback := FSubscribed[Channel]
  else
  begin
    EventCallback := TEventCallback.Create;
    FSubscribed.Add(Channel, EventCallback);
  end;

  if EventCallback.ContainsKey(EventName) then
    EventCallback[EventName] := Callback
  else
  begin
    EventCallback.Add(EventName, Callback);
    PusherClientNative.Subscribe(Channel, EventName);
  end;
end;

initialization
finalization
  TPusherClient.ReleaseInstance();

end.
pusherclient.pp (5,443 bytes)   

Marco van de Voort

2019-04-29 12:41

manager   ~0115890

It is indeed the line quoted, if I split it in

 tmpevt : Teventcallback;
begin
  try
   tmpevt:=TPusherClient.Instance.FSubscribed[StrPas(Channel)];
   tmpevt[StrPas(EventName)](StrPas(Message));
  except

it compiles

Thaddy de Koning

2019-04-29 15:40

reporter   ~0115896

strpas() will not throw any errors, but is limited to shortstring length.... Why not simply hardcast? That works better.
(I even got an internal error at some point while testing this, but it is gone now.)
Seems related to strpas(). Ole paths can exceed 255 very easily.

Sven Barth

2019-04-29 17:39

manager   ~0115899

@Thaddy: It's an exception inside the compiler, not an exception of the program.

Marco van de Voort

2019-04-30 09:10

manager   ~0115911

Yes, pity that the trace is so incomplete.

Akira1364

2019-05-02 05:04

reporter   ~0115946

Last edited: 2019-05-04 23:56

View 2 revisions

Note that doing:

with TPusherClient.Instance.FSubscribed[StrPas(Channel)] do
  Items[StrPas(EventName)](StrPas(Message));

also compiles fine. So it seems to have something to do with indexing.

Marco van de Voort

2020-05-19 13:03

manager   ~0122930

Please retest, works now for me.

Issue History

Date Modified Username Field Change
2019-04-29 12:24 Marco van de Voort New Issue
2019-04-29 12:24 Marco van de Voort File Added: pusherclient.pp
2019-04-29 12:41 Marco van de Voort Note Added: 0115890
2019-04-29 15:40 Thaddy de Koning Note Added: 0115896
2019-04-29 17:39 Sven Barth Note Added: 0115899
2019-04-30 09:10 Marco van de Voort Note Added: 0115911
2019-05-02 05:04 Akira1364 Note Added: 0115946
2019-05-04 23:56 Akira1364 Note Edited: 0115946 View Revisions
2020-05-19 13:03 Marco van de Voort Assigned To => Marco van de Voort
2020-05-19 13:03 Marco van de Voort Status new => feedback
2020-05-19 13:03 Marco van de Voort FPCTarget => -
2020-05-19 13:03 Marco van de Voort Note Added: 0122930