[ViewVC] Diff of: cvs/deliantra/server/server/cfperl.xs

Comparing deliantra/server/server/cfperl.xs (file contents):
Revision 1.31 by root, Wed Aug 30 12:08:15 2006 UTC vs.
Revision 1.37 by root, Thu Aug 31 17:54:15 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
55	extern sint64 *levels; // the experience table	43	extern sint64 *levels; // the experience table
56		44
57	typedef object object_ornull;	45	typedef object object_ornull;
…		…
61	#define newSVval64 newSVnv	49	#define newSVval64 newSVnv
62	#define SvVAL64 SvNV	50	#define SvVAL64 SvNV
63		51
64	static f_plug_api gethook = cfapi_get_hooks;	52	static f_plug_api gethook = cfapi_get_hooks;
65	static f_plug_api object_set_property = cfapi_object_set_property;	53	static f_plug_api object_set_property = cfapi_object_set_property;
66	static f_plug_api map_get_map = cfapi_map_get_map;
67	static f_plug_api object_insert = cfapi_object_insert;	54	static f_plug_api object_insert = cfapi_object_insert;
		55
		56	static 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 */
70	typedef struct	59	typedef 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
125	static void	114	static void
126	SVptr_cache_set (void ptr, SV sv)	115	SVptr_cache_set (void ptr, SV sv)
127	{	116	{
…		…
316	void attachable_base::clear ()	305	void 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
…		…
415	void reattach (attachable<subclass> *obj)	404	void 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
423	object_freezer::object_freezer (const char *filename)	414	object_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
438	object_freezer::~object_freezer ()	420	object_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
459	void object_freezer::put (attachable_base *ext)	425	void 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
		440	void object_freezer::put (const char k, const char v)
		441	{
		442	add (k);
		443
		444	//if (v)
		445	add (' '); //TODO//cf compatibility always add space
		446	if (v)
		447	add (v);
		448
		449	add ('\n');
		450	}
		451
		452	void object_freezer::put (const char *k, int v)
		453	{
		454	add (k);
		455	add (' ');
		456	add (sint32 (v));
		457	add ('\n');
		458	}
		459
		460	void object_freezer::put (keyword k, const char *v)
		461	{
		462	int klen = keyword_len [k];
		463	int vlen = v ? strlen (v) : 0;
		464
		465	char p = (char )alloc (klen + 1 + vlen + 1);
		466
		467	memcpy (p, keyword_str [k], klen); p += klen;
		468	*p++ = ' '; //TODO//cf compatibility always add space
		469	memcpy (p, v, vlen); p += vlen;
		470	*p = '\n';
		471	}
		472
		473	void object_freezer::put (keyword k, double v)
		474	{
		475	char buf [128];
		476
		477	snprintf (buf, 128, "%.7g", v);
		478
		479	put (k, (const char *)buf);
		480	}
		481
		482	void object_freezer::put_(keyword k, sint64 v)
		483	{
		484	add (keyword_str [k], keyword_len [k]);
		485	add (' ');
		486	add (v);
		487	add ('\n');
		488	}
		489
		490	void object_freezer::put_(keyword k, sint32 v)
		491	{
		492	add (keyword_str [k], keyword_len [k]);
		493	add (' ');
		494	add (v);
		495	add ('\n');
		496	}
		497
		498	void object_freezer::put (keyword kbeg, keyword kend, const char *v)
		499	{
		500	add (keyword_str [kbeg], keyword_len [kbeg]); add ('\n');
		501
		502	if (v)
		503	{
		504	add (v);
		505	add ('\n');
		506	}
		507
		508	add (keyword_str [kend], keyword_len [kend]); add ('\n');
		509	}
		510
		511	bool object_freezer::save (const char *filename)
		512	{
		513	dSP;
		514	ENTER;
		515	SAVETMPS;
		516	PUSHMARK (SP);
		517	EXTEND (SP, 3);
		518	PUSHs (sv_2mortal (newSVpv (filename, 0)));
		519	PUSHs (sv_2mortal (newRV_noinc (newSVpvn ((char *)linearise (), size ()))));
		520	PUSHs (sv_2mortal (newRV_inc ((SV *)av)));
		521	PUTBACK;
		522	call_pv ("cf::object_freezer_save", G_VOID \| G_DISCARD \| G_EVAL);
		523	FREETMPS;
		524	LEAVE;
		525	}
		526
		527	int fprintf (object_freezer &freezer, const char *format, ...)
		528	{
		529	va_list ap;
		530
		531	va_start (ap, format);
		532
		533	int len = vsnprintf ((char *)freezer.force (1024), 1024, format, ap);
		534
		535	if (len >= 0)
		536	freezer.alloc (len);
		537
		538	va_end (ap);
		539	}
		540
		541	int fputs (const char *s, object_freezer &freezer)
		542	{
		543	freezer.add (s);
469	}	544	}
470		545
471	object_thawer::object_thawer (const char *filename)	546	object_thawer::object_thawer (const char *filename)
472	{	547	{
473	av = 0;	548	av = 0;
…		…
481	{	556	{
482	LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno));	557	LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno));
483	return;	558	return;
484	}	559	}
485		560
486	if (perl)	561	if (perl_booted)
487	{	562	{
488	dSP;	563	dSP;
489	ENTER;	564	ENTER;
490	SAVETMPS;	565	SAVETMPS;
491	PUSHMARK (SP);	566	PUSHMARK (SP);
…		…
495	if (0 < call_pv ("cf::object_thawer_load", G_SCALAR \| G_EVAL))	570	if (0 < call_pv ("cf::object_thawer_load", G_SCALAR \| G_EVAL))
496	{	571	{
497	SPAGAIN;	572	SPAGAIN;
498	SV *sv = POPs;	573	SV *sv = POPs;
499	if (SvROK (sv))	574	if (SvROK (sv))
500	av = SvREFCNT_inc (SvRV (sv));	575	av = (AV *)SvREFCNT_inc (SvRV (sv));
501	}	576	}
502		577
503	FREETMPS;	578	FREETMPS;
504	LEAVE;	579	LEAVE;
505	}	580	}
506	}
507
508	// compatibility support, should be removed when no longer needed
509	int 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
518	int fputs (const char *s, object_freezer &freezer)
519	{
520	fputs (s, freezer.fp);
521	}	581	}
522		582
523	void object_thawer::get (data_type type, void obj, attachable_base ext, int oid)	583	void object_thawer::get (data_type type, void obj, attachable_base ext, int oid)
524	{	584	{
525	if (!av \|\| oid < 0) // this is actually an error of sorts	585	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);	595	printf ("trying to thaw duplicate or never-issued oid %d, ignoring.\n", oid);
536	return;	596	return;
537	}	597	}
538		598
539	ext->self = svp; svp = &PL_sv_undef;	599	ext->self = svp; svp = &PL_sv_undef;
540	sv_magic (SvRV ((SV )ext->self), 0, PERL_MAGIC_ext, (char )obj, 0);	600	sv_magic (SvRV (ext->self), 0, PERL_MAGIC_ext, (char *)obj, 0);
541		601
542	reattach (type, obj);	602	reattach (type, obj);
543	}	603	}
544		604
545	object_thawer::~object_thawer ()	605	object_thawer::~object_thawer ()
546	{	606	{
547	if (fp) fclose (fp);	607	if (fp) fclose (fp);
548	if (av) SvREFCNT_dec ((AV *)av);	608	if (av) SvREFCNT_dec ((AV *)av);
549	}	609	}
550		610
		611	token object_thawer::get_token ()
		612	{
		613	#if 0
		614	for (;;)
		615	{
		616	if (!fgets (line, sizeof (line), fp))
		617	return token (KW_eof);
		618
		619	unsigned char p = (unsigned char )line;
		620
		621	while (*p > ' ')
		622	p++;
		623
		624	int len = p - (unsigned char *)line;
		625
		626	while ((*p - 1) < ' ')
		627	p++;
		628
		629	if (*p)
		630	{
		631	char *v = p;
		632
		633	while (p && p != '\n')
		634	p++;
		635
		636	*p = 0;
		637
		638	return token (k, v);
		639	}
		640	else
		641	return token (k);
		642	}
		643	#endif
		644	}
		645
551	/////////////////////////////////////////////////////////////////////////////	646	/////////////////////////////////////////////////////////////////////////////
552		647
553	extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr)	648	extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr)
554	{	649	{
555	return 0;	650	return 0;
…		…
652	}	747	}
653		748
654	void	749	void
655	cfperl_init ()	750	cfperl_init ()
656	{	751	{
		752	PERL_SYS_INIT3 (&settings.argc, &settings.argv, 0);
		753	perl = perl_alloc ();
		754	perl_construct (perl);
		755
		756	PL_exit_flags \|= PERL_EXIT_DESTRUCT_END;
		757
657	char *argv[] = {	758	char *argv[] = {
658	"",	759	"",
659	"-e"	760	"-e"
660	"BEGIN {"
661	" cf->bootstrap;"	761	"cf->bootstrap;"
662	" unshift @INC, cf::datadir ();"	762	"unshift @INC, cf::datadir ();"
663	"}"
664	""
665	"use cf;"
666	};	763	};
667
668	perl = perl_alloc ();
669	perl_construct (perl);
670
671	PL_exit_flags \|= PERL_EXIT_DESTRUCT_END;
672		764
673	if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) \|\| perl_run (perl))	765	if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) \|\| perl_run (perl))
674	{	766	{
675	printf ("unable to initialize perl-interpreter, aborting.\n");	767	printf ("unable to initialize perl-interpreter, aborting.\n");
676
677	exit (EXIT_FAILURE);	768	exit (EXIT_FAILURE);
678	//perl_destruct (perl);
679	//perl_free (perl);
680	//perl = 0;
681	//return;
682	}	769	}
683		770
684	obj_cache = newHV ();	771	obj_cache = newHV ();
		772	}
		773
		774	void cfperl_boot ()
		775	{
		776	perl_booted = true;
		777
		778	eval_pv ("require cf", 1);
685	}	779	}
686		780
687	void cfperl_main ()	781	void cfperl_main ()
688	{	782	{
689	dSP;	783	dSP;
…		…
761	dt = (data_type) va_arg (ap, int);	855	dt = (data_type) va_arg (ap, int);
762	assert (("first argument must be of type object", dt == DT_OBJECT));	856	assert (("first argument must be of type object", dt == DT_OBJECT));
763	op = va_arg (ap, object *);	857	op = va_arg (ap, object *);
764		858
765	if (op->cb)	859	if (op->cb)
766	gather_callbacks (callbacks, (AV *)op->cb, event);	860	gather_callbacks (callbacks, op->cb, event);
767		861
768	if (op->type)	862	if (op->type)
769	{	863	{
770	if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type))	864	if (op->subtype && op->type + op->subtype * NUM_SUBTYPES <= AvFILLp (cb_type))
771	{	865	{
…		…
792	dt = (data_type) va_arg (ap, int);	886	dt = (data_type) va_arg (ap, int);
793	assert (("first argument must be of type player", dt == DT_PLAYER));	887	assert (("first argument must be of type player", dt == DT_PLAYER));
794	pl = va_arg (ap, player *);	888	pl = va_arg (ap, player *);
795		889
796	if (pl->cb)	890	if (pl->cb)
797	gather_callbacks (callbacks, (AV *)pl->cb, event);	891	gather_callbacks (callbacks, pl->cb, event);
798		892
799	gather_callbacks (callbacks, cb_player, event);	893	gather_callbacks (callbacks, cb_player, event);
800	break;	894	break;
801		895
802	case KLASS_MAP:	896	case KLASS_MAP:
803	dt = (data_type) va_arg (ap, int);	897	dt = (data_type) va_arg (ap, int);
804	assert (("first argument must be of type object", dt == DT_MAP));	898	assert (("first argument must be of type object", dt == DT_MAP));
805	map = va_arg (ap, mapstruct *);	899	map = va_arg (ap, mapstruct *);
806		900
807	if (map->cb)	901	if (map->cb)
808	gather_callbacks (callbacks, (AV *)map->cb, event);	902	gather_callbacks (callbacks, map->cb, event);
809		903
810	gather_callbacks (callbacks, cb_map, event);	904	gather_callbacks (callbacks, cb_map, event);
811	break;	905	break;
812		906
813	default:	907	default:
…		…
1854		1948
1855	void cf_object_drop (object op, object author)	1949	void cf_object_drop (object op, object author)
1856		1950
1857	void cf_object_take (object op, object author)	1951	void cf_object_take (object op, object author)
1858		1952
1859	void cf_object_say (object op, char msg)
1860
1861	void cf_object_speak (object op, char msg)
1862
1863	object cf_object_insert_object (object op, object *container)	1953	object cf_object_insert_object (object op, object *container)
1864		1954
1865	const char cf_object_get_msg (object ob)	1955	const char cf_object_get_msg (object ob)
1866	ALIAS: msg = 0	1956	ALIAS: msg = 0
1867		1957
…		…
2333	OUTPUT:	2423	OUTPUT:
2334	RETVAL	2424	RETVAL
2335		2425
2336		2426
2337	MODULE = cf PACKAGE = cf::arch	2427	MODULE = cf PACKAGE = cf::arch
		2428
		2429	archetype find (const char name)
		2430	CODE:
		2431	RETVAL = find_archetype (name);
		2432	OUTPUT:
		2433	RETVAL
2338		2434
2339	archetype *first()	2435	archetype *first()
2340	PROTOTYPE:	2436	PROTOTYPE:
2341	CODE:	2437	CODE:
2342	RETVAL = first_archetype;	2438	RETVAL = first_archetype;

Diff Legend

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

Comparing deliantra/server/server/cfperl.xs (file contents): Revision 1.31 by root, Wed Aug 30 12:08:15 2006 UTC vs. Revision 1.37 by root, Thu Aug 31 17:54:15 2006 UTC

Diff Legend

Comparing deliantra/server/server/cfperl.xs (file contents):
Revision 1.31 by root, Wed Aug 30 12:08:15 2006 UTC vs.
Revision 1.37 by root, Thu Aug 31 17:54:15 2006 UTC