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