1(* 2 Copyright (c) 2001, 2015 3 David C.J. Matthews 4 5 This library is free software; you can redistribute it and/or 6 modify it under the terms of the GNU Lesser General Public 7 License version 2.1 as published by the Free Software Foundation. 8 9 This library is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 Lesser General Public License for more details. 13 14 You should have received a copy of the GNU Lesser General Public 15 License along with this library; if not, write to the Free Software 16 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 17*) 18 19structure Resource : 20 sig 21 datatype ResourceType = 22 RT_CURSOR | RT_BITMAP | RT_ICON | RT_MENU | RT_DIALOG | RT_STRING | RT_FONTDIR | 23 RT_FONT | RT_ACCELERATOR | RT_RCDATA | RT_MESSAGETABLE | RT_GROUP_CURSOR | 24 RT_GROUP_ICON | RT_VERSION | RT_DLGINCLUDE | RT_ANICURSOR | RT_ANIICON | 25 RT_PLUGPLAY | RT_VXD 26 27 type HRSRC 28 type HRSRCGLOBAL 29 type HINSTANCE 30 31 datatype RESID = IdAsInt of int | IdAsString of string 32 val MAKEINTRESOURCE : int -> RESID 33 34 type HUPDATE 35 36 val BeginUpdateResource : string * bool -> HUPDATE 37 val EndUpdateResource : HUPDATE * bool -> unit 38 val FindResource : HINSTANCE * RESID * ResourceType -> HRSRC 39 val FindResourceEx : HINSTANCE * ResourceType * RESID * Locale.LANGID -> HRSRC 40 val FreeLibrary : HINSTANCE -> unit 41 val LoadLibrary : string -> HINSTANCE 42 val LoadResource : HINSTANCE * HRSRC -> HRSRCGLOBAL 43 val LoadString : HINSTANCE * RESID -> string 44 val LockResource : HRSRCGLOBAL -> Word8Vector.vector 45 val SizeofResource : HINSTANCE * HRSRC -> int 46 val UpdateResource : 47 HUPDATE * ResourceType * RESID * Locale.LANGID * Word8Vector.vector option -> unit 48 end 49 = 50struct 51 open Foreign 52 open Base 53 54 datatype RESID = datatype RESID 55 56 fun MAKEINTRESOURCE i = 57 if i >= 0 andalso i < 65536 then IdAsInt i 58 else raise Fail "resource id out of range" 59 60 fun checkHandle h = (checkResult(not(isHNull h)); h) 61 62 datatype ResourceType = 63 RT_CURSOR | RT_BITMAP | RT_ICON | RT_MENU | RT_DIALOG | RT_STRING | RT_FONTDIR | 64 RT_FONT | RT_ACCELERATOR | RT_RCDATA | RT_MESSAGETABLE | RT_GROUP_CURSOR | 65 RT_GROUP_ICON | RT_VERSION | RT_DLGINCLUDE | RT_ANICURSOR | RT_ANIICON | 66 RT_PLUGPLAY | RT_VXD 67 68 local 69 70 fun toRes 1 = RT_CURSOR | toRes 2 = RT_BITMAP | toRes 3 = RT_ICON | toRes 4 = RT_MENU 71 | toRes 5 = RT_DIALOG | toRes 6 = RT_STRING | toRes 7 = RT_FONTDIR | toRes 8 = RT_FONT 72 | toRes 9 = RT_ACCELERATOR | toRes 10 = RT_RCDATA | toRes 11 = RT_MESSAGETABLE 73 | toRes 12 = RT_GROUP_CURSOR | toRes 14 = RT_GROUP_ICON | toRes 16 = RT_VERSION 74 | toRes 17 = RT_DLGINCLUDE | toRes 19 = RT_PLUGPLAY | toRes 20 = RT_VXD 75 | toRes 21 = RT_ANICURSOR | toRes 22 = RT_ANIICON 76 | toRes _ = raise Fail "Unknown Resource Type" 77 78 fun fromRes RT_CURSOR = 1 | fromRes RT_BITMAP = 2 | fromRes RT_ICON = 3 79 | fromRes RT_MENU = 4 | fromRes RT_DIALOG = 5 | fromRes RT_STRING = 6 80 | fromRes RT_FONTDIR = 7 | fromRes RT_FONT = 8 | fromRes RT_ACCELERATOR = 9 81 | fromRes RT_RCDATA = 10 | fromRes RT_MESSAGETABLE = 11 | fromRes RT_GROUP_CURSOR = 12 82 | fromRes RT_GROUP_ICON = 14 | fromRes RT_VERSION = 16 | fromRes RT_DLGINCLUDE = 17 83 | fromRes RT_PLUGPLAY = 19 | fromRes RT_VXD = 20 | fromRes RT_ANICURSOR = 21 84 | fromRes RT_ANIICON = 22 85 in 86 val RESOURCETYPE = 87 absConversion {abs = toRes, rep = fromRes} cInt 88 end 89 90 local 91 datatype HRSRCGLOBAL = HRSRCGLOBAL of Memory.voidStar * int 92 in 93 type HRSRCGLOBAL = HRSRCGLOBAL 94 95 val LoadLibrary = checkHandle o winCall1 (kernel "LoadLibraryA") (cString) cHINSTANCE 96 and FreeLibrary = winCall1 (kernel "FreeLibrary") (cHINSTANCE) (successState "FreeLibrary") 97 and FindResource = checkHandle o 98 winCall3 (kernel "FindResourceA") 99 (cHINSTANCE, cRESID, RESOURCETYPE) cHRSRC 100 and SizeofResource = winCall2 (kernel "SizeofResource") (cHINSTANCE, cHRSRC) cDWORD 101 (* The name and type are in the reverse order in FindResource and FindResourceEx *) 102 and FindResourceEx = checkHandle o 103 winCall4 (kernel "FindResourceExA") 104 (cHINSTANCE, RESOURCETYPE, cRESID, LocaleBase.LANGID) cHRSRC 105 106 (* LoadResource - load a resource into memory and get a handle to it. *) 107 local 108 val loadResource = winCall2 (kernel "LoadResource") (cHINSTANCE, cHRSRC) 109 and lockResource = winCall1 (kernel "LockResource") (cPointer) cPointer 110 and loadString = winCall4 (user "LoadStringA") (cHINSTANCE, cRESID, cPointer, cInt) cInt 111 in 112 fun LoadResource (hInst, hRsrc) = 113 let 114 val size = SizeofResource (hInst, hRsrc) 115 val load = loadResource cPointer 116 val rsrc = load(hInst, hRsrc) 117 in 118 HRSRCGLOBAL(rsrc, size) 119 end 120 121 (* LockResource - get the resource as a piece of binary store. *) 122 fun LockResource (HRSRCGLOBAL(hg, size)) = 123 let 124 val res = lockResource hg 125 in 126 Word8Vector.tabulate(size, fn i => Memory.get8(res, Word.fromInt i)) 127 end 128 129 fun LoadString (hInst, resId): string = 130 let 131 (* The underlying call returns the number of bytes copied EXCLUDING the terminating null. *) 132 (* The easiest way to make sure we have enough store is to loop. *) 133 open Memory 134 fun tryLoad n = 135 let 136 val store = malloc n 137 val used = Word.fromInt(loadString(hInst, resId, store, Word.toInt n)) 138 in 139 (* We can't distinguish the empty string from a missing resource. *) 140 if used = 0w0 then "" 141 else if used < n-0w1 142 then fromCstring store before free store 143 else (free store; tryLoad(n*0w2)) 144 end 145 in 146 tryLoad 0w100 147 end 148 end 149 150 val BeginUpdateResource = 151 (fn c => (checkResult(not(isHNull c)); c)) o 152 winCall2 (user "BeginUpdateResourceA") (cString, cBool) cHUPDATE 153 154 val EndUpdateResource = 155 winCall2 (user "EndUpdateResource") (cHUPDATE, cBool) (successState "EndUpdateResource") 156 157 local 158 val updateResource = 159 winCall6 (user "UpdateResource") 160 (cHUPDATE, RESOURCETYPE, cRESID, LocaleBase.LANGID, cOptionPtr cByteArray, cInt) 161 (successState "UpdateResource") 162 in 163 (* NONE here means delete the resource, SOME means a value to store. *) 164 (* N.B. If updating a string the new value must be in Unicode. *) 165 fun UpdateResource(hup, rt, resid, lang, v as SOME vec) = 166 updateResource(hup, rt, resid, lang, v, Word8Vector.length vec) 167 | UpdateResource(hup, rt, resid, lang, NONE) = 168 updateResource(hup, rt, resid, lang, NONE, 0) 169 end 170 end 171end; 172