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.34 by root, Thu Aug 31 06:23:20 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
35#ifndef __CEXTRACT__
36#include <plugin.h>
37#endif
38
39#undef MODULEAPI
40#ifdef WIN32
41#else
42#define MODULEAPI
43#endif
44 28
45#include <plugin_common.h> 29#include <plugin_common.h>
46#include <sounds.h> 30#include <sounds.h>
47#include <cstdarg> 31#include <cstdarg>
48#include <sproto.h> 32#include <sproto.h>
49 33
50#include "cfperl.h" 34#include "cfperl.h"
51#include "shstr.h" 35#include "shstr.h"
52 36
37#include <EXTERN.h>
38#include <perl.h>
39#include <XSUB.h>
40
53#include "perlxsi.c" 41#include "perlxsi.c"
54 42
55extern sint64 *levels; // the experience table 43extern sint64 *levels; // the experience table
56 44
57typedef object object_ornull; 45typedef object object_ornull;
… …
61#define newSVval64 newSVnv 49#define newSVval64 newSVnv
62#define SvVAL64 SvNV 50#define SvVAL64 SvNV
63 51
64static f_plug_api gethook = cfapi_get_hooks; 52static f_plug_api gethook = cfapi_get_hooks;
65static f_plug_api object_set_property = cfapi_object_set_property; 53static 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; 54static f_plug_api object_insert = cfapi_object_insert;
55
56static bool perl_booted;
68 57
69/* this is a stupid way to do things, and awkward to use for plug-in authors */ 58/* this is a stupid way to do things, and awkward to use for plug-in authors */
70typedef struct 59typedef struct
71{ 60{
72 object* who; 61 object* who;
… …
117 return &PL_sv_undef; 106 return &PL_sv_undef;
118 107
119 if (!obj->self) 108 if (!obj->self)
120 obj->self = newSVptr (obj, klass); 109 obj->self = newSVptr (obj, klass);
121 110
122 return newSVsv (static_cast<SV *>(obj->self)); 111 return newSVsv (obj->self);
123} 112}
124 113
125static void 114static void
126SVptr_cache_set (void *ptr, SV *sv) 115SVptr_cache_set (void *ptr, SV *sv)
127{ 116{
… …
316void attachable_base::clear () 305void attachable_base::clear ()
317{ 306{
318 if (self) 307 if (self)
319 { 308 {
320 if (cb) 309 if (cb)
321 if (SvROK (*av_fetch ((AV *)cb, EVENT_OBJECT_DESTROY, 1))) 310 if (SvROK (*av_fetch (cb, EVENT_OBJECT_DESTROY, 1)))
322 INVOKE_OBJECT (DESTROY, static_cast<object *>(this)); 311 INVOKE_OBJECT (DESTROY, static_cast<object *>(this));
323 else if (SvROK (*av_fetch ((AV *)cb, EVENT_MAP_DESTROY, 1))) 312 else if (SvROK (*av_fetch (cb, EVENT_MAP_DESTROY, 1)))
324 INVOKE_MAP (DESTROY, static_cast<mapstruct *>(this)); 313 INVOKE_MAP (DESTROY, static_cast<mapstruct *>(this));
325 314
326 // disconnect Perl from C, to avoid crashes 315 // disconnect Perl from C, to avoid crashes
327 sv_unmagic (SvRV ((SV *)self), PERL_MAGIC_ext); 316 sv_unmagic (SvRV ((SV *)self), PERL_MAGIC_ext);
328 317
… …
418 407
419 if (obj->self) 408 if (obj->self)
420 reattach (subclass::get_dt (), (subclass *)obj); 409 reattach (subclass::get_dt (), (subclass *)obj);
421} 410}
422 411
423object_freezer::object_freezer (const char *filename) 412object_freezer::object_freezer ()
424{ 413{
425 this->filename = (SV *)newSVpv (filename, 0);
426
427 char filename2 [4096];
428 snprintf (filename2, 4096, "%s~", filename);
429
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 (); 414 av = newAV ();
415 // TODO: fast dynbuf implementation... yeah, we need obstacks
416 text = newSV (10 * 1024 * 1024); // only temporarily used, so be generous
436} 417}
437 418
438object_freezer::~object_freezer () 419object_freezer::~object_freezer ()
439{ 420{
440 if (fp) 421 SvREFCNT_dec (text);
441 { 422 SvREFCNT_dec (av);
442 fclose (fp);
443
444 dSP;
445 ENTER;
446 SAVETMPS;
447 PUSHMARK (SP);
448 XPUSHs (sv_2mortal ((SV *)filename));
449 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av)));
450 PUTBACK;
451 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL);
452 FREETMPS;
453 LEAVE;
454 }
455 else
456 SvREFCNT_dec ((SV *)filename);
457} 423}
458 424
459void object_freezer::put (attachable_base *ext) 425void object_freezer::put (attachable_base *ext)
460{ 426{
461 ext->optimise (); 427 ext->optimise ();
462 428
463 if (ext->self) 429 if (ext->self)
464 { 430 {
465 int idx = AvFILLp ((AV *)av) + 1; 431 int idx = AvFILLp ((AV *)av) + 1;
466 av_store ((AV *)av, idx, SvREFCNT_inc ((SV *)ext->self)); 432 av_store (av, idx, SvREFCNT_inc (ext->self));
467 fprintf (fp, "oid %d\n", idx); 433
434 sv_catpvf (text, "oid %d\n", idx);
468 } 435 }
436}
437
438bool object_freezer::save (const char *filename)
439{
440 dSP;
441 ENTER;
442 SAVETMPS;
443 PUSHMARK (SP);
444 EXTEND (SP, 3);
445 PUSHs (sv_2mortal (newSVpv (filename, 0)));
446 PUSHs (sv_2mortal (newRV_inc (text)));
447 PUSHs (sv_2mortal (newRV_inc ((SV *)av)));
448 PUTBACK;
449 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL);
450 FREETMPS;
451 LEAVE;
452}
453
454int fprintf (object_freezer &freezer, const char *format, ...)
455{
456 va_list ap;
457
458 va_start (ap, format);
459 sv_vcatpvfn (freezer.text, format, strlen (format), &ap, 0, 0, 0);
460 va_end (ap);
461}
462
463int fputs (const char *s, object_freezer &freezer)
464{
465 sv_catpvn (freezer.text, s, strlen (s));
469} 466}
470 467
471object_thawer::object_thawer (const char *filename) 468object_thawer::object_thawer (const char *filename)
472{ 469{
473 av = 0; 470 av = 0;
… …
481 { 478 {
482 LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno)); 479 LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno));
483 return; 480 return;
484 } 481 }
485 482
486 if (perl) 483 if (perl_booted)
487 { 484 {
488 dSP; 485 dSP;
489 ENTER; 486 ENTER;
490 SAVETMPS; 487 SAVETMPS;
491 PUSHMARK (SP); 488 PUSHMARK (SP);
… …
495 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL)) 492 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL))
496 { 493 {
497 SPAGAIN; 494 SPAGAIN;
498 SV *sv = POPs; 495 SV *sv = POPs;
499 if (SvROK (sv)) 496 if (SvROK (sv))
500 av = SvREFCNT_inc (SvRV (sv)); 497 av = (AV *)SvREFCNT_inc (SvRV (sv));
501 } 498 }
502 499
503 FREETMPS; 500 FREETMPS;
504 LEAVE; 501 LEAVE;
505 } 502 }
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} 503}
522 504
523void object_thawer::get (data_type type, void *obj, attachable_base *ext, int oid) 505void object_thawer::get (data_type type, void *obj, attachable_base *ext, int oid)
524{ 506{
525 if (!av || oid < 0) // this is actually an error of sorts 507 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); 517 printf ("trying to thaw duplicate or never-issued oid %d, ignoring.\n", oid);
536 return; 518 return;
537 } 519 }
538 520
539 ext->self = *svp; *svp = &PL_sv_undef; 521 ext->self = *svp; *svp = &PL_sv_undef;
540 sv_magic (SvRV ((SV *)ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0); 522 sv_magic (SvRV (ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0);
541 523
542 reattach (type, obj); 524 reattach (type, obj);
543} 525}
544 526
545object_thawer::~object_thawer () 527object_thawer::~object_thawer ()
546{ 528{
547 if (fp) fclose (fp); 529 if (fp) fclose (fp);
548 if (av) SvREFCNT_dec ((AV *)av); 530 if (av) SvREFCNT_dec ((AV *)av);
549} 531}
550 532
533token object_thawer::get_token ()
534{
535#if 0
536 for (;;)
537 {
538 if (!fgets (line, sizeof (line), fp))
539 return token (KW_eof);
540
541 unsigned char *p = (unsigned char *)line;
542
543 while (*p > ' ')
544 p++;
545
546 int len = p - (unsigned char *)line;
547
548 while ((*p - 1) < ' ')
549 p++;
550
551 if (*p)
552 {
553 char *v = p;
554
555 while (*p && *p != '\n')
556 p++;
557
558 *p = 0;
559
560 return token (k, v);
561 }
562 else
563 return token (k);
564 }
565#endif
566}
567
551///////////////////////////////////////////////////////////////////////////// 568/////////////////////////////////////////////////////////////////////////////
552 569
553extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr) 570extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr)
554{ 571{
555 return 0; 572 return 0;
… …
652} 669}
653 670
654void 671void
655cfperl_init () 672cfperl_init ()
656{ 673{
674 PERL_SYS_INIT3 (&settings.argc, &settings.argv, 0);
675 perl = perl_alloc ();
676 perl_construct (perl);
677
678 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
679
657 char *argv[] = { 680 char *argv[] = {
658 "", 681 "",
659 "-e" 682 "-e"
660 "BEGIN {"
661 " cf->bootstrap;" 683 "cf->bootstrap;"
662 " unshift @INC, cf::datadir ();" 684 "unshift @INC, cf::datadir ();"
663 "}"
664 ""
665 "use cf;"
666 }; 685 };
667
668 perl = perl_alloc ();
669 perl_construct (perl);
670
671 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
672 686
673 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl)) 687 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl))
674 { 688 {
675 printf ("unable to initialize perl-interpreter, aborting.\n"); 689 printf ("unable to initialize perl-interpreter, aborting.\n");
676
677 exit (EXIT_FAILURE); 690 exit (EXIT_FAILURE);
678 //perl_destruct (perl);
679 //perl_free (perl);
680 //perl = 0;
681 //return;
682 } 691 }
683 692
684 obj_cache = newHV (); 693 obj_cache = newHV ();
694}
695
696void cfperl_boot ()
697{
698 perl_booted = true;
699
700 eval_pv ("require cf", 1);
685} 701}
686 702
687void cfperl_main () 703void cfperl_main ()
688{ 704{
689 dSP; 705 dSP;
… …
761 dt = (data_type) va_arg (ap, int); 777 dt = (data_type) va_arg (ap, int);
762 assert (("first argument must be of type object", dt == DT_OBJECT)); 778 assert (("first argument must be of type object", dt == DT_OBJECT));
763 op = va_arg (ap, object *); 779 op = va_arg (ap, object *);
764 780
765 if (op->cb) 781 if (op->cb)
766 gather_callbacks (callbacks, (AV *)op->cb, event); 782 gather_callbacks (callbacks, op->cb, event);
767 783
768 if (op->type) 784 if (op->type)
769 { 785 {
770 if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type)) 786 if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type))
771 { 787 {
… …
792 dt = (data_type) va_arg (ap, int); 808 dt = (data_type) va_arg (ap, int);
793 assert (("first argument must be of type player", dt == DT_PLAYER)); 809 assert (("first argument must be of type player", dt == DT_PLAYER));
794 pl = va_arg (ap, player *); 810 pl = va_arg (ap, player *);
795 811
796 if (pl->cb) 812 if (pl->cb)
797 gather_callbacks (callbacks, (AV *)pl->cb, event); 813 gather_callbacks (callbacks, pl->cb, event);
798 814
799 gather_callbacks (callbacks, cb_player, event); 815 gather_callbacks (callbacks, cb_player, event);
800 break; 816 break;
801 817
802 case KLASS_MAP: 818 case KLASS_MAP:
803 dt = (data_type) va_arg (ap, int); 819 dt = (data_type) va_arg (ap, int);
804 assert (("first argument must be of type object", dt == DT_MAP)); 820 assert (("first argument must be of type object", dt == DT_MAP));
805 map = va_arg (ap, mapstruct *); 821 map = va_arg (ap, mapstruct *);
806 822
807 if (map->cb) 823 if (map->cb)
808 gather_callbacks (callbacks, (AV *)map->cb, event); 824 gather_callbacks (callbacks, map->cb, event);
809 825
810 gather_callbacks (callbacks, cb_map, event); 826 gather_callbacks (callbacks, cb_map, event);
811 break; 827 break;
812 828
813 default: 829 default:
… …
1854 1870
1855void cf_object_drop (object *op, object *author) 1871void cf_object_drop (object *op, object *author)
1856 1872
1857void cf_object_take (object *op, object *author) 1873void cf_object_take (object *op, object *author)
1858 1874
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) 1875object *cf_object_insert_object (object *op, object *container)
1864 1876
1865const char *cf_object_get_msg (object *ob) 1877const char *cf_object_get_msg (object *ob)
1866 ALIAS: msg = 0 1878 ALIAS: msg = 0
1867 1879

Diff Legend

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