just a first experimental version

git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/branches/experimental@2011 b956fd51-792f-4845-bead-9b4dfca2ff2c

2 files changed, 446 insertions, 0 deletions

diff --git a/Medley/src/lib/other/DirWatch.pas b/Medley/src/lib/other/DirWatch.pas
new file mode 100644
index 00000000..1e00ec5d
--- /dev/null
+++ b/Medley/src/lib/other/DirWatch.pas
@@ -0,0 +1,345 @@
+unit DirWatch;
+
+// -----------------------------------------------------------------------------
+// Component Name:  TDirectoryWatch                                            .
+// Module:          DirWatch                                                   .
+// Description:     Implements watching for file changes in a designated       .
+//                  directory (or directories).                                .
+// Version:         1.4                                                        .
+// Date:            10-MAR-2003                                                .
+// Target:          Win32, Delphi 3 - Delphi 7                                 .
+// Author:          Angus Johnson, angusj-AT-myrealbox-DOT-com                 .
+//                  A portion of code has been copied from the Drag & Drop     .
+//                  Component Suite which I co-authored with Anders Melander.  .
+// Copyright:       © 2003 Angus Johnson                                       .
+//                                                                             .
+// Usage:           1. Add a TDirectoryWatch component to your form.           .
+//                  2. Set its Directory property                              .
+//                  3. If you wish to watch its subdirectories too then set    .
+//                  the WatchSubDir property to true                           .
+//                  4. Assign the OnChange event                               .
+//                  5. Set Active to true                                      .
+// -----------------------------------------------------------------------------
+
+interface
+
+{$IFDEF FPC}
+  {$MODE Delphi}
+  {$H+} // use long strings
+{$ENDIF}
+
+uses
+  Windows,
+  Messages,
+  Classes,
+  {$IFDEF FPC}
+  WinAllocation,
+  {$ENDIF}
+  SysUtils;
+
+type
+  TNotifyFilters = set of (nfFilename, nfDirname, nfAttrib,
+    nfSize, nfLastWrite, nfSecurity);
+
+  TWatchThread = class;             //forward declaration
+
+  TDirectoryWatch = class(TComponent)
+  private
+    fWindowHandle: THandle;
+    fWatchThread: TWatchThread;
+    fWatchSubDirs: boolean;
+    fDirectory: string;
+    fActive: boolean;
+    fNotifyFilters: TNotifyFilters; //see FindFirstChangeNotification in winAPI
+    fOnChangeEvent: TNotifyEvent;
+    procedure SetActive(aActive: boolean);
+    procedure SetDirectory(aDir: string);
+    procedure SetWatchSubDirs(aWatchSubDirs: boolean);
+    procedure SetNotifyFilters(aNotifyFilters: TNotifyFilters);
+    procedure WndProc(var aMsg: TMessage);
+  public
+    constructor Create(aOwner: TComponent); override;
+    destructor Destroy; override;
+  published
+    property Directory: string read fDirectory write SetDirectory;
+    property NotifyFilters: TNotifyFilters
+      read fNotifyFilters write SetNotifyFilters;
+    property WatchSubDirs: boolean read fWatchSubDirs write SetWatchSubDirs;
+    property Active: boolean read fActive write SetActive;
+    property OnChange: TNotifyEvent read fOnChangeEvent write fOnChangeEvent;
+  end;
+
+  TWatchThread = class(TThread)
+  private
+    fOwnerHdl: Thandle;
+    fChangeNotify : THandle; //Signals whenever Windows detects a change in    .
+                             //the watched directory                           .
+    fBreakEvent: THandle;    //Signals when either the Directory property      .
+                             //changes or when the thread terminates           .
+    fDirectory: string;
+    fWatchSubDirs: longbool;
+    fNotifyFilters: dword;
+    fFinished: boolean;    
+  protected
+    procedure SetDirectory(const Value: string);
+    procedure ProcessFilenameChanges;
+    procedure Execute; override;
+  public
+    constructor Create( OwnerHdl: THandle;
+      const InitialDir: string; WatchSubDirs: boolean; NotifyFilters: dword);
+    destructor Destroy; override;
+    procedure Terminate;
+    property Directory: string write SetDirectory;
+  end;
+
+procedure Register;
+
+implementation
+
+const
+  NOTIFYCHANGE_MESSAGE = WM_USER + 1;
+
+resourcestring
+  sInvalidDir = 'Invalid Directory: ';
+
+//----------------------------------------------------------------------------
+// Miscellaneous functions ...
+//----------------------------------------------------------------------------
+
+procedure Register;
+begin
+  RegisterComponents('Samples', [TDirectoryWatch]);
+end;
+//----------------------------------------------------------------------------
+
+function DirectoryExists(const Name: string): Boolean;
+var
+  Code: Integer;
+begin
+  Code := GetFileAttributes(PChar(Name));
+  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
+end;
+
+//----------------------------------------------------------------------------
+// TDirectoryWatch methods ...
+//----------------------------------------------------------------------------
+
+constructor TDirectoryWatch.Create(aOwner: TComponent);
+begin
+  inherited Create(aOwner);
+  //default Notify values - notify if either a file name or a directory name
+  //changes or if a file is modified ...
+  fNotifyFilters := [nfFilename, nfDirname, nfLastWrite];
+  fDirectory := 'C:\';
+  //this non-visual control needs to handle messages, so ...
+  if not (csDesigning in ComponentState) then
+    fWindowHandle := AllocateHWnd(WndProc);
+end;
+//----------------------------------------------------------------------------
+
+destructor TDirectoryWatch.Destroy;
+begin
+  Active := false;
+  if not (csDesigning in ComponentState) then
+    DeallocateHWnd(fWindowHandle);
+  inherited Destroy;
+end;
+//----------------------------------------------------------------------------
+
+procedure TDirectoryWatch.WndProc(var aMsg: TMessage);
+begin
+  with aMsg do
+    if Msg = NOTIFYCHANGE_MESSAGE then
+    begin
+      if assigned(OnChange) then OnChange(self);
+    end else
+      Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
+end;
+//------------------------------------------------------------------------------
+
+procedure TDirectoryWatch.SetNotifyFilters(aNotifyFilters: TNotifyFilters);
+begin
+  if aNotifyFilters = fNotifyFilters then exit;
+  fNotifyFilters := aNotifyFilters;
+  if assigned(fWatchThread) then
+  begin
+    Active := false;
+    Active := true;
+  end;
+end;
+//------------------------------------------------------------------------------
+
+procedure TDirectoryWatch.SetWatchSubDirs(aWatchSubDirs: boolean);
+begin
+  if aWatchSubDirs = fWatchSubDirs then exit;
+  fWatchSubDirs := aWatchSubDirs;
+  if assigned(fWatchThread) then
+  begin
+    Active := false;
+    Active := true;
+  end;
+end;
+//------------------------------------------------------------------------------
+
+procedure TDirectoryWatch.SetDirectory(aDir: string);
+begin
+  if aDir = '' then
+  begin
+    Active := false;
+    fDirectory := '';
+    exit;
+  end;
+  if (aDir[length(aDir)] <> '\') then aDir := aDir + '\';
+  if aDir = fDirectory then exit;
+  if not (csDesigning in ComponentState) and not DirectoryExists(aDir) then
+    raise Exception.Create( sInvalidDir + aDir);
+  fDirectory := aDir;
+  if assigned(fWatchThread) then
+    fWatchThread.Directory := fDirectory;
+end;
+//------------------------------------------------------------------------------
+
+procedure TDirectoryWatch.SetActive(aActive: boolean);
+var
+  nf: dword;
+begin
+  if aActive = fActive then exit;
+  fActive := aActive;
+  if csDesigning in ComponentState then exit;
+  if fActive then
+  begin
+    if not DirectoryExists(fDirectory) then
+    begin
+      fActive := false;
+      raise Exception.Create(sInvalidDir + fDirectory);
+    end;
+    nf := 0;
+    if nfFilename in fNotifyFilters then
+      nf := nf or FILE_NOTIFY_CHANGE_FILE_NAME;
+    if nfDirname in fNotifyFilters then
+      nf := nf or FILE_NOTIFY_CHANGE_DIR_NAME;
+    if nfAttrib in fNotifyFilters then
+      nf := nf or FILE_NOTIFY_CHANGE_ATTRIBUTES;
+    if nfSize in fNotifyFilters then
+      nf := nf or FILE_NOTIFY_CHANGE_SIZE;
+    if nfLastWrite in fNotifyFilters then
+      nf := nf or FILE_NOTIFY_CHANGE_LAST_WRITE;
+    if nfSecurity in fNotifyFilters then
+      nf := nf or FILE_NOTIFY_CHANGE_SECURITY;
+    fWatchThread := TWatchThread.Create(
+      fWindowHandle, fDirectory, fWatchSubDirs, nf);
+  end else
+  begin
+    fWatchThread.Terminate;
+    fWatchThread := nil;
+  end;
+end;
+
+//----------------------------------------------------------------------------
+// TWatchThread methods ...
+//----------------------------------------------------------------------------
+
+constructor TWatchThread.Create(OwnerHdl: THandle;
+  const InitialDir: string; WatchSubDirs: boolean; NotifyFilters: dword);
+begin
+  inherited Create(True);       
+  fOwnerHdl := OwnerHdl;
+  if WatchSubDirs then
+    cardinal(fWatchSubDirs) := 1 //workaround a Win9x OS issue
+  else
+    fWatchSubDirs := false;
+  FreeOnTerminate := true;
+  Priority := tpLowest;
+  fDirectory := InitialDir;
+  fNotifyFilters := NotifyFilters;
+  fBreakEvent := windows.CreateEvent(nil, False, False, nil);
+  Resume;
+end;
+//------------------------------------------------------------------------------
+
+destructor TWatchThread.Destroy;
+begin
+  CloseHandle(fBreakEvent);
+  inherited Destroy;
+end;
+//------------------------------------------------------------------------------
+
+procedure TWatchThread.SetDirectory(const Value: string);
+begin
+  if (Value = FDirectory) then exit;
+  FDirectory := Value;
+  SetEvent(fBreakEvent);
+end;
+//------------------------------------------------------------------------------
+
+procedure TWatchThread.Terminate;
+begin
+  inherited Terminate;
+  SetEvent(fBreakEvent);
+  while not fFinished do sleep(10); //avoids a reported resource leak
+                                    //if called while closing the application.
+end;
+//------------------------------------------------------------------------------
+
+procedure TWatchThread.Execute;
+begin
+  //OUTER LOOP - manages Directory property reassignments
+  while (not Terminated) do
+  begin
+    fChangeNotify := FindFirstChangeNotification(pchar(fDirectory),
+      fWatchSubDirs, fNotifyFilters);
+    if (fChangeNotify = INVALID_HANDLE_VALUE) then
+      //Can't monitor the specified directory so we'll just wait for
+      //a new Directory assignment or the thread terminating ...
+      WaitForSingleObject(fBreakEvent, INFINITE)
+    else
+      try
+        //Now do the INNER loop...
+        ProcessFilenameChanges;
+      finally
+        FindCloseChangeNotification(fChangeNotify);
+      end;
+  end;
+  fFinished := true;
+end;
+//------------------------------------------------------------------------------
+
+procedure TWatchThread.ProcessFilenameChanges;
+var
+  WaitResult : DWORD;
+  HandleArray : array[0..1] of THandle;
+const
+  TEN_MSECS = 10;
+  HUNDRED_MSECS = 100;
+begin
+  HandleArray[0] := fBreakEvent;
+  HandleArray[1] := fChangeNotify;
+  //INNER LOOP - exits only when fBreakEvent signaled
+  while (not Terminated) do
+  begin
+    //waits for either fChangeNotify or fBreakEvent ...
+    WaitResult := WaitForMultipleObjects(2, @HandleArray, False, INFINITE);
+    if (WaitResult = WAIT_OBJECT_0 + 1) then //fChangeNotify
+    begin
+      repeat //ie: if a number of files are changing in a block
+             //just post the one notification message ...
+        FindNextChangeNotification(fChangeNotify);
+      until Terminated or
+        (WaitForSingleObject(fChangeNotify, TEN_MSECS) <> WAIT_OBJECT_0);
+      if Terminated then break;
+      //OK, now notify the main thread (before restarting inner loop)...
+      PostMessage(fOwnerHdl, NOTIFYCHANGE_MESSAGE, 0, 0);
+    end else //fBreakEvent ...
+    begin
+      //If the Directory property is undergoing multiple rapid reassignments
+      //wait 'til this stops before restarting monitoring of a new directory ...
+      while (not Terminated) and
+        (WaitForSingleObject(fBreakEvent, HUNDRED_MSECS) = WAIT_OBJECT_0) do;
+      break; //EXIT LOOP HERE
+    end;
+  end;
+end;
+//------------------------------------------------------------------------------
+//------------------------------------------------------------------------------
+
+end.
\ No newline at end of file
diff --git a/Medley/src/lib/other/WinAllocation.pas b/Medley/src/lib/other/WinAllocation.pas
new file mode 100644
index 00000000..ba1b0919
--- /dev/null
+++ b/Medley/src/lib/other/WinAllocation.pas
@@ -0,0 +1,101 @@
+unit WinAllocation;
+
+// FPC misses AllocateHWnd and DeallocateHWnd which is used by several
+// libraries such as Midi... or DirWatch.
+// Since FPC 2.2.2 there are dummies in Classes that just raise RunTime exceptions.
+// To avoid those exceptions, include this unit AFTER Classes.
+// Maybe the dummies will be replaced by functional routines in the future.WinAllocation
+//
+// THESE FUNCTIONS ARE ONLY FOR COMPATIBILITY WITH SOME EXTERNAL WIN32 LIBS.
+// DO NOT USE THEM IN USDX CODE.
+//
+
+interface
+
+{$IFDEF FPC}
+  {$MODE Delphi}
+{$ENDIF}
+
+uses
+  Classes,
+  Windows;
+
+function  AllocateHWnd(Method: TWndMethod): HWND;
+procedure DeallocateHWnd(hWnd: HWND);
+
+implementation
+
+function AllocateHWndCallback(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
+var
+  Msg: TMessage;
+  MethodPtr: ^TWndMethod;
+begin
+  FillChar(Msg, SizeOf(Msg), 0);
+  Msg.msg := uMsg;
+  Msg.wParam := wParam;
+  Msg.lParam := lParam;
+
+  MethodPtr := Pointer(GetWindowLongPtr(hwnd, GWL_USERDATA));
+  if Assigned(MethodPtr) then
+    MethodPtr^(Msg);
+
+  Result := DefWindowProc(hwnd, uMsg, wParam, lParam);
+end;
+
+function AllocateHWnd(Method: TWndMethod): HWND;
+var
+  ClassExists: Boolean;
+  WndClass, OldClass: TWndClass;
+  MethodPtr: ^TMethod;
+begin
+  Result := 0;
+
+  // setup class-info
+  FillChar(WndClass, SizeOf(TWndClass), 0);
+  WndClass.hInstance := HInstance;
+  // Important: do not enable AllocateHWndCallback before the msg-handler method is assigned,
+  //   otherwise race-conditions might occur
+  WndClass.lpfnWndProc := @DefWindowProc;
+  WndClass.lpszClassName:= 'USDXUtilWindowClass';
+
+  // check if class is already registered
+  ClassExists := GetClassInfo(HInstance, WndClass.lpszClassName, OldClass);
+  // create window-class shared by all windows created by AllocateHWnd()
+  if (not ClassExists) or (@OldClass.lpfnWndProc <> @DefWindowProc) then
+  begin
+    if ClassExists then
+      UnregisterClass(WndClass.lpszClassName, HInstance);
+    if (RegisterClass(WndClass) = 0) then
+       Exit;
+  end;
+  // create window
+  Result := CreateWindowEx(WS_EX_TOOLWINDOW, WndClass.lpszClassName, '',
+    DWORD(WS_POPUP), 0, 0, 0, 0, 0, 0, HInstance, nil);
+  if (Result = 0) then
+    Exit;
+  // assign individual callback procedure to the window
+  if Assigned(Method) then
+  begin
+    // TMethod contains two pointers but we can pass just one as USERDATA
+    GetMem(MethodPtr, SizeOf(TMethod));
+    MethodPtr^ := TMethod(Method);
+    SetWindowLongPtr(Result, GWL_USERDATA, LONG_PTR(MethodPtr));
+  end;
+  // now enable AllocateHWndCallback for this window
+  SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@AllocateHWndCallback));
+end;
+
+procedure DeallocateHWnd(hWnd: HWND);
+var
+  MethodPtr: ^TMethod;
+begin
+  if (hWnd <> 0) then
+  begin
+    MethodPtr := Pointer(GetWindowLongPtr(hWnd, GWL_USERDATA));
+    DestroyWindow(hWnd);
+    if Assigned(MethodPtr) then
+      FreeMem(MethodPtr);
+  end;
+end;
+
+end.