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.27 by root, Tue Aug 29 17:32:19 2006 UTC vs.
Revision 1.33 by elmex, Thu Aug 31 01:03:36 2006 UTC

… …
21 * You should have received a copy of the GNU General Public License 21 * You should have received a copy of the GNU General Public License
22 * along with this program; if not, write to the Free Software 22 * along with this program; if not, write to the Free Software
23 * Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 23 * Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
24*/ 24*/
25 25
26#include <EXTERN.h>
27#include <perl.h>
28#include <XSUB.h>
29
30#undef save_long // clashes with libproto.h
31
32#define PLUGIN_NAME "perl" 26#define PLUGIN_NAME "perl"
33#define PLUGIN_VERSION "cfperl 0.5" 27#define PLUGIN_VERSION "cfperl 0.5"
34 28
35#ifndef __CEXTRACT__ 29#ifndef __CEXTRACT__
36#include <plugin.h> 30#include <plugin.h>
… …
48#include <sproto.h> 42#include <sproto.h>
49 43
50#include "cfperl.h" 44#include "cfperl.h"
51#include "shstr.h" 45#include "shstr.h"
52 46
47#include <EXTERN.h>
48#include <perl.h>
49#include <XSUB.h>
50
53#include "perlxsi.c" 51#include "perlxsi.c"
54 52
55extern sint64 *levels; // the experience table 53extern sint64 *levels; // the experience table
56 54
57typedef object object_ornull; 55typedef object object_ornull;
… …
61#define newSVval64 newSVnv 59#define newSVval64 newSVnv
62#define SvVAL64 SvNV 60#define SvVAL64 SvNV
63 61
64static f_plug_api gethook = cfapi_get_hooks; 62static f_plug_api gethook = cfapi_get_hooks;
65static f_plug_api object_set_property = cfapi_object_set_property; 63static f_plug_api object_set_property = cfapi_object_set_property;
66static f_plug_api map_get_map = cfapi_map_get_map;
67static f_plug_api object_insert = cfapi_object_insert; 64static f_plug_api object_insert = cfapi_object_insert;
65
66static bool perl_booted;
68 67
69/* this is a stupid way to do things, and awkward to use for plug-in authors */ 68/* this is a stupid way to do things, and awkward to use for plug-in authors */
70typedef struct 69typedef struct
71{ 70{
72 object* who; 71 object* who;
… …
117 return &PL_sv_undef; 116 return &PL_sv_undef;
118 117
119 if (!obj->self) 118 if (!obj->self)
120 obj->self = newSVptr (obj, klass); 119 obj->self = newSVptr (obj, klass);
121 120
122 return newSVsv (static_cast<SV *>(obj->self)); 121 return newSVsv (obj->self);
123} 122}
124 123
125static void 124static void
126SVptr_cache_set (void *ptr, SV *sv) 125SVptr_cache_set (void *ptr, SV *sv)
127{ 126{
… …
316void attachable_base::clear () 315void attachable_base::clear ()
317{ 316{
318 if (self) 317 if (self)
319 { 318 {
320 if (cb) 319 if (cb)
321 if (SvROK (*av_fetch ((AV *)cb, EVENT_OBJECT_DESTROY, 1))) 320 if (SvROK (*av_fetch (cb, EVENT_OBJECT_DESTROY, 1)))
322 INVOKE_OBJECT (DESTROY, static_cast<object *>(this)); 321 INVOKE_OBJECT (DESTROY, static_cast<object *>(this));
323 else if (SvROK (*av_fetch ((AV *)cb, EVENT_MAP_DESTROY, 1))) 322 else if (SvROK (*av_fetch (cb, EVENT_MAP_DESTROY, 1)))
324 INVOKE_MAP (DESTROY, static_cast<mapstruct *>(this)); 323 INVOKE_MAP (DESTROY, static_cast<mapstruct *>(this));
325 324
326 // disconnect Perl from C, to avoid crashes 325 // disconnect Perl from C, to avoid crashes
327 sv_unmagic (SvRV ((SV *)self), PERL_MAGIC_ext); 326 sv_unmagic (SvRV ((SV *)self), PERL_MAGIC_ext);
328 327
… …
425 this->filename = (SV *)newSVpv (filename, 0); 424 this->filename = (SV *)newSVpv (filename, 0);
426 425
427 char filename2 [4096]; 426 char filename2 [4096];
428 snprintf (filename2, 4096, "%s~", filename); 427 snprintf (filename2, 4096, "%s~", filename);
429 428
429 av = newAV ();
430
431 // TODO: fast dynbuf implementation... yeah, we need obstacks
432 text = newSV (10 * 1024 * 1024); // only temporarily used, so be generous
433}
434
435object_freezer::~object_freezer ()
436{
437 dSP;
438 ENTER;
439 SAVETMPS;
440 PUSHMARK (SP);
441 XPUSHs (sv_2mortal ((SV *)filename));
442 XPUSHs (sv_2mortal (newRV_noinc (text)));
443 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
444 PUTBACK;
445 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL);
446 FREETMPS;
447 LEAVE;
448}
449
450void object_freezer::put (attachable_base *ext)
451{
452 ext->optimise ();
453
454 if (ext->self)
455 {
456 int idx = AvFILLp ((AV *)av) + 1;
457 av_store (av, idx, SvREFCNT_inc (ext->self));
458
459 sv_catpvf (text, "oid %d\n", idx);
460 }
461}
462
463int fprintf (object_freezer &freezer, const char *format, ...)
464{
465 va_list ap;
466
467 va_start (ap, format);
468 sv_vcatpvfn (freezer.text, format, strlen (format), &ap, 0, 0, 0);
469 va_end (ap);
470}
471
472int fputs (const char *s, object_freezer &freezer)
473{
474 sv_catpvn (freezer.text, s, strlen (s));
475}
476
477object_thawer::object_thawer (const char *filename)
478{
479 av = 0;
480 fp = 0;
481
482 if (!filename)
483 return;
484
430 fp = fopen (filename2, "w"); 485 fp = fopen (filename, "r");
431
432 if (!fp) 486 if (!fp)
433 LOG (llevError, "cannot open file '%s' for writing: %s\n", filename2, strerror (errno));
434
435 av = (AV *)newAV ();
436}
437
438object_freezer::~object_freezer ()
439{
440 if (fp)
441 { 487 {
442 fclose (fp); 488 LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno));
489 return;
490 }
443 491
492 if (perl_booted)
493 {
444 dSP; 494 dSP;
445 ENTER; 495 ENTER;
446 SAVETMPS; 496 SAVETMPS;
447 PUSHMARK (SP); 497 PUSHMARK (SP);
448 XPUSHs (sv_2mortal ((SV *)filename)); 498 XPUSHs (sv_2mortal (newSVpv (filename, 0)));
449 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
450 PUTBACK; 499 PUTBACK;
451 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL); 500
501 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL))
502 {
503 SPAGAIN;
504 SV *sv = POPs;
505 if (SvROK (sv))
506 av = (AV *)SvREFCNT_inc (SvRV (sv));
507 }
508
452 FREETMPS; 509 FREETMPS;
453 LEAVE; 510 LEAVE;
454 } 511 }
455 else
456 SvREFCNT_dec ((SV *)filename);
457}
458
459void object_freezer::put (attachable_base *ext)
460{
461 ext->optimise ();
462
463 if (ext->self)
464 {
465 int idx = AvFILLp ((AV *)av) + 1;
466 av_store ((AV *)av, idx, SvREFCNT_inc ((SV *)ext->self));
467 fprintf (fp, "oid %d\n", idx);
468 }
469}
470
471object_thawer::object_thawer (FILE *fp, const char *filename)
472{
473 this->fp = fp;
474 av = 0;
475
476 if (!filename)
477 return;
478
479 dSP;
480 ENTER;
481 SAVETMPS;
482 PUSHMARK (SP);
483 XPUSHs (sv_2mortal (newSVpv (filename, 0)));
484 PUTBACK;
485
486 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL))
487 {
488 SPAGAIN;
489 SV *sv = POPs;
490 if (SvROK (sv))
491 av = SvREFCNT_inc (SvRV (sv));
492 }
493
494 FREETMPS;
495 LEAVE;
496} 512}
497 513
498void object_thawer::get (data_type type, void *obj, attachable_base *ext, int oid) 514void object_thawer::get (data_type type, void *obj, attachable_base *ext, int oid)
499{ 515{
500 if (!av || oid < 0) // this is actually an error of sorts 516 if (!av || oid < 0) // this is actually an error of sorts
… …
510 printf ("trying to thaw duplicate or never-issued oid %d, ignoring.\n", oid); 526 printf ("trying to thaw duplicate or never-issued oid %d, ignoring.\n", oid);
511 return; 527 return;
512 } 528 }
513 529
514 ext->self = *svp; *svp = &PL_sv_undef; 530 ext->self = *svp; *svp = &PL_sv_undef;
515 sv_magic (SvRV ((SV *)ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0); 531 sv_magic (SvRV (ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0);
516 532
517 reattach (type, obj); 533 reattach (type, obj);
518} 534}
519 535
520object_thawer::~object_thawer () 536object_thawer::~object_thawer ()
521{ 537{
538 if (fp) fclose (fp);
522 if (av) SvREFCNT_dec ((AV *)av); 539 if (av) SvREFCNT_dec ((AV *)av);
523} 540}
524 541
525///////////////////////////////////////////////////////////////////////////// 542/////////////////////////////////////////////////////////////////////////////
526 543
… …
626} 643}
627 644
628void 645void
629cfperl_init () 646cfperl_init ()
630{ 647{
648 PERL_SYS_INIT3 (&settings.argc, &settings.argv, 0);
649 perl = perl_alloc ();
650 perl_construct (perl);
651
652 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
653
631 char *argv[] = { 654 char *argv[] = {
632 "", 655 "",
633 "-e" 656 "-e"
634 "BEGIN {"
635 " cf->bootstrap;" 657 "cf->bootstrap;"
636 " unshift @INC, cf::datadir ();" 658 "unshift @INC, cf::datadir ();"
637 "}"
638 ""
639 "use cf;"
640 }; 659 };
641
642 perl = perl_alloc ();
643 perl_construct (perl);
644
645 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
646 660
647 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl)) 661 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl))
648 { 662 {
649 printf ("unable to initialize perl-interpreter, aborting.\n"); 663 printf ("unable to initialize perl-interpreter, aborting.\n");
650
651 exit (EXIT_FAILURE); 664 exit (EXIT_FAILURE);
652 //perl_destruct (perl);
653 //perl_free (perl);
654 //perl = 0;
655 //return;
656 } 665 }
657 666
658 obj_cache = newHV (); 667 obj_cache = newHV ();
668}
669
670void cfperl_boot ()
671{
672 perl_booted = true;
673
674 eval_pv ("require cf", 1);
659} 675}
660 676
661void cfperl_main () 677void cfperl_main ()
662{ 678{
663 dSP; 679 dSP;
… …
735 dt = (data_type) va_arg (ap, int); 751 dt = (data_type) va_arg (ap, int);
736 assert (("first argument must be of type object", dt == DT_OBJECT)); 752 assert (("first argument must be of type object", dt == DT_OBJECT));
737 op = va_arg (ap, object *); 753 op = va_arg (ap, object *);
738 754
739 if (op->cb) 755 if (op->cb)
740 gather_callbacks (callbacks, (AV *)op->cb, event); 756 gather_callbacks (callbacks, op->cb, event);
741 757
742 if (op->type) 758 if (op->type)
743 { 759 {
744 if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type)) 760 if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type))
745 { 761 {
… …
766 dt = (data_type) va_arg (ap, int); 782 dt = (data_type) va_arg (ap, int);
767 assert (("first argument must be of type player", dt == DT_PLAYER)); 783 assert (("first argument must be of type player", dt == DT_PLAYER));
768 pl = va_arg (ap, player *); 784 pl = va_arg (ap, player *);
769 785
770 if (pl->cb) 786 if (pl->cb)
771 gather_callbacks (callbacks, (AV *)pl->cb, event); 787 gather_callbacks (callbacks, pl->cb, event);
772 788
773 gather_callbacks (callbacks, cb_player, event); 789 gather_callbacks (callbacks, cb_player, event);
774 break; 790 break;
775 791
776 case KLASS_MAP: 792 case KLASS_MAP:
777 dt = (data_type) va_arg (ap, int); 793 dt = (data_type) va_arg (ap, int);
778 assert (("first argument must be of type object", dt == DT_MAP)); 794 assert (("first argument must be of type object", dt == DT_MAP));
779 map = va_arg (ap, mapstruct *); 795 map = va_arg (ap, mapstruct *);
780 796
781 if (map->cb) 797 if (map->cb)
782 gather_callbacks (callbacks, (AV *)map->cb, event); 798 gather_callbacks (callbacks, map->cb, event);
783 799
784 gather_callbacks (callbacks, cb_map, event); 800 gather_callbacks (callbacks, cb_map, event);
785 break; 801 break;
786 802
787 default: 803 default:
… …
1407 prop (CFAPI_INT, MAP_PROP_WINDDIR) 1423 prop (CFAPI_INT, MAP_PROP_WINDDIR)
1408 prop (CFAPI_INT, MAP_PROP_SKY) 1424 prop (CFAPI_INT, MAP_PROP_SKY)
1409 prop (CFAPI_INT, MAP_PROP_WPARTX) 1425 prop (CFAPI_INT, MAP_PROP_WPARTX)
1410 prop (CFAPI_INT, MAP_PROP_WPARTY) 1426 prop (CFAPI_INT, MAP_PROP_WPARTY)
1411 prop (CFAPI_STRING, MAP_PROP_MESSAGE) 1427 prop (CFAPI_STRING, MAP_PROP_MESSAGE)
1412 prop (CFAPI_PMAP, MAP_PROP_NEXT)
1413 prop (CFAPI_PREGION, MAP_PROP_REGION) 1428 prop (CFAPI_PREGION, MAP_PROP_REGION)
1414 prop (CFAPI_POBJECT, OBJECT_PROP_NEXT_ACTIVE_OB) 1429 prop (CFAPI_POBJECT, OBJECT_PROP_NEXT_ACTIVE_OB)
1415 prop (CFAPI_POBJECT, OBJECT_PROP_PREV_ACTIVE_OB) 1430 prop (CFAPI_POBJECT, OBJECT_PROP_PREV_ACTIVE_OB)
1416 prop (CFAPI_POBJECT, OBJECT_PROP_INVENTORY) 1431 prop (CFAPI_POBJECT, OBJECT_PROP_INVENTORY)
1417 prop (CFAPI_POBJECT, OBJECT_PROP_ENVIRONMENT) 1432 prop (CFAPI_POBJECT, OBJECT_PROP_ENVIRONMENT)
… …
1829 1844
1830void cf_object_drop (object *op, object *author) 1845void cf_object_drop (object *op, object *author)
1831 1846
1832void cf_object_take (object *op, object *author) 1847void cf_object_take (object *op, object *author)
1833 1848
1834void cf_object_say (object *op, char *msg)
1835
1836void cf_object_speak (object *op, char *msg)
1837
1838object *cf_object_insert_object (object *op, object *container) 1849object *cf_object_insert_object (object *op, object *container)
1839 1850
1840const char *cf_object_get_msg (object *ob) 1851const char *cf_object_get_msg (object *ob)
1841 ALIAS: msg = 0 1852 ALIAS: msg = 0
1842 1853
… …
2118 OUTPUT: RETVAL 2129 OUTPUT: RETVAL
2119 2130
2120 2131
2121MODULE = cf PACKAGE = cf::map PREFIX = cf_map_ 2132MODULE = cf PACKAGE = cf::map PREFIX = cf_map_
2122 2133
2123void 2134mapstruct *first ()
2124trigger (mapstruct *map, long connection, bool state = true) 2135 PROTOTYPE:
2125 CODE:
2126 activate_connection (map, connection, state);
2127
2128void
2129get_connection (mapstruct *map, long connection)
2130 PPCODE: 2136 CODE:
2131{ 2137 RETVAL = first_map;
2132 oblinkpt *obp = get_connection_links (map, connection); 2138 OUTPUT: RETVAL
2133 if (obp) 2139
2134 for (objectlink *ol = obp->link; ol; ol = ol->next) 2140mapstruct *next (mapstruct *map)
2135 XPUSHs (sv_2mortal (newSVcfapi (CFAPI_POBJECT, ol->ob))); 2141 PROTOTYPE:
2136} 2142 CODE:
2143 RETVAL = map->next;
2144 OUTPUT: RETVAL
2137 2145
2138int invoke (mapstruct *map, int event, ...) 2146int invoke (mapstruct *map, int event, ...)
2139 CODE: 2147 CODE:
2140 if (KLASS_OF (event) != KLASS_MAP) croak ("event class must be MAP"); 2148 if (KLASS_OF (event) != KLASS_MAP) croak ("event class must be MAP");
2141 AV *av = (AV *)sv_2mortal ((SV *)newAV ()); 2149 AV *av = (AV *)sv_2mortal ((SV *)newAV ());
… …
2169 2177
2170mapstruct *new (int width, int height) 2178mapstruct *new (int width, int height)
2171 PROTOTYPE: 2179 PROTOTYPE:
2172 CODE: 2180 CODE:
2173{ 2181{
2174 int unused_type; 2182 RETVAL = get_empty_map (width, height);
2175 RETVAL = (mapstruct*) map_get_map (&unused_type, 0, width, height);
2176} 2183}
2177 OUTPUT: 2184 OUTPUT:
2178 RETVAL 2185 RETVAL
2179 2186
2180void delete_map (mapstruct *map) 2187void delete_map (mapstruct *map)
… …
2195 XSRETURN_UNDEF; 2202 XSRETURN_UNDEF;
2196 RETVAL = map->tile_path [dir]; 2203 RETVAL = map->tile_path [dir];
2197 OUTPUT: 2204 OUTPUT:
2198 RETVAL 2205 RETVAL
2199 2206
2200mapstruct *cf_map_get_map (char *name) 2207mapstruct *ready_map_name (char *name, int flags = 0)
2201 PROTOTYPE: $ 2208 PROTOTYPE: $;$
2202 ALIAS: map = 0 2209 ALIAS:
2210 find = 0
2211 get_map = 1
2203 2212
2204mapstruct *has_been_loaded (char *name) 2213mapstruct *has_been_loaded (char *name)
2205 PROTOTYPE: $ 2214 PROTOTYPE: $
2206
2207mapstruct *cf_map_get_first ()
2208 PROTOTYPE:
2209 ALIAS: first = 0
2210 2215
2211# whoever "designed" the plug-in api should have wasted 2216# whoever "designed" the plug-in api should have wasted
2212# his/her time with staying away from the project - would have 2217# his/her time with staying away from the project - would have
2213# saved others a lot of time, without doubt. 2218# saved others a lot of time, without doubt.
2214void set_path (mapstruct *where, char *path) 2219void set_path (mapstruct *where, char *path)
… …
2228 RETVAL 2233 RETVAL
2229 2234
2230void set_unique (mapstruct *map, bool unique) 2235void set_unique (mapstruct *map, bool unique)
2231 CODE: 2236 CODE:
2232 map->unique = unique; 2237 map->unique = unique;
2238
2239void
2240trigger (mapstruct *map, long connection, bool state = true)
2241 CODE:
2242 activate_connection (map, connection, state);
2243
2244void
2245get_connection (mapstruct *map, long connection)
2246 PPCODE:
2247 oblinkpt *obp = get_connection_links (map, connection);
2248 if (obp)
2249 for (objectlink *ol = obp->link; ol; ol = ol->next)
2250 XPUSHs (sv_2mortal (newSVcfapi (CFAPI_POBJECT, ol->ob)));
2233 2251
2234object *cf_map_insert_object_there (mapstruct *where, object *op, object *originator, int flags) 2252object *cf_map_insert_object_there (mapstruct *where, object *op, object *originator, int flags)
2235 2253
2236object *cf_map_insert_object (mapstruct *where, object* op, int x, int y) 2254object *cf_map_insert_object (mapstruct *where, object* op, int x, int y)
2237 2255
… …
2298 case 6: RETVAL = newSVuv ( GET_MAP_MOVE_ON (obj, x, y)); break; 2316 case 6: RETVAL = newSVuv ( GET_MAP_MOVE_ON (obj, x, y)); break;
2299 case 7: RETVAL = newSVuv ( GET_MAP_MOVE_OFF (obj, x, y)); break; 2317 case 7: RETVAL = newSVuv ( GET_MAP_MOVE_OFF (obj, x, y)); break;
2300 } 2318 }
2301 OUTPUT: 2319 OUTPUT:
2302 RETVAL 2320 RETVAL
2303
2304# "deserialise" perl map data into the map # TODO# compatibility cruft, remove
2305void
2306_set_obs (mapstruct *map, SV *sv)
2307 CODE:
2308{
2309 object *o;
2310 AV *av;
2311 int x, y;
2312 AV *obs = (AV *)SvRV (sv);
2313
2314 for (y = 0; y < MAP_HEIGHT (map); y++)
2315 for (x = 0; x < MAP_WIDTH (map); x++)
2316 {
2317 sv = *av_fetch (obs, x + y * MAP_HEIGHT (map), 1);
2318
2319 if (!SvROK (sv))
2320 continue;
2321
2322 av = (AV *)SvRV (sv);
2323
2324 for (o = GET_MAP_OB (map, x, y); o; o = o->above)
2325 {
2326 sv = av_shift (av);
2327
2328 if (SvROK (sv))
2329 {
2330 sv_magic ((SV *)SvRV (sv), 0, PERL_MAGIC_ext, (char *)o, 0);
2331 SVptr_cache_set (o, sv);
2332 }
2333 }
2334 }
2335}
2336 2321
2337 2322
2338MODULE = cf PACKAGE = cf::arch 2323MODULE = cf PACKAGE = cf::arch
2339 2324
2340archetype *first() 2325archetype *first()

Diff Legend

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