| 1 | |
| 2 | /* |
| 3 | * Copyright © 2001 Novell, Inc. All Rights Reserved. |
| 4 | * |
| 5 | * You may distribute under the terms of either the GNU General Public |
| 6 | * License or the Artistic License, as specified in the README file. |
| 7 | * |
| 8 | */ |
| 9 | |
| 10 | /* |
| 11 | * FILENAME : perllib.c |
| 12 | * DESCRIPTION : Library functions for parsing and running Perl. |
| 13 | * This is based on the perllib.c file of Win32 port. |
| 14 | * Author : SGP |
| 15 | * Date : January 2001. |
| 16 | * |
| 17 | */ |
| 18 | |
| 19 | /* |
| 20 | * "The Road goes ever on and on, down from the door where it began." |
| 21 | */ |
| 22 | |
| 23 | |
| 24 | |
| 25 | #include "EXTERN.h" |
| 26 | #include "perl.h" |
| 27 | |
| 28 | |
| 29 | #ifdef PERL_OBJECT |
| 30 | #define NO_XSLOCKS |
| 31 | #endif |
| 32 | |
| 33 | //CHKSGP |
| 34 | //Including this is giving premature end-of-file error during compilation |
| 35 | //#include "XSUB.h" |
| 36 | |
| 37 | #ifdef PERL_IMPLICIT_SYS |
| 38 | |
| 39 | #include "nw5iop.h" |
| 40 | #include <fcntl.h> |
| 41 | |
| 42 | #endif //PERL_IMPLICIT_SYS |
| 43 | |
| 44 | |
| 45 | #ifdef PERL_IMPLICIT_SYS |
| 46 | |
| 47 | #include "nwperlhost.h" |
| 48 | #define w32_internal_host (PL_sys_intern.internal_host) // (J) |
| 49 | |
| 50 | |
| 51 | EXTERN_C void |
| 52 | perl_get_host_info(struct IPerlMemInfo* perlMemInfo, |
| 53 | struct IPerlMemInfo* perlMemSharedInfo, |
| 54 | struct IPerlMemInfo* perlMemParseInfo, |
| 55 | struct IPerlEnvInfo* perlEnvInfo, |
| 56 | struct IPerlStdIOInfo* perlStdIOInfo, |
| 57 | struct IPerlLIOInfo* perlLIOInfo, |
| 58 | struct IPerlDirInfo* perlDirInfo, |
| 59 | struct IPerlSockInfo* perlSockInfo, |
| 60 | struct IPerlProcInfo* perlProcInfo) |
| 61 | { |
| 62 | if (perlMemInfo) { |
| 63 | Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); |
| 64 | perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); |
| 65 | } |
| 66 | if (perlMemSharedInfo) { |
| 67 | Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); |
| 68 | perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); |
| 69 | } |
| 70 | if (perlMemParseInfo) { |
| 71 | Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); |
| 72 | perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); |
| 73 | } |
| 74 | if (perlEnvInfo) { |
| 75 | Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); |
| 76 | perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); |
| 77 | } |
| 78 | if (perlStdIOInfo) { |
| 79 | Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); |
| 80 | perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); |
| 81 | } |
| 82 | if (perlLIOInfo) { |
| 83 | Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); |
| 84 | perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); |
| 85 | } |
| 86 | if (perlDirInfo) { |
| 87 | Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); |
| 88 | perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); |
| 89 | } |
| 90 | if (perlSockInfo) { |
| 91 | Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); |
| 92 | perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); |
| 93 | } |
| 94 | if (perlProcInfo) { |
| 95 | Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); |
| 96 | perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); |
| 97 | } |
| 98 | } |
| 99 | |
| 100 | EXTERN_C PerlInterpreter* |
| 101 | perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, |
| 102 | struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, |
| 103 | struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, |
| 104 | struct IPerlDir** ppDir, struct IPerlSock** ppSock, |
| 105 | struct IPerlProc** ppProc) |
| 106 | { |
| 107 | PerlInterpreter *my_perl = NULL; |
| 108 | CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, |
| 109 | ppStdIO, ppLIO, ppDir, ppSock, ppProc); |
| 110 | |
| 111 | if (pHost) { |
| 112 | my_perl = perl_alloc_using(pHost->m_pHostperlMem, |
| 113 | pHost->m_pHostperlMemShared, |
| 114 | pHost->m_pHostperlMemParse, |
| 115 | pHost->m_pHostperlEnv, |
| 116 | pHost->m_pHostperlStdIO, |
| 117 | pHost->m_pHostperlLIO, |
| 118 | pHost->m_pHostperlDir, |
| 119 | pHost->m_pHostperlSock, |
| 120 | pHost->m_pHostperlProc); |
| 121 | if (my_perl) { |
| 122 | #ifdef PERL_OBJECT |
| 123 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 124 | #endif |
| 125 | w32_internal_host = pHost; |
| 126 | } |
| 127 | } |
| 128 | return my_perl; |
| 129 | } |
| 130 | |
| 131 | EXTERN_C PerlInterpreter* |
| 132 | perl_alloc(void) |
| 133 | { |
| 134 | PerlInterpreter* my_perl = NULL; |
| 135 | CPerlHost* pHost = new CPerlHost(); |
| 136 | if (pHost) { |
| 137 | my_perl = perl_alloc_using(pHost->m_pHostperlMem, |
| 138 | pHost->m_pHostperlMemShared, |
| 139 | pHost->m_pHostperlMemParse, |
| 140 | pHost->m_pHostperlEnv, |
| 141 | pHost->m_pHostperlStdIO, |
| 142 | pHost->m_pHostperlLIO, |
| 143 | pHost->m_pHostperlDir, |
| 144 | pHost->m_pHostperlSock, |
| 145 | pHost->m_pHostperlProc); |
| 146 | if (my_perl) { |
| 147 | #ifdef PERL_OBJECT |
| 148 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 149 | #endif |
| 150 | //The following Should be uncommented - CHKSGP |
| 151 | w32_internal_host = pHost; |
| 152 | } |
| 153 | } |
| 154 | return my_perl; |
| 155 | } |
| 156 | |
| 157 | EXTERN_C void |
| 158 | nw_delete_internal_host(void *h) |
| 159 | { |
| 160 | CPerlHost *host = (CPerlHost*)h; |
| 161 | if(host && h) |
| 162 | { |
| 163 | delete host; |
| 164 | host=NULL; |
| 165 | h=NULL; |
| 166 | } |
| 167 | } |
| 168 | |
| 169 | #ifdef PERL_OBJECT |
| 170 | |
| 171 | EXTERN_C void |
| 172 | perl_construct(PerlInterpreter* my_perl) |
| 173 | { |
| 174 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 175 | try |
| 176 | { |
| 177 | Perl_construct(); |
| 178 | } |
| 179 | catch(...) |
| 180 | { |
| 181 | win32_fprintf(stderr, "%s\n", |
| 182 | "Error: Unable to construct data structures"); |
| 183 | perl_free(my_perl); |
| 184 | } |
| 185 | } |
| 186 | |
| 187 | EXTERN_C void |
| 188 | perl_destruct(PerlInterpreter* my_perl) |
| 189 | { |
| 190 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 191 | #ifdef DEBUGGING |
| 192 | Perl_destruct(); |
| 193 | #else |
| 194 | try |
| 195 | { |
| 196 | Perl_destruct(); |
| 197 | } |
| 198 | catch(...) |
| 199 | { |
| 200 | } |
| 201 | #endif |
| 202 | } |
| 203 | |
| 204 | EXTERN_C void |
| 205 | perl_free(PerlInterpreter* my_perl) |
| 206 | { |
| 207 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 208 | void *host = w32_internal_host; |
| 209 | #ifdef DEBUGGING |
| 210 | Perl_free(); |
| 211 | #else |
| 212 | try |
| 213 | { |
| 214 | Perl_free(); |
| 215 | } |
| 216 | catch(...) |
| 217 | { |
| 218 | } |
| 219 | #endif |
| 220 | win32_delete_internal_host(host); |
| 221 | PERL_SET_THX(NULL); |
| 222 | } |
| 223 | |
| 224 | EXTERN_C int |
| 225 | perl_run(PerlInterpreter* my_perl) |
| 226 | { |
| 227 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 228 | int retVal; |
| 229 | #ifdef DEBUGGING |
| 230 | retVal = Perl_run(); |
| 231 | #else |
| 232 | try |
| 233 | { |
| 234 | retVal = Perl_run(); |
| 235 | } |
| 236 | catch(...) |
| 237 | { |
| 238 | win32_fprintf(stderr, "Error: Runtime exception\n"); |
| 239 | retVal = -1; |
| 240 | } |
| 241 | #endif |
| 242 | return retVal; |
| 243 | } |
| 244 | |
| 245 | EXTERN_C int |
| 246 | perl_parse(PerlInterpreter* my_perl, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env) |
| 247 | { |
| 248 | int retVal; |
| 249 | CPerlObj* pPerl = (CPerlObj*)my_perl; |
| 250 | #ifdef DEBUGGING |
| 251 | retVal = Perl_parse(xsinit, argc, argv, env); |
| 252 | #else |
| 253 | try |
| 254 | { |
| 255 | retVal = Perl_parse(xsinit, argc, argv, env); |
| 256 | } |
| 257 | catch(...) |
| 258 | { |
| 259 | win32_fprintf(stderr, "Error: Parse exception\n"); |
| 260 | retVal = -1; |
| 261 | } |
| 262 | #endif |
| 263 | *win32_errno() = 0; |
| 264 | return retVal; |
| 265 | } |
| 266 | |
| 267 | #undef PL_perl_destruct_level |
| 268 | #define PL_perl_destruct_level int dummy |
| 269 | |
| 270 | #endif /* PERL_OBJECT */ |
| 271 | #endif /* PERL_IMPLICIT_SYS */ |
| 272 | |
| 273 | |