perl_c.c

   1 /* Interface to Perl from OCaml.
   2  * Copyright (C) 2003 Merjis Ltd.
   3  * $Id: perl_c.c,v 1.19 2004-12-11 15:40:09 rich Exp $
   4  */
   5
   6 #include <stdio.h>
   7 #include <stdlib.h>
   8 #include <assert.h>
   9 #include <unistd.h>
  10 #include <alloca.h>
  11
  12 #define CAML_NAME_SPACE 1
  13
  14 #include <caml/alloc.h>
  15 #include <caml/callback.h>
  16 #include <caml/custom.h>
  17 #include <caml/fail.h>
  18 #include <caml/memory.h>
  19 #include <caml/mlvalues.h>
  20
  21 #include <EXTERN.h>
  22 #include <perl.h>
  23
  24 /* Perl requires the interpreter to be called literally 'my_perl'! */
  25 static PerlInterpreter *my_perl;
  26
  27 /* Get the concrete value from an optional field. */
  28 static value unoption (value option, value deflt);
  29
  30 /* Wrap up an arbitrary void pointer in an opaque OCaml object. */
  31 static value Val_voidptr (void *ptr);
  32
  33 /* Unwrap an arbitrary void pointer from an opaque OCaml object. */
  34 #define Voidptr_val(type,rv) ((type *) Field ((rv), 0))
  35
  36 #if PERL4CAML_REFCOUNTING_EXPERIMENTAL
  37
  38 /* Unwrap a custom block. */
  39 #define Xv_val(rv) (*((void **)Data_custom_val(rv)))
  40
  41 /* Wrap up an SV, AV or HV in a custom OCaml object which will decrement
  42  * the reference count on finalization.
  43  */
  44 static value Val_xv (SV *sv);
  45
  46 #else
  47
  48 #define Xv_val(rv) Voidptr_val (SV, (rv))
  49 #define Val_xv(sv) Val_voidptr ((sv))
  50
  51 #endif
  52
  53 /* Hide Perl types in opaque OCaml objects. */
  54 #define Val_perl(pl) (Val_voidptr ((pl)))
  55 #define Perl_val(plv) (Voidptr_val (PerlInterpreter, (plv)))
  56 #define Val_sv(sv) (Val_xv ((sv)))
  57 #define Sv_val(svv) ((SV *) Xv_val (svv))
  58 #define Val_av(av) (Val_xv ((SV *)(av)))
  59 #define Av_val(avv) ((AV *) Xv_val (avv))
  60 #define Val_hv(hv) (Val_xv ((SV *)(hv)))
  61 #define Hv_val(hvv) ((HV *) Xv_val (hvv))
  62
  63 static void
  64 xs_init (pTHX)
  65 {
  66   char *file = __FILE__;
  67   EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  68
  69   newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  70 }
  71
  72 CAMLprim value
  73 perl4caml_init (value unit)
  74 {
  75   CAMLparam1 (unit);
  76   int argc = 4;
  77   static char *argv[] = { "", "-w", "-e", "0", NULL };
  78
  79   PERL_SYS_INIT (&argc, &argv);
  80   my_perl = perl_alloc ();
  81   perl_construct (my_perl);
  82   PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
  83   perl_parse (my_perl, xs_init, argc, argv, (char **) NULL);
  84   /*perl_run (my_perl);*/
  85
  86   CAMLreturn (Val_unit);
  87 }
  88
  89 CAMLprim value
  90 perl4caml_int_of_sv (value svv)
  91 {
  92   CAMLparam1 (svv);
  93   SV *sv = Sv_val (svv);
  94   CAMLreturn (Val_int (SvIV (sv)));
  95 }
  96
  97 CAMLprim value
  98 perl4caml_sv_of_int (value iv)
  99 {
 100   CAMLparam1 (iv);
 101   CAMLreturn (Val_sv (newSViv (Int_val (iv))));
 102 }
 103
 104 CAMLprim value
 105 perl4caml_float_of_sv (value svv)
 106 {
 107   CAMLparam1 (svv);
 108   SV *sv = Sv_val (svv);
 109   CAMLlocal1 (f);
 110   f = caml_copy_double (SvNV (sv));
 111   CAMLreturn (f);
 112 }
 113
 114 CAMLprim value
 115 perl4caml_sv_of_float (value fv)
 116 {
 117   CAMLparam1 (fv);
 118   CAMLreturn (Val_sv (newSViv (Double_val (fv))));
 119 }
 120
 121 CAMLprim value
 122 perl4caml_string_of_sv (value svv)
 123 {
 124   CAMLparam1 (svv);
 125   SV *sv = Sv_val (svv);
 126   char *str;
 127   STRLEN len;
 128   CAMLlocal1 (strv);
 129   str = SvPV (sv, len);
 130   /* XXX This won't work if the string contains NUL. */
 131   strv = caml_copy_string (str);
 132   CAMLreturn (strv);
 133 }
 134
 135 CAMLprim value
 136 perl4caml_sv_of_string (value strv)
 137 {
 138   CAMLparam1 (strv);
 139   CAMLreturn (Val_sv (newSVpv (String_val (strv), caml_string_length (strv))));
 140 }
 141
 142 CAMLprim value
 143 perl4caml_sv_is_true (value svv)
 144 {
 145   CAMLparam1 (svv);
 146   SV *sv = Sv_val (svv);
 147   CAMLreturn (SvTRUE (sv) ? Val_true : Val_false);
 148 }
 149
 150 CAMLprim value
 151 perl4caml_sv_undef (value unit)
 152 {
 153   CAMLparam1 (unit);
 154   /*CAMLreturn (Val_sv (newSV (0)));*/
 155   CAMLreturn (Val_sv (&PL_sv_undef));
 156 }
 157
 158 CAMLprim value
 159 perl4caml_sv_is_undef (value svv)
 160 {
 161   CAMLparam1 (svv);
 162   SV *sv = Sv_val (svv);
 163   CAMLreturn (!SvPOK (sv) && !SvIOK (sv) && SvTYPE (sv) == SVt_NULL
 164               ? Val_true : Val_false);
 165 }
 166
 167 CAMLprim value
 168 perl4caml_sv_yes (value unit)
 169 {
 170   CAMLparam1 (unit);
 171   CAMLreturn (Val_sv (&PL_sv_yes));
 172 }
 173
 174 CAMLprim value
 175 perl4caml_sv_no (value unit)
 176 {
 177   CAMLparam1 (unit);
 178   CAMLreturn (Val_sv (&PL_sv_no));
 179 }
 180
 181 CAMLprim value
 182 perl4caml_sv_type (value svv)
 183 {
 184   CAMLparam1 (svv);
 185   SV *sv = Sv_val (svv);
 186
 187   switch (SvTYPE (sv))
 188     {
 189     case SVt_IV: CAMLreturn (Val_int (1));
 190     case SVt_NV: CAMLreturn (Val_int (2));
 191     case SVt_PV: CAMLreturn (Val_int (3));
 192     case SVt_RV: CAMLreturn (Val_int (4));
 193     case SVt_PVAV: CAMLreturn (Val_int (5));
 194     case SVt_PVHV: CAMLreturn (Val_int (6));
 195     case SVt_PVCV: CAMLreturn (Val_int (7));
 196     case SVt_PVGV: CAMLreturn (Val_int (8));
 197     case SVt_PVMG: CAMLreturn (Val_int (9));
 198     default: CAMLreturn (Val_int (0));
 199     }
 200 }
 201
 202 CAMLprim value
 203 perl4caml_scalarref (value svv)
 204 {
 205   CAMLparam1 (svv);
 206   CAMLlocal1 (rsvv);
 207   SV *sv = Sv_val (svv);
 208   rsvv = Val_sv (newRV_inc (sv));
 209   CAMLreturn (rsvv);
 210 }
 211
 212 CAMLprim value
 213 perl4caml_arrayref (value avv)
 214 {
 215   CAMLparam1 (avv);
 216   CAMLlocal1 (rsvv);
 217   AV *av = Av_val (avv);
 218   rsvv = Val_sv (newRV_inc ((SV *) av));
 219   CAMLreturn (rsvv);
 220 }
 221
 222 CAMLprim value
 223 perl4caml_hashref (value hvv)
 224 {
 225   CAMLparam1 (hvv);
 226   CAMLlocal1 (rsvv);
 227   HV *hv = Hv_val (hvv);
 228   rsvv = Val_sv (newRV_inc ((SV *) hv));
 229   CAMLreturn (rsvv);
 230 }
 231
 232 CAMLprim value
 233 perl4caml_deref (value svv)
 234 {
 235   CAMLparam1 (svv);
 236   CAMLlocal1 (rsvv);
 237   SV *sv = Sv_val (svv);
 238
 239   if (!SvROK (sv))
 240     caml_invalid_argument ("deref: SV is not a reference");
 241   switch (SvTYPE (SvRV (sv))) {
 242   case SVt_IV:
 243   case SVt_NV:
 244   case SVt_PV:
 245   case SVt_RV:
 246   case SVt_PVMG:
 247     break;
 248   default:
 249     caml_invalid_argument ("deref: SV is not a reference to a scalar");
 250   }
 251   rsvv = Val_sv (SvRV (sv));
 252   CAMLreturn (rsvv);
 253 }
 254
 255 CAMLprim value
 256 perl4caml_deref_array (value svv)
 257 {
 258   CAMLparam1 (svv);
 259   CAMLlocal1 (ravv);
 260   SV *sv = Sv_val (svv);
 261
 262   if (!SvROK (sv))
 263     caml_invalid_argument ("deref_array: SV is not a reference");
 264   switch (SvTYPE (SvRV (sv))) {
 265   case SVt_PVAV:
 266     break;
 267   default:
 268     caml_invalid_argument ("deref_array: SV is not a reference to an array");
 269   }
 270   ravv = Val_av ((AV *) SvRV (sv));
 271   CAMLreturn (ravv);
 272 }
 273
 274 CAMLprim value
 275 perl4caml_deref_hash (value svv)
 276 {
 277   CAMLparam1 (svv);
 278   CAMLlocal1 (rhvv);
 279   SV *sv = Sv_val (svv);
 280
 281   if (!SvROK (sv))
 282     caml_invalid_argument ("deref_hash: SV is not a reference");
 283   switch (SvTYPE (SvRV (sv))) {
 284   case SVt_PVHV:
 285     break;
 286   default:
 287     caml_invalid_argument ("deref_hash: SV is not a reference to a hash");
 288   }
 289   rhvv = Val_hv ((HV *) SvRV (sv));
 290   CAMLreturn (rhvv);
 291 }
 292
 293 CAMLprim value
 294 perl4caml_av_empty (value unit)
 295 {
 296   CAMLparam1 (unit);
 297   AV *av = newAV ();
 298   CAMLreturn (Val_av (av));
 299 }
 300
 301 /* We don't know in advance how long the list will be, which makes this
 302  * a little harder.
 303  */
 304 CAMLprim value
 305 perl4caml_av_of_sv_list (value svlistv)
 306 {
 307   CAMLparam1 (svlistv);
 308   CAMLlocal1 (svv);
 309   SV *sv, **svlist = 0;
 310   int alloc = 0, size = 0;
 311   AV *av;
 312
 313   for (; svlistv != Val_int (0); svlistv = Field (svlistv, 1))
 314     {
 315       svv = Field (svlistv, 0);
 316       sv = Sv_val (svv);
 317       if (size >= alloc) {
 318         alloc = alloc == 0 ? 1 : alloc * 2;
 319         svlist = realloc (svlist, alloc * sizeof (SV *));
 320       }
 321       svlist[size++] = sv;
 322     }
 323
 324   av = av_make (size, svlist);
 325
 326   if (alloc > 0) free (svlist); /* Free memory allocated to SV list. */
 327
 328   CAMLreturn (Val_av (av));
 329 }
 330
 331 /* XXX av_map would be faster if we also had sv_list_of_av. */
 332
 333 CAMLprim value
 334 perl4caml_av_push (value avv, value svv)
 335 {
 336   CAMLparam2 (avv, svv);
 337   AV *av = Av_val (avv);
 338   SV *sv = Sv_val (svv);
 339   av_push (av, sv);
 340   CAMLreturn (Val_unit);
 341 }
 342
 343 CAMLprim value
 344 perl4caml_av_pop (value avv)
 345 {
 346   CAMLparam1 (avv);
 347   AV *av = Av_val (avv);
 348   SV *sv = av_pop (av);
 349   CAMLreturn (Val_sv (sv));
 350 }
 351
 352 CAMLprim value
 353 perl4caml_av_unshift (value avv, value svv)
 354 {
 355   CAMLparam2 (avv, svv);
 356   AV *av = Av_val (avv);
 357   SV *sv = Sv_val (svv);
 358   av_unshift (av, 1);
 359   SvREFCNT_inc (sv);
 360   if (av_store (av, 0, sv) == 0)
 361     SvREFCNT_dec (sv);
 362   CAMLreturn (Val_unit);
 363 }
 364
 365 CAMLprim value
 366 perl4caml_av_shift (value avv)
 367 {
 368   CAMLparam1 (avv);
 369   AV *av = Av_val (avv);
 370   SV *sv = av_shift (av);
 371   CAMLreturn (Val_sv (sv));
 372 }
 373
 374 CAMLprim value
 375 perl4caml_av_length (value avv)
 376 {
 377   CAMLparam1 (avv);
 378   AV *av = Av_val (avv);
 379   CAMLreturn (Val_int (av_len (av) + 1));
 380 }
 381
 382 CAMLprim value
 383 perl4caml_av_set (value avv, value i, value svv)
 384 {
 385   CAMLparam3 (avv, i, svv);
 386   AV *av = Av_val (avv);
 387   SV *sv = Sv_val (svv);
 388   SvREFCNT_inc (sv);
 389   if (av_store (av, Int_val (i), sv) == 0)
 390     SvREFCNT_dec (sv);
 391   CAMLreturn (Val_unit);
 392 }
 393
 394 CAMLprim value
 395 perl4caml_av_get (value avv, value i)
 396 {
 397   CAMLparam2 (avv, i);
 398   AV *av = Av_val (avv);
 399   SV **svp = av_fetch (av, Int_val (i), 0);
 400   if (svp == 0) caml_invalid_argument ("av_get: index out of bounds");
 401   CAMLreturn (Val_sv (*svp));
 402 }
 403
 404 CAMLprim value
 405 perl4caml_av_clear (value avv)
 406 {
 407   CAMLparam1 (avv);
 408   AV *av = Av_val (avv);
 409   av_clear (av);
 410   CAMLreturn (Val_unit);
 411 }
 412
 413 CAMLprim value
 414 perl4caml_av_undef (value avv)
 415 {
 416   CAMLparam1 (avv);
 417   AV *av = Av_val (avv);
 418   av_undef (av);
 419   CAMLreturn (Val_unit);
 420 }
 421
 422 CAMLprim value
 423 perl4caml_av_extend (value avv, value i)
 424 {
 425   CAMLparam2 (avv, i);
 426   AV *av = Av_val (avv);
 427   av_extend (av, Int_val (i));
 428   CAMLreturn (Val_unit);
 429 }
 430
 431 CAMLprim value
 432 perl4caml_hv_empty (value unit)
 433 {
 434   CAMLparam1 (unit);
 435   HV *hv = newHV ();
 436   CAMLreturn (Val_hv (hv));
 437 }
 438
 439 CAMLprim value
 440 perl4caml_hv_set (value hvv, value key, value svv)
 441 {
 442   CAMLparam3 (hvv, key, svv);
 443   HV *hv = Hv_val (hvv);
 444   SV *sv = Sv_val (svv);
 445   SvREFCNT_inc (sv);
 446   if (hv_store (hv, String_val (key), caml_string_length (key), sv, 0) == 0)
 447     SvREFCNT_dec (sv);
 448   CAMLreturn (Val_unit);
 449 }
 450
 451 CAMLprim value
 452 perl4caml_hv_get (value hvv, value key)
 453 {
 454   CAMLparam2 (hvv, key);
 455   HV *hv = Hv_val (hvv);
 456   SV **svp = hv_fetch (hv, String_val (key), caml_string_length (key), 0);
 457   if (svp == 0) caml_raise_not_found ();
 458   CAMLreturn (Val_sv (*svp));
 459 }
 460
 461 CAMLprim value
 462 perl4caml_hv_exists (value hvv, value key)
 463 {
 464   CAMLparam2 (hvv, key);
 465   HV *hv = Hv_val (hvv);
 466   bool r = hv_exists (hv, String_val (key), caml_string_length (key));
 467   CAMLreturn (r ? Val_true : Val_false);
 468 }
 469
 470 CAMLprim value
 471 perl4caml_hv_delete (value hvv, value key)
 472 {
 473   CAMLparam2 (hvv, key);
 474   HV *hv = Hv_val (hvv);
 475   hv_delete (hv, String_val (key), caml_string_length (key), G_DISCARD);
 476   CAMLreturn (Val_unit);
 477 }
 478
 479 CAMLprim value
 480 perl4caml_hv_clear (value hvv)
 481 {
 482   CAMLparam1 (hvv);
 483   HV *hv = Hv_val (hvv);
 484   hv_clear (hv);
 485   CAMLreturn (Val_unit);
 486 }
 487
 488 CAMLprim value
 489 perl4caml_hv_undef (value hvv)
 490 {
 491   CAMLparam1 (hvv);
 492   HV *hv = Hv_val (hvv);
 493   hv_undef (hv);
 494   CAMLreturn (Val_unit);
 495 }
 496
 497 CAMLprim value
 498 perl4caml_get_sv (value optcreate, value name)
 499 {
 500   CAMLparam2 (optcreate, name);
 501   CAMLlocal1 (create);
 502   SV *sv;
 503
 504   create = unoption (optcreate, Val_false);
 505   sv = get_sv (String_val (name), create == Val_true ? TRUE : FALSE);
 506   if (sv == NULL) caml_raise_not_found ();
 507
 508   CAMLreturn (Val_sv (sv));
 509 }
 510
 511 CAMLprim value
 512 perl4caml_get_av (value optcreate, value name)
 513 {
 514   CAMLparam2 (optcreate, name);
 515   CAMLlocal1 (create);
 516   AV *av;
 517
 518   create = unoption (optcreate, Val_false);
 519   av = get_av (String_val (name), create == Val_true ? TRUE : FALSE);
 520   if (av == NULL) caml_raise_not_found ();
 521
 522   CAMLreturn (Val_av (av));
 523 }
 524
 525 CAMLprim value
 526 perl4caml_get_hv (value optcreate, value name)
 527 {
 528   CAMLparam2 (optcreate, name);
 529   CAMLlocal1 (create);
 530   HV *hv;
 531
 532   create = unoption (optcreate, Val_false);
 533   hv = get_hv (String_val (name), create == Val_true ? TRUE : FALSE);
 534   if (hv == NULL) caml_raise_not_found ();
 535
 536   CAMLreturn (Val_hv (hv));
 537 }
 538
 539 static inline void
 540 check_perl_failure ()
 541 {
 542   SV *errsv = get_sv ("@", TRUE);
 543
 544   if (SvTRUE (errsv))           /* Equivalent of $@ in Perl. */
 545     {
 546       CAMLlocal1 (errv);
 547       STRLEN n_a;
 548       const char *err = SvPV (errsv, n_a);
 549
 550       errv = caml_copy_string (err);
 551
 552       caml_raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
 553     }
 554 }
 555
 556 CAMLprim value
 557 perl4caml_call (value optsv, value optfnname, value arglist)
 558 {
 559   CAMLparam3 (optsv, optfnname, arglist);
 560   dSP;
 561   int count;
 562   SV *sv;
 563   CAMLlocal3 (errv, svv, fnname);
 564
 565   ENTER;
 566   SAVETMPS;
 567
 568   /* Push the parameter list. */
 569   PUSHMARK (SP);
 570
 571   /* Iteration over the linked list. */
 572   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 573     {
 574       svv = Field (arglist, 0);
 575       sv = Sv_val (svv);
 576       XPUSHs (sv_2mortal (newSVsv (sv)));
 577     }
 578
 579   PUTBACK;
 580
 581   if (optsv != Val_int (0))
 582     {
 583       svv = unoption (optsv, Val_false);
 584       sv = Sv_val (svv);
 585       count = call_sv (sv, G_EVAL|G_SCALAR);
 586     }
 587   else if (optfnname != Val_int (0))
 588     {
 589       fnname = unoption (optfnname, Val_false);
 590       count = call_pv (String_val (fnname), G_EVAL|G_SCALAR);
 591     }
 592   else
 593     {
 594       fprintf (stderr,
 595                "Perl.call: must supply either 'sv' or 'fn' parameters.");
 596       abort ();
 597     }
 598
 599   SPAGAIN;
 600
 601   assert (count == 1); /* Pretty sure it should never be anything else. */
 602
 603   /* Pop return value off the stack. Note that the return value on the
 604    * stack is mortal, so we need to take a copy.
 605    */
 606   sv = newSVsv (POPs);
 607   PUTBACK;
 608   FREETMPS;
 609   LEAVE;
 610
 611   check_perl_failure ();
 612
 613   svv = Val_sv (sv);
 614   CAMLreturn (svv);
 615 }
 616
 617 CAMLprim value
 618 perl4caml_call_array (value optsv, value optfnname, value arglist)
 619 {
 620   CAMLparam3 (optsv, optfnname, arglist);
 621   dSP;
 622   int i, count;
 623   SV *sv;
 624   CAMLlocal5 (errv, svv, fnname, list, cons);
 625
 626   ENTER;
 627   SAVETMPS;
 628
 629   /* Push the parameter list. */
 630   PUSHMARK (SP);
 631
 632   /* Iteration over the linked list. */
 633   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 634     {
 635       svv = Field (arglist, 0);
 636       sv = Sv_val (svv);
 637       XPUSHs (sv_2mortal (newSVsv (sv)));
 638     }
 639
 640   PUTBACK;
 641
 642   if (optsv != Val_int (0))
 643     {
 644       svv = unoption (optsv, Val_false);
 645       sv = Sv_val (svv);
 646       count = call_sv (sv, G_EVAL|G_ARRAY);
 647     }
 648   else if (optfnname != Val_int (0))
 649     {
 650       fnname = unoption (optfnname, Val_false);
 651       count = call_pv (String_val (fnname), G_EVAL|G_ARRAY);
 652     }
 653   else
 654     {
 655       fprintf (stderr,
 656                "Perl.call_array: must supply either 'sv' or 'fn' parameters.");
 657       abort ();
 658     }
 659
 660   SPAGAIN;
 661
 662   /* Pop all the return values off the stack into a list. Values on the
 663    * stack are mortal, so we must copy them.
 664    */
 665   list = Val_int (0);
 666   for (i = 0; i < count; ++i) {
 667     SV *sv;
 668
 669     cons = caml_alloc (2, 0);
 670     Field (cons, 1) = list;
 671     list = cons;
 672     sv = newSVsv (POPs);
 673     Field (cons, 0) = Val_sv (sv);
 674   }
 675
 676   /* Restore the stack. */
 677   PUTBACK;
 678   FREETMPS;
 679   LEAVE;
 680
 681   check_perl_failure ();
 682
 683   CAMLreturn (list);
 684 }
 685
 686 CAMLprim value
 687 perl4caml_call_void (value optsv, value optfnname, value arglist)
 688 {
 689   CAMLparam3 (optsv, optfnname, arglist);
 690   dSP;
 691   int count;
 692   SV *sv;
 693   CAMLlocal3 (errv, svv, fnname);
 694
 695   ENTER;
 696   SAVETMPS;
 697
 698   /* Push the parameter list. */
 699   PUSHMARK (SP);
 700
 701   /* Iteration over the linked list. */
 702   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 703     {
 704       svv = Field (arglist, 0);
 705       sv = Sv_val (svv);
 706       XPUSHs (sv_2mortal (newSVsv (sv)));
 707     }
 708
 709   PUTBACK;
 710
 711   if (optsv != Val_int (0))
 712     {
 713       svv = unoption (optsv, Val_false);
 714       sv = Sv_val (svv);
 715       count = call_sv (sv, G_EVAL|G_VOID);
 716     }
 717   else if (optfnname != Val_int (0))
 718     {
 719       fnname = unoption (optfnname, Val_false);
 720       count = call_pv (String_val (fnname), G_EVAL|G_VOID|G_DISCARD);
 721     }
 722   else
 723     {
 724       fprintf (stderr,
 725                "Perl.call_void: must supply either 'sv' or 'fn' parameters.");
 726       abort ();
 727     }
 728
 729   SPAGAIN;
 730
 731   assert (count == 0);
 732
 733   /* Restore the stack. */
 734   PUTBACK;
 735   FREETMPS;
 736   LEAVE;
 737
 738   check_perl_failure ();
 739
 740   CAMLreturn (Val_unit);
 741 }
 742
 743 CAMLprim value
 744 perl4caml_eval (value expr)
 745 {
 746   CAMLparam1 (expr);
 747   dSP;
 748   SV *sv;
 749   CAMLlocal2 (errv, svv);
 750
 751   sv = eval_pv (String_val (expr), G_SCALAR);
 752
 753   check_perl_failure ();
 754
 755   svv = Val_sv (sv);
 756   CAMLreturn (svv);
 757 }
 758
 759 CAMLprim value
 760 perl4caml_call_method (value ref, value name, value arglist)
 761 {
 762   CAMLparam3 (ref, name, arglist);
 763   dSP;
 764   int count;
 765   SV *sv;
 766   CAMLlocal2 (errv, svv);
 767
 768   ENTER;
 769   SAVETMPS;
 770
 771   /* Push the parameter list. */
 772   PUSHMARK (SP);
 773
 774   sv = Sv_val (ref);
 775   XPUSHs (sv_2mortal (newSVsv (sv)));
 776
 777   /* Iteration over the linked list. */
 778   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 779     {
 780       svv = Field (arglist, 0);
 781       sv = Sv_val (svv);
 782       XPUSHs (sv_2mortal (newSVsv (sv)));
 783     }
 784
 785   PUTBACK;
 786
 787   count = call_method (String_val (name), G_EVAL|G_SCALAR);
 788
 789   SPAGAIN;
 790
 791   assert (count == 1); /* Pretty sure it should never be anything else. */
 792
 793   /* Pop return value off the stack. Note that the return value on the
 794    * stack is mortal, so we need to take a copy.
 795    */
 796   sv = newSVsv (POPs);
 797   PUTBACK;
 798   FREETMPS;
 799   LEAVE;
 800
 801   check_perl_failure ();
 802
 803   svv = Val_sv (sv);
 804   CAMLreturn (svv);
 805 }
 806
 807 CAMLprim value
 808 perl4caml_call_method_array (value ref, value name, value arglist)
 809 {
 810   CAMLparam3 (ref, name, arglist);
 811   dSP;
 812   int count, i;
 813   SV *sv;
 814   CAMLlocal4 (errv, svv, list, cons);
 815
 816   ENTER;
 817   SAVETMPS;
 818
 819   /* Push the parameter list. */
 820   PUSHMARK (SP);
 821
 822   sv = Sv_val (ref);
 823   XPUSHs (sv_2mortal (newSVsv (sv)));
 824
 825   /* Iteration over the linked list. */
 826   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 827     {
 828       svv = Field (arglist, 0);
 829       sv = Sv_val (svv);
 830       XPUSHs (sv_2mortal (newSVsv (sv)));
 831     }
 832
 833   PUTBACK;
 834
 835   count = call_method (String_val (name), G_EVAL|G_ARRAY);
 836
 837   SPAGAIN;
 838
 839   /* Pop all return values off the stack. Note that the return values on the
 840    * stack are mortal, so we need to take a copy.
 841    */
 842   list = Val_int (0);
 843   for (i = 0; i < count; ++i) {
 844     SV *sv;
 845
 846     cons = caml_alloc (2, 0);
 847     Field (cons, 1) = list;
 848     list = cons;
 849     sv = newSVsv (POPs);
 850     Field (cons, 0) = Val_sv (sv);
 851   }
 852
 853   /* Restore the stack. */
 854   PUTBACK;
 855   FREETMPS;
 856   LEAVE;
 857
 858   check_perl_failure ();
 859
 860   CAMLreturn (list);
 861 }
 862
 863 CAMLprim value
 864 perl4caml_call_method_void (value ref, value name, value arglist)
 865 {
 866   CAMLparam3 (ref, name, arglist);
 867   dSP;
 868   int count;
 869   SV *sv;
 870   CAMLlocal2 (errv, svv);
 871
 872   ENTER;
 873   SAVETMPS;
 874
 875   /* Push the parameter list. */
 876   PUSHMARK (SP);
 877
 878   sv = Sv_val (ref);
 879   XPUSHs (sv_2mortal (newSVsv (sv)));
 880
 881   /* Iteration over the linked list. */
 882   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 883     {
 884       svv = Field (arglist, 0);
 885       sv = Sv_val (svv);
 886       XPUSHs (sv_2mortal (newSVsv (sv)));
 887     }
 888
 889   PUTBACK;
 890
 891   count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD);
 892
 893   SPAGAIN;
 894
 895   assert (count == 0);
 896
 897   /* Restore the stack. */
 898   PUTBACK;
 899   FREETMPS;
 900   LEAVE;
 901
 902   check_perl_failure ();
 903
 904   CAMLreturn (Val_unit);
 905 }
 906
 907 CAMLprim value
 908 perl4caml_call_class_method (value classname, value name, value arglist)
 909 {
 910   CAMLparam3 (classname, name, arglist);
 911   dSP;
 912   int count;
 913   SV *sv;
 914   CAMLlocal2 (errv, svv);
 915
 916   ENTER;
 917   SAVETMPS;
 918
 919   /* Push the parameter list. */
 920   PUSHMARK (SP);
 921
 922   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
 923
 924   /* Iteration over the linked list. */
 925   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 926     {
 927       svv = Field (arglist, 0);
 928       sv = Sv_val (svv);
 929       XPUSHs (sv_2mortal (newSVsv (sv)));
 930     }
 931
 932   PUTBACK;
 933
 934   count = call_method (String_val (name), G_EVAL|G_SCALAR);
 935
 936   SPAGAIN;
 937
 938   assert (count == 1); /* Pretty sure it should never be anything else. */
 939
 940   /* Pop return value off the stack. Note that the return value on the
 941    * stack is mortal, so we need to take a copy.
 942    */
 943   sv = newSVsv (POPs);
 944   PUTBACK;
 945   FREETMPS;
 946   LEAVE;
 947
 948   check_perl_failure ();
 949
 950   svv = Val_sv (sv);
 951   CAMLreturn (svv);
 952 }
 953
 954 CAMLprim value
 955 perl4caml_call_class_method_array (value classname, value name, value arglist)
 956 {
 957   CAMLparam3 (classname, name, arglist);
 958   dSP;
 959   int count, i;
 960   SV *sv;
 961   CAMLlocal4 (errv, svv, list, cons);
 962
 963   ENTER;
 964   SAVETMPS;
 965
 966   /* Push the parameter list. */
 967   PUSHMARK (SP);
 968
 969   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
 970
 971   /* Iteration over the linked list. */
 972   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 973     {
 974       svv = Field (arglist, 0);
 975       sv = Sv_val (svv);
 976       XPUSHs (sv_2mortal (newSVsv (sv)));
 977     }
 978
 979   PUTBACK;
 980
 981   count = call_method (String_val (name), G_EVAL|G_ARRAY);
 982
 983   SPAGAIN;
 984
 985   /* Pop all return values off the stack. Note that the return values on the
 986    * stack are mortal, so we need to take a copy.
 987    */
 988   list = Val_int (0);
 989   for (i = 0; i < count; ++i) {
 990     cons = caml_alloc (2, 0);
 991     Field (cons, 1) = list;
 992     list = cons;
 993     Field (cons, 0) = Val_sv (newSVsv (POPs));
 994   }
 995
 996   /* Restore the stack. */
 997   PUTBACK;
 998   FREETMPS;
 999   LEAVE;
1000
1001   check_perl_failure ();
1002
1003   CAMLreturn (list);
1004 }
1005
1006 CAMLprim value
1007 perl4caml_call_class_method_void (value classname, value name, value arglist)
1008 {
1009   CAMLparam3 (classname, name, arglist);
1010   dSP;
1011   int count;
1012   SV *sv;
1013   CAMLlocal2 (errv, svv);
1014
1015   ENTER;
1016   SAVETMPS;
1017
1018   /* Push the parameter list. */
1019   PUSHMARK (SP);
1020
1021   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
1022
1023   /* Iteration over the linked list. */
1024   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1025     {
1026       svv = Field (arglist, 0);
1027       sv = Sv_val (svv);
1028       XPUSHs (sv_2mortal (newSVsv (sv)));
1029     }
1030
1031   PUTBACK;
1032
1033   count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD);
1034
1035   SPAGAIN;
1036
1037   assert (count == 0);
1038
1039   /* Restore the stack. */
1040   PUTBACK;
1041   FREETMPS;
1042   LEAVE;
1043
1044   check_perl_failure ();
1045
1046   CAMLreturn (Val_unit);
1047 }
1048
1049 static value
1050 Val_voidptr (void *ptr)
1051 {
1052   CAMLparam0 ();
1053   CAMLlocal1 (rv);
1054   rv = caml_alloc (1, Abstract_tag);
1055   Field(rv, 0) = (value) ptr;
1056   CAMLreturn (rv);
1057 }
1058
1059 #if PERL4CAML_REFCOUNTING_EXPERIMENTAL
1060
1061 static void
1062 xv_finalize (value v)
1063 {
1064   SvREFCNT_dec ((SV *) Xv_val (v));
1065 }
1066
1067 static struct custom_operations xv_custom_operations = {
1068   "xv_custom_operations",
1069   xv_finalize,
1070   custom_compare_default,
1071   custom_hash_default,
1072   custom_serialize_default,
1073   custom_deserialize_default
1074 };
1075
1076 static value
1077 Val_xv (SV *sv)
1078 {
1079   CAMLparam0 ();
1080   CAMLlocal1 (rv);
1081   rv = caml_alloc_custom (&xv_custom_operations, sizeof (void *), 0, 1);
1082   Xv_val (rv) = sv;
1083   CAMLreturn (rv);
1084 }
1085
1086 #endif /* PERL4CAML_REFCOUNTING_EXPERIMENTAL */
1087
1088 static value
1089 unoption (value option, value deflt)
1090 {
1091   if (option == Val_int (0))    /* "None" */
1092     return deflt;
1093   else                          /* "Some 'a" */
1094     return Field (option, 0);
1095 }