ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/server/cfperl.xs
(Generate patch)

Comparing deliantra/server/server/cfperl.xs (file contents):
Revision 1.9 by root, Fri Aug 25 15:31:45 2006 UTC vs.
Revision 1.14 by root, Sun Aug 27 13:02:04 2006 UTC

… …
28#include <XSUB.h> 28#include <XSUB.h>
29 29
30#undef save_long // clashes with libproto.h 30#undef save_long // clashes with libproto.h
31 31
32#define PLUGIN_NAME "perl" 32#define PLUGIN_NAME "perl"
33#define PLUGIN_VERSION "cfperl 0.3" 33#define PLUGIN_VERSION "cfperl 0.5"
34 34
35#ifndef __CEXTRACT__ 35#ifndef __CEXTRACT__
36#include <plugin.h> 36#include <plugin.h>
37#endif 37#endif
38 38
… …
46#include <sounds.h> 46#include <sounds.h>
47#include <cstdarg> 47#include <cstdarg>
48#include <sproto.h> 48#include <sproto.h>
49 49
50#include "cfperl.h" 50#include "cfperl.h"
51#include "shstr.h"
51 52
52#include "perlxsi.c" 53#include "perlxsi.c"
53
54static void *globalEventListener (int *type, ...);
55 54
56extern sint64 *levels; // the experience table 55extern sint64 *levels; // the experience table
57 56
58typedef object object_ornull; 57typedef object object_ornull;
59typedef mapstruct mapstruct_ornull; 58typedef mapstruct mapstruct_ornull;
… …
61typedef double val64; 60typedef double val64;
62#define newSVval64 newSVnv 61#define newSVval64 newSVnv
63#define SvVAL64 SvNV 62#define SvVAL64 SvNV
64 63
65static f_plug_api gethook; 64static f_plug_api gethook;
66static f_plug_api registerGlobalEvent;
67static f_plug_api unregisterGlobalEvent;
68static f_plug_api systemDirectory; 65static f_plug_api systemDirectory;
69static f_plug_api object_set_property; 66static f_plug_api object_set_property;
70static f_plug_api map_get_map; 67static f_plug_api map_get_map;
71static f_plug_api object_insert; 68static f_plug_api object_insert;
72 69
… …
99#define PUSH_PV PUSHcfapi_va(STRING, const char *) 96#define PUSH_PV PUSHcfapi_va(STRING, const char *)
100#define PUSH_IV PUSHs (sv_2mortal (newSViv (va_arg (args, int)))) 97#define PUSH_IV PUSHs (sv_2mortal (newSViv (va_arg (args, int))))
101 98
102////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// 99//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
103 100
104// garbage collect some perl objects, if possible
105// all objects no longer referenced and empty are
106// eligible for destruction.
107static void
108clean_obj_cache ()
109{
110 static int count;
111
112 if (++count & 7)
113 return;
114
115 int todo = 1000;
116 do
117 {
118 I32 klen;
119 char *key;
120 HE *he = hv_iternext (obj_cache);
121
122 if (he)
123 {
124 SV *sv = hv_iterval (obj_cache, he);
125
126 // empty and unreferenced? nuke it
127 if (SvREFCNT (sv) == 1 && SvREFCNT (SvRV (sv)) == 1 && !HvFILL ((HV *)(SvRV (sv))))
128 {
129 hv_delete (obj_cache, HeKEY (he), HeKLEN (he), G_DISCARD);
130 todo++;
131 }
132 }
133 else
134 break;
135 }
136 while (--todo);
137}
138
139static SV * 101static SV *
140newSVptr (void *ptr, const char *klass) 102newSVptr (void *ptr, const char *klass, HV *hv = newHV ())
141{ 103{
142 SV *sv; 104 SV *sv;
143 105
144 if (!ptr) 106 if (!ptr)
145 return &PL_sv_undef; 107 return &PL_sv_undef;
146 108
147 sv = newSV (0);
148 sv_magic (sv, 0, PERL_MAGIC_ext, (char *)ptr, 0); 109 sv_magic ((SV *)hv, 0, PERL_MAGIC_ext, (char *)ptr, 0);
149 return sv_bless (newRV_noinc (sv), gv_stashpv (klass, 1)); 110 return sv_bless (newRV_noinc ((SV *)hv), gv_stashpv (klass, 1));
111}
112
113template<class extendable>
114SV *
115newSVextendable (extendable *obj, const char *klass)
116{
117 if (!obj)
118 return &PL_sv_undef;
119
120 if (!obj->self)
121 obj->self = newSVptr (obj, klass);
122
123 return newSVsv (static_cast<SV *>(obj->self));
150} 124}
151 125
152static void 126static void
153SVptr_cache_set (void *ptr, SV *sv) 127SVptr_cache_set (void *ptr, SV *sv)
154{ 128{
… …
224 SV *sv; 198 SV *sv;
225 199
226 switch (type) 200 switch (type)
227 { 201 {
228 case DT_INT: 202 case DT_INT:
229 sv = newSViv (*va_arg (ap, int *)); 203 sv = newSViv (va_arg (ap, int));
230 break; 204 break;
231 205
232 case DT_LONG: 206 case DT_INT64:
233 sv = newSVval64 ((val64)*va_arg (ap, sint64 *)); 207 sv = newSVval64 ((val64)va_arg (ap, sint64));
234 break; 208 break;
235 209
236 case DT_DOUBLE: 210 case DT_DOUBLE:
237 sv = newSVnv (*va_arg (ap, double *)); 211 sv = newSVnv (va_arg (ap, double));
238 break; 212 break;
239 213
240 case DT_STRING: 214 case DT_STRING:
241 { 215 {
242 char *str = va_arg (ap, char *); 216 char *str = (char *)va_arg (ap, const char *);
243 sv = str ? newSVpv (str, 0) : &PL_sv_undef; 217 sv = str ? newSVpv (str, 0) : &PL_sv_undef;
244 } 218 }
245 break; 219 break;
246 220
247 case DT_DATA: 221 case DT_DATA:
248 { 222 {
249 char *str = (char *)va_arg (ap, void *); 223 char *str = (char *)va_arg (ap, const void *);
250 int len = va_arg (ap, int); 224 int len = va_arg (ap, int);
251 sv = str ? newSVpv (str, len) : &PL_sv_undef; 225 sv = str ? newSVpv (str, len) : &PL_sv_undef;
252 } 226 }
253 break; 227 break;
254 228
255 case DT_OBJECT: 229 case DT_OBJECT:
256 { 230 {
257 object *obj = va_arg (ap, object *); 231 object *obj = va_arg (ap, object *);
258 232 sv = newSVextendable (obj, obj && obj->type == PLAYER ? "cf::object::player::wrap" : "cf::object::wrap");
259 if (!obj)
260 sv = &PL_sv_undef;
261 else
262 switch (obj->type)
263 {
264 case MAP:
265 sv = newSVptr_cached (obj, "cf::object::map::wrap");
266 break;
267
268 case PLAYER:
269 sv = newSVptr_cached (obj, "cf::object::player::wrap");
270 break;
271
272 default:
273 sv = newSVptr_cached (obj, "cf::object::wrap");
274 break;
275 }
276 } 233 }
277 break; 234 break;
278 235
279 case DT_MAP: 236 case DT_MAP:
237 // va_arg (object *) when void * is passed is an XSI extension
280 sv = newSVptr (va_arg (ap, mapstruct *), "cf::map::wrap"); 238 sv = newSVextendable (va_arg (ap, mapstruct *), "cf::map::wrap");
281 break; 239 break;
282 240
283 case DT_PLAYER: 241 case DT_PLAYER:
284 sv = newSVptr (va_arg (ap, player *), "cf::player::wrap"); 242 sv = newSVextendable (va_arg (ap, player *), "cf::player::wrap");
285 break; 243 break;
286 244
287 case DT_ARCH: 245 case DT_ARCH:
288 sv = newSVptr (va_arg (ap, archetype *), "cf::arch::wrap"); 246 sv = newSVptr (va_arg (ap, archetype *), "cf::arch::wrap");
289 break; 247 break;
… …
323 va_list ap; 281 va_list ap;
324 va_start (ap, type); 282 va_start (ap, type);
325 283
326 switch (type) 284 switch (type)
327 { 285 {
328 case CFAPI_INT: sv = newSVdt_va (ap, DT_INT ); break; 286 case CFAPI_INT: sv = newSViv (*va_arg (ap, int * )); break;
329 case CFAPI_LONG: sv = newSVdt_va (ap, DT_LONG ); break; 287 case CFAPI_LONG: sv = newSVval64 (*va_arg (ap, sint64 *)); break;
330 case CFAPI_DOUBLE: sv = newSVdt_va (ap, DT_DOUBLE); break; 288 case CFAPI_DOUBLE: sv = newSVnv (*va_arg (ap, double *)); break;
331 case CFAPI_STRING: sv = newSVdt_va (ap, DT_STRING); break; 289 case CFAPI_STRING: sv = newSVdt_va (ap, DT_STRING); break;
332 case CFAPI_POBJECT: sv = newSVdt_va (ap, DT_OBJECT); break; 290 case CFAPI_POBJECT: sv = newSVdt_va (ap, DT_OBJECT); break;
333 case CFAPI_PMAP: sv = newSVdt_va (ap, DT_MAP ); break; 291 case CFAPI_PMAP: sv = newSVdt_va (ap, DT_MAP ); break;
334 case CFAPI_PPLAYER: sv = newSVdt_va (ap, DT_PLAYER); break; 292 case CFAPI_PPLAYER: sv = newSVdt_va (ap, DT_PLAYER); break;
335 case CFAPI_PARCH: sv = newSVdt_va (ap, DT_ARCH ); break; 293 case CFAPI_PARCH: sv = newSVdt_va (ap, DT_ARCH ); break;
… …
341 } 299 }
342 300
343 va_end (ap); 301 va_end (ap);
344 302
345 return sv; 303 return sv;
304}
305
306//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
307
308SV *
309registry_of (extendable_base *ext)
310{
311 if (!ext->cb)
312 ext->cb = newAV ();
313
314 return newRV_inc ((SV *)ext->cb);
315}
316
317void extendable_base::clear ()
318{
319 //if (self) fprintf (stderr, "free_ob_self %p %s (%p,%p)\n", this, ((object *)this)->name, self, cb);//D
320
321 if (self) SvREFCNT_dec (self);
322 if (cb) SvREFCNT_dec (cb);
323
324 if (attach) free_string (attach);
325
326 self = 0;
327 cb = 0;
328 attach = 0;
329}
330
331void extendable_base::optimise ()
332{
333 if (!self)
334 return;
335
336 HV *hv = (HV *)SvRV ((SV *)self);
337
338 if (SvREFCNT ((SV *)self) == 1
339 && SvREFCNT ((SV *)hv) == 1
340 && !HvKEYS (hv))
341 {
342 SvREFCNT_dec ((SV *)self);
343 self = 0;
344 }
345}
346
347void
348object::instantiate_ ()
349{
350 dSP;
351 ENTER;
352 SAVETMPS;
353 PUSHMARK (SP);
354 EXTEND (SP, 2);
355 PUSHs (sv_2mortal (newSVdt (DT_OBJECT, static_cast<object *>(this))));
356 PUSHs (sv_2mortal (newSVpv (attach, 0)));
357 PUTBACK;
358 call_pv ("cf::instantiate", G_DISCARD | G_VOID | G_EVAL);
359 FREETMPS;
360 LEAVE;
361}
362
363/////////////////////////////////////////////////////////////////////////////
364
365object_freezer::object_freezer (const char *filename)
366: filename (filename)
367{
368 av = (AV *)newAV ();
369 idx = 0;
370 av_extend ((AV *)av, 1024);
371}
372
373object_freezer::~object_freezer ()
374{
375 dSP;
376 ENTER;
377 SAVETMPS;
378 PUSHMARK (SP);
379 XPUSHs (sv_2mortal (newSVpv (filename, 0)));
380 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
381 PUTBACK;
382 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL);
383 FREETMPS;
384 LEAVE;
385}
386
387void object_freezer::put (extendable_base *ext)
388{
389 ext->optimise ();
390
391 if (ext->self)
392 av_store ((AV *)av, idx, SvREFCNT_inc ((SV *)ext->self));
393
394 ++idx;
395}
396
397object_thawer::object_thawer (const char *filename)
398{
399 av = 0;
400 idx = 0;
401
402 if (!filename)
403 return;
404
405 dSP;
406 ENTER;
407 SAVETMPS;
408 PUSHMARK (SP);
409 XPUSHs (sv_2mortal (newSVpv (filename, 0)));
410 PUTBACK;
411
412 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL))
413 {
414 SPAGAIN;
415 SV *sv = POPs;
416 if (SvROK (sv))
417 av = SvREFCNT_inc (SvRV (sv));
418 }
419
420 FREETMPS;
421 LEAVE;
422}
423
424void reattach (data_type type, void *obj)
425{
426 dSP;
427 ENTER;
428 SAVETMPS;
429 PUSHMARK (SP);
430 XPUSHs (sv_2mortal (newSVdt (type, obj)));
431 PUTBACK;
432 call_pv ("cf::reattach", G_DISCARD | G_VOID | G_EVAL);
433 FREETMPS;
434 LEAVE;
435
436 switch (type)
437 {
438 case DT_OBJECT: INVOKE_OBJECT (REATTACH, obj); break;
439 case DT_PLAYER: INVOKE_PLAYER (REATTACH, obj); break;
440 case DT_MAP: INVOKE_MAP (REATTACH, obj); break;
441 }
442}
443
444template<class subclass>
445void reattach (extendable<subclass> *obj)
446{
447 if (obj->self)
448 reattach (subclass::get_dt (), (subclass *)obj);
449}
450
451void object_thawer::get (data_type type, void *obj, extendable_base *ext)
452{
453 if (!av)
454 return;
455
456 // we have to "re-instantiate"/reattach to an object, so nuke ext->attach
457 ext->clear ();
458
459 SV **svp = av_fetch ((AV *)av, idx, 0);
460
461 ++idx;
462
463 if (!svp)
464 return;
465
466 if (SvROK (*svp))
467 {
468 ext->self = SvREFCNT_inc (*svp);
469 sv_magic (SvRV ((SV *)ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0);
470
471 reattach (type, obj);
472 }
473}
474
475object_thawer::~object_thawer ()
476{
477 if (av)
478 SvREFCNT_dec ((SV *)av);
346} 479}
347 480
348///////////////////////////////////////////////////////////////////////////// 481/////////////////////////////////////////////////////////////////////////////
349 482
350extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr) 483extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr)
… …
441 int hooktype = 1; 574 int hooktype = 1;
442 int rtype = 0; 575 int rtype = 0;
443 576
444 printf (PLUGIN_VERSION " post init\n"); 577 printf (PLUGIN_VERSION " post init\n");
445 578
446 registerGlobalEvent = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_system_register_global_event");
447 unregisterGlobalEvent = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_system_unregister_global_event");
448 systemDirectory = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_system_directory"); 579 systemDirectory = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_system_directory");
449 object_set_property = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_object_set_property"); 580 object_set_property = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_object_set_property");
450 map_get_map = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_map_get_map"); 581 map_get_map = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_map_get_map");
451 object_insert = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_object_insert"); 582 object_insert = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_object_insert");
452 583
453 cf_init_plugin (gethook); 584 cf_init_plugin (gethook);
454 585
455 /* Pick the global events you want to monitor from this plugin */
456 registerGlobalEvent (NULL, EVENT_CLOCK, PLUGIN_NAME, globalEventListener);
457 //registerGlobalEvent (NULL, EVENT_CRASH, PLUGIN_NAME, globalEventListener);
458 registerGlobalEvent (NULL, EVENT_FIND_UNARMED_SKILL, PLUGIN_NAME, globalEventListener);
459 registerGlobalEvent (NULL, EVENT_PLAYER_USE_SKILL, PLUGIN_NAME, globalEventListener);
460 registerGlobalEvent (NULL, EVENT_CAST_SPELL, PLUGIN_NAME, globalEventListener);
461 registerGlobalEvent (NULL, EVENT_MONSTER_USE_SKILL, PLUGIN_NAME, globalEventListener);
462 registerGlobalEvent (NULL, EVENT_GKILL, PLUGIN_NAME, globalEventListener);
463 registerGlobalEvent (NULL, EVENT_SHOUT, PLUGIN_NAME, globalEventListener);
464 registerGlobalEvent (NULL, EVENT_TELL, PLUGIN_NAME, globalEventListener);
465 registerGlobalEvent (NULL, EVENT_MUZZLE, PLUGIN_NAME, globalEventListener);
466 registerGlobalEvent (NULL, EVENT_KICK, PLUGIN_NAME, globalEventListener);
467 registerGlobalEvent (NULL, EVENT_EXTCMD, PLUGIN_NAME, globalEventListener);
468
469 return 0; 586 return 0;
470}
471
472static void *
473globalEventListener (int *type, ...)
474{
475 va_list args;
476 static int rv;
477 int event_code;
478
479 if (!perl)
480 return NULL;
481
482 va_start (args, type);
483 event_code = va_arg (args, int);
484
485 if (event_code == EVENT_CLOCK)
486 {
487 clean_obj_cache ();
488 }
489 else
490 {
491 dSP;
492
493 ENTER;
494 SAVETMPS;
495
496 PUSHMARK (SP);
497
498 EXTEND (SP, 10);
499 PUSHs (sv_2mortal (newSViv (event_code)));
500
501 switch (event_code)
502 {
503 case EVENT_CRASH:
504 break;
505
506 case EVENT_GKILL:
507 PUSH_OB;
508 PUSH_OB;
509 break;
510
511 case EVENT_SHOUT:
512 case EVENT_MUZZLE:
513 case EVENT_KICK:
514 PUSH_OB;
515 PUSH_PV;
516 break;
517
518 case EVENT_FIND_UNARMED_SKILL:
519 PUSH_OB;
520 break;
521
522 case EVENT_PLAYER_USE_SKILL:
523 case EVENT_MONSTER_USE_SKILL:
524 case EVENT_CAST_SPELL:
525 PUSH_OB;
526 PUSH_OB;
527 PUSH_OB;
528 PUSH_IV;
529 PUSH_PV;
530 break;
531
532 case EVENT_EXTCMD:
533 PUSH_PL;
534 {
535 char *buf = va_arg (args, char *);
536 int len = va_arg (args, int);
537 PUSHs (sv_2mortal (newSVpvn (buf, len)));
538 }
539 break;
540
541 case EVENT_TELL:
542 break;
543 }
544
545 va_end (args);
546
547 PUTBACK;
548 int count = call_pv ("cf::inject_global_event", G_SCALAR | G_EVAL);
549 SPAGAIN;
550
551 if (SvTRUE (ERRSV))
552 LOG (llevError, "global event '%d' callback evaluation error: %s", event_code, SvPV_nolen (ERRSV));
553
554 rv = count > 0 ? POPi : 0;
555
556 PUTBACK;
557 FREETMPS;
558 LEAVE;
559 }
560
561 return &rv;
562}
563
564extern "C" void *cfperl_eventListener (int *type, ...)
565{
566 static int rv;
567 va_list args;
568 int event_code;
569 object *who, *activator, *third, *event;
570 char *message, *extension, *options;
571
572 if (!perl)
573 return NULL;
574
575 va_start (args, type);
576 who = va_arg (args, object *);
577 event_code = va_arg (args, int);
578 activator = va_arg (args, object *);
579 third = va_arg (args, object *);
580 message = va_arg (args, char *);
581 va_arg (args, int); // fix yourself
582 extension = va_arg (args, char *);
583 options = va_arg (args, char *);
584 event = va_arg (args, object *);
585 va_end (args);
586
587 {
588 dSP;
589
590 ENTER;
591 SAVETMPS;
592
593 PUSHMARK (SP);
594 EXTEND (SP, 10);
595
596 PUSHcfapi (STRING, extension);
597 PUSHs (sv_2mortal (newSViv (event_code)));
598
599 PUSHcfapi (POBJECT, event);
600 PUSHcfapi (POBJECT, who);
601
602 switch (event_code)
603 {
604 case EVENT_STOP: // $ob (e.g. arrow)
605 case EVENT_TIME: // $ob
606 case EVENT_TIMER: // $ob
607 break;
608
609 case EVENT_APPLY: // $ob, $who
610 case EVENT_DROP: // $ob, $who
611 case EVENT_CLOSE: // $ob, $who
612 case EVENT_DEATH: // $ob[, $killer]
613 case EVENT_MOVE: // $ob, $enemy
614 case EVENT_THROW: // $ob, $thrower
615 PUSHcfapi (POBJECT, activator);
616 break;
617
618 case EVENT_DROP_ON: // $ob, $who, $what
619 case EVENT_ATTACK: // $ob, $who, $victim (?? please god enlighten me)
620 PUSHcfapi (POBJECT, activator);
621 PUSHcfapi (POBJECT, third);
622 break;
623
624 case EVENT_TRIGGER: // $ob, $originator, [$victim], [$msg]
625 PUSHcfapi (POBJECT, activator);
626 PUSHcfapi (POBJECT, third);
627 PUSHcfapi (POBJECT, message);
628 break;
629
630 case EVENT_SAY: // $ob, $who, $msg
631 PUSHcfapi (POBJECT, activator);
632 PUSHcfapi (STRING, message);
633 break;
634
635 default:
636 LOG (llevError, "perl plugin called for unsupported event type %d", event_code);
637 break;
638 }
639
640 PUTBACK;
641 int count = call_pv ("cf::inject_event", G_SCALAR | G_EVAL);
642 SPAGAIN;
643
644 if (SvTRUE (ERRSV))
645 LOG (llevError, "event '%d' callback evaluation error: %s", event_code, SvPV_nolen (ERRSV));
646
647 rv = count > 0 ? POPi : 0;
648
649 PUTBACK;
650 FREETMPS;
651 LEAVE;
652 }
653
654 return &rv;
655} 587}
656 588
657extern "C" int cfperl_closePlugin () 589extern "C" int cfperl_closePlugin ()
658{ 590{
659 return 0; 591 return 0;
… …
697 dSP; 629 dSP;
698 630
699 PUSHMARK (SP); 631 PUSHMARK (SP);
700 PUTBACK; 632 PUTBACK;
701 call_pv ("cf::main", G_DISCARD | G_VOID); 633 call_pv ("cf::main", G_DISCARD | G_VOID);
702}
703
704void cfperl_free_ob (object *op)
705{
706 SV *sv = hv_delete (obj_cache, (char *)&op, sizeof (void *), 0);
707
708 if (sv)
709 clearSVptr (sv);
710} 634}
711 635
712static event_klass klass_of[NUM_EVENT_TYPES] = { 636static event_klass klass_of[NUM_EVENT_TYPES] = {
713# define def(type,name) KLASS_ ## type, 637# define def(type,name) KLASS_ ## type,
714# include "eventinc.h" 638# include "eventinc.h"
… …
772 break; 696 break;
773 697
774 case KLASS_OBJECT: 698 case KLASS_OBJECT:
775 dt = (data_type) va_arg (ap, int); 699 dt = (data_type) va_arg (ap, int);
776 assert (("first argument must be of type object", dt == DT_OBJECT)); 700 assert (("first argument must be of type object", dt == DT_OBJECT));
777
778 op = va_arg (ap, object *); 701 op = va_arg (ap, object *);
779 702
703 if (op->cb)
704 gather_callbacks (callbacks, (AV *)op->cb, event);
705
706 if (op->type)
707 {
708 if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type))
709 {
710 SV *registry = AvARRAY (cb_type)[op->type + op->subtype * NUM_SUBTYPES];
711
712 if (registry && SvROK (registry) && SvTYPE (SvRV (registry)) == SVt_PVAV)
713 gather_callbacks (callbacks, (AV *)SvRV (registry), event);
714 }
715
716 if (op->type <= AvFILLp (cb_type))
717 {
718 SV *registry = AvARRAY (cb_type)[op->type];
719
720 if (registry && SvROK (registry) && SvTYPE (SvRV (registry)) == SVt_PVAV)
721 gather_callbacks (callbacks, (AV *)SvRV (registry), event);
722 }
723 }
724
780 gather_callbacks (callbacks, cb_object, event); 725 gather_callbacks (callbacks, cb_object, event);
781 //TODO: per-object
782
783 if (op->type > 0 && op->type <= AvFILLp (cb_type))
784 {
785 SV *registry = AvARRAY (cb_type)[op->type];
786
787 if (registry && SvROK (registry) && SvTYPE (SvRV (registry)) == SVt_PVAV)
788 gather_callbacks (callbacks, (AV *)SvRV (registry), event);
789 }
790 726
791 break; 727 break;
792 728
793 case KLASS_PLAYER: 729 case KLASS_PLAYER:
794 dt = (data_type) va_arg (ap, int); 730 dt = (data_type) va_arg (ap, int);
795 assert (("first argument must be of type player", dt == DT_PLAYER)); 731 assert (("first argument must be of type player", dt == DT_PLAYER));
796
797 pl = va_arg (ap, player *); 732 pl = va_arg (ap, player *);
733
734 if (pl->cb)
735 gather_callbacks (callbacks, (AV *)pl->cb, event);
736
798 gather_callbacks (callbacks, cb_player, event); 737 gather_callbacks (callbacks, cb_player, event);
799 break; 738 break;
800 739
801 case KLASS_MAP: 740 case KLASS_MAP:
802 dt = (data_type) va_arg (ap, int); 741 dt = (data_type) va_arg (ap, int);
803 assert (("first argument must be of type object", dt == DT_MAP)); 742 assert (("first argument must be of type object", dt == DT_MAP));
804
805 map = va_arg (ap, mapstruct *); 743 map = va_arg (ap, mapstruct *);
744
745 if (map->cb)
746 gather_callbacks (callbacks, (AV *)map->cb, event);
747
806 gather_callbacks (callbacks, cb_map, event); 748 gather_callbacks (callbacks, cb_map, event);
807 break; 749 break;
808 750
809 default: 751 default:
810 assert (("unsupported event klass in cfperl_invoke", 0)); 752 assert (("unsupported event klass in cfperl_invoke", 0));
… …
836 dt = (data_type) va_arg (ap, int); 778 dt = (data_type) va_arg (ap, int);
837 779
838 if (dt == DT_END) 780 if (dt == DT_END)
839 break; 781 break;
840 782
783 if (dt == DT_AV)
784 {
785 AV *av = va_arg (ap, AV *);
786
787 for (int i = 0; i <= av_len (av); ++i)
788 XPUSHs (*av_fetch (av, i, 1));
789 }
790 else
841 XPUSHs (sv_2mortal (newSVdt_va (ap, dt))); 791 XPUSHs (sv_2mortal (newSVdt_va (ap, dt)));
842 } 792 }
843 793
844 va_end (ap); 794 va_end (ap);
845 795
846 PUTBACK; 796 PUTBACK;
847 int count = call_pv ("cf::invoke", G_SCALAR | G_EVAL); 797 int count = call_pv ("cf::do_invoke", G_SCALAR | G_EVAL);
848 SPAGAIN; 798 SPAGAIN;
849 799
850 count = count > 0 ? POPi : 0; 800 count = count > 0 ? POPi : 0;
851 801
852 FREETMPS; 802 FREETMPS;
853 LEAVE; 803 LEAVE;
854 804
855 return count; 805 return count;
806}
807
808SV *
809cfperl_result (int idx)
810{
811 AV *av = get_av ("cfperl::invoke_results", 0);
812 if (!av)
813 return &PL_sv_undef;
814
815 SV **sv = av_fetch (av, idx, 0);
816 if (!sv)
817 return &PL_sv_undef;
818
819 return *sv;
820}
821
822int
823cfperl_result_INT (int idx)
824{
825 return SvIV (cfperl_result (idx));
856} 826}
857 827
858MODULE = cf PACKAGE = cf PREFIX = cf_ 828MODULE = cf PACKAGE = cf PREFIX = cf_
859 829
860BOOT: 830BOOT:
… …
994 const_iv (BUILDER) 964 const_iv (BUILDER)
995 const_iv (MATERIAL) 965 const_iv (MATERIAL)
996 const_iv (ITEM_TRANSFORMER) 966 const_iv (ITEM_TRANSFORMER)
997 const_iv (QUEST) 967 const_iv (QUEST)
998 968
969 const_iv (NUM_SUBTYPES)
970
999 const_iv (ST_BD_BUILD) 971 const_iv (ST_BD_BUILD)
1000 const_iv (ST_BD_REMOVE) 972 const_iv (ST_BD_REMOVE)
1001 973
1002 const_iv (ST_MAT_FLOOR) 974 const_iv (ST_MAT_FLOOR)
1003 const_iv (ST_MAT_WALL) 975 const_iv (ST_MAT_WALL)
… …
1351 for (civ = const_iv + sizeof (const_iv) / sizeof (const_iv [0]); civ-- > const_iv; ) 1323 for (civ = const_iv + sizeof (const_iv) / sizeof (const_iv [0]); civ-- > const_iv; )
1352 newCONSTSUB (stash, (char *)civ->name, newSViv (civ->iv)); 1324 newCONSTSUB (stash, (char *)civ->name, newSViv (civ->iv));
1353 1325
1354 static const struct { 1326 static const struct {
1355 const char *name; 1327 const char *name;
1328 int skip;
1356 IV klass; 1329 IV klass;
1357 IV iv; 1330 IV iv;
1358 } *eiv, event_iv[] = { 1331 } *eiv, event_iv[] = {
1359# define def(klass,name) { # name, (IV)KLASS_ ## klass, (IV)EV_ ## klass ## name }, 1332# define def(klass,name) { "EVENT_" # klass "_" # name, sizeof ("EVENT_" # klass), (IV)KLASS_ ## klass, (IV)EVENT_ ## klass ## _ ## name },
1360# include "eventinc.h" 1333# include "eventinc.h"
1361# undef def 1334# undef def
1362 }; 1335 };
1363 1336
1364 AV *av = get_av ("cf::EVENT", 1); 1337 AV *av = get_av ("cf::EVENT", 1);
1365 1338
1366 for (eiv = event_iv + sizeof (event_iv) / sizeof (event_iv [0]); eiv-- > event_iv; ) 1339 for (eiv = event_iv + sizeof (event_iv) / sizeof (event_iv [0]); eiv-- > event_iv; )
1367 { 1340 {
1368 AV *event = newAV (); 1341 AV *event = newAV ();
1369 av_push (event, newSVpv ((char *)eiv->name, 0)); 1342 av_push (event, newSVpv ((char *)eiv->name + eiv->skip, 0));
1370 av_push (event, newSViv (eiv->klass)); 1343 av_push (event, newSViv (eiv->klass));
1371 av_store (av, eiv->iv, newRV_noinc ((SV *)event)); 1344 av_store (av, eiv->iv, newRV_noinc ((SV *)event));
1345 newCONSTSUB (stash, (char *)eiv->name, newSViv (eiv->iv));
1372 } 1346 }
1373
1374 static const struct {
1375 const char *name;
1376 IV iv;
1377 } *event, event_list[] = {
1378# define const_event(name) { # name, (IV)EVENT_ ## name },
1379 const_event (NONE)
1380 const_event (APPLY)
1381 const_event (ATTACK)
1382 const_event (DEATH)
1383 const_event (DROP)
1384 const_event (DROP_ON)
1385 const_event (PICKUP)
1386 const_event (SAY)
1387 const_event (STOP)
1388 const_event (TIME)
1389 const_event (THROW)
1390 const_event (TRIGGER)
1391 const_event (CLOSE)
1392 const_event (TIMER)
1393 const_event (MOVE)
1394
1395 //const_event (CLOCK)
1396 const_event (CRASH)
1397 const_event (GKILL)
1398 const_event (SHOUT)
1399 const_event (TELL)
1400 const_event (MUZZLE)
1401 const_event (KICK)
1402 const_event (PLAYER_USE_SKILL)
1403 const_event (MONSTER_USE_SKILL)
1404 const_event (CAST_SPELL)
1405 const_event (FIND_UNARMED_SKILL)
1406 const_event (EXTCMD)
1407 //const_event (FREE_OB)
1408 };
1409
1410 av = get_av ("cf::PLUGIN_EVENT", 1);
1411
1412 for (event = event_list + sizeof (event_list) / sizeof (event_list [0]); event-- > event_list; )
1413 av_store (av, event->iv, newSVpv ((char *)event->name, 0));
1414 1347
1415 static const struct { 1348 static const struct {
1416 int dtype; 1349 int dtype;
1417 const char *name; 1350 const char *name;
1418 IV idx; 1351 IV idx;
… …
1546 { 1479 {
1547 hv_store (prop_type, cprop->name, strlen (cprop->name), newSViv (cprop->dtype), 0); 1480 hv_store (prop_type, cprop->name, strlen (cprop->name), newSViv (cprop->dtype), 0);
1548 hv_store (prop_idx, cprop->name, strlen (cprop->name), newSViv (cprop->idx ), 0); 1481 hv_store (prop_idx, cprop->name, strlen (cprop->name), newSViv (cprop->idx ), 0);
1549 } 1482 }
1550 1483
1551 cb_global = get_av ("cf::CB_GLOBAL", 1);
1552 cb_object = get_av ("cf::CB_OBJECT", 1);
1553 cb_player = get_av ("cf::CB_PLAYER", 1);
1554 cb_type = get_av ("cf::CB_TYPE" , 1);
1555 cb_map = get_av ("cf::CB_MAP" , 1);
1556
1557 //I_EVENT_API (PACKAGE); 1484 //I_EVENT_API (PACKAGE);
1485}
1486
1487void _reload_1 ()
1488 CODE:
1489 cb_global = get_av ("cf::CB_GLOBAL", 1);
1490 cb_object = get_av ("cf::CB_OBJECT", 1);
1491 cb_player = get_av ("cf::CB_PLAYER", 1);
1492 cb_type = get_av ("cf::CB_TYPE" , 1);
1493 cb_map = get_av ("cf::CB_MAP" , 1);
1494
1495void _reload_2 ()
1496 CODE:
1497{
1498 // reattach to all attachable objects in the game.
1499 for (player *pl = first_player; pl; pl = pl->next)
1500 reattach (pl);
1501
1502 for (mapstruct *map = first_map; map; map = map->next)
1503 reattach (map);
1504
1505 for (object *op = objects; op; op = op->next)
1506 reattach (op);
1558} 1507}
1559 1508
1560NV floor (NV x) 1509NV floor (NV x)
1561 1510
1562NV ceil (NV x) 1511NV ceil (NV x)
… …
1607 PROTOTYPE: $ 1556 PROTOTYPE: $
1608 1557
1609int random_roll(int min, int max, object *op, int goodbad); 1558int random_roll(int min, int max, object *op, int goodbad);
1610 1559
1611const char *cost_string_from_value(uint64 cost, int approx = 0) 1560const char *cost_string_from_value(uint64 cost, int approx = 0)
1561
1562int invoke (int event, SV *arg1, ...)
1563 CODE:
1564{
1565 // parse first arg and call invoke_object etc as seen fit
1566 //TODO
1567 //cfperl_invoke (event,
1568}
1612 1569
1613int 1570int
1614exp_to_level (val64 exp) 1571exp_to_level (val64 exp)
1615 CODE: 1572 CODE:
1616{ 1573{
… …
1855{ 1812{
1856 int unused_type; 1813 int unused_type;
1857 RETVAL = (object *)object_insert (&unused_type, ob, 0, where, orig, flag, x, y); 1814 RETVAL = (object *)object_insert (&unused_type, ob, 0, where, orig, flag, x, y);
1858} 1815}
1859 1816
1817SV *registry (object *op)
1818 CODE:
1819 RETVAL = registry_of (op);
1820 OUTPUT:
1821 RETVAL
1822
1860# syntatic sugar for easier use in event callbacks. 1823# syntatic sugar for easier use in event callbacks.
1861const char *options (object *op) 1824const char *options (object *op)
1862 CODE: 1825 CODE:
1863 RETVAL = op->name; 1826 RETVAL = op->name;
1864 OUTPUT: 1827 OUTPUT:
… …
1934 1897
1935void cf_player_set_party (object *op, partylist *party) 1898void cf_player_set_party (object *op, partylist *party)
1936 1899
1937void kill_player (object *op) 1900void kill_player (object *op)
1938 1901
1939MODULE = cf PACKAGE = cf::object::map PREFIX = cf_
1940
1941MODULE = cf PACKAGE = cf::player PREFIX = cf_player_ 1902MODULE = cf PACKAGE = cf::player PREFIX = cf_player_
1903
1904SV *registry (player *pl)
1905 CODE:
1906 RETVAL = registry_of (pl);
1907 OUTPUT:
1908 RETVAL
1942 1909
1943player *cf_player_find (char *name) 1910player *cf_player_find (char *name)
1944 PROTOTYPE: $ 1911 PROTOTYPE: $
1945 1912
1946void cf_player_move (player *pl, int dir) 1913void cf_player_move (player *pl, int dir)
… …
2064 RETVAL = &pl->last_stats; 2031 RETVAL = &pl->last_stats;
2065 OUTPUT: RETVAL 2032 OUTPUT: RETVAL
2066 2033
2067 2034
2068MODULE = cf PACKAGE = cf::map PREFIX = cf_map_ 2035MODULE = cf PACKAGE = cf::map PREFIX = cf_map_
2036
2037SV *registry (mapstruct *map)
2038 CODE:
2039 RETVAL = registry_of (map);
2040 OUTPUT:
2041 RETVAL
2069 2042
2070SV * 2043SV *
2071get_property (mapstruct *obj, int type, int idx) 2044get_property (mapstruct *obj, int type, int idx)
2072 CODE: 2045 CODE:
2073 RETVAL = newSVcfapi (type, cf_map_get_property (obj, idx)); 2046 RETVAL = newSVcfapi (type, cf_map_get_property (obj, idx));
… …
2217 case 7: RETVAL = newSVuv ( GET_MAP_MOVE_OFF (obj, x, y)); break; 2190 case 7: RETVAL = newSVuv ( GET_MAP_MOVE_OFF (obj, x, y)); break;
2218 } 2191 }
2219 OUTPUT: 2192 OUTPUT:
2220 RETVAL 2193 RETVAL
2221 2194
2222# "serialise" map perl data into a ref 2195# "deserialise" perl map data into the map # TODO# compatibility cruft, remove
2223void
2224_get_obs (mapstruct *map)
2225 PPCODE:
2226{
2227 object *o;
2228 int x, y;
2229 AV *obs = newAV ();
2230 int nonnull = 0;
2231
2232 for (y = 0; y < MAP_HEIGHT (map); y++)
2233 for (x = 0; x < MAP_WIDTH (map); x++)
2234 {
2235 AV *av = newAV ();
2236
2237 for (o = GET_MAP_OB (map, x, y); o; o = o->above)
2238 {
2239 SV *sv = SVptr_cache_get (o);
2240
2241 if (sv && HvFILL (SvRV (sv)))
2242 {
2243 nonnull = 1;
2244 sv = newSVsv (sv);
2245 }
2246 else
2247 sv = &PL_sv_undef;
2248
2249 av_push (av, sv);
2250 }
2251
2252 av_store (obs, x + y * MAP_HEIGHT (map), newRV_noinc ((SV *)av));
2253 }
2254
2255 if (nonnull)
2256 XPUSHs (sv_2mortal (newRV_noinc ((SV *)obs)));
2257 else
2258 SvREFCNT_dec (obs);
2259}
2260
2261# "deserialise" perl map data into the map
2262void 2196void
2263_set_obs (mapstruct *map, SV *sv) 2197_set_obs (mapstruct *map, SV *sv)
2264 CODE: 2198 CODE:
2265{ 2199{
2266 object *o; 2200 object *o;

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines