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.33 by elmex, Thu Aug 31 01:03:36 2006 UTC vs.
Revision 1.43 by root, Mon Sep 4 13:55:54 2006 UTC

… …
24*/ 24*/
25 25
26#define PLUGIN_NAME "perl" 26#define PLUGIN_NAME "perl"
27#define PLUGIN_VERSION "cfperl 0.5" 27#define PLUGIN_VERSION "cfperl 0.5"
28 28
29#ifndef __CEXTRACT__
30#include <plugin.h>
31#endif
32
33#undef MODULEAPI
34#ifdef WIN32
35#else
36#define MODULEAPI
37#endif
38
39#include <plugin_common.h> 29#include <plugin_common.h>
40#include <sounds.h> 30#include <sounds.h>
41#include <cstdarg> 31#include <cstdarg>
42#include <sproto.h> 32#include <sproto.h>
43 33
… …
60#define SvVAL64 SvNV 50#define SvVAL64 SvNV
61 51
62static f_plug_api gethook = cfapi_get_hooks; 52static f_plug_api gethook = cfapi_get_hooks;
63static f_plug_api object_set_property = cfapi_object_set_property; 53static f_plug_api object_set_property = cfapi_object_set_property;
64static f_plug_api object_insert = cfapi_object_insert; 54static f_plug_api object_insert = cfapi_object_insert;
65
66static bool perl_booted;
67 55
68/* this is a stupid way to do things, and awkward to use for plug-in authors */ 56/* this is a stupid way to do things, and awkward to use for plug-in authors */
69typedef struct 57typedef struct
70{ 58{
71 object* who; 59 object* who;
… …
336 { 324 {
337 SvREFCNT_dec (cb); 325 SvREFCNT_dec (cb);
338 cb = 0; 326 cb = 0;
339 } 327 }
340 328
341 if (attach)
342 {
343 free_string (attach);
344 attach = 0; 329 attach = 0;
345 }
346} 330}
347 331
348void attachable_base::optimise () 332void attachable_base::optimise ()
349{ 333{
350 if (!self) 334 if (!self)
… …
369 PUSHMARK (SP); 353 PUSHMARK (SP);
370 EXTEND (SP, 2); 354 EXTEND (SP, 2);
371 PUSHs (sv_2mortal (newSVdt (type, obj))); 355 PUSHs (sv_2mortal (newSVdt (type, obj)));
372 PUSHs (sv_2mortal (newSVpv (attach, 0))); 356 PUSHs (sv_2mortal (newSVpv (attach, 0)));
373 357
374 free_string (attach);
375 attach = 0; 358 attach = 0;
376 359
377 PUTBACK; 360 PUTBACK;
378 call_pv ("cf::instantiate", G_DISCARD | G_VOID | G_EVAL); 361 call_pv ("cf::instantiate", G_DISCARD | G_VOID | G_EVAL);
379 FREETMPS; 362 FREETMPS;
… …
414void reattach (attachable<subclass> *obj) 397void reattach (attachable<subclass> *obj)
415{ 398{
416 obj->optimise (); 399 obj->optimise ();
417 400
418 if (obj->self) 401 if (obj->self)
419 reattach (subclass::get_dt (), (subclass *)obj); 402 reattach ((data_type) cftype<subclass>::dt, (subclass *)obj);
420} 403}
421 404
405#include "kw_hash.h"
406
422object_freezer::object_freezer (const char *filename) 407object_freezer::object_freezer ()
408: dynbuf (128 * 1024, 64 * 1024)
423{ 409{
424 this->filename = (SV *)newSVpv (filename, 0);
425
426 char filename2 [4096];
427 snprintf (filename2, 4096, "%s~", filename);
428
429 av = newAV (); 410 av = newAV ();
430
431 // TODO: fast dynbuf implementation... yeah, we need obstacks
432 text = newSV (10 * 1024 * 1024); // only temporarily used, so be generous
433} 411}
434 412
435object_freezer::~object_freezer () 413object_freezer::~object_freezer ()
414{
415 SvREFCNT_dec (av);
416}
417
418void object_freezer::put (attachable_base *ext)
419{
420 ext->optimise ();
421
422 if (ext->self)
423 {
424 int idx = AvFILLp ((AV *)av) + 1;
425 av_store (av, idx, SvREFCNT_inc (ext->self));
426
427 add ((void *)"oid ", 4);
428 add ((sint32)idx);
429 add ('\n');
430 }
431}
432
433bool object_freezer::save (const char *filename)
436{ 434{
437 dSP; 435 dSP;
438 ENTER; 436 ENTER;
439 SAVETMPS; 437 SAVETMPS;
440 PUSHMARK (SP); 438 PUSHMARK (SP);
439 EXTEND (SP, 3);
441 XPUSHs (sv_2mortal ((SV *)filename)); 440 PUSHs (sv_2mortal (newSVpv (filename, 0)));
442 XPUSHs (sv_2mortal (newRV_noinc (text))); 441 PUSHs (sv_2mortal (newRV_noinc (newSVpvn ((char *)linearise (), size ()))));
443 XPUSHs (sv_2mortal (newRV_noinc ((SV *)av))); 442 PUSHs (sv_2mortal (newRV_inc ((SV *)av)));
444 PUTBACK; 443 PUTBACK;
445 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL); 444 call_pv ("cf::object_freezer_save", G_VOID | G_DISCARD | G_EVAL);
446 FREETMPS; 445 FREETMPS;
447 LEAVE; 446 LEAVE;
448} 447}
449 448
450void object_freezer::put (attachable_base *ext)
451{
452 ext->optimise ();
453
454 if (ext->self)
455 {
456 int idx = AvFILLp ((AV *)av) + 1;
457 av_store (av, idx, SvREFCNT_inc (ext->self));
458
459 sv_catpvf (text, "oid %d\n", idx);
460 }
461}
462
463int fprintf (object_freezer &freezer, const char *format, ...) 449int fprintf (object_freezer &freezer, const char *format, ...)
464{ 450{
465 va_list ap; 451 va_list ap;
466 452
467 va_start (ap, format); 453 va_start (ap, format);
468 sv_vcatpvfn (freezer.text, format, strlen (format), &ap, 0, 0, 0); 454
455 int len = vsnprintf ((char *)freezer.force (1024), 1024, format, ap);
456
457 if (len >= 0)
458 freezer.alloc (len);
459
469 va_end (ap); 460 va_end (ap);
470} 461}
471 462
472int fputs (const char *s, object_freezer &freezer) 463int fputs (const char *s, object_freezer &freezer)
473{ 464{
474 sv_catpvn (freezer.text, s, strlen (s)); 465 freezer.add (s);
475} 466}
476 467
477object_thawer::object_thawer (const char *filename) 468object_thawer::object_thawer (const char *filename)
478{ 469{
470 static const char eof[] = "\n\n\n\0\0\0";
471
479 av = 0; 472 av = 0;
480 fp = 0; 473 text = 0;
474 line = 0;
481 475
482 if (!filename) 476 if (filename)
483 return;
484
485 fp = fopen (filename, "r");
486 if (!fp)
487 {
488 LOG (llevError, "object_thawer: unable to open '%s': %s.\n", filename, strerror (errno));
489 return;
490 }
491
492 if (perl_booted)
493 { 477 {
494 dSP; 478 dSP;
495 ENTER; 479 ENTER;
496 SAVETMPS; 480 SAVETMPS;
497 PUSHMARK (SP); 481 PUSHMARK (SP);
498 XPUSHs (sv_2mortal (newSVpv (filename, 0))); 482 XPUSHs (sv_2mortal (newSVpv (filename, 0)));
499 PUTBACK; 483 PUTBACK;
500 484
501 if (0 < call_pv ("cf::object_thawer_load", G_SCALAR | G_EVAL)) 485 if (2 == call_pv ("cf::object_thawer_load", G_ARRAY | G_EVAL))
502 { 486 {
503 SPAGAIN; 487 SPAGAIN;
488
489 // second value - perl objects
490 {
504 SV *sv = POPs; 491 SV *sv = POPs;
505 if (SvROK (sv)) 492 if (SvROK (sv))
506 av = (AV *)SvREFCNT_inc (SvRV (sv)); 493 av = (AV *)SvREFCNT_inc (SvRV (sv));
494 }
495
496 // first value - text part, pad with 3 zeroes
497 {
498 SV *sv = POPs;
499 STRLEN len;
500 char *sv_ = SvPVbyte (sv, len);
501 text = newSV (len + sizeof (eof));
502 SvCUR_set (text, len);
503 memcpy (SvPVX (text), sv_, len);
504 memcpy (SvEND (text), eof, sizeof (eof)); // just to be sure
505
506 line = SvPVX (text);
507 }
507 } 508 }
508 509
510 PUTBACK;
509 FREETMPS; 511 FREETMPS;
510 LEAVE; 512 LEAVE;
511 } 513 }
512} 514}
513 515
… …
533 reattach (type, obj); 535 reattach (type, obj);
534} 536}
535 537
536object_thawer::~object_thawer () 538object_thawer::~object_thawer ()
537{ 539{
538 if (fp) fclose (fp); 540 if (text) SvREFCNT_dec (text);
539 if (av) SvREFCNT_dec ((AV *)av); 541 if (av) SvREFCNT_dec (av);
542}
543
544char *fgets (char *s, int n, object_thawer &thawer)
545{
546 char *p = thawer.line;
547 char *q = s;
548
549 if (!p)
550 return 0;
551
552 while (--n)
553 {
554 if (!*p)
555 break;
556
557 *q++ = *p;
558
559 if (*p++ == '\n')
560 break;
561 }
562
563 *q = 0;
564 thawer.line = p;
565
566 return s == q ? 0 : s;
567}
568
569keyword object_thawer::get_kv ()
570{
571 if (!line)
572 return KW_EOF;
573
574 for (;;)
575 {
576 char *p = line;
577
578 if (!*p)
579 return KW_EOF;
580
581 // parse keyword
582 while (*p > ' ')
583 p++;
584
585 int klen = p - line;
586
587 if (*p++ != '\n')
588 {
589 // parse value
590 while (*p <= ' ' && *p != '\n') // skip 0x01 .. 0x20
591 ++p;
592
593 last_value = p;
594
595 while (*p != '\n')
596 p++;
597
598 *p++ = 0;
599 }
600 else
601 last_value = 0;
602
603 line [klen] = 0;
604 keyword_idx *kw = kw_lex::match (line, klen);
605
606 //printf ("KV %d<%s,%s>\n", kw ? kw->index : 0, line, last_value);//D
607
608 if (kw)
609 {
610 line = p;
611 return kw->index;
612 }
613 else if (!*line || *line == '#')
614 {
615 // empty/comment line
616 line = p;
617 }
618 else
619 return KW_ERROR;
620 }
621}
622
623void object_thawer::get (shstr &sh) const
624{
625 if (last_value)
626 sh = last_value;
627 else
628 {
629 sh = "<value missing>";
630 LOG (llevError, "keyword requires value: <%s>\n", line);//TODO: add filename
631 }
632}
633
634void object_thawer::get_ml (keyword kend, shstr &sh)
635{
636 char kw[128];
637
638 int klen = keyword_len [kend];
639
640 kw [0] = '\n';
641 memcpy (kw + 1, keyword_str [kend], klen);
642 kw [klen + 1] = '\n';
643 kw [klen + 2] = 0;
644
645 // first test for completely empty msg... "endXXX\n"
646 if (!strncmp (line, kw + 1, klen + 1))
647 {
648 sh = 0;
649
650 line += klen + 1;
651
652 return;
653 }
654 else
655 {
656 // multi-line strings are delimited by "\nendXXX\n" or "endXXX\n" (NULL)
657
658 char *end = strstr (line, kw);
659
660 if (!end)
661 {
662 sh = 0;
663 return;
664 }
665
666 *end = 0;
667 sh = line;
668
669 line = end + keyword_len [kend] + 1;
670
671 while (*line++ != '\n')
672 ;
673 }
674}
675
676sint32 object_thawer::get_sint32 () const
677{
678 char *p = last_value;
679
680 if (!p)
681 return 0;
682
683 sint32 val = 0;
684 bool negate;
685
686 if (*p == '-')
687 {
688 negate = true;
689 ++p;
690 }
691 else
692 negate = false;
693
694 do
695 {
696 val *= 10;
697 val += *p++ - '0';
698 }
699 while (*p);
700
701 return negate ? -val : val;
702}
703
704sint64 object_thawer::get_sint64 () const
705{
706 return last_value ? atoll (last_value) : 0;
707}
708
709double object_thawer::get_double () const
710{
711 return last_value ? atof (last_value) : 0;
540} 712}
541 713
542///////////////////////////////////////////////////////////////////////////// 714/////////////////////////////////////////////////////////////////////////////
543 715
544extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr) 716extern "C" int cfperl_initPlugin (const char *iversion, f_plug_api gethooksptr)
… …
654 char *argv[] = { 826 char *argv[] = {
655 "", 827 "",
656 "-e" 828 "-e"
657 "cf->bootstrap;" 829 "cf->bootstrap;"
658 "unshift @INC, cf::datadir ();" 830 "unshift @INC, cf::datadir ();"
831 "require cf;"
659 }; 832 };
660 833
661 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl)) 834 if (perl_parse (perl, xs_init, 2, argv, (char **)NULL) || perl_run (perl))
662 { 835 {
663 printf ("unable to initialize perl-interpreter, aborting.\n"); 836 printf ("unable to initialize perl-interpreter, aborting.\n");
664 exit (EXIT_FAILURE); 837 exit (EXIT_FAILURE);
665 } 838 }
666 839
667 obj_cache = newHV (); 840 obj_cache = newHV ();
668}
669
670void cfperl_boot ()
671{
672 perl_booted = true;
673
674 eval_pv ("require cf", 1);
675} 841}
676 842
677void cfperl_main () 843void cfperl_main ()
678{ 844{
679 dSP; 845 dSP;
… …
1255 1421
1256 const_iv (SK_EXP_ADD_SKILL) 1422 const_iv (SK_EXP_ADD_SKILL)
1257 const_iv (SK_EXP_TOTAL) 1423 const_iv (SK_EXP_TOTAL)
1258 const_iv (SK_EXP_NONE) 1424 const_iv (SK_EXP_NONE)
1259 const_iv (SK_SUBTRACT_SKILL_EXP) 1425 const_iv (SK_SUBTRACT_SKILL_EXP)
1426 const_iv (SK_EXP_SKILL_ONLY)
1260 1427
1261 const_iv (SK_LOCKPICKING) 1428 const_iv (SK_LOCKPICKING)
1262 const_iv (SK_HIDING) 1429 const_iv (SK_HIDING)
1263 const_iv (SK_SMITHERY) 1430 const_iv (SK_SMITHERY)
1264 const_iv (SK_BOWYER) 1431 const_iv (SK_BOWYER)
… …
2320 RETVAL 2487 RETVAL
2321 2488
2322 2489
2323MODULE = cf PACKAGE = cf::arch 2490MODULE = cf PACKAGE = cf::arch
2324 2491
2492archetype *find (const char *name)
2493 CODE:
2494 RETVAL = find_archetype (name);
2495 OUTPUT:
2496 RETVAL
2497
2325archetype *first() 2498archetype *first()
2326 PROTOTYPE: 2499 PROTOTYPE:
2327 CODE: 2500 CODE:
2328 RETVAL = first_archetype; 2501 RETVAL = first_archetype;
2329 OUTPUT: RETVAL 2502 OUTPUT: RETVAL

Diff Legend

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