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   CAMLparam0 ();
 723   CAMLlocal1 (errv);
 724
 725   SV *errsv = get_sv ("@", TRUE);
 726
 727   if (SvTRUE (errsv))           /* Equivalent of $@ in Perl. */
 728     {
 729       STRLEN n_a;
 730       const char *err = SvPV (errsv, n_a);
 731
 732       errv = caml_copy_string (err);
 733
 734       caml_raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
 735     }
 736
 737   CAMLreturn0;
 738 }
 739
 740 CAMLprim value
 741 perl4caml_call (value optsv, value optfnname, value arglist)
 742 {
 743   CAMLparam3 (optsv, optfnname, arglist);
 744   dSP;
 745   int count;
 746   SV *sv;
 747   CAMLlocal3 (errv, svv, fnname);
 748
 749   ENTER;
 750   SAVETMPS;
 751
 752   /* Push the parameter list. */
 753   PUSHMARK (SP);
 754
 755   /* Iteration over the linked list. */
 756   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 757     {
 758       svv = Field (arglist, 0);
 759       sv = Sv_val (svv);
 760       XPUSHs (sv_2mortal (newSVsv (sv)));
 761     }
 762
 763   PUTBACK;
 764
 765   if (optsv != Val_int (0))
 766     {
 767       svv = unoption (optsv, Val_false);
 768       sv = Sv_val (svv);
 769       count = call_sv (sv, G_EVAL|G_SCALAR);
 770     }
 771   else if (optfnname != Val_int (0))
 772     {
 773       fnname = unoption (optfnname, Val_false);
 774       count = call_pv (String_val (fnname), G_EVAL|G_SCALAR);
 775     }
 776   else
 777     {
 778       fprintf (stderr,
 779                "Perl.call: must supply either 'sv' or 'fn' parameters.");
 780       abort ();
 781     }
 782
 783   SPAGAIN;
 784
 785   assert (count == 1); /* Pretty sure it should never be anything else. */
 786
 787   /* Pop return value off the stack. Note that the return value on the
 788    * stack is mortal, so we need to take a copy.
 789    */
 790   sv = newSVsv (POPs);
 791   PUTBACK;
 792   FREETMPS;
 793   LEAVE;
 794
 795   check_perl_failure ();
 796
 797   svv = Val_sv (sv);
 798   CAMLreturn (svv);
 799 }
 800
 801 CAMLprim value
 802 perl4caml_call_array (value optsv, value optfnname, value arglist)
 803 {
 804   CAMLparam3 (optsv, optfnname, arglist);
 805   dSP;
 806   int i, count;
 807   SV *sv;
 808   CAMLlocal5 (errv, svv, fnname, list, cons);
 809
 810   ENTER;
 811   SAVETMPS;
 812
 813   /* Push the parameter list. */
 814   PUSHMARK (SP);
 815
 816   /* Iteration over the linked list. */
 817   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 818     {
 819       svv = Field (arglist, 0);
 820       sv = Sv_val (svv);
 821       XPUSHs (sv_2mortal (newSVsv (sv)));
 822     }
 823
 824   PUTBACK;
 825
 826   if (optsv != Val_int (0))
 827     {
 828       svv = unoption (optsv, Val_false);
 829       sv = Sv_val (svv);
 830       count = call_sv (sv, G_EVAL|G_ARRAY);
 831     }
 832   else if (optfnname != Val_int (0))
 833     {
 834       fnname = unoption (optfnname, Val_false);
 835       count = call_pv (String_val (fnname), G_EVAL|G_ARRAY);
 836     }
 837   else
 838     {
 839       fprintf (stderr,
 840                "Perl.call_array: must supply either 'sv' or 'fn' parameters.");
 841       abort ();
 842     }
 843
 844   SPAGAIN;
 845
 846   /* Pop all the return values off the stack into a list. Values on the
 847    * stack are mortal, so we must copy them.
 848    */
 849   list = Val_int (0);
 850   for (i = 0; i < count; ++i) {
 851     SV *sv;
 852
 853     cons = caml_alloc (2, 0);
 854     Field (cons, 1) = list;
 855     list = cons;
 856     sv = newSVsv (POPs);
 857     Field (cons, 0) = Val_sv (sv);
 858   }
 859
 860   /* Restore the stack. */
 861   PUTBACK;
 862   FREETMPS;
 863   LEAVE;
 864
 865   check_perl_failure ();
 866
 867   CAMLreturn (list);
 868 }
 869
 870 CAMLprim value
 871 perl4caml_call_void (value optsv, value optfnname, value arglist)
 872 {
 873   CAMLparam3 (optsv, optfnname, arglist);
 874   dSP;
 875   int count;
 876   SV *sv;
 877   CAMLlocal3 (errv, svv, fnname);
 878
 879   ENTER;
 880   SAVETMPS;
 881
 882   /* Push the parameter list. */
 883   PUSHMARK (SP);
 884
 885   /* Iteration over the linked list. */
 886   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 887     {
 888       svv = Field (arglist, 0);
 889       sv = Sv_val (svv);
 890       XPUSHs (sv_2mortal (newSVsv (sv)));
 891     }
 892
 893   PUTBACK;
 894
 895   if (optsv != Val_int (0))
 896     {
 897       svv = unoption (optsv, Val_false);
 898       sv = Sv_val (svv);
 899       count = call_sv (sv, G_EVAL|G_VOID);
 900     }
 901   else if (optfnname != Val_int (0))
 902     {
 903       fnname = unoption (optfnname, Val_false);
 904       count = call_pv (String_val (fnname), G_EVAL|G_VOID|G_DISCARD);
 905     }
 906   else
 907     {
 908       fprintf (stderr,
 909                "Perl.call_void: must supply either 'sv' or 'fn' parameters.");
 910       abort ();
 911     }
 912
 913   SPAGAIN;
 914
 915   assert (count == 0);
 916
 917   /* Restore the stack. */
 918   PUTBACK;
 919   FREETMPS;
 920   LEAVE;
 921
 922   check_perl_failure ();
 923
 924   CAMLreturn (Val_unit);
 925 }
 926
 927 CAMLprim value
 928 perl4caml_eval (value expr)
 929 {
 930   CAMLparam1 (expr);
 931   dSP;
 932   SV *sv;
 933   CAMLlocal2 (errv, svv);
 934
 935   sv = eval_pv (String_val (expr), G_SCALAR);
 936
 937   check_perl_failure ();
 938
 939   svv = Val_sv (sv);
 940   CAMLreturn (svv);
 941 }
 942
 943 CAMLprim value
 944 perl4caml_call_method (value ref, value name, value arglist)
 945 {
 946   CAMLparam3 (ref, name, arglist);
 947   dSP;
 948   int count;
 949   SV *sv;
 950   CAMLlocal2 (errv, svv);
 951
 952   ENTER;
 953   SAVETMPS;
 954
 955   /* Push the parameter list. */
 956   PUSHMARK (SP);
 957
 958   sv = Sv_val (ref);
 959   XPUSHs (sv_2mortal (newSVsv (sv)));
 960
 961   /* Iteration over the linked list. */
 962   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 963     {
 964       svv = Field (arglist, 0);
 965       sv = Sv_val (svv);
 966       XPUSHs (sv_2mortal (newSVsv (sv)));
 967     }
 968
 969   PUTBACK;
 970
 971   count = call_method (String_val (name), G_EVAL|G_SCALAR);
 972
 973   SPAGAIN;
 974
 975   assert (count == 1); /* Pretty sure it should never be anything else. */
 976
 977   /* Pop return value off the stack. Note that the return value on the
 978    * stack is mortal, so we need to take a copy.
 979    */
 980   sv = newSVsv (POPs);
 981   PUTBACK;
 982   FREETMPS;
 983   LEAVE;
 984
 985   check_perl_failure ();
 986
 987   svv = Val_sv (sv);
 988   CAMLreturn (svv);
 989 }
 990
 991 CAMLprim value
 992 perl4caml_call_method_array (value ref, value name, value arglist)
 993 {
 994   CAMLparam3 (ref, name, arglist);
 995   dSP;
 996   int count, i;
 997   SV *sv;
 998   CAMLlocal4 (errv, svv, list, cons);
 999
1000   ENTER;
1001   SAVETMPS;
1002
1003   /* Push the parameter list. */
1004   PUSHMARK (SP);
1005
1006   sv = Sv_val (ref);
1007   XPUSHs (sv_2mortal (newSVsv (sv)));
1008
1009   /* Iteration over the linked list. */
1010   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1011     {
1012       svv = Field (arglist, 0);
1013       sv = Sv_val (svv);
1014       XPUSHs (sv_2mortal (newSVsv (sv)));
1015     }
1016
1017   PUTBACK;
1018
1019   count = call_method (String_val (name), G_EVAL|G_ARRAY);
1020
1021   SPAGAIN;
1022
1023   /* Pop all return values off the stack. Note that the return values on the
1024    * stack are mortal, so we need to take a copy.
1025    */
1026   list = Val_int (0);
1027   for (i = 0; i < count; ++i) {
1028     SV *sv;
1029
1030     cons = caml_alloc (2, 0);
1031     Field (cons, 1) = list;
1032     list = cons;
1033     sv = newSVsv (POPs);
1034     Field (cons, 0) = Val_sv (sv);
1035   }
1036
1037   /* Restore the stack. */
1038   PUTBACK;
1039   FREETMPS;
1040   LEAVE;
1041
1042   check_perl_failure ();
1043
1044   CAMLreturn (list);
1045 }
1046
1047 CAMLprim value
1048 perl4caml_call_method_void (value ref, value name, value arglist)
1049 {
1050   CAMLparam3 (ref, name, arglist);
1051   dSP;
1052   int count;
1053   SV *sv;
1054   CAMLlocal2 (errv, svv);
1055
1056   ENTER;
1057   SAVETMPS;
1058
1059   /* Push the parameter list. */
1060   PUSHMARK (SP);
1061
1062   sv = Sv_val (ref);
1063   XPUSHs (sv_2mortal (newSVsv (sv)));
1064
1065   /* Iteration over the linked list. */
1066   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1067     {
1068       svv = Field (arglist, 0);
1069       sv = Sv_val (svv);
1070       XPUSHs (sv_2mortal (newSVsv (sv)));
1071     }
1072
1073   PUTBACK;
1074
1075   count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD);
1076
1077   SPAGAIN;
1078
1079   assert (count == 0);
1080
1081   /* Restore the stack. */
1082   PUTBACK;
1083   FREETMPS;
1084   LEAVE;
1085
1086   check_perl_failure ();
1087
1088   CAMLreturn (Val_unit);
1089 }
1090
1091 CAMLprim value
1092 perl4caml_call_class_method (value classname, value name, value arglist)
1093 {
1094   CAMLparam3 (classname, name, arglist);
1095   dSP;
1096   int count;
1097   SV *sv;
1098   CAMLlocal2 (errv, svv);
1099
1100   ENTER;
1101   SAVETMPS;
1102
1103   /* Push the parameter list. */
1104   PUSHMARK (SP);
1105
1106   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
1107
1108   /* Iteration over the linked list. */
1109   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1110     {
1111       svv = Field (arglist, 0);
1112       sv = Sv_val (svv);
1113       XPUSHs (sv_2mortal (newSVsv (sv)));
1114     }
1115
1116   PUTBACK;
1117
1118   count = call_method (String_val (name), G_EVAL|G_SCALAR);
1119
1120   SPAGAIN;
1121
1122   assert (count == 1); /* Pretty sure it should never be anything else. */
1123
1124   /* Pop return value off the stack. Note that the return value on the
1125    * stack is mortal, so we need to take a copy.
1126    */
1127   sv = newSVsv (POPs);
1128   PUTBACK;
1129   FREETMPS;
1130   LEAVE;
1131
1132   check_perl_failure ();
1133
1134   svv = Val_sv (sv);
1135   CAMLreturn (svv);
1136 }
1137
1138 CAMLprim value
1139 perl4caml_call_class_method_array (value classname, value name, value arglist)
1140 {
1141   CAMLparam3 (classname, name, arglist);
1142   dSP;
1143   int count, i;
1144   SV *sv;
1145   CAMLlocal4 (errv, svv, list, cons);
1146
1147   ENTER;
1148   SAVETMPS;
1149
1150   /* Push the parameter list. */
1151   PUSHMARK (SP);
1152
1153   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
1154
1155   /* Iteration over the linked list. */
1156   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1157     {
1158       svv = Field (arglist, 0);
1159       sv = Sv_val (svv);
1160       XPUSHs (sv_2mortal (newSVsv (sv)));
1161     }
1162
1163   PUTBACK;
1164
1165   count = call_method (String_val (name), G_EVAL|G_ARRAY);
1166
1167   SPAGAIN;
1168
1169   /* Pop all return values off the stack. Note that the return values on the
1170    * stack are mortal, so we need to take a copy.
1171    */
1172   list = Val_int (0);
1173   for (i = 0; i < count; ++i) {
1174     cons = caml_alloc (2, 0);
1175     Field (cons, 1) = list;
1176     list = cons;
1177     Field (cons, 0) = Val_sv (newSVsv (POPs));
1178   }
1179
1180   /* Restore the stack. */
1181   PUTBACK;
1182   FREETMPS;
1183   LEAVE;
1184
1185   check_perl_failure ();
1186
1187   CAMLreturn (list);
1188 }
1189
1190 CAMLprim value
1191 perl4caml_call_class_method_void (value classname, value name, value arglist)
1192 {
1193   CAMLparam3 (classname, name, arglist);
1194   dSP;
1195   int count;
1196   SV *sv;
1197   CAMLlocal2 (errv, svv);
1198
1199   ENTER;
1200   SAVETMPS;
1201
1202   /* Push the parameter list. */
1203   PUSHMARK (SP);
1204
1205   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
1206
1207   /* Iteration over the linked list. */
1208   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1209     {
1210       svv = Field (arglist, 0);
1211       sv = Sv_val (svv);
1212       XPUSHs (sv_2mortal (newSVsv (sv)));
1213     }
1214
1215   PUTBACK;
1216
1217   count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD);
1218
1219   SPAGAIN;
1220
1221   assert (count == 0);
1222
1223   /* Restore the stack. */
1224   PUTBACK;
1225   FREETMPS;
1226   LEAVE;
1227
1228   check_perl_failure ();
1229
1230   CAMLreturn (Val_unit);
1231 }
1232
1233 static value
1234 Val_voidptr (void *ptr)
1235 {
1236   CAMLparam0 ();
1237   CAMLlocal1 (rv);
1238   rv = caml_alloc (1, Abstract_tag);
1239   Field(rv, 0) = (value) ptr;
1240   CAMLreturn (rv);
1241 }
1242
1243 #if PERL4CAML_REFCOUNTING_EXPERIMENTAL
1244
1245 static void
1246 xv_finalize (value v)
1247 {
1248   /*fprintf (stderr, "about to decrement %p\n", Xv_val (v));*/
1249   SvREFCNT_dec ((SV *) Xv_val (v));
1250 }
1251
1252 static struct custom_operations xv_custom_operations = {
1253   "xv_custom_operations",
1254   xv_finalize,
1255   custom_compare_default,
1256   custom_hash_default,
1257   custom_serialize_default,
1258   custom_deserialize_default
1259 };
1260
1261 static value
1262 Val_xv (SV *sv)
1263 {
1264   CAMLparam0 ();
1265   CAMLlocal1 (rv);
1266   rv = caml_alloc_custom (&xv_custom_operations, sizeof (void *), 0, 1);
1267   Xv_val (rv) = sv;
1268   CAMLreturn (rv);
1269 }
1270
1271 #endif /* PERL4CAML_REFCOUNTING_EXPERIMENTAL */
1272
1273 static value
1274 unoption (value option, value deflt)
1275 {
1276   if (option == Val_int (0))    /* "None" */
1277     return deflt;
1278   else                          /* "Some 'a" */
1279     return Field (option, 0);
1280 }