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.35 by root, Thu Aug 31 09:19:34 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
… …
415void reattach (attachable<subclass> *obj) 404void reattach (attachable<subclass> *obj)
416{ 405{
417 obj->optimise (); 406 obj->optimise ();
418 407
419 if (obj->self) 408 if (obj->self)
420 reattach (subclass::get_dt (), (subclass *)obj); 409 reattach ((data_type) cftype<subclass>::dt, (subclass *)obj);
421} 410}
422 411
412#include "kw_hash.h"
413
423object_freezer::object_freezer (const char *filename) 414object_freezer::object_freezer ()
424{ 415{
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 (); 416 av = newAV ();
417 // TODO: fast dynbuf implementation... yeah, we need obstacks
418 text = newSV (10 * 1024 * 1024); // only temporarily used, so be generous
436} 419}
437 420
438object_freezer::~object_freezer () 421object_freezer::~object_freezer ()
439{ 422{
440 if (fp) 423 SvREFCNT_dec (text);
441 { 424 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} 425}
458 426
459void object_freezer::put (attachable_base *ext) 427void object_freezer::put (attachable_base *ext)
460{ 428{
461 ext->optimise (); 429 ext->optimise ();
462 430
463 if (ext->self) 431 if (ext->self)
464 { 432 {
465 int idx = AvFILLp ((AV *)av) + 1; 433 int idx = AvFILLp ((AV *)av) + 1;
466 av_store ((AV *)av, idx, SvREFCNT_inc ((SV *)ext->self)); 434 av_store (av, idx, SvREFCNT_inc (ext->self));
467 fprintf (fp, "oid %d\n", idx); 435
436 sv_catpvf (text, "oid %d\n", idx);
468 } 437 }
438}
439
440void object_freezer::put (keyword k)
441{
442 sv_catpv (text, keyword_str [k]);
443}
444
445void object_freezer::put (const char *v)
446{
447 sv_catpv (text, v);
448}
449
450void object_freezer::put (int v)
451{
452 sv_catpvf (text, "%d\n", v);
453}
454
455bool object_freezer::save (const char *filename)
456{
457 dSP;
458 ENTER;
459 SAVETMPS;
460 PUSHMARK (SP);
461 EXTEND (SP, 3);
462 PUSHs (sv_2mortal (newSVpv (filename, 0)));
463 PUSHs (sv_2mortal (newRV_inc (text)));
464 PUSHs (sv_2mortal (newRV_inc ((SV *)av)));
465 PUTBACK;
466 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL);
467 FREETMPS;
468 LEAVE;
469}
470
471int fprintf (object_freezer &freezer, const char *format, ...)
472{
473 va_list ap;
474
475 va_start (ap, format);
476 sv_vcatpvfn (freezer.text, format, strlen (format), &ap, 0, 0, 0);
477 va_end (ap);
478}
479
480int fputs (const char *s, object_freezer &freezer)
481{
482 sv_catpvn (freezer.text, s, strlen (s));
469} 483}
470 484
471object_thawer::object_thawer (const char *filename) 485object_thawer::object_thawer (const char *filename)
472{ 486{
473 av = 0; 487 av = 0;
… …
481 { 495 {
482 LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno)); 496 LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno));
483 return; 497 return;
484 } 498 }
485 499
486 if (perl) 500 if (perl_booted)
487 { 501 {
488 dSP; 502 dSP;
489 ENTER; 503 ENTER;
490 SAVETMPS; 504 SAVETMPS;
491 PUSHMARK (SP); 505 PUSHMARK (SP);
… …
495 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL)) 509 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL))
496 { 510 {
497 SPAGAIN; 511 SPAGAIN;
498 SV *sv = POPs; 512 SV *sv = POPs;
499 if (SvROK (sv)) 513 if (SvROK (sv))
500 av = SvREFCNT_inc (SvRV (sv)); 514 av = (AV *)SvREFCNT_inc (SvRV (sv));
501 } 515 }
502 516
503 FREETMPS; 517 FREETMPS;
504 LEAVE; 518 LEAVE;
505 } 519 }
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} 520}
522 521
523void object_thawer::get (data_type type, void *obj, attachable_base *ext, int oid) 522void object_thawer::get (data_type type, void *obj, attachable_base *ext, int oid)
524{ 523{
525 if (!av || oid < 0) // this is actually an error of sorts 524 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); 534 printf ("trying to thaw duplicate or never-issued oid %d, ignoring.\n", oid);
536 return; 535 return;
537 } 536 }
538 537
539 ext->self = *svp; *svp = &PL_sv_undef; 538 ext->self = *svp; *svp = &PL_sv_undef;
540 sv_magic (SvRV ((SV *)ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0); 539 sv_magic (SvRV (ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0);
541 540
542 reattach (type, obj); 541 reattach (type, obj);
543} 542}
544 543
545object_thawer::~object_thawer () 544object_thawer::~object_thawer ()
546{ 545{
547 if (fp) fclose (fp); 546 if (fp) fclose (fp);
548 if (av) SvREFCNT_dec ((AV *)av); 547 if (av) SvREFCNT_dec ((AV *)av);
549} 548}
550 549
550token object_thawer::get_token ()
551{
552#if 0
553 for (;;)
554 {
555 if (!fgets (line, sizeof (line), fp))
556 return token (KW_eof);
557
558 unsigned char *p = (unsigned char *)line;
559
560 while (*p > ' ')
561 p++;
562
563 int len = p - (unsigned char *)line;
564
565 while ((*p - 1) < ' ')
566 p++;
567
568 if (*p)
569 {
570 char *v = p;
571
572 while (*p && *p != '\n')
573 p++;
574
575 *p = 0;
576
577 return token (k, v);
578 }
579 else
580 return token (k);
581 }
582#endif
583}
584
551///////////////////////////////////////////////////////////////////////////// 585/////////////////////////////////////////////////////////////////////////////
552 586
553extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr) 587extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr)
554{ 588{
555 return 0; 589 return 0;
… …
652} 686}
653 687
654void 688void
655cfperl_init () 689cfperl_init ()
656{ 690{
691 PERL_SYS_INIT3 (&settings.argc, &settings.argv, 0);
692 perl = perl_alloc ();
693 perl_construct (perl);
694
695 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
696
657 char *argv[] = { 697 char *argv[] = {
658 "", 698 "",
659 "-e" 699 "-e"
660 "BEGIN {"
661 " cf->bootstrap;" 700 "cf->bootstrap;"
662 " unshift @INC, cf::datadir ();" 701 "unshift @INC, cf::datadir ();"
663 "}"
664 ""
665 "use cf;"
666 }; 702 };
667
668 perl = perl_alloc ();
669 perl_construct (perl);
670
671 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
672 703
673 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl)) 704 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl))
674 { 705 {
675 printf ("unable to initialize perl-interpreter, aborting.\n"); 706 printf ("unable to initialize perl-interpreter, aborting.\n");
676
677 exit (EXIT_FAILURE); 707 exit (EXIT_FAILURE);
678 //perl_destruct (perl);
679 //perl_free (perl);
680 //perl = 0;
681 //return;
682 } 708 }
683 709
684 obj_cache = newHV (); 710 obj_cache = newHV ();
711}
712
713void cfperl_boot ()
714{
715 perl_booted = true;
716
717 eval_pv ("require cf", 1);
685} 718}
686 719
687void cfperl_main () 720void cfperl_main ()
688{ 721{
689 dSP; 722 dSP;
… …
761 dt = (data_type) va_arg (ap, int); 794 dt = (data_type) va_arg (ap, int);
762 assert (("first argument must be of type object", dt == DT_OBJECT)); 795 assert (("first argument must be of type object", dt == DT_OBJECT));
763 op = va_arg (ap, object *); 796 op = va_arg (ap, object *);
764 797
765 if (op->cb) 798 if (op->cb)
766 gather_callbacks (callbacks, (AV *)op->cb, event); 799 gather_callbacks (callbacks, op->cb, event);
767 800
768 if (op->type) 801 if (op->type)
769 { 802 {
770 if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type)) 803 if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type))
771 { 804 {
… …
792 dt = (data_type) va_arg (ap, int); 825 dt = (data_type) va_arg (ap, int);
793 assert (("first argument must be of type player", dt == DT_PLAYER)); 826 assert (("first argument must be of type player", dt == DT_PLAYER));
794 pl = va_arg (ap, player *); 827 pl = va_arg (ap, player *);
795 828
796 if (pl->cb) 829 if (pl->cb)
797 gather_callbacks (callbacks, (AV *)pl->cb, event); 830 gather_callbacks (callbacks, pl->cb, event);
798 831
799 gather_callbacks (callbacks, cb_player, event); 832 gather_callbacks (callbacks, cb_player, event);
800 break; 833 break;
801 834
802 case KLASS_MAP: 835 case KLASS_MAP:
803 dt = (data_type) va_arg (ap, int); 836 dt = (data_type) va_arg (ap, int);
804 assert (("first argument must be of type object", dt == DT_MAP)); 837 assert (("first argument must be of type object", dt == DT_MAP));
805 map = va_arg (ap, mapstruct *); 838 map = va_arg (ap, mapstruct *);
806 839
807 if (map->cb) 840 if (map->cb)
808 gather_callbacks (callbacks, (AV *)map->cb, event); 841 gather_callbacks (callbacks, map->cb, event);
809 842
810 gather_callbacks (callbacks, cb_map, event); 843 gather_callbacks (callbacks, cb_map, event);
811 break; 844 break;
812 845
813 default: 846 default:
… …
1854 1887
1855void cf_object_drop (object *op, object *author) 1888void cf_object_drop (object *op, object *author)
1856 1889
1857void cf_object_take (object *op, object *author) 1890void cf_object_take (object *op, object *author)
1858 1891
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) 1892object *cf_object_insert_object (object *op, object *container)
1864 1893
1865const char *cf_object_get_msg (object *ob) 1894const char *cf_object_get_msg (object *ob)
1866 ALIAS: msg = 0 1895 ALIAS: msg = 0
1867 1896

Diff Legend

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