perl_c.c

   1 /* Interface to Perl from OCaml.
   2  * Copyright (C) 2003 Merjis Ltd.
   3  * $Id: perl_c.c,v 1.18 2004-12-11 13:38:32 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/custom.h>
  15 #include <caml/fail.h>
  16 #include <caml/memory.h>
  17 #include <caml/mlvalues.h>
  18
  19 #ifndef PERL4CAML_NO_OFF64_T
  20 /* XXX This was required to avoid an error on my machine when loading the Perl
  21  * headers. Not clear why this is missing.
  22  */
  23 #define off64_t __off64_t
  24 #endif
  25
  26 #ifndef PERL4CAML_NO_CRYPT_H
  27 /* XXX This is required by Perl >= 5.8.2. */
  28 #define __USE_GNU
  29 #include <crypt.h>
  30 #endif
  31
  32 #include <EXTERN.h>
  33 #include <perl.h>
  34
  35 /* Perl requires the interpreter to be called literally 'my_perl'! */
  36 static PerlInterpreter *my_perl;
  37
  38 /* Get the concrete value from an optional field. */
  39 static value unoption (value option, value deflt);
  40
  41 /* Wrap up an arbitrary void pointer in an opaque OCaml object. */
  42 static value Val_voidptr (void *ptr);
  43
  44 /* Unwrap an arbitrary void pointer from an opaque OCaml object. */
  45 #define Voidptr_val(type,rv) ((type *) Field ((rv), 0))
  46
  47 #if PERL4CAML_REFCOUNTING_EXPERIMENTAL
  48
  49 /* Unwrap a custom block. */
  50 #define Xv_val(rv) (*((void **)Data_custom_val(rv)))
  51
  52 /* Wrap up an SV, AV or HV in a custom OCaml object which will decrement
  53  * the reference count on finalization.
  54  */
  55 static value Val_xv (SV *sv);
  56
  57 #else
  58
  59 #define Xv_val(rv) Voidptr_val (SV, (rv))
  60 #define Val_xv(sv) Val_voidptr ((sv))
  61
  62 #endif
  63
  64 /* Hide Perl types in opaque OCaml objects. */
  65 #define Val_perl(pl) (Val_voidptr ((pl)))
  66 #define Perl_val(plv) (Voidptr_val (PerlInterpreter, (plv)))
  67 #define Val_sv(sv) (Val_xv ((sv)))
  68 #define Sv_val(svv) ((SV *) Xv_val (svv))
  69 #define Val_av(av) (Val_xv ((SV *)(av)))
  70 #define Av_val(avv) ((AV *) Xv_val (avv))
  71 #define Val_hv(hv) (Val_xv ((SV *)(hv)))
  72 #define Hv_val(hvv) ((HV *) Xv_val (hvv))
  73
  74 static void
  75 xs_init (pTHX)
  76 {
  77   char *file = __FILE__;
  78   EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
  79
  80   newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  81 }
  82
  83 CAMLprim value
  84 perl4caml_init (value unit)
  85 {
  86   CAMLparam1 (unit);
  87   int argc = 4;
  88   static char *argv[] = { "", "-w", "-e", "0" };
  89
  90   PERL_SYS_INIT3 (NULL, NULL, NULL);
  91   my_perl = perl_alloc ();
  92   perl_construct (my_perl);
  93   PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
  94   perl_parse (my_perl, xs_init, argc, argv, NULL);
  95   /*perl_run (my_perl);*/
  96
  97   CAMLreturn (Val_unit);
  98 }
  99
 100 CAMLprim value
 101 perl4caml_int_of_sv (value svv)
 102 {
 103   CAMLparam1 (svv);
 104   SV *sv = Sv_val (svv);
 105   CAMLreturn (Val_int (SvIV (sv)));
 106 }
 107
 108 CAMLprim value
 109 perl4caml_sv_of_int (value iv)
 110 {
 111   CAMLparam1 (iv);
 112   CAMLreturn (Val_sv (newSViv (Int_val (iv))));
 113 }
 114
 115 CAMLprim value
 116 perl4caml_float_of_sv (value svv)
 117 {
 118   CAMLparam1 (svv);
 119   SV *sv = Sv_val (svv);
 120   CAMLlocal1 (f);
 121   f = copy_double (SvNV (sv));
 122   CAMLreturn (f);
 123 }
 124
 125 CAMLprim value
 126 perl4caml_sv_of_float (value fv)
 127 {
 128   CAMLparam1 (fv);
 129   CAMLreturn (Val_sv (newSViv (Double_val (fv))));
 130 }
 131
 132 CAMLprim value
 133 perl4caml_string_of_sv (value svv)
 134 {
 135   CAMLparam1 (svv);
 136   SV *sv = Sv_val (svv);
 137   char *str;
 138   STRLEN len;
 139   CAMLlocal1 (strv);
 140   str = SvPV (sv, len);
 141   /* XXX This won't work if the string contains NUL. */
 142   strv = copy_string (str);
 143   CAMLreturn (strv);
 144 }
 145
 146 CAMLprim value
 147 perl4caml_sv_of_string (value strv)
 148 {
 149   CAMLparam1 (strv);
 150   CAMLreturn (Val_sv (newSVpv (String_val (strv), string_length (strv))));
 151 }
 152
 153 CAMLprim value
 154 perl4caml_sv_is_true (value svv)
 155 {
 156   CAMLparam1 (svv);
 157   SV *sv = Sv_val (svv);
 158   CAMLreturn (SvTRUE (sv) ? Val_true : Val_false);
 159 }
 160
 161 CAMLprim value
 162 perl4caml_sv_undef (value unit)
 163 {
 164   CAMLparam1 (unit);
 165   /*CAMLreturn (Val_sv (newSV (0)));*/
 166   CAMLreturn (Val_sv (&PL_sv_undef));
 167 }
 168
 169 CAMLprim value
 170 perl4caml_sv_is_undef (value svv)
 171 {
 172   CAMLparam1 (svv);
 173   SV *sv = Sv_val (svv);
 174   CAMLreturn (!SvPOK (sv) && !SvIOK (sv) && SvTYPE (sv) == SVt_NULL
 175               ? Val_true : Val_false);
 176 }
 177
 178 CAMLprim value
 179 perl4caml_sv_yes (value unit)
 180 {
 181   CAMLparam1 (unit);
 182   CAMLreturn (Val_sv (&PL_sv_yes));
 183 }
 184
 185 CAMLprim value
 186 perl4caml_sv_no (value unit)
 187 {
 188   CAMLparam1 (unit);
 189   CAMLreturn (Val_sv (&PL_sv_no));
 190 }
 191
 192 CAMLprim value
 193 perl4caml_sv_type (value svv)
 194 {
 195   CAMLparam1 (svv);
 196   SV *sv = Sv_val (svv);
 197
 198   switch (SvTYPE (sv))
 199     {
 200     case SVt_IV: CAMLreturn (Val_int (1));
 201     case SVt_NV: CAMLreturn (Val_int (2));
 202     case SVt_PV: CAMLreturn (Val_int (3));
 203     case SVt_RV: CAMLreturn (Val_int (4));
 204     case SVt_PVAV: CAMLreturn (Val_int (5));
 205     case SVt_PVHV: CAMLreturn (Val_int (6));
 206     case SVt_PVCV: CAMLreturn (Val_int (7));
 207     case SVt_PVGV: CAMLreturn (Val_int (8));
 208     case SVt_PVMG: CAMLreturn (Val_int (9));
 209     default: CAMLreturn (Val_int (0));
 210     }
 211 }
 212
 213 CAMLprim value
 214 perl4caml_scalarref (value svv)
 215 {
 216   CAMLparam1 (svv);
 217   CAMLlocal1 (rsvv);
 218   SV *sv = Sv_val (svv);
 219   rsvv = Val_sv (newRV_inc (sv));
 220   CAMLreturn (rsvv);
 221 }
 222
 223 CAMLprim value
 224 perl4caml_arrayref (value avv)
 225 {
 226   CAMLparam1 (avv);
 227   CAMLlocal1 (rsvv);
 228   AV *av = Av_val (avv);
 229   rsvv = Val_sv (newRV_inc ((SV *) av));
 230   CAMLreturn (rsvv);
 231 }
 232
 233 CAMLprim value
 234 perl4caml_hashref (value hvv)
 235 {
 236   CAMLparam1 (hvv);
 237   CAMLlocal1 (rsvv);
 238   HV *hv = Hv_val (hvv);
 239   rsvv = Val_sv (newRV_inc ((SV *) hv));
 240   CAMLreturn (rsvv);
 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 (!SvROK (sv))
 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 (!SvROK (sv))
 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 (!SvROK (sv))
 293     invalid_argument ("deref_hash: SV is not a reference");
 294   switch (SvTYPE (SvRV (sv))) {
 295   case SVt_PVHV:
 296     break;
 297   default:
 298     invalid_argument ("deref_hash: 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     SV *sv;
 679
 680     cons = alloc (2, 0);
 681     Field (cons, 1) = list;
 682     list = cons;
 683     sv = newSVsv (POPs);
 684     Field (cons, 0) = Val_sv (sv);
 685   }
 686
 687   /* Restore the stack. */
 688   PUTBACK;
 689   FREETMPS;
 690   LEAVE;
 691
 692   check_perl_failure ();
 693
 694   CAMLreturn (list);
 695 }
 696
 697 CAMLprim value
 698 perl4caml_call_void (value optsv, value optfnname, value arglist)
 699 {
 700   CAMLparam3 (optsv, optfnname, arglist);
 701   dSP;
 702   int count;
 703   SV *sv;
 704   CAMLlocal3 (errv, svv, fnname);
 705
 706   ENTER;
 707   SAVETMPS;
 708
 709   /* Push the parameter list. */
 710   PUSHMARK (SP);
 711
 712   /* Iteration over the linked list. */
 713   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 714     {
 715       svv = Field (arglist, 0);
 716       sv = Sv_val (svv);
 717       XPUSHs (sv_2mortal (newSVsv (sv)));
 718     }
 719
 720   PUTBACK;
 721
 722   if (optsv != Val_int (0))
 723     {
 724       svv = unoption (optsv, Val_false);
 725       sv = Sv_val (svv);
 726       count = call_sv (sv, G_EVAL|G_VOID);
 727     }
 728   else if (optfnname != Val_int (0))
 729     {
 730       fnname = unoption (optfnname, Val_false);
 731       count = call_pv (String_val (fnname), G_EVAL|G_VOID|G_DISCARD);
 732     }
 733   else
 734     {
 735       fprintf (stderr,
 736                "Perl.call_void: must supply either 'sv' or 'fn' parameters.");
 737       abort ();
 738     }
 739
 740   SPAGAIN;
 741
 742   assert (count == 0);
 743
 744   /* Restore the stack. */
 745   PUTBACK;
 746   FREETMPS;
 747   LEAVE;
 748
 749   check_perl_failure ();
 750
 751   CAMLreturn (Val_unit);
 752 }
 753
 754 CAMLprim value
 755 perl4caml_eval (value expr)
 756 {
 757   CAMLparam1 (expr);
 758   dSP;
 759   SV *sv;
 760   CAMLlocal2 (errv, svv);
 761
 762   sv = eval_pv (String_val (expr), G_SCALAR);
 763
 764   check_perl_failure ();
 765
 766   svv = Val_sv (sv);
 767   CAMLreturn (svv);
 768 }
 769
 770 CAMLprim value
 771 perl4caml_call_method (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_SCALAR);
 799
 800   SPAGAIN;
 801
 802   assert (count == 1); /* Pretty sure it should never be anything else. */
 803
 804   /* Pop return value off the stack. Note that the return value on the
 805    * stack is mortal, so we need to take a copy.
 806    */
 807   sv = newSVsv (POPs);
 808   PUTBACK;
 809   FREETMPS;
 810   LEAVE;
 811
 812   check_perl_failure ();
 813
 814   svv = Val_sv (sv);
 815   CAMLreturn (svv);
 816 }
 817
 818 CAMLprim value
 819 perl4caml_call_method_array (value ref, value name, value arglist)
 820 {
 821   CAMLparam3 (ref, name, arglist);
 822   dSP;
 823   int count, i;
 824   SV *sv;
 825   CAMLlocal4 (errv, svv, list, cons);
 826
 827   ENTER;
 828   SAVETMPS;
 829
 830   /* Push the parameter list. */
 831   PUSHMARK (SP);
 832
 833   sv = Sv_val (ref);
 834   XPUSHs (sv_2mortal (newSVsv (sv)));
 835
 836   /* Iteration over the linked list. */
 837   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 838     {
 839       svv = Field (arglist, 0);
 840       sv = Sv_val (svv);
 841       XPUSHs (sv_2mortal (newSVsv (sv)));
 842     }
 843
 844   PUTBACK;
 845
 846   count = call_method (String_val (name), G_EVAL|G_ARRAY);
 847
 848   SPAGAIN;
 849
 850   /* Pop all return values off the stack. Note that the return values on the
 851    * stack are mortal, so we need to take a copy.
 852    */
 853   list = Val_int (0);
 854   for (i = 0; i < count; ++i) {
 855     SV *sv;
 856
 857     cons = alloc (2, 0);
 858     Field (cons, 1) = list;
 859     list = cons;
 860     sv = newSVsv (POPs);
 861     Field (cons, 0) = Val_sv (sv);
 862   }
 863
 864   /* Restore the stack. */
 865   PUTBACK;
 866   FREETMPS;
 867   LEAVE;
 868
 869   check_perl_failure ();
 870
 871   CAMLreturn (list);
 872 }
 873
 874 CAMLprim value
 875 perl4caml_call_method_void (value ref, value name, value arglist)
 876 {
 877   CAMLparam3 (ref, name, arglist);
 878   dSP;
 879   int count;
 880   SV *sv;
 881   CAMLlocal2 (errv, svv);
 882
 883   ENTER;
 884   SAVETMPS;
 885
 886   /* Push the parameter list. */
 887   PUSHMARK (SP);
 888
 889   sv = Sv_val (ref);
 890   XPUSHs (sv_2mortal (newSVsv (sv)));
 891
 892   /* Iteration over the linked list. */
 893   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 894     {
 895       svv = Field (arglist, 0);
 896       sv = Sv_val (svv);
 897       XPUSHs (sv_2mortal (newSVsv (sv)));
 898     }
 899
 900   PUTBACK;
 901
 902   count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD);
 903
 904   SPAGAIN;
 905
 906   assert (count == 0);
 907
 908   /* Restore the stack. */
 909   PUTBACK;
 910   FREETMPS;
 911   LEAVE;
 912
 913   check_perl_failure ();
 914
 915   CAMLreturn (Val_unit);
 916 }
 917
 918 CAMLprim value
 919 perl4caml_call_class_method (value classname, value name, value arglist)
 920 {
 921   CAMLparam3 (classname, name, arglist);
 922   dSP;
 923   int count;
 924   SV *sv;
 925   CAMLlocal2 (errv, svv);
 926
 927   ENTER;
 928   SAVETMPS;
 929
 930   /* Push the parameter list. */
 931   PUSHMARK (SP);
 932
 933   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
 934
 935   /* Iteration over the linked list. */
 936   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 937     {
 938       svv = Field (arglist, 0);
 939       sv = Sv_val (svv);
 940       XPUSHs (sv_2mortal (newSVsv (sv)));
 941     }
 942
 943   PUTBACK;
 944
 945   count = call_method (String_val (name), G_EVAL|G_SCALAR);
 946
 947   SPAGAIN;
 948
 949   assert (count == 1); /* Pretty sure it should never be anything else. */
 950
 951   /* Pop return value off the stack. Note that the return value on the
 952    * stack is mortal, so we need to take a copy.
 953    */
 954   sv = newSVsv (POPs);
 955   PUTBACK;
 956   FREETMPS;
 957   LEAVE;
 958
 959   check_perl_failure ();
 960
 961   svv = Val_sv (sv);
 962   CAMLreturn (svv);
 963 }
 964
 965 CAMLprim value
 966 perl4caml_call_class_method_array (value classname, value name, value arglist)
 967 {
 968   CAMLparam3 (classname, name, arglist);
 969   dSP;
 970   int count, i;
 971   SV *sv;
 972   CAMLlocal4 (errv, svv, list, cons);
 973
 974   ENTER;
 975   SAVETMPS;
 976
 977   /* Push the parameter list. */
 978   PUSHMARK (SP);
 979
 980   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
 981
 982   /* Iteration over the linked list. */
 983   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 984     {
 985       svv = Field (arglist, 0);
 986       sv = Sv_val (svv);
 987       XPUSHs (sv_2mortal (newSVsv (sv)));
 988     }
 989
 990   PUTBACK;
 991
 992   count = call_method (String_val (name), G_EVAL|G_ARRAY);
 993
 994   SPAGAIN;
 995
 996   /* Pop all return values off the stack. Note that the return values on the
 997    * stack are mortal, so we need to take a copy.
 998    */
 999   list = Val_int (0);
1000   for (i = 0; i < count; ++i) {
1001     cons = alloc (2, 0);
1002     Field (cons, 1) = list;
1003     list = cons;
1004     Field (cons, 0) = Val_sv (newSVsv (POPs));
1005   }
1006
1007   /* Restore the stack. */
1008   PUTBACK;
1009   FREETMPS;
1010   LEAVE;
1011
1012   check_perl_failure ();
1013
1014   CAMLreturn (list);
1015 }
1016
1017 CAMLprim value
1018 perl4caml_call_class_method_void (value classname, value name, value arglist)
1019 {
1020   CAMLparam3 (classname, name, arglist);
1021   dSP;
1022   int count;
1023   SV *sv;
1024   CAMLlocal2 (errv, svv);
1025
1026   ENTER;
1027   SAVETMPS;
1028
1029   /* Push the parameter list. */
1030   PUSHMARK (SP);
1031
1032   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
1033
1034   /* Iteration over the linked list. */
1035   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1036     {
1037       svv = Field (arglist, 0);
1038       sv = Sv_val (svv);
1039       XPUSHs (sv_2mortal (newSVsv (sv)));
1040     }
1041
1042   PUTBACK;
1043
1044   count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD);
1045
1046   SPAGAIN;
1047
1048   assert (count == 0);
1049
1050   /* Restore the stack. */
1051   PUTBACK;
1052   FREETMPS;
1053   LEAVE;
1054
1055   check_perl_failure ();
1056
1057   CAMLreturn (Val_unit);
1058 }
1059
1060 static value
1061 Val_voidptr (void *ptr)
1062 {
1063   CAMLparam0 ();
1064   CAMLlocal1 (rv);
1065   rv = alloc (1, Abstract_tag);
1066   Field(rv, 0) = (value) ptr;
1067   CAMLreturn (rv);
1068 }
1069
1070 #if PERL4CAML_REFCOUNTING_EXPERIMENTAL
1071
1072 static void
1073 xv_finalize (value v)
1074 {
1075   SvREFCNT_dec ((SV *) Xv_val (v));
1076 }
1077
1078 static struct custom_operations xv_custom_operations = {
1079   "xv_custom_operations",
1080   xv_finalize,
1081   custom_compare_default,
1082   custom_hash_default,
1083   custom_serialize_default,
1084   custom_deserialize_default
1085 };
1086
1087 static value
1088 Val_xv (SV *sv)
1089 {
1090   CAMLparam0 ();
1091   CAMLlocal1 (rv);
1092   rv = alloc_custom (&xv_custom_operations, sizeof (void *), 0, 1);
1093   Xv_val (rv) = sv;
1094   CAMLreturn (rv);
1095 }
1096
1097 #endif /* PERL4CAML_REFCOUNTING_EXPERIMENTAL */
1098
1099 static value
1100 unoption (value option, value deflt)
1101 {
1102   if (option == Val_int (0))    /* "None" */
1103     return deflt;
1104   else                          /* "Some 'a" */
1105     return Field (option, 0);
1106 }