perl_c.c

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