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
1 /* Copyright (c) 2004-2005 Nokia. All rights reserved. */
2
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
15 const TUint KPerlConsoleBufferMaxTChars = 0x0200;
16 const TUint KPerlConsoleNoPos           = 0xffff;
17
18 CPerlBase::CPerlBase()
19 {
20 }
21
22 EXPORT_C void CPerlBase::Destruct()
23 {
24     dTHX;
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
53 CPerlBase::~CPerlBase()
54 {
55     Destruct();
56 }
57
58 EXPORT_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
71 EXPORT_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
83 EXPORT_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
97 static int _console_stdin(void* cookie, char* buf, int n)
98 {
99     return ((CPerlBase*)cookie)->ConsoleRead(0, buf, n);
100 }
101
102 static int _console_stdout(void* cookie, const char* buf, int n)
103 {
104     return ((CPerlBase*)cookie)->ConsoleWrite(1, buf, n);
105 }
106
107 static int _console_stderr(void* cookie, const char* buf, int n)
108 {
109     return ((CPerlBase*)cookie)->ConsoleWrite(2, buf, n);
110 }
111
112 void 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
132 void 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
144     {
145         PerlInterpreter *my_perl = iPerl;
146         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
147     }
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
168 EXPORT_C PerlInterpreter* CPerlBase::GetInterpreter()
169 {
170     return (PerlInterpreter*) iPerl;
171 }
172
173 #ifdef PERL_MINIPERL
174 static void boot_DynaLoader(pTHX_ CV* cv) { }
175 #else
176 EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
177 #endif
178
179 static void xs_init(pTHX)
180 {
181     dXSUB_SYS;
182     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
183 }
184
185 EXPORT_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 }
213
214
215 EXPORT_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
232 EXPORT_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
243 EXPORT_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;
250         return ran;
251     } else
252         return -1;
253 }
254
255 EXPORT_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
262 int 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;
284         }
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
329 int 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     }
338
339     if (n < 0) {
340         errno = EINVAL;
341         return -1;
342     }
343
344     if (n == 0)
345         return 0;
346
347     TBuf8<4 * KPerlConsoleBufferMaxTChars> aBufferUtf8;
348     TBuf16<KPerlConsoleBufferMaxTChars>    aBufferUtf16;
349     int length = ConsoleReadLine();
350     int i;
351
352     iConsoleUsed += length;
353
354     aBufferUtf16.SetLength(length);
355     for (i = 0; i < length; i++)
356         aBufferUtf16[i] = iConsoleBuffer[i];
357     aBufferUtf8.SetLength(4 * length);
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)) {
371         unsigned long u = utf8_to_uvchr_buf((U8*)(pUtf8 + i),
372                                             (U8*)(pUtf8 + nUtf8),
373                                             0);
374         if (u > 0xFF) {
375             iConsole->Printf(_L("(keycode > 0xFF)\n"));
376             buf[i] = 0;
377             return -1;
378         }
379         buf[i] = u;
380     }
381 #endif
382     if (nUtf8 < n)
383         buf[nUtf8] = 0;
384     return nUtf8;
385 }
386
387 int 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)) {
410             TChar u = valid_utf8_to_uvchr((U8*)(buf + i), 0);
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