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