perl_c.c

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