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.31 by root, Wed Aug 30 12:08:15 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 }
506}
507
508// compatibility support, should be removed when no longer needed
509int fprintf (object_freezer &freezer, const char *format, ...)
510{
511 va_list ap;
512
513 va_start (ap, format);
514 vfprintf (freezer.fp, format, ap);
515 va_end (ap);
516}
517
518int fputs (const char *s, object_freezer &freezer)
519{
520 fputs (s, freezer.fp);
521} 512}
522 513
523void 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)
524{ 515{
525 if (!av || oid < 0) // this is actually an error of sorts 516 if (!av || oid < 0) // this is actually an error of sorts
… …
535 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);
536 return; 527 return;
537 } 528 }
538 529
539 ext->self = *svp; *svp = &PL_sv_undef; 530 ext->self = *svp; *svp = &PL_sv_undef;
540 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);
541 532
542 reattach (type, obj); 533 reattach (type, obj);
543} 534}
544 535
545object_thawer::~object_thawer () 536object_thawer::~object_thawer ()
… …
652} 643}
653 644
654void 645void
655cfperl_init () 646cfperl_init ()
656{ 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
657 char *argv[] = { 654 char *argv[] = {
658 "", 655 "",
659 "-e" 656 "-e"
660 "BEGIN {"
661 " cf->bootstrap;" 657 "cf->bootstrap;"
662 " unshift @INC, cf::datadir ();" 658 "unshift @INC, cf::datadir ();"
663 "}"
664 ""
665 "use cf;"
666 }; 659 };
667
668 perl = perl_alloc ();
669 perl_construct (perl);
670
671 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
672 660
673 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))
674 { 662 {
675 printf ("unable to initialize perl-interpreter, aborting.\n"); 663 printf ("unable to initialize perl-interpreter, aborting.\n");
676
677 exit (EXIT_FAILURE); 664 exit (EXIT_FAILURE);
678 //perl_destruct (perl);
679 //perl_free (perl);
680 //perl = 0;
681 //return;
682 } 665 }
683 666
684 obj_cache = newHV (); 667 obj_cache = newHV ();
668}
669
670void cfperl_boot ()
671{
672 perl_booted = true;
673
674 eval_pv ("require cf", 1);
685} 675}
686 676
687void cfperl_main () 677void cfperl_main ()
688{ 678{
689 dSP; 679 dSP;
… …
761 dt = (data_type) va_arg (ap, int); 751 dt = (data_type) va_arg (ap, int);
762 assert (("first argument must be of type object", dt == DT_OBJECT)); 752 assert (("first argument must be of type object", dt == DT_OBJECT));
763 op = va_arg (ap, object *); 753 op = va_arg (ap, object *);
764 754
765 if (op->cb) 755 if (op->cb)
766 gather_callbacks (callbacks, (AV *)op->cb, event); 756 gather_callbacks (callbacks, op->cb, event);
767 757
768 if (op->type) 758 if (op->type)
769 { 759 {
770 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))
771 { 761 {
… …
792 dt = (data_type) va_arg (ap, int); 782 dt = (data_type) va_arg (ap, int);
793 assert (("first argument must be of type player", dt == DT_PLAYER)); 783 assert (("first argument must be of type player", dt == DT_PLAYER));
794 pl = va_arg (ap, player *); 784 pl = va_arg (ap, player *);
795 785
796 if (pl->cb) 786 if (pl->cb)
797 gather_callbacks (callbacks, (AV *)pl->cb, event); 787 gather_callbacks (callbacks, pl->cb, event);
798 788
799 gather_callbacks (callbacks, cb_player, event); 789 gather_callbacks (callbacks, cb_player, event);
800 break; 790 break;
801 791
802 case KLASS_MAP: 792 case KLASS_MAP:
803 dt = (data_type) va_arg (ap, int); 793 dt = (data_type) va_arg (ap, int);
804 assert (("first argument must be of type object", dt == DT_MAP)); 794 assert (("first argument must be of type object", dt == DT_MAP));
805 map = va_arg (ap, mapstruct *); 795 map = va_arg (ap, mapstruct *);
806 796
807 if (map->cb) 797 if (map->cb)
808 gather_callbacks (callbacks, (AV *)map->cb, event); 798 gather_callbacks (callbacks, map->cb, event);
809 799
810 gather_callbacks (callbacks, cb_map, event); 800 gather_callbacks (callbacks, cb_map, event);
811 break; 801 break;
812 802
813 default: 803 default:
… …
1854 1844
1855void cf_object_drop (object *op, object *author) 1845void cf_object_drop (object *op, object *author)
1856 1846
1857void cf_object_take (object *op, object *author) 1847void cf_object_take (object *op, object *author)
1858 1848
1859void cf_object_say (object *op, char *msg)
1860
1861void cf_object_speak (object *op, char *msg)
1862
1863object *cf_object_insert_object (object *op, object *container) 1849object *cf_object_insert_object (object *op, object *container)
1864 1850
1865const char *cf_object_get_msg (object *ob) 1851const char *cf_object_get_msg (object *ob)
1866 ALIAS: msg = 0 1852 ALIAS: msg = 0
1867 1853

Diff Legend

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