msedynload.pas 13.9 KB
Newer Older
Martin Schreiber's avatar
Martin Schreiber committed
1 2 3 4
unit msedynload;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
interface
uses
5
 msesystypes,{$ifdef FPC}dynlibs,{$endif}{msestrings,}sysutils,msetypes{,msesys};
Martin Schreiber's avatar
Martin Schreiber committed
6 7 8

{$ifndef cpuarm}{$define set8087cw}{$endif}

Martin Schreiber's avatar
Martin Schreiber committed
9 10 11 12 13 14 15 16 17 18 19 20 21 22
type
 funcinfoty = record
               n: string;      //name
               d: ppointer;    //destination
              end;
 dynlibinfoty = record
  libhandle: tlibhandle;
  libname: filenamety;
  refcount: integer;
  inithooks: pointerarty;       //array of dynlibprocty
  deinithooks: pointerarty;     //array of dynlibprocty
  cw8087: word;             //fpu control word after lib load
 end;
 dynlibprocty = procedure(const dynlib: dynlibinfoty);
23
 dynloadcallbackty = procedure(const data: pointer);
24 25 26

 edynload = class(ecrashstatfile)
 end;
Martin Schreiber's avatar
Martin Schreiber committed
27 28 29 30 31 32 33 34 35 36
  
procedure initializelibinfo(var info: dynlibinfoty);
procedure finalizelibinfo(var info: dynlibinfoty);

function initializedynlib(var info: dynlibinfoty;
                              const libnames: array of filenamety;
                              const libnamesdefault: array of filenamety;
                              const funcs: array of funcinfoty;
                              const funcsopt: array of funcinfoty;
                              const errormessage: msestring = '';
37 38 39
                              const callback: dynloadcallbackty = nil;
                              const noexception: boolean = false;
                              const callbackdata: pointer = nil): boolean;
Martin Schreiber's avatar
Martin Schreiber committed
40 41 42
                                        //called after lib load
                              //returns true if all funcsopt found
procedure releasedynlib(var info: dynlibinfoty;
43 44 45
                         const callback: dynloadcallbackty = nil;
                         const nodlunload: boolean = false;
                         const callbackdata: pointer = nil);
Martin Schreiber's avatar
Martin Schreiber committed
46 47 48 49 50 51 52 53
                               //called before lib unload
procedure regdynlibinit(var info: dynlibinfoty; const initproc: dynlibprocty);
procedure regdynlibdeinit(var info: dynlibinfoty; const initproc: dynlibprocty);

procedure dynloadlock;
procedure dynloadunlock;

function loadlib(const libnames: array of filenamety; out libname: filenamety;
54 55
                        const errormessage: msestring = '';
                  const noexception: boolean = false): tlibhandle;
Martin Schreiber's avatar
Martin Schreiber committed
56 57 58
              
function getprocaddresses(const lib: tlibhandle;
                       const procedures: array of funcinfoty;
Martin Schreiber's avatar
Martin Schreiber committed
59 60
                       const noexception: boolean = false;
                       const libname: msestring = ''): boolean; overload;
Martin Schreiber's avatar
Martin Schreiber committed
61
function getprocaddresses(const lib: tlibhandle; const anames: array of string;
Martin Schreiber's avatar
Martin Schreiber committed
62 63 64 65 66 67
               const adest: array of ppointer;
               const noexception: boolean = false;
               const libname: msestring = ''): boolean; overload;
function getprocaddresses(const libinfo: dynlibinfoty;
                       const procedures: array of funcinfoty;
                       const noexception: boolean = false): boolean; overload;
68 69 70
function getprocaddresses(const libnames: array of msestring;
                       const procedures: array of funcinfoty;
                       const noexception: boolean = false):  tlibhandle; overload;
Martin Schreiber's avatar
Martin Schreiber committed
71 72
function getprocaddresses(const libinfo: dynlibinfoty;
               const anames: array of string;
Martin Schreiber's avatar
Martin Schreiber committed
73 74 75 76 77 78 79 80 81
               const adest: array of ppointer;
               const noexception: boolean = false): boolean; overload;
function getprocaddresses(const libnames: array of filenamety; 
                             const anames: array of string; 
                             const adest: array of ppointer;
                             const noexception: boolean = false): tlibhandle; overload;
function checkprocaddresses(const libnames: array of filenamety; 
                             const anames: array of string; 
                             const adest: array of ppointer): boolean;
82 83
function checkprocaddresses(const libnames: array of filenamety; 
                             const procedures: array of funcinfoty): boolean;
Martin Schreiber's avatar
Martin Schreiber committed
84 85 86 87 88
function quotelibnames(const libnames: array of filenamety): msestring;

implementation

uses
Martin Schreiber's avatar
Martin Schreiber committed
89
 msesysintf1{$ifdef linux},dl{$endif},msearrayutils,msestrings;
Martin Schreiber's avatar
Martin Schreiber committed
90 91 92

function getprocaddresses(const lib: tlibhandle;
                          const procedures: array of funcinfoty;
Martin Schreiber's avatar
Martin Schreiber committed
93 94
                          const noexception: boolean = false;
                          const libname: msestring = ''): boolean; overload;
Martin Schreiber's avatar
Martin Schreiber committed
95 96
var
 int1: integer;
97
 mstr1: msestring;
Martin Schreiber's avatar
Martin Schreiber committed
98 99
begin
 result:= true;
100
 mstr1:= '';
Martin Schreiber's avatar
Martin Schreiber committed
101 102 103 104 105 106 107 108 109 110
 for int1:= 0 to high(procedures) do begin
  with procedures[int1] do begin
  {$ifdef FPC}
   d^:= getprocedureaddress(lib,n);
  {$else}
   d^:= getprocaddress(lib,pansichar(n));
  {$endif}
   if (d^ = nil) then begin
    result:= false;
    if not noexception then begin
Martin Schreiber's avatar
Martin Schreiber committed
111
     if libname <> '' then begin
112
      mstr1:= libname + lineend;
Martin Schreiber's avatar
Martin Schreiber committed
113
     end;
114 115
     mstr1:= mstr1 + 'Function "'+msestring(n)+'" not found.';
     raise edynload.create(ansistring(mstr1));
Martin Schreiber's avatar
Martin Schreiber committed
116 117 118 119 120 121 122 123
    end;
   end;
  end;
 end;
end;

function getprocaddresses(const lib: tlibhandle; const anames: array of string; 
             const adest: array of ppointer;
Martin Schreiber's avatar
Martin Schreiber committed
124 125
             const noexception: boolean = false;
                                const libname: msestring = ''): boolean;
Martin Schreiber's avatar
Martin Schreiber committed
126 127
var
 int1: integer;
128
 mstr1: msestring;
Martin Schreiber's avatar
Martin Schreiber committed
129 130 131 132
begin
 if high(anames) <> high(adest) then begin
  raise exception.create('Invalid parameter.');
 end;
133
 mstr1:= '';
Martin Schreiber's avatar
Martin Schreiber committed
134 135 136 137 138 139
 result:= true;
 for int1:= 0 to high(anames) do begin
  adest[int1]^:= getprocaddress(lib,pansichar(anames[int1]));
  if (adest[int1]^ = nil) then begin
   result:= false;
   if not noexception then begin
Martin Schreiber's avatar
Martin Schreiber committed
140
    if libname <> '' then begin
141
     mstr1:= libname + lineend;
Martin Schreiber's avatar
Martin Schreiber committed
142
    end;
143 144
    mstr1:= mstr1 + 'Function "'+msestring(anames[int1])+'" not found.';
    raise exception.create(ansistring(mstr1));
Martin Schreiber's avatar
Martin Schreiber committed
145 146 147 148 149
   end;
  end;
 end;
end;

Martin Schreiber's avatar
Martin Schreiber committed
150 151 152 153 154 155 156 157 158
function getprocaddresses(const libinfo: dynlibinfoty;
                       const procedures: array of funcinfoty;
                       const noexception: boolean = false): boolean;
begin
 with libinfo do begin
  result:= getprocaddresses(libhandle,procedures,noexception,libname);
 end;
end;

159 160 161 162 163 164
function getprocaddresses(const libnames: array of msestring;
                       const procedures: array of funcinfoty;
                       const noexception: boolean = false): tlibhandle;
var
 str1: msestring;
begin
165 166
 result:= loadlib(libnames,str1,'',noexception);
 if result <> 0 then begin
167 168 169 170
  if not getprocaddresses(result,procedures,noexception,str1) then begin
   unloadlibrary(result);
   result:= 0;
  end;
171
 end;
172 173
end;

Martin Schreiber's avatar
Martin Schreiber committed
174 175 176 177 178 179 180 181 182 183
function getprocaddresses(const libinfo: dynlibinfoty;
               const anames: array of string;
               const adest: array of ppointer;
               const noexception: boolean = false): boolean; overload;
begin
 with libinfo do begin
  result:= getprocaddresses(libhandle,anames,adest,noexception,libname);
 end;
end;

Martin Schreiber's avatar
Martin Schreiber committed
184
function loadlib(const libnames: array of filenamety; out libname: filenamety; 
185 186
                 const errormessage: msestring = '';
                  const noexception: boolean = false): tlibhandle;
Martin Schreiber's avatar
Martin Schreiber committed
187 188
var
 int1: integer;
Martin Schreiber's avatar
Martin Schreiber committed
189 190 191 192 193
 s1: string;
{$ifdef linux}
 p1: pchar;
 ar1: stringarty;
{$endif}
Martin Schreiber's avatar
Martin Schreiber committed
194 195 196
begin
 result:= 0;
 libname:= '';
Martin Schreiber's avatar
Martin Schreiber committed
197 198 199
{$ifdef linux}
 p1:= nil;
{$endif}
Martin Schreiber's avatar
Martin Schreiber committed
200 201 202 203 204 205 206 207 208 209
 for int1:= 0 to high(libnames) do begin
 {$ifdef FPC}
  result:= loadlibrary(libnames[int1]);
 {$else}
  result:= loadlibrary(pansichar(string(libnames[int1])));
 {$endif}
  if result <> 0 then begin
   libname:= libnames[int1];
   break;
  end;
Martin Schreiber's avatar
Martin Schreiber committed
210 211 212 213
 {$ifdef linux}
  p1:= dlerror();
  additem(ar1,string(p1));
 {$endif}
Martin Schreiber's avatar
Martin Schreiber committed
214
 end;
215
 if (result = 0) and not noexception then begin
Martin Schreiber's avatar
Martin Schreiber committed
216 217 218 219 220 221 222 223
  s1:= ansistring(errormessage+
                   'Library '+quotelibnames(libnames)+' not found.');
 {$ifdef linux}
  if ar1 <> nil then begin
   s1:= s1+lineend+concatstrings(ar1,lineend);
  end;
 {$endif}
  raise exception.create(s1);
Martin Schreiber's avatar
Martin Schreiber committed
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260
 end;
end;

function getprocaddresses(const libnames: array of filenamety;
                 const anames: array of string; const adest: array of ppointer;
                 const noexception: boolean = false): tlibhandle; overload;
var
 mstr1: filenamety;
begin
 result:= loadlib(libnames,mstr1);
 getprocaddresses(result,anames,adest,noexception);
end;

function checkprocaddresses(const libnames: array of filenamety; 
                             const anames: array of string; 
                             const adest: array of ppointer): boolean;
var
 int1: integer;
begin
 for int1:= 0 to high(adest) do begin
  adest[int1]^:= nil;
 end;
 result:= true;
 try
  getprocaddresses(libnames,anames,adest,true);
 except
  result:= false;
  exit;
 end;
 for int1:= 0 to high(adest) do begin
  if adest[int1]^ = nil then begin
   result:= false;
   break;
  end;
 end;
end;

261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283
function checkprocaddresses(const libnames: array of filenamety; 
                             const procedures: array of funcinfoty): boolean;
var
 int1: integer;
begin
 for int1:= 0 to high(procedures) do begin
  procedures[int1].d^:= nil;
 end;
 result:= true;
 try
  getprocaddresses(libnames,procedures,true);
 except
  result:= false;
  exit;
 end;
 for int1:= 0 to high(procedures) do begin
  if procedures[int1].d^ = nil then begin
   result:= false;
   break;
  end;
 end;
end;

Martin Schreiber's avatar
Martin Schreiber committed
284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345
function quotelibnames(const libnames: array of filenamety): msestring;
var 
 int1: integer;
begin
 result:= '';
 for int1:= 0 to high(libnames) do begin
  result:= result+'"'+libnames[int1]+'",';
 end;  
 if length(result) > 0 then begin
  setlength(result,length(result)-1);
 end;
end;

{$ifndef FPC}
const
 nilhandle = 0;
 
Function UnloadLibrary(Lib : TLibHandle) : Boolean;
begin
 result:= freelibrary(lib);
end;
{$endif}

var
 lock: mutexty;

function adduniqueitem(var dest: pointerarty; const value: pointer): integer;
                        //returns index
var
 int1: integer;
begin
 for int1:= 0 to high(dest) do begin
  if dest[int1] = value then begin
   result:= int1;
   exit;
  end;
 end;
 result:= high(dest) + 1;
 setlength(dest,result+1);
 dest[result]:= value;
end;

procedure regdynlibinit(var info: dynlibinfoty; const initproc: dynlibprocty);
begin
 sys_mutexlock(lock);
 adduniqueitem(info.inithooks,pointer({$ifndef FPC}@{$endif}initproc));
 sys_mutexunlock(lock);
end;

procedure regdynlibdeinit(var info: dynlibinfoty; const initproc: dynlibprocty);
begin
 sys_mutexlock(lock);
 adduniqueitem(info.deinithooks,pointer({$ifndef FPC}@{$endif}initproc));
 sys_mutexunlock(lock);
end;

function initializedynlib(var info: dynlibinfoty;
                              const libnames: array of filenamety;
                              const libnamesdefault: array of filenamety;
                              const funcs: array of funcinfoty;
                              const funcsopt: array of funcinfoty;
                              const errormessage: msestring = '';
346 347 348
                              const callback: dynloadcallbackty = nil;
                              const noexception: boolean = false;
                              const callbackdata: pointer = nil): boolean;
Martin Schreiber's avatar
Martin Schreiber committed
349 350 351
                              //true if all funcsopt found
var
 int1: integer;
Martin Schreiber's avatar
Martin Schreiber committed
352
 {$ifdef set8087cw}
Martin Schreiber's avatar
Martin Schreiber committed
353
 wo1: word;
Martin Schreiber's avatar
Martin Schreiber committed
354
 {$endif}
Martin Schreiber's avatar
Martin Schreiber committed
355 356 357 358
begin
 with info do begin
  sys_mutexlock(lock);
  try
359
   result:= false;
Martin Schreiber's avatar
Martin Schreiber committed
360 361
   if refcount = 0 then begin
    if (high(libnames) >= 0) or (high(libnamesdefault) >= 0) then begin
Martin Schreiber's avatar
Martin Schreiber committed
362
 {$ifdef set8087cw}
Martin Schreiber's avatar
Martin Schreiber committed
363
     wo1:= get8087cw;
Martin Schreiber's avatar
Martin Schreiber committed
364
 {$endif}
Martin Schreiber's avatar
Martin Schreiber committed
365
     if (high(libnames) >= 0) then begin
Martin Schreiber's avatar
Martin Schreiber committed
366
      libhandle:= loadlib(libnames,libname,errormessage,noexception);
Martin Schreiber's avatar
Martin Schreiber committed
367 368
     end
     else begin
Martin Schreiber's avatar
Martin Schreiber committed
369
      libhandle:= loadlib(libnamesdefault,libname,errormessage,noexception);
Martin Schreiber's avatar
Martin Schreiber committed
370
     end;
Martin Schreiber's avatar
Martin Schreiber committed
371
     if libhandle <> nilhandle then begin
Martin Schreiber's avatar
Martin Schreiber committed
372
 {$ifdef set8087cw}
Martin Schreiber's avatar
Martin Schreiber committed
373 374
      cw8087:= get8087cw;
      set8087cw(wo1);
Martin Schreiber's avatar
Martin Schreiber committed
375
 {$endif}
Martin Schreiber's avatar
Martin Schreiber committed
376 377 378 379 380 381 382 383 384 385
      try
       result:= getprocaddresses(libhandle,funcs,noexception);
       if not result then begin
        if unloadlibrary(libhandle) then begin
         libhandle:= nilhandle;
        end;
        exit;
       end;
      except
       on e: exception do begin
386 387
        e.message:= ansistring(
         errormessage+'Library "'+libname+'": '+msestring(e.message));
Martin Schreiber's avatar
Martin Schreiber committed
388 389 390 391
        if unloadlibrary(libhandle) then begin
         libhandle:= nilhandle;
        end;
        raise;
Martin Schreiber's avatar
Martin Schreiber committed
392 393
       end;
      end;
Martin Schreiber's avatar
Martin Schreiber committed
394
      result:= getprocaddresses(libhandle,funcsopt,true);
Martin Schreiber's avatar
Martin Schreiber committed
395 396 397
     end;
    end
    else begin
Martin Schreiber's avatar
Martin Schreiber committed
398
 {$ifdef set8087cw}
399
     cw8087:= get8087cw; //refresh
Martin Schreiber's avatar
Martin Schreiber committed
400
 {$endif}
Martin Schreiber's avatar
Martin Schreiber committed
401
    end;
402 403 404 405 406 407
    if libhandle <> nilhandle then begin
     inc(refcount);
     for int1:= 0 to high(inithooks) do begin
      dynlibprocty(inithooks[int1])(info);
     end;
     if ({$ifndef FPC}@{$endif}callback <> nil) then begin
408
      callback(callbackdata);
409
     end;
Martin Schreiber's avatar
Martin Schreiber committed
410
    end;
411 412 413
   end
   else begin
    inc(refcount);
Martin Schreiber's avatar
Martin Schreiber committed
414 415 416 417 418 419 420 421
   end;
  finally
   sys_mutexunlock(lock);
  end;
 end;
end;

procedure releasedynlib(var info: dynlibinfoty;
422 423 424
                      const callback: dynloadcallbackty = nil;
                      const nodlunload: boolean = false;
                      const callbackdata: pointer = nil);
Martin Schreiber's avatar
Martin Schreiber committed
425 426 427 428 429 430 431 432 433 434 435 436 437
var
 int1: integer;
begin
 with info do begin
  sys_mutexlock(lock);
  try
   if refcount > 1 then begin
    dec(refcount);
   end
   else begin
    if refcount = 1 then begin //not initialized otherwise
     try
      if {$ifndef FPC}@{$endif}callback <> nil then begin
438
       callback(callbackdata);
Martin Schreiber's avatar
Martin Schreiber committed
439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491
      end;
      for int1:= 0 to high(deinithooks) do begin
       dynlibprocty(deinithooks[int1])(info);
      end;
     finally
      if nodlunload then begin
       dec(refcount);
      end
      else begin
       if (libhandle = nilhandle) or unloadlibrary(libhandle) then begin
        dec(refcount);
        libhandle:= nilhandle;
       end;
      end;
     end;
    end;
   end;
  finally
   sys_mutexunlock(lock);
  end;  
 end;
end;

procedure initializelibinfo(var info: dynlibinfoty);
begin
 sys_mutexcreate(lock);
 with info do begin
  libname:= '';
  refcount:= 0;
  libhandle:= 0;
 end;
end;

procedure finalizelibinfo(var info: dynlibinfoty);
begin
 with info do begin
 end;
end;

procedure dynloadlock;
begin
 sys_mutexlock(lock);
end;

procedure dynloadunlock;
begin
 sys_mutexunlock(lock);
end;

initialization
 sys_mutexcreate(lock);
finalization
 sys_mutexdestroy(lock);
492
end.