perl_c.c

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