perl_c.c

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