perl_c.c

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