42cd712001-09-03Martin Nilsson // This is a roxen module. Copyright © 2000 - 2001, 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> //<locate-token project="perl_module">LOCALE</locale-token> // USE_DEFERRED_LOCALE; #define LOCALE(X,Y) _DEF_LOCALE("perl_module",X,Y)
ef78e42000-08-01Leif Stensson #include <module.h> inherit "module"; inherit "roxenlib"; string cvs_version =
3e77c72002-01-30Martin Stjernholm  "$Id: perl.pike,v 2.23 2002/01/30 00:19:42 mast Exp $";
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  static string recent_error = 0; static int parsed_tags = 0, script_calls = 0, script_errors = 0;
d4c7322000-08-17Leif Stensson static mapping handler_settings = ([ ]);
09202e2001-08-08Leif Stensson static int cache_output;
3d5fa42001-01-12Leif Stensson static string script_output_mode;
ef78e42000-08-01Leif Stensson constant thread_safe = 1; #ifdef THREADS static object mutex = Thread.Mutex(); #endif void create() {
575c2b2001-11-01Henrik Grubbström (Grubba)  defvar("extensions", ({ "pl", "perl" }), LOCALE(0,"Extensions"), TYPE_STRING_LIST, LOCALE(0,"List of URL extensions that indicate that the document " "is a Perl script."));
ef78e42000-08-01Leif Stensson  #if 0
3d5fa42001-01-12Leif Stensson  defvar("libdir", "./perl", LOCALE(0, "Roxen Perl Directory"), TYPE_DIR, LOCALE(0, "This is the name of a directory with Roxen-related Perl " "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, LOCALE(0, "Show Backtraces"), TYPE_FLAG, LOCALE(0, "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, LOCALE(0, "Enable Perl Tag"), TYPE_FLAG, LOCALE(0, "This setting decides whether to enable parsing of Perl code " "in RXML pages, in &lt;perl&gt;..&lt;/perl&gt; containers."));
ef78e42000-08-01Leif Stensson 
3d5fa42001-01-12Leif Stensson  defvar("scriptout", "HTTP", LOCALE(0, "Script output"), TYPE_MULTIPLE_STRING, LOCALE(0, "How to treat script output. HTML means treat it as a plain " "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, LOCALE(0, "RXML-parse tag results"), TYPE_FLAG, LOCALE(0, "Whether to RXML parse tag results or not.")); #if constant(system.NetWkstaUserEnum) // WinNT. defvar("helper", "perl/bin/ntperl.pl", LOCALE(0, "Perl Helper"), TYPE_FILE, LOCALE(0, "Path to the helper program used to start a Perl subprocess. " "The default for this setting is `perl/bin/ntperl.pl'.")); #else // Assume Unix. defvar("helper", "perl/bin/perlrun", LOCALE(0, "Perl Helper"), TYPE_FILE, LOCALE(0, "Path to the helper program used to start a Perl subprocess. " "The default for this setting is `perl/bin/perlrun'.")); #endif
ef78e42000-08-01Leif Stensson 
09202e2001-08-08Leif Stensson  defvar("parallel", 3,
3d5fa42001-01-12Leif Stensson  LOCALE(0, "Parallel scripts"), TYPE_MULTIPLE_INT, LOCALE(0, "Number of scripts/tags that may be evaluated in parallel. " "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, LOCALE(0, "Cache output"), TYPE_FLAG, LOCALE(0, "Whether to cache the result of scripts. This is usually " "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:*", LOCALE(0, "Run Perl as..."), TYPE_STRING, LOCALE(0, "User and group to run Perl scripts and tags as. The default " "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; }
d4c7322000-08-17Leif Stensson static object gethandler()
ed540b2001-01-13Martin Nilsson { return ExtScript.getscripthandler(query("helper"), query("parallel"), handler_settings);
d4c7322000-08-17Leif Stensson } static void fix_settings() { string u, g; mapping s = ([ ]);
42b2932000-08-23Leif Stensson #if constant(getpwnam)
ed540b2001-01-13Martin Nilsson  if (sscanf(query("identity"), "%s:%s", u, 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 }
ef78e42000-08-01Leif Stensson static 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 } static void add_headers(string headers, object id) { 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  } } } static void do_response_callback(RequestID id, array result) { // 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