perl_c.c

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