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     if (!iStdioInitFunc) {
 145         iConsole =
 146           Console::NewL(_L("Perl Console"),
 147                         TSize(KConsFullScreen, KConsFullScreen));
 148         iConsoleBuffer =
 149           (TUint16*)malloc(sizeof(TUint) *
 150                            KPerlConsoleBufferMaxTChars);
 151         User::LeaveIfNull(iConsoleBuffer);
 152         iConsoleUsed = 0;
 153 #ifndef USE_PERLIO
 154         iStdioInitFunc = &StdioRewire;
 155 #endif
 156     }
 157     if (iStdioInitFunc)
 158         iStdioInitFunc(iStdioInitCookie);
 159     iReadFunc  = NULL;
 160     iWriteFunc = NULL;
 161     iState = EPerlConstructed;
 162 }
 163
 164 EXPORT_C PerlInterpreter* CPerlBase::GetInterpreter()
 165 {
 166     return (PerlInterpreter*) iPerl;
 167 }
 168
 169 #ifdef PERL_MINIPERL
 170 static void boot_DynaLoader(pTHX_ CV* cv) { }
 171 #else
 172 EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
 173 #endif
 174
 175 static void xs_init(pTHX)
 176 {
 177     dXSUB_SYS;
 178     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
 179 }
 180
 181 EXPORT_C TInt CPerlBase::RunScriptL(const TDesC& aFileName,
 182                                     int argc,
 183                                     char **argv,
 184                                     char *envp[]) {
 185     TBuf8<KMaxFileName> scriptUtf8;
 186     TInt error;
 187     error = CnvUtfConverter::ConvertFromUnicodeToUtf8(scriptUtf8, aFileName);
 188     User::LeaveIfError(error);
 189     char *filename = (char*)scriptUtf8.PtrZ();
 190     struct stat st;
 191     if (stat(filename, &st) == -1)
 192         return KErrNotFound;
 193     if (argc < 2)
 194         return KErrGeneral; /* Anything better? */
 195     char **Argv = (char**)malloc(argc * sizeof(char*));
 196     User::LeaveIfNull(Argv);
 197     TCleanupItem ArgvCleanupItem = TCleanupItem(free, Argv);
 198     CleanupStack::PushL(ArgvCleanupItem);
 199     Argv[0] = "perl";
 200     if (argv && argc > 2)
 201         for (int i = 2; i < argc - 1; i++)
 202             Argv[i] = argv[i];
 203     Argv[argc - 1] = filename;
 204     error = this->ParseAndRun(argc, Argv, envp);
 205     CleanupStack::PopAndDestroy(Argv);
 206     Argv = 0;
 207     return error == 0 ? KErrNone : KErrGeneral;
 208 }
 209
 210
 211 EXPORT_C int CPerlBase::Parse(int argc, char *argv[], char *envp[])
 212 {
 213     if (iState == EPerlConstructed) {
 214         const char* const NullArgv[] = { "perl", "-e", "0" };
 215         if (argc == 0 || argv == 0) {
 216             argc = 3;
 217             argv = (char**) NullArgv;
 218         }
 219         PERL_SYS_INIT(&argc, &argv);
 220         int parsed = perl_parse(iPerl, xs_init, argc, argv, envp);
 221         if (parsed == 0)
 222             iState = EPerlParsed;
 223         return parsed;
 224     } else
 225         return -1;
 226 }
 227
 228 EXPORT_C void CPerlBase::SetupExit()
 229 {
 230     if (iState == EPerlParsed) {
 231         diTHX;
 232         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 233         // PL_perl_destruct level of 2 would be nice but
 234         // it causes "Unbalanced scopes" for some reason.
 235         PL_perl_destruct_level = 1;
 236     }
 237 }
 238
 239 EXPORT_C int CPerlBase::Run()
 240 {
 241     if (iState == EPerlParsed) {
 242         SetupExit();
 243         iState = EPerlRunning;
 244         int ran = perl_run(iPerl);
 245         iState = (ran == 0) ? EPerlSuccess : EPerlFailure;
 246         return ran;
 247     } else
 248         return -1;
 249 }
 250
 251 EXPORT_C int CPerlBase::ParseAndRun(int argc, char *argv[], char *envp[])
 252 {
 253     int parsed = Parse(argc, argv, envp);
 254     int ran    = (parsed == 0) ? Run() : -1;
 255     return ran;
 256 }
 257
 258 int CPerlBase::ConsoleReadLine()
 259 {
 260     if (!iConsole)
 261         return -EIO;
 262
 263     TUint currX  = KPerlConsoleNoPos;
 264     TUint currY  = KPerlConsoleNoPos;
 265     TUint prevX  = KPerlConsoleNoPos;
 266     TUint prevY  = KPerlConsoleNoPos;
 267     TUint maxX   = KPerlConsoleNoPos;
 268     TUint offset = 0;
 269
 270     for (;;) {
 271         TKeyCode code = iConsole->Getch();
 272
 273         if (code == EKeyLineFeed || code == EKeyEnter) {
 274             if (offset < KPerlConsoleBufferMaxTChars) {
 275                 iConsoleBuffer[offset++] = '\n';
 276                 iConsole->Printf(_L("\n"));
 277                 iConsoleBuffer[offset++] = 0;
 278             }
 279             break;
 280         }
 281         else {
 282             TBool doBackward  = EFalse;
 283             TBool doBackspace = EFalse;
 284
 285             prevX = currX;
 286             prevY = currY;
 287             if (code == EKeyBackspace) {
 288                 if (offset > 0) {
 289                     iConsoleBuffer[--offset] = 0;
 290                     doBackward  = ETrue;
 291                     doBackspace = ETrue;
 292                 }
 293             }
 294             else if (offset < KPerlConsoleBufferMaxTChars) {
 295                 TChar ch = TChar(code);
 296
 297                 if (ch.IsPrint()) {
 298                     iConsoleBuffer[offset++] = (unsigned short)code;
 299                     iConsole->Printf(_L("%c"), code);
 300                 }
 301             }
 302             currX = iConsole->WhereX();
 303             currY = iConsole->WhereY();
 304             if (maxX  == KPerlConsoleNoPos && prevX != KPerlConsoleNoPos &&
 305                 prevY != KPerlConsoleNoPos && currY == prevY + 1)
 306                 maxX = prevX;
 307             if (doBackward) {
 308                 if (currX > 0)
 309                     iConsole->SetPos(currX - 1);
 310                 else if (currY > 0)
 311                     iConsole->SetPos(maxX, currY - 1);
 312                 if (doBackspace) {
 313                     TUint nowX = iConsole->WhereX();
 314                     TUint nowY = iConsole->WhereY();
 315                     iConsole->Printf(_L(" ")); /* scrub */
 316                     iConsole->SetPos(nowX, nowY);
 317                 }
 318             }
 319          }
 320     }
 321
 322     return offset;
 323 }
 324
 325 int CPerlBase::ConsoleRead(const int fd, char* buf, int n)
 326 {
 327     if (iReadFunc)
 328         return iReadFunc(fd, buf, n);
 329
 330     if (!iConsole) {
 331         errno = EIO;
 332         return -1;
 333     }
 334
 335     if (n < 0) {
 336         errno = EINVAL;
 337         return -1;
 338     }
 339
 340     if (n == 0)
 341         return 0;
 342
 343     TBuf8<4 * KPerlConsoleBufferMaxTChars> aBufferUtf8;
 344     TBuf16<KPerlConsoleBufferMaxTChars>    aBufferUtf16;
 345     int length = ConsoleReadLine();
 346     int i;
 347
 348     iConsoleUsed += length;
 349
 350     aBufferUtf16.SetLength(length);
 351     for (i = 0; i < length; i++)
 352         aBufferUtf16[i] = iConsoleBuffer[i];
 353     aBufferUtf8.SetLength(4 * length);
 354
 355     CnvUtfConverter::ConvertFromUnicodeToUtf8(aBufferUtf8, aBufferUtf16);
 356
 357     char *pUtf8 = (char*)aBufferUtf8.PtrZ();
 358     int nUtf8 = aBufferUtf8.Size();
 359     if (nUtf8 > n)
 360         nUtf8 = n; /* Potential data loss. */
 361 #ifdef PERL_SYMBIAN_CONSOLE_UTF8
 362     for (i = 0; i < nUtf8; i++)
 363         buf[i] = pUtf8[i];
 364 #else
 365     dTHX;
 366     for (i = 0; i < nUtf8; i+= UTF8SKIP(pUtf8 + i)) {
 367         unsigned long u = utf8_to_uvchr_buf((U8*)(pUtf8 + i),
 368                                             (U8*)(pUtf8 + nUtf8),
 369                                             0);
 370         if (u > 0xFF) {
 371             iConsole->Printf(_L("(keycode > 0xFF)\n"));
 372             buf[i] = 0;
 373             return -1;
 374         }
 375         buf[i] = u;
 376     }
 377 #endif
 378     if (nUtf8 < n)
 379         buf[nUtf8] = 0;
 380     return nUtf8;
 381 }
 382
 383 int CPerlBase::ConsoleWrite(const int fd, const char* buf, int n)
 384 {
 385     if (iWriteFunc)
 386         return iWriteFunc(fd, buf, n);
 387
 388     if (!iConsole) {
 389         errno = EIO;
 390         return -1;
 391     }
 392
 393     if (n < 0) {
 394         errno = EINVAL;
 395         return -1;
 396     }
 397
 398     if (n == 0)
 399         return 0;
 400
 401     int wrote = 0;
 402 #ifdef PERL_SYMBIAN_CONSOLE_UTF8
 403     dTHX;
 404     if (is_utf8_string((U8*)buf, n)) {
 405         for (int i = 0; i < n; i += UTF8SKIP(buf + i)) {
 406             TChar u = valid_utf8_to_uvchr((U8*)(buf + i), 0);
 407             iConsole->Printf(_L("%c"), u);
 408             wrote++;
 409         }
 410     } else {
 411         iConsole->Printf(_L("(malformed utf8: "));
 412         for (int i = 0; i < n; i++)
 413             iConsole->Printf(_L("%02x "), buf[i]);
 414         iConsole->Printf(_L(")\n"));
 415     }
 416 #else
 417     for (int i = 0; i < n; i++) {
 418         iConsole->Printf(_L("%c"), buf[i]);
 419     }
 420     wrote = n;
 421 #endif
 422     iConsoleUsed += wrote;
 423     return n;
 424 }
 425