ext/DynaLoader/dl_mpeix.xs

   1 /*
   2  * Author:  Mark Klein (mklein@dis.com)
   3  * Version: 2.1, 1996/07/25
   4  * Version: 2.2, 1997/09/25 Mark Bixby (markb@cccd.edu)
   5  * Version: 2.3, 1998/11/19 Mark Bixby (markb@cccd.edu)
   6  * Version: 2.4, 2002/03/24 Mark Bixby (mark@bixby.org)
   7  */
   8
   9 #include "EXTERN.h"
  10 #include "perl.h"
  11 #include "XSUB.h"
  12
  13 #ifdef __GNUC__
  14 extern void HPGETPROCPLABEL(    int    parms,
  15                                 char * procname,
  16                                 void * plabel,
  17                                 int  * status,
  18                                 char * firstfile,
  19                                 int    casesensitive,
  20                                 int    symboltype,
  21                                 int  * datasize,
  22                                 int    position,
  23                                 int    searchpath,
  24                                 int    binding);
  25 #else
  26 #pragma intrinsic HPGETPROCPLABEL
  27 #endif
  28 #include "dlutils.c"    /* for SaveError() etc */
  29
  30 typedef struct {
  31   char  filename[PATH_MAX + 3];
  32   } t_mpe_dld, *p_mpe_dld;
  33
  34 static void
  35 dl_private_init(pTHX)
  36 {
  37     (void)dl_generic_private_init(aTHX);
  38 }
  39
  40 MODULE = DynaLoader     PACKAGE = DynaLoader
  41
  42 BOOT:
  43     (void)dl_private_init(aTHX);
  44
  45 void *
  46 dl_load_file(filename, flags=0)
  47     char *      filename
  48     int         flags
  49     PREINIT:
  50     char                buf[PATH_MAX + 3];
  51     p_mpe_dld           obj = NULL;
  52
  53     CODE:
  54     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,
  55 flags));
  56     if (flags & 0x01)
  57         Perl_warn(aTHX_
  58 "Can't make loaded symbols global on this platform while loading %s",filename);
  59     obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld));
  60     memzero(obj, sizeof(t_mpe_dld));
  61     if (filename[0] != '/')
  62         {
  63         getcwd(buf,sizeof(buf));
  64         sprintf(obj->filename," %s/%s ",buf,filename);
  65         }
  66     else
  67         sprintf(obj->filename," %s ",filename);
  68
  69     DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", obj));
  70
  71     ST(0) = sv_newmortal() ;
  72     if (obj == NULL)
  73         SaveError(aTHX_"%s",Strerror(errno));
  74     else
  75         sv_setiv( ST(0), PTR2IV(obj) );
  76
  77 void *
  78 dl_find_symbol(libhandle, symbolname)
  79     void *      libhandle
  80     char *      symbolname
  81     CODE:
  82     int       datalen;
  83     p_mpe_dld obj = (p_mpe_dld) libhandle;
  84     char      symname[PATH_MAX + 3];
  85     void *    symaddr = NULL;
  86     int       status;
  87     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n",
  88                 libhandle, symbolname));
  89     ST(0) = sv_newmortal() ;
  90     errno = 0;
  91
  92     sprintf(symname, " %s ", symbolname);
  93     HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1,
  94                     0, &datalen, 1, 0, 0);
  95
  96     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"  symbolref(PROCEDURE) = %x, status=%x\n", symaddr, status));
  97
  98     if (status != 0) {
  99         SaveError(aTHX_"%s",(errno) ? Strerror(errno) : "Symbol not found") ;
 100     } else {
 101         sv_setiv( ST(0), PTR2IV(symaddr) );
 102     }
 103
 104 void
 105 dl_undef_symbols()
 106     PPCODE:
 107
 108 # These functions should not need changing on any platform:
 109
 110 void
 111 dl_install_xsub(perl_name, symref, filename="$Package")
 112     char *      perl_name
 113     void *      symref
 114     char *      filename
 115     CODE:
 116     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
 117             perl_name, symref));
 118     ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
 119                                               (void(*)(pTHX_ CV *))symref,
 120                                               filename, NULL,
 121                                               XS_DYNAMIC_FILENAME)));
 122
 123 char *
 124 dl_error()
 125     CODE:
 126     dMY_CXT;
 127     RETVAL = dl_last_error ;
 128     OUTPUT:
 129     RETVAL
 130
 131 # end.