From kamikaze@mist.isdn.uiuc.edu Fri May 26 13:10:36 2000 Return-Path: Received: from mist.isdn.uiuc.edu (IDENT:root@mist.isdn.uiuc.edu [192.17.23.67]) by araw.mede.uic.edu (8.10.1/8.10.1) with ESMTP id e4QIAR712270 for ; Fri, 26 May 2000 13:10:27 -0500 (CDT) Received: (from kamikaze@localhost) by mist.isdn.uiuc.edu (8.9.3/8.9.3) id NAA04552 for pennmush-contrib@pennmush.org; Fri, 26 May 2000 13:13:54 -0500 Date: Fri, 26 May 2000 13:13:54 -0500 From: Jonathan Booth To: pennmush-contrib@pennmush.org Subject: tcl patch Message-ID: <20000526131354.A4549@mist.isdn.uiuc.edu> Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii X-Mailer: Mutt 1.0.1i Status: RO Content-Length: 95332 Lines: 3632 # # Patch name: tcl # Patch version: jab8 # Author's name: Jonathan Booth # Author's email: kamikaze@imsa.edu # Author's website: http://www.imsa.edu/~kamikaze/mush/tcl/ # Version of PennMUSH: 1.7.3p1 # Date patch made: Fri May 26 13:11:51 CDT 2000 # Author is willing to support (yes/no): yes # Patch format: context diff # # # This is a contributed PennMUSH patch. Its use is subject to the # same restrictions found in PennMUSH's hdrs/copyrite.h file. # # No warranty is given for this patch. It is not necessarily going # to work on your system, with any version of PennMUSH other than # # the one above, etc. # If the author given above was willing to support the patch, you # should write to the author if you have any questions or problems. Do # *NOT* send email messages to Javelin or any PennMUSH mailing list about # this patch! # # Below this line is the author's description of the patch, # followed by the patch itself. If the patch is in context diff # format, you'll probably apply it by typing: patch < patchfile # in your top-level MUSH directory, unless instructed otherwise # below. # This is the TCL patch for PennMUSH. The patches are named tcl-.[.tar].gz The highest numbered is the latest one. Documentation is in this patch header, as well as at: http://www.imsa.edu/~kamikaze/mush/tcl (includes a helpfile for tcl there) If you have previously patched in an older version of the TCL patch, you must first UNPATCH that one before applying this. To do so, type patch -p1 -R < OldPatchName To install this patch, go to your pennmush/ directory and do: patch -p1 < tcl-. You will need TCL 8.0 or later, with or without the "Command Limit" patch applied. The "Command Limit" patch is Thorvald's, I haven't messed with it, simply redistribute it. I can't support it or help you with it; if it doesn't work, don't use patched TCL. However, without patched TCL, only GOD can use TCL. To install the "Command Limit" patch onto tcl, get tcl8.0p2 (exactly, not tcl8.0, not tcl8.1), go into the tcl8.0 directory, then use: patch -p1 < Tcl8.0p2.CommandLimit.Patch Then compile and build TCL as usual. If you don't install it in the usual location, you'll have to tweak the PennMUSH Makefile so that it finds your patched version of TCL, not the system's standard one. **** IMPORTANT **** You *MUST* delete config.sh and rerun Configure before compiling, or you WILL get errors. **** IMPORTANT **** Help for the tcl commands can be found at my website, just take the tcl.hlp file, and toss it into your game/txt/hlp directory, rebuild your indexes and @readcache (if it's needed, I can't recall). Index: stock.2/src/SWITCHES *** stock.2/src/SWITCHES Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/b/23_SWITCHES 1.1 600) --- tcl.2/src/SWITCHES Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/b/23_SWITCHES 1.2 600) *************** *** 51,58 **** --- 51,61 ---- INVENTORY IPRINT JOIN + KILL + LOAD LIST LOWERCASE + MASTER ME MEMBERS MOD *************** *** 84,89 **** --- 87,93 ---- QUIET READ REBOOT + RELOAD REMOVE RENAME REGISTER *************** *** 100,105 **** --- 104,110 ---- SKIPDEFAULTS SPEAK STATS + STATUS SUMMARY TAG TELEPORT Index: stock.2/src/timer.c *** stock.2/src/timer.c Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/b/30_timer.c 1.1 600) --- tcl.2/src/timer.c Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/b/30_timer.c 1.2 600) *************** *** 205,208 **** --- 205,211 ---- #endif local_timer(); + #ifdef ENABLE_TCL + tclhook_timer(); + #endif } Index: stock.2/src/switchinc.c *** stock.2/src/switchinc.c Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/b/33_switchinc. 1.1 600) --- tcl.2/src/switchinc.c Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/b/33_switchinc. 1.2 644) *************** *** 211,224 **** --- 211,236 ---- } , { + "KILL", SWITCH_KILL + } + , + { "LIST", SWITCH_LIST } , { + "LOAD", SWITCH_LOAD + } + , + { "LOWERCASE", SWITCH_LOWERCASE } , { + "MASTER", SWITCH_MASTER + } + , + { "ME", SWITCH_ME } , *************** *** 347,352 **** --- 359,368 ---- } , { + "RELOAD", SWITCH_RELOAD + } + , + { "REMOVE", SWITCH_REMOVE } , *************** *** 404,409 **** --- 420,429 ---- , { "STATS", SWITCH_STATS + } + , + { + "STATUS", SWITCH_STATUS } , { Index: stock.2/src/speech.c *** stock.2/src/speech.c Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/b/37_speech.c 1.1 600) --- tcl.2/src/speech.c Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/b/37_speech.c 1.2 600) *************** *** 21,28 **** #include "parse.h" #include "confmagic.h" ! static void oemit_notify_except _((dbref loc, dbref exc1, dbref exc2, ! const char *msg)); void do_oemit_list _((dbref player, char *list, const char *message)); const char *reconstruct_message _((char *arg1, char *arg2)); int okay_pemit _((dbref player, dbref target)); --- 21,28 ---- #include "parse.h" #include "confmagic.h" ! void oemit_notify_except _((dbref loc, dbref exc1, dbref exc2, ! const char *msg)); void do_oemit_list _((dbref player, char *list, const char *message)); const char *reconstruct_message _((char *arg1, char *arg2)); int okay_pemit _((dbref player, dbref target)); *************** *** 1529,1535 **** do_audible_stuff(loc, &pass[1], 2, msg); } ! static void oemit_notify_except(loc, exc1, exc2, msg) dbref loc; dbref exc1; --- 1529,1535 ---- do_audible_stuff(loc, &pass[1], 2, msg); } ! void oemit_notify_except(loc, exc1, exc2, msg) dbref loc; dbref exc1; Index: stock.2/src/player.c *** stock.2/src/player.c Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/b/47_player.c 1.1 600) --- tcl.2/src/player.c Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/b/47_player.c 1.2 600) *************** *** 358,363 **** --- 358,366 ---- #ifdef LOCAL_DATA local_data_create(player); #endif + #ifdef ENABLE_TCL + tclhook_create(player); + #endif return player; } Index: stock.2/src/lock.c *** stock.2/src/lock.c Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/c/7_lock.c 1.1 600) --- tcl.2/src/lock.c Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/c/7_lock.c 1.2 600) *************** *** 108,114 **** static void free_one_lock_list _((lock_list *ll)); void delete_lock _((dbref thing, lock_type type)); void free_locks _((lock_list *ll)); ! static lock_type check_lock_type _((dbref player, dbref thing, char *name)); void do_unlock _((dbref player, const char *name, lock_type type)); void do_lock _((dbref player, const char *name, const char *keyname, lock_type type)); --- 108,114 ---- static void free_one_lock_list _((lock_list *ll)); void delete_lock _((dbref thing, lock_type type)); void free_locks _((lock_list *ll)); ! lock_type check_lock_type _((dbref player, dbref thing, char *name)); void do_unlock _((dbref player, const char *name, lock_type type)); void do_lock _((dbref player, const char *name, const char *keyname, lock_type type)); *************** *** 271,277 **** * * Might destructively modify name. */ ! static lock_type check_lock_type(player, thing, name) dbref player; dbref thing; --- 271,277 ---- * * Might destructively modify name. */ ! lock_type check_lock_type(player, thing, name) dbref player; dbref thing; Index: stock.2/src/game.c *** stock.2/src/game.c Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/c/11_game.c 1.1 600) --- tcl.2/src/game.c Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/c/11_game.c 1.2 600) *************** *** 303,308 **** --- 303,311 ---- char tmpfl[2048]; FILE *f; + #ifdef ENABLE_TCL + tclhook_dbdump(); + #endif local_dump_database(); #ifdef ALWAYS_PARANOID *************** *** 633,638 **** --- 636,645 ---- #endif int panicdb; + #ifdef ENABLE_TCL + tcl_init(); + #endif + #ifdef WIN32 Win32MUSH_setup(); /* create index files, copy databases etc. */ #endif *************** *** 757,762 **** --- 764,773 ---- /* Call Local Startup */ local_startup(); + + #ifdef ENABLE_TCL + tcl_boot(); + #endif /* everything else ok. Restart all objects. */ do_restart(); Index: stock.2/src/destroy.c *** stock.2/src/destroy.c Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/c/25_destroy.c 1.1 600) --- tcl.2/src/destroy.c Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/c/25_destroy.c 1.2 600) *************** *** 579,584 **** --- 579,587 ---- dbref i; if (!GoodObject(thing)) return; + #ifdef ENABLE_TCL + tclhook_free(thing); + #endif #ifdef LOCAL_DATA local_data_free(thing); #endif Index: stock.2/src/create.c *** stock.2/src/create.c Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/c/28_create.c 1.1 600) --- tcl.2/src/create.c Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/c/28_create.c 1.2 600) *************** *** 160,165 **** --- 160,168 ---- #ifdef LOCAL_DATA local_data_create(new_exit); #endif + #ifdef ENABLE_TCL + tclhook_create(new_exit); + #endif return new_exit; } return NOTHING; *************** *** 397,402 **** --- 400,408 ---- #ifdef LOCAL_DATA local_data_create(room); #endif + #ifdef ENABLE_TCL + tclhook_create(room); + #endif if (tport) { /* We need to use the full command, because we need NO_TEL * and Z_TEL checking */ *************** *** 466,471 **** --- 472,480 ---- #ifdef LOCAL_DATA local_data_create(thing); #endif + #ifdef ENABLE_TCL + tclhook_create(thing); + #endif return thing; } return NOTHING; *************** *** 562,567 **** --- 571,579 ---- LocData(clone) = NULL; local_data_clone(clone, thing); #endif + #ifdef ENABLE_TCL + tclhook_clone(clone, thing); + #endif did_it(player, clone, NULL, NULL, NULL, NULL, "ACLONE", NOTHING); return clone; } *************** *** 611,616 **** --- 623,631 ---- #ifdef LOCAL_DATA LocData(clone) = NULL; local_data_clone(clone, thing); + #endif + #ifdef ENABLE_TCL + tclhook_clone(clone, thing); #endif return clone; } Index: stock.2/src/conf.c *** stock.2/src/conf.c Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/c/31_conf.c 1.1 600) --- tcl.2/src/conf.c Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/c/31_conf.c 1.2 600) *************** *** 140,145 **** --- 140,148 ---- "files"}, {"guest_html_file", cf_str, (int *) options.guest_file[1], 256, 0, "files"}, + #ifdef ENABLE_TCL + {"tcl_bootfile", cf_str, (int *) options.tcl_bootfile, 256, 0, "files"}, + #endif {"log_commands", cf_bool, &options.log_commands, 2, 0, "log"}, {"log_huhs", cf_bool, &options.log_huhs, 2, 0, "log"}, {"log_forces", cf_bool, &options.log_forces, 2, 0, "log"}, *************** *** 500,505 **** --- 503,511 ---- strcpy(options.down_file[1], "txt/down.html"); strcpy(options.full_file[1], "txt/full.html"); strcpy(options.guest_file[1], "txt/guest.html"); + #ifdef ENABLE_TCL + strcpy(options.tcl_bootfile, ""); + #endif options.log_commands = 0; options.log_huhs = 0; options.log_forces = 1; Index: stock.2/src/bsd.c *** stock.2/src/bsd.c Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/c/38_bsd.c 1.1 600) --- tcl.2/src/bsd.c Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/c/38_bsd.c 1.2 600) *************** *** 99,104 **** --- 99,105 ---- #include "ansi.h" #include "pueblo.h" #include "parse.h" + #include "penntcl.h" #include "access.h" #include "version.h" #include "patches.h" *************** *** 682,687 **** --- 683,691 ---- dump_database(); + #ifdef ENABLE_TCL + tclhook_shutdown(); + #endif local_shutdown(); end_all_logs(); *************** *** 3983,3988 **** --- 3987,3997 ---- rnxt[j] = NULL; } + /* Call the tcl connection hook */ + #ifdef ENABLE_TCL + tclhook_connect(player); + #endif + /* do the person's personal connect action */ temp = atr_get(player, "ACONNECT"); if (temp) { *************** *** 4092,4097 **** --- 4101,4111 ---- rnxt[j] = NULL; } + /* Call the tcl connection hook */ + #ifdef ENABLE_TCL + tclhook_disconnect(player); + #endif + temp = atr_get(player, "ADISCONNECT"); if (temp) { s = safe_uncompress(temp->value); *************** *** 5129,5134 **** --- 5143,5267 ---- remove(REBOOTFILE); flag_broadcast(0, 0, "GAME: Reboot finished."); } + + + #ifdef ENABLE_TCL + TCLCMD(tclcmd_connection) + { + DESC *d; + int cindex; + int powered; + Tcl_DString ds; + time_t now; + dbref target; + + static const char *coptions[] = + { + "list", "mortallist", "idle", "connected", "hidden", "poll", "doing", + NULL + }; + + enum coptions { + CONN_LWHO, CONN_MWHO, CONN_IDLE, CONN_CONNECTED, CONN_HIDDEN, CONN_POLL, CONN_DOING, + }; + + TCL_INIT; + + now = time((time_t *) NULL); + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "option ?arg?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], (char **) coptions, (char *) "option", 0, + &cindex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum coptions) cindex) { + case CONN_LWHO: + case CONN_MWHO: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_DStringInit(&ds); + powered = (cindex == CONN_LWHO); + DESC_ITER_CONN(d) { + if (!Hidden(d) || (powered && Priv_Who(player))) { + Tcl_DStringAppendElement(&ds, unparse_integer(d->player)); + } + } + + Tcl_DStringResult(interp, &ds); + break; + case CONN_IDLE: + case CONN_CONNECTED: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "player"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!Connected(target)) { + Tcl_SetIntObj(resultPtr, -1); + } else { + DESC_ITER_CONN(d) { + if (d->player == target) { + if (!Hidden(d) || Priv_Who(player)) { + if (cindex == CONN_IDLE) + Tcl_SetIntObj(resultPtr, now - d->last_time); + else + Tcl_SetIntObj(resultPtr, now - d->connected_at); + } else { + Tcl_SetIntObj(resultPtr, -1); + } + } + } + } + break; + case CONN_HIDDEN: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "player"); + return TCL_ERROR; + } + if (!See_All(player)) { + TCLERROR_STRING("permission denied"); + } + CMD_GETOBJECT(target, 2); + Tcl_SetIntObj(resultPtr, hidden(target) ? 1 : 0); + break; + case CONN_DOING: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "player"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + DESC_ITER_CONN(d) { + if (d->player == target) { + if (!Hidden(d) || Priv_Who(player)) { + Tcl_SetStringObj(resultPtr, d->doing, -1); + } else { + } + } + } + break; + case CONN_POLL: + if (objc == 3) { + if (!Change_Poll(player)) { + TCLERROR_STRING("permission denied"); + } + strncpy(poll_msg, Tcl_GetStringFromObj(objv[2], NULL), DOING_LEN - 1); + poll_msg[DOING_LEN - 1] = '\0'; + do_log(LT_WIZ, player, NOTHING, "Poll Set to '%s'.", poll_msg); + } else if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "?newpoll?"); + return TCL_ERROR; + } + Tcl_SetStringObj(resultPtr, poll_msg, -1); + break; + } + return TCL_OK; + } + #endif /* ENABLE_TCL */ #ifdef NT_TCP Index: stock.2/src/Makefile *** stock.2/src/Makefile Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/c/44_Makefile 1.1 755) --- tcl.2/src/Makefile Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/c/44_Makefile 1.2 755) *************** *** 103,108 **** --- 103,109 ---- strdup.o \ strtree.o \ strutil.o \ + tcl.o \ timer.o \ unparse.o \ utils.o \ Index: stock.2/hdrs/conf.h *** stock.2/hdrs/conf.h Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/d/21_conf.h 1.1 600) --- tcl.2/hdrs/conf.h Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/d/21_conf.h 1.2 600) *************** *** 146,151 **** --- 146,152 ---- char down_file[2][256]; char full_file[2][256]; char guest_file[2][256]; + char tcl_bootfile[256]; FBLOCK *connect_fcache[2]; FBLOCK *motd_fcache[2]; FBLOCK *wizmotd_fcache[2]; Index: stock.2/hdrs/switches.h *** stock.2/hdrs/switches.h Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/d/22_switches.h 1.1 600) --- tcl.2/hdrs/switches.h Thu, 25 May 2000 15:54:22 -0500 kamikaze (pennmush-1.7.3/d/22_switches.h 1.2 644) *************** *** 51,120 **** #define SWITCH_INVENTORY 51 #define SWITCH_IPRINT 52 #define SWITCH_JOIN 53 ! #define SWITCH_LIST 54 ! #define SWITCH_LOWERCASE 55 ! #define SWITCH_ME 56 ! #define SWITCH_MEMBERS 57 ! #define SWITCH_MOD 58 ! #define SWITCH_MORTAL 59 ! #define SWITCH_MOTD 60 ! #define SWITCH_MUTE 61 ! #define SWITCH_NAME 62 ! #define SWITCH_NO 63 ! #define SWITCH_NOEVAL 64 ! #define SWITCH_NOISY 65 ! #define SWITCH_NOSIG 66 ! #define SWITCH_NOSPACE 67 ! #define SWITCH_NOTIFY 68 ! #define SWITCH_NUKE 69 ! #define SWITCH_OFF 70 ! #define SWITCH_ON 71 ! #define SWITCH_OUTSIDE 72 ! #define SWITCH_OVERRIDE 73 ! #define SWITCH_PANIC 74 ! #define SWITCH_PARANOID 75 ! #define SWITCH_PLAYERS 76 ! #define SWITCH_PORT 77 ! #define SWITCH_POSE 78 ! #define SWITCH_PRESERVE 79 ! #define SWITCH_PRINT 80 ! #define SWITCH_PRIVS 81 ! #define SWITCH_PURGE 82 ! #define SWITCH_QUICK 83 ! #define SWITCH_QUIET 84 ! #define SWITCH_READ 85 ! #define SWITCH_REBOOT 86 ! #define SWITCH_REGISTER 87 ! #define SWITCH_REMOVE 88 ! #define SWITCH_RENAME 89 ! #define SWITCH_RETROACTIVE 90 ! #define SWITCH_ROOM 91 ! #define SWITCH_ROOMS 92 ! #define SWITCH_ROYALTY 93 ! #define SWITCH_SEE 94 ! #define SWITCH_SEEFLAG 95 ! #define SWITCH_SELF 96 ! #define SWITCH_SEND 97 ! #define SWITCH_SET 98 ! #define SWITCH_SILENT 99 ! #define SWITCH_SKIPDEFAULTS 100 ! #define SWITCH_SPEAK 101 ! #define SWITCH_STATS 102 ! #define SWITCH_SUMMARY 103 ! #define SWITCH_TAG 104 ! #define SWITCH_TELEPORT 105 ! #define SWITCH_TF 106 ! #define SWITCH_THINGS 107 ! #define SWITCH_TITLE 108 ! #define SWITCH_TRACE 109 ! #define SWITCH_UNCLEAR 110 ! #define SWITCH_UNFOLDER 111 ! #define SWITCH_UNTAG 112 ! #define SWITCH_URGENT 113 ! #define SWITCH_USEFLAG 114 ! #define SWITCH_WHAT 115 ! #define SWITCH_WIPE 116 ! #define SWITCH_WIZ 117 ! #define SWITCH_WIZARD 118 ! #define SWITCH_YES 119 ! #define SWITCH_ZONE 120 --- 51,125 ---- #define SWITCH_INVENTORY 51 #define SWITCH_IPRINT 52 #define SWITCH_JOIN 53 ! #define SWITCH_KILL 54 ! #define SWITCH_LIST 55 ! #define SWITCH_LOAD 56 ! #define SWITCH_LOWERCASE 57 ! #define SWITCH_MASTER 58 ! #define SWITCH_ME 59 ! #define SWITCH_MEMBERS 60 ! #define SWITCH_MOD 61 ! #define SWITCH_MORTAL 62 ! #define SWITCH_MOTD 63 ! #define SWITCH_MUTE 64 ! #define SWITCH_NAME 65 ! #define SWITCH_NO 66 ! #define SWITCH_NOEVAL 67 ! #define SWITCH_NOISY 68 ! #define SWITCH_NOSIG 69 ! #define SWITCH_NOSPACE 70 ! #define SWITCH_NOTIFY 71 ! #define SWITCH_NUKE 72 ! #define SWITCH_OFF 73 ! #define SWITCH_ON 74 ! #define SWITCH_OUTSIDE 75 ! #define SWITCH_OVERRIDE 76 ! #define SWITCH_PANIC 77 ! #define SWITCH_PARANOID 78 ! #define SWITCH_PLAYERS 79 ! #define SWITCH_PORT 80 ! #define SWITCH_POSE 81 ! #define SWITCH_PRESERVE 82 ! #define SWITCH_PRINT 83 ! #define SWITCH_PRIVS 84 ! #define SWITCH_PURGE 85 ! #define SWITCH_QUICK 86 ! #define SWITCH_QUIET 87 ! #define SWITCH_READ 88 ! #define SWITCH_REBOOT 89 ! #define SWITCH_REGISTER 90 ! #define SWITCH_RELOAD 91 ! #define SWITCH_REMOVE 92 ! #define SWITCH_RENAME 93 ! #define SWITCH_RETROACTIVE 94 ! #define SWITCH_ROOM 95 ! #define SWITCH_ROOMS 96 ! #define SWITCH_ROYALTY 97 ! #define SWITCH_SEE 98 ! #define SWITCH_SEEFLAG 99 ! #define SWITCH_SELF 100 ! #define SWITCH_SEND 101 ! #define SWITCH_SET 102 ! #define SWITCH_SILENT 103 ! #define SWITCH_SKIPDEFAULTS 104 ! #define SWITCH_SPEAK 105 ! #define SWITCH_STATS 106 ! #define SWITCH_STATUS 107 ! #define SWITCH_SUMMARY 108 ! #define SWITCH_TAG 109 ! #define SWITCH_TELEPORT 110 ! #define SWITCH_TF 111 ! #define SWITCH_THINGS 112 ! #define SWITCH_TITLE 113 ! #define SWITCH_TRACE 114 ! #define SWITCH_UNCLEAR 115 ! #define SWITCH_UNFOLDER 116 ! #define SWITCH_UNTAG 117 ! #define SWITCH_URGENT 118 ! #define SWITCH_USEFLAG 119 ! #define SWITCH_WHAT 120 ! #define SWITCH_WIPE 121 ! #define SWITCH_WIZ 122 ! #define SWITCH_WIZARD 123 ! #define SWITCH_YES 124 ! #define SWITCH_ZONE 125 Index: stock.2/options.h.dist *** stock.2/options.h.dist Thu, 25 May 2000 15:35:21 -0500 kamikaze (pennmush-1.7.3/d/34_options.h. 1.1 600) --- tcl.2/options.h.dist Thu, 25 May 2000 15:35:58 -0500 kamikaze (pennmush-1.7.3/d/34_options.h. 1.2 600) *************** *** 85,90 **** --- 85,94 ---- */ #define COMPRESSION_TYPE 1 + /* Enable TCL. Be damn carefull + */ + /* #define ENABLE_TCL /* */ + /*------------------------- Other internals ----------------------*/ Index: stock.2/src/tcl.c *** stock.2/src/tcl.c Fri, 26 May 2000 13:09:15 -0500 kamikaze (pennmush-1.7.3/d/39_tcl.c 1.1 644) --- tcl.2/src/tcl.c Thu, 25 May 2000 15:54:22 -0500 kamikaze (pennmush-1.7.3/d/36_tcl.c 1.1 644) *************** *** 0 **** --- 1,2627 ---- + /* tcl.c */ + + /* Modified by Jonathan Booth. Questions about this SHOULD BE SENT TO ME, + * and *** NOT *** to the PennMUSH developers, Javelin, or Thorvald. + * + * My email is kamikaze@imsa.edu + * + * This is just Thorvald's TCL patch, cleaned up to be good versus + * 1.7.3p1, with a couple additions, mainly the connect and + * disconnect hook, for some of my TCL code. :) + */ + + /* By Thorvald Natvig. Questions about this SHOULD BE SENT TO ME, and + * ***** NOT ***** to the PennMUSH developers or Javelin. + * + * My email is slicer@bimbo.hive.no + * + * Inspiration for this came from TinyMUSH 2.2.4 by Amberyl, and some came from + * various versions of eggdrop. + * + * I include the TCL functionality of Tiny 2.2.4, so people can use code written for + * it. + * + * This is my first use of TCL as an embedded language, so PLEASE send me ideas :) + * Also, if you ever hack anything in here... Read the copyrite, and send me a patch ;) + * + * The homepage for this is http://lists.pennmush.org/tcl/ + * That page contains links to updated source, as well as full documentation + * + */ + + + #include "copyrite.h" + + + #include "config.h" + #include + #ifdef I_STRING + #include + #else + #include + #endif + #include + + #include "conf.h" + + /* No TCL? Oh well */ + #ifdef ENABLE_TCL + #include "ansi.h" + #include "dbdefs.h" + #include "externs.h" + #include "function.h" + #include "globals.h" + #include "intrface.h" + #include "match.h" + #include "mushdb.h" + #include "parse.h" + #include "match.h" + #include "htab.h" + #include "privtab.h" + #include "lock.h" + + #ifdef MEM_CHECK + #include "memcheck.h" + #endif + #include "confmagic.h" + + /* Include our definitions */ + #include "penntcl.h" + + /* Hashtables to hold functions and commands */ + Tcl_HashTable tclhash_funs; + Tcl_HashTable tclhash_cmds; + Tcl_HashTable tclhash_ins; + Tcl_HashTable tclhash_tclcmds; + Tcl_HashTable tclhash_tclvars; + + /* The inMUSH commands/functions, from command.c and function.c */ + extern HASHTAB htab_function; + extern HASHTAB htab_command; + extern PRIV attr_privs[]; + + /* Linked lists of our event hooks */ + struct tcl_hook *event_hooks[EVENT_MAX]; + + /* Our linked list of instances */ + struct tcl_instance *master_instance; + + Tcl_HashTable tclhash_ins; + + /* Current 'depth' */ + int tcl_level = 0; + + /* TickTimer for tcl_timer() */ + int tcl_timer_tick = 1; + + /* SelfReminder Block (ignore) + * Functions we really should have: + * lwho() - All that's left. + */ + + struct tcl_hc_command tclcommands[] = + { + {"pemit", + {(Tcl_ObjCmdProc *) tclcmd_pemit, 2, NULL}}, + {"setattrib", + {(Tcl_ObjCmdProc *) tclcmd_setattrib, 2, NULL}}, + {"getattrib", + {(Tcl_ObjCmdProc *) tclcmd_getattrib, 2, NULL}}, + {"mushfunc", + {(Tcl_ObjCmdProc *) tclcmd_mushfunc, 2, NULL}}, + {"attrib", + {(Tcl_ObjCmdProc *) tclcmd_attrib, 2, NULL}}, + {"object", + {(Tcl_ObjCmdProc *) tclcmd_object, 2, NULL}}, + {"notify", + {(Tcl_ObjCmdProc *) tclcmd_notify, 2, NULL}}, + {"connection", + {(Tcl_ObjCmdProc *) tclcmd_connection, 2, NULL}}, + {"ansi", + {(Tcl_ObjCmdProc *) tclcmd_ansi, 2, NULL}}, + {"html", + {(Tcl_ObjCmdProc *) tclcmd_html, 2, NULL}}, + {"debug", + {(Tcl_ObjCmdProc *) tclcmd_debug, 2, NULL}}, + {"addfunc", + {(Tcl_ObjCmdProc *) tclcmd_addfunc, 1, NULL}}, + {"addcmd", + {(Tcl_ObjCmdProc *) tclcmd_addcmd, 1, NULL}}, + {"addhook", + {(Tcl_ObjCmdProc *) tclcmd_addhook, 1, NULL}}, + {"loadfile", + {(Tcl_ObjCmdProc *) tclcmd_loadfile, 0, NULL}}, + {NULL, + {NULL, 0, NULL}} + }; + + struct tcl_hc_variable tclvars[] = + { + {"db_top", + {(char *) &db_top, 2, TCL_LINK_INT | TCL_LINK_READ_ONLY}}, + {"v(0)", + {(char *) &wenv[0], 2, TCL_LINK_STRING | TCL_LINK_READ_ONLY}}, + {"v(1)", + {(char *) &wenv[1], 2, TCL_LINK_STRING | TCL_LINK_READ_ONLY}}, + {"v(2)", + {(char *) &wenv[2], 2, TCL_LINK_STRING | TCL_LINK_READ_ONLY}}, + {"v(3)", + {(char *) &wenv[3], 2, TCL_LINK_STRING | TCL_LINK_READ_ONLY}}, + {"v(4)", + {(char *) &wenv[4], 2, TCL_LINK_STRING | TCL_LINK_READ_ONLY}}, + {"v(5)", + {(char *) &wenv[5], 2, TCL_LINK_STRING | TCL_LINK_READ_ONLY}}, + {"v(6)", + {(char *) &wenv[6], 2, TCL_LINK_STRING | TCL_LINK_READ_ONLY}}, + {"v(7)", + {(char *) &wenv[7], 2, TCL_LINK_STRING | TCL_LINK_READ_ONLY}}, + {"v(8)", + {(char *) &wenv[8], 2, TCL_LINK_STRING | TCL_LINK_READ_ONLY}}, + {"v(9)", + {(char *) &wenv[9], 2, TCL_LINK_STRING | TCL_LINK_READ_ONLY}}, + {NULL, + {NULL, 0, 0}} + }; + + /********************************************************************* + * Interpreter Manipulation and Execution Functions + * + * These are functions to initialize TCL and interpreters as well + * as deleting and executing from them. Also includes the timer. + * + */ + + void + tcl_init() + { + int i; + + Tcl_InitHashTable(&tclhash_funs, TCL_STRING_KEYS); + Tcl_InitHashTable(&tclhash_cmds, TCL_STRING_KEYS); + Tcl_InitHashTable(&tclhash_ins, TCL_STRING_KEYS); + Tcl_InitHashTable(&tclhash_tclcmds, TCL_STRING_KEYS); + Tcl_InitHashTable(&tclhash_tclvars, TCL_STRING_KEYS); + for (i = 0; i < EVENT_MAX; i++) + event_hooks[i] = NULL; + + command_add("@TCL", CMD_T_ANY | CMD_T_NOPARSE, 0, 0, 0, switchmask("LIST KILL LOAD RELOAD MASTER DEBUG STATUS"), cmd_tcl); + function_add((char *) "TCLCLEAR", fun_tclclear, 1, 1, FN_REG); + function_add((char *) "TCLPARAMS", fun_tclparams, 0, 10, FN_REG); + function_add((char *) "TCLREGS", fun_tclregs, 0, 0, FN_REG); + function_add((char *) "TCLEVAL", fun_tcleval, 1, 10, FN_REG); + function_add((char *) "TCL", fun_tcl, 1, 10, FN_REG); + function_add((char *) "EVALTIME", fun_evaltime, 1, 2, FN_NOPARSE); + + i = 0; + while (tclcommands[i].name) { + tcl_addcmd((char *) tclcommands[i].name, tclcommands[i].cmd.proc, tclcommands[i].cmd.restrict, tclcommands[i].cmd.clientData); + i++; + } + + i = 0; + while (tclvars[i].name) { + tcl_addvar((char *) tclvars[i].name, tclvars[i].var.data, tclvars[i].var.restrict, tclvars[i].var.type); + i++; + } + } + + void + tcl_boot() + { + char *bp; + master_instance = tcl_spawn(NOTHING, NULL, &bp); + + if (!master_instance) { + fprintf(stderr, "ERROR: Could not spawn master TCL Interpreter."); + exit(1); + } + /* There's ALWAYS a reference to the master interpreter */ + master_instance->refs = 1; + + if (options.tcl_bootfile && *options.tcl_bootfile) + if (Tcl_EvalFile(master_instance->tcli, options.tcl_bootfile) != TCL_OK) + do_rawlog(LT_ERR, "Loading tcl_bootfile %s failed with: %s", options.tcl_bootfile, Tcl_GetStringResult(master_instance->tcli)); + tclhook_startup(); + } + + void + tcl_addcmd(name, proc, restrict, clientData) + char *name; + Tcl_ObjCmdProc *proc; + int restrict; + ClientData clientData; + { + Tcl_HashEntry *th; + int i; + struct tcl_command *tclcmd; + + if (!name || !proc) + return; + + th = Tcl_FindHashEntry(&tclhash_tclcmds, name); + if (th) { + tclcmd = Tcl_GetHashValue(th); + } else { + tclcmd = mush_malloc(sizeof(struct tcl_command), "tcl_command"); + th = Tcl_CreateHashEntry(&tclhash_tclcmds, name, &i); + if (!th) + return; + Tcl_SetHashValue(th, tclcmd); + } + tclcmd->proc = proc; + tclcmd->restrict = restrict; + tclcmd->clientData = clientData; + } + + void + tcl_addvar(name, data, restrict, type) + char *name; + char *data; + int restrict; + int type; + { + Tcl_HashEntry *th; + int i; + struct tcl_variable *tclvar; + + if (!name || !data) + return; + + th = Tcl_FindHashEntry(&tclhash_tclvars, name); + if (th) { + tclvar = Tcl_GetHashValue(th); + } else { + tclvar = mush_malloc(sizeof(struct tcl_variable), "tcl_variable"); + th = Tcl_CreateHashEntry(&tclhash_tclvars, name, &i); + if (!th) + return; + Tcl_SetHashValue(th, tclvar); + } + tclvar->data = data; + tclvar->restrict = restrict; + tclvar->type = type; + } + + struct tcl_instance * + tcl_spawn(player, name, result) + dbref player; + char *name; + char **result; + { + Tcl_Interp *tcli; + const char *n; + int restrict; + int i; + struct tcl_instance *ti; + Tcl_HashEntry *th; + Tcl_HashSearch hs; + struct tcl_command *tclcmd; + struct tcl_variable *tclvar; + ATTR *a; + char value[BUFFER_LEN]; + char aname[20]; + + if (player == NOTHING) { + tcli = Tcl_CreateInterp(); + restrict = 0; + n = "MASTER"; + player = GOD; + } else { + #ifndef TCL_HASLIMITS + if (!God(player)) { + *result = (char *) "TCL is not patched - Only GOD can use"; + return NULL; + } + #endif + if (!name) + n = unparse_dbref(player); + else + n = filebasename(name); + + th = Tcl_FindHashEntry(&tclhash_ins, n); + if (th) + return Tcl_GetHashValue(th); + + if (player == NOTHING) + restrict = 0; + else if (God(player)) + restrict = 0; + else if (Wizard(player)) + restrict = 1; + else + restrict = 2; + + /* tcli = Tcl_CreateSlave(master_instance->tcli, (char *) n, restrict); + + /* + * THIS WORKS. For some god unknown reason. + * Actually. When you @tcl/master create interp foo it fails with + * an error about can't find init.tcl. But we really don't want it + * to even do so. Coudl TCL_BOOTFILE config option need to be set + * here? Unsure. + */ + tcli = Tcl_CreateInterp(); + if (tcli && restrict) + Tcl_MakeSafe(tcli); + } + + if (!tcli) { + *result = (char *) "Could not spawn interpreter"; + return NULL; + } + ti = mush_malloc(sizeof(struct tcl_instance), "tcl_instance"); + if (!ti) { + *result = (char *) "Could not allocate structure"; + Tcl_DeleteInterp(tcli); + return NULL; + } + ti->tcli = tcli; + ti->name = strdup((name) ? name : n); + #ifdef MEM_CHECK + add_check("tcl_instance_name"); + #endif + ti->restrict = restrict; + ti->player = player; + ti->uses = 1; + ti->cmds = 0; + ti->refs = 0; + ti->level = 0; + ti->trace = NULL; + + + th = Tcl_FirstHashEntry(&tclhash_tclcmds, &hs); + while (th) { + tclcmd = Tcl_GetHashValue(th); + if (tclcmd->restrict >= restrict) + Tcl_CreateObjCommand(tcli, Tcl_GetHashKey(&tclhash_tclcmds, th), tclcmd->proc, (tclcmd->clientData) ? tclcmd->clientData : (ClientData) ti, NULL); + th = Tcl_NextHashEntry(&hs); + } + + th = Tcl_FirstHashEntry(&tclhash_tclvars, &hs); + while (th) { + tclvar = Tcl_GetHashValue(th); + if (tclvar->restrict >= restrict) + Tcl_LinkVar(tcli, Tcl_GetHashKey(&tclhash_tclvars, th), tclvar->data, tclvar->type); + th = Tcl_NextHashEntry(&hs); + } + /* Create Association for Unlink */ + th = Tcl_CreateHashEntry(&tclhash_ins, ti->name, &i); + Tcl_SetHashValue(th, ti); + Tcl_SetAssocData(tcli, (char *) TCL_ASSOCNAME, tcl_interp_delete, th); + + *result = (char *) ""; + + if (player != NOTHING) { + i = 0; + sprintf(aname, "TCLBOOT%d", i); + while ((a = atr_get(player, aname)) != NULL) { + i++; + sprintf(aname, "TCLBOOT%d", i); + strcpy(value, uncompress(a->value)); + tcl_eval(ti, value, result); + } + } + return ti; + } + + void + tcl_interp_delete(clientData, interp) + ClientData clientData; + Tcl_Interp *interp; + { + struct tcl_hook *hook, *ehook, *phook; + struct tcl_instance *ti; + int i; + FUN *fun; + COMMAND_INFO *cmd; + Tcl_HashEntry *th; + Tcl_HashSearch hs; + char *k; + Tcl_HashEntry *ihash; + + /* Find Me */ + ihash = (Tcl_HashEntry *) clientData; + ti = Tcl_GetHashValue(ihash); + Tcl_DeleteHashEntry(ihash); + + /* Remove defined functions */ + + th = Tcl_FirstHashEntry(&tclhash_funs, &hs); + while (th) { + hook = Tcl_GetHashValue(th); + if (hook->ti == ti) { + /* Oh blunder */ + k = Tcl_GetHashKey(&tclhash_funs, th); + fun = hashfind(k, &htab_function); + if (fun) { + hashdelete(k, &htab_function); + mush_free(fun, "function"); + } + Tcl_DeleteHashEntry(th); + hook_free(hook); + th = Tcl_FirstHashEntry(&tclhash_funs, &hs); + } else { + th = Tcl_NextHashEntry(&hs); + } + } + + /* Remove defined commands.. Need refining for aliases */ + + th = Tcl_FirstHashEntry(&tclhash_cmds, &hs); + while (th) { + hook = Tcl_GetHashValue(th); + if (hook->ti == ti) { + /* Oh double blunder */ + k = Tcl_GetHashKey(&tclhash_cmds, th); + cmd = hashfind(k, &htab_command); + if (cmd) { + hashdelete(k, &htab_command); + free((char *) cmd->name); + mush_free(cmd, "tcl_command"); + } + Tcl_DeleteHashEntry(th); + hook_free(hook); + th = Tcl_FirstHashEntry(&tclhash_cmds, &hs); + } else { + th = Tcl_NextHashEntry(&hs); + } + } + + /* Remove defined event hooks */ + + for (i = 0; i < EVENT_MAX; i++) { + ehook = event_hooks[i]; + phook = NULL; + while (ehook) { + hook = ehook->next; + if (ehook->ti == ti) { + if (!phook) + event_hooks[i] = ehook->next; + else + phook->next = ehook->next; + hook_free(ehook); + phook = ehook; + } + ehook = hook; + } + } + + /* This should NOT happen */ + if (ti->refs) + notify(Owner(ti->player), tprintf("TCL Warning: Intepreter %s killed with ref %i", ti->name, ti->refs)); + + free(ti->name); + mush_free(ti, "tcl_instance"); + } + + struct tcl_instance * + tcl_find_name(name) + char *name; + { + Tcl_HashEntry *th; + th = Tcl_FindHashEntry(&tclhash_ins, name); + if (th) + return Tcl_GetHashValue(th); + else + return NULL; + } + + struct tcl_instance * + tcl_findinstance(interp) + Tcl_Interp *interp; + { + Tcl_HashEntry *th; + th = Tcl_GetAssocData(interp, (char *) TCL_ASSOCNAME, NULL); + if (th) + return Tcl_GetHashValue(th); + else + return NULL; + } + + void + tcl_timer() + { + struct tcl_instance *ti; + Tcl_HashEntry *th; + Tcl_HashSearch hs; + + tcl_timer_tick--; + if (tcl_timer_tick) + return; + tcl_timer_tick = 60; + + th = Tcl_FirstHashEntry(&tclhash_ins, &hs); + while (th) { + /* Kill if unused, unreferenced, and not currently evaluating */ + ti = Tcl_GetHashValue(th); + if ((ti->uses == 0) && (ti->refs == 0) && (ti->level == 0)) { + Tcl_DeleteInterp(ti->tcli); + } else { + ti->uses = 0; + } + th = Tcl_NextHashEntry(&hs); + } + } + + int + tcl_load(master, filename, result) + int master; + char *filename; + char **result; + { + struct tcl_instance *ti; + Tcl_Obj *namePtr, *messagePtr; + + if (!master) { + ti = tcl_spawn(GOD, filename, result); + } else { + ti = master_instance; + } + + if (!ti) + return 0; + + if (Tcl_EvalFile(ti->tcli, filename) != TCL_OK) { + namePtr = Tcl_NewStringObj((char *) "errorInfo", -1); + Tcl_IncrRefCount(namePtr); + messagePtr = Tcl_ObjGetVar2(ti->tcli, namePtr, NULL, TCL_GLOBAL_ONLY); + if (messagePtr) { + *result = Tcl_GetStringFromObj(messagePtr, NULL); + } else { + *result = Tcl_GetStringResult(ti->tcli); + } + Tcl_DecrRefCount(namePtr); + return 0; + } + *result = (char *) "Ok"; + return 1; + } + + + int + tcl_eval(ti, command, result) + struct tcl_instance *ti; + char *command; + char **result; + { + int r; + char ebuff[BUFFER_LEN]; + char *bp = ebuff; + Tcl_Obj *namePtr, *messagePtr; + + if (!ti) + return 0; + + ti->uses++; + + #ifdef TCL_HASLIMITS + if (!tcl_level) + Tcl_SetGlobalCommandLimit(TCL_LIMIT_GLOBAL); + + if (!ti->level) { + if (ti->restrict == 0) + Tcl_SetCommandLimit(ti->tcli, TCL_LIMIT_GOD); + else if (ti->restrict == 1) + Tcl_SetCommandLimit(ti->tcli, TCL_LIMIT_WIZ); + else + Tcl_SetCommandLimit(ti->tcli, TCL_LIMIT_MORTAL); + } + #endif + + ti->level++; + tcl_level++; + r = (Tcl_Eval(ti->tcli, command) == TCL_OK); + tcl_level--; + ti->level--; + + if (result) { + *result = Tcl_GetStringResult(ti->tcli); + } + if (!r && Connected(Owner(ti->player))) { + namePtr = Tcl_NewStringObj((char *) "errorInfo", -1); + Tcl_IncrRefCount(namePtr); + messagePtr = Tcl_ObjGetVar2(ti->tcli, namePtr, NULL, TCL_GLOBAL_ONLY); + safe_str("TCL: ", ebuff, &bp); + safe_str(ti->name, ebuff, &bp); + safe_chr('(', ebuff, &bp); + safe_str(unparse_dbref(ti->player), ebuff, &bp); + safe_str(") ERROR while executing \"", ebuff, &bp); + safe_str(command, ebuff, &bp); + safe_str("\":\n", ebuff, &bp); + safe_str(Tcl_GetStringFromObj(messagePtr, NULL), ebuff, &bp); + Tcl_DecrRefCount(namePtr); /* free the name object */ + *bp = '\0'; + notify(Owner(ti->player), ebuff); + } + return r; + } + + void + tcl_debugtrace(clientData, interp, level, command, cmdProc, cmdClientData, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int level; + char *command; + Tcl_CmdProc *cmdProc; + ClientData cmdClientData; + int argc; + char *argv[]; + { + char buff[BUFFER_LEN]; + struct tcl_instance *ti; + char *p; + int i; + + ti = (struct tcl_instance *) clientData; + p = buff; + safe_str(ti->name, buff, &p); + safe_str("> ", buff, &p); + for (i = 1; i < level; i++) + safe_str(" ", buff, &p); + safe_str(command, buff, &p); + *p = '\0'; + notify(Owner(ti->player), buff); + } + + void + tcl_setdebug(ti, level) + struct tcl_instance *ti; + int level; + { + if (ti->trace) + Tcl_DeleteTrace(ti->tcli, ti->trace); + + if (level) + ti->trace = Tcl_CreateTrace(ti->tcli, level, tcl_debugtrace, (ClientData) ti); + else + ti->trace = NULL; + } + + /********************************************************************* + * Hooks + * + * Hooks are 'hooks' the TCL code here uses to know where and what + * should be executed when the hardcode requests something + * This handles the (semi)classic PennMUSH hooks, as well as + * the wrappers for commands and functions + * + */ + + struct tcl_hook * + hook_init(hook, ti, proc) + struct tcl_hook *hook; + struct tcl_instance *ti; + char *proc; + { + if (!ti || !proc || !*proc) + return NULL; + if (hook) { + free(hook->proc); + hook->ti->refs--; + } else { + hook = mush_malloc(sizeof(struct tcl_hook), "tcl_hook"); + hook->next = NULL; + } + hook->proc = strdup(proc); + #ifdef MEM_CHECK + add_check("tcl_hook_proc"); + #endif + hook->ti = ti; + ti->refs++; + return hook; + } + + void + hook_free(hook) + struct tcl_hook *hook; + { + if (!hook) + return; + hook->ti->refs--; + free(hook->proc); + mush_free(hook, "tcl_hook"); + } + + void + tclhook_doem(ht, args) + int ht; + char *args; + { + struct tcl_hook *hook; + Tcl_DString ds; + int r; + char *result; + char *execute; + + hook = event_hooks[ht]; + + while (hook) { + if (args) { + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, hook->proc, -1); + Tcl_DStringAppend(&ds, " ", 1); + Tcl_DStringAppend(&ds, args, -1); + execute = Tcl_DStringValue(&ds); + } else { + execute = hook->proc; + } + r = tcl_eval(hook->ti, execute, &result); + if (args) { + Tcl_DStringFree(&ds); + } + hook = hook->next; + } + } + + void + tclhook_startup() + { + tclhook_doem(EVENT_STARTUP, NULL); + } + + void + tclhook_dbdump() + { + tclhook_doem(EVENT_DBDUMP, NULL); + } + + void + tclhook_shutdown() + { + tclhook_doem(EVENT_SHUTDOWN, NULL); + } + + void + tclhook_timer() + { + tclhook_doem(EVENT_TIMER, NULL); + tcl_timer(); + } + + void + tclhook_create(new) + dbref new; + { + tclhook_doem(EVENT_CREATE, unparse_integer(new)); + } + + void + tclhook_clone(new, source) + dbref new; + dbref source; + { + char buff[128]; + sprintf(buff, "%d %d", new, source); + tclhook_doem(EVENT_CLONE, buff); + } + + void + tclhook_free(item) + dbref item; + { + tclhook_doem(EVENT_FREE, unparse_integer(item)); + } + + void + tclhook_connect(item) + dbref item; + { + tclhook_doem(EVENT_CONNECT, unparse_integer(item)); + } + + void + tclhook_disconnect(item) + dbref item; + { + tclhook_doem(EVENT_DISCONNECT, unparse_integer(item)); + } + + /********************************************************************* + * TinyMUSH 2.2.4 Compability Commands. + * + * These are here so we can do exactly what TinyMUSH 2.2.4 does. + * + */ + + TCLCMD(tclcmd_pemit) + { + dbref target; + TCL_INIT; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "target message"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 1); + if (!okay_pemit(player, target)) { + TCL_NOPERM; + } + notify(target, Tcl_GetStringFromObj(objv[2], NULL)); + return TCL_OK; + } + + TCLCMD(tclcmd_getattrib) + { + dbref target; + ATTR *a; + TCL_INIT; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "object attrname"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 1); + a = atr_get(target, upcasestr(Tcl_GetStringFromObj(objv[2], NULL))); + if (!a && Can_Examine(player, target)) { + return TCL_OK; + } else if (!a || !Can_Read_Attr(player, target, a)) { + TCL_NOPERM; + } + Tcl_SetStringObj(resultPtr, uncompress(a->value), -1); + return TCL_OK; + } + + TCLCMD(tclcmd_setattrib) + { + dbref target; + int res; + char *v; + char *an; + TCL_INIT; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "object attrname value"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 1); + if (!controls(player, target)) { + TCL_NOPERM; + } + an = upcasestr(Tcl_GetStringFromObj(objv[2], NULL)); + v = Tcl_GetStringFromObj(objv[3], NULL); + + res = (v && *v) ? atr_add(target, an, v, player, NOTHING) + : atr_clr(target, an, player); + if (res == -1) { + TCL_NOPERM; + } + return TCL_OK; + } + + TCLCMD(tclcmd_mushfunc) + { + int j; + char *tptr[10]; + char const *tp; + int nargs; + char buff[BUFFER_LEN]; + char *bp; + TCL_INIT; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "function"); + return TCL_ERROR; + } + /* save our stack */ + for (j = 0; j < 10; j++) + tptr[j] = wenv[j]; + + /* copy the appropriate args into the stack */ + nargs = objc - 2; + + if (nargs > 10) + nargs = 10; /* maximum ten args */ + for (j = 0; j < nargs; j++) + wenv[j] = Tcl_GetStringFromObj(objv[j + 2], NULL); + for (; j < 10; j++) + wenv[j] = NULL; + + bp = buff; + + tp = Tcl_GetStringFromObj(objv[1], NULL); + process_expression(buff, &bp, &tp, player, player, player, + PE_DEFAULT, PT_DEFAULT, NULL); + + + /* restore the stack */ + for (j = 0; j < 10; j++) + wenv[j] = tptr[j]; + + *bp = 0; + Tcl_SetStringObj(resultPtr, buff, -1); + return TCL_OK; + } + + /********************************************************************* + * MUSHcode functions. + * + * These are MUSHcode callable functions, some of which were + * 'inherited' from 2.2.4 + * + */ + + static void + handle_tclarrays(player, strname, copybufs, num, buff, bp) + dbref player; + char *strname; + char **copybufs; + int num; + char *buff; + char **bp; + { + struct tcl_instance *ti; + char *ep; + char tbuf[BUFFER_LEN]; + int i; + char *v; + char eb[3]; + + ti = tcl_spawn(player, NULL, &ep); + if (!ti) { + safe_str("#-1 TCL SPAWN FAILED: ", buff, bp); + safe_str(ep, buff, bp); + return; + } + eb[0] = 0; + + for (i = 0; i < num; i++) { + sprintf(tbuf, "%d", i); + if (copybufs && copybufs[i] && *copybufs[i]) + v = copybufs[i]; + else + v = eb; + + Tcl_SetVar2(ti->tcli, strname, tbuf, v, 0); + } + } + + FUNCTION(fun_tclclear) + { + struct tcl_instance *ti; + + ti = tcl_find_name(args[0]); + if (!ti) { + safe_str("#-1 NOT FOUND", buff, bp); + return; + } + if (!controls(executor, ti->player)) { + safe_str("#-1 PERMISSION DENIED", buff, bp); + return; + } + Tcl_DeleteInterp(ti->tcli); + } + + + FUNCTION(fun_tclparams) + { + handle_tclarrays(executor, "mushparams", args, 10, buff, bp); + } + + FUNCTION(fun_tclregs) + { + /* Oh blunder */ + char *hum[10]; + int i; + + for (i = 0; i < 10; i++) + hum[i] = renv[i]; + + handle_tclarrays(executor, "mushregs", hum, 10, buff, bp); + } + + FUNCTION(fun_tcleval) + { + dbref thing; + ATTR *a; + struct tcl_instance *ti; + char tbuf[BUFFER_LEN]; + char command[BUFFER_LEN]; + char *ep; + int r; + + parse_attrib(executor, args[0], &thing, &a); + if (!a || !Can_Read_Attr(executor, thing, a)) { + safe_str("#-1 PERMISSION DENIED", buff, bp); + return; + } + /* The code is executed by the executor */ + + ti = tcl_spawn(executor, NULL, &ep); + if (!ti) { + safe_str("#-1 TCL SPAWN FAILED: ", buff, bp); + safe_str(ep, buff, bp); + return; + } + sprintf(tbuf, "%d", executor); + Tcl_SetVar(ti->tcli, (char *) "me", tbuf, 0); + sprintf(tbuf, "%d", enactor); + Tcl_SetVar(ti->tcli, (char *) "enactor", tbuf, 0); + + handle_tclarrays(executor, "in", args + 1, 9, buff, bp); + + strcpy(command, uncompress(a->value)); + r = tcl_eval(ti, command, &ep); + if (!r) + safe_str("TCL ERROR", buff, bp); + else if (ep && *ep) + safe_str(ep, buff, bp); + } + + FUNCTION(fun_tcl) + { + struct tcl_instance *ti; + char *ep; + int r; + + ti = tcl_spawn(executor, NULL, &ep); + if (!ti) { + safe_str("#-1 TCL SPAWN FAILED: ", buff, bp); + safe_str(ep, buff, bp); + return; + } + handle_tclarrays(executor, "in", args + 1, 9, buff, bp); + + r = tcl_eval(ti, args[0], &ep); + + if (!r) + safe_str("TCL ERROR", buff, bp); + else if (ep && *ep) + safe_str(ep, buff, bp); + } + + FUNCTION(fun_evaltime) + { + int run, min, max, total; + struct timeval start, stop; + char tbuff[BUFFER_LEN]; + char *tbp; + const char *ep; + int j, i, count; + char *ws[10]; + + + + if (!Wizard(executor)) { + safe_str("#-1 NO PERMISSION", buff, bp); + return; + } + if (nargs == 2) + count = parse_number(args[1]); + else + count = 1; + + for (j = 0; j < 10; j++) + ws[j] = wenv[j]; + + total = 0; + min = INT_MAX; + max = 0; + i = count; + + + while (i-- > 0) { + ep = args[0]; + tbp = tbuff; + for (j = 0; j < 10; j++) + wenv[j] = 0; + + gettimeofday(&start, NULL); + process_expression(tbuff, &tbp, &ep, executor, caller, enactor, PE_DEFAULT, PT_DEFAULT, NULL); + gettimeofday(&stop, NULL); + run = (stop.tv_sec - start.tv_sec) * 1000000 + (stop.tv_usec - start.tv_usec); + if (run > max) + max = run; + if (run < min) + min = run; + total += run; + } + + for (j = 0; j < 10; j++) + wenv[j] = ws[j]; + + sprintf(tbuff, "%i %i %.2f", min, max, (total * 1.0) / (count * 1.0)); + safe_str(tbuff, buff, bp); + return; + } + + /********************************************************************* + * Server extending commands and callbacks + * + * This functions are the TCL commands and callbacks for new + * hardcode commands and functions + * + */ + + TCLCMD(tclcmd_addhook) + { + char *p, *t; + struct tcl_hook *hook, *ehook; + int ht; + TCL_INIT; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "type proc"); + return TCL_ERROR; + } + t = upcasestr(Tcl_GetStringFromObj(objv[1], NULL)); + p = Tcl_GetStringFromObj(objv[2], NULL); + + if (!t || !*t || !p || !*p) { + TCLERROR_STRING("addhook: function of proc name missing"); + } + if (!strcmp(t, "STARTUP")) + ht = EVENT_STARTUP; + else if (!strcmp(t, "DBDUMP")) + ht = EVENT_DBDUMP; + else if (!strcmp(t, "SHUTDOWN")) + ht = EVENT_SHUTDOWN; + else if (!strcmp(t, "TIMER")) + ht = EVENT_TIMER; + else if (!strcmp(t, "CREATE")) + ht = EVENT_CREATE; + else if (!strcmp(t, "CLONE")) + ht = EVENT_CLONE; + else if (!strcmp(t, "FREE")) + ht = EVENT_FREE; + else if (!strcmp(t, "CONNECT")) + ht = EVENT_CONNECT; + else if (!strcmp(t, "DISCONNECT")) + ht = EVENT_DISCONNECT; + else { + TCLERROR_STRING("addhook: unknown hooktype"); + } + + hook = NULL; + ehook = event_hooks[ht]; + while (ehook) { + if ((ehook->ti == ti) && !strcmp(ehook->proc, p)) { + hook = ehook; + break; + } + ehook = ehook->next; + } + + hook = hook_init(hook, ti, p); + + if (!ehook) { + hook->next = event_hooks[ht]; + event_hooks[ht] = hook; + } + return TCL_OK; + } + + TCLCMD(tclcmd_addfunc) + { + char *f, *p, *t; + struct tcl_hook *tf; + Tcl_HashEntry *th; + int min, max, type; + int r; + FUN *fun; + TCL_INIT; + + if (objc != 6) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "funname proc minargs maxargs type"); + return TCL_ERROR; + } + f = upcasestr(Tcl_GetStringFromObj(objv[1], NULL)); + p = Tcl_GetStringFromObj(objv[2], NULL); + TCLGETINT(3, min); + TCLGETINT(4, max); + t = Tcl_GetStringFromObj(objv[5], NULL); + + if (!f || !*f || !p || !*p) { + TCLERROR_STRING("addfunc: function or proc name missing"); + } + if (t && !strcasecmp(t, "reg")) { + type = FN_REG; + } else if (t && !strcasecmp(t, "noparse")) { + type = FN_NOPARSE; + } else { + TCLERROR_STRING("addfunc: type is invalid"); + } + + th = Tcl_FindHashEntry(&tclhash_funs, f); + if (th) + tf = (struct tcl_hook *) Tcl_GetHashValue(th); + else + tf = NULL; + + if (th && ti->restrict) { + if (tf->ti->tcli != interp) { + TCLERROR_STRING("addfunc: Function defined by other interpreter"); + } + } + fun = hashfind(f, &htab_function); + if (fun) { + if (fun->fun == fun_gfun) { + TCLERROR_STRING("addfunc: Function is already @function defined"); + } + if (fun->fun == fun_tclfun) + mush_free(fun, "tclfun"); + hashdelete(f, &htab_function); + } + if (!th) { + th = Tcl_CreateHashEntry(&tclhash_funs, f, &r); + if (!r) { + TCLERROR_STRING("addfunc: Could not add to hash"); + } + } + tf = hook_init(tf, ti, p); + Tcl_SetHashValue(th, tf); + + p = strdup(f); + #ifdef MEM_CHECK + add_check("tcl_addfunc_name"); + #endif + function_add(p, fun_tclfun, min, max, type); + return TCL_OK; + } + + TCLCMD(tclcmd_addcmd) + { + char *c, *p, *flags; + struct tcl_hook *tf; + Tcl_HashEntry *th; + int r; + int cflag, ct, cf, cp; + char tbuff[BUFFER_LEN]; + COMMAND_INFO *cmd; + TCL_INIT; + + /* The only thing tclcommands don't do, is the HC switches. They are currently + * a bit outtascope + */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "command proc flags"); + return TCL_ERROR; + } + c = upcasestr(Tcl_GetStringFromObj(objv[1], NULL)); + p = Tcl_GetStringFromObj(objv[2], NULL); + flags = Tcl_GetStringFromObj(objv[3], NULL); + + if (!c || !*c || !p || !*p) { + TCLERROR_STRING("addcmd: command or proc name missing"); + } + ct = cf = cp = 0; + + cflag = CMD_T_ANY | CMD_T_SWITCHES; + + /* FIXME : Do proper splitting, JEEZ! */ + if (flags && *flags) { + sprintf(tbuff, " %s ", flags); + if (strstr(tbuff, " nogag ")) + cflag |= CMD_T_NOGAGGED; + if (strstr(tbuff, " noguest ")) + cflag |= CMD_T_NOGUEST; + if (strstr(tbuff, " wizard ")) + cf |= WIZARD; + else if (strstr(tbuff, " admin ")) + cf |= ROYALTY | WIZARD; + if (strstr(tbuff, " god ")) + cflag |= CMD_T_GOD; + if (strstr(tbuff, " eqsplit ")) + cflag |= CMD_T_EQSPLIT; + if (strstr(tbuff, " lnp ")) + cflag |= CMD_T_LS_NOPARSE; + if (strstr(tbuff, " rnp ")) + cflag |= CMD_T_RS_NOPARSE; + if (strstr(tbuff, " la ")) + cflag |= CMD_T_LS_ARGS; + if (strstr(tbuff, " ra ")) + cflag |= CMD_T_RS_ARGS; + } + th = Tcl_FindHashEntry(&tclhash_cmds, c); + if (th) + tf = (struct tcl_hook *) Tcl_GetHashValue(th); + else + tf = NULL; + + if (tf && ti->restrict) { + if (tf->ti->tcli != interp) { + TCLERROR_STRING("cmdfunc: Command defined by other interpreter"); + } + } + if (!th) { + th = Tcl_CreateHashEntry(&tclhash_cmds, c, &r); + if (!r) { + TCLERROR_STRING("addfunc: Could not add to hash"); + } + } + cmd = hashfind(c, &htab_command); + if (!cmd) { + cmd = mush_malloc(sizeof(COMMAND_INFO), "tcl_command"); + cmd->name = strdup(c); + #ifdef MEM_CHECK + add_check("tcl_command_name"); + #endif + hashadd(cmd->name, (void *) cmd, &htab_command); + } + cmd->func = cmd_tclcmd; + cmd->type = cflag; + cmd->flags = cf; + cmd->toggles = ct; + cmd->powers = cp; + SW_ZERO(cmd->sw); + + tf = hook_init(tf, ti, p); + Tcl_SetHashValue(th, tf); + + return TCL_OK; + } + + FUNCTION(fun_tclfun) + { + char *result; + Tcl_HashEntry *th; + struct tcl_hook *tf; + char tbuff[BUFFER_LEN]; + int r; + int i; + Tcl_DString td; + + th = Tcl_FindHashEntry(&tclhash_funs, called_as); + if (!th) { + safe_str("#-1 TCL INCONSISTENCY", buff, bp); + return; + } + tf = (struct tcl_hook *) Tcl_GetHashValue(th); + + Tcl_DStringInit(&td); + + sprintf(tbuff, "%s %i %i %i ", tf->proc, executor, caller, enactor); + Tcl_DStringAppend(&td, tbuff, -1); + Tcl_DStringStartSublist(&td); + + for (i = 0; i < nargs; i++) + Tcl_DStringAppendElement(&td, args[i]); + Tcl_DStringEndSublist(&td); + + r = tcl_eval(tf->ti, Tcl_DStringValue(&td), &result); + Tcl_DStringFree(&td); + if (!r) { + safe_str("#-1 TCL ERROR", buff, bp); + } else { + safe_str(result, buff, bp); + } + } + + COMMAND (cmd_tclcmd) { + char *result; + Tcl_HashEntry *th; + struct tcl_hook *tf; + Tcl_DString td; + char tbuff[BUFFER_LEN]; + int i, r; + + th = Tcl_FindHashEntry(&tclhash_cmds, cmd->name); + + if (!th) { + notify(player, "TCL ERROR"); + return; + } + tf = (struct tcl_hook *) Tcl_GetHashValue(th); + + Tcl_DStringInit(&td); + + sprintf(tbuff, "%s %i %i ", tf->proc, player, cause); + Tcl_DStringAppend(&td, tbuff, -1); + Tcl_DStringAppendElement(&td, switches); + if (cmd->type & CMD_T_LS_ARGS) { + Tcl_DStringStartSublist(&td); + for (i = 1; args_left[i]; i++) { + Tcl_DStringAppendElement(&td, args_left[i]); + } + Tcl_DStringEndSublist(&td); + } else { + Tcl_DStringAppendElement(&td, arg_left); + } + + if (cmd->type & CMD_T_EQSPLIT) { + if (cmd->type & CMD_T_RS_ARGS) { + Tcl_DStringStartSublist(&td); + for (i = 1; args_right[i]; i++) { + Tcl_DStringAppendElement(&td, args_right[i]); + } + Tcl_DStringEndSublist(&td); + } else { + Tcl_DStringAppendElement(&td, arg_right); + } + } + r = tcl_eval(tf->ti, Tcl_DStringValue(&td), &result); + Tcl_DStringFree(&td); + if (!r && (tf->ti->player != player)) + notify(player, "TCL ERROR"); + } + + + /********************************************************************* + * + * TCL Utility commands + * These are commands added to TCL which provide various utility + * functions + * + */ + + TCLCMD(tclcmd_loadfile) + { + int r; + char *result; + TCL_INIT; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "filename"); + return TCL_ERROR; + } + r = tcl_load(0, Tcl_GetStringFromObj(objv[1], NULL), &result); + if (!r) { + TCLERROR_STRING(result); + } + return TCL_OK; + } + + /********************************************************************* + * + * Utility functions + * Various utility functions used elsewhere + * + */ + + char * + filebasename(filename) + char *filename; + { + char *s; + s = rindex(filename, '/'); + if (s) + return (s + 1); + else + return filename; + } + + int tb_num = 0; + + char tb_buff[10][BUFFER_LEN]; + + char * + tempbuffer() + { + tb_num++; + if (tb_num >= 10) + tb_num = 0; + return tb_buff[tb_num]; + } + + char * + pdbref(object) + dbref object; + { + char *b; + b = tempbuffer(); + sprintf(b, "#%d", object); + return b; + } + + /********************************************************************* + * + * Penn TCL Commands + * + * Functions actually, since everything in TCL returns something.. + * Anyway, this is the brunt of the commands that DO something + * + */ + + static int + attrib_lattr_helper(player, thing, pattern, atr, args) + dbref player; + dbref thing; + char const *pattern; + ATTR *atr; + void *args; + { + Tcl_DString *ds = args; + Tcl_DStringAppendElement(ds, AL_NAME(atr)); + return 0; + } + + TCLCMD(tclcmd_attrib) + { + dbref target, owner; + ATTR *a; + char *aname; + char *value; + int res; + int cindex; + Tcl_DString ds; + int toggle; + + static const char *coptions[] = + { + "get", "getp", "canget", + "set", "canset", + "has", "hasp", "hasv", "haspv", + "list", + "flags", + "lock", + "owner", + NULL + }; + + enum coptions { + ATR_GET, ATR_GETP, ATR_CANGET, + ATR_SET, ATR_CANSET, + ATR_HAS, ATR_HASP, ATR_HASV, ATR_HASPV, + ATR_LIST, + ATR_FLAGS, + ATR_LOCK, + ATR_OWNER + }; + + TCL_INIT; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "option object atrname ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], (char **) coptions, (char *) "option", 0, + &cindex) != TCL_OK) { + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!GoodObject(target)) { + TCLERROR_STRING("Object not found"); + } + aname = upcasestr(Tcl_GetStringFromObj(objv[3], NULL)); + if (!aname || !*aname) { + TCLERROR_STRING("attrname cannot be empty"); + } + value = NULL; + switch ((enum coptions) cindex) { + case ATR_GET: + case ATR_GETP: + case ATR_CANGET: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object atrname"); + return TCL_ERROR; + } + if (cindex == ATR_GET) + a = atr_get_noparent(target, aname); + else + a = atr_get(target, aname); + + if (cindex == ATR_CANGET) { + if (a) + Tcl_SetIntObj(resultPtr, (Can_Read_Attr(player, target, a)) ? 1 : 0); + else + Tcl_SetIntObj(resultPtr, (Can_Examine(player, target)) ? 1 : 0); + return TCL_OK; + } + if (!a) { + if (Can_Examine(player, target)) { + return TCL_OK; + } else { + TCL_NOPERM; + } + } + if (!Can_Read_Attr(player, target, a)) { + TCL_NOPERM; + } + Tcl_SetStringObj(resultPtr, uncompress(a->value), -1); + break; + case ATR_SET: + if ((objc != 5) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object atrname ?value?"); + return TCL_ERROR; + } + if (objc == 5) + value = Tcl_GetStringFromObj(objv[4], NULL); + + if (!controls(player, target)) { + TCL_NOPERM; + } + if (objc == 5) + res = atr_add(target, aname, value, player, NOTHING); + else + res = atr_clr(target, aname, player); + + if (res == -1) { + TCL_NOPERM; + } + break; + case ATR_CANSET: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object atrname"); + return TCL_ERROR; + } + if (!controls(player, target)) { + Tcl_SetIntObj(resultPtr, 0); + } else { + a = atr_get_noparent(target, aname); + if (a && !Can_Write_Attr(Owner(player), thing, a)) + Tcl_SetIntObj(resultPtr, 0); + else + Tcl_SetIntObj(resultPtr, 1); + } + break; + case ATR_HAS: + case ATR_HASP: + case ATR_HASV: + case ATR_HASPV: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object atrname"); + return TCL_ERROR; + } + if ((cindex == ATR_HAS) || (cindex == ATR_HASV)) + a = atr_get_noparent(target, aname); + else + a = atr_get(target, aname); + + if ((a && !Can_Read_Attr(player, target, a)) || (!Can_Examine(player, target))) { + TCL_NOPERM; + } + if ((cindex == ATR_HAS) || (cindex == ATR_HASP)) + Tcl_SetIntObj(resultPtr, a ? 1 : 0); + else + Tcl_SetIntObj(resultPtr, (a && *AL_STR(a)) ? 1 : 0); + break; + case ATR_LIST: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object atrmask"); + return TCL_ERROR; + } + if (!Can_Examine(player, target)) { + TCL_NOPERM; + } + Tcl_DStringInit(&ds); + atr_iter_get(player, target, aname, attrib_lattr_helper, &ds); + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + break; + case ATR_FLAGS: + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object atrname ?flags?"); + return TCL_ERROR; + } + a = atr_get_noparent(target, aname); + + if (objc == 5) { + CMD_ATTRIB_WRITECHECK; + + value = Tcl_GetStringFromObj(objv[4], NULL); + + res = string_to_privs(attr_privs, value, AL_FLAGS(a)); + if (!Hasprivs(player)) + res &= ~(AF_MDARK | AF_WIZARD); + AL_FLAGS(a) = res; + } else { + CMD_ATTRIB_READCHECK; + } + Tcl_SetStringObj(resultPtr, (char *) privs_to_string(attr_privs, AL_FLAGS(a)), -1); + break; + case ATR_LOCK: + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object atrname ?0/1?"); + return TCL_ERROR; + } + a = atr_get_noparent(target, aname); + + if (objc == 5) { + CMD_ATTRIB_WRITECHECK; + + res = Tcl_GetIntFromObj(interp, objv[4], &toggle); + if (res != TCL_OK) + return res; + + if (toggle) + AL_FLAGS(a) |= AF_LOCKED; + else + AL_FLAGS(a) &= ~AF_LOCKED; + } else { + CMD_ATTRIB_READCHECK; + } + Tcl_SetIntObj(resultPtr, (AL_FLAGS(a) & AF_LOCKED) ? 1 : 0); + break; + case ATR_OWNER: + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object atrname ?owner?"); + return TCL_ERROR; + } + a = atr_get_noparent(target, aname); + + if (objc == 5) { + CMD_ATTRIB_WRITECHECK; + CMD_GETOBJECT(owner, 4); + if (!GoodObject(owner)) { + TCLERROR_STRING("Object not found"); + } + if (!Wizard(player) && (Owner(target) != owner)) { + TCL_NOPERM; + } + AL_CREATOR(a) = Owner(owner); + } else { + CMD_ATTRIB_READCHECK; + } + Tcl_SetIntObj(resultPtr, AL_CREATOR(a)); + break; + } + return TCL_OK; + } + + TCLCMD(tclcmd_object) + { + dbref target, new; + char *name; + char *value; + int cindex; + Tcl_DString ds; + char *p; + int ctype; + char *regs[10]; + lock_type real_type; + struct boolexp *key; + object_flag_type pref_type; + long match_flags; + int ambig_ok; + + static const char *coptions[] = + { + "create", "clone", "destroy", + "location", "contents", "exits", + "firstcontent", "firstexit", "next", + "link", + "owner", "parent", "zone", + "flags", "powers", + "lock", "elock", + "name", + "nearby", "match", "controls", "cansee", + NULL + }; + + enum coptions { + OBJ_CREATE, OBJ_CLONE, OBJ_DESTROY, + OBJ_LOCATION, OBJ_CONTENTS, OBJ_EXITS, + OBJ_FIRSTCONTENT, OBJ_FIRSTEXIT, OBJ_NEXT, + OBJ_LINK, + OBJ_OWNER, OBJ_PARENT, OBJ_ZONE, + OBJ_FLAGS, OBJ_POWERS, + OBJ_LOCK, OBJ_ELOCK, + OBJ_NAME, + OBJ_NEARBY, OBJ_MATCH, OBJ_CONTROLS, OBJ_CANSEE + }; + + TCL_INIT; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], (char **) coptions, (char *) "option", 0, + &cindex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum coptions) cindex) { + case OBJ_CREATE: + if (objc == 3) { + ctype = TYPE_THING; + } else if (objc == 4) { + value = Tcl_GetStringFromObj(objv[3], NULL); + if (!strcasecmp(value, "thing")) + ctype = TYPE_THING; + else if (!strcasecmp(value, "room")) + ctype = TYPE_ROOM; + else if (!strcasecmp(value, "exit")) + ctype = TYPE_EXIT; + else { + TCLERROR_STRING("Unknown object type"); + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "name ?type?"); + return TCL_ERROR; + } + name = Tcl_GetStringFromObj(objv[2], NULL); + if (!name || !*name) { + TCLERROR_STRING("Name cannot be blank"); + } + switch (ctype) { + case TYPE_THING: + target = do_create(player, name, 10); + break; + case TYPE_ROOM: + regs[1] = NULL; + regs[2] = NULL; + target = do_dig(player, name, regs, 0); + break; + case TYPE_EXIT: + target = do_real_open(player, name, "", NOTHING); + break; + } + if (!GoodObject(target)) { + TCLERROR_STRING("Create failed for some reason"); + } + Tcl_SetIntObj(resultPtr, target); + break; + case OBJ_CLONE: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (objc == 4) { + target = do_clone(player, pdbref(target), 1); + } else { + target = do_clone(player, pdbref(target), 0); + } + if (!GoodObject(target)) { + TCLERROR_STRING("Clone failed for some reason"); + } + Tcl_SetIntObj(resultPtr, target); + break; + case OBJ_DESTROY: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + do_destroy(player, pdbref(target), 1); + break; + case OBJ_LOCATION: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object ?newloc?"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!Can_Examine(player, target)) { + TCL_NOPERM; + } + if (objc == 4) { + CMD_GETOBJECT(new, 3); + do_teleport(player, pdbref(target), pdbref(new)); + } + Tcl_SetIntObj(resultPtr, Location(target)); + break; + case OBJ_CONTENTS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!Can_Examine(player, target)) { + TCL_NOPERM; + } + Tcl_DStringInit(&ds); + DOLIST(target, Contents(target)) { + Tcl_DStringAppendElement(&ds, unparse_integer(target)); + } + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + break; + case OBJ_FIRSTCONTENT: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!Can_Examine(player, target)) { + TCL_NOPERM; + } + Tcl_SetIntObj(resultPtr, Contents(target)); + break; + case OBJ_EXITS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!Can_Examine(player, target) || (Typeof(target) != TYPE_ROOM)) { + TCL_NOPERM; + } + Tcl_DStringInit(&ds); + DOLIST(target, Exits(target)) { + Tcl_DStringAppendElement(&ds, unparse_integer(target)); + } + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + break; + case OBJ_FIRSTEXIT: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!Can_Examine(player, target)) { + TCL_NOPERM; + } + Tcl_SetIntObj(resultPtr, Exits(target)); + break; + case OBJ_NEXT: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if ((Typeof(target) == TYPE_ROOM) || ((Typeof(target) == TYPE_EXIT) && !Can_Examine(player, Source(target))) || + !Can_Examine(player, Location(target))) { + TCL_NOPERM; + } + Tcl_SetIntObj(resultPtr, Next(target)); + break; + case OBJ_LINK: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object linkto"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + CMD_GETOBJECT(new, 3); + do_link(player, pdbref(target), pdbref(new)); + break; + case OBJ_OWNER: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object ?newowner?"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (objc == 4) { + CMD_GETOBJECT(new, 3); + do_chown(player, pdbref(target), pdbref(new)); + } + Tcl_SetIntObj(resultPtr, Owner(target)); + break; + case OBJ_PARENT: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object ?newparent?"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!Can_Examine(player, target)) { + TCL_NOPERM; + } + if (objc == 4) { + CMD_GETOBJECT(new, 3); + do_parent(player, pdbref(target), (new == 0) ? (char *) "none" : pdbref(new)); + } + Tcl_SetIntObj(resultPtr, Parent(target)); + break; + case OBJ_ZONE: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object ?newzone?"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!Can_Examine(player, target)) { + TCL_NOPERM; + } + if (objc == 4) { + CMD_GETOBJECT(new, 3); + do_chzone(player, pdbref(target), (new == 0) ? "none" : pdbref(new)); + } + Tcl_SetIntObj(resultPtr, Zone(target)); + break; + case OBJ_FLAGS: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object ?newflags?"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (objc == 4) { + if (!controls(player, target)) { + TCL_NOPERM; + } + value = Tcl_GetStringFromObj(objv[3], NULL); + for (p = value; *p && (*p == NOT_TOKEN || isspace(*p)); p++) ; + set_flag(player, target, p, (*value == NOT_TOKEN) ? 1 : 0, Hearer(target), Listener(target)); + } else if (!Can_Examine(player, target)) { + TCL_NOPERM; + } + Tcl_SetStringObj(resultPtr, (char *) unparse_flags(target, player), -1); + break; + case OBJ_POWERS: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object ?newpowers?"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (objc == 4) { + if (!Wizard(player)) { + TCL_NOPERM; + } + value = Tcl_GetStringFromObj(objv[3], NULL); + for (p = value; *p && (*p == NOT_TOKEN || isspace(*p)); p++) ; + ctype = find_power(p); + if ((ctype == -1) || ((ctype == IS_GUEST) && Hasprivs(target))) { + TCLERROR_STRING("No such power"); + } + if (*value == NOT_TOKEN) + Powers(target) &= ~ctype; + else + Powers(target) |= ctype; + } else if (!Can_Examine(player, target)) { + TCL_NOPERM; + } + Tcl_SetStringObj(resultPtr, (char *) power_description(target), -1); + break; + case OBJ_LOCK: + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object locktype ?newkey?"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!controls(player, target)) { + TCL_NOPERM; + } + real_type = check_lock_type(player, target, Tcl_GetStringFromObj(objv[3], NULL)); + if (!real_type) { + TCLERROR_STRING("Unknown locktype"); + } + if (objc == 4) { + delete_lock(target, real_type); + } else { + value = Tcl_GetStringFromObj(objv[4], NULL); + key = parse_boolexp(player, value); + if (key == TRUE_BOOLEXP) { + TCLERROR_STRING("Unknown key"); + } + add_lock(target, real_type, key); + } + break; + case OBJ_ELOCK: + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object locktype passer"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + CMD_GETOBJECT(new, 4); + if (!Can_Read_Lock(player, target, NULL)) { + TCL_NOPERM; + } + Tcl_SetIntObj(resultPtr, (eval_lock(new, target, Tcl_GetStringFromObj(objv[3], NULL))) ? 1 : 0); + break; + case OBJ_NAME: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object ?newname?"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (objc == 4) { + value = Tcl_GetStringFromObj(objv[3], NULL); + do_name(player, pdbref(target), value); + } + Tcl_SetStringObj(resultPtr, shortname(target), -1); + break; + case OBJ_NEARBY: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "objecta objectb"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + CMD_GETOBJECT(new, 3); + if (!controls(player, target) && !controls(player, new) && !nearby(player, target) && !nearby(player, new)) { + TCL_NOPERM; + } + Tcl_SetIntObj(resultPtr, nearby(target, new) ? 1 : 0); + break; + case OBJ_MATCH: + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "object type matchstring"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + value = Tcl_GetStringFromObj(objv[3], NULL); + p = value; + pref_type = NOTYPE; + match_flags = 0; + ambig_ok = 0; + while (p && *p) { + switch (*p) { + case 'N': + pref_type = NOTYPE; + break; + case 'E': + pref_type = TYPE_EXIT; + break; + case 'P': + pref_type = TYPE_PLAYER; + break; + case 'R': + pref_type = TYPE_ROOM; + break; + case 'T': + pref_type = TYPE_THING; + break; + case 'L': + match_flags |= MAT_CHECK_KEYS; + break; + case '*': + match_flags |= MAT_EVERYTHING; + break; + case 'a': + match_flags |= MAT_ABSOLUTE; + break; + case 'c': + match_flags |= MAT_CARRIED_EXIT; + break; + case 'e': + match_flags |= MAT_EXIT; + break; + case 'h': + match_flags |= MAT_HERE; + break; + case 'i': + match_flags |= MAT_POSSESSION; + break; + case 'l': + match_flags |= MAT_CONTAINER; + break; + case 'm': + match_flags |= MAT_ME; + break; + case 'n': + match_flags |= MAT_NEIGHBOR; + break; + case 'p': + match_flags |= MAT_PLAYER; + break; + } + p++; + } + value = Tcl_GetStringFromObj(objv[4], NULL); + if (ambig_ok) + new = last_match_result(target, value, pref_type, match_flags); + else + new = match_result(target, value, pref_type, match_flags); + Tcl_SetIntObj(resultPtr, new); + break; + case OBJ_CONTROLS: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "objecta objectb"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + CMD_GETOBJECT(new, 3); + if (!controls(player, target)) { + TCL_NOPERM; + } + Tcl_SetIntObj(resultPtr, controls(target, new) ? 1 : 0); + break; + case OBJ_CANSEE: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "objecta objectb"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + CMD_GETOBJECT(new, 3); + Tcl_SetIntObj(resultPtr, Can_Examine(target, new) ? 1 : 0); + break; + } + return TCL_OK; + } + + TCLCMD(tclcmd_notify) + { + int cindex; + char *string; + int narg, maxarg; + dbref room, target, exc; + + static const char *coptions[] = + { + "object", "room", "zone", + #ifdef CHAT_SYSTEM + "channel", + #endif /* CHAT_SYSTEM */ + NULL + }; + + enum coptions { + NOTIFY_OBJECT, NOTIFY_ROOM, NOTIFY_ZONE + #ifdef CHAT_SYSTEM + ,NOTIFY_CHANNEL + #endif /* CHAT_SYSTEM */ + }; + + TCL_INIT; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "option arg ?args ...? message"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], (char **) coptions, (char *) "option", 0, + &cindex) != TCL_OK) { + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[objc - 1], NULL); + maxarg = objc - 1; + narg = 2; + + switch ((enum coptions) cindex) { + case NOTIFY_OBJECT: + while (narg < maxarg) { + CMD_GETOBJECT(target, narg); + if (!okay_pemit(player, target)) { + TCL_NOPERM; + } + notify(target, string); + narg++; + } + break; + case NOTIFY_ROOM: + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "room exception message"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + #ifdef SPEECH_LOCK + if (!Hasprivs(player) && !eval_lock(player, target, Speech_Lock)) { + TCL_NOPERM; + } + #endif + CMD_CONVOBJECT(exc, 3); + if ((player != exc) && (Location(player) == target)) + notify(player, string); + oemit_notify_except(target, player, GoodObject(exc) ? exc : NOTHING, string); + break; + case NOTIFY_ZONE: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "zone message"); + return TCL_ERROR; + } + CMD_GETOBJECT(target, 2); + if (!controls(player, target)) { + TCL_NOPERM; + } + for (room = 0; room < db_top; room++) + if ((Zone(room) == target) && (Typeof(room) == TYPE_ROOM) + #ifdef SPEECH_LOCK + && (Hasprivs(player) || eval_lock(player, room, Speech_Lock)) + #endif + ) + oemit_notify_except(room, player, room, string); + break; + #ifdef CHAT_SYSTEM + case NOTIFY_CHANNEL: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "channel message"); + return TCL_ERROR; + } + do_cemit(player, Tcl_GetStringFromObj(objv[2], NULL), string, 0); + break; + #endif /* CHAT_SYSTEM */ + } + + return TCL_OK; + } + + TCLCMD(tclcmd_ansi) + { + char *value; + int v; + TCL_INIT; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "?color?"); + return TCL_ERROR; + } + if (objc == 1) { + Tcl_SetStringObj(resultPtr, (char *) ANSI_NORMAL, -1); + } else { + value = Tcl_GetStringFromObj(objv[1], NULL); + if (*value) { + while (*value) { + v = -1; + switch (*value) { + case 'n': + v = 0; + break; + case 'h': + v = 1; + break; + case 'i': + v = 7; + break; + case 'f': + v = 5; + break; + case 'u': + v = 4; + break; + case 'x': + v = 30; + break; + case 'r': + v = 31; + break; + case 'g': + v = 32; + break; + case 'y': + v = 33; + break; + case 'b': + v = 34; + break; + case 'm': + v = 35; + break; + case 'c': + v = 36; + break; + case 'w': + v = 37; + break; + case 'X': + v = 40; + break; + case 'R': + v = 41; + break; + case 'G': + v = 42; + break; + case 'Y': + v = 43; + break; + case 'B': + v = 44; + break; + case 'M': + v = 45; + break; + case 'C': + v = 46; + break; + case 'W': + v = 47; + break; + case 't': + Tcl_AppendToObj(resultPtr, (char *) "\t", -1); + break; + case 'a': + if (Wizard(player)) + Tcl_AppendToObj(resultPtr, (char *) "\a", -1); + break; + default: + TCLERROR_STRING("unknown ansi code"); + } + if (v >= 0) { + Tcl_AppendToObj(resultPtr, (char *) "\x1B[", -1); + Tcl_AppendToObj(resultPtr, unparse_integer(v), -1); + Tcl_AppendToObj(resultPtr, (char *) "m", -1); + } + value++; + } + } + } + return TCL_OK; + } + + TCLCMD(tclcmd_html) + { + int cindex; + char *string; + int narg, maxarg; + dbref room, target, exc; + + static const char *coptions[] = + { + "tag", "endtag", "tagwrap", + NULL + }; + + enum coptions { + HTML_TAG, HTML_ENDTAG, HTML_TAGWRAP + }; + + TCL_INIT; + + if (objc == 2) { + Tcl_AppendToObj(resultPtr, (char *) "\02", -1); + Tcl_AppendToObj(resultPtr, Tcl_GetStringFromObj(objv[1], NULL), -1); + Tcl_AppendToObj(resultPtr, (char *) "\03", -1); + return TCL_OK; + } + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "option arg ?args ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], (char **) coptions, (char *) "option", 0, + &cindex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum coptions) cindex) { + case HTML_TAG: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "tag ?args?"); + return TCL_ERROR; + } + Tcl_AppendToObj(resultPtr, (char *) "\02", -1); + Tcl_AppendToObj(resultPtr, Tcl_GetStringFromObj(objv[2], NULL), -1); + if (objc == 4) { + Tcl_AppendToObj(resultPtr, (char *) " ", -1); + Tcl_AppendToObj(resultPtr, Tcl_GetStringFromObj(objv[3], NULL), -1); + } + Tcl_AppendToObj(resultPtr, (char *) "\03", -1); + break; + case HTML_ENDTAG: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "tag"); + return TCL_ERROR; + } + Tcl_AppendToObj(resultPtr, (char *) "\02/", -1); + Tcl_AppendToObj(resultPtr, Tcl_GetStringFromObj(objv[2], NULL), -1); + Tcl_AppendToObj(resultPtr, (char *) "\03", -1); + break; + case HTML_TAGWRAP: + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) "tag ?args? text"); + return TCL_ERROR; + } + Tcl_AppendToObj(resultPtr, (char *) "\02", -1); + Tcl_AppendToObj(resultPtr, Tcl_GetStringFromObj(objv[2], NULL), -1); + if (objc == 5) { + Tcl_AppendToObj(resultPtr, (char *) " ", -1); + Tcl_AppendToObj(resultPtr, Tcl_GetStringFromObj(objv[3], NULL), -1); + } + Tcl_AppendToObj(resultPtr, (char *) "\03", -1); + if (objc == 5) + Tcl_AppendToObj(resultPtr, Tcl_GetStringFromObj(objv[4], NULL), -1); + else + Tcl_AppendToObj(resultPtr, Tcl_GetStringFromObj(objv[3], NULL), -1); + Tcl_AppendToObj(resultPtr, (char *) "\02/", -1); + Tcl_AppendToObj(resultPtr, Tcl_GetStringFromObj(objv[2], NULL), -1); + Tcl_AppendToObj(resultPtr, (char *) "\03", -1); + break; + } + return TCL_OK; + } + + TCLCMD(tclcmd_debug) + { + int l; + TCL_INIT; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, (char *) "level"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(ti->tcli, objv[1], &l) == TCL_ERROR) + return TCL_ERROR; + tcl_setdebug(ti, l); + return TCL_OK; + } + + /********************************************************************* + * + * MUSH Interface + * These are the MUSH @Commands and function()s we add to interface + * with TCL in PennStyle. + * + */ + + COMMAND (cmd_tcl) { + char *bp; + struct tcl_instance *ti; + int r, is; + Tcl_HashEntry *th; + Tcl_HashSearch hs; + + if (SW_ISSET(sw, SWITCH_LOAD)) { + if (!God(player)) { + notify(player, "Permission REALLY denied."); + return; + } + r = tcl_load(SW_ISSET(sw, SWITCH_MASTER), arg_left, &bp); + notify(player, bp); + } else if (SW_ISSET(sw, SWITCH_RELOAD)) { + if (!God(player)) { + notify(player, "No, you can't"); + return; + } + ti = tcl_find_name(arg_left); + if (!ti) { + notify(player, "Not found"); + return; + } + Tcl_DeleteInterp(ti->tcli); + r = tcl_load(SW_ISSET(sw, SWITCH_MASTER), arg_left, &bp); + notify(player, bp); + } else if (SW_ISSET(sw, SWITCH_LIST)) { + th = Tcl_FirstHashEntry(&tclhash_ins, &hs); + notify(player, tprintf("%-20s%5s%5s%6s", "Name (Dbref#)", "Priv", "Refs", "Uses")); + while (th) { + ti = Tcl_GetHashValue(th); + if (Can_Examine(player, ti->player)) + notify(player, tprintf("%-20s%5i%5i%6i", ti->name, ti->restrict, ti->refs, ti->uses)); + th = Tcl_NextHashEntry(&hs); + } + } else if (SW_ISSET(sw, SWITCH_KILL)) { + if (!*arg_left) { + ti = tcl_find_name(pdbref(player)); + } else { + ti = tcl_find_name(arg_left); + } + if (!ti || !controls(player, ti->player)) { + notify(player, "Not found or not controlled"); + return; + } + Tcl_DeleteInterp(ti->tcli); + notify(player, "Killed"); + } else if (SW_ISSET(sw, SWITCH_DEBUG)) { + if (!*arg_left) { + ti = tcl_find_name(pdbref(player)); + } else { + ti = tcl_find_name(arg_left); + } + if (!ti || !controls(player, ti->player)) { + notify(player, "Not found or not controlled"); + return; + } + if (ti->trace) + is = 1; + else + is = 0; + if (SW_ISSET(sw, SWITCH_ON)) + r = 1; + if (SW_ISSET(sw, SWITCH_OFF)) + r = 0; + else + r = !is; + if (r == is) + return; + if (r && (player != Owner(ti->player))) { + notify(player, "Only the owner can set something debug"); + return; + } + tcl_setdebug(ti, (r) ? 1 : 0); + notify(player, tprintf("TCL Debugging now %s.", (r) ? "on" : "off")); + } else if (SW_ISSET(sw, SWITCH_STATUS)) { + if (SW_ISSET(sw, SWITCH_MASTER)) { + notify(player, "TCL Configuration"); + #ifdef TCL_HASLIMITS + notify(player, tprintf("TCL Version : %s (Patched)", TCL_PATCH_LEVEL)); + #else + notify(player, tprintf("TCL Version : %s (Unsafe)", TCL_PATCH_LEVEL)); + #endif + notify(player, tprintf("TCL PatchVersion : %s", TCL_PATCHVERSION)); + #ifdef TCL_HASLIMITS + notify(player, "Command Limits"); + notify(player, tprintf(" Global : %6ik", TCL_LIMIT_GLOBAL / 1000)); + notify(player, tprintf(" God : %6ik", TCL_LIMIT_GOD / 1000)); + notify(player, tprintf(" Wizard : %6ik", TCL_LIMIT_WIZ / 1000)); + notify(player, tprintf(" Mortal : %6ik", TCL_LIMIT_MORTAL / 1000)); + #endif + } else { + if (!*arg_left) { + ti = tcl_find_name(pdbref(player)); + } else { + ti = tcl_find_name(arg_left); + } + if (!ti || !Can_Examine(player, ti->player)) { + notify(player, "Not found or not allowed"); + return; + } + notify(player, tprintf("Name : %s", ti->name)); + notify(player, tprintf("Owner : %s", pdbref(ti->player))); + notify(player, tprintf("Refs : %i", ti->refs)); + notify(player, tprintf("Uses : %i", ti->uses)); + notify(player, tprintf("Debug : %s", (ti->trace) ? "Yes" : "No")); + r = tcl_eval(ti, (char *) "if {[info procs status] == \"status\"} {status}", &bp); + if (r && *bp) + notify(player, tprintf("Status: %s", bp)); + } + } else { + if (God(player) && SW_ISSET(sw, SWITCH_MASTER)) { + ti = master_instance; + } else { + ti = tcl_spawn(player, NULL, &bp); + if (!ti) { + notify(player, tprintf("TCL Spawn failed: %s", bp)); + return; + } + } + r = tcl_eval(ti, arg_left, &bp); + if (r && bp && *bp) + notify(player, tprintf("Result: %s", bp)); + } + } + + #endif Index: stock.2/hdrs/penntcl.h *** stock.2/hdrs/penntcl.h Fri, 26 May 2000 13:09:15 -0500 kamikaze (pennmush-1.7.3/d/38_penntcl.h 1.1 644) --- tcl.2/hdrs/penntcl.h Thu, 25 May 2000 15:54:22 -0500 kamikaze (pennmush-1.7.3/d/37_penntcl.h 1.1 644) *************** *** 0 **** --- 1,202 ---- + /* The defines for penntcl.h + */ + + #ifndef PENNTCL_H + #define PENNTCL_H + #ifdef ENABLE_TCL + + + #include "config.h" + #include "confmagic.h" + #include + #include "function.h" + #include "command.h" + + + #define TCL_PATCHVERSION "0.1a2" + + #define TCL_LIMIT_GLOBAL 1000000 + #define TCL_LIMIT_GOD 1000000 + #define TCL_LIMIT_WIZ 500000 + #define TCL_LIMIT_MORTAL 100000 + + #define TCL_ASSOCNAME "hash_instance" + + struct tcl_instance { + Tcl_Interp *tcli; + char *name; + int restrict; + dbref player; + int uses; + int cmds; + int refs; + int level; + Tcl_Trace trace; + }; + + struct tcl_hook { + /* Only used by the event hooks, but it's nice to have a conforming structure. */ + struct tcl_hook *next; + struct tcl_instance *ti; + char *proc; + }; + + struct tcl_command { + Tcl_ObjCmdProc *proc; + int restrict; + ClientData clientData; + }; + + struct tcl_hc_command { + const char *name; + struct tcl_command cmd; + }; + + struct tcl_variable { + char *data; + int restrict; + int type; + }; + + struct tcl_hc_variable { + const char *name; + struct tcl_variable var; + }; + + #define EVENT_STARTUP 0 + #define EVENT_DBDUMP 1 + #define EVENT_SHUTDOWN 2 + #define EVENT_TIMER 3 + #define EVENT_CREATE 4 + #define EVENT_CLONE 5 + #define EVENT_FREE 6 + #define EVENT_CONNECT 7 + #define EVENT_DISCONNECT 8 + #define EVENT_MAX 9 + + /* ClientData? tcl_instance? Same thing :) */ + #define TCLCMD(x) \ + int \ + x(ti, interp, objc, objv) \ + struct tcl_instance *ti; \ + Tcl_Interp *interp; \ + int objc; \ + Tcl_Obj *CONST objv[]; \ + + + #define TCLCMD_PROTO(x) int x _((struct tcl_instance *ti, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])) + #define TCL_INSTANCE struct tcl_instance *ti=(struct tcl_instance *) + + + /* Tiny 2.2.4 commands */ + TCLCMD_PROTO(tclcmd_pemit); + TCLCMD_PROTO(tclcmd_getattrib); + TCLCMD_PROTO(tclcmd_setattrib); + TCLCMD_PROTO(tclcmd_mushfunc); + + /* Our commands */ + TCLCMD_PROTO(tclcmd_addhook); + TCLCMD_PROTO(tclcmd_addcmd); + TCLCMD_PROTO(tclcmd_addfunc); + TCLCMD_PROTO(tclcmd_loadfile); + TCLCMD_PROTO(tclcmd_attrib); + TCLCMD_PROTO(tclcmd_object); + TCLCMD_PROTO(tclcmd_notify); + TCLCMD_PROTO(tclcmd_connection); + TCLCMD_PROTO(tclcmd_ansi); + TCLCMD_PROTO(tclcmd_html); + TCLCMD_PROTO(tclcmd_debug); + + /* Hooks for additions */ + FUNCTION_PROTO(fun_tclfun); + COMMAND_PROTO(cmd_tclcmd); + + /* Our MUSH Online interfaces */ + FUNCTION_PROTO(fun_tclclear); + FUNCTION_PROTO(fun_tclparams); + FUNCTION_PROTO(fun_tclregs); + FUNCTION_PROTO(fun_tcleval); + FUNCTION_PROTO(fun_tcl); + FUNCTION_PROTO(fun_evaltime); + COMMAND_PROTO(cmd_tcl); + + struct tcl_hook *hook_init _((struct tcl_hook * hook, struct tcl_instance * ti, char *proc)); + void hook_free _((struct tcl_hook * hook)); + void tclhook_doem _((int ht, char *args)); + void tclhook_startup _((void)); + void tclhook_dbdump _((void)); + void tclhook_shutdown _((void)); + void tclhook_timer _((void)); + void tclhook_create _((dbref new)); + void tclhook_clone _((dbref new, dbref source)); + void tclhook_free _((dbref item)); + void tclhook_connect _((dbref item)); + void tclhook_disconnect _((dbref item)); + char *filebasename _((char *filename)); + struct tcl_instance *tcl_spawn _((dbref player, char *name, char **result)); + void tcl_init _((void)); + int tcl_kill_interp _((struct tcl_instance * ti)); + struct tcl_instance *tcl_find_name _((char *name)); + struct tcl_instance *tcl_findinstance _((Tcl_Interp * interp)); + int tcl_load _((int master, char *filename, char **result)); + int tcl_eval _((struct tcl_instance * ti, char *command, char **result)); + void tcl_timer _((void)); + void tcl_setdebug _((struct tcl_instance * ti, int level)); + void tcl_interp_delete _((ClientData clientData, Tcl_Interp * interp)); + void tcl_addcmd _((char *name, Tcl_ObjCmdProc * proc, int restrict, ClientData clientData)); + void tcl_addvar _((char *name, char *data, int restrict, int type)); + + #define TCL_INIT \ + Tcl_Obj *resultPtr; \ + dbref player; \ + resultPtr = Tcl_GetObjResult(interp); \ + player = ti->player; + + #define TCLERROR_STRING(x) \ + Tcl_SetStringObj(resultPtr, (char *)x, -1); return TCL_ERROR + + #define TCL_NOPERM \ + Tcl_SetStringObj(resultPtr, (char *) "permission denied", -1); return TCL_ERROR + + #define TCLGETINT(x, y) \ + if (Tcl_GetIntFromObj(interp, objv[x], &y)==TCL_ERROR) \ + return TCL_ERROR + + #define CMD_ATTRIB_READCHECK \ + if ((a && !Can_Read_Attr(player, target, a)) || !Can_Examine(player, target)) { \ + TCLERROR_STRING("permission denied"); \ + } \ + if (!a) { \ + TCLERROR_STRING("attribute not found"); \ + } + + #define CMD_ATTRIB_WRITECHECK \ + if ((a && !Can_Write_Attr(player, target, a)) || !controls(player, target)) { \ + TCLERROR_STRING("Permission denied"); \ + } \ + if (!a) { \ + TCLERROR_STRING("Attribute not found"); \ + } + + + #define CMD_CONVOBJECT(x, y) \ + if (Tcl_GetIntFromObj(interp, objv[y], &x) != TCL_OK) { \ + Tcl_ResetResult(interp); \ + x = match_result(player, Tcl_GetStringFromObj(objv[y], NULL), NOTYPE, MAT_EVERYTHING | MAT_ME | MAT_HERE); \ + } + + #define CMD_GETOBJECT(x, y) \ + CMD_CONVOBJECT(x, y) \ + if (!GoodObject(x)) { \ + TCLERROR_STRING("object not found"); \ + } + + /* Externals we need */ + int okay_pemit _((dbref player, dbref target)); + void do_chown _((dbref player, const char *name, const char *newobj)); + lock_type check_lock_type _((dbref player, dbref thing, char *name)); + void oemit_notify_except _((dbref loc, dbref exc1, dbref exc2, const char *msg)); + + + #endif + #endif