perl_c.c

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