roka/bds.mr.devmgr
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Rework

Browse Source
This commit is contained in:
Róka Miklós
2026-01-08 19:04:51 +01:00
parent b9305ab8af
commit cb039a3035
14 changed files with 723 additions and 338 deletions
Download Patch File Download Diff File Expand all files Collapse all files
prj.devmgr/Delphi12Athens/mr.devmgr.dpk
+6 -5
View File
@@ -31,10 +31,9 @@ package mr.devmgr;
requires
rtl,
vcl;
// spring.core,
// mr.dpgrtl,
// mr.jtag;
vcl,
mr.jtag,
spring.base;
contains
mr.drv in '..\..\src.devmgr\drv\mr.drv.pas',
@@ -66,6 +65,8 @@ contains
m.eeprom in '..\..\src.devmgr\dev\usb\trinity\modules\eeprom\m.eeprom.pas',
m.eeprom.types in '..\..\src.devmgr\dev\usb\trinity\modules\eeprom\m.eeprom.types.pas',
m.cfg in '..\..\src.devmgr\dev\usb\trinity\modules\cfg\m.cfg.pas',
m.cfg.types in '..\..\src.devmgr\dev\usb\trinity\modules\cfg\m.cfg.types.pas';
m.cfg.types in '..\..\src.devmgr\dev\usb\trinity\modules\cfg\m.cfg.types.pas',
mr.drv.usb.notifier in '..\..\src.devmgr\drv\usb\mr.drv.usb.notifier.pas',
mr.drv.trinity in '..\..\src.devmgr\drv\usb\mr.drv.trinity.pas';
end.
prj.devmgr/Delphi12Athens/mr.devmgr.dproj
+6 -3
View File
@@ -60,7 +60,7 @@
<SanitizedProjectName>mr_devmgr</SanitizedProjectName>
<VerInfo_Locale>1033</VerInfo_Locale>
<VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
<DllSuffix>.270</DllSuffix>
<DllSuffix>.290</DllSuffix>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''">
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
@@ -85,7 +85,6 @@
<DCC_RemoteDebug>false</DCC_RemoteDebug>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<DCC_Description>mr Device Manager for USB devices</DCC_Description>
<DllSuffix>.290</DllSuffix>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''">
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
@@ -102,6 +101,8 @@
</DelphiCompile>
<DCCReference Include="rtl.dcp"/>
<DCCReference Include="vcl.dcp"/>
<DCCReference Include="mr.jtag.dcp"/>
<DCCReference Include="spring.base.dcp"/>
<DCCReference Include="..\..\src.devmgr\drv\mr.drv.pas"/>
<DCCReference Include="..\..\src.devmgr\drv\usb\mr.drv.usb.pas"/>
<DCCReference Include="..\..\src.devmgr\drv\usb\mr.drv.usb.types.pas"/>
@@ -132,6 +133,8 @@
<DCCReference Include="..\..\src.devmgr\dev\usb\trinity\modules\eeprom\m.eeprom.types.pas"/>
<DCCReference Include="..\..\src.devmgr\dev\usb\trinity\modules\cfg\m.cfg.pas"/>
<DCCReference Include="..\..\src.devmgr\dev\usb\trinity\modules\cfg\m.cfg.types.pas"/>
<DCCReference Include="..\..\src.devmgr\drv\usb\mr.drv.usb.notifier.pas"/>
<DCCReference Include="..\..\src.devmgr\drv\usb\mr.drv.trinity.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
@@ -168,7 +171,7 @@
<DeployFile LocalName="$(BDS)\Redist\osx32\libcgunwind.1.0.dylib" Class="DependencyModule"/>
<DeployFile LocalName="C:\Users\Public\Documents\Embarcadero\Studio\21.0\Bpl\mr_devmgr.bpl" Configuration="Debug" Class="ProjectOutput"/>
<DeployFile LocalName="C:\Users\Public\Documents\Embarcadero\Studio\21.0\Bpl\mr_devmgr.bpl" Configuration="Release" Class="ProjectOutput"/>
<DeployFile LocalName="C:\Users\Public\Documents\Embarcadero\Studio\23.0\Bpl\mr.devmgr.270.bpl" Configuration="Debug" Class="ProjectOutput">
<DeployFile LocalName="C:\Users\Public\Documents\Embarcadero\Studio\23.0\Bpl\mr.devmgr.290.bpl" Configuration="Debug" Class="ProjectOutput">
<Platform Name="Win32">
<RemoteName>mr.devmgr.bpl</RemoteName>
<Overwrite>true</Overwrite>
src.devmgr/dev/mr.dev.pas
+2 -2
View File
@@ -5,9 +5,9 @@ uses
mr.drv;
type
TDevice = class(TInterfacedObject)
TDevice = class
protected
fDriver: TDriver;
fDriver : TDriver;
public
procedure Open; virtual; abstract;
src.devmgr/dev/usb/trinity/modules/lcd/m.lcd.types.pas
+1 -1
View File
@@ -14,7 +14,7 @@ type
procedure Cls;
procedure GotoXY( x,y: word);
procedure putc( const c: AnsiChar);
// procedure puts( const s: AnsiString);
procedure puts( const s: AnsiString);
end;
implementation
src.devmgr/dev/usb/trinity/mr.trinity.hex.pas
+1 -1
View File
@@ -429,7 +429,7 @@ begin
// blk.Address;
// blk.BlockLength;
s := Format('%3d %4.4x-%4.4x (%4.4x)'#13, [i,blk.Address,blk.Address+blk.BlockLength, blk.BlockLength]);
writeln(s);
// writeln(s);
INC(i);
end;
src.devmgr/dev/usb/trinity/mr.trinity.pas
+18 -12
View File
@@ -41,7 +41,7 @@ type
// -----------------------------------------------------------------------------------
// TTrinity
// -----------------------------------------------------------------------------------
TTrinity = class (TUsbDevice, ITrinity, IIIC, ILCD, ILED, IEEPROM, IJTAG, ICFG)
TTrinity = class (TUsbDevice)
protected
fCaps : TCapabilities;
fCaps64 : Int64;
@@ -76,17 +76,17 @@ type
fModCFG : ICFG;
fModIIC : IIIC;
fModEPR : IEEPROM;
fModJTAG : IJTAG;
fModJTG : IJTAG;
fModLCD : ILCD;
fModLED : ILED;
protected
property cfg : ICFG read fModCFG implements ICFG;
property iic : IIIC read fModIIC implements IIIC;
property eeprom : IEEPROM read fModEPR implements IEEPROM;
property jtag : IJTAG read fModJTAG implements IJTAG;
property lcd : ILCD read fModLCD implements ILCD;
property led : ILED read fModLED implements ILED;
public
property cfg : ICFG read fModCFG;
property iic : IIIC read fModIIC;
property eeprom : IEEPROM read fModEPR;
property jtag : IJTAG read fModJTG;
property lcd : ILCD read fModLCD;
property led : ILED read fModLED;
// ----------------------------------------------------------------------
// construction / destruction
@@ -164,7 +164,7 @@ begin
fModEPR := TmodEEPROM .Create( self);
fModLCD := TmodLCD .Create( self);
fModLED := TmodLED .Create( self);
fModJTAG := TmodJTAG .Create( self);
fModJTG := TmodJTAG .Create( self);
end;
// ================================================================================================
@@ -172,11 +172,16 @@ end;
// ================================================================================================
procedure TTrinity.BeforeDestruction;
begin
fModCFG := nil;
fModIIC := nil;
fModEPR := nil;
fModLCD := nil;
fModLED := nil;
fModJTG := nil;
inherited
end;
function TTrinity.Capabilities: TCapabilities;
begin
result := fCaps
@@ -244,6 +249,7 @@ begin
fCaps64 := PInt64(@buf)^;
fCaps := DecodeCapabilities(fCaps64);
end
end
end;
src.devmgr/dev/usb/trinity/mr.trinity.types.pas
+2 -4
View File
@@ -86,7 +86,7 @@ begin
if cap in caps then
begin
if result <> '' then
result := result +',';
result := result +', ';
case cap of
capSER : result := result +'SER';
@@ -99,9 +99,7 @@ begin
capLCD2 : result := result +'LCD2';
end;
end;
end
end;
end.
src.devmgr/drv/mr.drv.pas
+8 -1
View File
@@ -3,7 +3,11 @@ unit mr.drv;
interface
type
TDriver = class abstract( TInterfacedObject)
TDriver = class abstract
protected
class var
fInterfaceGuid : string;
protected
fDeviceHandle : THandle;
fDevicePath : string;
@@ -12,6 +16,9 @@ type
procedure Open; virtual; abstract;
procedure Close; virtual; abstract;
public
class property InterfaceGUID: string read fInterfaceGuid;
public
property DevicePath : string read fDevicePath;
property DeviceHandle : THandle read fDeviceHandle;
src.devmgr/drv/usb/mr.drv.trinity.pas
+24
View File
@@ -0,0 +1,24 @@
unit mr.drv.trinity;
interface
uses
mr.drv.usb.winusb;
type TTrinityDriver = class (TWinUsbDriver)
class constructor CreateClass;
end;
implementation
uses
mr.dev.manager;
class constructor TTrinityDriver.CreateClass;
begin
fInterfaceGUID := '{CDDE880F-898A-4DAB-B0EA-51FBA32C1D82}';
end;
initialization
RegisterDriver( TTrinityDriver);
end.
src.devmgr/drv/usb/mr.drv.usb.notifier.pas
+188
View File
@@ -0,0 +1,188 @@
unit mr.drv.usb.notifier;
interface
uses
System.Classes,
Winapi.Windows,
Winapi.Messages,
mr.drv.usb;
const
DBT_DEVTYP_DEVICEINTERFACE = $00000005; // device interface class
DBT_DEVICEARRIVAL = $8000; // system detected a new device
DBT_DEVICEQUERYREMOVE = $8001;
DBT_DEVICEQUERYREMOVEFAILED= $8002;
DBT_DEVICEREMOVEPENDING = $8003;
DBT_DEVICEREMOVECOMPLETE = $8004; // device is gone
DBT_DEVICETYPESPECIFIC = $8005;
type
TusbNotifyEvent = procedure( APath: string; ADriverClass: TUsbDriverClass) of object;
PDevBroadcastHdr = ^DEV_BROADCAST_HDR;
DEV_BROADCAST_HDR = packed record
dbch_size : DWORD;
dbch_devicetype: DWORD;
dbch_reserved : DWORD;
end;
PDevBroadcastDeviceInterface = ^DEV_BROADCAST_DEVICEINTERFACE;
DEV_BROADCAST_DEVICEINTERFACE = record
dbcc_size : DWORD;
dbcc_devicetype: DWORD;
dbcc_reserved : DWORD;
dbcc_classguid : TGUID;
dbcc_name : char;
end;
type
TusbNotifier = class
private
fDeviceInterface : string;
fDriverClass : TUsbDriverClass;
fNotifyHandle : HDEVNOTIFY;
FWindowHandle : HWND;
FOnUSBArrival : TusbNotifyEvent;
FOnUSBRemove : TusbNotifyEvent;
procedure WndProc(var Msg: TMessage);
function USBRegister: Boolean;
protected
procedure WMDeviceChange(var Msg: TMessage); dynamic;
public
constructor Create( ADeviceInterface: string; ADriverClass: TUsbDriverClass);
destructor Destroy; override;
public
property OnUSBArrival : TusbNotifyEvent read FOnUSBArrival write FOnUSBArrival;
property OnUSBRemove : TusbNotifyEvent read FOnUSBRemove write FOnUSBRemove;
property DeviceInterface: string read fDeviceInterface;
end;
implementation
uses
Vcl.Forms,
System.SysUtils;
{ TusbNotifier }
// ================================================================================================
// constructor
//
// '{CDDE880F-898A-4DAB-B0EA-51FBA32C1D82}' [trinity.inf]
// ================================================================================================
constructor TusbNotifier.Create( ADeviceInterface: string; ADriverClass: TUsbDriverClass);
begin
inherited Create;
fDeviceInterface := ADeviceInterface;
fDriverClass := ADriverClass;
fWindowHandle := AllocateHWnd(WndProc);
UsbRegister
end;
// ================================================================================================
// destructor
// ================================================================================================
destructor TusbNotifier.Destroy;
begin
if fNotifyHandle <> nil then
UnregisterDeviceNotification( fNotifyHandle);
DeallocateHWnd( fWindowHandle);
inherited
end;
// ================================================================================================
// UsbRegister
// ================================================================================================
function TusbNotifier.USBRegister: Boolean;
var
dbi : DEV_BROADCAST_DEVICEINTERFACE;
size : Integer;
begin
size := SizeOf(DEV_BROADCAST_DEVICEINTERFACE);
ZeroMemory(@dbi, Size);
dbi.dbcc_size := Size;
dbi.dbcc_devicetype := DBT_DEVTYP_DEVICEINTERFACE;
dbi.dbcc_classguid := StringToGUID( fDeviceInterface);
dbi.dbcc_reserved := 0;
dbi.dbcc_name := #0;
fNotifyHandle := RegisterDeviceNotification( fWindowHandle, @dbi, DEVICE_NOTIFY_WINDOW_HANDLE);
result := fNotifyHandle <> nil
end;
// ================================================================================================
// WndProc
// ================================================================================================
procedure TusbNotifier.WndProc(var Msg: TMessage);
begin
if Msg.Msg = WM_DEVICECHANGE then
begin
try
WMDeviceChange(Msg)
except
Application.HandleException(Self)
end
end
else
Msg.Result := DefWindowProc( fWindowHandle, Msg.Msg, Msg.wParam, Msg.lParam)
end;
// ================================================================================================
// WM Device Change
// ================================================================================================
procedure TusbNotifier.WMDeviceChange(var Msg: TMessage);
var
devType : Integer;
devHdr : PDevBroadcastHdr;
begin
if (Msg.wParam = DBT_DEVICEARRIVAL) or (Msg.wParam = DBT_DEVICEREMOVECOMPLETE) then
begin
devHdr := PDevBroadcastHdr( Msg.lParam);
devType := devHdr^.dbch_devicetype;
if devType = DBT_DEVTYP_DEVICEINTERFACE then
begin // USB Device
var x := PDevBroadcastDeviceInterface( Msg.LParam);
var p := PChar( @x.dbcc_name);
var s := '';
while p^ <> #0 do
begin
s := s + p^;
INC(p)
end;
if Msg.wParam = DBT_DEVICEARRIVAL then
begin
if Assigned( fOnUSBArrival) then
FOnUSBArrival( s, fDriverClass)
end
else begin
if Assigned( fOnUSBRemove) then
FOnUSBRemove( s, fDriverClass)
end
end
end
end;
end.
src.devmgr/drv/usb/mr.drv.usb.pas
+5 -68
View File
@@ -16,7 +16,6 @@ type
TScanCallback = reference to procedure( DevicePath: string);
TUsbDeviceInfo = class
private
fDriverClass : TUsbDriverClass;
@@ -41,27 +40,14 @@ type
IUsbDriverMap = IDictionary<string, TUsbDeviceInfo>;
TAnsiStringList = TList<AnsiString>;
TList = spring.Collections.IList<string>;
TUsbDriver = class abstract(TDriver, IUsbDriver)
TUsbDriver = class abstract(TDriver)
public
class procedure Scan( ScanCallback: TScanCallback); virtual; abstract;
public
class procedure ParseInstanceId( InstanceId : string;
var VendorID : word;
var ProductID : word;
var Location : string;
var Description : string);
protected
class var fDriverID: TGUID;
protected
fVendorID : word;
fProductID : word;
@@ -138,6 +124,8 @@ type
implementation
uses
mr.dev.usb,
mr.dev.manager,
System.Win.Registry,
System.SysUtils;
{ TUsbDriver }
@@ -160,7 +148,7 @@ begin
fDevicePath := DevicePath;
fDeviceSpeed := LowSpeed;
ParseInstanceId( fDevicePath, fVendorID, fProductID, fLocation, fDescription);
ParseDevicePath( fDevicePath, fVendorID, fProductID, fLocation, fDescription);
end;
// @@@: INTERNALS +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
@@ -172,57 +160,6 @@ end;
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
// parse instance id
// ================================================================================================
class procedure TUsbDriver.ParseInstanceId( InstanceId : string;
var VendorID : word;
var ProductID : word;
var Location : string;
var Description : string);
var
i : integer;
l : integer;
id : string;
loc: string;
dsc: string;
begin
i := 1;
l := Length(InstanceId);
while (i<=l) and (InstanceId[i] <> '\') do
inc(i);
inc(i);
while (i<=l) and (InstanceId[i] <> '\') do
begin
id := id + InstanceId[i];
inc(i)
end;
inc(i);
while (i<=l) and (InstanceId[i] <> '#') do
begin
loc := loc + InstanceId[i];
inc(i)
end;
inc(i);
while (i<=l) do
begin
dsc := dsc + InstanceId[i];
inc(i)
end;
VendorId := StrToInt('$'+Copy( id, 5, 4));
ProductId := StrToInt('$'+Copy( id, 14, 4));
Location := loc;
Description := dsc;
end;
{ TUsbDeviceInfo }
@@ -244,7 +181,7 @@ begin
fDevicePath := DevicePath;
fDriverClass := DriverClass;
DriverClass.ParseInstanceId( fDevicePath, fVendorID, fProductID, fLocation, fDescription)
ParseDevicePath( fDevicePath, fVendorID, fProductID, fLocation, fDescription)
end;
// ================================================================================================
src.devmgr/drv/usb/mr.drv.usb.types.pas
+3 -1
View File
@@ -7,7 +7,7 @@ uses
const
// Standard request codes (btw not used)
CTRL_GET_STATUS = 0;
CTRL_CLEAR_FEATURE = 1;
CTRL_CLR_FEATURE = 1;
CTRL_SET_FEATURE = 3;
CTRL_SET_ADDRESS = 5;
CTRL_GET_DESCRIPTOR = 6;
@@ -140,9 +140,11 @@ type
1: (
SetupDat : array [2..7] of byte;
);
end;
type
IUsbDriver = interface
['{786E9A46-F7FE-4A8C-8BB8-563AB8C51BD5}']
src.devmgr/drv/usb/mr.drv.usb.winusb.pas
+23 -31
View File
@@ -9,16 +9,11 @@ uses
type
TWinUsbInterfaceHandle = THandle;
TWinUsbDriver = class( TUsbDriver)
public
class procedure Scan( ScanCallback: TScanCallback); override;
protected
fWinUsbHandle : TWinUsbInterfaceHandle;
@@ -36,10 +31,14 @@ type
function GetAssociatedInterface
(
InterfaceIndex : byte;
var InterfaceHandle): boolean; override;
var InterfaceHandle
): boolean; override;
function QueryInterfaceSettings( AlternateSettingNumber : byte;
var AlternateSettingDescriptor : TUsbAlternateSettingDescriptor): boolean; override;
function QueryInterfaceSettings
(
AlternateSettingNumber : byte;
var AlternateSettingDescriptor : TUsbAlternateSettingDescriptor
): boolean; override;
function QueryPipe
(
@@ -91,9 +90,6 @@ type
public
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
end;
implementation
@@ -243,17 +239,17 @@ end;
procedure TWinUsbDriver.BeforeDestruction;
begin
Close;
fWinUsbHandle := INVALID_HANDLE_VALUE;
fDeviceHandle := INVALID_HANDLE_VALUE;
inherited;
end;
// ================================================================================================
// Open
//
// Note:
// fDevicePath is in the form:
// 'USB\VID_04B4&PID_8613\6&26c545a4&0&1#Cypress FX2
//
// it must be converted into:
// DevicePath must be in the form of:
// \\?\USB#VID_04B4&PID_8613#6&26c545a4&0&1#{CDDE880F-898A-4DAB-B0EA-51FBA32C1D82}
// ================================================================================================
procedure TWinUsbDriver.Open;
@@ -270,13 +266,14 @@ begin
// Prepare device path
// ---------------------------------------------------------------
// strip device description
i := Pos('#', path);
{ i := Pos('#', path);
if i > 0 then
path := Copy( path, 1, i-1);
path := ReplaceStr(path,'\','#');
path := '\\?\'+path+'#'+GuidToString(fDriverID);
path := '\\?\'+path+'#'+fInterfaceGuid;
}
// ---------------------------------------------------------------
// open
@@ -546,9 +543,9 @@ var
s : string;
begin
try
dsc := CreateComObject( CLSID_FunctionDiscovery) as IFunctionDiscovery;
try
cat := FCTN_CATEGORY_PNP;
hr := dsc.GetInstanceCollection(cat, nil, true, fcts);
@@ -562,18 +559,14 @@ begin
begin
if 'WinUSB' = propv.pwszVal then
begin
// \\?\USB#VID_04B4&PID_8613#6&26c545a4&0&1#{CDDE880F-898A-4DAB-B0EA-51FBA32C1D82}
props.GetValue( PKEY_Device_InstanceId, propv);
s := propv.pwszVal;
props.GetValue( PKEY_Device_DeviceDesc, propv);
s := s +'#'+ propv.pwszVal;
s := StringReplace( propv.pwszVal, '\', '#', [rfReplaceAll]);
s := Uppercase('\\?\' +s +'#' +fInterfaceGuid);
ScanCallback( s);
// if Map.ContainsKey( s) then
// Map.Remove( s);
//
// Map.Add( s, TUsbDeviceInfo.Create(s, self))
ScanCallback( s)
end
end
end
@@ -635,9 +628,8 @@ initialization
// The device path must look like this:
// \\?\USB#VID_04B4&PID_8613#6&26c545a4&0&1#Cypress-FX2
// --------------------------------------------------------------------------------
TWinUsbDriver.fDriverID := StringToGuid('{CDDE880F-898A-4DAB-B0EA-51FBA32C1D82}');
RegisterDriver( TWinUsbDriver);
// TWinUsbDriver.fDriverID := StringToGuid('{CDDE880F-898A-4DAB-B0EA-51FBA32C1D82}');
// RegisterDriver( TWinUsbDriver);
end;
src.devmgr/mr.dev.manager.pas
+423 -196
View File
@@ -4,11 +4,9 @@ unit mr.dev.manager;
interface
uses
// Vcl.Dialogs,
System.Classes,
mr.drv.usb,
mr.dev.usb;
// dev.usb.trinity.types;
type
GetDeviceListCallback = reference to function( VendorID : word;
@@ -17,40 +15,44 @@ type
Location : string;
DevicePath : string): boolean;
procedure RegisterDriver( DriverClass : TUsbDriverClass);
//
procedure RegisterDevice( VendorID : word;
ProductID : word;
Capabilities: int64;
DeviceClass : TUsbDeviceClass);
//
function AllocateDevice( DevicePath : string): TUsbDevice;
// Capabilities: TCapabilities = [];
// IgnoreCap : boolean = false): TUsbDevice;
//
//function AllocateDeviceBySN( SerialNumber: AnsiString;
// Capabilities: TCapabilities = [];
// IgnoreCap : boolean = false): TUsbDevice;
//
procedure DeallocateDevice( var Device : TUsbDevice);
//
procedure GetDeviceList( Callback : GetDeviceListCallback;
VendorID : word = 0;
ProductID : word = 0);
DeviceConnectEvent = procedure(ADevicePath : string) of object;
procedure RegisterDriver( ADriverClass : TUsbDriverClass);
procedure RegisterDevice( AVendorID : word;
AProductID : word;
ACapabilities : int64;
ADeviceClass : TUsbDeviceClass);
procedure GetDeviceList( ACallback : GetDeviceListCallback;
AVendorID : word = 0;
AProductID : word = 0);
function AllocateDevice( ADevicePath : string): TUsbDevice;
procedure DeallocateDevice( var ADevice : TUsbDevice);
function ParseDevicePath( InstanceId : string;
var VendorID : word;
var ProductID : word;
var Location : string;
var Description : string): boolean;
procedure RegisterUsbConnectEventHandler( AEventHandler: DeviceConnectEvent);
procedure RegisterUsbDisconnectEventHandler( AEventHandler: DeviceConnectEvent);
implementation
uses
system.SysUtils,
spring.Collections;
procedure ParseInstanceId( InstanceId : string;
var VendorID : word;
var ProductID : word;
var Location : string;
var Description : string); forward;
Winapi.Windows,
System.SysUtils,
System.Win.Registry,
Spring.Collections,
mr.drv.usb.notifier;
// SysUtils,
// Generics.Collections,
@@ -118,155 +120,185 @@ type
property Description : string read GetDescription;
end;
TDeviceManager = class
private
fOnDeviceArrival : DeviceConnectEvent;
fOnDeviceRemoval : DeviceConnectEvent;
private
fUsbDeviceSetups : IDictionary< cardinal, TUsbDeviceSetup>;
fUsbDevices : IDictionary< string, TUsbDeviceDescriptor>;
fUsbNotifiers : IDictionary< string, TusbNotifier>;
procedure DoUsbArrival( ADevicePath : string;
ADriverClass : TUsbDriverClass);
procedure DoUsbRemoval( ADevicePath : string;
ADriverClass : TUsbDriverClass);
public
procedure RegisterDriver( ADriverClass : TUsbDriverClass);
procedure RegisterDevice( AVendorID : word;
AProductID : word;
ACapabilities : int64;
ADeviceClass : TUsbDeviceClass);
procedure GetDeviceList( ACallback : GetDeviceListCallback;
AVendorID : word = 0;
AProductID : word = 0);
function AllocateDevice( ADevicePath : string): TUsbDevice;
procedure DeallocateDevice( ADevice : TUsbDevice);
public
constructor Create;
destructor Destroy; override;
public
property OnDeviceArrival : DeviceConnectEvent read fOnDeviceArrival write fOnDeviceArrival;
property OnDeviceRemoval : DeviceConnectEvent read fOnDeviceRemoval write fOnDeviceRemoval;
end;
var
UsbDeviceSetups : IDictionary< cardinal, TUsbDeviceSetup>;
UsbDevices : IDictionary< string, TUsbDeviceDescriptor>;
gDeviceManager: TDeviceManager;
function DeviceManager: TDeviceManager; forward;
procedure RegisterUsbConnectEventHandler( AEventHandler: DeviceConnectEvent);
begin
DeviceManager.OnDeviceArrival := AEventHandler
end;
procedure RegisterUsbDisconnectEventHandler( AEventHandler: DeviceConnectEvent);
begin
DeviceManager.OnDeviceRemoval := AEventHandler;
end;
// ================================================================================================
// Register Driver
// parse device path
//
// '\\?\USB#VID_04B4&PID_8613#7&2ec9f839&0&17#{cdde880f-898a-4dab-b0ea-51fba32c1d82}'
// ================================================================================================
procedure RegisterDriver( DriverClass: TUsbDriverClass);
function ParseDevicePath( InstanceId : string;
var VendorID : word;
var ProductID : word;
var Location : string;
var Description : string): boolean;
var
vid: word;
pid: word;
id : string;
loc: string;
dsc: string;
key: cardinal;
uds: TUsbDeviceSetup;
udd: TUsbDeviceDescriptor;
begin
if UsbDevices = nil then
UsbDevices := tCollections.CreateDictionary< string, TUsbDeviceDescriptor>([doOwnsValues]);
result := false;
if UsbDeviceSetups = nil then
UsbDeviceSetups := TCollections.CreateDictionary< cardinal, TUsbDeviceSetup>([doOwnsValues]);
if Copy( InstanceId, 1, 8) = '\\?\USB#'
then InstanceId := Copy( InstanceId, 9)
else exit;
DriverClass.Scan( procedure( DevicePath: string)
var items := InstanceId.Split(['#']);
if Length(items) = 3 then
begin
DriverClass.ParseInstanceId( DevicePath, vid, pid, loc, dsc);
key := (vid shl 16) + pid;
id := items[0];
loc := items[1];
dsc := items[2];
end
// --------------------------------------------------------------
// add or update (override) an usb device setup entry
// --------------------------------------------------------------
if not UsbDeviceSetups.TryGetValue( key, uds) then
else
exit;
var ids := id.Split(['&']);
if Length(ids) = 2 then
begin
uds := TUsbDeviceSetup.Create;
uds.VendorID := vid;
uds.ProductID := pid;
VendorID := StrToInt('$'+Copy( ids[0], 5, 4));
ProductID := StrToInt('$'+Copy( ids[1], 5, 4));
end
UsbDeviceSetups.Add( key, uds)
else
exit;
Location := Uppercase(loc);
var reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
if reg.OpenKeyReadOnly('SYSTEM\CurrentControlSet\Enum\USB\'+id +'\'+ loc) then
begin
Description := reg.ReadString('DeviceDesc');
var i := Pos( ';', Description);
if i > 0 then
Description := Copy( Description, i+1);
reg.CloseKey
end;
uds.DriverClass := DriverClass;
uds.Description := dsc;
SetLength( items, 0);
SetLength( ids, 0);
// --------------------------------------------------------------
// add or update (override) an usb device entry
// --------------------------------------------------------------
if not UsbDevices.TryGetValue( DevicePath, udd) then
begin
udd := TUsbDeviceDescriptor.Create( DevicePath);
UsbDevices.Add(DevicePath, udd)
end;
result := true
end;
udd.DeviceSetup := uds
end)
// ================================================================================================
// DeviceManager (singleton pattern)
// ================================================================================================
function DeviceManager: TDeviceManager;
begin
if gDeviceManager = nil then
gDeviceManager := TDeviceManager.Create;
result := gDeviceManager
end;
// ================================================================================================
// Register Device
// register driver
// ================================================================================================
procedure RegisterDevice( VendorID : word;
ProductID : word;
Capabilities: int64;
DeviceClass : TUsbDeviceClass);
var
key: cardinal;
uds: TUsbDeviceSetup;
procedure RegisterDriver( ADriverClass: TUsbDriverClass);
begin
if UsbDeviceSetups = nil then
UsbDeviceSetups := TCollections.CreateDictionary< cardinal, TUsbDeviceSetup>([doOwnsValues]);
DeviceManager.RegisterDriver( ADriverClass)
end;
key := (VendorID shl 16) + ProductID;
if not UsbDeviceSetups.TryGetValue( key, uds) then
begin
uds := TUsbDeviceSetup.Create;
uds.VendorID := VendorID;
uds.ProductID := ProductID;
UsbDeviceSetups.Add( key, uds);
end;
uds.DeviceClass := DeviceClass;
// ================================================================================================
// register device
// ================================================================================================
procedure RegisterDevice( AVendorID : word;
AProductID : word;
ACapabilities : int64;
ADeviceClass : TUsbDeviceClass);
begin
DeviceManager.RegisterDevice( AVendorID, AProductID, ACapabilities, ADeviceClass)
end;
// ================================================================================================
// Get Device List
// ================================================================================================
procedure GetDeviceList( Callback : GetDeviceListCallback;
VendorID : word = 0;
ProductID : word = 0);
procedure GetDeviceList( ACallback : GetDeviceListCallback;
AVendorID : word = 0;
AProductID : word = 0);
begin
for var udd in UsbDevices.Values do
if ((VendorID = 0) and (ProductID = 0)) or
((VendorID = udd.VendorID) and (ProductID = udd.ProductID)) then
begin
with udd do
if not Callback( VendorID, ProductID, Description, Location, DevicePath) then
break
end
DeviceManager.GetDeviceList( ACallback, AVendorID, AProductID)
end;
// ================================================================================================
// Allocate Device
// ================================================================================================
function AllocateDevice( DevicePath: string): TUsbDevice;
var
udd: TUsbDeviceDescriptor;
function AllocateDevice( ADevicePath : string): TUsbDevice;
begin
result := nil;
assert( UsbDeviceSetups <> nil);
assert( UsbDevices <> nil);
if UsbDevices.TryGetValue( DevicePath, udd) and not udd.Allocated then
begin
var ds := udd.DeviceSetup;
assert( ds <> nil);
if (ds.DriverClass <> nil) and (ds.DeviceClass <> nil) then
begin
udd.Allocated := true;
var drv := ds.DriverClass.Create( DevicePath);
var dev := ds.DeviceClass.Create( drv);
exit(dev)
end
end
result := DeviceManager.AllocateDevice( ADevicePath)
end;
// ================================================================================================
// Deallocate Device
// ================================================================================================
procedure DeallocateDevice( var Device: TUsbDevice);
var
udd: TUsbDeviceDescriptor;
procedure DeallocateDevice( var ADevice: TUsbDevice);
begin
if Assigned(Device) then
begin
if UsbDevices.TryGetValue( Device.DevicePath, udd) then
udd.Allocated := false;
// FreeAndNil( Device)
end
DeviceManager.DeallocateDevice( ADevice)
end;
@@ -356,64 +388,8 @@ end;
//
// ================================================================================================
// parse instnce ID
// ================================================================================================
procedure ParseInstanceId( InstanceId : string;
var VendorID : word;
var ProductID : word;
var Location : string;
var Description : string);
var
i : integer;
l : integer;
id : string;
loc: string;
dsc: string;
begin
i := 1;
l := Length(InstanceId);
while (i<=l) and (InstanceId[i] <> '\') do
inc(i);
inc(i);
while (i<=l) and (InstanceId[i] <> '\') do
begin
id := id + InstanceId[i];
inc(i)
end;
inc(i);
while (i<=l) and (InstanceId[i] <> '#') do
begin
loc := loc + InstanceId[i];
inc(i)
end;
inc(i);
while (i<=l) do
begin
dsc := dsc + InstanceId[i];
inc(i)
end;
if @VendorID <> nil then
VendorId := StrToInt('$'+Copy( id, 5, 4));
ProductId := StrToInt('$'+Copy( id, 14, 4));
Location := loc;
Description := dsc
end;
{ TUsbDeviceDescriptor }
// @@@: UsbDeviceDescriptor +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
@@ -427,7 +403,7 @@ end;
// ================================================================================================
// constructor
// ================================================================================================
constructor TUsbDeviceDescriptor.Create(DevicePath: string);
constructor TUsbDeviceDescriptor.Create( DevicePath: string);
var
vid: word;
pid: word;
@@ -439,7 +415,8 @@ begin
fAllocated := false;
fDevicePath := DevicePath;
ParseInstanceId( fDevicePath, vid, pid, fLocation, dsc)
if not ParseDevicePath( fDevicePath, vid, pid, fLocation, dsc) then
fLocation := ''
end;
// ================================================================================================
@@ -490,8 +467,258 @@ begin
result := fDeviceSetup.Description
end;
{ TDeviceManager }
// ================================================================================================
// constructor
// ================================================================================================
constructor TDeviceManager.Create;
begin
inherited;
fUsbDeviceSetups := TCollections.CreateDictionary< cardinal, TUsbDeviceSetup> ([doOwnsValues]);
fUsbDevices := TCollections.CreateDictionary< string, TUsbDeviceDescriptor>([doOwnsValues]);
fUsbNotifiers := TCollections.CreateDictionary< string, TusbNotifier> ([doOwnsValues]);
end;
// ================================================================================================
// destructor
// ================================================================================================
destructor TDeviceManager.Destroy;
begin
fUsbDeviceSetups := nil;
fUsbDevices := nil;
fUsbNotifiers := nil;
inherited
end;
// ================================================================================================
// get device list
// ================================================================================================
procedure TDeviceManager.GetDeviceList( ACallback : GetDeviceListCallback;
AVendorID : word = 0;
AProductID: word = 0);
begin
for var udd in fUsbDevices.Values do
if ((AVendorID = 0) and (AProductID = 0)) or
((AVendorID = udd.VendorID) and (AProductID = udd.ProductID)) then
with udd do
if not ACallback( VendorID, ProductID, Description, Location, DevicePath) then
break
end;
// ================================================================================================
// allocate device
// ================================================================================================
function TDeviceManager.AllocateDevice( ADevicePath: string): TUsbDevice;
var
udd: TUsbDeviceDescriptor;
begin
result := nil;
assert( fUsbDeviceSetups <> nil);
assert( fUsbDevices <> nil);
if fUsbDevices.TryGetValue( ADevicePath, udd) then
begin
if not udd.Allocated then
begin
var ds := udd.DeviceSetup;
assert( ds <> nil);
if (ds.DriverClass <> nil) and (ds.DeviceClass <> nil) then
begin
udd.Allocated := true;
var drv := ds.DriverClass.Create( udd.DevicePath);
var dev := ds.DeviceClass.Create( drv);
exit(dev)
end
end
else begin
udd.Allocated := true
end;
end
end;
// ================================================================================================
// deallocate device
// ================================================================================================
procedure TDeviceManager.DeallocateDevice( ADevice: TUsbDevice);
var
udd: TUsbDeviceDescriptor;
begin
if ADevice <> nil then
begin
if fUsbDevices.TryGetValue( ADevice.DevicePath, udd) then
udd.Allocated := false;
FreeAndNil( ADevice)
end
end;
// ================================================================================================
// register driver
// ================================================================================================
procedure TDeviceManager.RegisterDriver( ADriverClass: TUsbDriverClass);
begin
if Assigned( ADriverClass) then
begin
// --------------------------------------------------
// register for usb arrival/removal notifications
// --------------------------------------------------
var guid := ADriverClass.InterfaceGUID;
if guid <> '' then
begin
if not fUsbNotifiers.ContainsKey( guid) then
begin
var noti := TusbNotifier.Create( guid, ADriverClass);
noti.OnUSBArrival := DoUsbArrival;
noti.OnUSBRemove := DoUsbRemoval;
fUsbNotifiers.Add( guid, noti);
end;
// --------------------------------------------------
// scan for already connected devices
// --------------------------------------------------
ADriverClass.Scan(
procedure( ADevicePath: string)
var
vid : word;
pid : word;
loc : string;
dsc : string;
uds : TUsbDeviceSetup;
begin
ParseDevicePath( ADevicePath, vid, pid, loc, dsc);
var key := (vid shl 16) + pid;
// --------------------------------------------------------------
// add or update (override) an usb device setup entry
// --------------------------------------------------------------
if not fUsbDeviceSetups.TryGetValue( key, uds) then
begin
uds := TUsbDeviceSetup.Create;
uds.VendorID := vid;
uds.ProductID := pid;
fUsbDeviceSetups.Add( key, uds)
end;
uds.DriverClass := ADriverClass;
uds.Description := dsc;
// --------------------------------------------------------------
// add usb device
// --------------------------------------------------------------
if not fUsbDevices.ContainsKey( ADevicePath) then
begin
var udd := TUsbDeviceDescriptor.Create( ADevicePath);
udd.DeviceSetup := uds;
fUsbDevices.Add( ADevicePath, udd)
end
end)
end
end
end;
// ================================================================================================
// register device
// ================================================================================================
procedure TDeviceManager.RegisterDevice( AVendorID : word;
AProductID : word;
ACapabilities : int64;
ADeviceClass : TUsbDeviceClass);
var
key: cardinal;
uds: TUsbDeviceSetup;
begin
key := (AVendorID shl 16) + AProductID;
if not fUsbDeviceSetups.TryGetValue( key, uds) then
begin
uds := TUsbDeviceSetup.Create;
uds.VendorID := AVendorID;
uds.ProductID := AProductID;
fUsbDeviceSetups.Add( key, uds);
end;
uds.DeviceClass := ADeviceClass;
end;
// ================================================================================================
// USB device connected
// ================================================================================================
procedure TDeviceManager.DoUsbArrival( ADevicePath: string; ADriverClass: TUsbDriverClass);
var
vid : word;
pid : word;
loc : string;
dsc : string;
uds : TUsbDeviceSetup;
udd : TUsbDeviceDescriptor;
begin
ADevicePath := Uppercase( ADevicePath);
ParseDevicePath( ADevicePath, vid, pid, loc, dsc);
// --------------------------------------------------------------
// add device
// --------------------------------------------------------------
var key := (vid shl 16) + pid;
if fUsbDeviceSetups.TryGetValue( key, uds) then
begin
if not Assigned( uds.DriverClass) then
uds.DriverClass := ADriverClass;
if not fUsbDevices.ContainsKey( ADevicePath) then
begin
udd := TUsbDeviceDescriptor.Create( ADevicePath);
udd.DeviceSetup := uds;
fUsbDevices.Add( ADevicePath, udd);
if Assigned( fOnDeviceArrival) then
fOnDeviceArrival( ADevicePath)
end
end
end;
// ================================================================================================
// USB device disconnected
// ================================================================================================
procedure TDeviceManager.DoUsbRemoval( ADevicePath: string; ADriverClass: TUsbDriverClass);
begin
ADevicePath := Uppercase( ADevicePath);
if fUsbDevices.ContainsKey( ADevicePath) then
begin
if Assigned( fOnDeviceRemoval) then
fOnDeviceRemoval( ADevicePath);
fUsbDevices.Remove( ADevicePath)
end
end;
initialization
finalization
if gDeviceManager <> nil then
gDeviceManager.Free
end.