+++ /dev/null
-/* dl_os2.xs
- *
- * Platform: OS/2.
- * Author: Andreas Kaiser (ak@ananke.s.bawue.de)
- * Created: 08th December 1994
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-#define INCL_BASE
-#include <os2.h>
-
-#include "dlutils.c" /* SaveError() etc */
-
-static ULONG retcode;
-
-static void *
-dlopen(char *path, int mode)
-{
- HMODULE handle;
- char tmp[260], *beg, *dot;
- char fail[300];
- ULONG rc;
-
- if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
- return (void *)handle;
-
- retcode = rc;
-
- /* Not found. Check for non-FAT name and try truncated name. */
- /* Don't know if this helps though... */
- for (beg = dot = path + strlen(path);
- beg > path && !strchr(":/\\", *(beg-1));
- beg--)
- if (*beg == '.')
- dot = beg;
- if (dot - beg > 8) {
- int n = beg+8-path;
- memmove(tmp, path, n);
- memmove(tmp+n, dot, strlen(dot)+1);
- if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0)
- return (void *)handle;
- }
-
- return NULL;
-}
-
-static void *
-dlsym(void *handle, char *symbol)
-{
- ULONG rc, type;
- PFN addr;
-
- rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr);
- if (rc == 0) {
- rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
- if (rc == 0 && type == PT_32BIT)
- return (void *)addr;
- rc = ERROR_CALL_NOT_IMPLEMENTED;
- }
- retcode = rc;
- return NULL;
-}
-
-static char *
-dlerror(void)
-{
- static char buf[300];
- ULONG len;
-
- if (retcode == 0)
- return NULL;
- if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len))
- sprintf(buf, "OS/2 system error code %d", retcode);
- else
- buf[len] = '\0';
- retcode = 0;
- return buf;
-}
-
-
-static void
-dl_private_init()
-{
- (void)dl_generic_private_init();
-}
-
-static char *
-mod2fname(sv)
- SV *sv;
-{
- static char fname[9];
- int pos = 7;
- int len;
- AV *av;
- SV *svp;
- char *s;
-
- if (!SvROK(sv)) croak("Not a reference given to mod2fname");
- sv = SvRV(sv);
- if (SvTYPE(sv) != SVt_PVAV)
- croak("Not array reference given to mod2fname");
- if (av_len((AV*)sv) < 0)
- croak("Empty array reference given to mod2fname");
- s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
- strncpy(fname, s, 8);
- if ((len=strlen(s)) < 7) pos = len;
- fname[pos] = '_';
- fname[pos + 1] = '\0';
- return (char *)fname;
-}
-
-MODULE = DynaLoader PACKAGE = DynaLoader
-
-BOOT:
- (void)dl_private_init();
-
-
-void *
-dl_load_file(filename)
- char * filename
- CODE:
- int mode = 1; /* Solaris 1 */
-#ifdef RTLD_LAZY
- mode = RTLD_LAZY; /* Solaris 2 */
-#endif
- DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename));
- RETVAL = dlopen(filename, mode) ;
- DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL));
- ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
- SaveError("%s",dlerror()) ;
- else
- sv_setiv( ST(0), (IV)RETVAL);
-
-
-void *
-dl_find_symbol(libhandle, symbolname)
- void * libhandle
- char * symbolname
- CODE:
-#ifdef DLSYM_NEEDS_UNDERSCORE
- char symbolname_buf[1024];
- symbolname = dl_add_underscore(symbolname, symbolname_buf);
-#endif
- DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n",
- libhandle, symbolname));
- RETVAL = dlsym(libhandle, symbolname);
- DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL));
- ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
- SaveError("%s",dlerror()) ;
- else
- sv_setiv( ST(0), (IV)RETVAL);
-
-
-void
-dl_undef_symbols()
- PPCODE:
-
-char *
-mod2fname(sv)
- SV *sv;
-
-
-# These functions should not need changing on any platform:
-
-void
-dl_install_xsub(perl_name, symref, filename="$Package")
- char * perl_name
- void * symref
- char * filename
- CODE:
- DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
- perl_name, symref));
- ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
-
-
-char *
-dl_error()
- CODE:
- RETVAL = LastError ;
- OUTPUT:
- RETVAL
-
-# end.