perl_c.c

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