perl_c.c

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