ef78e42000-08-01Leif Stensson #include <module.h> inherit "module"; inherit "roxenlib";
2304b92000-12-18Leif Stensson // Perl script and tag handler module.
ef78e42000-08-01Leif Stensson // by Leif Stensson. string cvs_version =
bfe4e82001-01-12Leif Stensson  "$Id: perl.pike,v 2.17 2001/01/12 16:55:48 leif Exp $";
ef78e42000-08-01Leif Stensson 
2304b92000-12-18Leif Stensson constant module_type = MODULE_FILE_EXTENSION | MODULE_TAG;
ef78e42000-08-01Leif Stensson  constant module_name = "Perl support"; constant module_doc =
2304b92000-12-18Leif 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; " "container to run Perl code from inside RXML pages."; static string recent_error = 0; static int parsed_tags = 0, script_calls = 0, script_errors = 0;
d4c7322000-08-17Leif Stensson static mapping handler_settings = ([ ]);
ef78e42000-08-01Leif Stensson constant thread_safe = 1; #ifdef THREADS static object mutex = Thread.Mutex(); #endif void create() { defvar("extensions", ({ "pl", "perl" }), "Extensions", TYPE_STRING_LIST, "List of URL extensions that should be taken to indicate that the " "document is a Perl script."); #if 0 defvar("libdir", "./perl", "Roxen Perl Directory", TYPE_DIR, "This is the name of a directory with Roxen-related Perl stuff. It " "should normally point to `perl' in the Roxen server directory, " "but you may want to point it elsewhere if you want to modify the " "code."); #endif defvar("showbacktrace", 0, "Show Backtraces", TYPE_FLAG, "This setting decides whether to deliver a backtrace in the document " "if an error is caught while a script runs."); defvar("tagenable", 0, "Enable Perl Tag", TYPE_FLAG, "This setting decides whether to enable parsing of Perl code in " "RXML pages, in &lt;perl&gt;..&lt;/perl&gt; containers."); defvar("scriptout", "HTML", "Script output", TYPE_MULTIPLE_STRING, "How to treat script output. HTML means treat it as a plain HTML " "document. RXML is similar, but passes it through the RXML parser " "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 " "data.", ({ "HTML", "RXML", "HTTP" }) ); defvar("rxmltag", 0, "RXML-parse tag results", TYPE_FLAG, "Allow RXML parsing of tag results.");
2304b92000-12-18Leif Stensson  defvar("helper", #if constant(system.NetWkstaUserEnum) // NT
bfe4e82001-01-12Leif Stensson  "perl/bin/ntperl.pl",
2304b92000-12-18Leif Stensson #else // Assume Unix "perl/bin/perlrun", #endif "Perl Helper", TYPE_DIR, "Path to the Perl helper program used to start Perl subprocesses.");
ef78e42000-08-01Leif Stensson  defvar("parallel", 2, "Parallel scripts", TYPE_MULTIPLE_INT, "Number of scripts/tags that may be evaluated in parallel. Don't set " "this higher than necessary, since it may cause the server to block. " "The default for this setting is 2.", ({ 1, 2, 3, 4, 5 }) );
d4c7322000-08-17Leif Stensson 
42b2932000-08-23Leif Stensson #if constant(getpwnam)
d4c7322000-08-17Leif Stensson  defvar("identity", "nobody:*", "Run Perl as...", TYPE_STRING, "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 " "same as Roxen'."); #endif
ef78e42000-08-01Leif Stensson } string status() { string s = "<b>Script calls</b>: " + script_calls + " <br />\n" + "<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>: ";
2304b92000-12-18Leif Stensson  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()
2304b92000-12-18Leif Stensson { return ExtScript.getscripthandler(QUERY(helper),
d4c7322000-08-17Leif Stensson  QUERY(parallel), handler_settings); } static void fix_settings() { string u, g; mapping s = ([ ]);
42b2932000-08-23Leif Stensson #if constant(getpwnam)
d4c7322000-08-17Leif Stensson  if (sscanf(QUERY(identity), "%s:%s", u, g) == 2) { 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; }
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()
d4c7322000-08-17Leif Stensson { fix_settings(); call_out(periodic, 900);
ef78e42000-08-01Leif Stensson } mixed handle_file_extension(Stdio.File file, string ext, object id)
d4c7322000-08-17Leif Stensson { object h = gethandler();
ef78e42000-08-01Leif Stensson  if (id->realfile && stringp(id->realfile)) { array result;
d4c7322000-08-17Leif Stensson  NOCACHE();
ef78e42000-08-01Leif Stensson  if (!h) return http_string_answer("<h1>Script support failed.</h1>"); mixed bt = catch (result = h->run(id->realfile, id)); ++script_calls; if (bt) { ++script_errors;
d4c7322000-08-17Leif Stensson  report_error("Perl script `" + id->realfile + "' failed.\n");
ef78e42000-08-01Leif Stensson  if (QUERY(showbacktrace)) return http_string_answer("<h1>Script Error!</h1>\n<pre>" + describe_backtrace(bt) + "\n</pre>"); else return http_string_answer("<h1>Script Error!</h1>"); } else if (sizeof(result) > 1) { string r = result[1]; // werror("Result: " + sprintf("%O", r) + "\n"); if (r == "") r = " "; // Some browsers don't like null answers. if (!stringp(r)) r = "(not a string)"; switch (QUERY(scriptout)) { case "RXML": return http_rxml_answer(r, id); case "HTML": return http_string_answer(r); case "HTTP": id->connection()->write("HTTP/1.0 200 OK\r\n"); id->connection()->write(r); id->connection()->close(); return http_pipe_in_progress(); default: return http_string_answer("SCRIPT ERROR: " "bad output mode configured.\n"); } } else { return http_string_answer(sprintf("RESULT: %O", result)); } } return http_string_answer("FOO!"); return 0; } constant simpletag_perl_flags = 0; mixed simpletag_perl(string tag, mapping attr, string contents, object id, RXML.Frame frame) { if (!QUERY(tagenable)) RXML.run_error("<perl>...</perl> tag not enabled in this server.");
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]); else if (QUERY(rxmltag)) { frame->result_type = frame->result_type(RXML.PXml); return parse_rxml(result[1], id); } else return result[1]; } else return sprintf("SCRIPT ERROR: bad result: %O", result); return "<b>(No perl tag support?)</b>"; }
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 { return QUERY(extensions);
ef78e42000-08-01Leif Stensson }
f8dd6d2000-09-18Kenneth Johansson TAGDOCUMENTATION; #ifdef manual constant tagdoc=([
523da02000-11-09Kenneth Johansson "?perl":#"<desc pi='pi'><p><short hide='hide'>
3debdf2000-09-20Kenneth Johansson  Perl processing instruction tag.</short>This processing intruction
190c062000-11-03Kenneth 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 
94bc9d2000-10-13Kenneth Johansson  <p>There is also a <tag>perl</tag>...<tag>/perl</tag> container tag
f8dd6d2000-09-18Kenneth Johansson  available.</p> </desc>", ]); #endif
ef78e42000-08-01Leif Stensson