Start

[exim.git] / src / src / perl.c

diff --git a/src/src/perl.c b/src/src/perl.c
new file mode 100644 (file)
index 0000000..533d2c4
--- /dev/null
+++ b/src/src/perl.c
@@ -0,0 +1,174 @@
+/* $Cambridge: exim/src/src/perl.c,v 1.1 2004/10/07 10:39:01 ph10 Exp $ */
+
+/*************************************************
+*     Exim - an Internet mail transport agent    *
+*************************************************/
+
+/* Copyright (c) 1998 Malcolm Beattie */
+
+/* Modified by PH to get rid of the "na" usage, March 1999.
+   Modified further by PH for general tidying for Exim 4.
+   Threaded Perl support added by Stefan Traby, Nov 2002
+*/
+
+
+/* This Perl add-on can be distributed under the same terms as Exim itself. */
+/* See the file NOTICE for conditions of use and distribution. */
+
+#include "exim.h"
+
+#define EXIM_TRUE TRUE
+#undef TRUE
+
+#define EXIM_FALSE FALSE
+#undef FALSE
+
+#define EXIM_DEBUG DEBUG
+#undef DEBUG
+
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+
+#ifndef ERRSV
+#define ERRSV (GvSV(errgv))
+#endif
+
+/* Some people like very old perl versions, so avoid any build side-effects. */
+
+#ifndef pTHX
+# define pTHX
+# define pTHX_
+#endif
+#ifndef EXTERN_C
+# define EXTERN_C extern
+#endif
+
+EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
+
+
+static PerlInterpreter *interp_perl = 0;
+
+XS(xs_expand_string)
+{
+  dXSARGS;
+  uschar *str;
+  STRLEN len;
+
+  if (items != 1)
+    croak("Usage: Exim::expand_string(string)");
+
+  str = expand_string(US SvPV(ST(0), len));
+  ST(0) = sv_newmortal();
+  if (str != NULL)
+    sv_setpv(ST(0), (const char *) str);
+  else if (!expand_string_forcedfail)
+    croak("syntax error in Exim::expand_string argument: %s",
+      expand_string_message);
+}
+
+XS(xs_debug_write)
+{
+  dXSARGS;
+  STRLEN len;
+  if (items != 1)
+    croak("Usage: Exim::debug_write(string)");
+  debug_printf("%s", US SvPV(ST(0), len));
+}
+
+XS(xs_log_write)
+{
+  dXSARGS;
+  STRLEN len;
+  if (items != 1)
+    croak("Usage: Exim::log_write(string)");
+  log_write(0, LOG_MAIN, "%s", US SvPV(ST(0), len));
+}
+
+static void  xs_init(pTHX)
+{
+  char *file = __FILE__;
+  newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+  newXS("Exim::expand_string", xs_expand_string, file);
+  newXS("Exim::debug_write", xs_debug_write, file);
+  newXS("Exim::log_write", xs_log_write, file);
+}
+
+uschar *
+init_perl(uschar *startup_code)
+{
+  static int argc = 2;
+  static char *argv[3] = { "exim-perl", "/dev/null", 0 };
+  SV *sv;
+  STRLEN len;
+
+  if (interp_perl) return 0;
+  interp_perl = perl_alloc();
+  perl_construct(interp_perl);
+  perl_parse(interp_perl, xs_init, argc, argv, 0);
+  perl_run(interp_perl);
+    {
+    dSP;
+    sv = newSVpv(CS startup_code, 0);
+    PUSHMARK(SP);
+    perl_eval_sv(sv, G_SCALAR|G_DISCARD|G_KEEPERR);
+    SvREFCNT_dec(sv);
+    if (SvTRUE(ERRSV)) return US SvPV(ERRSV, len);
+    return NULL;
+    }
+}
+
+void
+cleanup_perl(void)
+{
+  if (!interp_perl)
+    return;
+  perl_destruct(interp_perl);
+  perl_free(interp_perl);
+  interp_perl = 0;
+}
+
+uschar *
+call_perl_cat(uschar *yield, int *sizep, int *ptrp, uschar **errstrp,
+  uschar *name, uschar **arg)
+{
+  dSP;
+  SV *sv;
+  STRLEN len;
+  uschar *str;
+  int items;
+
+  if (!interp_perl)
+    {
+    *errstrp = US"the Perl interpreter has not been started";
+    return 0;
+    }
+
+  ENTER;
+  SAVETMPS;
+  PUSHMARK(SP);
+  while (*arg != NULL) XPUSHs(newSVpv(CS (*arg++), 0));
+  PUTBACK;
+  items = perl_call_pv(CS name, G_SCALAR|G_EVAL);
+  SPAGAIN;
+  sv = POPs;
+  PUTBACK;
+  if (SvTRUE(ERRSV))
+    {
+    *errstrp = US SvPV(ERRSV, len);
+    return NULL;
+    }
+  if (!SvOK(sv))
+    {
+    *errstrp = 0;
+    return NULL;
+    }
+  str = US SvPV(sv, len);
+  yield = string_cat(yield, sizep, ptrp, str, (int)len);
+  FREETMPS;
+  LEAVE;
+
+  return yield;
+}
+
+/* End of perl.c */