perl_c.c

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