perl_c.c

   1 /* Interface to Perl from OCaml.
   2  * Copyright (C) 2003 Merjis Ltd.
   3  * $Id: perl_c.c,v 1.2 2003-10-12 10:52:00 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/fail.h>
  15 #include <caml/memory.h>
  16 #include <caml/mlvalues.h>
  17
  18 /* XXX This was required to avoid an error on my machine when loading the Perl
  19  * headers. Not clear why this is missing.
  20  */
  21 #define off64_t __off64_t
  22
  23 #include <EXTERN.h>
  24 #include <perl.h>
  25
  26 /* Perl requires the interpreter to be called literally 'my_perl'! */
  27 static PerlInterpreter *my_perl;
  28
  29 /* Wrap up an arbitrary void pointer in an opaque OCaml object. */
  30 static value Val_voidptr (void *ptr);
  31
  32 /* Get the concrete value from an optional field. */
  33 static value unoption (value option, value deflt);
  34
  35 /* Unwrap an arbitrary void pointer from an opaque OCaml object. */
  36 #define Voidptr_val(type,rv) ((type *) Field ((rv), 0))
  37
  38 /* Hide Perl types in opaque OCaml objects. */
  39 #define Val_perl(pl) (Val_voidptr ((pl)))
  40 #define Perl_val(plv) (Voidptr_val (PerlInterpreter, (plv)))
  41 #define Val_sv(sv) (Val_voidptr ((sv)))
  42 #define Sv_val(svv) (Voidptr_val (SV, (svv)))
  43
  44 CAMLprim value
  45 perl4caml_init (value unit)
  46 {
  47   PERL_SYS_INIT3 (NULL, NULL, NULL);
  48   return Val_unit;
  49 }
  50
  51 CAMLprim value
  52 perl4caml_create (value optargs, value unit)
  53 {
  54   CAMLparam2 (optargs, unit);
  55   CAMLlocal1 (args);
  56   int argc, i;
  57   char **argv;
  58   static char *no_args[] = { "", "-e", "0" };
  59
  60   /* Arguments given? */
  61   if (optargs == Val_int (0))   /* "None" */
  62     {
  63       argc = 3;
  64       argv = no_args;
  65     }
  66   else                          /* "Some args" where args is a string array. */
  67     {
  68       args = Field (optargs, 0);
  69       argc = Wosize_val (args);
  70       argv = alloca (argc * sizeof (char *));
  71       for (i = 0; i < argc; ++i) argv[i] = String_val (Field (args, i));
  72     }
  73
  74   my_perl = perl_alloc ();
  75   perl_construct (my_perl);
  76   PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
  77   perl_parse (my_perl, NULL, argc, argv, NULL);
  78   perl_run (my_perl);
  79
  80   CAMLreturn (Val_perl (my_perl));
  81 }
  82
  83 CAMLprim value
  84 perl4caml_destroy (value plv)
  85 {
  86   CAMLparam1 (plv);
  87   PerlInterpreter *pl = Perl_val (plv);
  88
  89   perl_destruct (pl);
  90   perl_free (pl);
  91
  92   CAMLreturn (Val_unit);
  93 }
  94
  95 CAMLprim value
  96 perl4caml_set_context (value plv)
  97 {
  98   CAMLparam1 (plv);
  99   PerlInterpreter *pl = Perl_val (plv);
 100
 101   PERL_SET_CONTEXT (pl);
 102   my_perl = pl;
 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 = 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 (newSViv (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   /* XXX This won't work if the string contains NUL. */
 149   strv = copy_string (str);
 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), string_length (strv))));
 158 }
 159
 160 CAMLprim value
 161 perl4caml_get_sv (value optcreate, value name)
 162 {
 163   CAMLparam2 (optcreate, name);
 164   CAMLlocal1 (create);
 165   SV *sv;
 166
 167   create = unoption (optcreate, Val_false);
 168   sv = get_sv (String_val (name), create == Val_true ? TRUE : FALSE);
 169   if (sv == NULL) raise_not_found ();
 170
 171   CAMLreturn (Val_sv (sv));
 172 }
 173
 174 CAMLprim value
 175 perl4caml_call (value optsv, value optfnname, value arglist)
 176 {
 177   CAMLparam3 (optsv, optfnname, arglist);
 178   dSP;
 179   int count;
 180   SV *sv;
 181   CAMLlocal3 (errv, svv, fnname);
 182
 183   ENTER;
 184   SAVETMPS;
 185
 186   /* Push the parameter list. */
 187   PUSHMARK (SP);
 188
 189   /* Iteration over the linked list. */
 190   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 191     {
 192       svv = Field (arglist, 0);
 193       sv = Sv_val (svv);
 194       XPUSHs (sv_2mortal (newSVsv (sv)));
 195     }
 196
 197   PUTBACK;
 198
 199   if (optsv != Val_int (0))
 200     {
 201       svv = unoption (optsv, Val_false);
 202       sv = Sv_val (svv);
 203       count = call_sv (sv, G_EVAL|G_SCALAR);
 204     }
 205   else if (optfnname != Val_int (0))
 206     {
 207       fnname = unoption (optfnname, Val_false);
 208       count = call_pv (String_val (fnname), G_EVAL|G_SCALAR);
 209     }
 210   else
 211     {
 212       fprintf (stderr,
 213                "Perl.call: must supply either 'sv' or 'fn' parameters.");
 214       abort ();
 215     }
 216
 217   SPAGAIN;
 218
 219   assert (count == 1); /* Pretty sure it should never be anything else. */
 220
 221   /* Pop return value off the stack. Note that the return value on the
 222    * stack is mortal, so we need to take a copy.
 223    */
 224   sv = newSVsv (POPs);
 225   PUTBACK;
 226   FREETMPS;
 227   LEAVE;
 228
 229   /* Died with an error?
 230    * XXX Actually this doesn't work for some reason.
 231    */
 232   if (SvTRUE (ERRSV))
 233     {
 234       STRLEN n_a;
 235       const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
 236
 237       errv = copy_string (err);
 238
 239       raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
 240     }
 241   else
 242     {
 243       svv = Val_sv (sv);
 244       CAMLreturn (svv);
 245     }
 246 }
 247
 248 CAMLprim value
 249 perl4caml_call_array (value optsv, value optfnname, value arglist)
 250 {
 251   CAMLparam3 (optsv, optfnname, arglist);
 252   dSP;
 253   int i, count;
 254   SV *sv;
 255   CAMLlocal5 (errv, svv, fnname, list, cons);
 256
 257   ENTER;
 258   SAVETMPS;
 259
 260   /* Push the parameter list. */
 261   PUSHMARK (SP);
 262
 263   /* Iteration over the linked list. */
 264   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 265     {
 266       svv = Field (arglist, 0);
 267       sv = Sv_val (svv);
 268       XPUSHs (sv_2mortal (newSVsv (sv)));
 269     }
 270
 271   PUTBACK;
 272
 273   if (optsv != Val_int (0))
 274     {
 275       svv = unoption (optsv, Val_false);
 276       sv = Sv_val (svv);
 277       count = call_sv (sv, G_EVAL|G_ARRAY);
 278     }
 279   else if (optfnname != Val_int (0))
 280     {
 281       fnname = unoption (optfnname, Val_false);
 282       count = call_pv (String_val (fnname), G_EVAL|G_ARRAY);
 283     }
 284   else
 285     {
 286       fprintf (stderr,
 287                "Perl.call_array: must supply either 'sv' or 'fn' parameters.");
 288       abort ();
 289     }
 290
 291   SPAGAIN;
 292
 293   /* Pop all the return values off the stack into a list. Values on the
 294    * stack are mortal, so we must copy them.
 295    */
 296   list = Val_int (0);
 297   for (i = 0; i < count; ++i) {
 298     cons = alloc (2, 0);
 299     Field (cons, 1) = list;
 300     list = cons;
 301     Field (cons, 0) = Val_sv (newSVsv (POPs));
 302   }
 303
 304   /* Restore the stack. */
 305   PUTBACK;
 306   FREETMPS;
 307   LEAVE;
 308
 309   /* Died with an error?
 310    * XXX Actually this doesn't work for some reason.
 311    */
 312   if (SvTRUE (ERRSV))
 313     {
 314       STRLEN n_a;
 315       const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
 316
 317       errv = copy_string (err);
 318
 319       raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
 320     }
 321   else
 322     CAMLreturn (list);
 323 }
 324
 325 CAMLprim value
 326 perl4caml_call_void (value optsv, value optfnname, value arglist)
 327 {
 328   CAMLparam3 (optsv, optfnname, arglist);
 329   dSP;
 330   int count;
 331   SV *sv;
 332   CAMLlocal3 (errv, svv, fnname);
 333
 334   ENTER;
 335   SAVETMPS;
 336
 337   /* Push the parameter list. */
 338   PUSHMARK (SP);
 339
 340   /* Iteration over the linked list. */
 341   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
 342     {
 343       svv = Field (arglist, 0);
 344       sv = Sv_val (svv);
 345       XPUSHs (sv_2mortal (newSVsv (sv)));
 346     }
 347
 348   PUTBACK;
 349
 350   if (optsv != Val_int (0))
 351     {
 352       svv = unoption (optsv, Val_false);
 353       sv = Sv_val (svv);
 354       count = call_sv (sv, G_EVAL|G_VOID);
 355     }
 356   else if (optfnname != Val_int (0))
 357     {
 358       fnname = unoption (optfnname, Val_false);
 359       count = call_pv (String_val (fnname), G_EVAL|G_VOID);
 360     }
 361   else
 362     {
 363       fprintf (stderr,
 364                "Perl.call_void: must supply either 'sv' or 'fn' parameters.");
 365       abort ();
 366     }
 367
 368   SPAGAIN;
 369
 370   assert (count == 0); /* Pretty sure it should never be anything else. */
 371
 372   /* Restore the stack. */
 373   PUTBACK;
 374   FREETMPS;
 375   LEAVE;
 376
 377   /* Died with an error?
 378    * XXX Actually this doesn't work for some reason.
 379    */
 380   if (SvTRUE (ERRSV))
 381     {
 382       STRLEN n_a;
 383       const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
 384
 385       errv = copy_string (err);
 386
 387       raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
 388     }
 389   else
 390     CAMLreturn (Val_unit);
 391 }
 392
 393 CAMLprim value
 394 perl4caml_eval (value expr)
 395 {
 396   CAMLparam1 (expr);
 397   dSP;
 398   SV *sv;
 399   CAMLlocal2 (errv, svv);
 400
 401   ENTER;
 402   SAVETMPS;
 403
 404   PUSHMARK (SP);
 405   eval_pv (String_val (expr), G_SCALAR);
 406
 407   SPAGAIN;
 408   sv = newSVsv (POPs);
 409   PUTBACK;
 410   FREETMPS;
 411   LEAVE;
 412
 413   /* Died with an error?
 414    * XXX Actually this doesn't work for some reason.
 415    */
 416   if (SvTRUE (ERRSV))
 417     {
 418       STRLEN n_a;
 419       const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
 420
 421       errv = copy_string (err);
 422
 423       raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
 424     }
 425   else
 426     {
 427       svv = Val_sv (sv);
 428       CAMLreturn (svv);
 429     }
 430 }
 431
 432 static value
 433 Val_voidptr (void *ptr)
 434 {
 435   value rv = alloc (1, Abstract_tag); /* XXX Is this correct? */
 436   Field(rv, 0) = (value) ptr;
 437   return rv;
 438 }
 439
 440 static value
 441 unoption (value option, value deflt)
 442 {
 443   if (option == Val_int (0))    /* "None" */
 444     return deflt;
 445   else                          /* "Some 'a" */
 446     return Field (option, 0);
 447 }