diff --git a/conf/autoload_configs/perl.conf.xml b/conf/autoload_configs/perl.conf.xml
new file mode 100644
index 0000000000..83732890c6
--- /dev/null
+++ b/conf/autoload_configs/perl.conf.xml
@@ -0,0 +1,6 @@
+
+
+
+
+
+
diff --git a/src/mod/languages/mod_perl/Makefile b/src/mod/languages/mod_perl/Makefile
new file mode 100644
index 0000000000..3d33b7c143
--- /dev/null
+++ b/src/mod/languages/mod_perl/Makefile
@@ -0,0 +1,34 @@
+BASE=../../../..
+PERL = `which perl`
+PERL_LIBDIR =-L$(shell perl -MConfig -e 'print $$Config{archlib}')/CORE
+PERL_LIBS =$(shell perl -MConfig -e 'print $$Config{libs}')
+LOCAL_CFLAGS= -w -DMULTIPLICITY $(shell $(PERL) -MExtUtils::Embed -e ccopts) -DEMBED_PERL
+LOCAL_LDFLAGS=$(shell $(PERL) -MExtUtils::Embed -e ldopts) $(shell $(PERL) -MConfig -e 'print $$Config{libs}')
+LOCAL_OBJS=freeswitch_perl.o mod_perl_wrap.o perlxsi.o
+VERBOSE=1
+
+include $(BASE)/build/modmake.rules
+
+swigclean: clean
+ rm mod_perl_wrap.*
+
+mod_perl_wrap.cpp: $(TOLUA_A)
+ swig -static -shadow -perl5 -c++ -DMULTIPLICITY -I../../../../src/include -o mod_perl_wrap.cpp freeswitch.i
+
+freeswitch.$(DYNAMIC_LIB_EXTEN): $(LOCAL_OBJS) $(LOCAL_LIBADD)
+ $(LINK) $(SOLINK) -o freeswitch.$(DYNAMIC_LIB_EXTEN) $(LOCAL_OBJS) $(LOCAL_LIBADD) $(LDFLAGS)
+
+local_all: freeswitch.$(DYNAMIC_LIB_EXTEN)
+
+.perlok:
+ @(${PERL} -V | grep -i usemultiplicity=define >/dev/null && echo Phew, You have the right perl.) \
+ || ((echo Sorry, you need to compile perl with threads and multiplicity.&& exit 1))
+ @touch .perlok
+
+local_clean:
+ rm -fr *~ .perlok freeswitch.$(DYNAMIC_LIB_EXTEN)
+
+depend_install:
+ mkdir -p $(PREFIX)/perl
+ $(LTINSTALL) freeswitch.$(DYNAMIC_LIB_EXTEN) freeswitch.pm $(PREFIX)/perl
+ if [ ! -f $(PREFIX)/perl/freeswitch.pm ] ; then $(LTINSTALL) freeswitch.pm $(PREFIX)/perl ; fi
diff --git a/src/mod/languages/mod_perl/compiler.opts b/src/mod/languages/mod_perl/compiler.opts
new file mode 100644
index 0000000000..e5f81c4039
--- /dev/null
+++ b/src/mod/languages/mod_perl/compiler.opts
@@ -0,0 +1 @@
+/IC:\perl\lib\CORE
\ No newline at end of file
diff --git a/src/mod/languages/mod_perl/compiler.opts.in b/src/mod/languages/mod_perl/compiler.opts.in
new file mode 100644
index 0000000000..61b705b080
--- /dev/null
+++ b/src/mod/languages/mod_perl/compiler.opts.in
@@ -0,0 +1 @@
+/I@PERL_INCLUDE@
\ No newline at end of file
diff --git a/src/mod/languages/mod_perl/freeswitch.i b/src/mod/languages/mod_perl/freeswitch.i
new file mode 100644
index 0000000000..62f7bf00b8
--- /dev/null
+++ b/src/mod/languages/mod_perl/freeswitch.i
@@ -0,0 +1,30 @@
+%module freeswitch
+//%include "cstring.i"
+
+/**
+ * tell swig to treat these variables as mutable so they
+ * can be used to return values.
+ * See http://www.swig.org/Doc1.3/Library.html
+ */
+//%cstring_bounded_mutable(char *dtmf_buf, 128);
+//%cstring_bounded_mutable(char *terminator, 8);
+
+
+/** insert the following includes into generated code so it compiles */
+%{
+#include "switch_cpp.h"
+#include "freeswitch_perl.h"
+%}
+
+
+%ignore SwitchToMempool;
+
+/**
+ * tell swig to grok everything defined in these header files and
+ * build all sorts of c wrappers and lua shadows of the c wrappers.
+ */
+%include switch_cpp.h
+%include freeswitch_perl.h
+
+
+
diff --git a/src/mod/languages/mod_perl/freeswitch.pm b/src/mod/languages/mod_perl/freeswitch.pm
new file mode 100644
index 0000000000..07972ae753
--- /dev/null
+++ b/src/mod/languages/mod_perl/freeswitch.pm
@@ -0,0 +1,319 @@
+# This file was automatically generated by SWIG (http://www.swig.org).
+# Version 1.3.35
+#
+# Don't modify this file, modify the SWIG interface instead.
+
+package freeswitch;
+require Exporter;
+@ISA = qw(Exporter);
+package freeswitchc;
+boot_freeswitch();
+package freeswitch;
+@EXPORT = qw( );
+
+# ---------- BASE METHODS -------------
+
+package freeswitch;
+
+sub TIEHASH {
+ my ($classname,$obj) = @_;
+ return bless $obj, $classname;
+}
+
+sub CLEAR { }
+
+sub FIRSTKEY { }
+
+sub NEXTKEY { }
+
+sub FETCH {
+ my ($self,$field) = @_;
+ my $member_func = "swig_${field}_get";
+ $self->$member_func();
+}
+
+sub STORE {
+ my ($self,$field,$newval) = @_;
+ my $member_func = "swig_${field}_set";
+ $self->$member_func($newval);
+}
+
+sub this {
+ my $ptr = shift;
+ return tied(%$ptr);
+}
+
+
+# ------- FUNCTION WRAPPERS --------
+
+package freeswitch;
+
+*console_log = *freeswitchc::console_log;
+*console_clean_log = *freeswitchc::console_clean_log;
+*api_execute = *freeswitchc::api_execute;
+*api_reply_delete = *freeswitchc::api_reply_delete;
+*process_callback_result = *freeswitchc::process_callback_result;
+*bridge = *freeswitchc::bridge;
+*hanguphook = *freeswitchc::hanguphook;
+*dtmf_callback = *freeswitchc::dtmf_callback;
+
+############# Class : freeswitch::input_callback_state_t ##############
+
+package freeswitch::input_callback_state_t;
+use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS);
+@ISA = qw( freeswitch );
+%OWNER = ();
+%ITERATORS = ();
+*swig_function_get = *freeswitchc::input_callback_state_t_function_get;
+*swig_function_set = *freeswitchc::input_callback_state_t_function_set;
+*swig_threadState_get = *freeswitchc::input_callback_state_t_threadState_get;
+*swig_threadState_set = *freeswitchc::input_callback_state_t_threadState_set;
+*swig_extra_get = *freeswitchc::input_callback_state_t_extra_get;
+*swig_extra_set = *freeswitchc::input_callback_state_t_extra_set;
+*swig_funcargs_get = *freeswitchc::input_callback_state_t_funcargs_get;
+*swig_funcargs_set = *freeswitchc::input_callback_state_t_funcargs_set;
+sub new {
+ my $pkg = shift;
+ my $self = freeswitchc::new_input_callback_state_t(@_);
+ bless $self, $pkg if defined($self);
+}
+
+sub DESTROY {
+ return unless $_[0]->isa('HASH');
+ my $self = tied(%{$_[0]});
+ return unless defined $self;
+ delete $ITERATORS{$self};
+ if (exists $OWNER{$self}) {
+ freeswitchc::delete_input_callback_state_t($self);
+ delete $OWNER{$self};
+ }
+}
+
+sub DISOWN {
+ my $self = shift;
+ my $ptr = tied(%$self);
+ delete $OWNER{$ptr};
+}
+
+sub ACQUIRE {
+ my $self = shift;
+ my $ptr = tied(%$self);
+ $OWNER{$ptr} = 1;
+}
+
+
+############# Class : freeswitch::Stream ##############
+
+package freeswitch::Stream;
+use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS);
+@ISA = qw( freeswitch );
+%OWNER = ();
+%ITERATORS = ();
+sub new {
+ my $pkg = shift;
+ my $self = freeswitchc::new_Stream(@_);
+ bless $self, $pkg if defined($self);
+}
+
+sub DESTROY {
+ return unless $_[0]->isa('HASH');
+ my $self = tied(%{$_[0]});
+ return unless defined $self;
+ delete $ITERATORS{$self};
+ if (exists $OWNER{$self}) {
+ freeswitchc::delete_Stream($self);
+ delete $OWNER{$self};
+ }
+}
+
+*write = *freeswitchc::Stream_write;
+*get_data = *freeswitchc::Stream_get_data;
+sub DISOWN {
+ my $self = shift;
+ my $ptr = tied(%$self);
+ delete $OWNER{$ptr};
+}
+
+sub ACQUIRE {
+ my $self = shift;
+ my $ptr = tied(%$self);
+ $OWNER{$ptr} = 1;
+}
+
+
+############# Class : freeswitch::Event ##############
+
+package freeswitch::Event;
+use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS);
+@ISA = qw( freeswitch );
+%OWNER = ();
+%ITERATORS = ();
+sub new {
+ my $pkg = shift;
+ my $self = freeswitchc::new_Event(@_);
+ bless $self, $pkg if defined($self);
+}
+
+sub DESTROY {
+ return unless $_[0]->isa('HASH');
+ my $self = tied(%{$_[0]});
+ return unless defined $self;
+ delete $ITERATORS{$self};
+ if (exists $OWNER{$self}) {
+ freeswitchc::delete_Event($self);
+ delete $OWNER{$self};
+ }
+}
+
+*set_priority = *freeswitchc::Event_set_priority;
+*get_header = *freeswitchc::Event_get_header;
+*get_body = *freeswitchc::Event_get_body;
+*add_body = *freeswitchc::Event_add_body;
+*add_header = *freeswitchc::Event_add_header;
+*del_header = *freeswitchc::Event_del_header;
+*fire = *freeswitchc::Event_fire;
+sub DISOWN {
+ my $self = shift;
+ my $ptr = tied(%$self);
+ delete $OWNER{$ptr};
+}
+
+sub ACQUIRE {
+ my $self = shift;
+ my $ptr = tied(%$self);
+ $OWNER{$ptr} = 1;
+}
+
+
+############# Class : freeswitch::CoreSession ##############
+
+package freeswitch::CoreSession;
+use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS);
+@ISA = qw( freeswitch );
+%OWNER = ();
+%ITERATORS = ();
+sub DESTROY {
+ return unless $_[0]->isa('HASH');
+ my $self = tied(%{$_[0]});
+ return unless defined $self;
+ delete $ITERATORS{$self};
+ if (exists $OWNER{$self}) {
+ freeswitchc::delete_CoreSession($self);
+ delete $OWNER{$self};
+ }
+}
+
+*swig_session_get = *freeswitchc::CoreSession_session_get;
+*swig_session_set = *freeswitchc::CoreSession_session_set;
+*swig_channel_get = *freeswitchc::CoreSession_channel_get;
+*swig_channel_set = *freeswitchc::CoreSession_channel_set;
+*swig_flags_get = *freeswitchc::CoreSession_flags_get;
+*swig_flags_set = *freeswitchc::CoreSession_flags_set;
+*swig_allocated_get = *freeswitchc::CoreSession_allocated_get;
+*swig_allocated_set = *freeswitchc::CoreSession_allocated_set;
+*swig_cb_state_get = *freeswitchc::CoreSession_cb_state_get;
+*swig_cb_state_set = *freeswitchc::CoreSession_cb_state_set;
+*swig_hook_state_get = *freeswitchc::CoreSession_hook_state_get;
+*swig_hook_state_set = *freeswitchc::CoreSession_hook_state_set;
+*answer = *freeswitchc::CoreSession_answer;
+*preAnswer = *freeswitchc::CoreSession_preAnswer;
+*hangup = *freeswitchc::CoreSession_hangup;
+*setVariable = *freeswitchc::CoreSession_setVariable;
+*getVariable = *freeswitchc::CoreSession_getVariable;
+*recordFile = *freeswitchc::CoreSession_recordFile;
+*setCallerData = *freeswitchc::CoreSession_setCallerData;
+*originate = *freeswitchc::CoreSession_originate;
+*setDTMFCallback = *freeswitchc::CoreSession_setDTMFCallback;
+*speak = *freeswitchc::CoreSession_speak;
+*set_tts_parms = *freeswitchc::CoreSession_set_tts_parms;
+*collectDigits = *freeswitchc::CoreSession_collectDigits;
+*getDigits = *freeswitchc::CoreSession_getDigits;
+*transfer = *freeswitchc::CoreSession_transfer;
+*playAndGetDigits = *freeswitchc::CoreSession_playAndGetDigits;
+*streamFile = *freeswitchc::CoreSession_streamFile;
+*flushEvents = *freeswitchc::CoreSession_flushEvents;
+*flushDigits = *freeswitchc::CoreSession_flushDigits;
+*setAutoHangup = *freeswitchc::CoreSession_setAutoHangup;
+*setHangupHook = *freeswitchc::CoreSession_setHangupHook;
+*ready = *freeswitchc::CoreSession_ready;
+*execute = *freeswitchc::CoreSession_execute;
+*begin_allow_threads = *freeswitchc::CoreSession_begin_allow_threads;
+*end_allow_threads = *freeswitchc::CoreSession_end_allow_threads;
+*get_uuid = *freeswitchc::CoreSession_get_uuid;
+*get_cb_args = *freeswitchc::CoreSession_get_cb_args;
+*check_hangup_hook = *freeswitchc::CoreSession_check_hangup_hook;
+*run_dtmf_callback = *freeswitchc::CoreSession_run_dtmf_callback;
+sub DISOWN {
+ my $self = shift;
+ my $ptr = tied(%$self);
+ delete $OWNER{$ptr};
+}
+
+sub ACQUIRE {
+ my $self = shift;
+ my $ptr = tied(%$self);
+ $OWNER{$ptr} = 1;
+}
+
+
+############# Class : freeswitch::Session ##############
+
+package freeswitch::Session;
+use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS);
+@ISA = qw( freeswitch::CoreSession freeswitch );
+%OWNER = ();
+%ITERATORS = ();
+sub new {
+ my $pkg = shift;
+ my $self = freeswitchc::new_Session(@_);
+ bless $self, $pkg if defined($self);
+}
+
+sub DESTROY {
+ return unless $_[0]->isa('HASH');
+ my $self = tied(%{$_[0]});
+ return unless defined $self;
+ delete $ITERATORS{$self};
+ if (exists $OWNER{$self}) {
+ freeswitchc::delete_Session($self);
+ delete $OWNER{$self};
+ }
+}
+
+*begin_allow_threads = *freeswitchc::Session_begin_allow_threads;
+*end_allow_threads = *freeswitchc::Session_end_allow_threads;
+*check_hangup_hook = *freeswitchc::Session_check_hangup_hook;
+*run_dtmf_callback = *freeswitchc::Session_run_dtmf_callback;
+*swig_session_get = *freeswitchc::Session_session_get;
+*swig_session_set = *freeswitchc::Session_session_set;
+*swig_channel_get = *freeswitchc::Session_channel_get;
+*swig_channel_set = *freeswitchc::Session_channel_set;
+*swig_flags_get = *freeswitchc::Session_flags_get;
+*swig_flags_set = *freeswitchc::Session_flags_set;
+*swig_allocated_get = *freeswitchc::Session_allocated_get;
+*swig_allocated_set = *freeswitchc::Session_allocated_set;
+*swig_cb_state_get = *freeswitchc::Session_cb_state_get;
+*swig_cb_state_set = *freeswitchc::Session_cb_state_set;
+*swig_hook_state_get = *freeswitchc::Session_hook_state_get;
+*swig_hook_state_set = *freeswitchc::Session_hook_state_set;
+sub DISOWN {
+ my $self = shift;
+ my $ptr = tied(%$self);
+ delete $OWNER{$ptr};
+}
+
+sub ACQUIRE {
+ my $self = shift;
+ my $ptr = tied(%$self);
+ $OWNER{$ptr} = 1;
+}
+
+
+# ------- VARIABLE STUBS --------
+
+package freeswitch;
+
+*S_HUP = *freeswitchc::S_HUP;
+*S_FREE = *freeswitchc::S_FREE;
+*S_RDLOCK = *freeswitchc::S_RDLOCK;
+1;
diff --git a/src/mod/languages/mod_perl/freeswitch_perl.cpp b/src/mod/languages/mod_perl/freeswitch_perl.cpp
new file mode 100644
index 0000000000..12fff1ab92
--- /dev/null
+++ b/src/mod/languages/mod_perl/freeswitch_perl.cpp
@@ -0,0 +1,85 @@
+#include "freeswitch_perl.h"
+
+Session::Session() : CoreSession()
+{
+
+}
+
+Session::Session(char *uuid) : CoreSession(uuid)
+{
+
+}
+
+Session::Session(switch_core_session_t *new_session) : CoreSession(new_session)
+{
+
+}
+
+Session::~Session()
+{
+
+}
+
+
+bool Session::begin_allow_threads()
+{
+ return true;
+}
+
+bool Session::end_allow_threads()
+{
+ return true;
+}
+
+void Session::check_hangup_hook()
+{
+}
+
+switch_status_t Session::run_dtmf_callback(void *input, switch_input_type_t itype)
+{
+ return SWITCH_STATUS_FALSE;
+}
+
+
+#if 0
+int Session::answer() {}
+int Session::preAnswer() {}
+void Session::hangup(char *cause) {}
+void Session::setVariable(char *var, char *val) {}
+const char *Session::getVariable(char *var) {}
+int Session::recordFile(char *file_name, int max_len, int silence_threshold, int silence_secs) {}
+void Session::setCallerData(char *var, char *val) {}
+int Session::originate(CoreSession *a_leg_session, char *dest, int timeout) {}
+void Session::setDTMFCallback(void *cbfunc, char *funcargs) {}
+int Session::speak(char *text) {}
+void Session::set_tts_parms(char *tts_name, char *voice_name) {}
+int Session::collectDigits(int timeout) {}
+int Session::getDigits(char *dtmf_buf,
+ switch_size_t buflen,
+ switch_size_t maxdigits,
+ char *terminators,
+ char *terminator,
+ int timeout) {}
+
+int Session::transfer(char *extensions, char *dialplan, char *context) {}
+int Session::playAndGetDigits(int min_digits,
+ int max_digits,
+ int max_tries,
+ int timeout,
+ char *terminators,
+ char *audio_files,
+ char *bad_input_audio_files,
+ char *dtmf_buf,
+ char *digits_regex) {}
+
+int Session::streamFile(char *file, int starting_sample_count) {}
+int Session::flushEvents() {}
+int Session::flushDigits() {}
+int Session::setAutoHangup(bool val) {}
+void Session::setHangupHook(void *hangup_func) {}
+bool Session::ready() {}
+void Session::execute(char *app, char *data) {}
+char* Session::get_uuid() {}
+const switch_input_args_t& Session::get_cb_args() {}
+
+#endif
diff --git a/src/mod/languages/mod_perl/freeswitch_perl.h b/src/mod/languages/mod_perl/freeswitch_perl.h
new file mode 100644
index 0000000000..682051acf4
--- /dev/null
+++ b/src/mod/languages/mod_perl/freeswitch_perl.h
@@ -0,0 +1,78 @@
+#ifndef FREESWITCH_PYTHON_H
+#define FREESWITCH_PYTHON_H
+
+#include
+
+void console_log(char *level_str, char *msg);
+void console_clean_log(char *msg);
+char *api_execute(char *cmd, char *arg);
+void api_reply_delete(char *reply);
+
+
+class Session : public CoreSession {
+ private:
+ public:
+ Session();
+ Session(char *uuid);
+ Session(switch_core_session_t *session);
+ ~Session();
+
+ virtual bool begin_allow_threads();
+ virtual bool end_allow_threads();
+ virtual void check_hangup_hook();
+ virtual switch_status_t run_dtmf_callback(void *input, switch_input_type_t itype);
+
+ switch_core_session_t *session;
+ switch_channel_t *channel;
+ unsigned int flags;
+ int allocated;
+ input_callback_state cb_state; // callback state, always pointed to by the buf
+ // field in this->args
+ switch_channel_state_t hook_state; // store hookstate for on_hangup callback
+
+#if 0
+
+ int answer();
+ int preAnswer();
+ virtual void hangup(char *cause);
+ void setVariable(char *var, char *val);
+ const char *getVariable(char *var);
+ int recordFile(char *file_name, int max_len=0, int silence_threshold=0, int silence_secs=0);
+ void setCallerData(char *var, char *val);
+ int originate(CoreSession *a_leg_session, char *dest, int timeout=60);
+ void setDTMFCallback(void *cbfunc, char *funcargs);
+ int speak(char *text);
+ void set_tts_parms(char *tts_name, char *voice_name);
+ int collectDigits(int timeout);
+ int getDigits(char *dtmf_buf,
+ switch_size_t buflen,
+ switch_size_t maxdigits,
+ char *terminators,
+ char *terminator,
+ int timeout);
+
+ int transfer(char *extensions, char *dialplan, char *context);
+ int playAndGetDigits(int min_digits,
+ int max_digits,
+ int max_tries,
+ int timeout,
+ char *terminators,
+ char *audio_files,
+ char *bad_input_audio_files,
+ char *dtmf_buf,
+ char *digits_regex);
+
+ int streamFile(char *file, int starting_sample_count=0);
+ int flushEvents();
+ int flushDigits();
+ int setAutoHangup(bool val);
+ void setHangupHook(void *hangup_func);
+ bool ready();
+ void execute(char *app, char *data);
+ char* get_uuid();
+ const switch_input_args_t& get_cb_args();
+#endif
+
+};
+
+#endif
diff --git a/src/mod/languages/mod_perl/mod_perl.c b/src/mod/languages/mod_perl/mod_perl.c
new file mode 100644
index 0000000000..f55c1346bf
--- /dev/null
+++ b/src/mod/languages/mod_perl/mod_perl.c
@@ -0,0 +1,431 @@
+/*
+ * FreeSWITCH Modular Media Switching Software Library / Soft-Switch Application
+ * Copyright (C) 2005/2006, Anthony Minessale II
+ *
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is FreeSWITCH Modular Media Switching Software Library / Soft-Switch Application
+ *
+ * The Initial Developer of the Original Code is
+ * Anthony Minessale II
+ * Portions created by the Initial Developer are Copyright (C)
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * Anthony Minessale II
+ *
+ *
+ * mod_perl.c -- Perl
+ *
+ */
+#ifdef __ICC
+#pragma warning (disable:1419)
+#endif
+#ifdef _MSC_VER
+#include
+#pragma comment(lib, PERL_LIB)
+#endif
+
+#include
+#include
+#include
+static char *embedding[] = { "", "-e", "" };
+EXTERN_C void xs_init(pTHX);
+
+SWITCH_MODULE_LOAD_FUNCTION(mod_perl_load);
+SWITCH_MODULE_SHUTDOWN_FUNCTION(mod_perl_shutdown);
+SWITCH_MODULE_DEFINITION(mod_perl, mod_perl_load, mod_perl_shutdown, NULL);
+
+
+
+static STRLEN n_a;
+
+static struct {
+ PerlInterpreter *my_perl;
+ switch_memory_pool_t *pool;
+ char *xml_handler;
+} globals;
+
+
+static void Perl_safe_eval(PerlInterpreter *my_perl, const char *string, int tf)
+{
+ char *st = switch_mprintf("eval { %s }; $__ERR = $@", string);
+ char *err = NULL;
+ Perl_eval_pv(my_perl, st, tf);
+
+ if ((err = SvPV(get_sv("__ERR", FALSE), n_a)) && !switch_strlen_zero(err)) {
+ switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_ERROR, "%s\n", err);
+ }
+
+ switch_safe_free(st);
+}
+
+static void destroy_perl(PerlInterpreter ** to_destroy)
+{
+ perl_destruct(*to_destroy);
+ perl_free(*to_destroy);
+ *to_destroy = NULL;
+}
+
+static PerlInterpreter *clone_perl(void)
+{
+ PerlInterpreter *my_perl = perl_clone(globals.my_perl, CLONEf_COPY_STACKS | CLONEf_KEEP_PTR_TABLE);
+ PERL_SET_CONTEXT(my_perl);
+ return my_perl;
+}
+
+static perl_parse_and_execute (PerlInterpreter *my_perl, char *input_code, char *setup_code)
+{
+ int error = 0;
+
+
+ if (*input_code == '~') {
+ char *buff = input_code + 1;
+ perl_parse(my_perl, xs_init, 3, embedding, NULL);
+ if (setup_code) Perl_safe_eval(my_perl, setup_code, TRUE);
+ Perl_safe_eval(my_perl, buff, TRUE);
+ } else {
+ int argc = 0;
+ char *argv[128] = { 0 };
+ argv[0] = "FreeSWITCH";
+ argc++;
+
+ argc += switch_separate_string(input_code, ' ', &argv[1], (sizeof(argv) / sizeof(argv[0])) - 1);
+ perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);
+ if (setup_code) Perl_safe_eval(my_perl, setup_code, TRUE);
+ perl_run(my_perl);
+ }
+}
+
+
+
+static void perl_function(switch_core_session_t *session, char *data)
+{
+ char *uuid = switch_core_session_get_uuid(session);
+ PerlInterpreter *my_perl = clone_perl();
+
+ char code[1024];
+ switch_snprintf(code, sizeof(code),
+ "use lib '%s/perl';\n"
+ "use freeswitch;\n"
+ "$SWITCH_ENV{UUID} = \"%s\";\n"
+ "$session = new freeswitch::Session(\"%s\")"
+ ,
+ SWITCH_GLOBAL_dirs.base_dir,
+ uuid,
+ uuid);
+
+ perl_parse_and_execute(my_perl, data, code);
+ Perl_safe_eval(my_perl, "undef $session;", TRUE);
+ Perl_safe_eval(my_perl, "undef (*);", TRUE);
+ destroy_perl(&my_perl);
+}
+
+SWITCH_MODULE_SHUTDOWN_FUNCTION(mod_perl_shutdown)
+{
+ if (globals.my_perl) {
+ perl_destruct(globals.my_perl);
+ perl_free(globals.my_perl);
+ globals.my_perl = NULL;
+ switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_INFO, "Unallocated perl interpreter.\n");
+ }
+ return SWITCH_STATUS_SUCCESS;
+}
+
+static void *SWITCH_THREAD_FUNC perl_thread_run(switch_thread_t *thread, void *obj)
+{
+ char *input_code = (char *) obj;
+ PerlInterpreter *my_perl = clone_perl();
+ char code[1024];
+
+ switch_snprintf(code, sizeof(code),
+ "use lib '%s/perl';\n"
+ "use freeswitch;\n"
+ ,
+ SWITCH_GLOBAL_dirs.base_dir
+ );
+
+ perl_parse_and_execute(my_perl, input_code, code);
+
+ if (input_code) {
+ free(input_code);
+ }
+
+ Perl_safe_eval(my_perl, "undef(*);", TRUE);
+ destroy_perl(&my_perl);
+
+ return NULL;
+}
+
+int perl_thread(const char *text)
+{
+ switch_thread_t *thread;
+ switch_threadattr_t *thd_attr = NULL;
+
+ switch_threadattr_create(&thd_attr, globals.pool);
+ switch_threadattr_detach_set(thd_attr, 1);
+ switch_threadattr_stacksize_set(thd_attr, SWITCH_THREAD_STACKSIZE);
+ switch_thread_create(&thread, thd_attr, perl_thread_run, strdup(text), globals.pool);
+
+ return 0;
+}
+
+SWITCH_STANDARD_API(perlrun_api_function) {
+ perl_thread(cmd);
+ stream->write_function(stream, "+OK\n");
+ return SWITCH_STATUS_SUCCESS;
+}
+
+SWITCH_STANDARD_API(perl_api_function) {
+
+ PerlInterpreter *my_perl = clone_perl();
+ char code[1024];
+ SV *sv = NULL;
+ char *uuid = NULL;
+
+ if (session) {
+ uuid = switch_core_session_get_uuid(session);
+ }
+
+
+ switch_snprintf(code, sizeof(code),
+ "use lib '%s/perl';\n"
+ "use freeswitch;\n"
+ "$SWITCH_ENV{UUID} = \"%s\";\n"
+ "use IO::String;\n"
+ "$handle = IO::String->new($__OUT);\n"
+ "select($handle);"
+ ,
+
+ SWITCH_GLOBAL_dirs.base_dir,
+ switch_str_nil(uuid)
+
+ );
+
+ perl_parse(my_perl, xs_init, 3, embedding, NULL);
+ Perl_safe_eval(my_perl, code, TRUE);
+
+ if (uuid) {
+ switch_snprintf(code, sizeof(code), "$session = new freeswitch::Session(\"%s\")", uuid);
+ Perl_safe_eval(my_perl, code, TRUE);
+ }
+
+ if (cmd) {
+ Perl_safe_eval(my_perl, cmd, TRUE);
+ }
+
+ stream->write_function(stream, "%s", switch_str_nil(SvPV(get_sv("__OUT", FALSE), n_a)));
+
+ if (uuid) {
+ switch_snprintf(code, sizeof(code), "undef $session;", uuid);
+ Perl_safe_eval(my_perl, code, TRUE);
+ }
+
+ Perl_safe_eval(my_perl, "undef(*);", TRUE);
+ destroy_perl(&my_perl);
+
+
+ return SWITCH_STATUS_SUCCESS;
+}
+
+
+static switch_xml_t perl_fetch(const char *section,
+ const char *tag_name,
+ const char *key_name,
+ const char *key_value,
+ switch_event_t *params,
+ void *user_data)
+{
+
+ char *argv[128] = { 0 };
+ int argc = 0;
+ switch_xml_t xml = NULL;
+
+ if (!switch_strlen_zero(globals.xml_handler)) {
+ PerlInterpreter *my_perl = clone_perl();
+ HV *hash;
+ char *str;
+ switch_event_header_t *hp;
+ SV *this;
+ char code[1024] = "";
+
+ argv[argc++] = "FreeSWITCH";
+ argv[argc++] = globals.xml_handler;
+
+ PERL_SET_CONTEXT(my_perl);
+
+ if (perl_parse(my_perl, xs_init, argc, argv, (char **)NULL)) {
+ switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_ERROR, "Error Parsing Result!\n");
+ return NULL;
+ }
+
+ if (!(hash = get_hv("XML_REQUEST", TRUE))) {
+ abort();
+ }
+
+ if (switch_strlen_zero(section)) {
+ section = "";
+ }
+
+ this = newSV(strlen(section)+1);
+ sv_setpv(this, section);
+ hv_store(hash, "section", 7, this, 0);
+
+
+ if (switch_strlen_zero(tag_name)) {
+ tag_name = "";
+ }
+
+ this = newSV(strlen(tag_name)+1);
+ sv_setpv(this, tag_name);
+ hv_store(hash, "tag_name", 8, this, 0);
+
+ if (switch_strlen_zero(key_name)) {
+ key_name = "";
+ }
+
+ this = newSV(strlen(key_name)+1);
+ sv_setpv(this, key_name);
+ hv_store(hash, "key_name", 8, this, 0);
+
+
+ if (switch_strlen_zero(key_value)) {
+ key_value = "";
+ }
+
+ this = newSV(strlen(key_value)+1);
+ sv_setpv(this, key_value);
+ hv_store(hash, "key_value", 9, this, 0);
+
+ if (!(hash = get_hv("XML_DATA", TRUE))) {
+ abort();
+ }
+
+
+ if (params) {
+ for (hp = params->headers; hp; hp = hp->next) {
+ this = newSV(strlen(hp->value)+1);
+ sv_setpv(this, hp->value);
+ hv_store(hash, hp->name, strlen(hp->name), this, 0);
+ }
+ }
+
+ switch_snprintf(code, sizeof(code),
+ "use lib '%s/perl';\n"
+ "use freeswitch;\n"
+ ,
+ SWITCH_GLOBAL_dirs.base_dir
+ );
+ Perl_safe_eval(my_perl, code, TRUE);
+
+ perl_run(my_perl);
+ str = SvPV(get_sv("XML_STRING", FALSE), n_a);
+
+ if (str) {
+ if (switch_strlen_zero(str)) {
+ switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_ERROR, "No Result\n");
+ } else if (!(xml = switch_xml_parse_str(str, strlen(str)))) {
+ switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_ERROR, "Error Parsing XML Result!\n");
+ }
+ }
+
+ destroy_perl(&my_perl);
+ }
+
+ return xml;
+
+}
+
+static switch_status_t do_config(void)
+{
+
+ char *cf = "perl.conf";
+ switch_xml_t cfg, xml, settings, param;
+
+
+ if (!(xml = switch_xml_open_cfg(cf, &cfg, NULL))) {
+ switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_ERROR, "open of %s failed\n", cf);
+ return SWITCH_STATUS_TERM;
+ }
+
+ if ((settings = switch_xml_child(cfg, "settings"))) {
+ for (param = switch_xml_child(settings, "param"); param; param = param->next) {
+ char *var = (char *) switch_xml_attr_soft(param, "name");
+ char *val = (char *) switch_xml_attr_soft(param, "value");
+
+ if (!strcmp(var, "xml-handler-script")) {
+ globals.xml_handler = switch_core_strdup(globals.pool, val);
+ } else if (!strcmp(var, "xml-handler-bindings")) {
+ if (!switch_strlen_zero(globals.xml_handler)) {
+ switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_INFO, "binding '%s' to '%s'\n", globals.xml_handler, var);
+ switch_xml_bind_search_function(perl_fetch, switch_xml_parse_section_string(val), NULL);
+ }
+ }
+ }
+ }
+
+
+ switch_xml_free(xml);
+
+ return SWITCH_STATUS_SUCCESS;
+}
+
+
+SWITCH_MODULE_LOAD_FUNCTION(mod_perl_load)
+{
+ switch_application_interface_t *app_interface;
+ PerlInterpreter *my_perl;
+ char code[1024];
+ switch_api_interface_t *api_interface;
+
+ globals.pool = pool;
+
+ if (!(my_perl = perl_alloc())) {
+ switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_ERROR, "Could not allocate perl intrepreter\n");
+ return SWITCH_STATUS_MEMERR;
+ }
+ switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_INFO, "Allocated perl intrepreter.\n");
+
+
+ perl_construct(my_perl);
+ perl_parse(my_perl, xs_init, 3, embedding, NULL);
+ perl_run(my_perl);
+ globals.my_perl = my_perl;
+
+ //switch_snprintf(code, sizeof(code), "use lib '%s/perl';use freeswitch\n", SWITCH_GLOBAL_dirs.base_dir);
+
+
+
+ /* connect my internal structure to the blank pointer passed to me */
+ *module_interface = switch_loadable_module_create_module_interface(pool, modname);
+ SWITCH_ADD_APP(app_interface, "perl", NULL, NULL, perl_function, NULL, SAF_NONE);
+ SWITCH_ADD_API(api_interface, "perlrun", "run a script", perlrun_api_function, "