ext/DynaLoader/dl_os2.xs

   1 /* dl_os2.xs
   2  *
   3  * Platform:    OS/2.
   4  * Author:      Andreas Kaiser (ak@ananke.s.bawue.de)
   5  * Created:     08th December 1994
   6  */
   7
   8 #include "EXTERN.h"
   9 #include "perl.h"
  10 #include "XSUB.h"
  11
  12 #define INCL_BASE
  13 #include <os2.h>
  14
  15 #include "dlutils.c"    /* SaveError() etc      */
  16
  17 static ULONG retcode;
  18
  19 static void *
  20 dlopen(char *path, int mode)
  21 {
  22         HMODULE handle;
  23         char tmp[260], *beg, *dot;
  24         char fail[300];
  25         ULONG rc;
  26
  27         if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
  28                 return (void *)handle;
  29
  30         retcode = rc;
  31
  32         /* Not found. Check for non-FAT name and try truncated name. */
  33         /* Don't know if this helps though... */
  34         for (beg = dot = path + strlen(path);
  35              beg > path && !strchr(":/\\", *(beg-1));
  36              beg--)
  37                 if (*beg == '.')
  38                         dot = beg;
  39         if (dot - beg > 8) {
  40                 int n = beg+8-path;
  41                 memmove(tmp, path, n);
  42                 memmove(tmp+n, dot, strlen(dot)+1);
  43                 if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0)
  44                         return (void *)handle;
  45         }
  46
  47         return NULL;
  48 }
  49
  50 static void *
  51 dlsym(void *handle, char *symbol)
  52 {
  53         ULONG rc, type;
  54         PFN addr;
  55
  56         rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr);
  57         if (rc == 0) {
  58                 rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
  59                 if (rc == 0 && type == PT_32BIT)
  60                         return (void *)addr;
  61                 rc = ERROR_CALL_NOT_IMPLEMENTED;
  62         }
  63         retcode = rc;
  64         return NULL;
  65 }
  66
  67 static char *
  68 dlerror(void)
  69 {
  70         static char buf[300];
  71         ULONG len;
  72
  73         if (retcode == 0)
  74                 return NULL;
  75         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len))
  76                 sprintf(buf, "OS/2 system error code %d", retcode);
  77         else
  78                 buf[len] = '\0';
  79         retcode = 0;
  80         return buf;
  81 }
  82
  83
  84 static void
  85 dl_private_init()
  86 {
  87     (void)dl_generic_private_init();
  88 }
  89
  90 static char *
  91 mod2fname(sv)
  92      SV   *sv;
  93 {
  94     static char fname[9];
  95     int pos = 7;
  96     int len;
  97     AV  *av;
  98     SV  *svp;
  99     char *s;
 100
 101     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
 102     sv = SvRV(sv);
 103     if (SvTYPE(sv) != SVt_PVAV)
 104       croak("Not array reference given to mod2fname");
 105     if (av_len((AV*)sv) < 0)
 106       croak("Empty array reference given to mod2fname");
 107     s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
 108     strncpy(fname, s, 8);
 109     if ((len=strlen(s)) < 7) pos = len;
 110     fname[pos] = '_';
 111     fname[pos + 1] = '\0';
 112     return (char *)fname;
 113 }
 114
 115 MODULE = DynaLoader     PACKAGE = DynaLoader
 116
 117 BOOT:
 118     (void)dl_private_init();
 119
 120
 121 void *
 122 dl_load_file(filename)
 123     char *              filename
 124     CODE:
 125     int mode = 1;     /* Solaris 1 */
 126 #ifdef RTLD_LAZY
 127     mode = RTLD_LAZY; /* Solaris 2 */
 128 #endif
 129     DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename));
 130     RETVAL = dlopen(filename, mode) ;
 131     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL));
 132     ST(0) = sv_newmortal() ;
 133     if (RETVAL == NULL)
 134         SaveError("%s",dlerror()) ;
 135     else
 136         sv_setiv( ST(0), (IV)RETVAL);
 137
 138
 139 void *
 140 dl_find_symbol(libhandle, symbolname)
 141     void *      libhandle
 142     char *      symbolname
 143     CODE:
 144 #ifdef DLSYM_NEEDS_UNDERSCORE
 145     char symbolname_buf[1024];
 146     symbolname = dl_add_underscore(symbolname, symbolname_buf);
 147 #endif
 148     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n",
 149         libhandle, symbolname));
 150     RETVAL = dlsym(libhandle, symbolname);
 151     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "  symbolref = %x\n", RETVAL));
 152     ST(0) = sv_newmortal() ;
 153     if (RETVAL == NULL)
 154         SaveError("%s",dlerror()) ;
 155     else
 156         sv_setiv( ST(0), (IV)RETVAL);
 157
 158
 159 void
 160 dl_undef_symbols()
 161     PPCODE:
 162
 163 char *
 164 mod2fname(sv)
 165      SV   *sv;
 166
 167
 168 # These functions should not need changing on any platform:
 169
 170 void
 171 dl_install_xsub(perl_name, symref, filename="$Package")
 172     char *              perl_name
 173     void *              symref
 174     char *              filename
 175     CODE:
 176     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
 177                 perl_name, symref));
 178     ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
 179
 180
 181 char *
 182 dl_error()
 183     CODE:
 184     RETVAL = LastError ;
 185     OUTPUT:
 186     RETVAL
 187
 188 # end.