perl_c.c

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