This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
set PERL_EXIT_DESTRUCT_END in all embeddings
[perl5.git] / symbian / PerlBase.cpp
CommitLineData
27da23d5 1/* Copyright (c) 2004-2005 Nokia. All rights reserved. */
d1dd14d1 2
27da23d5
JH
3/* The CPerlBase class is licensed under the same terms as Perl itself. */
4
5/* See PerlBase.pod for documentation. */
6
7#define PERLBASE_CPP
8
9#include <e32cons.h>
10#include <e32keys.h>
11#include <utf.h>
12
13#include "PerlBase.h"
14
15const TUint KPerlConsoleBufferMaxTChars = 0x0200;
16const TUint KPerlConsoleNoPos = 0xffff;
17
18CPerlBase::CPerlBase()
19{
20}
21
22EXPORT_C void CPerlBase::Destruct()
23{
4dc4bba6 24 dTHX;
27da23d5
JH
25 iState = EPerlDestroying;
26 if (iConsole) {
27 iConsole->Printf(_L("[Any key to continue]"));
28 iConsole->Getch();
29 }
30 if (iPerl) {
31 (void)perl_destruct(iPerl);
32 perl_free(iPerl);
33 iPerl = NULL;
34 PERL_SYS_TERM();
35 }
36 if (iConsole) {
37 delete iConsole;
38 iConsole = NULL;
39 }
40 if (iConsoleBuffer) {
41 free(iConsoleBuffer);
42 iConsoleBuffer = NULL;
43 }
44#ifdef PERL_GLOBAL_STRUCT
45 if (iVars) {
46 PerlInterpreter* my_perl = NULL;
47 free_global_struct(iVars);
48 iVars = NULL;
49 }
50#endif
51}
52
53CPerlBase::~CPerlBase()
54{
55 Destruct();
56}
57
43639bac
AR
58EXPORT_C CPerlBase* CPerlBase::NewInterpreter(TBool aCloseStdlib,
59 void (*aStdioInitFunc)(void*),
60 void *aStdioInitCookie)
61{
62 CPerlBase* self = new (ELeave) CPerlBase;
63 self->iCloseStdlib = aCloseStdlib;
64 self->iStdioInitFunc = aStdioInitFunc;
65 self->iStdioInitCookie = aStdioInitCookie;
66 self->ConstructL();
67 PERL_APPCTX_SET(self);
68 return self;
69}
70
27da23d5
JH
71EXPORT_C CPerlBase* CPerlBase::NewInterpreterL(TBool aCloseStdlib,
72 void (*aStdioInitFunc)(void*),
73 void *aStdioInitCookie)
74{
75 CPerlBase* self =
76 CPerlBase::NewInterpreterLC(aCloseStdlib,
77 aStdioInitFunc,
78 aStdioInitCookie);
79 CleanupStack::Pop(self);
80 return self;
81}
82
83EXPORT_C CPerlBase* CPerlBase::NewInterpreterLC(TBool aCloseStdlib,
84 void (*aStdioInitFunc)(void*),
85 void *aStdioInitCookie)
86{
87 CPerlBase* self = new (ELeave) CPerlBase;
88 CleanupStack::PushL(self);
89 self->iCloseStdlib = aCloseStdlib;
90 self->iStdioInitFunc = aStdioInitFunc;
91 self->iStdioInitCookie = aStdioInitCookie;
92 self->ConstructL();
93 PERL_APPCTX_SET(self);
94 return self;
95}
96
97static int _console_stdin(void* cookie, char* buf, int n)
98{
99 return ((CPerlBase*)cookie)->ConsoleRead(0, buf, n);
100}
101
102static int _console_stdout(void* cookie, const char* buf, int n)
103{
104 return ((CPerlBase*)cookie)->ConsoleWrite(1, buf, n);
105}
106
107static int _console_stderr(void* cookie, const char* buf, int n)
108{
109 return ((CPerlBase*)cookie)->ConsoleWrite(2, buf, n);
110}
111
112void CPerlBase::StdioRewire(void *arg) {
113 _REENT->_sf[0]._cookie = (void*)this;
114 _REENT->_sf[0]._read = &_console_stdin;
115 _REENT->_sf[0]._write = 0;
116 _REENT->_sf[0]._seek = 0;
117 _REENT->_sf[0]._close = 0;
118
119 _REENT->_sf[1]._cookie = (void*)this;
120 _REENT->_sf[1]._read = 0;
121 _REENT->_sf[1]._write = &_console_stdout;
122 _REENT->_sf[1]._seek = 0;
123 _REENT->_sf[1]._close = 0;
124
125 _REENT->_sf[2]._cookie = (void*)this;
126 _REENT->_sf[2]._read = 0;
127 _REENT->_sf[2]._write = &_console_stderr;
128 _REENT->_sf[2]._seek = 0;
129 _REENT->_sf[2]._close = 0;
130}
131
132void CPerlBase::ConstructL()
133{
134 iState = EPerlNone;
135#ifdef PERL_GLOBAL_STRUCT
136 PerlInterpreter *my_perl = 0;
137 iVars = init_global_struct();
138 User::LeaveIfNull(iVars);
139#endif
140 iPerl = perl_alloc();
141 User::LeaveIfNull(iPerl);
142 iState = EPerlAllocated;
143 perl_construct(iPerl); // returns void
8e920bd3
Z
144 {
145 PerlInterpreter *my_perl = iPerl;
146 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
147 }
27da23d5
JH
148 if (!iStdioInitFunc) {
149 iConsole =
150 Console::NewL(_L("Perl Console"),
151 TSize(KConsFullScreen, KConsFullScreen));
152 iConsoleBuffer =
153 (TUint16*)malloc(sizeof(TUint) *
154 KPerlConsoleBufferMaxTChars);
155 User::LeaveIfNull(iConsoleBuffer);
156 iConsoleUsed = 0;
157#ifndef USE_PERLIO
158 iStdioInitFunc = &StdioRewire;
159#endif
160 }
161 if (iStdioInitFunc)
162 iStdioInitFunc(iStdioInitCookie);
163 iReadFunc = NULL;
164 iWriteFunc = NULL;
165 iState = EPerlConstructed;
166}
167
168EXPORT_C PerlInterpreter* CPerlBase::GetInterpreter()
169{
170 return (PerlInterpreter*) iPerl;
171}
172
173#ifdef PERL_MINIPERL
174static void boot_DynaLoader(pTHX_ CV* cv) { }
175#else
176EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
177#endif
178
179static void xs_init(pTHX)
180{
181 dXSUB_SYS;
182 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
183}
184
185EXPORT_C TInt CPerlBase::RunScriptL(const TDesC& aFileName,
186 int argc,
187 char **argv,
188 char *envp[]) {
189 TBuf8<KMaxFileName> scriptUtf8;
190 TInt error;
191 error = CnvUtfConverter::ConvertFromUnicodeToUtf8(scriptUtf8, aFileName);
192 User::LeaveIfError(error);
193 char *filename = (char*)scriptUtf8.PtrZ();
194 struct stat st;
195 if (stat(filename, &st) == -1)
196 return KErrNotFound;
197 if (argc < 2)
198 return KErrGeneral; /* Anything better? */
199 char **Argv = (char**)malloc(argc * sizeof(char*));
200 User::LeaveIfNull(Argv);
201 TCleanupItem ArgvCleanupItem = TCleanupItem(free, Argv);
202 CleanupStack::PushL(ArgvCleanupItem);
203 Argv[0] = "perl";
204 if (argv && argc > 2)
205 for (int i = 2; i < argc - 1; i++)
206 Argv[i] = argv[i];
207 Argv[argc - 1] = filename;
208 error = this->ParseAndRun(argc, Argv, envp);
209 CleanupStack::PopAndDestroy(Argv);
210 Argv = 0;
211 return error == 0 ? KErrNone : KErrGeneral;
212}
d1dd14d1 213
27da23d5
JH
214
215EXPORT_C int CPerlBase::Parse(int argc, char *argv[], char *envp[])
216{
217 if (iState == EPerlConstructed) {
218 const char* const NullArgv[] = { "perl", "-e", "0" };
219 if (argc == 0 || argv == 0) {
220 argc = 3;
221 argv = (char**) NullArgv;
222 }
223 PERL_SYS_INIT(&argc, &argv);
224 int parsed = perl_parse(iPerl, xs_init, argc, argv, envp);
225 if (parsed == 0)
226 iState = EPerlParsed;
227 return parsed;
228 } else
229 return -1;
230}
231
232EXPORT_C void CPerlBase::SetupExit()
233{
234 if (iState == EPerlParsed) {
235 diTHX;
236 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
237 // PL_perl_destruct level of 2 would be nice but
238 // it causes "Unbalanced scopes" for some reason.
239 PL_perl_destruct_level = 1;
240 }
241}
242
243EXPORT_C int CPerlBase::Run()
244{
245 if (iState == EPerlParsed) {
246 SetupExit();
247 iState = EPerlRunning;
248 int ran = perl_run(iPerl);
249 iState = (ran == 0) ? EPerlSuccess : EPerlFailure;
d1dd14d1 250 return ran;
27da23d5
JH
251 } else
252 return -1;
253}
254
255EXPORT_C int CPerlBase::ParseAndRun(int argc, char *argv[], char *envp[])
256{
257 int parsed = Parse(argc, argv, envp);
258 int ran = (parsed == 0) ? Run() : -1;
259 return ran;
260}
261
262int CPerlBase::ConsoleReadLine()
263{
264 if (!iConsole)
265 return -EIO;
266
267 TUint currX = KPerlConsoleNoPos;
268 TUint currY = KPerlConsoleNoPos;
269 TUint prevX = KPerlConsoleNoPos;
270 TUint prevY = KPerlConsoleNoPos;
271 TUint maxX = KPerlConsoleNoPos;
272 TUint offset = 0;
273
274 for (;;) {
275 TKeyCode code = iConsole->Getch();
276
277 if (code == EKeyLineFeed || code == EKeyEnter) {
278 if (offset < KPerlConsoleBufferMaxTChars) {
279 iConsoleBuffer[offset++] = '\n';
280 iConsole->Printf(_L("\n"));
281 iConsoleBuffer[offset++] = 0;
282 }
283 break;
d1dd14d1 284 }
27da23d5
JH
285 else {
286 TBool doBackward = EFalse;
287 TBool doBackspace = EFalse;
288
289 prevX = currX;
290 prevY = currY;
291 if (code == EKeyBackspace) {
292 if (offset > 0) {
293 iConsoleBuffer[--offset] = 0;
294 doBackward = ETrue;
295 doBackspace = ETrue;
296 }
297 }
298 else if (offset < KPerlConsoleBufferMaxTChars) {
299 TChar ch = TChar(code);
300
301 if (ch.IsPrint()) {
302 iConsoleBuffer[offset++] = (unsigned short)code;
303 iConsole->Printf(_L("%c"), code);
304 }
305 }
306 currX = iConsole->WhereX();
307 currY = iConsole->WhereY();
308 if (maxX == KPerlConsoleNoPos && prevX != KPerlConsoleNoPos &&
309 prevY != KPerlConsoleNoPos && currY == prevY + 1)
310 maxX = prevX;
311 if (doBackward) {
312 if (currX > 0)
313 iConsole->SetPos(currX - 1);
314 else if (currY > 0)
315 iConsole->SetPos(maxX, currY - 1);
316 if (doBackspace) {
317 TUint nowX = iConsole->WhereX();
318 TUint nowY = iConsole->WhereY();
319 iConsole->Printf(_L(" ")); /* scrub */
320 iConsole->SetPos(nowX, nowY);
321 }
322 }
323 }
324 }
325
326 return offset;
327}
328
329int CPerlBase::ConsoleRead(const int fd, char* buf, int n)
330{
331 if (iReadFunc)
332 return iReadFunc(fd, buf, n);
333
334 if (!iConsole) {
335 errno = EIO;
336 return -1;
337 }
d1dd14d1 338
27da23d5
JH
339 if (n < 0) {
340 errno = EINVAL;
341 return -1;
342 }
d1dd14d1 343
27da23d5
JH
344 if (n == 0)
345 return 0;
d1dd14d1 346
27da23d5
JH
347 TBuf8<4 * KPerlConsoleBufferMaxTChars> aBufferUtf8;
348 TBuf16<KPerlConsoleBufferMaxTChars> aBufferUtf16;
349 int length = ConsoleReadLine();
d1dd14d1 350 int i;
27da23d5
JH
351
352 iConsoleUsed += length;
353
354 aBufferUtf16.SetLength(length);
355 for (i = 0; i < length; i++)
356 aBufferUtf16[i] = iConsoleBuffer[i];
d1dd14d1 357 aBufferUtf8.SetLength(4 * length);
27da23d5
JH
358
359 CnvUtfConverter::ConvertFromUnicodeToUtf8(aBufferUtf8, aBufferUtf16);
360
361 char *pUtf8 = (char*)aBufferUtf8.PtrZ();
362 int nUtf8 = aBufferUtf8.Size();
363 if (nUtf8 > n)
364 nUtf8 = n; /* Potential data loss. */
365#ifdef PERL_SYMBIAN_CONSOLE_UTF8
366 for (i = 0; i < nUtf8; i++)
367 buf[i] = pUtf8[i];
368#else
369 dTHX;
370 for (i = 0; i < nUtf8; i+= UTF8SKIP(pUtf8 + i)) {
4b88fb76
KW
371 unsigned long u = utf8_to_uvchr_buf((U8*)(pUtf8 + i),
372 (U8*)(pUtf8 + nUtf8),
373 0);
27da23d5
JH
374 if (u > 0xFF) {
375 iConsole->Printf(_L("(keycode > 0xFF)\n"));
376 buf[i] = 0;
377 return -1;
378 }
379 buf[i] = u;
d1dd14d1 380 }
27da23d5
JH
381#endif
382 if (nUtf8 < n)
383 buf[nUtf8] = 0;
384 return nUtf8;
385}
386
387int CPerlBase::ConsoleWrite(const int fd, const char* buf, int n)
388{
389 if (iWriteFunc)
390 return iWriteFunc(fd, buf, n);
391
392 if (!iConsole) {
393 errno = EIO;
394 return -1;
395 }
396
397 if (n < 0) {
398 errno = EINVAL;
399 return -1;
400 }
401
402 if (n == 0)
403 return 0;
404
405 int wrote = 0;
406#ifdef PERL_SYMBIAN_CONSOLE_UTF8
407 dTHX;
408 if (is_utf8_string((U8*)buf, n)) {
409 for (int i = 0; i < n; i += UTF8SKIP(buf + i)) {
4b88fb76 410 TChar u = valid_utf8_to_uvchr((U8*)(buf + i), 0);
27da23d5
JH
411 iConsole->Printf(_L("%c"), u);
412 wrote++;
413 }
414 } else {
415 iConsole->Printf(_L("(malformed utf8: "));
416 for (int i = 0; i < n; i++)
417 iConsole->Printf(_L("%02x "), buf[i]);
418 iConsole->Printf(_L(")\n"));
419 }
420#else
421 for (int i = 0; i < n; i++) {
422 iConsole->Printf(_L("%c"), buf[i]);
423 }
424 wrote = n;
425#endif
426 iConsoleUsed += wrote;
427 return n;
428}
429