home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / perl-5.003-base.tgz / perl-5.003-base.tar / fsf / perl / ext / DynaLoader / dl_os2.xs < prev    next >
Text File  |  1996-03-25  |  4KB  |  189 lines
  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,fprintf(stderr,"dl_load_file(%s):\n", filename));
  130.     RETVAL = dlopen(filename, mode) ;
  131.     DLDEBUG(2,fprintf(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,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
  149.     libhandle, symbolname));
  150.     RETVAL = dlsym(libhandle, symbolname);
  151.     DLDEBUG(2,fprintf(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,fprintf(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.
  189.