perl et win32::api (fonctions windows)

perl et win32::api (fonctions windows) - Perl - Programmation

Marsh Posté le 22-02-2011 à 11:27:49    

Bonjour,
 
Je ne sais pas si il y a un grand guru du perl qui a qq notions en C sur ce forum mais sinon j'aurai besoin d'un peu (beaucoup) d'aide pour  
 pouvoir mettre en oeuvre les fonctions "SHSetKnownFolderPath" et "SHChangeNotify" (pour pouvoir rediriger partiellement le profil utilisateur).
 
http://msdn.microsoft.com/en-us/li [...] S.85).aspx

Code :
  1. HRESULT SHSetKnownFolderPath(
  2.   __in  REFKNOWNFOLDERID rfid,
  3.   __in  DWORD dwFlags,
  4.   __in  HANDLE hToken,
  5.   __in  PCWSTR pszPath
  6. );


 
http://msdn.microsoft.com/en-us/li [...] S.85).aspx

Code :
  1. void SHChangeNotify(
  2.             LONG wEventId,
  3.             UINT uFlags,
  4.   __in_opt  LPCVOID dwItem1,
  5.   __in_opt  LPCVOID dwItem2
  6. );


 
Voici 1 exemple concret en C :
http://social.msdn.microsoft.com/F [...] 1faea3fbbd
 
J'ai testé un autre exemple en autoit mais cette fois ci avec la fonction SHGetKnownFolderPath :
http://www.autoitscript.com/forum/ [...] _p__489845
* on trouve beaucoup d'exemples de fonctions implémentées via "autoit" (du coup ça renseigne sur les types, structures et constantes).
 
Pour obtenir le "REFKNOWNFOLDERID", il faut utiliser la fonction "CLSIDFromString" :

Code :
  1. HRESULT CLSIDFromString(
  2.   LPOLESTR lpsz,
  3.   LPCLSID pclsid
  4. );


 
Le pointeur "pclsid" référence à priori une structure du type 'lssC8' (j'ai traduit d'autoit en perl pack) :
http://www.autoitscript.com/autoit [...] agGUID.htm
http://www.autoitscript.com/autoit [...] Create.htm
http://perldoc.perl.org/functions/pack.html
 
Du coup, pour l'instant j'en suis là (mais je n'arrive pas à récupérer le clsid) :

Code :
  1. use strict;
  2. use Win32;
  3. use Win32::API;
  4. $Win32::API::DEBUG = 1;
  5. # intialisation du pointeur
  6. my $pclsid = pack ('lssC8', "x\00" );
  7. # initialisation de la fonction
  8. my $CLSIDFromString = new Win32::API("Ole32", 'CLSIDFromString', 'NP', 'N') || die;
  9. # appel de la fonction
  10. $CLSIDFromString->Call('{4BD8D571-6D19-48D3-BE97-422220080E43}', $pclsid );


 
Merci d'avance pour votre aide !!!

Reply

Marsh Posté le 22-02-2011 à 11:27:49   

Reply

Marsh Posté le 22-02-2011 à 23:48:41    

:hello:  
Bon ben tu me devras un apéro, car je m'en suis sorti, mais ça n'a pas été particulièrement simple.
Ton problème à la base venait de ce que tu n'avais pas encodé en wide_char les chaines passées aux fonctions OLE (ça je l'avais tout de suite vu, mais il y'avait un gros piège de chaines qui bien que OLE n'avaient pas un 0 a la fin et ça il m'a fallu plusieurs heures pour le comprendre)
Bon, tant que j'y étais, j'ai testé CLSIDFromProgID, StringFromCLSID et CLSIDFromString (la plus récalcitrante) et j'ai ajouté une petite procédure StringIDToClassID pure perl qui fait la même chose que cette dernière, a partir d'une string ansi.
Ton second problème était que le paramètre P dans Win32::API fait qu'on va avoir un passage par adresse du paramètre lors de l'appel ultérieur à la fonction de la DLL. Il fallait donc poser new Win32::API("OLE32", 'CLSIDFromString', 'PP', 'N')
 

Code :
  1. #!/usr/local/bin/perl
  2. use strict;
  3. use warnings;
  4.  
  5. use Win32;
  6. use Win32::API;
  7. $Win32::API::DEBUG = 1;
  8.  
  9.  
  10. my $MultiByteToWideChar = new Win32::API("KERNEL32", "MultiByteToWideChar", "INPIPI", "I" ) or die "Can't Import OLE32 or find MultiByteToWideChar";
  11. my $CLSIDFromProgID = new Win32::API("OLE32", "CLSIDFromProgID", "PP", "N" ) or die "Can't Import OLE32 or find CLSIDFromProgID";
  12. my $StringFromCLSID = new Win32::API("OLE32", "StringFromCLSID", "PP", "N" ) or die "Can't Import OLE32 or find StringFromCLSID";
  13. my $CLSIDFromString = new Win32::API("OLE32", "CLSIDFromString", "PP", "N" ) || die "Can't find CLSIDFromString: $!\n";
  14.  
  15.  
  16. # On va tester avec ce cas trouve dans la base de registres
  17. #WMP.DeskBand.1 <= ProgID
  18. #HKEY_LOCAL_MACHINE\SOFTWARE\Classes\CLSID\{0A4286EA-E355-44FB-8086-AF3DF7645BD9} <= Windows Media Player
  19.  
  20. my $progid = "WMP.DeskBand.1";
  21. my $oleprogid = COlestr($progid); # translate it to wide chars
  22. my $classid = "\0" x 16; # 16 bytes data
  23.  
  24. my $result = $CLSIDFromProgID->Call($oleprogid, $classid );
  25. if ($result) {
  26.    printf "Error: 0x%x\n", $result;
  27. }
  28. else {
  29.    # vérifions que l'appel a marche
  30.    my ($data1, $data2, $data3, $data4, $data5, $data6, $data7, $data8, $data9, $data10, $data11) = unpack 'LSSC8', $classid;
  31.    printf "{%x-%x-%x-%x%x-%x%x%x%x%x%x}\n", $data1, $data2, $data3, $data4, $data5, $data6, $data7, $data8, $data9, $data10, $data11;
  32.    # on devrait avoir {0A4286EA-E355-44FB-8086-AF3DF7645BD9}
  33. }
  34.  
  35. my $PPV = pack 'P', 0; # au retour, contiendra la OLESTR allouee
  36. my $ppv = pack 'P', $PPV; # C'est tordu, fallait le trouver, pour le parametre LPOLESTR *
  37. $result = $StringFromCLSID->Call($classid, $ppv);
  38. if ($result) {
  39.    printf "Error: 0x%x\n", $result;
  40. }
  41. else {
  42.    $PPV = unpack 'P[76]', $ppv;
  43.    print $PPV, "\n";
  44.    # on devrait avoir {0A4286EA-E355-44FB-8086-AF3DF7645BD9} chaque lettre occupant 2 cases
  45. }
  46. # note: $PPV doit etre desalloué par un appel a OLE si on est un bon petit programmeur
  47. # respectueux de la mémoire qui ne lui appartient pas...
  48.  
  49. my $newstring = $PPV . "\0"; # le retour etait un OLESTR, pas un COLESTR et c'etait un piege
  50. $classid = "\0" x 16; # 16 bytes data
  51. $result = $CLSIDFromString->Call($newstring, $classid);
  52.  
  53. if ($result) {
  54.    printf "Error: 0x%x\n", $result;
  55. }
  56. else {
  57.    my ($data1, $data2, $data3, $data4, $data5, $data6, $data7, $data8, $data9, $data10, $data11) = unpack 'LSSC8', $classid;
  58.    printf "{%x-%x-%x-%x%x-%x%x%x%x%x%x}\n", $data1, $data2, $data3, $data4, $data5, $data6, $data7, $data8, $data9, $data10, $data11;
  59.    # on devrait avoir {0A4286EA-E355-44FB-8086-AF3DF7645BD9}
  60. }
  61.  
  62. #test avec une string en ascii
  63. $newstring = '{0A4286EA-E355-44FB-8086-AF3DF7645BD9}';
  64. $oleprogid = COlestr($newstring);
  65. $classid = "\0" x 16; # 16 bytes data
  66. $result = $CLSIDFromString->Call($oleprogid, $classid);
  67.  
  68. if ($result) {
  69.    printf "Error: 0x%x\n", $result;
  70. }
  71. else {
  72.    my ($data1, $data2, $data3, $data4, $data5, $data6, $data7, $data8, $data9, $data10, $data11) = unpack 'LSSC8', $classid;
  73.    printf "{%x-%x-%x-%x%x-%x%x%x%x%x%x}\n", $data1, $data2, $data3, $data4, $data5, $data6, $data7, $data8, $data9, $data10, $data11;
  74.    # on devrait avoir {0A4286EA-E355-44FB-8086-AF3DF7645BD9}
  75. }
  76.  
  77. # la subroutine perl StringIDToClassID fait aussi bien
  78. $newstring = '{0A4286EA-E355-44FB-8086-AF3DF7645BD9}';
  79. my $refclsid = StringIDToClassID($newstring);
  80. $PPV = pack 'P', 0;
  81. $ppv = pack 'P', $PPV;
  82. $result = $StringFromCLSID->Call($refclsid, $ppv);
  83.  
  84. if ($result) {
  85.    printf "Error: 0x%x\n", $result;
  86. }
  87. else {
  88.    $PPV = unpack 'P[76]', $ppv;
  89.    print $PPV, "\n";
  90.    # on devrait avoir {0A4286EA-E355-44FB-8086-AF3DF7645BD9} chaque lettre occupant 2 cases
  91. }
  92.  
  93.  
  94. # transforme une chaine en ansi en une en wide chars
  95. sub Olestr {
  96.    my $ansistr = shift;
  97.    my $lg = length($ansistr);
  98.    my $olestring =  "\0" x (2*$lg);
  99.    $MultiByteToWideChar->Call(0, 0, $ansistr, $lg, $olestring, $lg);
  100.    return $olestring;
  101. }
  102.  
  103. # transforme une chaine en ansi en une en wide chars terminée par un \0
  104. # ne pas l'avoir fait a ete la principale source de bugs qui faisait que
  105. # les appels foiraient
  106. sub COlestr {
  107.    my $ansistr = shift;
  108.    my $lg = length($ansistr);
  109.    my $olestring =  "\0" x (2*$lg);
  110.    $MultiByteToWideChar->Call(0, 0, $ansistr, $lg, $olestring, $lg);
  111.    $olestring = $olestring . "\0";
  112.    return $olestring;
  113. }
  114.  
  115. # On peut aussi le faire en perl sans passer par des appels OLE
  116. # La chaine en entree est en ansi, pas en wide chars
  117. sub StringIDToClassID {
  118.    my $strID = shift;
  119.    $strID =~ s/^{|}$//g;
  120.    my @c = split /-/, $strID;
  121.    my $classID = pack 'LSSC8',
  122.                        hex $c[0],
  123.                        hex $c[1],
  124.                        hex $c[2],
  125.                        hex (substr $c[3], 0, 2), hex (substr $c[3], 2, 2),
  126.                        hex (substr $c[4], 0, 2), hex (substr $c[4], 2, 2),
  127.                        hex (substr $c[4], 4, 2), hex (substr $c[4], 6, 2),
  128.                        hex (substr $c[4], 8, 2), hex (substr $c[4], 10, 2);
  129.    return $classID;
  130. }


Tout ça marche maintenant sans pb sur ma bécane avec le perl de Active State.
 
Tu peux le diffuser sur d'autres forums ou j'ai vu que tu avais posé la question, car j'ai vu que dans le passé, d'autres s'étaient posé ce type de question, et l'avaient partiellement résolu (je me suis servi de certaines de leur idées) sans persévérer jusqu’à la solution (en général,ils sont passé à coté du 0 final manquant aux chaines converties par MultiByteToWideChar). Donc si ça peux servir au plus grand nombre...
 
A+,


Message édité par gilou le 23-02-2011 à 00:04:19

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
Reply

Marsh Posté le 23-02-2011 à 00:37:08    

Note annexe:
Plutôt que passer par MultiByteToWideChar, je m'étais dit: "utilisons Encode avec comme codage utf-16".
Ça eut été trop beau:

Pour la même chaine de départ, "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Avec MultiByteToWideChar
+--------------------------------------------------+------------------+
| 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F  | 0123456789ABCDEF |
+--------------------------------------------------+------------------+
| 30 00 31 00 32 00 33 00 34 00 35 00 36 00 37 00  | 0.1.2.3.4.5.6.7. |
| 38 00 39 00 41 00 42 00 43 00 44 00 45 00 46 00  | 8.9.A.B.C.D.E.F. |
| 47 00 48 00 49 00 4A 00 4B 00 4C 00 4D 00 4E 00  | G.H.I.J.K.L.M.N. |
| 4F 00 50 00 51 00 52 00 53 00 54 00 55 00 56 00  | O.P.Q.R.S.T.U.V. |
| 57 00 58 00 59 00 5A 00                          | W.X.Y.Z.         |
+--------------------------------------------------+------------------+
Avec Encode en utf-16
+--------------------------------------------------+------------------+
| 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F  | 0123456789ABCDEF |
+--------------------------------------------------+------------------+
| FE FF 00 30 00 31 00 32 00 33 00 34 00 35 00 36  | þÿ.0.1.2.3.4.5.6 |
| 00 37 00 38 00 39 00 41 00 42 00 43 00 44 00 45  | .7.8.9.A.B.C.D.E |
| 00 46 00 47 00 48 00 49 00 4A 00 4B 00 4C 00 4D  | .F.G.H.I.J.K.L.M |
| 00 4E 00 4F 00 50 00 51 00 52 00 53 00 54 00 55  | .N.O.P.Q.R.S.T.U |
| 00 56 00 57 00 58 00 59 00 5A                    | .V.W.X.Y.Z       |
+--------------------------------------------------+------------------+


MultiByteToWideChar inverse les octets de poids fort avec ceux de poids faible, tandis que Encode rajoute une Byte order mark au début :cry:
Bon, en virant la BOM et swappant les octets 2 a 2, il y a moyens d'éviter de faire un appel à MultiByteToWideChar et utiliser uniquement du perl.
Pour les chaines CLSID qui sont toujours en ASCII, ça peut permettre de se dispenser d'un appel pour une tache que Perl peut faire plus efficacement.
A+,


Message édité par gilou le 23-02-2011 à 00:42:34

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
Reply

Marsh Posté le 23-02-2011 à 22:19:23    

oh la bonne surprise !!!  
j'etais loin de penser que qqu'un allait prendre le temps de regarder un truc aussi tordu  :D  
je n'ai pas testé mais ça ne saurait tarder ...  
en tout cas, chapeau bas  :jap:  
le temps passé vaut bien plus plus qu'un apéro !!!
evidemment je ne manquerai pas de te citer  :hello:  
 
ps : suis curieux de savoir comment tu as pu debogguer tout ça ?!

Reply

Marsh Posté le 24-02-2011 à 00:29:47    

:hello: Bonsoir,
 
Pour débogguer, ça a été à coups de Data::Dumper pour le côté Perl et les HRESULT pour le côté OLE. Bon, j'avais un peu d'expérience OLE mais très ancienne (mas pas complètement oubliée, c'est pour ça que les chaines ANSI et non OLESTR ça m'a sauté aux yeux en lisant le code, sans doute un traumatisme vécu à cause de ça et d'un bug, il y a longtemps :D ), et pas mal d'expérience Windows (depuis Windows 2.0) plus pas mal d'info ça et la glanées sur le web (par exemple le coup du $PPV = pack 'P', 0; $ppv = pack 'P', $PPV; je l'ai trouvé sur le web, chez qqu'un qui n'avait pas vu cette histoire de chaines OLESTR qui ne sont pas des chaines COLESTR et avait laché le morceau).
 
Bon, j'espère qu'à partir de ça, tu as pu faire marcher ton code avec SHSetKnownFolderPath.
 
A+,
 


---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
Reply

Marsh Posté le 24-02-2011 à 23:00:26    

merci du grand coup de pouce  :bounce:  :bounce:  :bounce:  
 
j'ai réussi à mettre en oeuvre les fonctions "shsetknownfolderpath" et "shchangenotify"  :D  
(pour info le "path" doit aussi être en wide char et se terminer par un \0)
 
pour le clsidfromstring j'avais trouvé ça (en faisant une recherche google sur +"lssc8" ) :
http://www.perlmonks.org/bare/?node_id=321990
mais de toute façon j'aurai butté sur le dernier paramètre de la fonction "shsetknownfolderpath"
 
du coup, grosso modo ça donne ça (avec ton "bout" de code  ;) ) :

Code :
  1. $newstring = '{4BD8D571-6D19-48D3-BE97-422220080E43}';
  2. $oleprogid = COlestr($newstring);
  3. $classid = "\0" x 16; # 16 bytes data
  4. $result = $CLSIDFromString->Call($oleprogid, $classid);
  5. my $path = COlestr("c:\\temp" );
  6. my $SHSetKnownFolderPath = new Win32::API("Shell32", 'SHSetKnownFolderPath', 'PNNP', 'N') || die;
  7. $SHSetKnownFolderPath->Call($classid, 0, 0, $path);
  8. my $SHChangeNotify = new Win32::API("Shell32", 'SHChangeNotify', 'NIPP', '') || die;
  9. $SHChangeNotify->Call(0x8000000, 0x1000, "\x00", "\x00" );


 
cet exemple permet de rediriger à chaud "ma musique" (de mon profil) dans "c:\temp"
 
encore merci  :hello:

Reply

Marsh Posté le 25-02-2011 à 17:26:33    

:hello:
Très bien. :)

 
jonhdooe a écrit :

pour le clsidfromstring j'avais trouvé ça (en faisant une recherche google sur +"lssc8" ) :
http://www.perlmonks.org/bare/?node_id=321990

Moi aussi, c'est ce qui m'a permis de comprendre comment procéder.

 

En cherchant un peu, j'ai compris d'ou venait le problème OLESTR etc:

Citation :

Perl's strings are C structs that include (amongst other things) a pointer to the first character, AND the length of the string. Since perl doesn't need a special terminating character you can use 0 characters in the middle of a string too.


Donc tout le code doit être améliorable en transformant les chaines Perl en vraies chaines C avant de faire les appels au code C des API Windows.
Une version plus aboutie (et probablement plus efficace) donnerait:

 
Code :
  1. #!/usr/local/bin/perl
  2. use strict;
  3. use warnings;
  4. use Encode;
  5. use String::Scanf;
  6.  
  7. use Win32;
  8. use Win32::API;
  9. $Win32::API::DEBUG = 1;
  10.  
  11. my $CLSIDFromProgID = new Win32::API("OLE32", "CLSIDFromProgID", "PP", "N" ) or die "Can't Import OLE32 or find CLSIDFromProgID";
  12. my $ProgIDFromCLSID = new Win32::API("OLE32", "ProgIDFromCLSID", "PP", "N" ) or die "Can't Import OLE32 or find ProgIDFromCLSID";
  13.  
  14. # Deux subs en perl qui permettent de convertir d'une string Perl a une string unicode Windows
  15. # et réciproquement.
  16. # Transformer d'abord en chaine C terminée par un 0 une chaine perl qu'on va passer à du code Windows
  17. # en ajoutant "\0" à la fin.    
  18. sub AnsiToOlestr {
  19.    my $input = substr(encode("utf16", $_[0]), 2);
  20.    return join '', map {pack( "c2", reverse( unpack( "c2", $_ )))} ($input =~ m/..?/g );
  21. }
  22.  
  23. sub OlestrToAnsi {
  24.    my $input = join '', map {pack( "c2", reverse( unpack( "c2", $_ )))} ($_[0] =~ m/..?/g );
  25.    return decode("utf16", "\xfe\xff".$input);
  26. }
  27.  
  28. # ces deux subs en perl remplacent les fonctions correspondantes de OLE32, mais se font sur une base de
  29. # strings Perl et non de strings unicode Windows
  30. sub CLSIDFromString {
  31.    my @c = sscanf("{%s-%s-%s-%s-%s}", $_[0]);
  32.    return pack 'LSSC8',
  33.                        hex $c[0],
  34.                        hex $c[1],
  35.                        hex $c[2],
  36.                        hex (substr $c[3], 0, 2), hex (substr $c[3], 2, 2),
  37.                        hex (substr $c[4], 0, 2), hex (substr $c[4], 2, 2),
  38.                        hex (substr $c[4], 4, 2), hex (substr $c[4], 6, 2),
  39.                        hex (substr $c[4], 8, 2), hex (substr $c[4], 10, 2);
  40. }
  41.  
  42. sub StringFromCLSID {
  43.    my @a = (unpack 'LSSC8', $_[0]);
  44.    return sprintf("{%x-%x-%x-%x%x-%x%x%x%x%x%x}", @a);
  45. }
  46.  
  47. # petit test
  48.  
  49. my $progid = "WMP.DeskBand.1"."\0"; # On en fait une chaine C
  50. my $oleprogid = AnsiToOlestr($progid); # On transforme en Unicode à la windows
  51. my $classid = "\0" x 16; # 16 bytes data
  52.  
  53. my $result = $CLSIDFromProgID->Call($oleprogid, $classid );
  54. if ($result) {
  55.    printf "Error: 0x%x\n", $result;
  56. }
  57. else {
  58.    print StringFromCLSID($classid), "\n";
  59.    # on devrait avoir {0A4286EA-E355-44FB-8086-AF3DF7645BD9}
  60. }
  61.  
  62. my $string = '{0A4286EA-E355-44FB-8086-AF3DF7645BD9}';
  63. $classid = CLSIDFromString($string);
  64. my $PPV = pack 'P', 0;
  65. my $ppv = pack 'P', $PPV;
  66. $result = $ProgIDFromCLSID->Call($classid, $ppv );
  67. if ($result) {
  68.    printf "Error: 0x%x\n", $result;
  69. }
  70. else {
  71.    $PPV = unpack 'P[256]', $ppv;
  72.    if ($PPV =~ m/\x00\x00\x00.*/) {
  73.     $PPV =~ s/\x00\x00\x00.*/\x00/;
  74.    }
  75.    elsif ($PPV =~ m/\x00\x00.*/) {
  76.     $PPV =~ s/\x00\x00.*//;
  77.    }
  78.    else {
  79.     print "Warning: Truncating result string from ProgIDFromCLSID call\n";
  80.    }
  81.    print OlestrToAnsi($PPV), "\n";
  82.    # on devrait avoir "WMP.DeskBand.1"
  83. }
  84.  
  85. __END__
  86.  
  87.  
  88. # Pas testé parce que je suis sous XP ou SHSetKnownFolderPath n'est pas implémenté:
  89. # Je ferais ainsi pour le bout de code que tu as donné:
  90.  
  91. my $SHSetKnownFolderPath = new Win32::API("Shell32", 'SHSetKnownFolderPath', 'PNNP', 'N') || die;
  92. my $SHChangeNotify = new Win32::API("Shell32", 'SHChangeNotify', 'NIPP', '') || die;
  93.  
  94. $classid = CLSIDFromString("{4BD8D571-6D19-48D3-BE97-422220080E43}" );
  95. my $path = AnsiToOlestr("c:\\temp"."\0" );
  96. $SHSetKnownFolderPath->Call($classid, 0, 0, $path);
  97. $SHChangeNotify->Call(0x8000000, 0x1000, "\x00", "\x00" );
 

A+,

 


Message édité par gilou le 25-02-2011 à 17:38:01

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed