| /* ==================================================================== |
| * The Apache Software License, Version 1.1 |
| * |
| * Copyright (c) 2000 The Apache Software Foundation. All rights |
| * reserved. |
| * |
| * Redistribution and use in source and binary forms, with or without |
| * modification, are permitted provided that the following conditions |
| * are met: |
| * |
| * 1. Redistributions of source code must retain the above copyright |
| * notice, this list of conditions and the following disclaimer. |
| * |
| * 2. Redistributions in binary form must reproduce the above copyright |
| * notice, this list of conditions and the following disclaimer in |
| * the documentation and/or other materials provided with the |
| * distribution. |
| * |
| * 3. The end-user documentation included with the redistribution, |
| * if any, must include the following acknowledgment: |
| * "This product includes software developed by the |
| * Apache Software Foundation (http://www.apache.org/)." |
| * Alternately, this acknowledgment may appear in the software itself, |
| * if and wherever such third-party acknowledgments normally appear. |
| * |
| * 4. The names "Apache" and "Apache Software Foundation" must |
| * not be used to endorse or promote products derived from this |
| * software without prior written permission. For written |
| * permission, please contact apache@apache.org. |
| * |
| * 5. Products derived from this software may not be called "Apache", |
| * nor may "Apache" appear in their name, without prior written |
| * permission of the Apache Software Foundation. |
| * |
| * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED |
| * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES |
| * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE |
| * DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR |
| * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, |
| * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT |
| * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF |
| * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND |
| * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, |
| * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT |
| * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF |
| * SUCH DAMAGE. |
| * ==================================================================== |
| * |
| * This software consists of voluntary contributions made by many |
| * individuals on behalf of the Apache Software Foundation. For more |
| * information on the Apache Software Foundation, please see |
| * <http://www.apache.org/>. |
| * |
| * Portions of this software are based upon public domain software |
| * originally written at the National Center for Supercomputing Applications, |
| * University of Illinois, Urbana-Champaign. |
| */ |
| |
| #include "mod_tcl.h" |
| |
| static int tcl_init(apr_pool_t *pconf, apr_pool_t *plog, apr_pool_t *ptemp); |
| static apr_status_t tcl_cleanup(void *data); |
| static int tcl_init_handler(apr_pool_t *pconf, apr_pool_t *plog, apr_pool_t *ptemp, server_rec *s); |
| static void* tcl_create_dir_config(apr_pool_t *p, char *d); |
| |
| /* 0 */ inline int tcl_handler(request_rec *r); |
| /* 1 */ inline int tcl_post_read_request(request_rec *r); |
| /* 2 */ inline int tcl_translate_name(request_rec *r); |
| /* 3 */ inline int tcl_header_parser(request_rec *r); |
| /* 4 */ inline int tcl_access_checker(request_rec *r); |
| /* 5 */ inline int tcl_check_user_id(request_rec *r); |
| /* 6 */ inline int tcl_auth_checker(request_rec *r); |
| /* 7 */ inline int tcl_type_checker(request_rec *r); |
| /* 8 */ inline int tcl_fixups(request_rec *r); |
| /* 9 */ inline int tcl_log_transaction(request_rec *r); |
| |
| static const char* add_hand1(cmd_parms *parms, void *mconfig, const char *arg); |
| static const char* add_hand2(cmd_parms *parms, void *mconfig, const char *arg1, const char *arg2); |
| static const char* sfl(cmd_parms *parms, void *mconfig, int flag); |
| static const char* tcl_set(cmd_parms *parms, void *mconfig, const char *one, const char *two, const char *three); |
| static const char* tcl_setlist(cmd_parms *parms, void *mconfig, const char *one, const char *two); |
| //static const char* tcl_raw_args(cmd_parms *parms, void *mconfig, char *arg); |
| |
| //typedef const char* (*fz_t)(void); |
| |
| static const command_rec tcl_commands[] = { |
| /* this doesn't do anything anymore */ |
| AP_INIT_FLAG( "Tcl", /*(fz_t)*/ sfl, (void*) 1, OR_AUTHCFG, "turn mod_tcl on or off." ), |
| AP_INIT_TAKE23( "Tcl_Var", /*(fz_t)*/ tcl_set, NULL, OR_AUTHCFG, "set global variables in TCL." ), |
| AP_INIT_TAKE2( "Tcl_ListVar", /*(fz_t)*/ tcl_setlist, NULL, OR_AUTHCFG, "set global list variables." ), |
| |
| /* this will be phased out, it should now be, Tcl_ContentHandler */ |
| AP_INIT_TAKE1( "Tcl_ContentHandlers", /*(fz_t)*/ add_hand1, (void*) 8, OR_AUTHCFG, "add content handler." ), |
| AP_INIT_TAKE1( "Tcl_ContentHandler", /*(fz_t)*/ add_hand1, (void*) 8, OR_AUTHCFG, "add content handlers." ), |
| |
| AP_INIT_TAKE2( "Tcl_Hook_Post_Read_Request", /*(fz_t)*/ add_hand2, (void*) 0, OR_AUTHCFG, "add post_read_request handlers." ), |
| AP_INIT_TAKE2( "Tcl_Hook_Translate_Name", /*(fz_t)*/ add_hand2, (void*) 1, OR_AUTHCFG, "add translate_name handlers." ), |
| AP_INIT_TAKE2( "Tcl_Hook_Header_Parser", /*(fz_t)*/ add_hand2, (void*) 2, OR_AUTHCFG, "add header_parser handlers." ), |
| AP_INIT_TAKE2( "Tcl_Hook_Access_Checker", /*(fz_t)*/ add_hand2, (void*) 3, OR_AUTHCFG, "add access_checker handlers." ), |
| AP_INIT_TAKE2( "Tcl_Hook_Check_User_ID", /*(fz_t)*/ add_hand2, (void*) 4, OR_AUTHCFG, "add check_user_id handlers." ), |
| AP_INIT_TAKE2( "Tcl_Hook_Auth_Checker", /*(fz_t)*/ add_hand2, (void*) 5, OR_AUTHCFG, "add auth_checker handlers." ), |
| AP_INIT_TAKE2( "Tcl_Hook_Type_Checker", /*(fz_t)*/ add_hand2, (void*) 6, OR_AUTHCFG, "add type_checker handlers." ), |
| AP_INIT_TAKE2( "Tcl_Hook_Fixups", /*(fz_t)*/ add_hand2, (void*) 7, OR_AUTHCFG, "add fixups handlers." ), |
| AP_INIT_TAKE1( "Tcl_Hook_Handler", /*(fz_t)*/ add_hand1, (void*) 8, OR_AUTHCFG, "add content handler." ), |
| AP_INIT_TAKE2( "Tcl_Hook_Log_Transaction", /*(fz_t)*/ add_hand2, (void*) 9, OR_AUTHCFG, "add log_transaction handlers." ), |
| // AP_INIT_RAW_ARGS( "<Tcl>", /*(fz_t)*/ tcl_raw_args, NULL, RSRC_CONF|EXEC_ON_READ, "add raw tcl to the interpreter." ), |
| { NULL } |
| }; |
| |
| static void register_hooks(apr_pool_t *p) |
| { |
| ap_hook_pre_config(tcl_init, NULL, NULL, APR_HOOK_REALLY_FIRST); |
| ap_hook_post_config(tcl_init_handler, NULL, NULL, APR_HOOK_MIDDLE); |
| |
| ap_hook_post_read_request(tcl_post_read_request, NULL, NULL, APR_HOOK_MIDDLE); |
| ap_hook_translate_name(tcl_translate_name, NULL, NULL, APR_HOOK_MIDDLE); |
| ap_hook_header_parser(tcl_header_parser, NULL, NULL, APR_HOOK_MIDDLE); |
| ap_hook_access_checker(tcl_access_checker, NULL, NULL, APR_HOOK_MIDDLE); |
| ap_hook_check_user_id(tcl_check_user_id, NULL, NULL, APR_HOOK_MIDDLE); |
| ap_hook_auth_checker(tcl_auth_checker, NULL, NULL, APR_HOOK_MIDDLE); |
| ap_hook_type_checker(tcl_type_checker, NULL, NULL, APR_HOOK_MIDDLE); |
| ap_hook_fixups(tcl_fixups, NULL, NULL, APR_HOOK_MIDDLE); |
| ap_hook_handler(tcl_handler, NULL, NULL, APR_HOOK_MIDDLE); |
| ap_hook_log_transaction(tcl_log_transaction, NULL, NULL, APR_HOOK_MIDDLE); |
| } |
| |
| AP_DECLARE_DATA module tcl_module = { |
| STANDARD20_MODULE_STUFF, |
| tcl_create_dir_config, /* create per-directory config structure */ |
| NULL, /* merge per-directory config structures */ |
| NULL, /* create per-server config structure */ |
| NULL, /* merge per-server config structures */ |
| tcl_commands, /* command apr_table_t */ |
| register_hooks /* register hooks */ |
| }; |
| |
| typedef struct { |
| char *var1, *var2, *var3; |
| int fl; |
| } var_cache; |
| |
| typedef struct { |
| int fl; |
| char *handlers[10]; |
| char *file_location[10]; |
| apr_array_header_t *var_list; |
| } tcl_config_rec; |
| |
| typedef struct { |
| char *file; |
| struct stat st; |
| } file_cache; |
| |
| Tcl_Interp *interp = NULL; |
| apr_array_header_t *fcache = NULL; |
| char *raw_tcl = NULL; |
| apr_pool_t *_pconf = NULL; |
| request_rec *_r = NULL; |
| char *current_namespace = NULL; |
| int read_post_ok; |
| |
| static void* tcl_create_dir_config(apr_pool_t *p, char *d) |
| { |
| int i; |
| tcl_config_rec *tclr = (tcl_config_rec*) apr_pcalloc(p, sizeof(tcl_config_rec)); |
| |
| tclr->fl = 0; |
| tclr->var_list = apr_array_make(p, 0, sizeof(var_cache)); |
| |
| memset(tclr->handlers, 0, 10 * sizeof(char*)); |
| memset(tclr->file_location, 0, 10 * sizeof(char*)); |
| |
| return tclr; |
| } |
| |
| static const char* add_hand1(cmd_parms *parms, void *mconfig, const char* arg) |
| { |
| int pos = (int) parms->info; |
| tcl_config_rec *tclr = (tcl_config_rec*) mconfig; |
| |
| tclr->handlers[pos] = apr_pstrdup(parms->pool, arg); |
| |
| return NULL; |
| } |
| |
| static const char* add_hand2(cmd_parms *parms, void *mconfig, const char* arg1, const char* arg2) |
| { |
| int pos = (int) parms->info; |
| tcl_config_rec *tclr = (tcl_config_rec*) mconfig; |
| |
| tclr->handlers[pos] = apr_pstrdup(parms->pool, arg1); |
| tclr->file_location[pos] = apr_pstrdup(parms->pool, arg2); |
| |
| return NULL; |
| } |
| |
| static const char* sfl(cmd_parms *parms, void *mconfig, int flag) |
| { |
| int f = (int) parms->info; |
| tcl_config_rec *tclr = (tcl_config_rec*) mconfig; |
| |
| if (flag) { |
| tclr->fl |= f; |
| } |
| else { |
| tclr->fl &= ~f; |
| } |
| |
| return NULL; |
| } |
| |
| static const char* tcl_set(cmd_parms *parms, void *mconfig, const char *one, const char *two, const char *three) |
| { |
| tcl_config_rec *tclr = (tcl_config_rec*) mconfig; |
| char *ptr2, *ptr3; |
| var_cache *var = (var_cache*) apr_array_push(tclr->var_list); |
| |
| if (three == NULL) { |
| ptr2 = NULL; |
| ptr3 = (char*) two; |
| } |
| else { |
| ptr2 = (char*) two; |
| ptr3 = (char*) three; |
| } |
| |
| var->var1 = apr_pstrdup(parms->pool, one); |
| var->var2 = apr_pstrdup(parms->pool, ptr2); |
| var->var3 = apr_pstrdup(parms->pool, ptr3); |
| |
| var->fl = 1; |
| |
| return NULL; |
| } |
| |
| static const char* tcl_setlist(cmd_parms *parms, void *mconfig, const char *one, const char *two) |
| { |
| tcl_config_rec *tclr = (tcl_config_rec*) mconfig; |
| var_cache *var = (var_cache*) apr_array_push(tclr->var_list); |
| |
| var->var1 = apr_pstrdup(parms->pool, one); |
| var->var2 = apr_pstrdup(parms->pool, two); |
| |
| var->fl = 2; |
| |
| return NULL; |
| } |
| /* |
| static const char* tcl_raw_args(cmd_parms *cmd, void *mconfig, char *arg) |
| { |
| char **xx, *z = apr_pstrdup(cmd->pool, ""); |
| char l[MAX_STRING_LEN]; |
| const char *err = ap_check_cmd_context(cmd, NOT_IN_DIR_LOC_FILE|NOT_IN_LIMIT); |
| |
| if (err != NULL) { |
| return err; |
| } |
| |
| while (!(ap_cfg_getline(l, MAX_STRING_LEN, cmd->config_file))) { |
| if (!strncasecmp(l, "</Tcl>", 6)) { |
| break; |
| } |
| |
| // ick |
| z = apr_pstrcat(cmd->pool, z, l, "\n", NULL); |
| } |
| |
| // ick |
| raw_tcl = realloc(raw_tcl, strlen(z) + 1); |
| strcat(raw_tcl, z); |
| |
| return NULL; |
| } |
| */ |
| void run_script(Tcl_Interp* interp, char *fmt, ...) |
| { |
| char *bptr = NULL; |
| va_list va; |
| Tcl_Obj *obj; |
| |
| va_start(va, fmt); |
| vasprintf(&bptr, fmt, va); |
| va_end(va); |
| |
| obj = Tcl_NewStringObj(bptr, -1); |
| |
| if (Tcl_EvalObjEx(interp, obj, 0) == TCL_ERROR) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL, "Tcl_EvalObjEx(%s): %s", bptr, Tcl_GetStringResult(interp)); |
| } |
| |
| free(bptr); |
| } |
| |
| void set_var(Tcl_Interp* interp, char *var1, char *var2, const char *fmt, ...) |
| { |
| char *bptr; |
| va_list va; |
| Tcl_Obj *obj; |
| |
| va_start(va, fmt); |
| vasprintf(&bptr, fmt, va); |
| va_end(va); |
| |
| obj = Tcl_NewStringObj(bptr, -1); |
| |
| if (Tcl_SetVar2Ex(interp, var1, var2, obj, TCL_LEAVE_ERR_MSG) == NULL) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL, "Tcl_SetVarEx2(%s, %s, %s): %s", var1, var2 ? var2 : "NULL", bptr, Tcl_GetStringResult(interp)); |
| } |
| |
| free(bptr); |
| } |
| |
| void set_vari(Tcl_Interp* interp, char *var1, char *var2, int var) |
| { |
| if (Tcl_SetVar2Ex(interp, var1, var2, Tcl_NewIntObj(var), TCL_LEAVE_ERR_MSG) == NULL) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL, "Tcl_SetVarEx2(%s, %s, %d): %s", var1, var2 ? var2 : "NULL", var, Tcl_GetStringResult(interp)); |
| } |
| } |
| |
| void set_varb(Tcl_Interp* interp, char *var1, char *var2, char *data, int len) |
| { |
| Tcl_Obj *obj; |
| |
| obj = Tcl_NewByteArrayObj(data, len); |
| |
| if (Tcl_SetVar2Ex(interp, var1, var2, obj, TCL_LEAVE_ERR_MSG) == NULL) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL, "Tcl_SetVarEx2(%s, %s, %s): %s", var1, var2 ? var2 : "NULL", "*data*", Tcl_GetStringResult(interp)); |
| } |
| } |
| |
| static int tcl_init(apr_pool_t *pconf, apr_pool_t *plog, apr_pool_t *ptemp) |
| { |
| char *buf; |
| |
| _pconf = pconf; |
| fcache = apr_array_make(pconf, 0, sizeof(file_cache)); |
| |
| interp = Tcl_CreateInterp(); |
| |
| if (Tcl_Init(interp) == TCL_ERROR) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, NULL, "Tcl_Init(0x%x): %s", interp, Tcl_GetStringResult(interp)); |
| exit(1); |
| } |
| |
| apr_pool_cleanup_register(pconf, NULL, tcl_cleanup, apr_pool_cleanup_null); |
| |
| /* misc util */ |
| Tcl_CreateObjCommand(interp, "apache::abort", cmd_abort, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::read_post", cmd_read_post, NULL, NULL); |
| |
| Tcl_CreateObjCommand(interp, "apache::random", cmd_random, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::srandom", cmd_srandom, NULL, NULL); |
| |
| Tcl_CreateObjCommand(interp, "apache::base64_encode", cmd_base64_encode, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::base64_decode", cmd_base64_decode, NULL, NULL); |
| |
| /* read and set stuff from request_rec */ |
| Tcl_CreateObjCommand(interp, "apache::r", cmd_r, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::r_set", cmd_r_set, NULL, NULL); |
| |
| /* http_core.h */ |
| Tcl_CreateObjCommand(interp, "apache::ap_allow_options", cmd_ap_allow_options, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_allow_overrides", cmd_ap_allow_overrides, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_default_type", cmd_ap_default_type, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_document_root", cmd_ap_document_root, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_get_remote_host", cmd_ap_get_remote_host, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_get_remote_logname", cmd_ap_get_remote_logname, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_construct_url", cmd_ap_construct_url, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_get_server_name", cmd_ap_get_server_name, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_get_server_port", cmd_ap_get_server_port, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_get_limit_req_body", cmd_ap_get_limit_req_body, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_get_limit_xml_body", cmd_ap_get_limit_xml_body, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_custom_response", cmd_ap_custom_response, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_exists_config_define", cmd_ap_exists_config_define, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_auth_type", cmd_ap_auth_type, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_auth_name", cmd_ap_auth_name, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_satisfies", cmd_ap_satisfies, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_requires", cmd_ap_requires, NULL, NULL); |
| |
| /* http_log.h */ |
| Tcl_CreateObjCommand(interp, "apache::ap_log_error", cmd_ap_log_error, NULL, NULL); |
| |
| /* http_protocol.h */ |
| Tcl_CreateObjCommand(interp, "apache::ap_send_http_header", cmd_ap_send_http_header, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_send_http_trace", cmd_ap_send_http_trace, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_send_http_options", cmd_ap_send_http_options, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_finalize_request_protocol", cmd_ap_finalize_request_protocol, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_send_error_response", cmd_ap_send_error_response, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_set_content_length", cmd_ap_set_content_length, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_set_keepalive", cmd_ap_set_keepalive, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_rationalize_mtime", cmd_ap_rationalize_mtime, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_make_etag", cmd_ap_make_etag, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_set_etag", cmd_ap_set_etag, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_set_last_modified", cmd_ap_set_last_modified, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_meets_conditions", cmd_ap_meets_conditions, NULL, NULL); |
| /**/ |
| Tcl_CreateObjCommand(interp, "apache::rputs", cmd_rputs, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::rwrite", cmd_rwrite, NULL, NULL); |
| /**/ |
| Tcl_CreateObjCommand(interp, "apache::ap_rputs", cmd_rputs, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_rwrite", cmd_rwrite, NULL, NULL); |
| /**/ |
| Tcl_CreateObjCommand(interp, "apache::ap_rflush", cmd_ap_rflush, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_get_status_line", cmd_ap_get_status_line, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_setup_client_block", cmd_ap_setup_client_block, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_get_client_block", cmd_ap_get_client_block, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_discard_request_body", cmd_ap_discard_request_body, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_note_auth_failure", cmd_ap_note_auth_failure, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_note_basic_auth_failure", cmd_ap_note_basic_auth_failure, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_note_digest_auth_failure", cmd_ap_note_digest_auth_failure, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_get_basic_auth_pw", cmd_ap_get_basic_auth_pw, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_parse_uri", cmd_ap_parse_uri, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_method_number_of", cmd_ap_method_number_of, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_method_name_of", cmd_ap_method_name_of, NULL, NULL); |
| |
| /* http_request.h */ |
| Tcl_CreateObjCommand(interp, "apache::ap_internal_redirect", cmd_ap_internal_redirect, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_internal_redirect_handler", cmd_ap_internal_redirect_handler, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_some_auth_required", cmd_ap_some_auth_required, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_update_mtime", cmd_ap_update_mtime, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_allow_methods", cmd_ap_allow_methods, NULL, NULL); |
| |
| /* httpd.h */ |
| Tcl_CreateObjCommand(interp, "apache::ap_get_server_version", cmd_ap_get_server_version, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_add_version_component", cmd_ap_add_version_component, NULL, NULL); |
| Tcl_CreateObjCommand(interp, "apache::ap_get_server_built", cmd_ap_get_server_built, NULL, NULL); |
| |
| /* util_script.h */ |
| Tcl_CreateObjCommand(interp, "apache::ap_create_environment", cmd_ap_create_environment, NULL, NULL); |
| |
| /* output script */ |
| buf = "\ |
| proc apache::output { script } {\n\ |
| set script [split $script \\n]\n\ |
| \n\ |
| foreach i $script {\n\ |
| if { $i != \"\" } {\n\ |
| regsub -all {\\\"} $i {\\\"} i\n\ |
| uplevel 1 rputs \\\"$i\\\"\n\ |
| }\n\ |
| }\n\ |
| }"; |
| |
| run_script(interp, buf); |
| |
| /* built-in null handler for cancelling out previously defined handlers in parent directories */ |
| buf = "\ |
| proc apache::null_handler { } {\n\ |
| variable DECLINED\n\ |
| \n\ |
| return $DECLINED\n\ |
| }"; |
| |
| run_script(interp, buf); |
| |
| set_vari(interp, "apache::DECLINED", NULL, DECLINED); |
| set_vari(interp, "apache::DONE", NULL, DONE); |
| set_vari(interp, "apache::OK", NULL, OK); |
| |
| /* legacy */ |
| set_vari(interp, "apache::BAD_REQUEST", NULL, HTTP_BAD_REQUEST); |
| set_vari(interp, "apache::REDIRECT", NULL, HTTP_MOVED_TEMPORARILY); |
| set_vari(interp, "apache::SERVER_ERROR", NULL, HTTP_INTERNAL_SERVER_ERROR); |
| set_vari(interp, "apache::NOT_FOUND", NULL, HTTP_NOT_FOUND); |
| |
| set_vari(interp, "apache::M_POST", NULL, M_POST); |
| set_vari(interp, "apache::M_GET", NULL, M_GET); |
| set_vari(interp, "apache::M_PUT", NULL, M_PUT); |
| set_vari(interp, "apache::M_DELETE", NULL, M_DELETE); |
| set_vari(interp, "apache::M_CONNECT", NULL, M_CONNECT); |
| set_vari(interp, "apache::M_OPTIONS", NULL, M_OPTIONS); |
| set_vari(interp, "apache::M_TRACE", NULL, M_TRACE); |
| set_vari(interp, "apache::M_PATCH", NULL, M_PATCH); |
| set_vari(interp, "apache::M_PROPFIND", NULL, M_PROPFIND); |
| set_vari(interp, "apache::M_PROPPATCH", NULL, M_PROPPATCH); |
| set_vari(interp, "apache::M_MKCOL", NULL, M_MKCOL); |
| set_vari(interp, "apache::M_COPY", NULL, M_COPY); |
| set_vari(interp, "apache::M_MOVE", NULL, M_MOVE); |
| set_vari(interp, "apache::M_LOCK", NULL, M_LOCK); |
| set_vari(interp, "apache::M_UNLOCK", NULL, M_UNLOCK); |
| set_vari(interp, "apache::M_INVALID", NULL, M_INVALID); |
| |
| set_vari(interp, "apache::HTTP_CONTINUE", NULL, HTTP_CONTINUE); |
| set_vari(interp, "apache::HTTP_SWITCHING_PROTOCOLS", NULL, HTTP_SWITCHING_PROTOCOLS); |
| set_vari(interp, "apache::HTTP_PROCESSING", NULL, HTTP_PROCESSING); |
| set_vari(interp, "apache::HTTP_OK", NULL, HTTP_OK); |
| set_vari(interp, "apache::HTTP_CREATED", NULL, HTTP_CREATED); |
| set_vari(interp, "apache::HTTP_ACCEPTED", NULL, HTTP_ACCEPTED); |
| set_vari(interp, "apache::HTTP_NON_AUTHORITATIVE", NULL, HTTP_NON_AUTHORITATIVE); |
| set_vari(interp, "apache::HTTP_NO_CONTENT", NULL, HTTP_NO_CONTENT); |
| set_vari(interp, "apache::HTTP_RESET_CONTENT", NULL, HTTP_RESET_CONTENT); |
| set_vari(interp, "apache::HTTP_PARTIAL_CONTENT", NULL, HTTP_PARTIAL_CONTENT); |
| set_vari(interp, "apache::HTTP_MULTI_STATUS", NULL, HTTP_MULTI_STATUS); |
| set_vari(interp, "apache::HTTP_MULTIPLE_CHOICES", NULL, HTTP_MULTIPLE_CHOICES); |
| set_vari(interp, "apache::HTTP_MOVED_PERMANENTLY", NULL, HTTP_MOVED_PERMANENTLY); |
| set_vari(interp, "apache::HTTP_MOVED_TEMPORARILY", NULL, HTTP_MOVED_TEMPORARILY); |
| set_vari(interp, "apache::HTTP_SEE_OTHER", NULL, HTTP_SEE_OTHER); |
| set_vari(interp, "apache::HTTP_NOT_MODIFIED", NULL, HTTP_NOT_MODIFIED); |
| set_vari(interp, "apache::HTTP_USE_PROXY", NULL, HTTP_USE_PROXY); |
| set_vari(interp, "apache::HTTP_TEMPORARY_REDIRECT", NULL, HTTP_TEMPORARY_REDIRECT); |
| set_vari(interp, "apache::HTTP_BAD_REQUEST", NULL, HTTP_BAD_REQUEST); |
| set_vari(interp, "apache::HTTP_UNAUTHORIZED", NULL, HTTP_UNAUTHORIZED); |
| set_vari(interp, "apache::HTTP_PAYMENT_REQUIRED", NULL, HTTP_PAYMENT_REQUIRED); |
| set_vari(interp, "apache::HTTP_FORBIDDEN", NULL, HTTP_FORBIDDEN); |
| set_vari(interp, "apache::HTTP_NOT_FOUND", NULL, HTTP_NOT_FOUND); |
| set_vari(interp, "apache::HTTP_METHOD_NOT_ALLOWED", NULL, HTTP_METHOD_NOT_ALLOWED); |
| set_vari(interp, "apache::HTTP_NOT_ACCEPTABLE", NULL, HTTP_NOT_ACCEPTABLE); |
| set_vari(interp, "apache::HTTP_PROXY_AUTHENTICATION_REQUIRED", NULL, HTTP_PROXY_AUTHENTICATION_REQUIRED); |
| set_vari(interp, "apache::HTTP_REQUEST_TIME_OUT", NULL, HTTP_REQUEST_TIME_OUT); |
| set_vari(interp, "apache::HTTP_CONFLICT", NULL, HTTP_CONFLICT); |
| set_vari(interp, "apache::HTTP_GONE", NULL, HTTP_GONE); |
| set_vari(interp, "apache::HTTP_LENGTH_REQUIRED", NULL, HTTP_LENGTH_REQUIRED); |
| set_vari(interp, "apache::HTTP_PRECONDITION_FAILED", NULL, HTTP_PRECONDITION_FAILED); |
| set_vari(interp, "apache::HTTP_REQUEST_ENTITY_TOO_LARGE", NULL, HTTP_REQUEST_ENTITY_TOO_LARGE); |
| set_vari(interp, "apache::HTTP_REQUEST_URI_TOO_LARGE", NULL, HTTP_REQUEST_URI_TOO_LARGE); |
| set_vari(interp, "apache::HTTP_UNSUPPORTED_MEDIA_TYPE", NULL, HTTP_UNSUPPORTED_MEDIA_TYPE); |
| set_vari(interp, "apache::HTTP_RANGE_NOT_SATISFIABLE", NULL, HTTP_RANGE_NOT_SATISFIABLE); |
| set_vari(interp, "apache::HTTP_EXPECTATION_FAILED", NULL, HTTP_EXPECTATION_FAILED); |
| set_vari(interp, "apache::HTTP_UNPROCESSABLE_ENTITY", NULL, HTTP_UNPROCESSABLE_ENTITY); |
| set_vari(interp, "apache::HTTP_LOCKED", NULL, HTTP_LOCKED); |
| set_vari(interp, "apache::HTTP_FAILED_DEPENDENCY", NULL, HTTP_FAILED_DEPENDENCY); |
| set_vari(interp, "apache::HTTP_INTERNAL_SERVER_ERROR", NULL, HTTP_INTERNAL_SERVER_ERROR); |
| set_vari(interp, "apache::HTTP_NOT_IMPLEMENTED", NULL, HTTP_NOT_IMPLEMENTED); |
| set_vari(interp, "apache::HTTP_BAD_GATEWAY", NULL, HTTP_BAD_GATEWAY); |
| set_vari(interp, "apache::HTTP_SERVICE_UNAVAILABLE", NULL, HTTP_SERVICE_UNAVAILABLE); |
| set_vari(interp, "apache::HTTP_GATEWAY_TIME_OUT", NULL, HTTP_GATEWAY_TIME_OUT); |
| set_vari(interp, "apache::HTTP_VERSION_NOT_SUPPORTED", NULL, HTTP_VERSION_NOT_SUPPORTED); |
| set_vari(interp, "apache::HTTP_VARIANT_ALSO_VARIES", NULL, HTTP_VARIANT_ALSO_VARIES); |
| set_vari(interp, "apache::HTTP_INSUFFICIENT_STORAGE", NULL, HTTP_INSUFFICIENT_STORAGE); |
| set_vari(interp, "apache::HTTP_NOT_EXTENDED", NULL, HTTP_NOT_EXTENDED); |
| |
| set_vari(interp, "apache::REMOTE_HOST", NULL, REMOTE_HOST); |
| set_vari(interp, "apache::REMOTE_NAME", NULL, REMOTE_NAME); |
| set_vari(interp, "apache::REMOTE_NOLOOKUP", NULL, REMOTE_NOLOOKUP); |
| set_vari(interp, "apache::REMOTE_DOUBLE_REV", NULL, REMOTE_DOUBLE_REV); |
| |
| set_vari(interp, "apache::APLOG_EMERG", NULL, APLOG_EMERG); |
| set_vari(interp, "apache::APLOG_ALERT", NULL, APLOG_ALERT); |
| set_vari(interp, "apache::APLOG_CRIT", NULL, APLOG_CRIT); |
| set_vari(interp, "apache::APLOG_ERR", NULL, APLOG_ERR); |
| set_vari(interp, "apache::APLOG_WARNING", NULL, APLOG_WARNING); |
| set_vari(interp, "apache::APLOG_NOTICE", NULL, APLOG_NOTICE); |
| set_vari(interp, "apache::APLOG_INFO", NULL, APLOG_INFO); |
| set_vari(interp, "apache::APLOG_DEBUG", NULL, APLOG_DEBUG); |
| set_vari(interp, "apache::APLOG_NOERRNO", NULL, APLOG_NOERRNO); |
| |
| set_vari(interp, "apache::REQUEST_NO_BODY", NULL, REQUEST_NO_BODY); |
| set_vari(interp, "apache::REQUEST_CHUNKED_ERROR", NULL, REQUEST_CHUNKED_ERROR); |
| set_vari(interp, "apache::REQUEST_CHUNKED_DECHUNK", NULL, REQUEST_CHUNKED_DECHUNK); |
| |
| buf = "\ |
| namespace eval apache {\ |
| namespace export *\ |
| }"; |
| |
| run_script(interp, buf); |
| |
| return OK; |
| } |
| |
| static apr_status_t tcl_cleanup(void *data) |
| { |
| if (interp) { |
| Tcl_DeleteInterp(interp); |
| interp = NULL; |
| } |
| |
| free(raw_tcl); |
| |
| return APR_SUCCESS; |
| } |
| |
| static int tcl_init_handler(apr_pool_t *pconf, apr_pool_t *plog, apr_pool_t *ptemp, server_rec *s) |
| { |
| ap_add_version_component(pconf, "mod_tcl/1.0d8-2002031000"); |
| |
| return OK; |
| } |
| |
| static int run_handler(request_rec *r, int hh) |
| { |
| int xx = HTTP_NOT_FOUND, i; |
| tcl_config_rec *tclr = (tcl_config_rec*) ap_get_module_config(r->per_dir_config, &tcl_module); |
| size_t flen; |
| file_cache *fptr = NULL, *fa = (file_cache*) fcache->elts; |
| var_cache *vl = (var_cache*) tclr->var_list->elts; |
| struct stat st; |
| char *tmp_filename; |
| |
| if (!interp) { |
| return DECLINED; |
| } |
| |
| /* handler wasn't set so ignore it */ |
| if (!tclr->handlers[hh]) { |
| return DECLINED; |
| } |
| |
| if (hh != 8) { |
| if (hh < 2) { |
| tmp_filename = tclr->file_location[hh]; |
| } |
| else { |
| tmp_filename = r->filename; |
| } |
| |
| /* this will be rewritten by some translation... */ |
| r->filename = tclr->file_location[hh]; |
| } |
| else if (r->finfo.filetype != APR_REG) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "request URI does not match a file, a translation phase may have failed, r->filename = %s", r->filename); |
| return DECLINED; |
| } |
| |
| flen = strlen(r->filename); |
| stat(r->filename, &st); |
| |
| for (i = 0; i < fcache->nelts; i++) { |
| if (!strcmp(fa[i].file, r->filename)) { |
| fptr = &(fa[i]); |
| break; |
| } |
| } |
| |
| if (!fptr) { |
| int fd; |
| void *mptr; |
| char *bptr; |
| off_t pos = 0; |
| Tcl_Obj *obj; |
| |
| if ((fd = open(r->filename, O_RDONLY, 0)) == -1) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "open(%s, ...): %s", r->filename, strerror(errno)); |
| |
| return HTTP_NOT_FOUND; |
| } |
| |
| #ifdef HAVE_MMAP |
| mptr = mmap((caddr_t) 0, st.st_size, PROT_READ, MAP_SHARED, fd, 0); |
| #else |
| mptr = malloc(st.st_size); |
| read(fd, mptr, st.st_size); |
| #endif /* HAVE_MMAP */ |
| |
| bptr = (char*) malloc(st.st_size + flen + 21); |
| |
| memcpy(bptr, "namespace eval ", 15); pos += 15; |
| memcpy(bptr + pos, r->filename, flen); pos += flen; |
| memcpy(bptr + pos, " {\n", 3); pos += 3; |
| memcpy(bptr + pos, mptr, st.st_size); pos += st.st_size; |
| memcpy(bptr + pos, "\n}\0", 3); |
| |
| #ifdef HAVE_MMAP |
| munmap((char*) mptr, st.st_size); |
| #else |
| free(mptr); |
| #endif /* HAVE_MMAP */ |
| |
| close(fd); |
| |
| fptr = (file_cache*) apr_array_push(fcache); |
| |
| fptr->file = apr_pstrdup(fcache->pool, r->filename); |
| memcpy(&(fptr->st), &st, sizeof(struct stat)); |
| |
| obj = Tcl_NewStringObj(bptr, -1); |
| |
| free(bptr); |
| |
| if (Tcl_EvalObjEx(interp, obj, 0) == TCL_ERROR) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "Tcl_EvalObjEx(...): %s\n%s", Tcl_GetStringResult(interp), Tcl_GetVar(interp, "errorInfo", 0)); |
| return HTTP_INTERNAL_SERVER_ERROR; |
| } |
| |
| for (i = 0; i < tclr->var_list->nelts; i++) { |
| if (vl[i].fl == 1) { |
| char *namespc = (char*) malloc(strlen(r->filename) + strlen(vl[i].var1) + 3); |
| |
| sprintf(namespc, "%s::%s", r->filename, vl[i].var1); |
| set_var(interp, namespc, vl[i].var2, vl[i].var3); |
| free(namespc); |
| } |
| else if (vl[i].fl == 2) { |
| char *namespc = (char*) malloc(strlen(r->filename) + strlen(vl[i].var1) + 3); |
| |
| sprintf(namespc, "%s::%s", r->filename, vl[i].var1); |
| run_script(interp, "lappend %s %s", namespc, vl[i].var2); |
| free(namespc); |
| } |
| } |
| |
| if (raw_tcl) { |
| run_script(interp, "namespace eval %s { %s }", r->filename, raw_tcl); |
| } |
| } |
| else if (st.st_mtime > fptr->st.st_mtime) { |
| int fd; |
| void *mptr; |
| char *bptr; |
| off_t pos = 0; |
| Tcl_Obj *obj; |
| |
| if ((fd = open(r->filename, O_RDONLY, 0)) == -1) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "open(%s, ...): %s", r->filename, strerror(errno)); |
| return HTTP_INTERNAL_SERVER_ERROR; |
| } |
| |
| #ifdef HAVE_MMAP |
| mptr = mmap((caddr_t) 0, st.st_size, PROT_READ, MAP_SHARED, fd, 0); |
| #else |
| mptr = malloc(st.st_size); |
| read(fd, mptr, st.st_size); |
| #endif /* HAVE_MMAP */ |
| |
| bptr = malloc(st.st_size + flen + 21); |
| |
| memcpy(bptr, "namespace eval ", 15); pos += 15; |
| memcpy(bptr + pos, r->filename, flen); pos += flen; |
| memcpy(bptr + pos, " {\n", 3); pos += 3; |
| memcpy(bptr + pos, mptr, st.st_size); pos += st.st_size; |
| memcpy(bptr + pos, "\n}\0", 3); |
| |
| #ifdef HAVE_MMAP |
| munmap((char*) mptr, st.st_size); |
| #else |
| free(mptr); |
| #endif /* HAVE_MMAP */ |
| |
| close(fd); |
| |
| fptr = (file_cache*) apr_array_push(fcache); |
| |
| fptr->file = apr_pstrdup(fcache->pool, r->filename); |
| memcpy(&(fptr->st), &st, sizeof(struct stat)); |
| |
| obj = Tcl_NewStringObj(bptr, -1); |
| |
| free(bptr); |
| |
| if (Tcl_EvalObjEx(interp, obj, 0) == TCL_ERROR) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "Tcl_EvalObjEx(...): %s\n%s", Tcl_GetStringResult(interp), Tcl_GetVar(interp, "errorInfo", 0)); |
| return HTTP_INTERNAL_SERVER_ERROR; |
| } |
| } |
| |
| _r = r; |
| current_namespace = r->filename; |
| read_post_ok = 1; |
| |
| { |
| char *eptr = (char*) malloc(strlen(tclr->handlers[hh]) + flen + 3); |
| Tcl_Obj *obj; |
| |
| sprintf(eptr, "%s::%s", fptr->file, tclr->handlers[hh]); |
| |
| obj = Tcl_NewStringObj(eptr, -1); |
| |
| free(eptr); |
| |
| if (Tcl_EvalObjEx(interp, obj, 0) == TCL_ERROR) { |
| ap_log_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, 0, r->server, "Tcl_EvalObjEx(%s): %s", eptr, Tcl_GetStringResult(interp)); |
| |
| r->content_type = "text/html"; |
| // ap_send_http_header(r); |
| |
| ap_rprintf(r, "<H3>TCL Error</H3><BR><PRE>%s</PRE>", Tcl_GetString(Tcl_GetVar2Ex(interp, "errorInfo", NULL, 0))); |
| |
| return OK; |
| } |
| |
| Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &xx); |
| } |
| |
| r->filename = tmp_filename; |
| |
| return xx; |
| } |
| |
| inline int tcl_post_read_request(request_rec *r) |
| { |
| return run_handler(r, 0); |
| } |
| |
| inline int tcl_translate_name(request_rec *r) |
| { |
| return run_handler(r, 1); |
| } |
| |
| inline int tcl_header_parser(request_rec *r) |
| { |
| return run_handler(r, 2); |
| } |
| |
| inline int tcl_access_checker(request_rec *r) |
| { |
| return run_handler(r, 3); |
| } |
| |
| inline int tcl_check_user_id(request_rec *r) |
| { |
| return run_handler(r, 4); |
| } |
| |
| inline int tcl_auth_checker(request_rec *r) |
| { |
| return run_handler(r, 5); |
| } |
| |
| inline int tcl_type_checker(request_rec *r) |
| { |
| return run_handler(r, 6); |
| } |
| |
| inline int tcl_fixups(request_rec *r) |
| { |
| return run_handler(r, 7); |
| } |
| |
| inline int tcl_handler(request_rec *r) |
| { |
| if (strcmp("tcl-handler", r->handler)) { |
| return DECLINED; |
| } |
| |
| return run_handler(r, 8); |
| } |
| |
| inline int tcl_log_transaction(request_rec *r) |
| { |
| return run_handler(r, 9); |
| } |