--- Merging r22257 into '.':

U    rtl/objpas/classes/stringl.inc
U    rtl/objpas/classes/collect.inc
U    rtl/objpas/classes/persist.inc
U    rtl/objpas/classes/lists.inc
U    rtl/objpas/classes/classesh.inc
--- Merging r22258 into '.':
G    rtl/objpas/classes/collect.inc
--- Merging r22260 into '.':
U    rtl/objpas/rtlconst.inc
--- Merging r22261 into '.':
G    rtl/objpas/classes/collect.inc
G    rtl/objpas/classes/lists.inc
--- Merging r22262 into '.':
G    rtl/objpas/classes/stringl.inc
G    rtl/objpas/classes/collect.inc
G    rtl/objpas/classes/lists.inc
G    rtl/objpas/classes/classesh.inc
--- Merging r22392 into '.':
U    rtl/objpas/classes/streams.inc
G    rtl/objpas/classes/classesh.inc
--- Merging r22398 into '.':
U    packages/fcl-base/fpmake.pp
A    packages/fcl-base/src/fpobserver.pp
--- Merging r22427 into '.':
U    rtl/win/winsock2.pp
--- Merging r22504 into '.':
U    packages/winunits-base/src/mmsystem.pp
--- Merging r22526 into '.':
U    rtl/win/wininc/base.inc
U    rtl/win/wininc/func.inc
--- Merging r22556 into '.':
G    rtl/objpas/classes/classesh.inc

# revisions: 22257,22258,22260,22261,22262,22392,22398,22427,22504,22526,22556
r22257 | michael | 2012-08-27 21:28:14 +0200 (Mon, 27 Aug 2012) | 1 line
Changed paths:
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/collect.inc
   M /trunk/rtl/objpas/classes/lists.inc
   M /trunk/rtl/objpas/classes/persist.inc
   M /trunk/rtl/objpas/classes/stringl.inc

* Added observer support
r22258 | michael | 2012-08-27 21:35:54 +0200 (Mon, 27 Aug 2012) | 1 line
Changed paths:
   M /trunk/rtl/objpas/classes/collect.inc

* TCollection.Exchange also needs to notify
r22260 | michael | 2012-08-28 09:20:42 +0200 (Tue, 28 Aug 2012) | 1 line
Changed paths:
   M /trunk/rtl/objpas/rtlconst.inc

* Forgot to commit
r22261 | michael | 2012-08-28 14:30:06 +0200 (Tue, 28 Aug 2012) | 1 line
Changed paths:
   M /trunk/rtl/objpas/classes/collect.inc
   M /trunk/rtl/objpas/classes/lists.inc

* remove use of ooCustom to avoid polluting custom use
r22262 | michael | 2012-08-28 14:32:15 +0200 (Tue, 28 Aug 2012) | 1 line
Changed paths:
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/collect.inc
   M /trunk/rtl/objpas/classes/lists.inc
   M /trunk/rtl/objpas/classes/stringl.inc

* Changed ooChanged to ooChange, to be more consistent with tense in other values
r22392 | jonas | 2012-09-14 17:05:08 +0200 (Fri, 14 Sep 2012) | 4 lines
Changed paths:
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/streams.inc

  * changed resource handle parameters from THandle to TFPResourceHMODULE so
    they don't truncate the handle data on 64 bit platforms (patch by
    Anton Kavalenka, mantis #21721)
r22398 | michael | 2012-09-16 11:09:13 +0200 (Sun, 16 Sep 2012) | 1 line
Changed paths:
   M /trunk/packages/fcl-base/fpmake.pp
   A /trunk/packages/fcl-base/src/fpobserver.pp

* Observer hook and mediator implementation added
r22427 | marco | 2012-09-20 18:56:28 +0200 (Thu, 20 Sep 2012) | 2 lines
Changed paths:
   M /trunk/rtl/win/winsock2.pp

 * fix some of the overloads for -A and -W routines.
r22504 | marco | 2012-09-30 12:32:32 +0200 (Sun, 30 Sep 2012) | 2 lines
Changed paths:
   M /trunk/packages/winunits-base/src/mmsystem.pp

 * a few dword->dword_ptr fixes. I only fixed a few that sb in a forum stumbled on, I didn't do a full audit.
r22526 | marco | 2012-10-03 21:06:22 +0200 (Wed, 03 Oct 2012) | 2 lines
Changed paths:
   M /trunk/rtl/win/wininc/base.inc
   M /trunk/rtl/win/wininc/func.inc

 * fixes #23025, 64-bit issue with timer functions, patch by Luiz Americo
r22556 | marco | 2012-10-06 12:06:55 +0200 (Sat, 06 Oct 2012) | 4 lines
Changed paths:
   M /trunk/rtl/objpas/classes/classesh.inc

 * change make TBinaryObjectWriter.WriteStr public mantis #22973
   Delphi seems to use .writestr also for shortstring only, so the 
   function is the same.

git-svn-id: branches/fixes_2_6@22689 -

.gitattributes

@@ -1755,6 +1755,7 @@ packages/fcl-base/src/dummy/eventlog.inc svneol=native#text/plain
 packages/fcl-base/src/eventlog.pp svneol=native#text/plain
 packages/fcl-base/src/fpexprpars.pp svneol=native#text/plain
 packages/fcl-base/src/fpmimetypes.pp svneol=native#text/plain
+packages/fcl-base/src/fpobserver.pp svneol=native#text/plain
 packages/fcl-base/src/fptemplate.pp svneol=native#text/plain
 packages/fcl-base/src/fptimer.pp svneol=native#text/plain
 packages/fcl-base/src/gettext.pp svneol=native#text/plain

packages/fcl-base/fpmake.pp

@@ -38,6 +38,8 @@ begin
     T:=P.Targets.AddUnit('ascii85.pp');
     T:=P.Targets.AddUnit('avl_tree.pp');
     T:=P.Targets.AddUnit('base64.pp');
+    T:=P.Targets.AddUnit('fpobserver.pp');
+      T.ResourceStrings:=true;
     T:=P.Targets.AddUnit('blowfish.pp');
       T.ResourceStrings:=true;
     T:=P.Targets.AddUnit('bufstream.pp');

packages/fcl-base/src/fpobserver.pp

@@ -0,0 +1,1473 @@
+unit fpobserver;
+
+{$mode objfpc}{$H+}
+{$interfaces corba}
+
+interface
+
+uses
+  Classes, SysUtils, typinfo, contnrs;
+
+Type
+
+  TObservedHook = Class(TObject,IFPObserved)
+  Protected
+    FObservers : TFPList;
+    FSender : TObject;
+  Public
+    // ASender will be the default sender.
+    Constructor CreateSender(ASender : TObject);
+    Destructor Destroy; override;
+    Procedure FPOAttachObserver(AObserver : TObject);
+    Procedure FPODetachObserver(AObserver : TObject);
+    Procedure Changed;
+    Procedure AddItem(AItem : TObject);
+    Procedure DeleteItem(AItem : TObject);
+    Procedure CustomNotify(Data : Pointer = Nil);
+    Procedure FPONotifyObservers(ASender : TObject; AOperation : TFPObservedOperation; Data : Pointer);
+    Property Sender : TObject Read FSender;
+  end;
+
+//  EObserver = Class(Exception);
+
+
+  { TBaseMediator }
+
+  TMediatingEvent = Procedure(Sender : TObject; var Handled : Boolean) of object;
+
+  TBaseMediator = Class(TComponent,IFPObserver)
+  private
+    FActive: Boolean;
+    FOnObjectToView: TMediatingEvent;
+    FOnViewToObject: TMediatingEvent;
+    FReadOnly: Boolean;
+    FTransferring : Boolean;
+    FSubjectPropertyName: String;
+    FSubject: TObject;
+    FValueList: TObjectList;
+    FViewPropertyName: String;
+    procedure SetReadOnly(const AValue: Boolean);
+    procedure SetValueList(const AValue: TObjectList);
+    procedure SetViewPropertyName(const AValue: String); Virtual;
+  Protected
+    // Should return true (Default) if ViewPropertyName is published
+    Class Function PublishedViewProperty : Boolean; virtual;
+    // Should return true (Default) if SubjectPropertyName is published
+    Class Function PublishedSubjectProperty : Boolean; virtual;
+    // Set active. Descendents (such as list mediators) can override this.
+    procedure SetActive(const AValue: Boolean); virtual;
+    // set subject. Attaches observer and calls MaybeObjectToView
+    procedure SetSubject(const AValue: TObject); virtual;
+    // set subjectpropertyname. Checks if it exists, and calls MaybeObjectToView
+    procedure SetSubjectPropertyName(const AValue: String); virtual;
+    // Can be used in descendents to respond to onchange events
+    Procedure ViewChangedHandler(Sender : TObject);  virtual;
+    // Check if APropertyName is published property of AObject.
+    // Only performed if both parameters are not empty.
+    procedure CheckPropertyName(AObject: TObject; APropertyName: String);
+    // If all CheckObjectSubject and Active are true, call ObjectToView.
+    Procedure MaybeObjectToView;
+    // If all CheckObjectSubject and Active are true, call ViewToObject.
+    Procedure MaybeViewToObject;
+    // Check if Subject/View and property names are set up correctly.
+    Function  CheckViewSubject : Boolean;
+    // Override  next two for custom behaviour.
+    // Copies Subject.SubjectPropertyName to View.ViewPropertyName.
+    Procedure DoObjectToView; virtual;
+    // Copies View.ViewPropertyName to Subject.SubjectPropertyName
+    Procedure DoViewToObject; virtual;
+    // Override these, and call inherited at the end.
+    // Get View component. Typically a TCustomEdit instance.
+    function  GetView : TObject; virtual;
+    // Descendents should call this when the view changed.
+    procedure ViewChanged; virtual;
+    // Descendents should override this to handle changes in the value list
+    procedure ValuelistChanged; virtual;
+    // IFPObserver. Will call the necessary events.
+    Procedure FPOObservedChanged(ASender : TObject; Operation : TFPObservedOperation; Data : Pointer);
+    // Raise an error which shows more information about the control, subject and fieldname.
+    Procedure RaiseMediatorError(Const Msg : String); overload;
+    // Format version
+    Procedure RaiseMediatorError(Const Fmt : String; Args : Array of const); overload;
+    // View property that will be set by default
+    Property ViewPropertyName : String Read FViewPropertyName Write SetViewPropertyName;
+    // Is a copy operation View <-> Subject in progress ?
+    Property Transferring : Boolean Read FTransferring;
+  Public
+    Destructor Destroy; override;
+    // Copy subject to view. No check is done to see if all is well.
+    Procedure ObjectToView;
+    // Copy view to subject. No check is done to see if all is well.
+    Procedure ViewToObject;
+    // Minimum class that View must have to be handled by this mediator.
+    class function ViewClass: TClass; virtual;
+    // Composite mediator or not ?
+    class function CompositeMediator : Boolean; virtual;
+    // Subject. Must have IFPObserved interface
+    Property Subject : TObject Read FSubject Write SetSubject;
+    // View. Must have ViewPropertyName, if in use.
+    Property View : TObject Read GetView;
+    // Value list. To be used in mediators that use a dynamical value list
+    // such as Listbox, combobox, groupbox.
+    Property Valuelist : TObjectList Read FValueList Write SetValueList;
+  Published
+    // Property that will be copied to view.
+    Property SubjectPropertyName : String Read FSubjectPropertyName Write SetSubjectPropertyName;
+    // If not active, no copying is being done either way.
+    Property Active : Boolean Read FActive Write SetActive;
+    // If ReadOnly, only ObjectToView is used
+    Property ReadOnly : Boolean Read FReadOnly Write SetReadOnly;
+    // Can be used to copy data from control (view) to subject manually
+    Property OnViewToObject : TMediatingEvent Read FOnViewToObject Write FOnViewToObject;
+    // Can be used to copy data from control (view) to subject manually
+    Property OnObjectToView : TMediatingEvent Read FOnObjectToView Write FOnObjectToView;
+  end;
+  TMediatorClass = Class of TBaseMediator;
+
+  // Forward definitions
+  TBaseListMediator = Class;
+
+  { TComponentMediator }
+  { General-purpose of Mediating views. Can be used on any form/component }
+
+  TComponentMediator = Class(TBaseMediator)
+    FViewComponent : TComponent;
+  Protected
+    function  GetView : TObject; override;
+    procedure SetComponent(const AValue: TComponent);
+  Public
+    procedure Notification(AComponent: TComponent;  Operation: TOperation); override;
+    Procedure ViewChangedHandler(Sender : TObject); override;
+  Published
+    // General component which can be set in Object Inspector
+    Property ViewComponent : TComponent Read FViewComponent Write SetComponent;
+    // Punlish property so it can be set in Object Inspector
+    Property ViewPropertyName;
+  end;
+
+  { Event object used for OnBeforeSetupField event. Is used to allow formatting
+    of fields before written to listview Caption or Items. }
+  TOnBeforeSetupField = procedure(AObject: TObject; const AFieldName: string; var AValue: string) of object;
+
+  { TListItemMediator }
+
+  TListItemMediator = class(TObject, IFPObserver)
+  private
+    FSubject: TObject;
+    FOnBeforeSetupField: TOnBeforeSetupField;
+    FListMediator : TBaseListMediator;
+    Function GetActive : Boolean;
+  protected
+    procedure SetSubject(const AValue: TObject); virtual;
+    Procedure FPOObservedChanged(ASender : TObject; Operation : TFPObservedOperation; Data : Pointer); virtual;
+    Procedure ObjectToView; virtual;
+    Procedure ViewToObject; virtual;
+  public
+    destructor Destroy; override;
+    procedure MaybeObjectToView;
+    property OnBeforeSetupField: TOnBeforeSetupField read FOnBeforeSetupField write FOnBeforeSetupField;
+    property Subject : TObject read FSubject write SetSubject;
+    property Active : Boolean read GetActive;
+  end;
+
+  { TBaseListMediator - Base mediator that handles lists of objects.
+
+    Needs a TList as subject. Items in list must have IFPObserved
+    interface. It will create one (and use as subject) if passed a normal
+    list or a collection.
+  }
+
+  TBaseListMediator = class(TBaseMediator)
+  private
+    FOnBeforeSetupField: TOnBeforeSetupField;
+    FMediatorList: TFPObjectList;
+    FListChanged : Boolean;
+    procedure SetOnBeforeSetupField(const Value: TOnBeforeSetupField);
+  protected
+    // This needs to return false
+    Class Function PublishedViewProperty : Boolean; override;
+    // Descendents can override;
+    Function AddObject(AObject: TObject; AIndex: Integer) : TListItemMediator; virtual;
+    // Set all descendents to active
+    procedure SetActive(const AValue: Boolean); override;
+    // Must be overridden in descendents, and should return selected object
+    function GetSelectedObject: TObject; virtual;
+    // Must be overridden in descendents, and should set selected object
+    procedure SetSelectedObject(const AValue: TObject); virtual;
+    // Must be overridden in descendents to create an item mediator and add it to GUI control
+    // Subject will be set after this call.
+    Function CreateItemMediator(AData: TObject; ARow : integer) : TListItemMediator; virtual; abstract;
+    // This frees the mediator. Descendents can override to additionally update the GUI control
+    procedure DoDeleteItemMediator(AIndex : Integer; AMediator : TListItemMediator); virtual;
+    // Creates a mediator for all items in the list. List Item Mediators are re-used (subject is set)
+    procedure CreateSubMediators; virtual;
+    // Does nothing
+    procedure DoViewToObject; override;
+    // Calls CreateSubMediators. Override for additional GUI setup.
+    procedure DoObjectToView; override;
+    // Additional checks on subject.
+    procedure SetSubject(const AValue: TObject); override;
+
+    Function FindObjectMediator(AObject : TObject; out AtIndex : Integer) : TListItemMediator;
+    property MediatorList: TFPObjectList read FMediatorList;
+  public
+    constructor Create(AOwner : TComponent); override;
+    destructor Destroy; override;
+    class function CompositeMediator: Boolean; override;
+    // This should handle additional additem/deleteitem events
+    Procedure ObservedChanged(ASender : TObject; Operation : TFPObservedOperation);
+    // Selected item in the list.
+    property SelectedObject: TObject read GetSelectedObject write SetSelectedObject;
+  published
+    // Event to setup fields in item mediators.
+    property OnBeforeSetupField: TOnBeforeSetupField read FOnBeforeSetupField write SetOnBeforeSetupField;
+  end;
+
+  { TMediatorFieldInfo - Describe a column in a columnar list display }
+
+  TMediatorFieldInfo = class(TCollectionItem)
+  private
+    FWidth: integer;
+    FCaption: string;
+    FPropName: string;
+    FAlign: TAlignment;
+    function GetCaption: string;
+    procedure SetAlign(const AValue: TAlignment);
+    procedure SetCaption(const AValue: string);
+    procedure SetPropName(const AValue: string);
+    procedure SetWidth(const AValue: Integer);
+  protected
+    function GetAsString: string; virtual;
+    procedure SetAsString(const AValue: string); virtual;
+    Procedure Change;
+  public
+    procedure Assign(Source: TPersistent); override;
+    // Setting this will parse everything.
+    property AsString: string read GetAsString write SetAsString;
+  published
+    // Property Caption to be used for column head.
+    property Caption: string read GetCaption write SetCaption;
+    // Property Name to be displayed in column
+    property PropertyName: string read FPropName write SetPropName;
+    // Width of column
+    property Width: Integer read FWidth write SetWidth;
+    // Alignment of column
+    property Alignment: TAlignment read FAlign write SetAlign default taLeftJustify;
+  end;
+
+  TColumnsListMediator = Class;
+
+  { TMediatorFieldInfoList - Collection describing the columns in a columnar list display }
+
+  TMediatorFieldInfoList = class(TCollection)
+  private
+    FMediator : TColumnsListMediator;
+    function GetAsString: string;
+    function GetI(Index: integer): TMediatorFieldInfo;
+    procedure SetI(Index: integer; const AValue: TMediatorFieldInfo);
+  protected
+    procedure Notify(Item: TCollectionItem;Action: TCollectionNotification); override;
+    Property Mediator : TColumnsListMediator read FMediator;
+  public
+    // Adding items to the collection.
+    function AddFieldInfo: TMediatorFieldInfo; overload;
+    function AddFieldInfo (Const APropName : String; AFieldWidth : Integer) : TMediatorFieldInfo; overload;
+    function AddFieldInfo (Const APropName,ACaption : String; AFieldWidth : Integer) : TMediatorFieldInfo; overload;
+    function AddFieldInfo (Const APropName,ACaption : String; AFieldWidth : Integer; AAlignment : TAlignment) : TMediatorFieldInfo; overload;
+    property FieldInfo[Index: integer]: TMediatorFieldInfo read GetI write SetI; default;
+    property AsString: string read GetAsString;
+  end;
+
+  { TColumnsListItemMediator - List item mediator that can handle multiple columns }
+
+  TColumnsListItemMediator = class(TListItemMediator)
+  Private
+    Function GetFieldsInfo: TMediatorFieldInfoList;
+  Published
+    property FieldsInfo: TMediatorFieldInfoList read GetFieldsInfo;
+  end;
+
+  { TColumnsListMediator - List mediator that handles multiple columns }
+
+  TColumnsListMediator = class(TBaseListMediator)
+  Private
+    FFieldsInfo: TMediatorFieldInfoList;
+    procedure SetFieldsInfo(const AValue: TMediatorFieldInfoList);
+    function GetDisplayNames: string;
+    procedure SetDisplayNames(const AValue: string);
+    procedure FieldInfoChanged(Item: TMediatorFieldInfo; Action: TCollectionNotification); virtual;
+  Protected
+    Class Function PublishedSubjectProperty : Boolean; override;
+    procedure ParseDisplayNames(const AValue: string);
+    // Called by DoViewToObject prior to creating item mediators
+    procedure CreateColumns; virtual;
+    // Calls CreateColumns and CreateSubMediators. Override for additional GUI setup.
+    procedure DoObjectToView; override;
+  Public
+    Constructor Create(AOwner: TComponent); override;
+    Destructor Destroy; override;
+    // Can be used to set the column properties in 1 statement.
+    property DisplayNames: string read GetDisplayNames write SetDisplayNames;
+  Published
+    // How to display the columns in the list.
+    property FieldsInfo: TMediatorFieldInfoList read FFieldsInfo write SetFieldsInfo;
+  end;
+
+  { TMediatorDef - Mediator Definition Storage for MediatorManager }
+
+  TMediatorDef = class(TCollectionItem)
+  private
+    FMC: TMediatorClass;
+    FMSC: TClass;
+    FPN: string;
+    FPT: TTypeKinds;
+  public
+    // Return True if this definition handles the Subject,Gui,APropinfo trio
+    function Handles(ASubject: TObject; AGui: TComponent; APropInfo: PPropInfo): Boolean;
+    // Return True if this definition matches 'closer' than M.
+    // Note that both current and M must have Handles() returned true for this to be useful.
+    function BetterMatch(M: TMediatorDef): Boolean;
+    // Definition
+    property MediatorClass: TMediatorClass read FMC write FMC;
+    property MinSubjectClass: TClass read FMSC write FMSC;
+    property PropertyTypes: TTypeKinds read FPT write FPT;
+    property PropertyName: string read FPN write FPN;
+  end;
+
+
+  TMediatorDefs = class(TCollection)
+  private
+    function GetDef(Index: integer): TMediatorDef;
+    procedure SetDef(Index: integer; const AValue: TMediatorDef);
+  public
+    function AddDef: TMediatorDef;
+    property Defs[Index: integer]: TMediatorDef read GetDef write SetDef; default;
+  end;
+
+
+  TMediatorManager = class(TObject)
+  private
+    FDefs: TMediatorDefs;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    // If APropName is empty or APropInfo is Nil, a composite mediator will be searched.
+    function FindDefFor(ASubject: TObject; AGui: TComponent): TMediatorDef; overload;
+    function FindDefFor(ASubject: TObject; AGui: TComponent; APropName: string): TMediatorDef; overload;
+    function FindDefFor(ASubject: TObject; AGui: TComponent; APropInfo: PPropInfo): TMediatorDef; overload;
+    function RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass): TMediatorDef; overload;
+    function RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass; PropertyName: string): TMediatorDef; overload;
+    function RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass; PropertyTypes: TTypeKinds): TMediatorDef; overload;
+    property Defs: TMediatorDefs read FDefs;
+  end;
+
+  EMediator = class(Exception);
+
+function MediatorManager: TMediatorManager;
+Procedure MediatorError(Sender : TObject; Const Msg : String); overload;
+Procedure MediatorError(Sender : TObject; Fmt : String; Args : Array of const); overload;
+
+implementation
+
+
+Resourcestring
+  SErrNotObserver = 'Instance of class %s is not an observer.';
+  SErrInvalidPropertyName = '%s is not a valid published property of class %s';
+  SErrObjectCannotBeObserved = 'Cannot observe an instance of class %d';
+  sErrInvalidFieldName      = 'No fieldname specified for column %d';
+  sErrInvalidAlignmentChar  = 'Invalid alignment character "%s" specified for column %d';
+  sErrInvalidWidthSpecifier = 'Invalid with "%s" specified for column %d';
+  sErrNotListObject         = '%s is not a TObjectList';
+  sErrCompositeNeedsList    = '%s needs a TObjectList class but is registered with %s';
+  SErrActive                = 'Operation not allowed while the mediator is active';
+  SErrNoGuiFieldName        = 'no gui fieldname set';
+  SErrNoSubjectFieldName    = 'no subject fieldname set';
+
+{ ---------------------------------------------------------------------
+  Mediator global routines
+  ---------------------------------------------------------------------}
+
+Procedure MediatorError(Sender : TObject; Const Msg : String); overload;
+
+Var
+  M : TBaseMediator;
+  C : TComponent;
+  V,S : TObject;
+  CN,SN,Err : String;
+
+begin
+  if (Sender=Nil) then
+    Err:=Msg
+  else If Sender is TBaseMediator then
+    begin
+    M:=Sender as TBaseMediator;
+    V:=M.View;
+    S:=M.Subject;
+    CN:='';
+    If Assigned(V) then
+      begin
+      if (V is TComponent) then
+        begin
+        C:=TComponent(V);
+        CN:=C.Name;
+        end;
+      If (CN='') then
+        CN:=C.ClassName+' instance';
+      end
+    else
+      CN:='Nil';
+    If Assigned(S) then
+      SN:=S.ClassName
+    else
+      SN:='Nil';
+    Err:=Format('Mediator %s (%s,%s,%s) : %s',[M.ClassName,SN,CN,M.SubjectPropertyName,Msg]);
+    end
+  else if (Sender is TComponent) and (TComponent(Sender).Name<>'') then
+    Err:=Format('%s : %s',[TComponent(Sender).Name,Msg])
+  else
+    Err:=Format('%s : %s',[Sender.ClassName,Msg]);
+  Raise EMediator.Create(Err);
+end;
+
+Procedure MediatorError(Sender : TObject; Fmt : String; Args : Array of const); overload;
+
+begin
+  MediatorError(Sender,Format(Fmt,Args));
+end;
+
+Var
+  MM : TMediatorManager;
+
+function MediatorManager: TMediatorManager;
+begin
+  if (MM = nil) then
+    MM := TMediatorManager.Create;
+  Result := MM;
+end;
+
+{ TObservedHook }
+
+constructor TObservedHook.CreateSender(ASender: TObject);
+begin
+  FSender:=ASender;
+  If FSender=Nil then
+    FSender:=Self;
+end;
+
+destructor TObservedHook.Destroy;
+begin
+  If Assigned(FObservers) then
+    begin
+    FPONotifyObservers(FSender,ooFree,Nil);
+    FreeAndNil(FObservers);
+    end;
+  inherited Destroy;
+end;
+
+procedure TObservedHook.FPOAttachObserver(AObserver: TObject);
+
+Var
+  I : IFPObserver;
+
+begin
+  If Not AObserver.GetInterface(SGUIDObserver,I) then
+    Raise EObserver.CreateFmt(SErrNotObserver,[AObserver.ClassName]);
+  If not Assigned(FObservers) then
+    FObservers:=TFPList.Create;
+  FObservers.Add(AObserver);
+end;
+
+procedure TObservedHook.FPODetachObserver(AObserver: TObject);
+
+Var
+  I : IFPObserver;
+
+begin
+  If Not AObserver.GetInterface(SGUIDObserver,I) then
+    Raise EObserver.CreateFmt(SErrNotObserver,[AObserver.ClassName]);
+  If Assigned(FObservers) then
+    begin
+    FObservers.Remove(AObserver);
+    If (FObservers.Count=0) then
+      FreeAndNil(FObservers);
+    end;
+end;
+
+procedure TObservedHook.Changed;
+begin
+  FPONotifyObservers(Sender,ooChange,Nil)
+end;
+
+procedure TObservedHook.AddItem(AItem: TObject);
+begin
+  FPONotifyObservers(FSender,ooAddItem,AItem);
+end;
+
+procedure TObservedHook.DeleteItem(AItem: TObject);
+begin
+  FPONotifyObservers(FSender,ooDeleteItem,AItem);
+end;
+
+procedure TObservedHook.CustomNotify(Data : Pointer = Nil);
+begin
+  FPONotifyObservers(FSender,ooCustom,Data);
+end;
+
+procedure TObservedHook.FPONotifyObservers(ASender: TObject;  AOperation: TFPObservedOperation; Data : Pointer);
+
+Var
+  O : TObject;
+  I : Integer;
+  Obs : IFPObserver;
+
+begin
+  If Assigned(FObservers) then
+    For I:=FObservers.Count-1 downto 0 do
+      begin
+      O:=TObject(FObservers[i]);
+      If O.GetInterface(SGUIDObserver,Obs) then
+        Obs.FPOObservedChanged(ASender,AOperation,Data);
+      end;
+end;
+
+{ TBaseMediator }
+
+function TBaseMediator.GetView: TObject;
+begin
+  Result:=Nil;
+end;
+
+procedure TBaseMediator.ViewChanged;
+begin
+  If PublishedViewProperty then
+    CheckPropertyName(View,ViewPropertyName);
+  MaybeObjectToView
+end;
+
+procedure TBaseMediator.ValuelistChanged;
+begin
+  // Do nothing
+end;
+
+procedure TBaseMediator.SetActive(const AValue: Boolean);
+begin
+  if FActive=AValue then exit;
+  FActive:=AValue;
+  MaybeObjectToView;
+end;
+
+procedure TBaseMediator.SetReadOnly(const AValue: Boolean);
+begin
+  if FReadOnly=AValue then exit;
+  FReadOnly:=AValue;
+  MaybeObjectToView;
+end;
+
+procedure TBaseMediator.SetValueList(const AValue: TObjectList);
+
+Var
+  I : IFPObserved;
+
+begin
+  if FValueList=AValue then exit;
+  If FValueList<>Nil then
+      I.FPODetachObserver(Self);
+  If Assigned(AValue) then
+    begin
+    FValueList:=AValue;
+    If Assigned(AValue) then
+      AValue.FPOAttachObserver(Self);
+    end;
+  FValueList:=AValue;
+  ValueListChanged;
+end;
+
+procedure TBaseMediator.CheckPropertyName(AObject : TObject; APropertyName : String);
+
+begin
+  If Assigned(AObject) and (APropertyName<>'') then
+    If Not IsPublishedProp(AObject,APropertyName) then
+      Raise EObserver.CreateFmt(SErrInvalidPropertyName,[APropertyName,AObject.ClassName]);
+end;
+
+procedure TBaseMediator.MaybeObjectToView;
+begin
+  If FActive and CheckViewSubject then
+    ObjectToView
+end;
+
+procedure TBaseMediator.MaybeViewToObject;
+begin
+  If FActive and (Not ReadOnly) and CheckViewSubject then
+    ViewToObject;
+end;
+
+function TBaseMediator.CheckViewSubject: Boolean;
+
+Var
+  O : TObject;
+
+begin
+  O:=GetView;
+  Result:=Assigned(FSubject)
+          and Assigned(O)
+          and (ViewPropertyName<>'')
+          and (SubjectPropertyName<>'');
+end;
+
+procedure TBaseMediator.SetSubjectPropertyName(const AValue: String);
+
+begin
+  if FSubjectPropertyName=AValue then exit;
+  If PublishedSubjectProperty then
+    CheckPropertyName(FSubject,AValue);
+  FSubjectPropertyName:=AValue;
+  MaybeObjectToView;
+end;
+
+
+procedure TBaseMediator.SetSubject(const AValue: TObject);
+
+Var
+  I : IFPObserved;
+
+begin
+  if FSubject=AValue then exit;
+  If PublishedSubjectProperty then
+    CheckPropertyName(AValue,FSubjectPropertyName);
+  If FSubject<>Nil then
+    If FSubject.GetInterface(SGUIDObserved,I) then
+      I.FPODetachObserver(Self);
+  If (AValue<>Nil) then
+    begin
+    If not AValue.GetInterface(SGUIDObserved,I) then
+      Raise EObserver.CreateFmt(SErrObjectCannotBeObserved,[AValue.ClassName]);
+    FSubject:=AValue;
+    I.FPOAttachObserver(Self);
+    end
+  else
+    FSubject:=AValue;
+  MaybeObjectToView;
+end;
+
+procedure TBaseMediator.SetViewPropertyName(const AValue: String);
+begin
+  if FViewPropertyName=AValue then exit;
+  If PublishedViewProperty then
+    CheckPropertyName(GetView,AValue);
+  FViewPropertyName:=AValue;
+  MaybeObjectToView;
+end;
+
+class function TBaseMediator.PublishedViewProperty: Boolean;
+begin
+  Result:=True;
+end;
+
+class function TBaseMediator.PublishedSubjectProperty: Boolean;
+begin
+  Result:=True;
+end;
+
+procedure TBaseMediator.ViewChangedHandler(Sender: TObject);
+begin
+  MaybeViewToObject;
+end;
+
+
+procedure TBaseMediator.FPOObservedChanged(ASender: TObject;
+  Operation: TFPObservedOperation; Data : Pointer);
+
+
+begin
+  If (ASender=FSubject) then
+    begin
+    If Operation=ooChange then
+      MaybeObjectToView
+    else if Operation=ooFree then
+      FSubject:=Nil;
+    end
+  else if (ASender=FValueList) then
+    begin
+    If Operation=ooChange then
+      ValueListChanged
+    else if Operation=ooFree then
+      FValueList:=Nil;
+    end;
+end;
+
+procedure TBaseMediator.RaiseMediatorError(const Msg: String);
+begin
+  MediatorError(Self,Msg);
+end;
+
+procedure TBaseMediator.RaiseMediatorError(const Fmt: String;
+  Args: array of const);
+begin
+  RaiseMediatorError(Format(FMT,Args));
+end;
+
+destructor TBaseMediator.Destroy;
+begin
+  Subject:=Nil;
+  ValueList:=Nil;
+  inherited Destroy;
+end;
+
+procedure TBaseMediator.DoObjectToView;
+
+begin
+  SetPropValue(GetView,ViewPropertyName,GetPropValue(FSubject,FSubjectPropertyName));
+end;
+
+procedure TBaseMediator.DoViewToObject;
+
+begin
+  SetPropValue(FSubject,FSubjectPropertyName,GetPropValue(GetView,ViewPropertyName));
+end;
+
+procedure TBaseMediator.ObjectToView;
+
+Var
+  B : Boolean;
+
+begin
+  If Not FTransferring then
+    begin
+    FTransferring:=True;
+    try
+      B:=False;
+      If Assigned(FOnObjectToView) then
+        FOnObjectToView(Self,B);
+      If not B then
+        DoObjectToView;
+    finally
+      FTransferring:=False;
+    end;
+    end;
+end;
+
+procedure TBaseMediator.ViewToObject;
+
+Var
+  B : Boolean;
+
+begin
+  If Not FTransferring then
+    begin
+    FTransferring:=True;
+    try
+      B:=False;
+      If Assigned(FONViewToObject) then
+        FONViewToObject(Self,B);
+      If not B then
+      DoViewToObject;
+    finally
+      FTransferring:=False;
+    end;
+    end;
+end;
+
+class function TBaseMediator.ViewClass: TClass;
+begin
+  Result:=TObject;
+end;
+
+class function TBaseMediator.CompositeMediator: Boolean;
+begin
+  Result:=False;
+end;
+
+{ TComponentMediator }
+
+function TComponentMediator.GetView: TObject;
+begin
+  Result:=FViewComponent;
+end;
+
+procedure TComponentMediator.SetComponent(const AValue: TComponent);
+begin
+  If (Avalue=FViewComponent) then
+    Exit;
+  If Assigned(FViewComponent) then
+    FViewComponent.RemoveFreeNotification(Self);
+  FViewComponent:=AValue;
+  If Assigned(FViewComponent) then
+    FViewComponent.FreeNotification(Self);
+  ViewChanged;
+end;
+
+procedure TComponentMediator.Notification(AComponent: TComponent;
+  Operation: TOperation);
+begin
+  inherited Notification(AComponent, Operation);
+  If (Operation=opRemove) and (AComponent=FViewComponent) then
+    begin
+    FViewComponent:=Nil;
+    ViewChanged;
+    end;
+end;
+
+procedure TComponentMediator.ViewChangedHandler(Sender: TObject);
+begin
+  inherited ViewChangedHandler(Sender);
+end;
+
+{ TMediatorDef }
+
+function TMediatorDef.Handles(ASubject: TObject; AGui: TComponent; APropInfo: PPropInfo): Boolean;
+var
+  N: string;
+begin
+  if (APropInfo = nil) then
+    Result := FMC.CompositeMediator
+  else
+  begin
+    N      := APropInfo^.Name;
+    Result := True;
+  end;
+  if not Result then
+    Exit; // ==>
+  // At least the classes must match
+  Result := AGui.InheritsFrom(FMC.ViewClass) and ASubject.InheritsFrom(FMSC);
+  if Result and not FMC.CompositeMediator then
+    if (PropertyName <> '') then
+      Result := (CompareText(N, PropertyName) = 0)
+    else // Property kind should match. Note that property MUST be set to something.
+      Result := (APropInfo^.PropType^.Kind in PropertyTypes); // If PropertyName is set, it must match
+end;
+
+function TMediatorDef.BetterMatch(M: TMediatorDef): Boolean;
+begin
+  Result := (M = nil);
+  if not Result then
+  begin
+    Result := (FMC.CompositeMediator = M.MediatorClass.CompositeMediator);
+    if Result then
+    begin
+      Result := (PropertyName <> '') and (M.PropertyName = '');
+      if not Result then
+      begin
+        // M's property matches closer
+        Result := not ((M.PropertyName <> '') and (PropertyName = ''));
+        if Result then
+        begin
+          // Properties are on equal level. Check GUI class.
+          // Closer GUI class ?
+          Result := FMC.ViewClass.InheritsFrom(M.MediatorClass.ViewClass);
+          if not Result then
+          begin
+            // M's GUI class matches closer ?
+            Result := not (M.MediatorClass.ViewClass.InheritsFrom(FMC.ViewClass));
+            if Result then
+            begin
+              // GUI classes are on equal level (different branches in tree). Check subject class.
+              // Closer Subject class ?
+              Result := FMSC.InheritsFrom(M.FMSC);
+              if not Result then
+                // M's subject class matches closer ?
+                Result := not M.FMSC.InheritsFrom(FMSC);
+            end;
+          end;
+        end;
+      end;
+    end;
+  end;
+end;
+
+{ TMediatorDefs }
+
+function TMediatorDefs.GetDef(Index: integer): TMediatorDef;
+begin
+  Result := TMediatorDef(Items[Index]);
+end;
+
+procedure TMediatorDefs.SetDef(Index: integer; const AValue: TMediatorDef);
+begin
+  Items[Index] := AValue;
+end;
+
+function TMediatorDefs.AddDef: TMediatorDef;
+begin
+  Result := Add as TMediatorDef;
+end;
+
+{ TMediatorManager }
+
+constructor TMediatorManager.Create;
+begin
+  FDefs := TMediatorDefs.Create(TMediatorDef);
+end;
+
+destructor TMediatorManager.Destroy;
+begin
+  FreeAndNil(FDefs);
+  inherited Destroy;
+end;
+
+function TMediatorManager.FindDefFor(ASubject: TObject; AGui: TComponent): TMediatorDef;
+begin
+  Result := FindDefFor(ASubject, AGUI, PPropInfo(nil));
+end;
+
+function TMediatorManager.FindDefFor(ASubject: TObject; AGui: TComponent; APropName: string): TMediatorDef;
+var
+  propinfo: PPropInfo;
+begin
+  propinfo := GetPropInfo(ASubject, APropName);
+  Result := FindDefFor(ASubject, AGUI, propinfo);
+end;
+
+function TMediatorManager.FindDefFor(ASubject: TObject; AGui: TComponent; APropInfo: PPropInfo): TMediatorDef;
+var
+  D: TMediatorDef;
+  I: integer;
+begin
+  Result := nil;
+  for I := 0 to FDefs.Count - 1 do
+  begin
+    D := FDefs[I];
+    if D.Handles(ASubject, AGUI, APropInfo) then
+      if (D.BetterMatch(Result)) then
+        Result := D;
+  end;
+end;
+
+function TMediatorManager.RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass): TMediatorDef;
+
+begin
+  Result      := FDefs.AddDef;
+  Result.MediatorClass := MediatorClass;
+  Result.FMSC := MinSubjectClass;
+  Result.FPN  := '';
+  Result.FPT  := tkProperties - [tkClass, tkInterface, tkDynArray, tkObject, tkInterfaceRaw];
+end;
+
+function TMediatorManager.RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass; PropertyName: string): TMediatorDef;
+
+begin
+  Result      := FDefs.AddDef;
+  Result.MediatorClass := MediatorClass;
+  Result.FMSC := MinSubjectClass;
+  Result.FPN  := PropertyName;
+  Result.FPT  := [];
+end;
+
+function TMediatorManager.RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass; PropertyTypes: TTypeKinds): TMediatorDef;
+
+begin
+  Result      := FDefs.AddDef;
+  Result.MediatorClass := MediatorClass;
+  Result.FMSC := MinSubjectClass;
+  Result.FPN  := '';
+  Result.FPT  := PropertyTypes;
+end;
+
+{ TListItemMediator }
+
+
+function TListItemMediator.GetActive: Boolean;
+begin
+  Result:=False;
+  If Assigned(FListMediator) then
+    Result:=FListMediator.Active;
+end;
+
+procedure TListItemMediator.SetSubject(const AValue: TObject);
+
+Var
+  I : IFPObserved;
+
+begin
+  if Avalue=FSubject then
+    Exit;
+  If FSubject<>Nil then
+    If FSubject.GetInterface(SGUIDObserved,I) then
+      I.FPODetachObserver(Self);
+  FSubject:=AValue;
+  If (FSubject<>Nil) then
+    begin
+    If not FSubject.GetInterface(SGUIDObserved,I) then
+      Raise EObserver.CreateFmt(SErrObjectCannotBeObserved,[FSubject.ClassName]);
+    I.FPOAttachObserver(Self);
+    end;
+  MaybeObjectToView
+end;
+
+procedure TListItemMediator.FPOObservedChanged(ASender: TObject;
+  Operation: TFPObservedOperation; Data : Pointer);
+begin
+  If Operation=ooFree then
+    FSubject:=Nil
+  else
+    MaybeObjectToView;
+end;
+
+procedure TListItemMediator.ObjectToView;
+begin
+  // Do nothing
+end;
+
+procedure TListItemMediator.ViewToObject;
+begin
+  // Do nothing
+end;
+
+destructor TListItemMediator.Destroy;
+begin
+  Subject:=Nil;
+  inherited Destroy;
+end;
+
+procedure TListItemMediator.MaybeObjectToView;
+begin
+  If Assigned(FSubject) and Active then
+    ObjectToView;
+end;
+
+{ TMediatorFieldInfo }
+
+procedure TMediatorFieldInfo.Change;
+
+begin
+  FPONotifyObservers(Self,ooChange,Nil);
+end;
+
+function TMediatorFieldInfo.GetCaption: string;
+begin
+  Result:=FCaption;
+  If (Result='') then
+    Result:=FPropName;
+end;
+
+procedure TMediatorFieldInfo.SetAlign(const AValue: TAlignment);
+begin
+  If AValue=fAlign then Exit;
+  FAlign:=AValue;
+  Change;
+end;
+
+procedure TMediatorFieldInfo.SetCaption(const AValue: string);
+begin
+  If AValue=Caption then Exit;
+  FCaption:=AValue;
+  Change;
+end;
+
+procedure TMediatorFieldInfo.SetPropName(const AValue: string);
+begin
+  If AValue=FPropName then Exit;
+  FPropName:=AValue;
+  Change;
+end;
+
+procedure TMediatorFieldInfo.SetWidth(const AValue: Integer);
+begin
+  If (FWidth=AValue) then Exit;
+  FWidth:=AValue;
+  Change;
+end;
+
+const
+  AlignChars: array[TAlignMent] of char     = ('l', 'r', 'c');
+
+function TMediatorFieldInfo.GetAsString: string;
+begin
+  Result := Format('%s|%s|%d|%s', [PropertyName, AlignChars[Alignment], Width, Caption]);
+end;
+
+procedure TMediatorFieldInfo.SetAsString(const AValue: string);
+
+  Function GetToken(Var S : String) : String;
+
+  Var
+    P : Integer;
+
+  begin
+    P:=Pos('|',S);
+    If P=0 then P:=Length(S)+1;
+    Result:=Copy(S,1,P-1);
+    Delete(S,1,P);
+  end;
+
+var
+  V,S: string;
+  A: TAlignment;
+  I: integer;
+
+begin
+  V:=S;
+  I := 0;
+  PropertyName:=GetToken(V);
+  if (PropertyName = '') then
+    MediatorError(Self,SErrInvalidFieldName, [Index + 1]);
+  Alignment:=taLeftJustify;
+  Width:=50;
+  S:=GetToken(V);
+  if (S<>'') then
+    begin
+    if (length(S)<>1) then
+      MediatorError(Self,SErrInvalidAlignmentChar, [S,Index+1]);
+    for A := Low(Talignment) to High(TAlignment) do
+      if (Upcase(AlignChars[A])=Upcase(S[1])) then
+        Alignment := A;
+    S:=GetToken(V);
+    if (S<>'') then
+      begin
+      if not TryStrToInt(S,i) then
+        MediatorError(Self,SErrInvalidWidthSpecifier,[S]);
+      Width:=I;
+      S:=getToken(V);
+      if (S<>'') then
+        Caption := S;
+      end;
+    end;
+end;
+
+procedure TMediatorFieldInfo.Assign(Source: TPersistent);
+
+Var
+  M : TMediatorFieldInfo;
+
+begin
+  if (Source is TMediatorFieldInfo) then
+    begin
+    M:=Source as TMediatorFieldInfo;
+    FWidth:=M.FWidth;
+    FCaption:=M.FCaption;
+    FPropName:=M.FPropname;
+    FAlign:=M.FAlign;
+    end
+  else
+    inherited Assign(Source);
+end;
+
+{ TColumnsListItemMediator }
+
+function TColumnsListItemMediator.GetFieldsInfo: TMediatorFieldInfoList;
+begin
+  If Assigned(FListmediator) and (FListMediator is TColumnsListMediator) then
+    Result:=TColumnsListMediator(FListMediator).FFieldsInfo;
+end;
+
+{ TBaseListMediator }
+
+procedure TBaseListMediator.SetOnBeforeSetupField(
+  const Value: TOnBeforeSetupField);
+
+var
+  I: integer;
+begin
+  FOnBeforeSetupField := Value;
+  for I := 0 to FMediatorList.Count - 1 do
+    TListItemMediator(FMediatorList[i]).OnBeforeSetupField := Value;
+end;
+
+class function TBaseListMediator.PublishedViewProperty: Boolean;
+begin
+  Result:=False;
+end;
+
+procedure TBaseListMediator.SetActive(const AValue: Boolean);
+
+Var
+  i : Integer;
+
+begin
+  inherited SetActive(AValue);
+  If AValue then
+    For I:=0 to MediatorList.Count-1 do
+      TListItemMediator(MediatorList[i]).MaybeObjectToView;
+end;
+
+function TBaseListMediator.GetSelectedObject: TObject;
+begin
+  Result := nil;
+end;
+
+procedure TBaseListMediator.SetSelectedObject(const AValue: TObject);
+begin
+  // Do nothing
+end;
+
+procedure TBaseListMediator.DoDeleteItemMediator(AIndex: Integer;
+  AMediator: TListItemMediator);
+begin
+  MediatorList.Delete(AIndex);
+end;
+
+Function TBaseListMediator.AddObject(AObject : TObject; AIndex : Integer) : TListItemMediator;
+
+
+begin
+  Result:=CreateItemMediator(AObject,AIndex);
+  If (Result<>Nil) then
+    begin
+    Result.FListMediator:=Self;
+    Result.Subject:=AObject;
+    MediatorList.Add(Result);
+    end;
+end;
+
+procedure TBaseListMediator.CreateSubMediators;
+
+var
+  I : integer;
+  Model : TObjectList;
+  
+begin
+  Model:=Subject as TObjectList;
+  for i := 0 to Model.Count - 1 do
+    begin
+    if i < MediatorList.Count then
+      TListItemMediator(MediatorList[i]).Subject := Model[i]
+    else
+      AddObject(Model[i], i);
+    end;
+  for i := MediatorList.Count-1 downto Model.Count do
+    DoDeleteItemMediator(I,TListItemMediator(MediatorList[i]));
+  FListChanged:=False;
+end;
+
+procedure TBaseListMediator.DoViewToObject;
+begin
+  // Do nothing
+end;
+
+procedure TBaseListMediator.DoObjectToView;
+begin
+  CreateSubMediators;
+end;
+
+procedure TBaseListMediator.SetSubject(const AValue: TObject);
+
+Var
+  V : TOBject;
+
+begin
+  if (AValue <> nil) then
+    begin
+    V:=Nil;
+    if (AValue is TObjectList) then
+      V:=AValue
+    else If (AValue is TList) then
+      V:=AValue
+    else If (AValue is TCollection) then
+      V:=AValue;
+    if (V=Nil) then
+      RaiseMediatorError(SErrNotListObject, [AValue.ClassName]);
+    end;
+  FListChanged:=True;
+  inherited SetSubject(AValue)
+end;
+
+function TBaseListMediator.FindObjectMediator(AObject: TObject; out
+  AtIndex: Integer): TListItemMediator;
+begin
+  AtIndex:=FMediatorList.Count-1;
+  While (AtIndex>=0) and (TListItemMediator(FMediatorList[AtIndex]).Subject<>AObject) do
+    Dec(AtIndex);
+  If (AtIndex=-1) then
+    Result:=Nil
+  else
+    Result:=TListItemMediator(FMediatorList[AtIndex]);
+end;
+
+constructor TBaseListMediator.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FMediatorList := TFPObjectList.Create;
+  Active        := False;
+  ViewPropertyName:='Caption';
+end;
+
+destructor TBaseListMediator.Destroy;
+begin
+  FreeAndNil(FMediatorList);
+  inherited Destroy;
+end;
+
+class function TBaseListMediator.CompositeMediator: Boolean;
+begin
+  Result:=True;
+end;
+
+procedure TBaseListMediator.ObservedChanged(ASender: TObject;
+  Operation: TFPObservedOperation);
+
+var
+  M     : TListItemMediator;
+  Model : TObjectList;
+  I     : Integer;
+
+begin
+  // Do not call inherited, it will rebuild the list !!
+  Case Operation of
+    ooAddItem    : AddObject(ASender,TObjectList(Subject).Count-1); // always at the end...
+    ooDeleteItem : begin
+                   M:=FindObjectMediator(ASender,I);
+                   if M<>nil then
+                     DoDeleteItemMediator(I,M);
+                   end;
+    ooChange    : begin
+                   Model:=(Subject as TObjectList);
+                   if FListChanged or (TObjectList(Model).Count<>MediatorList.Count) or (Model.Count=0) then // Safety measure
+                     MaybeObjectToView;
+                   end;
+  end;
+
+end;
+
+{ TColumnsListMediator }
+
+procedure TColumnsListMediator.SetFieldsInfo(
+  const AValue: TMediatorFieldInfoList);
+begin
+  FFieldsInfo.Assign(AValue);
+end;
+
+function TColumnsListMediator.GetDisplayNames: string;
+begin
+  Result := FFieldsInfo.AsString;
+end;
+
+procedure TColumnsListMediator.SetDisplayNames(const AValue: string);
+begin
+  SubjectPropertyName:=AValue;
+  ParseDisplayNames(AValue);
+end;
+
+procedure TColumnsListMediator.FieldInfoChanged(Item: TMediatorFieldInfo;
+  Action: TCollectionNotification);
+begin
+  If Active  then
+    RaiseMediatorError(SErrActive);
+end;
+
+class function TColumnsListMediator.PublishedSubjectProperty: Boolean;
+begin
+  Result:=False;
+end;
+
+procedure TColumnsListMediator.ParseDisplayNames(const AValue: string);
+
+  Function GetToken(Var S : String) : String;
+
+  Var
+    P : Integer;
+
+  begin
+    P:=Pos(';',S);
+    If P=0 then P:=Length(S)+1;
+    Result:=Copy(S,1,P-1);
+    Delete(S,1,P);
+  end;
+
+var
+  I : integer;
+  lField : string;
+  MFI : TMediatorFieldInfo;
+  A,S : String;
+
+begin
+  FFieldsInfo.Clear;
+  A:=AValue;
+  Repeat
+    S:=GetToken(A);
+    If (S<>'') then
+      begin
+      MFI:=FFieldsInfo.AddFieldInfo;
+      MFI.AsString:=S;
+      end;
+  until (S='');
+end;
+
+procedure TColumnsListMediator.CreateColumns;
+begin
+  // Do nothing. Must be implemented by descendent objects.
+end;
+
+procedure TColumnsListMediator.DoObjectToView;
+begin
+  CreateColumns;
+  inherited DoObjectToView;
+end;
+
+constructor TColumnsListMediator.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FFieldsInfo:=TMediatorFieldInfoList.create(TMediatorFieldInfo);
+  SubjectPropertyName:='Caption';
+end;
+
+destructor TColumnsListMediator.Destroy;
+begin
+  FreeAndNil(FFieldsInfo);
+  inherited Destroy;
+end;
+
+{ TMediatorFieldInfoList }
+
+function TMediatorFieldInfoList.GetAsString: string;
+
+var
+  I: integer;
+begin
+  Result := '';
+  for I := 0 to Count - 1 do
+  begin
+    if (Result <> '') then
+      Result := Result + ';';
+    Result := Result + FieldInfo[i].AsString;
+  end;
+end;
+
+function TMediatorFieldInfoList.GetI(Index: integer): TMediatorFieldInfo;
+begin
+  Result := TMediatorFieldInfo(Items[Index]);
+end;
+
+procedure TMediatorFieldInfoList.SetI(Index: integer;
+  const AValue: TMediatorFieldInfo);
+
+begin
+  Items[Index] := AValue;
+end;
+
+procedure TMediatorFieldInfoList.Notify(Item: TCollectionItem;
+  Action: TCollectionNotification);
+begin
+  inherited Notify(Item, Action);
+  If Assigned(FMediator) then
+    FMediator.FieldInfoChanged(Item as TMediatorFieldInfo,Action)
+end;
+
+function TMediatorFieldInfoList.AddFieldInfo: TMediatorFieldInfo;
+begin
+  Result := Add as TMediatorFieldInfo;
+end;
+
+function TMediatorFieldInfoList.AddFieldInfo(const APropName: String;
+  AFieldWidth: Integer): TMediatorFieldInfo;
+begin
+  Result:=AddFieldInfo();
+  Result.PropertyName:=APropName;
+  Result.Width:=AFieldWidth;
+end;
+
+function TMediatorFieldInfoList.AddFieldInfo(const APropName, ACaption: String;
+  AFieldWidth: Integer): TMediatorFieldInfo;
+begin
+  Result:=AddFieldInfo(APropName,AFieldWidth);
+  Result.Caption:=ACaption;
+end;
+
+function TMediatorFieldInfoList.AddFieldInfo(const APropName, ACaption: String;
+  AFieldWidth: Integer; AAlignment: TAlignment): TMediatorFieldInfo;
+begin
+  Result:=AddFieldInfo(APropName,ACaption,AFieldWidth);
+  Result.Alignment:=AAlignment;
+end;
+
+end.
+

packages/winunits-base/src/mmsystem.pp

@@ -998,7 +998,7 @@ Type
                             lpData: PChar;
                             dwBufferLength: DWORD;
                             dwBytesRecorded: DWORD;
-                            dwUser: DWORD;
+                            dwUser: DWORD_PTR;
                             dwFlags: DWORD;
                             dwLoops: DWORD;
                             lpNext: PWAVEHDR;
@@ -1242,12 +1242,12 @@ Type
                     lpData: PChar;
                     dwBufferLength: DWORD;
                     dwBytesRecorded: DWORD;
-                    dwUser: DWORD;
+                    dwUser: DWORD_PTR;
                     dwFlags: DWORD;
                     lpNext: PMIDIHDR;
                     reserved: DWORD;
                     dwOffset: DWORD;
-                    dwReserved: array [0..Pred(8)] Of DWORD;
+                    dwReserved: array [0..Pred(8)] Of DWORD_PTR;
 	    End;
  MIDIHDR   = _midihdr;
  NPMIDIHDR = ^_midihdr;
@@ -1379,7 +1379,7 @@ Type
                        dwSource: DWORD;
                        dwLineID: DWORD;
                        fdwLine: DWORD;
-                       dwUser: DWORD;
+                       dwUser: DWORD_PTR;
                        dwComponentType: DWORD;
                        cChannels: DWORD;
                        cConnections: DWORD;
@@ -1404,7 +1404,7 @@ Type
                        dwSource: DWORD;
                        dwLineID: DWORD;
                        fdwLine: DWORD;
-                       dwUser: DWORD;
+                       dwUser: DWORD_PTR;
                        dwComponentType: DWORD;
                        cChannels: DWORD;
                        cConnections: DWORD;

rtl/objpas/classes/classesh.inc

@@ -147,6 +147,51 @@ type
   EInvalidOperation = class(Exception);
   TExceptionClass = Class of Exception;
 
+{ ---------------------------------------------------------------------
+  Free Pascal Observer support
+  ---------------------------------------------------------------------}
+
+
+Const
+  BaseGUIDObserved = '{663C603C-3F3C-4CC5-823C-AC8079F979E5}';
+  BaseGUIDObserver = '{BC7376EA-199C-4C2A-8684-F4805F0691CA}';
+
+  GUIDObserved : TGUID = BaseGUIDObserved;
+  GUIDObserver : TGUID = BaseGUIDObserver;
+
+  // String is needed for testing
+  SGUIDObserver = BaseGUIDObserver;
+  SGUIDObserved = BaseGUIDObserved;
+
+
+
+Type
+  // Notification operations :
+  // Observer has changed, is freed, item added to/deleted from list, custom event.
+  TFPObservedOperation = (ooChange,ooFree,ooAddItem,ooDeleteItem,ooCustom);
+{$INTERFACES CORBA}
+
+  { IFPObserved }
+
+  IFPObserved = Interface [BaseGUIDObserved]
+    // attach a new observer
+    Procedure FPOAttachObserver(AObserver : TObject);
+    // Detach an observer
+    Procedure FPODetachObserver(AObserver : TObject);
+    // Notify all observers of a change.
+    Procedure FPONotifyObservers(ASender : TObject; AOperation : TFPObservedOperation; Data : Pointer);
+  end;
+
+  { IFPObserver }
+
+  IFPObserver = Interface  [BaseGUIDObserver]
+    // Called by observed when observers are notified.
+    Procedure FPOObservedChanged(ASender : TObject; Operation : TFPObservedOperation; Data : Pointer);
+  end;
+{$INTERFACES COM}
+
+  EObserver = Class(Exception);
+
 { Forward class declarations }
 
   TStream = class;
@@ -269,9 +314,10 @@ type
     property Current: Pointer read GetCurrent;
   end;
 
-  TList = class(TObject)
+  TList = class(TObject,IFPObserved)
   private
     FList: TFPList;
+    FObservers : TFPList;
     procedure CopyMove (aList : TList);
     procedure MergeMove (aList : TList);
     procedure DoCopy(ListA, ListB : TList);
@@ -293,6 +339,9 @@ type
   public
     constructor Create;
     destructor Destroy; override;
+    Procedure FPOAttachObserver(AObserver : TObject);
+    Procedure FPODetachObserver(AObserver : TObject);
+    Procedure FPONotifyObservers(ASender : TObject; AOperation : TFPObservedOperation; Data : Pointer);
     Procedure AddList(AList : TList);
     function Add(Item: Pointer): Integer;
     procedure Clear; virtual;
@@ -390,14 +439,19 @@ type
 
 {$M+}
 
-  TPersistent = class(TObject)
+  TPersistent = class(TObject,IFPObserved)
   private
+    FObservers : TFPList;
     procedure AssignError(Source: TPersistent);
   protected
     procedure AssignTo(Dest: TPersistent); virtual;
     procedure DefineProperties(Filer: TFiler); virtual;
     function  GetOwner: TPersistent; dynamic;
+    Procedure FPOAttachObserver(AObserver : TObject);
+    Procedure FPODetachObserver(AObserver : TObject);
+    Procedure FPONotifyObservers(ASender : TObject; AOperation : TFPObservedOperation; Data : Pointer);
   public
+    Destructor Destroy; override;
     procedure Assign(Source: TPersistent); virtual;
     function  GetNamePath: string; virtual; {dynamic;}
   end;
@@ -961,10 +1015,10 @@ type
   private
     Res: TFPResourceHandle;
     Handle: TFPResourceHGLOBAL;
-    procedure Initialize(Instance: THandle; Name, ResType: PWideChar; NameIsID: Boolean);
+    procedure Initialize(Instance: TFPResourceHMODULE; Name, ResType: PWideChar; NameIsID: Boolean);
   public
-    constructor Create(Instance: THandle; const ResName: WideString; ResType: PWideChar);
-    constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PWideChar);
+    constructor Create(Instance: TFPResourceHMODULE; const ResName: WideString; ResType: PWideChar);
+    constructor CreateFromID(Instance: TFPResourceHMODULE; ResID: Integer; ResType: PWideChar);
     destructor Destroy; override;
   end;
 {$else}
@@ -972,10 +1026,10 @@ type
   private
     Res: TFPResourceHandle;
     Handle: TFPResourceHGLOBAL;
-    procedure Initialize(Instance: THandle; Name, ResType: PChar; NameIsID: Boolean);
+    procedure Initialize(Instance: TFPResourceHMODULE; Name, ResType: PChar; NameIsID: Boolean);
   public
-    constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
-    constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
+    constructor Create(Instance: TFPResourceHMODULE; const ResName: string; ResType: PChar);
+    constructor CreateFromID(Instance: TFPResourceHMODULE; ResID: Integer; ResType: PChar);
     destructor Destroy; override;
   end;
 {$endif UNICODE}
@@ -1314,7 +1368,6 @@ type
 {$endif}
     procedure FlushBuffer;
     procedure WriteValue(Value: TValueType);
-    procedure WriteStr(const Value: String);
   public
     constructor Create(Stream: TStream; BufSize: Integer);
     destructor Destroy; override;
@@ -1342,6 +1395,7 @@ type
     procedure WriteUInt64(Value: QWord); override;
     procedure WriteMethodName(const Name: String); override;
     procedure WriteSet(Value: LongInt; SetType: Pointer); override;
+    procedure WriteStr(const Value: String);
     procedure WriteString(const Value: String); override;
     procedure WriteWideString(const Value: WideString); override;
     procedure WriteUnicodeString(const Value: UnicodeString); override;

rtl/objpas/classes/collect.inc

@@ -288,6 +288,7 @@ end;
 
 procedure TCollection.Update(Item: TCollectionItem);
 begin
+  FPONotifyObservers(Self,ooChange,Pointer(Item));
 end;
 
 
@@ -395,6 +396,12 @@ end;
 
 procedure TCollection.Notify(Item: TCollectionItem;Action: TCollectionNotification);
 begin
+  if Assigned(FObservers) then
+    Case Action of
+      cnAdded      : FPONotifyObservers(Self,ooAddItem,Pointer(Item));
+      cnExtracting : FPONotifyObservers(Self,ooDeleteItem,Pointer(Item));
+      cnDeleting   : FPONotifyObservers(Self,ooDeleteItem,Pointer(Item));
+    end;
 end;
 
 procedure TCollection.Sort(Const Compare : TCollectionSortCompare);
@@ -412,6 +419,7 @@ procedure TCollection.Exchange(Const Index1, index2: integer);
 
 begin
   FItems.Exchange(Index1,Index2);
+  FPONotifyObservers(Self,ooChange,Nil);
 end;
 
 

rtl/objpas/classes/lists.inc

@@ -606,6 +606,12 @@ end;
 
 procedure TList.Notify(Ptr: Pointer; Action: TListNotification);
 begin
+   if Assigned(FObservers) then
+     Case ACtion of
+       lnAdded     : FPONotifyObservers(Self,ooAddItem,Ptr);
+       lnExtracted : FPONotifyObservers(Self,ooDeleteItem,Ptr);
+       lnDeleted   : FPONotifyObservers(Self,ooDeleteItem,Ptr);
+     end;
 end;
 
 function TList.GetCapacity: integer;
@@ -642,10 +648,61 @@ destructor TList.Destroy;
 begin
   If (Flist<>Nil) then
     Clear;
+  If Assigned(FObservers) then
+    begin
+    FPONotifyObservers(Self,ooFree,Nil);
+    FreeAndNil(FObservers);
+    end;
   FreeAndNil(FList);
   inherited Destroy;
 end;
 
+procedure TList.FPOAttachObserver(AObserver: TObject);
+
+Var
+   I : IFPObserver;
+
+begin
+  If Not AObserver.GetInterface(SGUIDObserver,I) then
+    Raise EObserver.CreateFmt(SErrNotObserver,[AObserver.ClassName]);
+  If not Assigned(FObservers) then
+    FObservers:=TFPList.Create;
+  FObservers.Add(AObserver);
+end;
+
+procedure TList.FPODetachObserver(AObserver: TObject);
+Var
+  I : IFPObserver;
+
+begin
+  If Not AObserver.GetInterface(SGUIDObserver,I) then
+    Raise EObserver.CreateFmt(SErrNotObserver,[AObserver.ClassName]);
+  If Assigned(FObservers) then
+    begin
+    FObservers.Remove(AObserver);
+    If (FObservers.Count=0) then
+      FreeAndNil(FObservers);
+    end;
+end;
+
+procedure TList.FPONotifyObservers(ASender: TObject;
+  AOperation: TFPObservedOperation; Data : Pointer);
+
+Var
+  O : TObject;
+  I : Integer;
+  Obs : IFPObserver;
+
+begin
+  If Assigned(FObservers) then
+    For I:=FObservers.Count-1 downto 0 do
+      begin
+      O:=TObject(FObservers[i]);
+      If O.GetInterface(SGUIDObserver,Obs) then
+        Obs.FPOObservedChanged(Self,AOperation,Data);
+      end;
+end;
+
 function TList.Add(Item: Pointer): Integer;
 begin
   Result := FList.Add(Item);
@@ -664,7 +721,7 @@ begin
   for I := 0 to AList.Count - 1 do
     if AList[I] <> nil then
       Notify(AList[I], lnAdded);
-end;            
+end;
 
 procedure TList.Clear;
 
@@ -681,7 +738,8 @@ var P : pointer;
 begin
   P:=FList.Get(Index);
   FList.Delete(Index);
-  if assigned(p) then Notify(p, lnDeleted);
+  if assigned(p) then
+    Notify(p, lnDeleted);
 end;
 
 class procedure TList.Error(const Msg: string; Data: PtrInt);
@@ -692,6 +750,7 @@ end;
 procedure TList.Exchange(Index1, Index2: Integer);
 begin
   FList.Exchange(Index1, Index2);
+  FPONotifyObservers(Self,ooChange,Nil);
 end;
 
 function TList.Expand: TList;

rtl/objpas/classes/persist.inc

@@ -49,6 +49,60 @@ begin
   Result:=Nil;
 end;
 
+destructor TPersistent.Destroy;
+begin
+  If Assigned(FObservers) then
+    begin
+    FPONotifyObservers(Self,ooFree,Nil);
+    FreeAndNil(FObservers);
+    end;
+  inherited Destroy;
+end;
+
+procedure TPersistent.FPOAttachObserver(AObserver: TObject);
+Var
+   I : IFPObserver;
+
+begin
+   If Not AObserver.GetInterface(SGUIDObserver,I) then
+     Raise EObserver.CreateFmt(SErrNotObserver,[AObserver.ClassName]);
+   If not Assigned(FObservers) then
+     FObservers:=TFPList.Create;
+   FObservers.Add(AObserver);
+end;
+
+procedure TPersistent.FPODetachObserver(AObserver: TObject);
+Var
+  I : IFPObserver;
+
+begin
+  If Not AObserver.GetInterface(SGUIDObserver,I) then
+    Raise EObserver.CreateFmt(SErrNotObserver,[AObserver.ClassName]);
+  If Assigned(FObservers) then
+    begin
+    FObservers.Remove(AObserver);
+    If (FObservers.Count=0) then
+      FreeAndNil(FObservers);
+    end;
+end;
+
+procedure TPersistent.FPONotifyObservers(ASender: TObject;
+  AOperation: TFPObservedOperation; Data : Pointer);
+Var
+  O : TObject;
+  I : Integer;
+  Obs : IFPObserver;
+
+begin
+  If Assigned(FObservers) then
+    For I:=FObservers.Count-1 downto 0 do
+      begin
+      O:=TObject(FObservers[i]);
+      If O.GetInterface(SGUIDObserver,Obs) then
+        Obs.FPOObservedChanged(Self,AOperation,Data);
+      end;
+end;
+
 procedure TPersistent.Assign(Source: TPersistent);
 
 begin

rtl/objpas/classes/streams.inc

@@ -872,7 +872,7 @@ end;
 {****************************************************************************}
 
 {$ifdef UNICODE}
-procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PWideChar; NameIsID: Boolean);
+procedure TResourceStream.Initialize(Instance: TFPResourceHMODULE; Name, ResType: PWideChar; NameIsID: Boolean);
   begin
     Res:=FindResource(Instance, Name, ResType);
     if Res=0 then
@@ -889,19 +889,19 @@ procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PWideChar
     SetPointer(LockResource(Handle),SizeOfResource(Instance,Res));
   end;
 
-constructor TResourceStream.Create(Instance: THandle; const ResName: WideString; ResType: PWideChar);
+constructor TResourceStream.Create(Instance: TFPResourceHMODULE; const ResName: WideString; ResType: PWideChar);
   begin
     inherited create;
     Initialize(Instance,PWideChar(ResName),ResType,False);
   end;
-constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer; ResType: PWideChar);
+constructor TResourceStream.CreateFromID(Instance: TFPResourceHMODULE; ResID: Integer; ResType: PWideChar);
   begin
     inherited create;
     Initialize(Instance,PWideChar(ResID),ResType,True);
   end;
 {$else UNICODE}
 
-procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar; NameIsID: Boolean);
+procedure TResourceStream.Initialize(Instance: TFPResourceHMODULE; Name, ResType: PChar; NameIsID: Boolean);
   begin
     Res:=FindResource(Instance, Name, ResType);
     if Res=0 then
@@ -918,12 +918,12 @@ procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar; Na
     SetPointer(LockResource(Handle),SizeOfResource(Instance,Res));
   end;
 
-constructor TResourceStream.Create(Instance: THandle; const ResName: string; ResType: PChar);
+constructor TResourceStream.Create(Instance: TFPResourceHMODULE; const ResName: string; ResType: PChar);
   begin
     inherited create;
     Initialize(Instance,pchar(ResName),ResType,False);
   end;
-constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
+constructor TResourceStream.CreateFromID(Instance: TFPResourceHMODULE; ResID: Integer; ResType: PChar);
   begin
     inherited create;
     Initialize(Instance,pchar(PtrInt(ResID)),ResType,True);

rtl/objpas/classes/stringl.inc

@@ -551,6 +551,7 @@ end;
 Procedure TStrings.SetUpdateState(Updating: Boolean);
 
 begin
+  FPONotifyObservers(Self,ooChange,Nil);
 end;
 
 
@@ -1030,8 +1031,11 @@ Procedure TStringList.Changed;
 
 begin
   If (FUpdateCount=0) Then
+   begin
    If Assigned(FOnChange) then
      FOnchange(Self);
+   FPONotifyObservers(Self,ooChange,Nil);
+   end;
 end;
 
 

rtl/objpas/rtlconst.inc

@@ -114,6 +114,7 @@ ResourceString
   SErrNoStreaming               = 'Failed to initialize component class "%s": No streaming method available.';
   SErrNoVariantSupport          = 'No variant support for properties. Please use the variants unit in your project and recompile';
   SErrOutOfMemory               = 'Out of memory';
+  SErrNotObserver               = '"%s" is not an observer';
   SErrPropertyNotFound          = 'Unknown property: "%s"';
   SerrInvalidPropertyType       = 'Invalid property type from streamed property: %d';
   SErrUnknownEnumValue          = 'Unknown enumeration value: "%s"';

rtl/win/wininc/base.inc

@@ -599,7 +599,7 @@
 
      SENDASYNCPROC = procedure (_para1:HWND; _para2:UINT; _para3:DWORD; _para4:LRESULT);stdcall;
 
-     TIMERPROC = procedure (_para1:HWND; _para2:UINT; _para3:UINT; _para4:DWORD);stdcall;
+     TIMERPROC = procedure (hWnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
 
      GRAYSTRINGPROC = FARPROC;
 

rtl/win/wininc/func.inc

@@ -500,8 +500,8 @@ function GetCapture:HWND; external 'user32' name 'GetCapture';
 function SetCapture(hWnd:HWND):HWND; external 'user32' name 'SetCapture';
 function ReleaseCapture:WINBOOL; external 'user32' name 'ReleaseCapture';
 function MsgWaitForMultipleObjects(nCount:DWORD; pHandles:LPHANDLE; fWaitAll:WINBOOL; dwMilliseconds:DWORD; dwWakeMask:DWORD):DWORD; external 'user32' name 'MsgWaitForMultipleObjects';
-function SetTimer(hWnd:HWND; nIDEvent:UINT; uElapse:UINT; lpTimerFunc:TIMERPROC):UINT; external 'user32' name 'SetTimer';
-function KillTimer(hWnd:HWND; uIDEvent:UINT):WINBOOL; external 'user32' name 'KillTimer';
+function SetTimer(hWnd:HWND; nIDEvent:UINT_PTR; uElapse:UINT; lpTimerFunc:TIMERPROC):UINT_PTR; external 'user32' name 'SetTimer';
+function KillTimer(hWnd:HWND; uIDEvent:UINT_PTR):WINBOOL; external 'user32' name 'KillTimer';
 function IsWindowUnicode(hWnd:HWND):WINBOOL; external 'user32' name 'IsWindowUnicode';
 function EnableWindow(hWnd:HWND; bEnable:WINBOOL):WINBOOL; external 'user32' name 'EnableWindow';
 function IsWindowEnabled(hWnd:HWND):WINBOOL; external 'user32' name 'IsWindowEnabled';

rtl/win/winsock2.pp

@@ -1251,11 +1251,19 @@ function WSAConnect( s : TSocket; const name : PSockAddr; namelen : Longint; lpC
 function WSACreateEvent : WSAEVENT; stdcall; external WINSOCK2_DLL name 'WSACreateEvent';
 function WSADuplicateSocketA( s : TSocket; dwProcessId : DWORD; lpProtocolInfo : LPWSAProtocol_InfoA ) : Longint; stdcall; external WINSOCK2_DLL name 'WSADuplicateSocketA';
 function WSADuplicateSocketW( s : TSocket; dwProcessId : DWORD; lpProtocolInfo : LPWSAProtocol_InfoW ) : Longint; stdcall; external WINSOCK2_DLL name 'WSADuplicateSocketW';
-function WSADuplicateSocket( s : TSocket; dwProcessId : DWORD; lpProtocolInfo : LPWSAProtocol_Info ) : Longint; stdcall; external WINSOCK2_DLL name 'WSADuplicateSocket';
+{$ifndef Unicode}
+function WSADuplicateSocket( s : TSocket; dwProcessId : DWORD; lpProtocolInfo : LPWSAProtocol_InfoA ) : Longint; stdcall; external WINSOCK2_DLL name 'WSADuplicateSocketA';
+{$else}
+function WSADuplicateSocket( s : TSocket; dwProcessId : DWORD; lpProtocolInfo : LPWSAProtocol_InfoW ) : Longint; stdcall; external WINSOCK2_DLL name 'WSADuplicateSocketW';
+{$endif}
 function WSAEnumNetworkEvents( const s : TSocket; const hEventObject : WSAEVENT; lpNetworkEvents : LPWSANETWORKEVENTS ) :Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumNetworkEvents';
 function WSAEnumProtocolsA( lpiProtocols : PLongint; lpProtocolBuffer : LPWSAProtocol_InfoA; var lpdwBufferLength : DWORD ) : Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumProtocolsA';
 function WSAEnumProtocolsW( lpiProtocols : PLongint; lpProtocolBuffer : LPWSAProtocol_InfoW; var lpdwBufferLength : DWORD ) : Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumProtocolsW';
-function WSAEnumProtocols( lpiProtocols : PLongint; lpProtocolBuffer : LPWSAProtocol_Info; var lpdwBufferLength : DWORD ) : Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumProtocols';
+{$ifndef Unicode}
+function WSAEnumProtocols( lpiProtocols : PLongint; lpProtocolBuffer : LPWSAProtocol_InfoA; var lpdwBufferLength : DWORD ) : Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumProtocolsA';
+{$else}
+function WSAEnumProtocols( lpiProtocols : PLongint; lpProtocolBuffer : LPWSAProtocol_InfoW; var lpdwBufferLength : DWORD ) : Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumProtocolsW';
+{$endif}
 function WSAEventSelect( s : TSocket; hEventObject : WSAEVENT; lNetworkEvents : LongInt ): Longint; stdcall; external WINSOCK2_DLL name 'WSAEventSelect';
 function WSAGetOverlappedResult( s : TSocket; lpOverlapped : LPWSAOVERLAPPED; lpcbTransfer : LPDWORD; fWait : BOOL; var lpdwFlags : DWORD ) : WordBool; stdcall; external WINSOCK2_DLL name 'WSAGetOverlappedResult';
 function WSAGetQosByName( s : TSocket; lpQOSName : LPWSABUF; lpQOS : LPQOS ): WordBool; stdcall; external WINSOCK2_DLL name 'WSAGetQosByName';
@@ -1283,55 +1291,106 @@ function WSASendMsg( s : TSocket; lpMsg : LPWSAMSG; dwFlags : DWORD; lpNumberOfB
 function WSASetEvent( hEvent : WSAEVENT ): WordBool; stdcall; external WINSOCK2_DLL name 'WSASetEvent';
 function WSASocketA( af, iType, protocol : Longint; lpProtocolInfo : LPWSAProtocol_InfoA; g : GROUP; dwFlags : DWORD ): TSocket; stdcall; external WINSOCK2_DLL name 'WSASocketA';
 function WSASocketW( af, iType, protocol : Longint; lpProtocolInfo : LPWSAProtocol_InfoW; g : GROUP; dwFlags : DWORD ): TSocket; stdcall; external WINSOCK2_DLL name 'WSASocketW';
-function WSASocket( af, iType, protocol : Longint; lpProtocolInfo : LPWSAProtocol_Info; g : GROUP; dwFlags : DWORD ): TSocket; stdcall; external WINSOCK2_DLL name 'WSASocket';
+
+{$ifndef UNICODE}
+function WSASocket ( af, iType, protocol : Longint; lpProtocolInfo : LPWSAProtocol_InfoA; g : GROUP; dwFlags : DWORD ): TSocket; stdcall; external WINSOCK2_DLL name 'WSASocketA';
+{$else}
+function WSASocket ( af, iType, protocol : Longint; lpProtocolInfo : LPWSAProtocol_InfoW; g : GROUP; dwFlags : DWORD ): TSocket; stdcall; external WINSOCK2_DLL name 'WSASocketW';
+{$endif}
+
 function WSAWaitForMultipleEvents( cEvents : DWORD; lphEvents : PWSAEVENT; fWaitAll : LongBool;
         dwTimeout : DWORD; fAlertable : LongBool ): DWORD; stdcall; external WINSOCK2_DLL name 'WSAWaitForMultipleEvents';
 function WSAAddressToStringA( var lpsaAddress : TSockAddr; const dwAddressLength : DWORD; const lpProtocolInfo : LPWSAProtocol_InfoA;
         const lpszAddressString : PChar; var lpdwAddressStringLength : DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSAAddressToStringA';
 function WSAAddressToStringW( var lpsaAddress : TSockAddr; const dwAddressLength : DWORD; const lpProtocolInfo : LPWSAProtocol_InfoW;
         const lpszAddressString : PWideChar; var lpdwAddressStringLength : DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSAAddressToStringW';
-function WSAAddressToString( var lpsaAddress : TSockAddr; const dwAddressLength : DWORD; const lpProtocolInfo : LPWSAProtocol_Info;
-        const lpszAddressString : PMBChar; var lpdwAddressStringLength : DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSAAddressToString';
+{$ifndef Unicode}
+function WSAAddressToString( var lpsaAddress : TSockAddr; const dwAddressLength : DWORD; const lpProtocolInfo : LPWSAProtocol_InfoA;
+        const lpszAddressString : PChar; var lpdwAddressStringLength : DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSAAddressToStringA';
+{$else}
+function WSAAddressToString( var lpsaAddress : TSockAddr; const dwAddressLength : DWORD; const lpProtocolInfo : LPWSAProtocol_InfoW;
+        const lpszAddressString : PWideChar; var lpdwAddressStringLength : DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSAAddressToStringW';
+{$endif}
+
 function WSAStringToAddressA( const AddressString : PChar; const AddressFamily: Longint; const lpProtocolInfo : LPWSAProtocol_InfoA;
         var lpAddress : TSockAddr; var lpAddressLength : Longint ): Longint; stdcall; external WINSOCK2_DLL name 'WSAStringToAddressA';
 function WSAStringToAddressW( const AddressString : PWideChar; const AddressFamily: Longint; const lpProtocolInfo : LPWSAProtocol_InfoA;
         var lpAddress : TSockAddr; var lpAddressLength : Longint ): Longint; stdcall; external WINSOCK2_DLL name 'WSAStringToAddressW';
-function WSAStringToAddress( const AddressString : PMBChar; const AddressFamily: Longint; const lpProtocolInfo : LPWSAProtocol_Info;
-        var lpAddress : TSockAddr; var lpAddressLength : Longint ): Longint; stdcall; external WINSOCK2_DLL name 'WSAStringToAddress';
+{$ifndef Unicode}
+function WSAStringToAddress( const AddressString : PChar; const AddressFamily: Longint; const lpProtocolInfo : LPWSAProtocol_InfoA;
+        var lpAddress : TSockAddr; var lpAddressLength : Longint ): Longint; stdcall; external WINSOCK2_DLL name 'WSAStringToAddressA';
+{$else}
+function WSAStringToAddress( const AddressString : PWideChar; const AddressFamily: Longint; const lpProtocolInfo : LPWSAProtocol_InfoA;
+        var lpAddress : TSockAddr; var lpAddressLength : Longint ): Longint; stdcall; external WINSOCK2_DLL name 'WSAStringToAddressW';
+{$endif}
 
 {       Registration and Name Resolution API functions }
 function WSALookupServiceBeginA( const lpqsRestrictions : LPWSAQuerySetA; const dwControlFlags : DWORD; lphLookup : PHANDLE ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceBeginA';
 function WSALookupServiceBeginW( const lpqsRestrictions : LPWSAQuerySetW; const dwControlFlags : DWORD; lphLookup : PHANDLE ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceBeginW';
-function WSALookupServiceBegin( const lpqsRestrictions : LPWSAQuerySet; const dwControlFlags : DWORD; lphLookup : PHANDLE ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceBegin';
+{$ifndef Unicode}
+function WSALookupServiceBegin( const lpqsRestrictions : LPWSAQuerySetA; const dwControlFlags : DWORD; lphLookup : PHANDLE ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceBeginA';
+{$else}
+function WSALookupServiceBegin( const lpqsRestrictions : LPWSAQuerySetW; const dwControlFlags : DWORD; lphLookup : PHANDLE ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceBeginW';
+{$endif}
+
 function WSALookupServiceNextA( const hLookup : THandle; const dwControlFlags : DWORD; var lpdwBufferLength : DWORD; lpqsResults : LPWSAQuerySetA ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceNextA';
 function WSALookupServiceNextW( const hLookup : THandle; const dwControlFlags : DWORD; var lpdwBufferLength : DWORD; lpqsResults : LPWSAQuerySetW ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceNextW';
-function WSALookupServiceNext( const hLookup : THandle; const dwControlFlags : DWORD; var lpdwBufferLength : DWORD; lpqsResults : LPWSAQuerySet ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceNext';
+{$ifndef unicode}
+function WSALookupServiceNext( const hLookup : THandle; const dwControlFlags : DWORD; var lpdwBufferLength : DWORD; lpqsResults : LPWSAQuerySetA ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceNextA';
+{$else}
+function WSALookupServiceNext( const hLookup : THandle; const dwControlFlags : DWORD; var lpdwBufferLength : DWORD; lpqsResults : LPWSAQuerySetW ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceNextW';
+{$endif}
 function WSALookupServiceEnd( const hLookup : THandle ): Longint; stdcall; external WINSOCK2_DLL name 'WSALookupServiceEnd';
 function WSAInstallServiceClassA( const lpServiceClassInfo : LPWSAServiceClassInfoA ) : Longint; stdcall; external WINSOCK2_DLL name 'WSAInstallServiceClassA';
 function WSAInstallServiceClassW( const lpServiceClassInfo : LPWSAServiceClassInfoW ) : Longint; stdcall; external WINSOCK2_DLL name 'WSAInstallServiceClassW';
-function WSAInstallServiceClass( const lpServiceClassInfo : LPWSAServiceClassInfo ) : Longint; stdcall; external WINSOCK2_DLL name 'WSAInstallServiceClass';
+{$ifndef unicode}
+function WSAInstallServiceClass( const lpServiceClassInfo : LPWSAServiceClassInfoA ) : Longint; stdcall; external WINSOCK2_DLL name 'WSAInstallServiceClassA';
+{$else}
+function WSAInstallServiceClass( const lpServiceClassInfo : LPWSAServiceClassInfoW ) : Longint; stdcall; external WINSOCK2_DLL name 'WSAInstallServiceClassW';
+{$endif}
 function WSARemoveServiceClass( const lpServiceClassId : PGUID ) : Longint; stdcall; external WINSOCK2_DLL name 'WSARemoveServiceClass';
 function WSAGetServiceClassInfoA( const lpProviderId : PGUID; const lpServiceClassId : PGUID; var lpdwBufSize : DWORD;
         lpServiceClassInfo : LPWSAServiceClassInfoA ): Longint; stdcall; external WINSOCK2_DLL name 'WSAGetServiceClassInfoA';
 function WSAGetServiceClassInfoW( const lpProviderId : PGUID; const lpServiceClassId : PGUID; var lpdwBufSize : DWORD;
         lpServiceClassInfo : LPWSAServiceClassInfoW ): Longint; stdcall; external WINSOCK2_DLL name 'WSAGetServiceClassInfoW';
+{$ifndef Unicode}
+function WSAGetServiceClassInfo( const lpProviderId : PGUID; const lpServiceClassId : PGUID; var lpdwBufSize : DWORD;
+        lpServiceClassInfo : LPWSAServiceClassInfoA ): Longint; stdcall; external WINSOCK2_DLL name 'WSAGetServiceClassInfoA';
+{$else}
 function WSAGetServiceClassInfo( const lpProviderId : PGUID; const lpServiceClassId : PGUID; var lpdwBufSize : DWORD;
-        lpServiceClassInfo : LPWSAServiceClassInfo ): Longint; stdcall; external WINSOCK2_DLL name 'WSAGetServiceClassInfo';
+        lpServiceClassInfo : LPWSAServiceClassInfoW ): Longint; stdcall; external WINSOCK2_DLL name 'WSAGetServiceClassInfoW';
+{$endif}
+
 function WSAEnumNameSpaceProvidersA( var lpdwBufferLength: DWORD; const lpnspBuffer: LPWSANameSpace_InfoA ): Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumNameSpaceProvidersA';
 function WSAEnumNameSpaceProvidersW( var lpdwBufferLength: DWORD; const lpnspBuffer: LPWSANameSpace_InfoW ): Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumNameSpaceProvidersW';
-function WSAEnumNameSpaceProviders( var lpdwBufferLength: DWORD; const lpnspBuffer: LPWSANameSpace_Info ): Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumNameSpaceProviders';
+{$ifndef Unicode}
+function WSAEnumNameSpaceProviders( var lpdwBufferLength: DWORD; const lpnspBuffer: LPWSANameSpace_InfoA ): Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumNameSpaceProvidersA';
+{$else}
+function WSAEnumNameSpaceProviders( var lpdwBufferLength: DWORD; const lpnspBuffer: LPWSANameSpace_InfoW ): Longint; stdcall; external WINSOCK2_DLL name 'WSAEnumNameSpaceProvidersW';
+{$endif}
+
 function WSAGetServiceClassNameByClassIdA( const lpServiceClassId: PGUID; lpszServiceClassName: PChar;
         var lpdwBufferLength: DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSAGetServiceClassNameByClassIdA';
 function WSAGetServiceClassNameByClassIdW( const lpServiceClassId: PGUID; lpszServiceClassName: PWideChar;
         var lpdwBufferLength: DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSAGetServiceClassNameByClassIdW';
-function WSAGetServiceClassNameByClassId( const lpServiceClassId: PGUID; lpszServiceClassName: PMBChar;
-        var lpdwBufferLength: DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSAGetServiceClassNameByClassId';
+{$ifndef Unicode}
+function WSAGetServiceClassNameByClassId( const lpServiceClassId: PGUID; lpszServiceClassName: PChar;
+        var lpdwBufferLength: DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSAGetServiceClassNameByClassIdA';
+{$else}
+function WSAGetServiceClassNameByClassId( const lpServiceClassId: PGUID; lpszServiceClassName: PWideChar;
+        var lpdwBufferLength: DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSAGetServiceClassNameByClassIdW';
+{$endif}
 function WSASetServiceA( const lpqsRegInfo: LPWSAQuerySetA; const essoperation: TWSAeSetServiceOp;
         const dwControlFlags: DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSASetServiceA';
 function WSASetServiceW( const lpqsRegInfo: LPWSAQuerySetW; const essoperation: TWSAeSetServiceOp;
         const dwControlFlags: DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSASetServiceW';
-function WSASetService( const lpqsRegInfo: LPWSAQuerySet; const essoperation: TWSAeSetServiceOp;
-        const dwControlFlags: DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSASetService';
+{$ifndef Unicode}
+function WSASetService( const lpqsRegInfo: LPWSAQuerySetA; const essoperation: TWSAeSetServiceOp;
+        const dwControlFlags: DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSASetServiceA';
+{$else}
+function WSASetService( const lpqsRegInfo: LPWSAQuerySetW; const essoperation: TWSAeSetServiceOp;
+        const dwControlFlags: DWORD ): Longint; stdcall; external WINSOCK2_DLL name 'WSASetServiceW';
+{$endif}
 
 { Macros }
 function WSAMakeSyncReply(Buflen, Error: Word): Longint;