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.4 by root, Mon Aug 21 07:13:32 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
42#define MODULEAPI 42#define MODULEAPI
43#endif 43#endif
44 44
45#include <plugin_common.h> 45#include <plugin_common.h>
46#include <sounds.h> 46#include <sounds.h>
47
48#include <stdarg.h> 47#include <cstdarg>
49
50#include <sproto.h> 48#include <sproto.h>
51 49
52//#include "EventAPI.h" 50#include "cfperl.h"
51#include "shstr.h"
52
53#include "perlxsi.c" 53#include "perlxsi.c"
54
55static void *globalEventListener (int *type, ...);
56 54
57extern sint64 *levels; // the experience table 55extern sint64 *levels; // the experience table
58 56
59typedef object object_ornull; 57typedef object object_ornull;
60typedef mapstruct mapstruct_ornull; 58typedef mapstruct mapstruct_ornull;
62typedef double val64; 60typedef double val64;
63#define newSVval64 newSVnv 61#define newSVval64 newSVnv
64#define SvVAL64 SvNV 62#define SvVAL64 SvNV
65 63
66static f_plug_api gethook; 64static f_plug_api gethook;
67static f_plug_api registerGlobalEvent;
68static f_plug_api unregisterGlobalEvent;
69static f_plug_api systemDirectory; 65static f_plug_api systemDirectory;
70static f_plug_api object_set_property; 66static f_plug_api object_set_property;
71static f_plug_api map_get_map; 67static f_plug_api map_get_map;
72static f_plug_api object_insert; 68static f_plug_api object_insert;
73 69
88} CFPContext; 84} CFPContext;
89 85
90static HV *obj_cache; 86static HV *obj_cache;
91static PerlInterpreter *perl; 87static PerlInterpreter *perl;
92 88
89static AV *cb_global, *cb_object, *cb_player, *cb_type, *cb_map;
90
93#define PUSHcfapi(type,value) PUSHs (sv_2mortal (newSVcfapi (CFAPI_ ## type, (value)))) 91#define PUSHcfapi(type,value) PUSHs (sv_2mortal (newSVcfapi (CFAPI_ ## type, (value))))
94#define PUSHcfapi_va(type,ctype) PUSHcfapi (type, va_arg (args, ctype)) 92#define PUSHcfapi_va(type,ctype) PUSHcfapi (type, va_arg (args, ctype))
95#define PUSH_OB PUSHcfapi_va(POBJECT, object *) 93#define PUSH_OB PUSHcfapi_va(POBJECT, object *)
96#define PUSH_PL PUSHcfapi_va(PPLAYER, player *) 94#define PUSH_PL PUSHcfapi_va(PPLAYER, player *)
97#define PUSH_MAP PUSHcfapi_va(PMAP, mapstruct *) 95#define PUSH_MAP PUSHcfapi_va(PMAP, mapstruct *)
98#define PUSH_PV PUSHcfapi_va(STRING, const char *) 96#define PUSH_PV PUSHcfapi_va(STRING, const char *)
99#define PUSH_IV PUSHs (sv_2mortal (newSViv (va_arg (args, int)))) 97#define PUSH_IV PUSHs (sv_2mortal (newSViv (va_arg (args, int))))
100 98
101////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// 99//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
102 100
103// garbage collect some perl objects, if possible
104// all objects no longer referenced and empty are
105// eligible for destruction.
106static void
107clean_obj_cache ()
108{
109 static int count;
110
111 if (++count & 7)
112 return;
113
114 int todo = 1000;
115 do
116 {
117 I32 klen;
118 char *key;
119 HE *he = hv_iternext (obj_cache);
120
121 if (he)
122 {
123 SV *sv = hv_iterval (obj_cache, he);
124
125 // empty and unreferenced? nuke it
126 if (SvREFCNT (sv) == 1 && SvREFCNT (SvRV (sv)) == 1 && !HvFILL ((HV *)(SvRV (sv))))
127 {
128 hv_delete (obj_cache, HeKEY (he), HeKLEN (he), G_DISCARD);
129 todo++;
130 }
131 }
132 else
133 break;
134 }
135 while (--todo);
136}
137
138static SV * 101static SV *
139newSVptr (void *ptr, const char *klass) 102newSVptr (void *ptr, const char *klass, HV *hv = newHV ())
140{ 103{
141 SV *sv; 104 SV *sv;
142 105
143 if (!ptr) 106 if (!ptr)
144 return &PL_sv_undef; 107 return &PL_sv_undef;
145 108
146 sv = newSV (0);
147 sv_magic (sv, 0, PERL_MAGIC_ext, (char *)ptr, 0); 109 sv_magic ((SV *)hv, 0, PERL_MAGIC_ext, (char *)ptr, 0);
148 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));
149} 124}
150 125
151static void 126static void
152SVptr_cache_set (void *ptr, SV *sv) 127SVptr_cache_set (void *ptr, SV *sv)
153{ 128{
216 else 191 else
217 return 0; 192 return 0;
218} 193}
219 194
220static SV * 195static SV *
221newSVcfapi (int type, ...) 196newSVdt_va (va_list &ap, data_type type)
222{ 197{
223 SV *sv; 198 SV *sv;
224
225 va_list args;
226 va_start (args, type);
227 199
228 switch (type) 200 switch (type)
229 { 201 {
230#if 0
231 case CFAPI_INT16: 202 case DT_INT:
232 sv = newSViv (*va_arg (args, sint16_t *)); 203 sv = newSViv (va_arg (ap, int));
233 break; 204 break;
234#endif
235 205
236 case CFAPI_INT: 206 case DT_INT64:
237 sv = newSViv (*va_arg (args, int *)); 207 sv = newSVval64 ((val64)va_arg (ap, sint64));
238 break; 208 break;
239 209
240 case CFAPI_LONG: 210 case DT_DOUBLE:
241 sv = newSVval64 ((val64)*va_arg (args, sint64 *)); 211 sv = newSVnv (va_arg (ap, double));
242 break; 212 break;
243 213
244 case CFAPI_DOUBLE:
245 sv = newSVnv (*va_arg (args, double *));
246 break;
247
248 case CFAPI_STRING: 214 case DT_STRING:
249 { 215 {
250 char *str = va_arg (args, char *); 216 char *str = (char *)va_arg (ap, const char *);
251 sv = str ? newSVpv (str, 0) : &PL_sv_undef; 217 sv = str ? newSVpv (str, 0) : &PL_sv_undef;
252 } 218 }
253 break; 219 break;
254 220
255 case CFAPI_POBJECT: 221 case DT_DATA:
256 { 222 {
257 object *obj = va_arg (args, object *); 223 char *str = (char *)va_arg (ap, const void *);
258 224 int len = va_arg (ap, int);
259 if (!obj) 225 sv = str ? newSVpv (str, len) : &PL_sv_undef;
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 } 226 }
277 break; 227 break;
278 228
279 case CFAPI_PMAP: 229 case DT_OBJECT:
280 sv = newSVptr (va_arg (args, mapstruct *), "cf::map::wrap"); 230 {
231 object *obj = va_arg (ap, object *);
232 sv = newSVextendable (obj, obj && obj->type == PLAYER ? "cf::object::player::wrap" : "cf::object::wrap");
233 }
281 break; 234 break;
282 235
283 case CFAPI_PPLAYER: 236 case DT_MAP:
284 sv = newSVptr (va_arg (args, player *), "cf::player::wrap"); 237 // va_arg (object *) when void * is passed is an XSI extension
238 sv = newSVextendable (va_arg (ap, mapstruct *), "cf::map::wrap");
285 break; 239 break;
286 240
287 case CFAPI_PARCH: 241 case DT_PLAYER:
288 sv = newSVptr (va_arg (args, archetype *), "cf::arch::wrap"); 242 sv = newSVextendable (va_arg (ap, player *), "cf::player::wrap");
289 break; 243 break;
290 244
291 case CFAPI_PPARTY: 245 case DT_ARCH:
292 sv = newSVptr (va_arg (args, partylist *), "cf::party::wrap"); 246 sv = newSVptr (va_arg (ap, archetype *), "cf::arch::wrap");
293 break; 247 break;
294 248
295 case CFAPI_PREGION: 249 case DT_PARTY:
296 sv = newSVptr (va_arg (args, region *), "cf::region::wrap"); 250 sv = newSVptr (va_arg (ap, partylist *), "cf::party::wrap");
297 break; 251 break;
252
253 case DT_REGION:
254 sv = newSVptr (va_arg (ap, region *), "cf::region::wrap");
255 break;
256
257 default:
258 assert (("unhandled type in newSVdt_va", 0));
259 }
260
261 return sv;
262}
263
264static SV *
265newSVdt (data_type type, ...)
266{
267 va_list ap;
268
269 va_start (ap, type);
270 SV *sv = newSVdt_va (ap, type);
271 va_end (ap);
272
273 return sv;
274}
275
276static SV *
277newSVcfapi (int type, ...)
278{
279 SV *sv;
280
281 va_list ap;
282 va_start (ap, type);
283
284 switch (type)
285 {
286 case CFAPI_INT: sv = newSViv (*va_arg (ap, int * )); break;
287 case CFAPI_LONG: sv = newSVval64 (*va_arg (ap, sint64 *)); break;
288 case CFAPI_DOUBLE: sv = newSVnv (*va_arg (ap, double *)); break;
289 case CFAPI_STRING: sv = newSVdt_va (ap, DT_STRING); break;
290 case CFAPI_POBJECT: sv = newSVdt_va (ap, DT_OBJECT); break;
291 case CFAPI_PMAP: sv = newSVdt_va (ap, DT_MAP ); break;
292 case CFAPI_PPLAYER: sv = newSVdt_va (ap, DT_PLAYER); break;
293 case CFAPI_PARCH: sv = newSVdt_va (ap, DT_ARCH ); break;
294 case CFAPI_PPARTY: sv = newSVdt_va (ap, DT_PARTY ); break;
295 case CFAPI_PREGION: sv = newSVdt_va (ap, DT_REGION); break;
298 296
299 default: 297 default:
300 assert (("unhandled type in newSVcfapi", 0)); 298 assert (("unhandled type in newSVcfapi", 0));
301 } 299 }
302 300
303 va_end (args); 301 va_end (ap);
304 302
305 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);
306} 479}
307 480
308///////////////////////////////////////////////////////////////////////////// 481/////////////////////////////////////////////////////////////////////////////
309 482
310extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr) 483extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr)
401 int hooktype = 1; 574 int hooktype = 1;
402 int rtype = 0; 575 int rtype = 0;
403 576
404 printf (PLUGIN_VERSION " post init\n"); 577 printf (PLUGIN_VERSION " post init\n");
405 578
406 registerGlobalEvent = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_system_register_global_event");
407 unregisterGlobalEvent = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_system_unregister_global_event");
408 systemDirectory = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_system_directory"); 579 systemDirectory = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_system_directory");
409 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");
410 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");
411 object_insert = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_object_insert"); 582 object_insert = (void* (*)(int*, ...)) gethook (&rtype, hooktype, "cfapi_object_insert");
412 583
413 cf_init_plugin (gethook); 584 cf_init_plugin (gethook);
414 585
415 /* Pick the global events you want to monitor from this plugin */ 586 return 0;
416 registerGlobalEvent (NULL, EVENT_BORN, PLUGIN_NAME, globalEventListener); 587}
417 registerGlobalEvent (NULL, EVENT_CLOCK, PLUGIN_NAME, globalEventListener);
418 //registerGlobalEvent (NULL, EVENT_CRASH, PLUGIN_NAME, globalEventListener);
419 registerGlobalEvent (NULL, EVENT_FIND_UNARMED_SKILL, PLUGIN_NAME, globalEventListener);
420 registerGlobalEvent (NULL, EVENT_PLAYER_USE_SKILL, PLUGIN_NAME, globalEventListener);
421 registerGlobalEvent (NULL, EVENT_CAST_SPELL, PLUGIN_NAME, globalEventListener);
422 registerGlobalEvent (NULL, EVENT_MONSTER_USE_SKILL, PLUGIN_NAME, globalEventListener);
423 registerGlobalEvent (NULL, EVENT_PLAYER_DEATH, PLUGIN_NAME, globalEventListener);
424 registerGlobalEvent (NULL, EVENT_GKILL, PLUGIN_NAME, globalEventListener);
425 registerGlobalEvent (NULL, EVENT_LOGIN, PLUGIN_NAME, globalEventListener);
426 registerGlobalEvent (NULL, EVENT_LOGOUT, PLUGIN_NAME, globalEventListener);
427 registerGlobalEvent (NULL, EVENT_MAPENTER, PLUGIN_NAME, globalEventListener);
428 registerGlobalEvent (NULL, EVENT_MAPLEAVE, PLUGIN_NAME, globalEventListener);
429 registerGlobalEvent (NULL, EVENT_MAPRESET, PLUGIN_NAME, globalEventListener);
430 registerGlobalEvent (NULL, EVENT_MAPLOAD, PLUGIN_NAME, globalEventListener);
431 registerGlobalEvent (NULL, EVENT_MAPOUT, PLUGIN_NAME, globalEventListener);
432 registerGlobalEvent (NULL, EVENT_MAPIN, PLUGIN_NAME, globalEventListener);
433 registerGlobalEvent (NULL, EVENT_MAPCLEAN, PLUGIN_NAME, globalEventListener);
434 registerGlobalEvent (NULL, EVENT_REMOVE, PLUGIN_NAME, globalEventListener);
435 registerGlobalEvent (NULL, EVENT_SHOUT, PLUGIN_NAME, globalEventListener);
436 registerGlobalEvent (NULL, EVENT_TELL, PLUGIN_NAME, globalEventListener);
437 registerGlobalEvent (NULL, EVENT_MUZZLE, PLUGIN_NAME, globalEventListener);
438 registerGlobalEvent (NULL, EVENT_KICK, PLUGIN_NAME, globalEventListener);
439 registerGlobalEvent (NULL, EVENT_FREE_OB, PLUGIN_NAME, globalEventListener);
440 registerGlobalEvent (NULL, EVENT_PLAYER_LOAD, PLUGIN_NAME, globalEventListener);
441 registerGlobalEvent (NULL, EVENT_PLAYER_SAVE, PLUGIN_NAME, globalEventListener);
442 registerGlobalEvent (NULL, EVENT_EXTCMD, PLUGIN_NAME, globalEventListener);
443 588
589extern "C" int cfperl_closePlugin ()
590{
591 return 0;
592}
593
594void
595cfperl_init ()
596{
444 char *argv[] = { 597 char *argv[] = {
445 "", 598 "",
446 "-e" 599 "-e"
447 "BEGIN {" 600 "BEGIN {"
448 " cf->bootstrap;" 601 " cf->bootstrap;"
457 610
458 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; 611 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
459 612
460 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl)) 613 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl))
461 { 614 {
462 printf ("unable to initialize perl-interpreter, continuing without.\n"); 615 printf ("unable to initialize perl-interpreter, aborting.\n");
463 616
617 exit (EXIT_FAILURE);
464 perl_destruct (perl); 618 //perl_destruct (perl);
465 perl_free (perl); 619 //perl_free (perl);
466 perl = 0; 620 //perl = 0;
621 //return;
467 } 622 }
468 else 623
624 obj_cache = newHV ();
625}
626
627void cfperl_main ()
628{
629 dSP;
630
631 PUSHMARK (SP);
632 PUTBACK;
633 call_pv ("cf::main", G_DISCARD | G_VOID);
634}
635
636static event_klass klass_of[NUM_EVENT_TYPES] = {
637# define def(type,name) KLASS_ ## type,
638# include "eventinc.h"
639# undef def
640};
641
642static void
643gather_callbacks (AV *&callbacks, AV *registry, event_type event)
644{
645 // event must be in array
646 if (event >= 0 && event <= AvFILLp (registry))
469 { 647 {
470 obj_cache = newHV (); 648 SV *cbs_ = AvARRAY (registry)[event];
649
650 // element must be list of callback entries
651 if (cbs_ && SvROK (cbs_) && SvTYPE (SvRV (cbs_)) == SVt_PVAV)
652 {
653 AV *cbs = (AV *)SvRV (cbs_);
654
655 // no callback entries, no callbacks to call
656 if (AvFILLp (cbs) >= 0)
657 {
658 if (!callbacks)
659 {
660 callbacks = newAV ();
661 av_extend (callbacks, 16);
662 }
663
664 // never use SvREFCNT_inc to copy values, but its ok here :)
665 for (int i = 0; i <= AvFILLp (cbs); ++i)
666 av_push (callbacks, SvREFCNT_inc (AvARRAY (cbs)[i]));
667 }
668 }
471 } 669 }
472
473 return 0;
474} 670}
475 671
476static void * 672bool cfperl_invoke (event_type event, ...)
477globalEventListener (int *type, ...)
478{ 673{
674 data_type dt;
479 va_list args; 675 va_list ap;
480 static int rv;
481 int event_code;
482 676
483 if (!perl)
484 return NULL;
485
486 va_start (args, type); 677 va_start (ap, event);
487 event_code = va_arg (args, int);
488 678
489 if (event_code == EVENT_FREE_OB) 679 AV *callbacks = 0;
680
681 object *op;
682 player *pl;
683 mapstruct *map;
684
685 // callback call ordering is:
686 // 1. per-object callback (NYI)
687 // 2. per-class object
688 // 2a. per-type callback
689 // 4. global callbacks
690
691 gather_callbacks (callbacks, cb_global, event);
692
693 switch (klass_of [event])
490 { 694 {
491 player *pl; 695 case KLASS_GLOBAL:
492 object *op; 696 break;
493 SV *sv;
494 697
698 case KLASS_OBJECT:
699 dt = (data_type) va_arg (ap, int);
700 assert (("first argument must be of type object", dt == DT_OBJECT));
495 op = va_arg (args, object *); 701 op = va_arg (ap, object *);
496 sv = hv_delete (obj_cache, (char *)&op, sizeof (void *), 0);
497 702
498 if (sv) 703 if (op->cb)
499 clearSVptr (sv); 704 gather_callbacks (callbacks, (AV *)op->cb, event);
500 705
501 rv = 0; 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
725 gather_callbacks (callbacks, cb_object, event);
726
727 break;
728
729 case KLASS_PLAYER:
730 dt = (data_type) va_arg (ap, int);
731 assert (("first argument must be of type player", dt == DT_PLAYER));
732 pl = va_arg (ap, player *);
733
734 if (pl->cb)
735 gather_callbacks (callbacks, (AV *)pl->cb, event);
736
737 gather_callbacks (callbacks, cb_player, event);
738 break;
739
740 case KLASS_MAP:
741 dt = (data_type) va_arg (ap, int);
742 assert (("first argument must be of type object", dt == DT_MAP));
743 map = va_arg (ap, mapstruct *);
744
745 if (map->cb)
746 gather_callbacks (callbacks, (AV *)map->cb, event);
747
748 gather_callbacks (callbacks, cb_map, event);
749 break;
750
751 default:
752 assert (("unsupported event klass in cfperl_invoke", 0));
502 } 753 }
503 else if (event_code == EVENT_CLOCK)
504 {
505 clean_obj_cache ();
506 }
507 else
508 {
509 dSP;
510 754
511 ENTER; 755 // short-circuit processing if no callbacks found/defined
512 SAVETMPS; 756 if (!callbacks)
513
514 PUSHMARK (SP);
515
516 EXTEND (SP, 10);
517 PUSHs (sv_2mortal (newSViv (event_code)));
518
519 switch (event_code)
520 {
521 case EVENT_CRASH:
522 break;
523
524 case EVENT_PLAYER_LOAD:
525 case EVENT_PLAYER_SAVE:
526 PUSH_OB;
527 PUSH_PV;
528 break;
529
530 case EVENT_MAPLOAD:
531 case EVENT_MAPOUT:
532 case EVENT_MAPIN:
533 case EVENT_MAPCLEAN:
534 case EVENT_MAPRESET:
535 PUSH_MAP;
536 break;
537
538 case EVENT_MAPENTER:
539 case EVENT_MAPLEAVE:
540 case EVENT_BORN:
541 case EVENT_REMOVE:
542 case EVENT_PLAYER_DEATH:
543 PUSH_OB;
544 break;
545
546 case EVENT_GKILL:
547 PUSH_OB;
548 PUSH_OB;
549 break;
550
551 case EVENT_LOGIN:
552 case EVENT_LOGOUT:
553 PUSH_PL;
554 PUSH_PV;
555 break;
556
557 case EVENT_SHOUT:
558 case EVENT_MUZZLE:
559 case EVENT_KICK:
560 PUSH_OB;
561 PUSH_PV;
562 break;
563
564 case EVENT_FIND_UNARMED_SKILL:
565 PUSH_OB;
566 break;
567
568 case EVENT_PLAYER_USE_SKILL:
569 case EVENT_MONSTER_USE_SKILL:
570 case EVENT_CAST_SPELL:
571 PUSH_OB;
572 PUSH_OB;
573 PUSH_OB;
574 PUSH_IV;
575 PUSH_PV;
576 break;
577
578 case EVENT_EXTCMD:
579 PUSH_PL;
580 {
581 char *buf = va_arg (args, char *);
582 int len = va_arg (args, int);
583 PUSHs (sv_2mortal (newSVpvn (buf, len)));
584 }
585 break;
586
587 case EVENT_TELL:
588 break;
589 }
590
591 va_end (args);
592
593 PUTBACK;
594 int count = call_pv ("cf::inject_global_event", G_SCALAR | G_EVAL);
595 SPAGAIN;
596
597 if (SvTRUE (ERRSV))
598 LOG (llevError, "global event '%d' callback evaluation error: %s", event_code, SvPV_nolen (ERRSV));
599
600 rv = count > 0 ? POPi : 0;
601
602 PUTBACK;
603 FREETMPS;
604 LEAVE;
605 }
606
607 return &rv;
608}
609
610extern "C" void *cfperl_eventListener (int *type, ...)
611{
612 static int rv;
613 va_list args;
614 int event_code;
615 object *who, *activator, *third, *event;
616 char *message, *extension, *options;
617
618 if (!perl)
619 return NULL;
620
621 va_start (args, type);
622 who = va_arg (args, object *);
623 event_code = va_arg (args, int);
624 activator = va_arg (args, object *);
625 third = va_arg (args, object *);
626 message = va_arg (args, char *);
627 va_arg (args, int); // fix yourself
628 extension = va_arg (args, char *);
629 options = va_arg (args, char *);
630 event = va_arg (args, object *);
631 va_end (args);
632
633 {
634 dSP;
635
636 ENTER;
637 SAVETMPS;
638
639 PUSHMARK (SP);
640 EXTEND (SP, 10);
641
642 PUSHcfapi (STRING, extension);
643 PUSHs (sv_2mortal (newSViv (event_code)));
644
645 PUSHcfapi (POBJECT, event);
646 PUSHcfapi (POBJECT, who);
647
648 switch (event_code)
649 {
650 case EVENT_STOP: // $ob (e.g. arrow)
651 case EVENT_TIME: // $ob
652 case EVENT_TIMER: // $ob
653 break;
654
655 case EVENT_APPLY: // $ob, $who
656 case EVENT_DROP: // $ob, $who
657 case EVENT_CLOSE: // $ob, $who
658 case EVENT_DEATH: // $ob[, $killer]
659 case EVENT_MOVE: // $ob, $enemy
660 case EVENT_THROW: // $ob, $thrower
661 PUSHcfapi (POBJECT, activator);
662 break;
663
664 case EVENT_DROP_ON: // $ob, $who, $what
665 case EVENT_ATTACK: // $ob, $who, $victim (?? please god enlighten me)
666 PUSHcfapi (POBJECT, activator);
667 PUSHcfapi (POBJECT, third);
668 break;
669
670 case EVENT_TRIGGER: // $ob, $originator, [$victim], [$msg]
671 PUSHcfapi (POBJECT, activator);
672 PUSHcfapi (POBJECT, third);
673 PUSHcfapi (POBJECT, message);
674 break;
675
676 case EVENT_SAY: // $ob, $who, $msg
677 PUSHcfapi (POBJECT, activator);
678 PUSHcfapi (STRING, message);
679 break;
680
681 default:
682 LOG (llevError, "perl plugin called for unsupported event type %d", event_code);
683 break;
684 }
685
686 PUTBACK;
687 int count = call_pv ("cf::inject_event", G_SCALAR | G_EVAL);
688 SPAGAIN;
689
690 if (SvTRUE (ERRSV))
691 LOG (llevError, "event '%d' callback evaluation error: %s", event_code, SvPV_nolen (ERRSV));
692
693 rv = count > 0 ? POPi : 0;
694
695 PUTBACK;
696 FREETMPS;
697 LEAVE;
698 }
699
700 return &rv;
701}
702
703extern "C" int cfperl_closePlugin ()
704{
705 printf (PLUGIN_VERSION " closing\n");
706
707 if (perl)
708 {
709 perl_destruct (perl);
710 perl_free (perl);
711 perl = 0;
712 }
713
714 return 0; 757 return 0;
715}
716 758
717void cfperl_sleep (double delta)
718{
719 dSP; 759 dSP;
720 ENTER; 760 ENTER;
721 SAVETMPS; 761 SAVETMPS;
722 762
723 PUSHMARK (SP); 763 PUSHMARK (SP);
764 EXTEND (SP, 3);
765
766 PUSHs (sv_2mortal (newSViv (event))); // only used for debugging nowadays
767 PUSHs (sv_2mortal (newRV_noinc ((SV *)callbacks)));
768
769 switch (klass_of [event])
770 {
771 case KLASS_OBJECT: PUSHs (sv_2mortal (newSVdt (DT_OBJECT, op))); break;
772 case KLASS_PLAYER: PUSHs (sv_2mortal (newSVdt (DT_PLAYER, pl))); break;
773 case KLASS_MAP: PUSHs (sv_2mortal (newSVdt (DT_MAP, map))); break;
774 }
775
776 for (;;)
777 {
778 dt = (data_type) va_arg (ap, int);
779
780 if (dt == DT_END)
781 break;
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
724 XPUSHs (sv_2mortal (newSVnv (delta))); 791 XPUSHs (sv_2mortal (newSVdt_va (ap, dt)));
792 }
793
794 va_end (ap);
795
725 PUTBACK; 796 PUTBACK;
726 call_pv ("cf::sleep_delta", G_DISCARD | G_VOID | G_EVAL); 797 int count = call_pv ("cf::do_invoke", G_SCALAR | G_EVAL);
727 SPAGAIN; 798 SPAGAIN;
799
800 count = count > 0 ? POPi : 0;
728 801
729 FREETMPS; 802 FREETMPS;
730 LEAVE; 803 LEAVE;
804
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));
731} 826}
732 827
733MODULE = cf PACKAGE = cf PREFIX = cf_ 828MODULE = cf PACKAGE = cf PREFIX = cf_
734 829
735BOOT: 830BOOT:
744 const_iv (llevError) 839 const_iv (llevError)
745 const_iv (llevInfo) 840 const_iv (llevInfo)
746 const_iv (llevDebug) 841 const_iv (llevDebug)
747 const_iv (llevMonster) 842 const_iv (llevMonster)
748 843
844 const_iv (MAX_TIME)
749 const_iv (PLAYER) 845 const_iv (PLAYER)
750 const_iv (TRANSPORT) 846 const_iv (TRANSPORT)
751 const_iv (ROD) 847 const_iv (ROD)
752 const_iv (TREASURE) 848 const_iv (TREASURE)
753 const_iv (POTION) 849 const_iv (POTION)
868 const_iv (BUILDER) 964 const_iv (BUILDER)
869 const_iv (MATERIAL) 965 const_iv (MATERIAL)
870 const_iv (ITEM_TRANSFORMER) 966 const_iv (ITEM_TRANSFORMER)
871 const_iv (QUEST) 967 const_iv (QUEST)
872 968
969 const_iv (NUM_SUBTYPES)
970
873 const_iv (ST_BD_BUILD) 971 const_iv (ST_BD_BUILD)
874 const_iv (ST_BD_REMOVE) 972 const_iv (ST_BD_REMOVE)
875 973
876 const_iv (ST_MAT_FLOOR) 974 const_iv (ST_MAT_FLOOR)
877 const_iv (ST_MAT_WALL) 975 const_iv (ST_MAT_WALL)
1213 1311
1214 const_iv (MAP_IN_MEMORY) 1312 const_iv (MAP_IN_MEMORY)
1215 const_iv (MAP_SWAPPED) 1313 const_iv (MAP_SWAPPED)
1216 const_iv (MAP_LOADING) 1314 const_iv (MAP_LOADING)
1217 const_iv (MAP_SAVING) 1315 const_iv (MAP_SAVING)
1316
1317 const_iv (KLASS_GLOBAL)
1318 const_iv (KLASS_OBJECT)
1319 const_iv (KLASS_PLAYER)
1320 const_iv (KLASS_MAP)
1218 }; 1321 };
1219 1322
1220 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; )
1221 newCONSTSUB (stash, (char *)civ->name, newSViv (civ->iv)); 1324 newCONSTSUB (stash, (char *)civ->name, newSViv (civ->iv));
1222 1325
1223 static const struct { 1326 static const struct {
1224 const char *name; 1327 const char *name;
1328 int skip;
1329 IV klass;
1225 IV iv; 1330 IV iv;
1226 } *event, event_list[] = { 1331 } *eiv, event_iv[] = {
1227# define const_event(name) { # name, (IV)EVENT_ ## name }, 1332# define def(klass,name) { "EVENT_" # klass "_" # name, sizeof ("EVENT_" # klass), (IV)KLASS_ ## klass, (IV)EVENT_ ## klass ## _ ## name },
1228 const_event (NONE) 1333# include "eventinc.h"
1229 const_event (APPLY) 1334# undef def
1230 const_event (ATTACK)
1231 const_event (DEATH)
1232 const_event (DROP)
1233 const_event (DROP_ON)
1234 const_event (PICKUP)
1235 const_event (SAY)
1236 const_event (STOP)
1237 const_event (TIME)
1238 const_event (THROW)
1239 const_event (TRIGGER)
1240 const_event (CLOSE)
1241 const_event (TIMER)
1242 const_event (MOVE)
1243
1244 const_event (BORN)
1245 //const_event (CLOCK)
1246 const_event (CRASH)
1247 const_event (PLAYER_DEATH)
1248 const_event (PLAYER_LOAD)
1249 const_event (PLAYER_SAVE)
1250 const_event (GKILL)
1251 const_event (LOGIN)
1252 const_event (LOGOUT)
1253 const_event (MAPENTER)
1254 const_event (MAPLEAVE)
1255 const_event (MAPRESET)
1256 const_event (MAPLOAD)
1257 const_event (MAPOUT)
1258 const_event (MAPIN)
1259 const_event (MAPCLEAN)
1260 const_event (REMOVE)
1261 const_event (SHOUT)
1262 const_event (TELL)
1263 const_event (MUZZLE)
1264 const_event (KICK)
1265 const_event (PLAYER_USE_SKILL)
1266 const_event (MONSTER_USE_SKILL)
1267 const_event (CAST_SPELL)
1268 const_event (FIND_UNARMED_SKILL)
1269 const_event (EXTCMD)
1270 //const_event (FREE_OB)
1271 }; 1335 };
1272 1336
1273 AV *av = get_av ("cf::EVENT", 1); 1337 AV *av = get_av ("cf::EVENT", 1);
1274 1338
1275 for (event = event_list + sizeof (event_list) / sizeof (event_list [0]); event-- > event_list; ) 1339 for (eiv = event_iv + sizeof (event_iv) / sizeof (event_iv [0]); eiv-- > event_iv; )
1276 av_store (av, event->iv, newSVpv ((char *)event->name, 0)); 1340 {
1341 AV *event = newAV ();
1342 av_push (event, newSVpv ((char *)eiv->name + eiv->skip, 0));
1343 av_push (event, newSViv (eiv->klass));
1344 av_store (av, eiv->iv, newRV_noinc ((SV *)event));
1345 newCONSTSUB (stash, (char *)eiv->name, newSViv (eiv->iv));
1346 }
1277 1347
1278 static const struct { 1348 static const struct {
1279 int dtype; 1349 int dtype;
1280 const char *name; 1350 const char *name;
1281 IV idx; 1351 IV idx;
1412 } 1482 }
1413 1483
1414 //I_EVENT_API (PACKAGE); 1484 //I_EVENT_API (PACKAGE);
1415} 1485}
1416 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);
1507}
1508
1417NV floor (NV x) 1509NV floor (NV x)
1418 1510
1419NV ceil (NV x) 1511NV ceil (NV x)
1512
1513void server_tick ()
1420 1514
1421void 1515void
1422LOG (int level, char *msg) 1516LOG (int level, char *msg)
1423 PROTOTYPE: $$ 1517 PROTOTYPE: $$
1424 C_ARGS: (LogLevel)level, "%s", msg 1518 C_ARGS: (LogLevel)level, "%s", msg
1462 PROTOTYPE: $ 1556 PROTOTYPE: $
1463 1557
1464int random_roll(int min, int max, object *op, int goodbad); 1558int random_roll(int min, int max, object *op, int goodbad);
1465 1559
1466const 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}
1467 1569
1468int 1570int
1469exp_to_level (val64 exp) 1571exp_to_level (val64 exp)
1470 CODE: 1572 CODE:
1471{ 1573{
1710{ 1812{
1711 int unused_type; 1813 int unused_type;
1712 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);
1713} 1815}
1714 1816
1817SV *registry (object *op)
1818 CODE:
1819 RETVAL = registry_of (op);
1820 OUTPUT:
1821 RETVAL
1822
1715# syntatic sugar for easier use in event callbacks. 1823# syntatic sugar for easier use in event callbacks.
1716const char *options (object *op) 1824const char *options (object *op)
1717 CODE: 1825 CODE:
1718 RETVAL = op->name; 1826 RETVAL = op->name;
1719 OUTPUT: 1827 OUTPUT:
1789 1897
1790void cf_player_set_party (object *op, partylist *party) 1898void cf_player_set_party (object *op, partylist *party)
1791 1899
1792void kill_player (object *op) 1900void kill_player (object *op)
1793 1901
1794MODULE = cf PACKAGE = cf::object::map PREFIX = cf_
1795
1796MODULE = 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
1797 1909
1798player *cf_player_find (char *name) 1910player *cf_player_find (char *name)
1799 PROTOTYPE: $ 1911 PROTOTYPE: $
1800 1912
1801void cf_player_move (player *pl, int dir) 1913void cf_player_move (player *pl, int dir)
1828 1940
1829char * 1941char *
1830client (player *pl) 1942client (player *pl)
1831 CODE: 1943 CODE:
1832 RETVAL = pl->socket.client; 1944 RETVAL = pl->socket.client;
1945 OUTPUT:
1946 RETVAL
1947
1948char *
1949host (player *pl)
1950 CODE:
1951 RETVAL = pl->socket.host;
1952 OUTPUT:
1953 RETVAL
1954
1955char *
1956killer (player *pl, char *killer = 0)
1957 CODE:
1958 if (killer)
1959 snprintf (pl->killer, sizeof (pl->killer), "%s", killer);
1960 RETVAL = pl->killer;
1833 OUTPUT: 1961 OUTPUT:
1834 RETVAL 1962 RETVAL
1835 1963
1836void 1964void
1837buggy_mapscroll (player *pl, int value = 1) 1965buggy_mapscroll (player *pl, int value = 1)
1903 RETVAL = &pl->last_stats; 2031 RETVAL = &pl->last_stats;
1904 OUTPUT: RETVAL 2032 OUTPUT: RETVAL
1905 2033
1906 2034
1907MODULE = 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
1908 2042
1909SV * 2043SV *
1910get_property (mapstruct *obj, int type, int idx) 2044get_property (mapstruct *obj, int type, int idx)
1911 CODE: 2045 CODE:
1912 RETVAL = newSVcfapi (type, cf_map_get_property (obj, idx)); 2046 RETVAL = newSVcfapi (type, cf_map_get_property (obj, idx));
2056 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;
2057 } 2191 }
2058 OUTPUT: 2192 OUTPUT:
2059 RETVAL 2193 RETVAL
2060 2194
2061# "serialise" map perl data into a ref 2195# "deserialise" perl map data into the map # TODO# compatibility cruft, remove
2062void
2063_get_obs (mapstruct *map)
2064 PPCODE:
2065{
2066 object *o;
2067 int x, y;
2068 AV *obs = newAV ();
2069 int nonnull = 0;
2070
2071 for (y = 0; y < MAP_HEIGHT (map); y++)
2072 for (x = 0; x < MAP_WIDTH (map); x++)
2073 {
2074 AV *av = newAV ();
2075
2076 for (o = GET_MAP_OB (map, x, y); o; o = o->above)
2077 {
2078 SV *sv = SVptr_cache_get (o);
2079
2080 if (sv && HvFILL (SvRV (sv)))
2081 {
2082 nonnull = 1;
2083 sv = newSVsv (sv);
2084 }
2085 else
2086 sv = &PL_sv_undef;
2087
2088 av_push (av, sv);
2089 }
2090
2091 av_store (obs, x + y * MAP_HEIGHT (map), newRV_noinc ((SV *)av));
2092 }
2093
2094 if (nonnull)
2095 XPUSHs (sv_2mortal (newRV_noinc ((SV *)obs)));
2096 else
2097 SvREFCNT_dec (obs);
2098}
2099
2100# "deserialise" perl map data into the map
2101void 2196void
2102_set_obs (mapstruct *map, SV *sv) 2197_set_obs (mapstruct *map, SV *sv)
2103 CODE: 2198 CODE:
2104{ 2199{
2105 object *o; 2200 object *o;

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines