unit MAHUSBUtils;
  (* from http://delphi.cjcsoft.net/viewthread.php?tid=48860 *)

  interface
    uses
      Messages (* tMessage, WM_DEVICECHANGE *),
      Windows  (* DefWindowProc, DEVICE_NOTIFY_WINDOW_HANDLE,
                    HKEY_LOCAL_MACHINE, hWND, RegisterDeviceNotification,
                    ZeroMemory *);

    type
      tUSBInfo = record
        VID: string;
        PID: string;
        DeviceType: string;
        SerialNumber: string;
        DriverName: string;
        FriendlyName: string;
        RRFCPU: integer;
        end (* tUSBInfo *);

      tTeensy35PortInfo = record
        AssociatedTeensy: boolean;
        SN: string;
        RRFCPU: integer;
        end (* tTeensy35PortInfo *);

    type
      tOnUSBChangeEvent =
         procedure(Sender: tObject; const USBInfo: tUSBInfo) of object;

      tUSB = class(tObject)
        private
          fHandle : hWND;
          fOnUSBRemoval, fOnUSBInsertion : tOnUSBChangeEvent;
          procedure GetUSBInfo(const DeviceString : string; out USBInfo: tUSBInfo);
          procedure RegisterUSBHandler;
          procedure WinMethod(var TheMessage : tMessage);
          procedure WMDeviceChange(var TheMessage : tMessage);
        public
          constructor Create;
          destructor Destroy; override;
          property OnUSBInsertion: tOnUsbChangeEvent read  fOnUsbInsertion
                                                     write fOnUsbInsertion;
          property OnUsbRemoval : tOnUsbChangeEvent read fOnUsbRemoval
                                                    write fOnUsbRemoval;
        end (* tUSB *);

    function TeensySerialNumber(const COMxx: string): tTeensy35PortInfo;

  implementation
    uses
      Classes  (* AllocateHWnd, DeallocateHWnd, tStringList *),
//      Dialogs  (* ShowMessageFmt *),
      Masks    (* MatchesMask *),
      MyConsts (* nullstring, SHARP, STAR *),
      Registry (* tRegistry *),
      SysUtils (* Format *);

    const
      USBkeyFormat    = 'SYSTEM\CurrentControlSet\Enum\USB\%s\%s';
      USBStoreKey     = 'SYSTEM\CurrentControlSet\Enum\USBSTOR';
      SubKeyFormat    = USBStoreKey + '\%s';
      SubSubKeyFormat = SubKeyFormat + '\%s';
      USBInterface    = $00000005; // Device interface class

    type
      tDeviceBroadcastInterface = record
        Size: dword;
        DeviceType: dword;
        Reserved: dword;
        ClassGUID: tGUID;
        Name: char;
        end (* tDeviceBroadcastInterface *);
      tpDeviceBroadcastInterface = ^tDeviceBroadcastInterface;

{ tUSB }

    constructor tUSB.Create;
      (* constructor *)
    
      begin (* tUSB.Create *)
        inherited Create;
        fHandle := AllocateHWnd(WinMethod);
        RegisterUSBHandler
      end   (* tUSB.Create *);

    destructor tUSB.Destroy;
      (* destructor *)
    
      begin (* tUSB.Destroy *)
        DeallocateHWnd(fHandle);
        inherited Destroy
      end   (* tUSB.Destroy *);

    procedure tUSB.GetUSBInfo(const DeviceString: string;
                              out USBInfo: tUSBInfo);
      (* xxx *)
    
      var
        Found: boolean;
        Registry: tRegistry;
        SN, USBKey, VIDPID: string;
        Keys, SubKeys: tStringList;

      procedure FindKeyToMatchSN;
        (*  Get list of keys in \USBSTOR and look for a key that matches our
          SN ='0005050400044'
            The entry we are looking for normally has '&0' appended to it,
             eg. '0005050400044&0'
        *)

        var
          I, J: integer;
          SubKey, SubSubKey: string;

        begin (* FindKeyToMatchSN *)
          // ShowMessageFmt('Looking for "%s"', [SN]);
          USBInfo.SerialNumber := SN;
          if SN <> nullstring then
            USBInfo.SerialNumber := copy(SN, 1, length(SN)-1);
          with Registry do
            if OpenKeyReadOnly(USBStoreKey) then
              begin (* in USBStore *)
                // ShowMessageFmt('  2 Looking in %s', [USBStoreKey]);
                GetKeyNames(Keys);
                CloseKey;

                for I := 1 to Keys.Count do
                  begin (* check key #I *)
                    SubKey := Format(SubKeyFormat, [Keys[I-1]]);
                    if OpenKeyReadOnly(SubKey) then
                      begin (* get subkeys *)
                        // ShowMessageFmt('    3 Looking in %s', [USBStoreKey]);
                        GetKeyNames(SubKeys);
                        CloseKey;
                        for J := 1 to SubKeys.Count do
                          begin (* check subkey #J *)
                            if MatchesMask(SubKeys[J-1], SN + STAR) then
                              begin (* got a match *)
                                SubSubKey := Format(SubSubKeyFormat,
                                                    [Keys[I-1], SubKeys[J-1]]);
                                if OpenKeyReadOnly(SubSubKey) then
                                  begin (* get data *)
                                    USBInfo.DriverName := ReadString('DeviceDesc');
                                    // USBInfo.FriendlyName := ReadString('FriendlyName');
                                    CloseKey;
                                  end   (* get data *);

                                Found := true
                              end   (* got a match *)
                          end   (* check subkey #J *)
                      end   (* get subkeys *);
                    if Found then
                      break
                  end   (* check key #I *)
              end   (* in USBStore *)
        end   (* FindKeyToMatchSN *);

      procedure ParseDeviceString;
        (* Extract the portions of the string we need for registry. eg.
             \\?\USB#Vid_4146&Pid_d2b5#0005050400044#{a5dcbf10- ..... -54334fb951ed}
                                     11111111
                            12345678901234567
           We need VID_PID='Vid_4146&Pid_d2b5'
                   SN ='0005050400044'
        *)

        var
          SharpPos: integer;
          AfterSharp: string;

        begin (* ParseDeviceString *)
          SharpPos    := pos(SHARP, DeviceString);
          AfterSharp  := copy(DeviceString, SharpPos+1, maxint); // VIDPID#Code#etc
          SharpPos    := pos(SHARP, AfterSharp);
          VIDPID      := copy(AfterSharp, 1, SharpPos-1);
          USBInfo.VID := copy(VIDPID,  5, 4);
          USBInfo.PID := copy(VIDPID, 14, 4);
          AfterSharp  := copy(AfterSharp, SharpPos+1, maxint);  // Code#etc
          SharpPos    := pos(SHARP, AfterSharp);
          SN          := copy(AfterSharp, 1, SharpPos-1);
        end   (* ParseDeviceString *);

      begin (* tUSB.GetUSBInfo *)
        with USBInfo do
          begin (* USBInfo *)
            DeviceType   := nullstring;
            DriverName   := nullstring;
            FriendlyName := nullstring;
            RRFCPU := 0;
            VID := nullstring;
            PID := nullstring
          end   (* USBInfo *);

        if DeviceString <> nullstring then
          begin (* -1 nondegenerate *)
            Found := false;
            Registry := tRegistry.Create;
            with Registry do
              try     (* must free Registry *)
                RootKey := HKEY_LOCAL_MACHINE;
                ParseDeviceString;
                USBKey := Format(USBKeyFormat, [VIDPID, SN]);
                if OpenKeyReadOnly(USBKey) then
                  begin (* get device-type description *)
                    // ShowMessageFmt('Looking in %s', [USBKey]);
                    USBInfo.DeviceType := ReadString('DeviceDesc');
                    USBInfo.FriendlyName := ReadString('FriendlyName');
                    if ValueExists('RRFCPU') then
                      USBInfo.RRFCPU := ReadInteger('RRFCPU');
                    Registry.CloseKey;
                    Keys := tStringList.Create;
                    try     (* must release Keys *)
                      SubKeys := tStringList.Create;
                      try      (* must release SubKeys *)
                        FindKeyToMatchSN
                      finally (* must release SubKeys *)
                        FreeAndNil(SubKeys)
                      end     (* must release SubKeys *)
                    finally (* must release Keys *)
                      FreeAndNil(Keys);
                    end     (* must release Keys *)
                  end   (* get device-type description *);
              finally (* must free Registry *)
                FreeAndNil(Registry)
              end     (* must free Registry *)
          end   (* -1 nondegenerate *)
      end   (* tUSB.GetUSBInfo *);

                                                                 {$WARNINGS OFF}
    procedure tUSB.RegisterUsbHandler;
      (* xxx *)

      const
        USBGUID: tGUID = '{A5DCBF10-6530-11D2-901F-00C04FB951ED}';

      var
        DeviceBroadcastInterface: tDeviceBroadcastInterface;
        DBISize : integer;

      begin (* tUSB.RegisterUsbHandler *)
        DBISize := sizeof(tDeviceBroadcastInterface);
        ZeroMemory(@DeviceBroadcastInterface, DBISize);
        with DeviceBroadcastInterface do
          begin (* DeviceBroadcastInterface *)
            Size := DBISize;
            DeviceType := USBInterface;
            Reserved := 0;
            ClassGUID := USBGUID;
            Name := #0
          end   (* DeviceBroadcastInterface *);

        RegisterDeviceNotification(fHandle, @DeviceBroadcastInterface,
                                     DEVICE_NOTIFY_WINDOW_HANDLE)
      end   (* tUSB.RegisterUsbHandler *);
                                                                 {$WARNINGS ON}

    function TeensySerialNumber(const COMxx: string): tTeensy35PortInfo;
      (* does this COM port have a Teensy Association?
      This works only for Teensy 3.5.  Teensy 3.2s have the same
      VID and PID 0486, but NO FriendlyName in the Registry, and no COMxx
      anywhere.  Teensy 4.1s don't have FriendlyNames either.
      *)

      const
        SNsKey = 'SYSTEM\CurrentControlSet\Enum\USB\VID_16C0&PID_0483';

      var
        I: integer;
        Registry: tRegistry;
        FriendlyName, Probe, SN, SNKey: string;
        SNs: tStringList;

      begin (* TeensySerialNumber *)
        Result.AssociatedTeensy := false;
        Result.RRFCPU := 0;
        Probe := Format('(%s)', [COMxx]);
        Registry := tRegistry.Create;
        try     (* must free Registry *)
          Registry.RootKey := HKEY_LOCAL_MACHINE;
          with Registry do
            if OpenKeyReadOnly(SNsKey) then
              begin (* look among Teensies *)
                SNs := tStringList.Create();
                try     (* must release SNs *)
                  GetKeyNames(SNs);
                  CloseKey;  // SNsKey
                  for I := 1 to SNs.Count do
                    begin (* look at Teensy #I *)
                      SN := SNs[I-1];
                      SNKey := Format('%s\%s', [SNsKey, SN]);
                      // ShowMessageFmt('Looking in %s', [TeensyKey]);
                      if OpenKeyReadOnly(SNKey) then
                        begin (* one Teensy *)
                          if ValueExists('FriendlyName') then
                            begin (* look here *)
                              FriendlyName := ReadString('FriendlyName');
                              // ShowMessageFmt('FN(%s) = %s', [SN, FriendlyName]);
                              if pos(Probe, FriendlyName) > 0 then
                                begin (* success *)
                                  Result.AssociatedTeensy := true;
                                  Result.SN := SN;
                                  if ValueExists('RRFCPU') then
                                    Result.RRFCPU := ReadInteger('RRFCPU');
                                  break
                                end   (* success *)
                            end   (* look here *);
                          CloseKey  // SNKey
                        end   (* one Teensy *)
                    end   (* look at Teensy #I *)
                finally (* must release Teensies *)
                  FreeAndNil(SNs)
                end     (* must release Teensies *)
              end   (* look among Teensies *)
        finally (* must free Registry *)
          FreeAndNil(Registry)
        end     (* must free Registry *)
      end   (* TeensySerialNumber *);

    procedure tUSB.WinMethod(var TheMessage: tMessage);
      (* xxx *)

      begin (* tUSB.WinMethod *)
        if TheMessage.Msg = WM_DEVICECHANGE then
          WMDeviceChange(TheMessage)
        else
          TheMessage.Result := DefWindowProc(fHandle, TheMessage.Msg,
                                             TheMessage.wParam,
                                             TheMessage.lParam)
      end   (* tUSB.WinMethod *);

    procedure tUSB.WMDeviceChange(var TheMessage: tMessage);
      (* xxx *)


      const
        USBInserted = $8000;     // System detected a new device
        USBRemoved  = $8004;     // Device is gone

      var
        DevType: integer;
        pData: tpDeviceBroadcastInterface;
        DeviceName: string;
        USBInfo: tUSBInfo;

      procedure MightTrigger(const WParameter: integer;
                             TheEvent: tOnUSBChangeEvent);
        (* trigger if pertinent & assigned *)

        begin (* MightTrigger *)

          if TheMessage.WParam = WParameter then
            if Assigned(TheEvent) then
              TheEvent(self, USBInfo)
        end   (* MightTrigger *);
                                                                 {$WARNINGS OFF}

      begin (* tUSB.WMDeviceChange *)
        if (TheMessage.wParam = USBInserted) or
           (TheMessage.wParam = USBRemoved) then
          begin (* action needed *)
            pData := tpDeviceBroadcastInterface(TheMessage.LParam);
            DevType := pData^.DeviceType;
            if DevType = USBInterface then
              begin (* USB-interface device *)
                DeviceName := pChar(@pData^.Name);
                GetUSBInfo(DeviceName, USBInfo);
                MightTrigger(USBInserted, fOnUSBInsertion);
                MightTrigger(USBRemoved,  fOnUSBRemoval)
              end   (* USB-interface device *)
          end   (* action needed *)
      end   (* tUSB.WMDeviceChange *);
                                                                 {$WARNINGS ON}
end.
