src/rxvtperl.xs

   1 /*----------------------------------------------------------------------*
   2  * File:        rxvtperl.xs
   3  *----------------------------------------------------------------------*
   4  *
   5  * All portions of code are copyright by their respective author/s.
   6  * Copyright (c) 2005-2005 Marc Lehmann <pcg@goof.com>
   7  *
   8  * This program is free software; you can redistribute it and/or modify
   9  * it under the terms of the GNU General Public License as published by
  10  * the Free Software Foundation; either version 2 of the License, or
  11  * (at your option) any later version.
  12  *
  13  * This program is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  * GNU General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU General Public License
  19  * along with this program; if not, write to the Free Software
  20  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21  *----------------------------------------------------------------------*/
  22
  23 #define line_t perl_line_t
  24 #include <EXTERN.h>
  25 #include <perl.h>
  26 #include <XSUB.h>
  27 #undef line_t
  28
  29 #include "../config.h"
  30
  31 #include <cstdarg>
  32
  33 #include "rxvt.h"
  34 #include "iom.h"
  35 #include "rxvtutil.h"
  36 #include "rxvtperl.h"
  37
  38 #include "perlxsi.c"
  39
  40 /////////////////////////////////////////////////////////////////////////////
  41
  42 static wchar_t *
  43 sv2wcs (SV *sv)
  44 {
  45   STRLEN len;
  46   char *str = SvPVutf8 (sv, len);
  47   return rxvt_utf8towcs (str, len);
  48 }
  49
  50 static SV *
  51 new_ref (HV *hv, const char *klass)
  52 {
  53   return sv_bless (newRV ((SV *)hv), gv_stashpv (klass, 1));
  54 }
  55
  56 //TODO: use magic
  57 static SV *
  58 newSVptr (void *ptr, const char *klass)
  59 {
  60   HV *hv = newHV ();
  61   hv_store (hv, "_ptr", 4, newSViv ((long)ptr), 0);
  62   return sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
  63 }
  64
  65 static long
  66 SvPTR (SV *sv, const char *klass)
  67 {
  68   if (!sv_derived_from (sv, klass))
  69     croak ("object of type %s expected", klass);
  70
  71   IV iv = SvIV (*hv_fetch ((HV *)SvRV (sv), "_ptr", 4, 1));
  72
  73   if (!iv)
  74     croak ("perl code used %s object, but C++ object is already destroyed, caught", klass);
  75
  76   return (long)iv;
  77 }
  78
  79 #define newSVterm(term) SvREFCNT_inc ((SV *)term->self)
  80 #define SvTERM(sv) (rxvt_term *)SvPTR (sv, "urxvt::term")
  81
  82 /////////////////////////////////////////////////////////////////////////////
  83
  84 struct perl_watcher
  85 {
  86   SV *cbsv;
  87   HV *self;
  88
  89   perl_watcher ()
  90   : cbsv (newSV (0))
  91   {
  92   }
  93
  94   ~perl_watcher ()
  95   {
  96     SvREFCNT_dec (cbsv);
  97   }
  98
  99   void cb (SV *cb)
 100   {
 101     sv_setsv (cbsv, cb);
 102   }
 103
 104   void invoke (const char *type, SV *self, int arg = -1);
 105 };
 106
 107 void
 108 perl_watcher::invoke (const char *type, SV *self, int arg)
 109 {
 110   dSP;
 111
 112   ENTER;
 113   SAVETMPS;
 114
 115   PUSHMARK (SP);
 116
 117   XPUSHs (sv_2mortal (self));
 118
 119   if (arg >= 0)
 120     XPUSHs (sv_2mortal (newSViv (arg)));
 121
 122   PUTBACK;
 123   call_sv (cbsv, G_VOID | G_EVAL | G_DISCARD);
 124   SPAGAIN;
 125
 126   PUTBACK;
 127   FREETMPS;
 128   LEAVE;
 129
 130   if (SvTRUE (ERRSV))
 131     rxvt_warn ("%s callback evaluation error: %s", type, SvPV_nolen (ERRSV));
 132 }
 133
 134 #define newSVtimer(timer) new_ref (timer->self, "urxvt::timer")
 135 #define SvTIMER(sv) (timer *)SvPTR (sv, "urxvt::timer")
 136
 137 struct timer : time_watcher, perl_watcher
 138 {
 139   timer ()
 140   : time_watcher (this, &timer::execute)
 141   {
 142   }
 143
 144   void execute (time_watcher &w)
 145   {
 146     invoke ("urxvt::timer", newSVtimer (this));
 147   }
 148 };
 149
 150 #define newSViow(iow) new_ref (iow->self, "urxvt::iow")
 151 #define SvIOW(sv) (iow *)SvPTR (sv, "urxvt::iow")
 152
 153 struct iow : io_watcher, perl_watcher
 154 {
 155   iow ()
 156   : io_watcher (this, &iow::execute)
 157   {
 158   }
 159
 160   void execute (io_watcher &w, short revents)
 161   {
 162     invoke ("urxvt::iow", newSViow (this), revents);
 163   }
 164 };
 165
 166 /////////////////////////////////////////////////////////////////////////////
 167
 168 struct rxvt_perl_interp rxvt_perl;
 169
 170 static PerlInterpreter *perl;
 171
 172 rxvt_perl_interp::rxvt_perl_interp ()
 173 {
 174 }
 175
 176 rxvt_perl_interp::~rxvt_perl_interp ()
 177 {
 178   if (perl)
 179     {
 180       perl_destruct (perl);
 181       perl_free (perl);
 182     }
 183 }
 184
 185 void
 186 rxvt_perl_interp::init ()
 187 {
 188   if (!perl)
 189     {
 190       char *argv[] = {
 191         "",
 192         "-edo '" LIBDIR "/urxvt.pm' or ($@ and die $@) or exit 1",
 193       };
 194
 195       perl = perl_alloc ();
 196       perl_construct (perl);
 197
 198       if (perl_parse (perl, xs_init, 2, argv, (char **)NULL)
 199           || perl_run (perl))
 200         {
 201           rxvt_warn ("unable to initialize perl-interpreter, continuing without.\n");
 202
 203           perl_destruct (perl);
 204           perl_free (perl);
 205           perl = 0;
 206         }
 207     }
 208 }
 209
 210 bool
 211 rxvt_perl_interp::invoke (rxvt_term *term, hook_type htype, ...)
 212 {
 213   if (!perl
 214       || (!should_invoke [htype] && htype != HOOK_INIT && htype != HOOK_DESTROY))
 215     return false;
 216
 217   if (htype == HOOK_INIT) // first hook ever called
 218     term->self = (void *)newSVptr ((void *)term, "urxvt::term");
 219
 220   dSP;
 221   va_list ap;
 222
 223   va_start (ap, htype);
 224
 225   ENTER;
 226   SAVETMPS;
 227
 228   PUSHMARK (SP);
 229
 230   XPUSHs (sv_2mortal (newSVterm (term)));
 231   XPUSHs (sv_2mortal (newSViv (htype)));
 232
 233   for (;;) {
 234     data_type dt = (data_type)va_arg (ap, int);
 235
 236     switch (dt)
 237       {
 238         case DT_INT:
 239           XPUSHs (sv_2mortal (newSViv (va_arg (ap, int))));
 240           break;
 241
 242         case DT_LONG:
 243           XPUSHs (sv_2mortal (newSViv (va_arg (ap, long))));
 244           break;
 245
 246         case DT_STRING:
 247           XPUSHs (sv_2mortal (newSVpv (va_arg (ap, char *), 0)));
 248           break;
 249
 250         case DT_END:
 251           {
 252             va_end (ap);
 253
 254             PUTBACK;
 255             int count = call_pv ("urxvt::invoke", G_ARRAY | G_EVAL);
 256             SPAGAIN;
 257
 258             if (count)
 259               {
 260                 SV *status = POPs;
 261                 count = SvTRUE (status);
 262               }
 263
 264             PUTBACK;
 265             FREETMPS;
 266             LEAVE;
 267
 268             if (SvTRUE (ERRSV))
 269               rxvt_warn ("perl hook %d evaluation error: %s", htype, SvPV_nolen (ERRSV));
 270
 271             if (htype == HOOK_DESTROY)
 272               {
 273                 // TODO: clear magic
 274                 hv_clear ((HV *)SvRV ((SV *)term->self));
 275                 SvREFCNT_dec ((SV *)term->self);
 276               }
 277
 278             return count;
 279           }
 280
 281         default:
 282           rxvt_fatal ("FATAL: unable to pass data type %d\n", dt);
 283       }
 284   }
 285 }
 286
 287 /////////////////////////////////////////////////////////////////////////////
 288
 289 MODULE = urxvt             PACKAGE = urxvt
 290
 291 PROTOTYPES: ENABLE
 292
 293 BOOT:
 294 {
 295 # define set_hookname(sym) av_store (hookname, PP_CONCAT(HOOK_, sym), newSVpv (PP_STRINGIFY(sym), 0))
 296   AV *hookname = get_av ("urxvt::HOOKNAME", 1);
 297   set_hookname (INIT);
 298   set_hookname (RESET);
 299   set_hookname (START);
 300   set_hookname (DESTROY);
 301   set_hookname (SEL_BEGIN);
 302   set_hookname (SEL_EXTEND);
 303   set_hookname (SEL_MAKE);
 304   set_hookname (SEL_GRAB);
 305   set_hookname (FOCUS_IN);
 306   set_hookname (FOCUS_OUT);
 307   set_hookname (VIEW_CHANGE);
 308   set_hookname (SCROLL_BACK);
 309   set_hookname (TTY_ACTIVITY);
 310   set_hookname (REFRESH_BEGIN);
 311   set_hookname (REFRESH_END);
 312   set_hookname (KEYBOARD_COMMAND);
 313
 314   sv_setpv (get_sv ("urxvt::LIBDIR", 1), LIBDIR);
 315 }
 316
 317 void
 318 set_should_invoke (int htype, int value)
 319         CODE:
 320         rxvt_perl.should_invoke [htype] = value;
 321
 322 void
 323 warn (const char *msg)
 324         CODE:
 325         rxvt_warn ("%s", msg);
 326
 327 void
 328 fatal (const char *msg)
 329         CODE:
 330         rxvt_fatal ("%s", msg);
 331
 332 NV
 333 NOW ()
 334         CODE:
 335         RETVAL = NOW;
 336         OUTPUT:
 337         RETVAL
 338
 339 MODULE = urxvt             PACKAGE = urxvt::term
 340
 341 int
 342 rxvt_term::strwidth (SV *str)
 343         CODE:
 344 {
 345         wchar_t *wstr = sv2wcs (str);
 346
 347         rxvt_push_locale (THIS->locale);
 348         RETVAL = wcswidth (wstr, wcslen (wstr));
 349         rxvt_pop_locale ();
 350
 351         free (wstr);
 352 }
 353         OUTPUT:
 354         RETVAL
 355
 356 SV *
 357 rxvt_term::locale_encode (SV *str)
 358         CODE:
 359 {
 360         wchar_t *wstr = sv2wcs (str);
 361
 362         rxvt_push_locale (THIS->locale);
 363         char *mbstr = rxvt_wcstombs (wstr);
 364         rxvt_pop_locale ();
 365
 366         free (wstr);
 367
 368         RETVAL = newSVpv (mbstr, 0);
 369         free (mbstr);
 370 }
 371         OUTPUT:
 372         RETVAL
 373
 374 SV *
 375 rxvt_term::locale_decode (SV *octets)
 376         CODE:
 377 {
 378         STRLEN len;
 379         char *data = SvPVbyte (octets, len);
 380
 381         rxvt_push_locale (THIS->locale);
 382         wchar_t *wstr = rxvt_mbstowcs (data, len);
 383         rxvt_pop_locale ();
 384
 385         char *str = rxvt_wcstoutf8 (wstr);
 386         free (wstr);
 387
 388         RETVAL = newSVpv (str, 0);
 389         SvUTF8_on (RETVAL);
 390         free (str);
 391 }
 392         OUTPUT:
 393         RETVAL
 394
 395 int
 396 rxvt_term::nsaved ()
 397         CODE:
 398         RETVAL = THIS->nsaved;
 399         OUTPUT:
 400         RETVAL
 401
 402 int
 403 rxvt_term::view_start (int newval = -1)
 404         CODE:
 405 {
 406         RETVAL = THIS->view_start;
 407
 408         if (newval >= 0)
 409           {
 410             THIS->view_start = min (newval, THIS->nsaved);
 411             THIS->scr_changeview (RETVAL);
 412           }
 413 }
 414         OUTPUT:
 415         RETVAL
 416
 417 void
 418 rxvt_term::_resource (char *name, int index, SV *newval = 0)
 419         PPCODE:
 420 {
 421         struct resval { const char *name; int value; } rslist [] = {
 422 #         define Rs_def(name) { # name, Rs_ ## name },
 423 #         define Rs_reserve(name,count)
 424 #         include "rsinc.h"
 425 #         undef Rs_def
 426 #         undef Rs_reserve
 427         };
 428
 429         struct resval *rs = rslist + sizeof (rslist) / sizeof (rslist [0]);
 430
 431         do {
 432           if (rs-- == rslist)
 433             croak ("no such resource '%s', requested", name);
 434         } while (strcmp (name, rs->name));
 435
 436         index += rs->value;
 437
 438         if (!IN_RANGE_EXC (index, 0, NUM_RESOURCES))
 439           croak ("requested out-of-bound resource %s+%d,", name, index - rs->value);
 440
 441         if (GIMME_V != G_VOID)
 442           XPUSHs (THIS->rs [index] ? sv_2mortal (newSVpv (THIS->rs [index], 0)) : &PL_sv_undef);
 443
 444         if (newval)
 445           {
 446             if (SvOK (newval))
 447               {
 448                 char *str = strdup (SvPVbyte_nolen (newval));
 449                 THIS->rs [index] = str;
 450                 THIS->allocated.push_back (str);
 451               }
 452             else
 453               THIS->rs [index] = 0;
 454           }
 455 }
 456
 457 void
 458 rxvt_term::selection_mark (...)
 459         PROTOTYPE: $;$$
 460         ALIAS:
 461            selection_beg = 1
 462            selection_end = 2
 463         PPCODE:
 464 {
 465         row_col_t &sel = ix == 1 ? THIS->selection.beg
 466                        : ix == 2 ? THIS->selection.end
 467                        :           THIS->selection.mark;
 468
 469         if (GIMME_V != G_VOID)
 470           {
 471             EXTEND (SP, 2);
 472             PUSHs (sv_2mortal (newSViv (sel.row)));
 473             PUSHs (sv_2mortal (newSViv (sel.col)));
 474           }
 475
 476         if (items == 3)
 477           {
 478             sel.row = clamp (SvIV (ST (1)), -THIS->nsaved, THIS->nrow - 1);
 479             sel.col = clamp (SvIV (ST (2)), 0, THIS->ncol - 1);
 480
 481             if (ix)
 482               THIS->want_refresh = 1;
 483           }
 484 }
 485
 486 int
 487 rxvt_term::selection_grab (int eventtime)
 488
 489 void
 490 rxvt_term::selection (SV *newtext = 0)
 491         PPCODE:
 492 {
 493         if (GIMME_V != G_VOID)
 494           {
 495             char *sel = rxvt_wcstoutf8 (THIS->selection.text, THIS->selection.len);
 496             SV *sv = newSVpv (sel, 0);
 497             SvUTF8_on (sv);
 498             free (sel);
 499             XPUSHs (sv_2mortal (sv));
 500           }
 501
 502         if (newtext)
 503           {
 504             free (THIS->selection.text);
 505
 506             THIS->selection.text = sv2wcs (newtext);
 507             THIS->selection.len = wcslen (THIS->selection.text);
 508           }
 509 }
 510
 511 void
 512 rxvt_term::scr_overlay_new (int x, int y, int w, int h)
 513
 514 void
 515 rxvt_term::scr_overlay_off ()
 516
 517 void
 518 rxvt_term::scr_overlay_set_char (int x, int y, U32 text, U32 rend = OVERLAY_RSTYLE)
 519         CODE:
 520         THIS->scr_overlay_set (x, y, text, rend);
 521
 522 void
 523 rxvt_term::scr_overlay_set (int x, int y, SV *text)
 524         CODE:
 525 {
 526         wchar_t *wtext = sv2wcs (text);
 527         THIS->scr_overlay_set (x, y, wtext);
 528         free (wtext);
 529 }
 530
 531 void
 532 rxvt_term::tt_write (SV *octets)
 533         INIT:
 534           STRLEN len;
 535           char *str = SvPVbyte (octets, len);
 536         C_ARGS:
 537           (unsigned char *)str, len
 538
 539 MODULE = urxvt             PACKAGE = urxvt::timer
 540
 541 SV *
 542 timer::new ()
 543         CODE:
 544         timer *w =  new timer;
 545         RETVAL = newSVptr ((void *)w, "urxvt::timer");
 546         w->self = (HV *)SvRV (RETVAL);
 547         OUTPUT:
 548         RETVAL
 549
 550 timer *
 551 timer::cb (SV *cb)
 552         CODE:
 553         THIS->cb (cb);
 554         RETVAL = THIS;
 555         OUTPUT:
 556         RETVAL
 557
 558 NV
 559 timer::at ()
 560         CODE:
 561         RETVAL = THIS->at;
 562         OUTPUT:
 563         RETVAL
 564
 565 timer *
 566 timer::set (NV tstamp)
 567         CODE:
 568         THIS->set (tstamp);
 569         RETVAL = THIS;
 570         OUTPUT:
 571         RETVAL
 572
 573 timer *
 574 timer::start (NV tstamp = THIS->at)
 575         CODE:
 576         THIS->start (tstamp);
 577         RETVAL = THIS;
 578         OUTPUT:
 579         RETVAL
 580
 581 timer *
 582 timer::stop ()
 583         CODE:
 584         THIS->stop ();
 585         RETVAL = THIS;
 586         OUTPUT:
 587         RETVAL
 588
 589 void
 590 timer::DESTROY ()
 591
 592 MODULE = urxvt             PACKAGE = urxvt::iow
 593
 594 SV *
 595 iow::new ()
 596         CODE:
 597         iow *w =  new iow;
 598         RETVAL = newSVptr ((void *)w, "urxvt::iow");
 599         w->self = (HV *)SvRV (RETVAL);
 600         OUTPUT:
 601         RETVAL
 602
 603 iow *
 604 iow::cb (SV *cb)
 605         CODE:
 606         THIS->cb (cb);
 607         RETVAL = THIS;
 608         OUTPUT:
 609         RETVAL
 610
 611 iow *
 612 iow::fd (int fd)
 613         CODE:
 614         THIS->fd = fd;
 615         RETVAL = THIS;
 616         OUTPUT:
 617         RETVAL
 618
 619 iow *
 620 iow::events (short events)
 621         CODE:
 622         THIS->events = events;
 623         RETVAL = THIS;
 624         OUTPUT:
 625         RETVAL
 626
 627 iow *
 628 iow::start ()
 629         CODE:
 630         THIS->start ();
 631         RETVAL = THIS;
 632         OUTPUT:
 633         RETVAL
 634
 635 iow *
 636 iow::stop ()
 637         CODE:
 638         THIS->stop ();
 639         RETVAL = THIS;
 640         OUTPUT:
 641         RETVAL
 642
 643 void
 644 iow::DESTROY ()
 645
 646