source: trunk/essentials/dev-lang/perl/win32/perllib.c

/*
 * "The Road goes ever on and on, down from the door where it began."
 */
#define PERLIO_NOT_STDIO 0
#include "EXTERN.h"
#include "perl.h"

#include "XSUB.h"

#ifdef PERL_IMPLICIT_SYS
#include "win32iop.h"
#include <fcntl.h>
#endif /* PERL_IMPLICIT_SYS */


/* Register any extra external extensions */
char *staticlinkmodules[] = {
    "DynaLoader",
    /* other similar records will be included from "perllibst.h" */
#define STATIC1
#include "perllibst.h"
    NULL,
};

EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
/* other similar records will be included from "perllibst.h" */
#define STATIC2
#include "perllibst.h"

static void
xs_init(pTHX)
{
    char *file = __FILE__;
    dXSUB_SYS;
    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
    /* other similar records will be included from "perllibst.h" */
#define STATIC3
#include "perllibst.h"
}

#ifdef PERL_IMPLICIT_SYS

#include "perlhost.h"

void
win32_checkTLS(PerlInterpreter *host_perl)
{
    dTHX;
    if (host_perl != my_perl) {
        int *nowhere = NULL;
        *nowhere = 0; 
        abort();
    }
}

EXTERN_C void
perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
                   struct IPerlMemInfo* perlMemSharedInfo,
                   struct IPerlMemInfo* perlMemParseInfo,
                   struct IPerlEnvInfo* perlEnvInfo,
                   struct IPerlStdIOInfo* perlStdIOInfo,
                   struct IPerlLIOInfo* perlLIOInfo,
                   struct IPerlDirInfo* perlDirInfo,
                   struct IPerlSockInfo* perlSockInfo,
                   struct IPerlProcInfo* perlProcInfo)
{
    if (perlMemInfo) {
        Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
        perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
    }
    if (perlMemSharedInfo) {
        Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*);
        perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
    }
    if (perlMemParseInfo) {
        Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*);
        perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
    }
    if (perlEnvInfo) {
        Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
        perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
    }
    if (perlStdIOInfo) {
        Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
        perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
    }
    if (perlLIOInfo) {
        Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
        perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
    }
    if (perlDirInfo) {
        Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
        perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
    }
    if (perlSockInfo) {
        Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
        perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
    }
    if (perlProcInfo) {
        Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
        perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
    }
}

EXTERN_C PerlInterpreter*
perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
                 struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
                 struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
                 struct IPerlDir** ppDir, struct IPerlSock** ppSock,
                 struct IPerlProc** ppProc)
{
    PerlInterpreter *my_perl = NULL;
    CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv,
                                     ppStdIO, ppLIO, ppDir, ppSock, ppProc);

    if (pHost) {
        my_perl = perl_alloc_using(pHost->m_pHostperlMem,
                                   pHost->m_pHostperlMemShared,
                                   pHost->m_pHostperlMemParse,
                                   pHost->m_pHostperlEnv,
                                   pHost->m_pHostperlStdIO,
                                   pHost->m_pHostperlLIO,
                                   pHost->m_pHostperlDir,
                                   pHost->m_pHostperlSock,
                                   pHost->m_pHostperlProc);
        if (my_perl) {
            w32_internal_host = pHost;
            pHost->host_perl  = my_perl;
        }
    }
    return my_perl;
}

EXTERN_C PerlInterpreter*
perl_alloc(void)
{
    PerlInterpreter* my_perl = NULL;
    CPerlHost* pHost = new CPerlHost();
    if (pHost) {
        my_perl = perl_alloc_using(pHost->m_pHostperlMem,
                                   pHost->m_pHostperlMemShared,
                                   pHost->m_pHostperlMemParse,
                                   pHost->m_pHostperlEnv,
                                   pHost->m_pHostperlStdIO,
                                   pHost->m_pHostperlLIO,
                                   pHost->m_pHostperlDir,
                                   pHost->m_pHostperlSock,
                                   pHost->m_pHostperlProc);
        if (my_perl) {
            w32_internal_host = pHost;
            pHost->host_perl  = my_perl;
        }
    }
    return my_perl;
}

EXTERN_C void
win32_delete_internal_host(void *h)
{
    CPerlHost *host = (CPerlHost*)h;
    delete host;
}

#endif /* PERL_IMPLICIT_SYS */

EXTERN_C HANDLE w32_perldll_handle;

EXTERN_C DllExport int
RunPerl(int argc, char **argv, char **env)
{
    int exitstatus;
    PerlInterpreter *my_perl, *new_perl = NULL;

#ifndef __BORLANDC__
    /* XXX this _may_ be a problem on some compilers (e.g. Borland) that
     * want to free() argv after main() returns.  As luck would have it,
     * Borland's CRT does the right thing to argv[0] already. */
    char szModuleName[MAX_PATH];

    GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
    (void)win32_longpath(szModuleName);
    argv[0] = szModuleName;
#endif

#ifdef PERL_GLOBAL_STRUCT
#define PERLVAR(var,type) /**/