f41b982009-05-07Martin Stjernholm // This is a roxen module. Copyright © 2000 - 2009, Roxen IS.
e5a6302001-01-30Leif Stensson // Perl script and tag handler module.
3d5fa42001-01-12Leif Stensson // by Leif Stensson. #include <roxen.h> #include <module.h>
eb73ee2003-06-26Anders Johansson //<locale-token project="mod_perl">LOCALE</locale-token>
3d5fa42001-01-12Leif Stensson // USE_DEFERRED_LOCALE;
eb73ee2003-06-26Anders Johansson #define LOCALE(X,Y) _DEF_LOCALE("mod_perl",X,Y)
3d5fa42001-01-12Leif Stensson 
ef78e42000-08-01Leif Stensson #include <module.h> inherit "module"; inherit "roxenlib"; string cvs_version =
0917d32013-03-04Anders Johansson  "$Id$";
ef78e42000-08-01Leif Stensson 
3d5fa42001-01-12Leif Stensson constant module_type = MODULE_FILE_EXTENSION | MODULE_TAG;
ef78e42000-08-01Leif Stensson 
f7bd0d2001-03-03Per Hedbor constant module_name = "Scripting: Perl support";
ef78e42000-08-01Leif Stensson constant module_doc =
3d5fa42001-01-12Leif Stensson  "This module provides a faster way of running Perl scripts with Roxen. "
ef78e42000-08-01Leif Stensson  "The module also optionally provides a &lt;perl&gt;..&lt;/perl&gt; "
e5a6302001-01-30Leif Stensson  "container (and a corresponding processing instruction &lt;?perl ... " "?&gt;) to run Perl code from inside RXML pages.";
ef78e42000-08-01Leif Stensson 
fc40392008-08-15Martin Stjernholm protected string recent_error = 0; protected int parsed_tags = 0, script_calls = 0, script_errors = 0;
ef78e42000-08-01Leif Stensson 
fc40392008-08-15Martin Stjernholm protected mapping handler_settings = ([ ]);
d4c7322000-08-17Leif Stensson 
fc40392008-08-15Martin Stjernholm protected int cache_output;
09202e2001-08-08Leif Stensson 
fc40392008-08-15Martin Stjernholm protected string script_output_mode;
3d5fa42001-01-12Leif Stensson 
ef78e42000-08-01Leif Stensson constant thread_safe = 1; #ifdef THREADS
fc40392008-08-15Martin Stjernholm protected object mutex = Thread.Mutex();
ef78e42000-08-01Leif Stensson #endif void create() {
575c2b2001-11-01Henrik Grubbström (Grubba)  defvar("extensions", ({ "pl", "perl" }),
eb73ee2003-06-26Anders Johansson  LOCALE(1,"Extensions"), TYPE_STRING_LIST, LOCALE(2,"List of URL extensions that indicate that the document "
575c2b2001-11-01Henrik Grubbström (Grubba)  "is a Perl script."));
ef78e42000-08-01Leif Stensson  #if 0
3d5fa42001-01-12Leif Stensson  defvar("libdir", "./perl",
eb73ee2003-06-26Anders Johansson  LOCALE(3, "Roxen Perl Directory"), TYPE_DIR, LOCALE(4, "This is the name of a directory with Roxen-related Perl "
3d5fa42001-01-12Leif Stensson  "stuff. It should normally point to `perl' in the Roxen server directory, "
ef78e42000-08-01Leif Stensson  "but you may want to point it elsewhere if you want to modify the "
3d5fa42001-01-12Leif Stensson  "code."));
ef78e42000-08-01Leif Stensson #endif
3d5fa42001-01-12Leif Stensson  defvar("showbacktrace", 0,
eb73ee2003-06-26Anders Johansson  LOCALE(5, "Show Backtraces"), TYPE_FLAG, LOCALE(6, "This setting decides whether to deliver a backtrace in the "
09202e2001-08-08Leif Stensson  "document if an error is caught while a script runs."));
ef78e42000-08-01Leif Stensson 
3d5fa42001-01-12Leif Stensson  defvar("tagenable", 0,
eb73ee2003-06-26Anders Johansson  LOCALE(7, "Enable Perl Tag"), TYPE_FLAG, LOCALE(8, "This setting decides whether to enable parsing of Perl code "
3d5fa42001-01-12Leif Stensson  "in RXML pages, in &lt;perl&gt;..&lt;/perl&gt; containers."));
ef78e42000-08-01Leif Stensson 
3d5fa42001-01-12Leif Stensson  defvar("scriptout", "HTTP",
eb73ee2003-06-26Anders Johansson  LOCALE(9, "Script output"), TYPE_MULTIPLE_STRING, LOCALE(10, "How to treat script output. HTML means treat it as a plain "
3d5fa42001-01-12Leif Stensson  "HTML document. RXML is similar, but passes it through the RXML parser "
ef78e42000-08-01Leif Stensson  "before returning it to the client. HTTP is the traditional CGI " "output style, where the script is responsible for producing the " "HTTP headers before the document, as well as the main document "
3d5fa42001-01-12Leif Stensson  "data."),
ef78e42000-08-01Leif Stensson  ({ "HTML", "RXML", "HTTP" }) );
3d5fa42001-01-12Leif Stensson  defvar("rxmltag", 0,
eb73ee2003-06-26Anders Johansson  LOCALE(11, "RXML-parse tag results"), TYPE_FLAG, LOCALE(12, "Whether to RXML parse tag results or not."));
3d5fa42001-01-12Leif Stensson  #if constant(system.NetWkstaUserEnum) // WinNT. defvar("helper", "perl/bin/ntperl.pl",
eb73ee2003-06-26Anders Johansson  LOCALE(13, "Perl Helper"), TYPE_FILE, LOCALE(14, "Path to the helper program used to start a Perl subprocess. "
3d5fa42001-01-12Leif Stensson  "The default for this setting is `perl/bin/ntperl.pl'.")); #else // Assume Unix. defvar("helper", "perl/bin/perlrun",
eb73ee2003-06-26Anders Johansson  LOCALE(13, "Perl Helper"), TYPE_FILE, LOCALE(15, "Path to the helper program used to start a Perl subprocess. "
3d5fa42001-01-12Leif Stensson  "The default for this setting is `perl/bin/perlrun'.")); #endif
ef78e42000-08-01Leif Stensson 
09202e2001-08-08Leif Stensson  defvar("parallel", 3,
eb73ee2003-06-26Anders Johansson  LOCALE(16, "Parallel scripts"), TYPE_MULTIPLE_INT, LOCALE(17, "Number of scripts/tags that may be evaluated in parallel. "
3d5fa42001-01-12Leif Stensson  "Don't set this higher than necessary, since it may cause the server "
09202e2001-08-08Leif Stensson  "to block (by using all available threads). The default for this " "setting is 3."), ({ 1, 2, 3, 4, 5, 6 }) ); defvar("caching", 0,
eb73ee2003-06-26Anders Johansson  LOCALE(18, "Cache output"), TYPE_FLAG, LOCALE(19, "Whether to cache the result of scripts. This is usually "
09202e2001-08-08Leif Stensson  "not desirable, so the default for this setting is No."));
d4c7322000-08-17Leif Stensson 
42b2932000-08-23Leif Stensson #if constant(getpwnam)
3d5fa42001-01-12Leif Stensson  defvar("identity", "nobody:*",
eb73ee2003-06-26Anders Johansson  LOCALE(20, "Run Perl as..."), TYPE_STRING, LOCALE(21, "User and group to run Perl scripts and tags as. The default "
3d5fa42001-01-12Leif Stensson  "for this option is `nobody:*'. Note that Roxen can't change user ID "
ba1c9e2000-08-22Leif Stensson  "unless it has sufficient permissions to do so. `*' means `use "
3d5fa42001-01-12Leif Stensson  "same as Roxen'."));
ba1c9e2000-08-22Leif Stensson #endif
ef78e42000-08-01Leif Stensson } string status()
3d5fa42001-01-12Leif Stensson { string s = "<b>Script calls</b>: " + script_calls + " <br />\n" +
ef78e42000-08-01Leif Stensson  "<b>Script errors</b>: " + script_errors + " <br />\n" + "<b>Parsed tags</b>: " + parsed_tags + " <br />\n";
42b2932000-08-23Leif Stensson #if constant(getpwnam)
d4c7322000-08-17Leif Stensson  if (handler_settings->set_uid) s += sprintf("<b>Subprocess UID</b>: set uid=%O <br />\n", handler_settings->set_uid); else s += "<b>Subprocess UID</b>: same as Roxen<br />\n";
ba1c9e2000-08-22Leif Stensson #endif
d4c7322000-08-17Leif Stensson  s += "<b>Helper script</b>: ";
ed540b2001-01-13Martin Nilsson  if (Stdio.File(query("helper"), "r")) s += "found: " + query("helper")+" <br />\n";
d4c7322000-08-17Leif Stensson  else s += "not found.<br />\n";
ef78e42000-08-01Leif Stensson  if (recent_error) s += "<b>Most recent error</b>: " + recent_error + " <br />\n"; return s; }
fc40392008-08-15Martin Stjernholm protected object gethandler()
ed540b2001-01-13Martin Nilsson { return ExtScript.getscripthandler(query("helper"), query("parallel"), handler_settings);
d4c7322000-08-17Leif Stensson }
fc40392008-08-15Martin Stjernholm protected void fix_settings()
d4c7322000-08-17Leif Stensson { mapping s = ([ ]);
42b2932000-08-23Leif Stensson #if constant(getpwnam)
03b0022008-10-21Martin Stjernholm  if (sscanf(query("identity"), "%s:%s", string u, string g) == 2)
d4c7322000-08-17Leif Stensson  { array ua = getpwnam(u), ga = getgrnam(g); if (!ua) ua = getpwuid((int) u); if (!ga) ga = getgrgid((int) g); if (ua) s->set_uid = ua[2]; if (ga) s->set_gid = ga[2]; }
ba1c9e2000-08-22Leif Stensson #endif
d4c7322000-08-17Leif Stensson  handler_settings = s;
09202e2001-08-08Leif Stensson  cache_output = query("caching");
d4c7322000-08-17Leif Stensson }
fc40392008-08-15Martin Stjernholm protected void periodic()
d4c7322000-08-17Leif Stensson { fix_settings(); ExtScript.periodic_cleanup();
ef78e42000-08-01Leif Stensson  call_out(periodic, 900); } void start()
3d5fa42001-01-12Leif Stensson { periodic();
ed540b2001-01-13Martin Nilsson  script_output_mode = query("scriptout");
3d5fa42001-01-12Leif Stensson }
fc40392008-08-15Martin Stjernholm protected void add_headers(string headers, object id)
3d5fa42001-01-12Leif Stensson { string header, name, value; if (headers) foreach(headers / "\r\n", header) { if (sscanf(header, "%[^:]:%s", name, value) == 2) switch (name) { case "Content-Type": case "Content-Encoding": case "Content-Languages": // Might require special treatment in the future? ;
3e77c72002-01-30Martin Stjernholm  default: id->add_response_header (name, value);
3d5fa42001-01-12Leif Stensson  } } }
fc40392008-08-15Martin Stjernholm protected void do_response_callback(RequestID id, array result)
3d5fa42001-01-12Leif Stensson { // werror("perl:do_response_callback: %O %O\n", id, result); id->connection()->write("HTTP/1.0 200 OK\r\n"); if (arrayp(result) && sizeof(result) > 1) { if (sizeof(result) > 2 && stringp(result[2])) { foreach(result[2] / "\r\n" - "", string s) id->connection()->write(s + "\r\n"); id->connection()->write("\r\n"); } id->connection()->write(result[1]); } id->connection()->close();
ef78e42000-08-01Leif Stensson } mixed handle_file_extension(Stdio.File file, string ext, object id)
09202e2001-08-08Leif Stensson { object h = gethandler();
ef78e42000-08-01Leif Stensson  if (id->realfile && stringp(id->realfile)) { array result;
09202e2001-08-08Leif Stensson  if (!cache_output) { NOCACHE(); }
d4c7322000-08-17Leif Stensson 
3d5fa42001-01-12Leif Stensson  if (!h)
e5a6302001-01-30Leif Stensson  return Roxen.http_string_answer("<h1>Script support failed.</h1>");
ef78e42000-08-01Leif Stensson 
3d5fa42001-01-12Leif Stensson  mixed bt;
e5a6302001-01-30Leif Stensson 
3d5fa42001-01-12Leif Stensson  if (script_output_mode == "HTTP") bt = catch (result = h->run(id->realfile, id, do_response_callback)); else bt = catch (result = h->run(id->realfile, id));
ef78e42000-08-01Leif Stensson  ++script_calls; if (bt)
e5a6302001-01-30Leif Stensson  { ++script_errors;
d4c7322000-08-17Leif Stensson  report_error("Perl script `" + id->realfile + "' failed.\n");
ed540b2001-01-13Martin Nilsson  if (query("showbacktrace"))
3d5fa42001-01-12Leif Stensson  return Roxen.http_string_answer("<h1>Script Error!</h1>\n<pre>" +
ef78e42000-08-01Leif Stensson  describe_backtrace(bt) + "\n</pre>"); else
3d5fa42001-01-12Leif Stensson  return Roxen.http_string_answer("<h1>Script Error!</h1>");
ef78e42000-08-01Leif Stensson  }
3d5fa42001-01-12Leif Stensson  else if (arrayp(result)) { string r = sizeof(result) > 1 ? result[1] : "";
e5a6302001-01-30Leif Stensson 
ef78e42000-08-01Leif Stensson // werror("Result: " + sprintf("%O", r) + "\n"); if (r == "") r = " "; // Some browsers don't like null answers. if (!stringp(r)) r = "(not a string)";
e5a6302001-01-30Leif Stensson 
3d5fa42001-01-12Leif Stensson  switch (script_output_mode)
e5a6302001-01-30Leif Stensson  { case "RXML":
3d5fa42001-01-12Leif Stensson  if (sizeof(result) > 2 && stringp(result[2])) add_headers(result[2], id); return Roxen.http_rxml_answer(r, id);
e5a6302001-01-30Leif Stensson 
ef78e42000-08-01Leif Stensson  case "HTML":
3d5fa42001-01-12Leif Stensson  if (sizeof(result) > 2 && stringp(result[2])) add_headers(result[2], id); return Roxen.http_string_answer(r);
e5a6302001-01-30Leif Stensson 
ef78e42000-08-01Leif Stensson  case "HTTP":
3d5fa42001-01-12Leif Stensson  if (sizeof(result) > 0) { id->connection()->write("HTTP/1.0 200 OK\r\n"); id->connection()->write(r); id->connection()->close(); // werror("id/perl: connection closed.\n"); } // else werror("id/perl: nonblocking.\n"); return Roxen.http_pipe_in_progress();
e5a6302001-01-30Leif Stensson 
ef78e42000-08-01Leif Stensson  default:
3d5fa42001-01-12Leif Stensson  return Roxen.http_string_answer("SCRIPT ERROR: "
e5a6302001-01-30Leif Stensson  "bad output mode configured.\n");
ef78e42000-08-01Leif Stensson  } } else
e5a6302001-01-30Leif Stensson  return Roxen.http_string_answer(sprintf("RESULT: %O", result));
ef78e42000-08-01Leif Stensson  }
09202e2001-08-08Leif Stensson #if 1 return http_string_answer("Script file not accessible in this filesystem " "(no real file)."); #else // Possible security leak allowing people to read the contents // of script files.
ef78e42000-08-01Leif Stensson  return 0;
09202e2001-08-08Leif Stensson #endif
ef78e42000-08-01Leif Stensson } constant simpletag_perl_flags = 0; mixed simpletag_perl(string tag, mapping attr, string contents, object id, RXML.Frame frame) {
ed540b2001-01-13Martin Nilsson  if (!query("tagenable"))
3d5fa42001-01-12Leif Stensson  RXML.run_error("Perl tag not enabled in this server.");
ef78e42000-08-01Leif Stensson 
d4c7322000-08-17Leif Stensson  object h = gethandler();
ef78e42000-08-01Leif Stensson  if (!h) RXML.run_error("Perl tag support unavailable.");
d4c7322000-08-17Leif Stensson  NOCACHE();
ef78e42000-08-01Leif Stensson  array result; mixed bt = catch (result = h->eval(contents, id)); ++parsed_tags; if (bt) { werror("Perl tag backtrace:\n" + describe_backtrace(bt) + "\n"); RXML.run_error("Perl tag"); } else if (sizeof(result) > 1) { if (result[0] < 0 || !stringp(result[1])) return "SCRIPT ERROR: " + sprintf("%O", result[1]);
ed540b2001-01-13Martin Nilsson  else if (query("rxmltag"))
ef78e42000-08-01Leif Stensson  { frame->result_type = frame->result_type(RXML.PXml);
3d5fa42001-01-12Leif Stensson  return Roxen.parse_rxml(result[1], id);
ef78e42000-08-01Leif Stensson  } else return result[1]; } else return sprintf("SCRIPT ERROR: bad result: %O", result);
3d5fa42001-01-12Leif Stensson  return "<b>(?perl?)</b>";
ef78e42000-08-01Leif Stensson }
2db3732000-08-08Leif Stensson mixed simple_pi_tag_perl(string tag, mapping attr, string contents, object id, RXML.Frame frame)
d4c7322000-08-17Leif Stensson { return simpletag_perl(tag, attr, contents, id, frame);
2db3732000-08-08Leif Stensson }
ef78e42000-08-01Leif Stensson array(string) query_file_extensions()
d4c7322000-08-17Leif Stensson {
575c2b2001-11-01Henrik Grubbström (Grubba)  return query("extensions");
ef78e42000-08-01Leif Stensson }
f8dd6d2000-09-18Kenneth Johansson TAGDOCUMENTATION; #ifdef manual constant tagdoc=([
ce8fb02001-09-21Johan Sundström "?perl":#"<desc type='pi'><p><short hide='hide'>
3debdf2000-09-20Kenneth Johansson  Perl processing instruction tag.</short>This processing intruction
e8d1032000-09-20Kenneth Johansson  tag allows for evaluating Perl code directly in the document.</p>
ef78e42000-08-01Leif Stensson 
f8dd6d2000-09-18Kenneth Johansson  <p>Note: Read the installation and configuration documentation in the Administration manual to set up the Perl support properly. If the correct parameters are not set the Perl code might not work properly or security issues might arise.</p>
ef78e42000-08-01Leif Stensson 
7dfc6a2001-07-20Johan Sundström  <p>There is also a <tag>perl</tag>...<tag>/perl</tag> container tag
f8dd6d2000-09-18Kenneth Johansson  available.</p> </desc>", ]); #endif