Files
bds.mr.devmgr/src.devmgr/mr.dev.manager.pas
T
2026-01-08 19:04:51 +01:00

725 lines
24 KiB
ObjectPascal

// Device manager uses WinUSB driver by default!!!
unit mr.dev.manager;
interface
uses
System.Classes,
mr.drv.usb,
mr.dev.usb;
type
GetDeviceListCallback = reference to function( VendorID : word;
ProductID : word;
Description : string;
Location : string;
DevicePath : string): boolean;
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
Winapi.Windows,
System.SysUtils,
System.Win.Registry,
Spring.Collections,
mr.drv.usb.notifier;
// SysUtils,
// Generics.Collections,
// drv.usb.winusb,
// dev.usb.trinity,
// dev.usb.trinity.utils;
//
//type
//
//type
// TUsbDriverMap = TDictionary <AnsiString, TUsbDriverClass>;
// TUsbDeviceMap = TObjectDictionary<AnsiString, TUsbDeviceInfo>;
//
//var
// UsbDriverAlloc : TUsbDriverMap = nil;
// UsbDriverMap : TUsbDriverMap = nil;
// UsbDeviceMap : TUsbDeviceMap = nil;
//
//
type
TUsbDeviceSetup = class
strict protected
fDriverClass : TUsbDriverClass;
fDeviceClass : TUsbDeviceClass;
fVendorID : word;
fProductID : word;
fDescription : string;
public
property DriverClass : TUsbDriverClass read fDriverClass write fDriverClass;
property DeviceClass : TUsbDeviceClass read fDeviceClass write fDeviceClass;
property VendorID : word read fVendorID write fVendorID;
property ProductID : word read fProductID write fProductID;
property Description : string read fDescription write fDescription;
end;
TUsbDeviceDescriptor = class
strict protected
fDeviceSetup : TUsbDeviceSetup;
fDevicePath : string;
fLocation : string;
fAllocated : boolean;
strict protected
function GetDriverClass : TUsbDriverClass;
function GetDeviceClass : TUsbDeviceClass;
function GetDescription : string;
function GetVendorID : word;
function GetProductID : word;
public
constructor Create( DevicePath: string); reintroduce;
destructor Destroy; override;
public
property Allocated : boolean read fAllocated write fAllocated;
property DeviceSetup : TUsbDeviceSetup read fDeviceSetup write fDeviceSetup;
property DevicePath : string read fDevicePath;
property Location : string read fLocation;
property VendorID : word read GetVendorId;
property ProductID : word read GetProductID;
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
gDeviceManager: TDeviceManager;
function DeviceManager: TDeviceManager; forward;
procedure RegisterUsbConnectEventHandler( AEventHandler: DeviceConnectEvent);
begin
DeviceManager.OnDeviceArrival := AEventHandler
end;
procedure RegisterUsbDisconnectEventHandler( AEventHandler: DeviceConnectEvent);
begin
DeviceManager.OnDeviceRemoval := AEventHandler;
end;
// ================================================================================================
// parse device path
//
// '\\?\USB#VID_04B4&PID_8613#7&2ec9f839&0&17#{cdde880f-898a-4dab-b0ea-51fba32c1d82}'
// ================================================================================================
function ParseDevicePath( InstanceId : string;
var VendorID : word;
var ProductID : word;
var Location : string;
var Description : string): boolean;
var
id : string;
loc: string;
dsc: string;
begin
result := false;
if Copy( InstanceId, 1, 8) = '\\?\USB#'
then InstanceId := Copy( InstanceId, 9)
else exit;
var items := InstanceId.Split(['#']);
if Length(items) = 3 then
begin
id := items[0];
loc := items[1];
dsc := items[2];
end
else
exit;
var ids := id.Split(['&']);
if Length(ids) = 2 then
begin
VendorID := StrToInt('$'+Copy( ids[0], 5, 4));
ProductID := StrToInt('$'+Copy( ids[1], 5, 4));
end
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;
SetLength( items, 0);
SetLength( ids, 0);
result := true
end;
// ================================================================================================
// DeviceManager (singleton pattern)
// ================================================================================================
function DeviceManager: TDeviceManager;
begin
if gDeviceManager = nil then
gDeviceManager := TDeviceManager.Create;
result := gDeviceManager
end;
// ================================================================================================
// register driver
// ================================================================================================
procedure RegisterDriver( ADriverClass: TUsbDriverClass);
begin
DeviceManager.RegisterDriver( ADriverClass)
end;
// ================================================================================================
// 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( ACallback : GetDeviceListCallback;
AVendorID : word = 0;
AProductID : word = 0);
begin
DeviceManager.GetDeviceList( ACallback, AVendorID, AProductID)
end;
// ================================================================================================
// Allocate Device
// ================================================================================================
function AllocateDevice( ADevicePath : string): TUsbDevice;
begin
result := DeviceManager.AllocateDevice( ADevicePath)
end;
// ================================================================================================
// Deallocate Device
// ================================================================================================
procedure DeallocateDevice( var ADevice: TUsbDevice);
begin
DeviceManager.DeallocateDevice( ADevice)
end;
//// ================================================================================================
//// allocate device by serial number
//// ================================================================================================
//function AllocateDeviceBySN( SerialNumber: AnsiString;
// Capabilities: TCapabilities = [];
// IgnoreCap : boolean = false): TUsbDevice;
//var
// vid : word;
// pid : word;
// loc : string;
// dsc : string;
//
// drv : TUsbDriver;
// drvc : TUsbDriverClass;
//
// dev : TUsbDevice;
// devc : TUsbDeviceClass;
//
// tri : TTrinity;
// inf : TUsbDeviceInfo;
// cap : TCapabilities;
// sn : AnsiString;
//
// path : AnsiString;
//
//begin
// result := nil;
//
// if Assigned( UsbDriverMap) and Assigned(UsbDeviceMap) then
// begin
// for path in UsbDriverMap.Keys do
// begin
// ParseInstanceID( path, vid, pid, loc, dsc);
//
// drvc := UsbDriverMap.Items[path];
// devc := nil;
// cap := [];
//
// if (vid = $16d0) and (pid = $0712) then
// begin
// try
// drv := drvc.Create(path);
// tri := TTrinity.Create(drv);
//
// tri.Open;
// cap := tri.Capabilities;
// sn := tri.SerialNumber;
// tri.Close;
//
// tri.Free;
//
// except
//
// end;
// end;
//
// for inf in UsbDeviceMap.Values do
// if (inf.VendorID = vid) and (inf.ProductID = pid) then
// if (inf.Capabilities * cap = cap) or IgnoreCap then
// begin
// if sn = SerialNumber then
// begin
// devc := inf.DeviceClass;
// break;
// end;
// end;
//
// if Assigned(devc) then
// begin
// drv := drvc.Create(path);
// dev := devc.Create(drv);
//
// if not Assigned( UsbDriverAlloc) then
// UsbDriverAlloc := TUsbDriverMap.Create;
//
// UsbDriverAlloc.Add( path, drvc);
// UsbDriverMap.Remove(path);
//
// result:= dev;
// end;
// end
// end
//end;
//
{ TUsbDeviceDescriptor }
// @@@: UsbDeviceDescriptor +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//
// UsbDeviceDescriptor
//
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// ================================================================================================
// constructor
// ================================================================================================
constructor TUsbDeviceDescriptor.Create( DevicePath: string);
var
vid: word;
pid: word;
dsc: string;
begin
inherited Create;
fAllocated := false;
fDevicePath := DevicePath;
if not ParseDevicePath( fDevicePath, vid, pid, fLocation, dsc) then
fLocation := ''
end;
// ================================================================================================
// destructor
// ================================================================================================
destructor TUsbDeviceDescriptor.Destroy;
begin
inherited;
end;
// ================================================================================================
// get driver class
// ================================================================================================
function TUsbDeviceDescriptor.GetDriverClass: TUsbDriverClass;
begin
result := fDeviceSetup.DriverClass
end;
// ================================================================================================
// get device class
// ================================================================================================
function TUsbDeviceDescriptor.GetDeviceClass: TUsbDeviceClass;
begin
result := fDeviceSetup.DeviceClass
end;
// ================================================================================================
// get vendor ID
// ================================================================================================
function TUsbDeviceDescriptor.GetVendorID: word;
begin
result := fDeviceSetup.VendorID
end;
// ================================================================================================
// get product ID
// ================================================================================================
function TUsbDeviceDescriptor.GetProductID: word;
begin
result := fDeviceSetup.ProductID
end;
// ================================================================================================
// get description
// ================================================================================================
function TUsbDeviceDescriptor.GetDescription: string;
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.