ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/rxvt-unicode/src/rxvtperl.xs
Revision: 1.6
Committed: Mon Jan 2 21:17:01 2006 UTC (18 years, 6 months ago) by root
Branch: MAIN
Changes since 1.5: +5 -0 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.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 root 1.5 if (!perl
214     || (!should_invoke [htype] && htype != HOOK_INIT && htype != HOOK_DESTROY))
215 root 1.1 return false;
216 root 1.4
217 root 1.1 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 root 1.6 case DT_STRING:
247     XPUSHs (sv_2mortal (newSVpv (va_arg (ap, char *), 0)));
248     break;
249    
250 root 1.1 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 root 1.4 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 root 1.1 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 root 1.6 set_hookname (KEYBOARD_COMMAND);
313 root 1.1
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 root 1.3 NV
333     NOW ()
334     CODE:
335     RETVAL = NOW;
336     OUTPUT:
337     RETVAL
338    
339     MODULE = urxvt PACKAGE = urxvt::term
340    
341 root 1.1 int
342 root 1.3 rxvt_term::strwidth (SV *str)
343 root 1.1 CODE:
344     {
345     wchar_t *wstr = sv2wcs (str);
346 root 1.3
347     rxvt_push_locale (THIS->locale);
348 root 1.1 RETVAL = wcswidth (wstr, wcslen (wstr));
349 root 1.3 rxvt_pop_locale ();
350    
351 root 1.1 free (wstr);
352     }
353     OUTPUT:
354     RETVAL
355    
356 root 1.3 SV *
357     rxvt_term::locale_encode (SV *str)
358 root 1.1 CODE:
359 root 1.3 {
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 root 1.1 RETVAL
373    
374 root 1.3 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 root 1.1
395     void
396 root 1.2 rxvt_term::_resource (char *name, int index, SV *newval = 0)
397     PPCODE:
398     {
399     struct resval { const char *name; int value; } rslist [] = {
400     # define Rs_def(name) { # name, Rs_ ## name },
401     # define Rs_reserve(name,count)
402     # include "rsinc.h"
403     # undef Rs_def
404     # undef Rs_reserve
405     };
406    
407     struct resval *rs = rslist + sizeof (rslist) / sizeof (rslist [0]);
408    
409     do {
410     if (rs-- == rslist)
411     croak ("no such resource '%s', requested", name);
412     } while (strcmp (name, rs->name));
413    
414     index += rs->value;
415    
416     if (!IN_RANGE_EXC (index, 0, NUM_RESOURCES))
417     croak ("requested out-of-bound resource %s+%d,", name, index - rs->value);
418    
419     if (GIMME_V != G_VOID)
420     XPUSHs (THIS->rs [index] ? sv_2mortal (newSVpv (THIS->rs [index], 0)) : &PL_sv_undef);
421    
422     if (newval)
423     {
424     if (SvOK (newval))
425     {
426     char *str = strdup (SvPVbyte_nolen (newval));
427     THIS->rs [index] = str;
428     THIS->allocated.push_back (str);
429     }
430     else
431     THIS->rs [index] = 0;
432     }
433     }
434    
435     void
436 root 1.1 rxvt_term::selection_mark (...)
437     PROTOTYPE: $;$$
438     ALIAS:
439     selection_beg = 1
440     selection_end = 2
441     PPCODE:
442     {
443     row_col_t &sel = ix == 1 ? THIS->selection.beg
444     : ix == 2 ? THIS->selection.end
445     : THIS->selection.mark;
446    
447     if (GIMME_V != G_VOID)
448     {
449     EXTEND (SP, 2);
450     PUSHs (sv_2mortal (newSViv (sel.row)));
451     PUSHs (sv_2mortal (newSViv (sel.col)));
452     }
453    
454     if (items == 3)
455     {
456     sel.row = clamp (SvIV (ST (1)), -THIS->nsaved, THIS->nrow - 1);
457     sel.col = clamp (SvIV (ST (2)), 0, THIS->ncol - 1);
458    
459     if (ix)
460     THIS->want_refresh = 1;
461     }
462     }
463    
464     int
465     rxvt_term::selection_grab (int eventtime)
466    
467     void
468     rxvt_term::selection (SV *newtext = 0)
469     PPCODE:
470     {
471     if (GIMME_V != G_VOID)
472     {
473     char *sel = rxvt_wcstoutf8 (THIS->selection.text, THIS->selection.len);
474     SV *sv = newSVpv (sel, 0);
475     SvUTF8_on (sv);
476     free (sel);
477     XPUSHs (sv_2mortal (sv));
478     }
479    
480     if (newtext)
481     {
482     free (THIS->selection.text);
483    
484     THIS->selection.text = sv2wcs (newtext);
485     THIS->selection.len = wcslen (THIS->selection.text);
486     }
487     }
488    
489     void
490     rxvt_term::scr_overlay_new (int x, int y, int w, int h)
491    
492     void
493     rxvt_term::scr_overlay_off ()
494    
495     void
496     rxvt_term::scr_overlay_set_char (int x, int y, U32 text, U32 rend = OVERLAY_RSTYLE)
497     CODE:
498     THIS->scr_overlay_set (x, y, text, rend);
499    
500     void
501     rxvt_term::scr_overlay_set (int x, int y, SV *text)
502     CODE:
503     {
504     wchar_t *wtext = sv2wcs (text);
505     THIS->scr_overlay_set (x, y, wtext);
506     free (wtext);
507     }
508    
509 root 1.3 void
510     rxvt_term::tt_write (SV *octets)
511     INIT:
512     STRLEN len;
513     char *str = SvPVbyte (octets, len);
514     C_ARGS:
515     (unsigned char *)str, len
516    
517 root 1.1 MODULE = urxvt PACKAGE = urxvt::timer
518    
519     SV *
520     timer::new ()
521     CODE:
522     timer *w = new timer;
523     RETVAL = newSVptr ((void *)w, "urxvt::timer");
524     w->self = (HV *)SvRV (RETVAL);
525     OUTPUT:
526     RETVAL
527    
528     timer *
529     timer::cb (SV *cb)
530     CODE:
531     THIS->cb (cb);
532     RETVAL = THIS;
533     OUTPUT:
534     RETVAL
535    
536     NV
537     timer::at ()
538     CODE:
539     RETVAL = THIS->at;
540     OUTPUT:
541     RETVAL
542    
543     timer *
544     timer::set (NV tstamp)
545     CODE:
546     THIS->set (tstamp);
547     RETVAL = THIS;
548     OUTPUT:
549     RETVAL
550    
551     timer *
552     timer::start (NV tstamp = THIS->at)
553     CODE:
554     THIS->start (tstamp);
555     RETVAL = THIS;
556     OUTPUT:
557     RETVAL
558    
559     timer *
560     timer::stop ()
561     CODE:
562     THIS->stop ();
563     RETVAL = THIS;
564     OUTPUT:
565     RETVAL
566    
567     void
568     timer::DESTROY ()
569    
570     MODULE = urxvt PACKAGE = urxvt::iow
571    
572     SV *
573     iow::new ()
574     CODE:
575     iow *w = new iow;
576     RETVAL = newSVptr ((void *)w, "urxvt::iow");
577     w->self = (HV *)SvRV (RETVAL);
578     OUTPUT:
579     RETVAL
580    
581     iow *
582     iow::cb (SV *cb)
583     CODE:
584     THIS->cb (cb);
585     RETVAL = THIS;
586     OUTPUT:
587     RETVAL
588    
589     iow *
590     iow::fd (int fd)
591     CODE:
592     THIS->fd = fd;
593     RETVAL = THIS;
594     OUTPUT:
595     RETVAL
596    
597     iow *
598     iow::events (short events)
599     CODE:
600     THIS->events = events;
601     RETVAL = THIS;
602     OUTPUT:
603     RETVAL
604    
605     iow *
606     iow::start ()
607     CODE:
608     THIS->start ();
609     RETVAL = THIS;
610     OUTPUT:
611     RETVAL
612    
613     iow *
614     iow::stop ()
615     CODE:
616     THIS->stop ();
617     RETVAL = THIS;
618     OUTPUT:
619     RETVAL
620    
621     void
622     iow::DESTROY ()
623    
624