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.29 by root, Wed Aug 30 08:28:33 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
430 fp = fopen (filename2, "w");
431
432 if (!fp)
433 LOG (llevError, "cannot open file '%s' for writing: %s\n", filename2, strerror (errno));
434
435 av = (AV *)newAV (); 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
436} 433}
437 434
438object_freezer::~object_freezer () 435object_freezer::~object_freezer ()
439{ 436{
440 if (fp)
441 {
442 fclose (fp);
443
444 dSP; 437 dSP;
445 ENTER; 438 ENTER;
446 SAVETMPS; 439 SAVETMPS;
447 PUSHMARK (SP); 440 PUSHMARK (SP);
448 XPUSHs (sv_2mortal ((SV *)filename)); 441 XPUSHs (sv_2mortal ((SV *)filename));
442 XPUSHs (sv_2mortal (newRV_noinc (text)));
449 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av))); 443 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
450 PUTBACK; 444 PUTBACK;
451 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL); 445 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL);
452 FREETMPS; 446 FREETMPS;
453 LEAVE; 447 LEAVE;
454 }
455 else
456 SvREFCNT_dec ((SV *)filename);
457} 448}
458 449
459void object_freezer::put (attachable_base *ext) 450void object_freezer::put (attachable_base *ext)
460{ 451{
461 ext->optimise (); 452 ext->optimise ();
462 453
463 if (ext->self) 454 if (ext->self)
464 { 455 {
465 int idx = AvFILLp ((AV *)av) + 1; 456 int idx = AvFILLp ((AV *)av) + 1;
466 av_store ((AV *)av, idx, SvREFCNT_inc ((SV *)ext->self)); 457 av_store (av, idx, SvREFCNT_inc (ext->self));
467 fprintf (fp, "oid %d\n", idx); 458
459 sv_catpvf (text, "oid %d\n", idx);
468 } 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));
469} 475}
470 476
471object_thawer::object_thawer (const char *filename) 477object_thawer::object_thawer (const char *filename)
472{ 478{
473 av = 0; 479 av = 0;
… …
481 { 487 {
482 LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno)); 488 LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno));
483 return; 489 return;
484 } 490 }
485 491
486 if (perl) 492 if (perl_booted)
487 { 493 {
488 dSP; 494 dSP;
489 ENTER; 495 ENTER;
490 SAVETMPS; 496 SAVETMPS;
491 PUSHMARK (SP); 497 PUSHMARK (SP);
… …
495 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL)) 501 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL))
496 { 502 {
497 SPAGAIN; 503 SPAGAIN;
498 SV *sv = POPs; 504 SV *sv = POPs;
499 if (SvROK (sv)) 505 if (SvROK (sv))
500 av = SvREFCNT_inc (SvRV (sv)); 506 av = (AV *)SvREFCNT_inc (SvRV (sv));
501 } 507 }
502 508
503 FREETMPS; 509 FREETMPS;
504 LEAVE; 510 LEAVE;
505 } 511 }
… …
520 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);
521 return; 527 return;
522 } 528 }
523 529
524 ext->self = *svp; *svp = &PL_sv_undef; 530 ext->self = *svp; *svp = &PL_sv_undef;
525 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);
526 532
527 reattach (type, obj); 533 reattach (type, obj);
528} 534}
529 535
530object_thawer::~object_thawer () 536object_thawer::~object_thawer ()
… …
637} 643}
638 644
639void 645void
640cfperl_init () 646cfperl_init ()
641{ 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
642 char *argv[] = { 654 char *argv[] = {
643 "", 655 "",
644 "-e" 656 "-e"
645 "BEGIN {"
646 " cf->bootstrap;" 657 "cf->bootstrap;"
647 " unshift @INC, cf::datadir ();" 658 "unshift @INC, cf::datadir ();"
648 "}"
649 ""
650 "use cf;"
651 }; 659 };
652
653 perl = perl_alloc ();
654 perl_construct (perl);
655
656 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
657 660
658 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))
659 { 662 {
660 printf ("unable to initialize perl-interpreter, aborting.\n"); 663 printf ("unable to initialize perl-interpreter, aborting.\n");
661
662 exit (EXIT_FAILURE); 664 exit (EXIT_FAILURE);
663 //perl_destruct (perl);
664 //perl_free (perl);
665 //perl = 0;
666 //return;
667 } 665 }
668 666
669 obj_cache = newHV (); 667 obj_cache = newHV ();
668}
669
670void cfperl_boot ()
671{
672 perl_booted = true;
673
674 eval_pv ("require cf", 1);
670} 675}
671 676
672void cfperl_main () 677void cfperl_main ()
673{ 678{
674 dSP; 679 dSP;
… …
746 dt = (data_type) va_arg (ap, int); 751 dt = (data_type) va_arg (ap, int);
747 assert (("first argument must be of type object", dt == DT_OBJECT)); 752 assert (("first argument must be of type object", dt == DT_OBJECT));
748 op = va_arg (ap, object *); 753 op = va_arg (ap, object *);
749 754
750 if (op->cb) 755 if (op->cb)
751 gather_callbacks (callbacks, (AV *)op->cb, event); 756 gather_callbacks (callbacks, op->cb, event);
752 757
753 if (op->type) 758 if (op->type)
754 { 759 {
755 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))
756 { 761 {
… …
777 dt = (data_type) va_arg (ap, int); 782 dt = (data_type) va_arg (ap, int);
778 assert (("first argument must be of type player", dt == DT_PLAYER)); 783 assert (("first argument must be of type player", dt == DT_PLAYER));
779 pl = va_arg (ap, player *); 784 pl = va_arg (ap, player *);
780 785
781 if (pl->cb) 786 if (pl->cb)
782 gather_callbacks (callbacks, (AV *)pl->cb, event); 787 gather_callbacks (callbacks, pl->cb, event);
783 788
784 gather_callbacks (callbacks, cb_player, event); 789 gather_callbacks (callbacks, cb_player, event);
785 break; 790 break;
786 791
787 case KLASS_MAP: 792 case KLASS_MAP:
788 dt = (data_type) va_arg (ap, int); 793 dt = (data_type) va_arg (ap, int);
789 assert (("first argument must be of type object", dt == DT_MAP)); 794 assert (("first argument must be of type object", dt == DT_MAP));
790 map = va_arg (ap, mapstruct *); 795 map = va_arg (ap, mapstruct *);
791 796
792 if (map->cb) 797 if (map->cb)
793 gather_callbacks (callbacks, (AV *)map->cb, event); 798 gather_callbacks (callbacks, map->cb, event);
794 799
795 gather_callbacks (callbacks, cb_map, event); 800 gather_callbacks (callbacks, cb_map, event);
796 break; 801 break;
797 802
798 default: 803 default:
… …
1839 1844
1840void cf_object_drop (object *op, object *author) 1845void cf_object_drop (object *op, object *author)
1841 1846
1842void cf_object_take (object *op, object *author) 1847void cf_object_take (object *op, object *author)
1843 1848
1844void cf_object_say (object *op, char *msg)
1845
1846void cf_object_speak (object *op, char *msg)
1847
1848object *cf_object_insert_object (object *op, object *container) 1849object *cf_object_insert_object (object *op, object *container)
1849 1850
1850const char *cf_object_get_msg (object *ob) 1851const char *cf_object_get_msg (object *ob)
1851 ALIAS: msg = 0 1852 ALIAS: msg = 0
1852 1853
… …
2315 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;
2316 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;
2317 } 2318 }
2318 OUTPUT: 2319 OUTPUT:
2319 RETVAL 2320 RETVAL
2320
2321# "deserialise" perl map data into the map # TODO# compatibility cruft, remove
2322void
2323_set_obs (mapstruct *map, SV *sv)
2324 CODE:
2325{
2326 object *o;
2327 AV *av;
2328 int x, y;
2329 AV *obs = (AV *)SvRV (sv);
2330
2331 for (y = 0; y < MAP_HEIGHT (map); y++)
2332 for (x = 0; x < MAP_WIDTH (map); x++)
2333 {
2334 sv = *av_fetch (obs, x + y * MAP_HEIGHT (map), 1);
2335
2336 if (!SvROK (sv))
2337 continue;
2338
2339 av = (AV *)SvRV (sv);
2340
2341 for (o = GET_MAP_OB (map, x, y); o; o = o->above)
2342 {
2343 sv = av_shift (av);
2344
2345 if (SvROK (sv))
2346 {
2347 sv_magic ((SV *)SvRV (sv), 0, PERL_MAGIC_ext, (char *)o, 0);
2348 SVptr_cache_set (o, sv);
2349 }
2350 }
2351 }
2352}
2353 2321
2354 2322
2355MODULE = cf PACKAGE = cf::arch 2323MODULE = cf PACKAGE = cf::arch
2356 2324
2357archetype *first() 2325archetype *first()

Diff Legend

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