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.38 by root, Thu Aug 31 18:59:24 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 ()
415: dynbuf (128 * 1024, 64 * 1024)
424{ 416{
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 (); 417 av = newAV ();
436} 418}
437 419
438object_freezer::~object_freezer () 420object_freezer::~object_freezer ()
439{ 421{
440 if (fp) 422 SvREFCNT_dec (av);
441 {
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 add ((void *)"oid ", 4);
435 add ((sint32)idx);
436 add ('\n');
468 } 437 }
438}
439
440bool object_freezer::save (const char *filename)
441{
442 dSP;
443 ENTER;
444 SAVETMPS;
445 PUSHMARK (SP);
446 EXTEND (SP, 3);
447 PUSHs (sv_2mortal (newSVpv (filename, 0)));
448 PUSHs (sv_2mortal (newRV_noinc (newSVpvn ((char *)linearise (), size ()))));
449 PUSHs (sv_2mortal (newRV_inc ((SV *)av)));
450 PUTBACK;
451 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL);
452 FREETMPS;
453 LEAVE;
454}
455
456int fprintf (object_freezer &freezer, const char *format, ...)
457{
458 va_list ap;
459
460 va_start (ap, format);
461
462 int len = vsnprintf ((char *)freezer.force (1024), 1024, format, ap);
463
464 if (len >= 0)
465 freezer.alloc (len);
466
467 va_end (ap);
468}
469
470int fputs (const char *s, object_freezer &freezer)
471{
472 freezer.add (s);
469} 473}
470 474
471object_thawer::object_thawer (const char *filename) 475object_thawer::object_thawer (const char *filename)
472{ 476{
473 av = 0; 477 av = 0;
… …
481 { 485 {
482 LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno)); 486 LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno));
483 return; 487 return;
484 } 488 }
485 489
486 if (perl) 490 if (perl_booted)
487 { 491 {
488 dSP; 492 dSP;
489 ENTER; 493 ENTER;
490 SAVETMPS; 494 SAVETMPS;
491 PUSHMARK (SP); 495 PUSHMARK (SP);
… …
495 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL)) 499 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL))
496 { 500 {
497 SPAGAIN; 501 SPAGAIN;
498 SV *sv = POPs; 502 SV *sv = POPs;
499 if (SvROK (sv)) 503 if (SvROK (sv))
500 av = SvREFCNT_inc (SvRV (sv)); 504 av = (AV *)SvREFCNT_inc (SvRV (sv));
501 } 505 }
502 506
503 FREETMPS; 507 FREETMPS;
504 LEAVE; 508 LEAVE;
505 } 509 }
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} 510}
522 511
523void object_thawer::get (data_type type, void *obj, attachable_base *ext, int oid) 512void object_thawer::get (data_type type, void *obj, attachable_base *ext, int oid)
524{ 513{
525 if (!av || oid < 0) // this is actually an error of sorts 514 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); 524 printf ("trying to thaw duplicate or never-issued oid %d, ignoring.\n", oid);
536 return; 525 return;
537 } 526 }
538 527
539 ext->self = *svp; *svp = &PL_sv_undef; 528 ext->self = *svp; *svp = &PL_sv_undef;
540 sv_magic (SvRV ((SV *)ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0); 529 sv_magic (SvRV (ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0);
541 530
542 reattach (type, obj); 531 reattach (type, obj);
543} 532}
544 533
545object_thawer::~object_thawer () 534object_thawer::~object_thawer ()
546{ 535{
547 if (fp) fclose (fp); 536 if (fp) fclose (fp);
548 if (av) SvREFCNT_dec ((AV *)av); 537 if (av) SvREFCNT_dec ((AV *)av);
549} 538}
550 539
540token object_thawer::get_token ()
541{
542#if 0
543 for (;;)
544 {
545 if (!fgets (line, sizeof (line), fp))
546 return token (KW_eof);
547
548 unsigned char *p = (unsigned char *)line;
549
550 while (*p > ' ')
551 p++;
552
553 int len = p - (unsigned char *)line;
554
555 while ((*p - 1) < ' ')
556 p++;
557
558 if (*p)
559 {
560 char *v = p;
561
562 while (*p && *p != '\n')
563 p++;
564
565 *p = 0;
566
567 return token (k, v);
568 }
569 else
570 return token (k);
571 }
572#endif
573}
574
551///////////////////////////////////////////////////////////////////////////// 575/////////////////////////////////////////////////////////////////////////////
552 576
553extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr) 577extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr)
554{ 578{
555 return 0; 579 return 0;
… …
652} 676}
653 677
654void 678void
655cfperl_init () 679cfperl_init ()
656{ 680{
681 PERL_SYS_INIT3 (&settings.argc, &settings.argv, 0);
682 perl = perl_alloc ();
683 perl_construct (perl);
684
685 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
686
657 char *argv[] = { 687 char *argv[] = {
658 "", 688 "",
659 "-e" 689 "-e"
660 "BEGIN {"
661 " cf->bootstrap;" 690 "cf->bootstrap;"
662 " unshift @INC, cf::datadir ();" 691 "unshift @INC, cf::datadir ();"
663 "}"
664 ""
665 "use cf;"
666 }; 692 };
667
668 perl = perl_alloc ();
669 perl_construct (perl);
670
671 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
672 693
673 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl)) 694 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl))
674 { 695 {
675 printf ("unable to initialize perl-interpreter, aborting.\n"); 696 printf ("unable to initialize perl-interpreter, aborting.\n");
676
677 exit (EXIT_FAILURE); 697 exit (EXIT_FAILURE);
678 //perl_destruct (perl);
679 //perl_free (perl);
680 //perl = 0;
681 //return;
682 } 698 }
683 699
684 obj_cache = newHV (); 700 obj_cache = newHV ();
701}
702
703void cfperl_boot ()
704{
705 perl_booted = true;
706
707 eval_pv ("require cf", 1);
685} 708}
686 709
687void cfperl_main () 710void cfperl_main ()
688{ 711{
689 dSP; 712 dSP;
… …
761 dt = (data_type) va_arg (ap, int); 784 dt = (data_type) va_arg (ap, int);
762 assert (("first argument must be of type object", dt == DT_OBJECT)); 785 assert (("first argument must be of type object", dt == DT_OBJECT));
763 op = va_arg (ap, object *); 786 op = va_arg (ap, object *);
764 787
765 if (op->cb) 788 if (op->cb)
766 gather_callbacks (callbacks, (AV *)op->cb, event); 789 gather_callbacks (callbacks, op->cb, event);
767 790
768 if (op->type) 791 if (op->type)
769 { 792 {
770 if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type)) 793 if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type))
771 { 794 {
… …
792 dt = (data_type) va_arg (ap, int); 815 dt = (data_type) va_arg (ap, int);
793 assert (("first argument must be of type player", dt == DT_PLAYER)); 816 assert (("first argument must be of type player", dt == DT_PLAYER));
794 pl = va_arg (ap, player *); 817 pl = va_arg (ap, player *);
795 818
796 if (pl->cb) 819 if (pl->cb)
797 gather_callbacks (callbacks, (AV *)pl->cb, event); 820 gather_callbacks (callbacks, pl->cb, event);
798 821
799 gather_callbacks (callbacks, cb_player, event); 822 gather_callbacks (callbacks, cb_player, event);
800 break; 823 break;
801 824
802 case KLASS_MAP: 825 case KLASS_MAP:
803 dt = (data_type) va_arg (ap, int); 826 dt = (data_type) va_arg (ap, int);
804 assert (("first argument must be of type object", dt == DT_MAP)); 827 assert (("first argument must be of type object", dt == DT_MAP));
805 map = va_arg (ap, mapstruct *); 828 map = va_arg (ap, mapstruct *);
806 829
807 if (map->cb) 830 if (map->cb)
808 gather_callbacks (callbacks, (AV *)map->cb, event); 831 gather_callbacks (callbacks, map->cb, event);
809 832
810 gather_callbacks (callbacks, cb_map, event); 833 gather_callbacks (callbacks, cb_map, event);
811 break; 834 break;
812 835
813 default: 836 default:
… …
1854 1877
1855void cf_object_drop (object *op, object *author) 1878void cf_object_drop (object *op, object *author)
1856 1879
1857void cf_object_take (object *op, object *author) 1880void cf_object_take (object *op, object *author)
1858 1881
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) 1882object *cf_object_insert_object (object *op, object *container)
1864 1883
1865const char *cf_object_get_msg (object *ob) 1884const char *cf_object_get_msg (object *ob)
1866 ALIAS: msg = 0 1885 ALIAS: msg = 0
1867 1886
… …
2333 OUTPUT: 2352 OUTPUT:
2334 RETVAL 2353 RETVAL
2335 2354
2336 2355
2337MODULE = cf PACKAGE = cf::arch 2356MODULE = cf PACKAGE = cf::arch
2357
2358archetype *find (const char *name)
2359 CODE:
2360 RETVAL = find_archetype (name);
2361 OUTPUT:
2362 RETVAL
2338 2363
2339archetype *first() 2364archetype *first()
2340 PROTOTYPE: 2365 PROTOTYPE:
2341 CODE: 2366 CODE:
2342 RETVAL = first_archetype; 2367 RETVAL = first_archetype;

Diff Legend

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