#!/usr/bin/perl
#
# o 8
# 8 8
# o8P .oPYo. .oPYo. odYo. o o ooYoYo. o o .oPYo. 8oPYo.
# 8 8oooo8 8oooo8 8' `8 8 8 8' 8 8 8 8 Yb.. 8 8
# 8 8. 8. 8 8 8 8 8 8 8 8 8 'Yb. 8 8
# 8 `Yooo' `Yooo' 8 8 `YooP8 8 8 8 `YooP' `YooP' 8 8
# 8
# 'oooP'
#
# A TinyMUSH like server written in perl?
# [ impossible but true ]
#
# General Notes:
#
# Reloading Code:
# The code supports re-loading the perl code while the MUSH is running
# for the purposes of debuging or general ease of use. One hurdle is
# certain lines of code should not be re-run or bad things will happen.
# If line is determined that it should not be re-loaded, a "#!#" will
# need to be added to the line to signify to not re-load that line.
#
# See renumber_code() for additional trickery that is required to
# preserve line numbers.
#
use strict;
use IO::Select;
use IO::Socket;
use File::Basename;
use Text::Wrap;
use Digest::SHA qw(sha1 sha1_hex);
use Time::HiRes "ualarm";
use Scalar::Util qw(looks_like_number);
use Time::Local;
use Math::BigInt;
$Text::Wrap::huge = 'overflow';
use POSIX;
use Fcntl qw( SEEK_END SEEK_SET);
#
# Certain lines of the code should not be re-loaded or the MUSH or bad
# things will happen. To combat this, the code will assume it should never
# reload any line that contains "#!#". Blank lines will be loaded instead
# to preserve line numbers.
#
my (%command, #!# commands for after player has connected
%fun, #!# functions for players to use
%offline, #!# commands for before player has connected
%connected, #!# connected socket information
%connected_user, #!# users connected
$readable, #!# sockets to wait for input on
$listener, #!# port details
$web, #!# web port details
$ws, #!# websocket server object
$websock, #!# websocket listener
%http, #!# http socket list
%code, #!# loaded perl files w/mod times
$log, #!# database connection for logs
%info, #!# misc info storage
$user, #!# current user details
$enactor, #!# object who initated the action
%c, #!#
%engine, #!# process holder for running
%ansi_rgb, #!# color number to rgb code
%ansi_name, #!# color names to 256 color id
%default, #!# default values for some config options
#----[memory database structures]---------------------------------------#
%help, #!# online-help
@db, #!# whole database
@delta, #!# db changes storage during @dump
%dirty, #!# dirty "bit" to track db changes.
%player, #!# player list for quick lookup
@free, #!# free objects list
%deleted, #!# deleted objects during backup
%flag, #!# flag definition
); #!#
# this should be a variable, but this allows us to reload the data
# without restarting the server.
sub version
{
return "TeenyMUSH 0.91";
}
#
# load_modules
# Some modules are "optional". Load these optional modules or disable
# their use by setting the coresponding @info variable to -1.
#
sub load_modules
{
my %mod = (
'URI::Escape' => 'uri_escape', # liburi-encode-perl
'Net::WebSocket::Server' => 'websocket', # perl -MCPAN -e "install
# Net::WebSocket::Server"
'Net::HTTPS::NB' => 'url_https', # libnet-https-nb-perl
'Net::HTTP::NB' => 'url_http',
'HTML::Entities' => 'entities',
'Digest::MD5' => 'md5',
'File::Copy' => 'copy',
'HTML::Restrict' => 'html_restrict', # libhtml-restrict-perl
'MIME::Base64' => 'mime',
'Compress::Zlib' => 'compress',
'Net::DNS' => 'dns', # libnet-dns-perl
'Cwd' => 'cwd',
'Carp' => 'carp'
);
for my $key (keys %mod) {
if(!defined @info{"@mod{$key}"} || @info{"@mod{$key}"} eq undef) {
@info{"@mod{$key}"} = 1;
eval "use $key; 1;" or @info{"@mod{$key}"} = -1;
if(@info{"@mod{$key}"} == -1 && !@info{shell}) {
printf("WARNING: Missing $key module, @mod{$key} disabled\n");
}
}
}
}
#
# getfile
# Load a file into memory and return the contents of that file.
# Depending upon the extention, files are loaded from different
# folders.
#
sub getfile
{
my ($fn,$code,$filter) = @_;
my($file, $out);
if($fn =~ /^[^\\|\/]+\.(pl|dat|dev|conf)$/i || $fn =~ /tmshell$/) {
open($file,$fn) || return undef; # open pl file
} elsif($fn =~ /^[^\\|\/]+$/i) {
open($file,"files\/$fn") || return undef; # open txt file
} else {
return undef; # don't open file because
} # it doesn't follow conventions
@{$$code{$fn}}{lines} = 0 if(ref($code) eq "HASH");
while(<$file>) { # read all data
s/\r//g;
@{$$code{$fn}}{lines}++ if(ref($code) eq "HASH");
if($filter eq undef || ($_ =~ /ALWAYS_LOAD/ || $_ !~ /$filter/)) {
$out .= $_;
} else {
$out .= "#!#\n"; # preserve line numbers? ALWAYS_LOAD
}
}
close($file);
$out =~ s/\r//g;
$out =~ s/\n/\r\n/g;
return $out; # return data
}
#
# getbinfile
# Load a binary file into memory, such as a jpg for use by
# httpd.
#
sub getbinfile
{
my $fn = shift;
my ($file, $content);
open($file,"files/$fn") || return undef;
binmode($file);
{
local $/;
$content = <$file>;
};
close($file);
return $content;
}
#
# load_defaults
# Default values for common configuration items. This is handled as a
# list of sets to allow reloading while running.
#
sub load_defaults
{
delete @default{keys %default};
@default{max} = 78;
@default{memory_prog_limit} = 122880;
@default{memory_db_limit} = 122880;
@default{dump_interval} = 3600;
@default{master_override} = "no";
@default{money_name_plural} = "Pennies";
@default{money_name_singular} = "Penny";
@default{paycheck} = 50;
@default{starting_room} = 1;
@default{starting_money} = 150;
@default{linkcost} = 1;
@default{digcost} = 10;
@default{createcost} = 10;
@default{function_limit} = 2500;
@default{weblog} = "yes";
@default{conlog} = "yes";
@default{auditlog} = "yes";
@default{httpd_invalid} = 3;
@default{login} = "Welcome to TeenyMUSH\r\n\r\n" .
"Type the below command to " .
"customize this screen after loging ".
"in as God.\r\n\r\n &conf.login #0" .
"= Login screen\r\n\r\n";
@default{badsite} = "Your site has been banned.";
@default{httpd_template} = "<pre>";
@default{mudname} = "TeenyMUSH";
@default{port} = "4096,4201,6250";
@default{starting_quota} = 5;
}
#
# handle command line arguements
#
sub arg
{
my $txt = shift;
for my $i (0 .. $#ARGV) {
return 1 if(@ARGV[$i] eq $txt || @ARGV[$i] eq "--$txt")
}
return 0;
}
#
# process_commandline
# Allow the user to set config attributes when the mush is not running.
# The mush will dump a new db and shutdown when complete.
#
sub process_commandline
{
my $hit = 0;
my $value;
if(conf_true("safemode")) {
set(obj(0),{},0,"conf.safemode");
}
for my $i (0 .. $#ARGV) { # set conf attributes from cmdline
if(@ARGV[$i] =~ /^-{1,2}D([^=]+)(=)/ ||
@ARGV[$i] =~ /^-{1,2}D([^=]+)$/) {
if($2 eq "=" && $' eq undef) {
con(" - Deleting conf.%s setting\n",$1);
$value = undef;
} elsif($2 eq "=") {
con(" + Setting conf.%s to %s\n",$1,$');
$value = $';
} else {
con(" + Setting conf.%s to on\n",$1,$');
$value = 1;
}
set(obj(0),{},0,"conf.$1",$value);
$hit = 1 if $1 ne "safemode";
}
}
if($hit) {
printf("\nShutting down as per commandline defines.\n");
if(defined @info{dump_name}) {
do_full_dirty_dump();
} else {
do_full_dump();
}
exit(0);
}
}
#
# run_command
# Run one command and then wait for the queue to empty before
# continueing on. This should only be used when its okay to lag
# the mush.
#
sub run_command
{
mushrun(self => obj(0),
runas => obj(0),
invoker=> obj(0),
source => 1,
cmd => shift
);
while(scalar keys %engine) { # command will remove itself when done
spin();
}
}
#
# main
# The one that rules them all
#
sub main
{
@info{run} = 1;
load_db();
printf("%s\n",conf("version")) if !@info{shell};
# trap signal HUP and try to reload the code
$SIG{HUP} = sub {
if(module_enabled("md5")) {
my $count = reload_code();
delete @engine{keys %engine};
con("HUP signal caught, reloading: %s\n",$count ? $count : "none");
} else {
con("HUP signal caught, but \@reload not enabled.");
}
};
load_modules();
initialize_functions();
initialize_ansi();
initialize_commands();
initialize_flags();
# not needed for tmshell, should be faster startup too
if(module_enabled("md5") && !@info{shell}) {
@info{source_prev} = get_source_checksums(1);
reload_code();
}
load_defaults();
# create txt directory and silently move help.txt into the right
# location so the user doesn't have to.. and better yet, I don't have
# to document it.
if(!@info{shell}) {
if(!-e "txt") {
mkdir("txt") || die("Unable to create txt directory");
}
if(module_enabled("copy")) {
if(!-e "txt\help.txt" && -e "help.txt") {
move("help.txt","files/help.txt") ||
die("Unable to move help.txt to txt folder");
}
}
}
run_command("@free");
process_commandline();
fun_mush_address(obj(0),{}) if !@info{shell}; # cache public address
if(@info{shell}) {
run_command(join(" ",@ARGV[0 .. $#ARGV]));
} else {
server_start(); #!# start only once
}
}
#
# initalize_ansi
# Define colors numbers to rgb values and color names to color numbers
# for use by ansi. This is handled as a list of sets to allow reloading
# while running.
#
sub initialize_ansi
{
delete @ansi_rgb{keys %ansi_rgb};
delete @ansi_name{keys %ansi_name};
%ansi_rgb = (
0 => "000000", 1 => "800000", 2 => "008000", 3 => "808000",
4 => "000080", 5 => "800080", 6 => "008080", 7 => "c0c0c0",
8 => "808080", 9 => "ff0000", 10 => "00ff00", 11 => "ffff00",
12 => "0000ff", 13 => "ff00ff", 14 => "00ffff", 15 => "ffffff",
16 => "000000", 17 => "00005f", 18 => "000087", 19 => "0000af",
20 => "0000d7", 21 => "0000ff", 22 => "005f00", 23 => "005f5f",
24 => "005f87", 25 => "005faf", 26 => "005fd7", 27 => "005fff",
28 => "008700", 29 => "00875f", 30 => "008787", 31 => "0087af",
32 => "0087d7", 33 => "0087ff", 34 => "00af00", 35 => "00af5f",
36 => "00af87", 37 => "00afaf", 38 => "00afd7", 39 => "00afff",
40 => "00d700", 41 => "00d75f", 42 => "00d787", 43 => "00d7af",
44 => "00d7d7", 45 => "00d7ff", 46 => "00ff00", 47 => "00ff5f",
48 => "00ff87", 49 => "00ffaf", 50 => "00ffd7", 51 => "00ffff",
52 => "5f0000", 53 => "5f005f", 54 => "5f0087", 55 => "5f00af",
56 => "5f00d7", 57 => "5f00ff", 58 => "5f5f00", 59 => "5f5f5f",
60 => "5f5f87", 61 => "5f5faf", 62 => "5f5fd7", 63 => "5f5fff",
64 => "5f8700", 65 => "5f875f", 66 => "5f8787", 67 => "5f87af",
68 => "5f87d7", 69 => "5f87ff", 70 => "5faf00", 71 => "5faf5f",
72 => "5faf87", 73 => "5fafaf", 74 => "5fafd7", 75 => "5fafff",
76 => "5fd700", 77 => "5fd75f", 78 => "5fd787", 79 => "5fd7af",
80 => "5fd7d7", 81 => "5fd7ff", 82 => "5fff00", 83 => "5fff5f",
84 => "5fff87", 85 => "5fffaf", 86 => "5fffd7", 87 => "5fffff",
88 => "870000", 89 => "87005f", 90 => "870087", 91 => "8700af",
92 => "8700d7", 93 => "8700ff", 94 => "875f00", 95 => "875f5f",
96 => "875f87", 97 => "875faf", 98 => "875fd7", 99 => "875fff",
100 => "878700", 101 => "87875f", 102 => "878787", 103 => "8787af",
104 => "8787d7", 105 => "8787ff", 106 => "87af00", 107 => "87af5f",
108 => "87af87", 109 => "87afaf", 110 => "87afd7", 111 => "87afff",
112 => "87d700", 113 => "87d75f", 114 => "87d787", 115 => "87d7af",
116 => "87d7d7", 117 => "87d7ff", 118 => "87ff00", 119 => "87ff5f",
120 => "87ff87", 121 => "87ffaf", 122 => "87ffd7", 123 => "87ffff",
124 => "af0000", 125 => "af005f", 126 => "af0087", 127 => "af00af",
128 => "af00d7", 129 => "af00ff", 130 => "af5f00", 131 => "af5f5f",
132 => "af5f87", 133 => "af5faf", 134 => "af5fd7", 135 => "af5fff",
136 => "af8700", 137 => "af875f", 138 => "af8787", 139 => "af87af",
140 => "af87d7", 141 => "af87ff", 142 => "afaf00", 143 => "afaf5f",
144 => "afaf87", 145 => "afafaf", 146 => "afafd7", 147 => "afafff",
148 => "afd700", 149 => "afd75f", 150 => "afd787", 151 => "afd7af",
152 => "afd7d7", 153 => "afd7ff", 154 => "afff00", 155 => "afff5f",
156 => "afff87", 157 => "afffaf", 158 => "afffd7", 159 => "afffff",
160 => "d70000", 161 => "d7005f", 162 => "d70087", 163 => "d700af",
164 => "d700d7", 165 => "d700ff", 166 => "d75f00", 167 => "d75f5f",
168 => "d75f87", 169 => "d75faf", 170 => "d75fd7", 171 => "d75fff",
172 => "d78700", 173 => "d7875f", 174 => "d78787", 175 => "d787af",
176 => "d787d7", 177 => "d787ff", 178 => "d7af00", 179 => "d7af5f",
180 => "d7af87", 181 => "d7afaf", 182 => "d7afd7", 183 => "d7afff",
184 => "d7d700", 185 => "d7d75f", 186 => "d7d787", 187 => "d7d7af",
188 => "d7d7d7", 189 => "d7d7ff", 190 => "d7ff00", 191 => "d7ff5f",
192 => "d7ff87", 193 => "d7ffaf", 194 => "d7ffd7", 195 => "d7ffff",
196 => "ff0000", 197 => "ff005f", 198 => "ff0087", 199 => "ff00af",
200 => "ff00d7", 201 => "ff00ff", 202 => "ff5f00", 203 => "ff5f5f",
204 => "ff5f87", 205 => "ff5faf", 206 => "ff5fd7", 207 => "ff5fff",
208 => "ff8700", 209 => "ff875f", 210 => "ff8787", 211 => "ff87af",
212 => "ff87d7", 213 => "ff87ff", 214 => "ffaf00", 215 => "ffaf5f",
216 => "ffaf87", 217 => "ffafaf", 218 => "ffafd7", 219 => "ffafff",
220 => "ffd700", 221 => "ffd75f", 222 => "ffd787", 223 => "ffd7af",
224 => "ffd7d7", 225 => "ffd7ff", 226 => "ffff00", 227 => "ffff5f",
228 => "ffff87", 229 => "ffffaf", 230 => "ffffd7", 231 => "ffffff",
232 => "080808", 233 => "121212", 234 => "1c1c1c", 235 => "262626",
236 => "303030", 237 => "3a3a3a", 238 => "444444", 239 => "4e4e4e",
240 => "585858", 241 => "626262", 242 => "6c6c6c", 243 => "767676",
244 => "808080", 245 => "8a8a8a", 246 => "949494", 247 => "9e9e9e",
248 => "a8a8a8", 249 => "b2b2b2", 250 => "bcbcbc", 251 => "c6c6c6",
252 => "d0d0d0", 253 => "dadada", 254 => "e4e4e4", 255 => "eeeeee",
);
%ansi_name = (
aliceblue => 15, antiquewhite => 224, antiquewhite1 => 230,
antiquewhite2 => 224, antiquewhite3 => 181, antiquewhite4 => 8,
aquamarine => 122, aquamarine1 => 122, aquamarine2 => 122,
aquamarine3 => 79, aquamarine4 => 66, azure => 15, azure1 => 15,
azure2 => 255, azure3 => 251, azure4 => 102, beige => 230, bisque => 224,
bisque1 => 224, bisque2 => 223, bisque3 => 181, bisque4 => 101,
black => 0, blanchedalmond => 224, blue => 12, blue1 => 12, blue2 => 12,
blue3 => 20, blue4 => 18, blueviolet => 92, brown => 124, blueviolet => 92,
brown => 124, brown1 => 203, brown2 => 203, brown3 => 167, brown4 => 88,
burlywood => 180, burlywood1 => 222, burlywood2 => 222, burlywood3 => 180,
burlywood4 => 95, cadetblue => 73, cadetblue1 => 123, cadetblue2 => 117,
cadetblue3 => 116, cadetblue4 => 66, chartreuse => 118, chartreuse1 => 118,
chartreuse2 => 118, chartreuse3 => 76, chartreuse4 => 64, chocolate => 166,
chocolate1 => 208, chocolate2 => 208, chocolate3 => 166, chocolate4 => 94,
coral => 209, coral1 => 203, coral2 => 203, coral3 => 167, coral4 => 94,
cornflowerblue => 69, cornsilk => 230, cornsilk1 => 230, cornsilk2 => 254,
cornsilk3 => 187, cornsilk4 => 102, cyan => 14, cyan1 => 14, cyan2 => 14,
cyan3 => 44, cyan4 => 30, darkblue => 18, darkcyan => 30,
darkgoldenrod => 136, darkgoldenrod1 => 214, darkgoldenrod2 => 214,
darkgoldenrod3 => 172, darkgoldenrod4 => 94, darkgray => 248,
darkgreen => 22, darkgrey => 248, darkkhaki => 143, darkmagenta => 90,
darkolivegreen => 239, darkolivegreen1 => 191, darkolivegreen2 => 155,
darkolivegreen3 => 149, darkolivegreen4 => 65, darkorange => 208,
darkorange1 => 208, darkorange2 => 208, darkorange3 => 166,
darkorange4 => 94, darkorchid => 98, darkorchid1 => 135, darkorchid2 => 135,
darkorchid3 => 98, darkorchid4 => 54, darkred => 88, darksalmon => 174,
darkseagreen => 108, darkseagreen1 => 157, darkseagreen2 => 157,
darkseagreen3 => 114, darkseagreen4 => 65, darkslateblue => 60,
darkslategray => 238, darkslategray1 => 123, darkslategray2 => 123,
darkslategray3 => 116, darkslategray4 => 66, darkslategrey => 238,
darkturquoise => 44, darkviolet => 92, debianred => 161, deeppink => 198,
deeppink1 => 198, deeppink2 => 198, deeppink3 => 162, deeppink4 => 89,
deepskyblue => 39, deepskyblue1 => 39, deepskyblue2 => 39,
deepskyblue3 => 32, deepskyblue4 => 24, dimgrey => 242, dodgerblue => 33,
dodgerblue1 => 33, dodgerblue2 => 33, dodgerblue3 => 32, dodgerblue4 => 24,
firebrick => 124, firebrick1 => 203, firebrick2 => 9, firebrick3 => 160,
firebrick4 => 88, floralwhite => 15, forestgreen => 28, gainsboro => 253,
ghostwhite => 15, gold => 220, gold1 => 220, gold2 => 220, gold3 => 178,
gold4 => 3, goldenrod => 178, goldenrod1 => 214, goldenrod2 => 214,
goldenrod3 => 172, goldenrod4 => 94, gray => 7, gray0 => 0, gray1 => 0,
gray2 => 232, gray3 => 232, gray4 => 232, gray5 => 232, gray6 => 233,
gray7 => 233, gray8 => 233, gray9 => 233, gray10 => 234, gray11 => 234,
gray12 => 234, gray13 => 234, gray14 => 235, gray15 => 235, gray16 => 235,
gray17 => 235, gray18 => 236, gray19 => 236, gray20 => 236, gray21 => 237,
gray22 => 237, gray23 => 237, gray24 => 237, gray25 => 238, gray26 => 238,
gray27 => 238, gray28 => 238, gray29 => 239, gray30 => 239, gray31 => 239,
gray32 => 239, gray33 => 240, gray34 => 240, gray35 => 240, gray36 => 59,
gray37 => 59, gray38 => 241, gray39 => 241, gray40 => 241, gray41 => 242,
gray42 => 242, gray43 => 242, gray44 => 242, gray45 => 243, gray46 => 243,
gray47 => 243, gray48 => 243, gray49 => 8, gray50 => 8, gray51 => 8,
gray52 => 102, gray53 => 102, gray54 => 245, gray55 => 245, gray56 => 245,
gray57 => 246, gray58 => 246, gray59 => 246, gray60 => 246, gray61 => 247,
gray62 => 247, gray63 => 247, gray64 => 247, gray65 => 248, gray66 => 248,
gray67 => 248, gray68 => 145, gray69 => 145, gray70 => 249, gray71 => 249,
gray72 => 250, gray73 => 250, gray74 => 250, gray75 => 7, gray76 => 7,
gray77 => 251, gray78 => 251, gray79 => 251, gray80 => 252, gray81 => 252,
gray82 => 252, gray83 => 188, gray84 => 188, gray85 => 253, gray86 => 253,
gray87 => 253, gray88 => 254, gray89 => 254, gray90 => 254, gray91 => 254,
gray92 => 255, gray93 => 255, gray94 => 255, gray95 => 255, gray96 => 255,
gray97 => 15, gray98 => 15, gray99 => 15, gray100 => 15, green => 10,
green1 => 10, green2 => 10, green3 => 40, green4 => 28, greenyellow => 154,
grey => 7, grey0 => 0, grey1 => 0, grey2 => 232, grey3 => 232, grey4 => 232,
grey5 => 232, grey6 => 233, grey7 => 233, grey8 => 233, grey9 => 233,
grey10 => 234, grey11 => 234, grey12 => 234, grey13 => 234, grey14 => 235,
grey15 => 235, grey16 => 235, grey17 => 235, grey18 => 236, grey19 => 236,
grey20 => 236, grey21 => 237, grey22 => 237, grey23 => 237, grey24 => 237,
grey25 => 238, grey26 => 238, grey27 => 238, grey28 => 238, grey29 => 239,
grey30 => 239, grey31 => 239, grey32 => 239, grey33 => 240, grey34 => 240,
grey35 => 240, grey36 => 59, grey37 => 59, grey38 => 241, grey39 => 241,
grey40 => 241, grey41 => 242, grey42 => 242, grey43 => 242, grey44 => 242,
grey45 => 243, grey46 => 243, grey47 => 243, grey48 => 243, grey49 => 8,
grey50 => 8, grey51 => 8, grey52 => 102, grey53 => 102, grey54 => 245,
grey55 => 245, grey56 => 245, grey57 => 246, grey58 => 246, grey59 => 246,
grey60 => 246, grey61 => 247, grey62 => 247, grey63 => 247, grey64 => 247,
grey65 => 248, grey66 => 248, grey67 => 248, grey68 => 145, grey69 => 145,
grey70 => 249, grey71 => 249, grey72 => 250, grey73 => 250, grey74 => 250,
grey75 => 7, grey76 => 7, grey77 => 251, grey78 => 251, grey79 => 251,
grey80 => 252, grey81 => 252, grey82 => 252, grey83 => 188, grey84 => 188,
grey85 => 253, grey86 => 253, grey87 => 253, grey88 => 254, grey89 => 254,
grey90 => 254, grey91 => 254, grey92 => 255, grey93 => 255, grey94 => 255,
grey95 => 255, grey96 => 255, grey97 => 15, grey98 => 15, grey99 => 15,
grey100 => 231, honeydew => 255, honeydew1 => 255, honeydew2 => 194,
honeydew2 => 254, honeydew3 => 251, honeydew4 => 102, hotpink => 205,
hotpink1 => 205, hotpink2 => 205, hotpink3 => 168, hotpink4 => 95,
indianred => 167, indianred1 => 203, indianred2 => 203, indianred3 => 167,
indianred4 => 95, indigo => 54, ivory => 15, ivory1 => 15, ivory2 => 255,
ivory3 => 251, ivory4 => 102, khaki => 222, khaki1 => 228, khaki2 => 222,
khaki3 => 185, khaki4 => 101, lavender => 255, lavenderblush => 15,
lavenderblush1 => 15, lavenderblush2 => 254, lavenderblush3 => 251,
lavenderblush4 => 102, lawngreen => 118, lemonchiffon => 230,
lemonchiffon1 => 230, lemonchiffon2 => 223, lemonchiffon3 => 187,
lemonchiffon4 => 101, lightblue => 152, lightblue1 => 159,
lightblue2 => 153, lightblue3 => 110, lightblue4 => 66, lightcoral => 210,
lightcyan => 195, lightcyan1 => 195, lightcyan2 => 254, lightcyan3 => 152,
lightcyan4 => 102, lightgoldenrod => 222, lightgoldenrod1 => 228,
lightgoldenrod2 => 222, lightgoldenrod3 => 179, lightgoldenrod4 => 101,
lightgoldenrodyellow => 205, lightgray => 252, lightgreen => 120,
lightgrey => 252, lightpink => 217, lightpink1 => 217, lightpink2 => 217,
lightpink3 => 174, lightpink4 => 95, lightsalmon => 216,
lightsalmon1 => 216, lightsalmon2 => 209, lightsalmon3 => 173,
lightsalmon4 => 95, lightseagreen => 37, lightskyblue => 117,
lightskyblue1 => 153, lightskyblue2 => 153, lightskyblue3 => 110,
lightskyblue4 => 66, lightslateblue => 99, lightslategrey => 102,
lightsteelblue => 152, lightsteelblue1 => 189, lightsteelblue2 => 153,
lightsteelblue3 => 146, lightsteelblue4 => 66, lightyellow => 230,
lightyellow1 => 230, lightyellow2 => 254, lightyellow3 => 187,
lightyellow4 => 102, limegreen => 77, linen => 255, magenta => 13,
magenta1 => 13, magenta2 => 13, magenta3 => 164, magenta4 => 90,
maroon => 131, maroon1 => 205, maroon2 => 205, maroon3 => 162,
maroon4 => 89, mediumaquamarine => 79, mediumblue => 20,
mediumorchid => 134, mediumorchid1 => 171, mediumorchid2 => 171,
mediumorchid3 => 134, mediumorchid4 => 96, mediumpurple => 98,
mediumpurple1 => 141, mediumpurple2 => 141, mediumpurple3 => 98,
mediumpurple4 => 60, mediumseagreen => 71, mediumslateblue => 99,
mediumspringgreen => 48, mediumturquoise => 80, mediumvioletred => 162,
midnightblue => 4, mintcream => 15, mistyrose => 224, mistyrose1 => 224,
mistyrose2 => 224, mistyrose3 => 181, mistyrose4 => 8, moccasin => 223,
navajowhite => 223, navajowhite1 => 223, navajowhite2 => 223,
navajowhite3 => 180, navajowhite4 => 101, navy => 4, navyblue => 4,
oldlace => 230, olivedrab => 64, olivedrab1 => 155, olivedrab2 => 155,
olivedrab3 => 113, olivedrab4 => 64, orange => 214, orange1 => 214,
orange2 => 208, orange3 => 172, orange4 => 94, orangered => 202,
orangered1 => 202, orangered2 => 202, orangered3 => 166, orangered4 => 88,
orchid => 170, orchid1 => 213, orchid2 => 212, orchid3 => 170,
orchid4 => 96, palegoldenrod => 223, palegreen => 120, palegreen1 => 120,
palegreen2 => 120, palegreen3 => 114, palegreen4 => 65,
paleturquoise => 159, paleturquoise1 => 159, paleturquoise2 => 159,
paleturquoise3 => 116, paleturquoise4 => 66, palevioletred => 168,
palevioletred1 => 211, palevioletred2 => 211, palevioletred3 => 168,
palevioletred4 => 95, papayawhip => 230, peachpuff => 223,
peachpuff1 => 223, peachpuff2 => 223, peachpuff3 => 180, peachpuff4 => 101,
peru => 173, pink => 218, pink1 => 218, pink2 => 217, pink3 => 175,
pink4 => 95, plum => 182, plum1 => 219, plum2 => 183, plum3 => 176,
plum4 => 96, powderblue => 152, purple => 129, purple1 => 99,
purple2 => 93, purple3 => 92, purple4 => 54, red => 9, red1 => 9, red2=>9,
red3 => 160, red4 => 88, rosybrown => 138, rosybrown1 => 217,
rosybrown2 => 217, rosybrown3 => 174, rosybrown4 => 95, royalblue => 62,
royalblue1 => 69, royalblue2 => 63, royalblue3 => 62, royalblue4 => 24,
saddlebrown => 94, salmon => 209, salmon1 => 209, salmon2 => 209,
salmon3 => 167, salmon4 => 95, sandybrown => 215, seagreen => 29,
seagreen1 => 85, seagreen2 => 84, seagreen3 => 78, seagreen4 => 29,
seashell => 255, seashell1 => 255, seashell2 => 254, seashell3 => 251,
seashell4 => 102, sienna => 130, sienna1 => 209, sienna1 => 209,
sienna2 => 209, sienna3 => 167, sienna4 => 94, skyblue => 116,
skyblue1 => 117, skyblue2 => 111, skyblue3 => 74, skyblue4 => 60,
slateblue => 62, slateblue1 => 99, slateblue2 => 99, slateblue3 => 62,
slateblue4 => 60, slategray => 66, slategray1 => 189, slategray2 => 153,
slategray3 => 146, slategray4 => 66, slategrey => 66, snow => 15,
snow1 => 15, snow2 => 255, snow3 => 251, snow4 => 245, springgreen => 48,
springgreen1 => 48, springgreen2 => 48, springgreen3 => 41,
springgreen4 => 29, steelblue => 67, steelblue1 => 75, steelblue2 => 75,
steelblue3 => 68, steelblue4 => 60, tan => 180, tan1 => 215, tan2 => 209,
tan3 => 173, tan4 => 94, thistle => 182, thistle1 => 225, thistle2 => 254,
thistle3 => 182, thistle4 => 102, tomato => 203, tomato1 => 203,
tomato2 => 203, tomato3 => 167, tomato4 => 94, turquoise => 80,
turquoise1 => 14, turquoise2 => 45, turquoise3 => 44, turquoise4 => 30,
violet => 213, violetred => 162, violetred1 => 204, violetred2 => 204,
violetred3 => 168, violetred4 => 89, wheat => 223, wheat1 => 223,
wheat2 => 223, wheat3 => 180, wheat4 => 101, white => 15, whitesmoke => 255,
xterm0 => 0, xterm1 => 1, xterm2 => 2, xterm3 => 3, xterm4 => 4,
xterm5 => 5, xterm6 => 6, xterm7 => 7, xterm8 => 8, xterm9 => 9,
xterm10 => 10, xterm11 => 11, xterm12 => 12, xterm13 => 13, xterm14 => 14,
xterm15 => 15, xterm16 => 16, xterm17 => 17, xterm18 => 18, xterm19 => 19,
xterm20 => 20, xterm21 => 21, xterm22 => 22, xterm23 => 23, xterm24 => 24,
xterm25 => 25, xterm26 => 26, xterm27 => 27, xterm28 => 28, xterm29 => 29,
xterm30 => 30, xterm31 => 31, xterm32 => 32, xterm33 => 33, xterm34 => 34,
xterm35 => 35, xterm36 => 36, xterm37 => 37, xterm38 => 38, xterm39 => 39,
xterm40 => 40, xterm41 => 41, xterm42 => 42, xterm43 => 43, xterm44 => 44,
xterm45 => 45, xterm46 => 46, xterm47 => 47, xterm48 => 48, xterm49 => 49,
xterm50 => 50, xterm51 => 51, xterm52 => 52, xterm53 => 53, xterm54 => 54,
xterm55 => 55, xterm56 => 56, xterm57 => 57, xterm58 => 58, xterm59 => 59,
xterm60 => 60, xterm61 => 61, xterm62 => 62, xterm63 => 63, xterm64 => 64,
xterm65 => 65, xterm66 => 66, xterm67 => 67, xterm68 => 68, xterm69 => 69,
xterm70 => 70, xterm71 => 71, xterm72 => 72, xterm73 => 73, xterm74 => 74,
xterm75 => 75, xterm76 => 76, xterm77 => 77, xterm78 => 78, xterm79 => 79,
xterm80 => 80, xterm81 => 81, xterm82 => 82, xterm83 => 83, xterm84 => 84,
xterm85 => 85, xterm86 => 86, xterm87 => 87, xterm88 => 88, xterm89 => 89,
xterm90 => 90, xterm91 => 91, xterm92 => 92, xterm93 => 93, xterm94 => 94,
xterm95 => 95, xterm96 => 96, xterm97 => 97, xterm98 => 98, xterm99 => 99,
xterm100 => 100, xterm101 => 101, xterm102 => 102, xterm103 => 103,
xterm104 => 104, xterm105 => 105, xterm106 => 106, xterm107 => 107,
xterm108 => 108, xterm109 => 109, xterm110 => 110, xterm111 => 111,
xterm112 => 112, xterm113 => 113, xterm114 => 114, xterm115 => 115,
xterm116 => 116, xterm117 => 117, xterm118 => 118, xterm119 => 119,
xterm120 => 120, xterm121 => 121, xterm122 => 122, xterm123 => 123,
xterm124 => 124, xterm125 => 125, xterm126 => 126, xterm127 => 127,
xterm128 => 128, xterm129 => 129, xterm130 => 130, xterm131 => 131,
xterm132 => 132, xterm133 => 133, xterm134 => 134, xterm135 => 135,
xterm136 => 136, xterm137 => 137, xterm138 => 138, xterm139 => 139,
xterm140 => 140, xterm141 => 141, xterm142 => 142, xterm143 => 143,
xterm144 => 144, xterm145 => 145, xterm146 => 146, xterm147 => 147,
xterm148 => 148, xterm149 => 149, xterm150 => 150, xterm151 => 151,
xterm152 => 152, xterm153 => 153, xterm154 => 154, xterm155 => 155,
xterm156 => 156, xterm157 => 157, xterm158 => 158, xterm159 => 159,
xterm160 => 160, xterm161 => 161, xterm162 => 162, xterm163 => 163,
xterm164 => 164, xterm165 => 165, xterm166 => 166, xterm167 => 167,
xterm168 => 168, xterm169 => 169, xterm170 => 170, xterm171 => 171,
xterm172 => 172, xterm173 => 173, xterm174 => 174, xterm175 => 175,
xterm176 => 176, xterm177 => 177, xterm178 => 178, xterm179 => 179,
xterm180 => 180, xterm181 => 181, xterm182 => 182, xterm183 => 183,
xterm184 => 184, xterm185 => 185, xterm186 => 186, xterm187 => 187,
xterm188 => 188, xterm189 => 189, xterm190 => 190, xterm191 => 191,
xterm192 => 192, xterm193 => 193, xterm194 => 194, xterm195 => 195,
xterm196 => 196, xterm197 => 197, xterm198 => 198, xterm199 => 199,
xterm200 => 200, xterm201 => 201, xterm202 => 202, xterm203 => 203,
xterm204 => 204, xterm205 => 205, xterm206 => 206, xterm207 => 207,
xterm208 => 208, xterm209 => 209, xterm210 => 210, xterm211 => 211,
xterm212 => 212, xterm213 => 213, xterm214 => 214, xterm215 => 215,
xterm216 => 216, xterm217 => 217, xterm218 => 218, xterm219 => 219,
xterm220 => 220, xterm221 => 221, xterm222 => 222, xterm223 => 223,
xterm224 => 224, xterm225 => 225, xterm226 => 226, xterm227 => 227,
xterm228 => 228, xterm229 => 229, xterm230 => 230, xterm231 => 231,
xterm232 => 232, xterm233 => 233, xterm234 => 234, xterm235 => 235,
xterm236 => 236, xterm237 => 237, xterm238 => 238, xterm239 => 239,
xterm240 => 240, xterm241 => 241, xterm242 => 242, xterm243 => 243,
xterm244 => 244, xterm245 => 245, xterm246 => 246, xterm247 => 247,
xterm248 => 248, xterm249 => 249, xterm250 => 250, xterm251 => 251,
xterm252 => 252, xterm253 => 253, xterm254 => 254, xterm255 => 255,
yellow => 11, yellow1 => 11, yellow2 => 11, yellow3 => 184, yellow4 => 100,
yellowgreen => 113,
);
}
#
# initialize_commands
# Populate the HASH table of commands. This could be defined when %command
# is defined but we'd loose the ability to change the variable on the fly,
# or we'd have to have two lists.
#
sub initialize_commands
{
delete @command{keys %command};
delete @offline{keys %offline};
@offline{connect} = sub { return cmd_connect(@_); };
@offline{who} = sub { return cmd_who(@_); };
@offline{create} = sub { return cmd_pcreate(@_); };
@offline{quit} = sub { return cmd_quit(@_); };
@offline{huh} = sub { return cmd_offline_huh(@_); };
@offline{screenwidth} = sub { return; };
@offline{screenheight} = sub { return; };
# ------------------------------------------------------------------------#
@command{"\@search"} ={ fun => sub { return &cmd_search(@_);} };
@command{screenwidth} ={ fun => sub { return 1;} };
@command{screenheight} ={ fun => sub { return 1;} };
@command{"\@wall"} ={ fun => sub { return &cmd_wall(@_);} };
@command{"\@read"} ={ fun => sub { return &cmd_read(@_);} };
@command{"\@function"} ={ fun => sub { return &cmd_function(@_);} };
@command{"\@imc"} ={ fun => sub { return &cmd_imc(@_);} };
@command{"\@perl"} ={ fun => sub { return &cmd_perl(@_); } };
@command{say} ={ fun => sub { return &cmd_say(@_); } };
@command{"\""} ={ fun => sub { return &cmd_say(@_); }, nsp=>1 };
@command{"`"} ={ fun => sub { return &cmd_to(@_); }, nsp=>1 };
@command{"&"} ={ fun => sub { return &cmd_set2(@_); }, nsp=>1 };
@command{"\@reload"} ={ fun => sub { return &cmd_reload_code(@_); } };
@command{pose} ={ fun => sub { return &cmd_pose(@_); } };
@command{":"} ={ fun => sub { return &cmd_pose(@_); }, nsp=>1 };
@command{";"} ={ fun => sub { return &cmd_pose(@_,1); },nsp=>1};
@command{"emote"} ={ fun => sub { return &cmd_pose(@_,1); },nsp=>1};
@command{"\\"} ={ fun => sub { return &cmd_slash(@_,1);},nsp=>1};
@command{who} ={ fun => sub { return &cmd_who(@_); } };
@command{whisper} ={ fun => sub { return &cmd_whisper(@_); } };
@command{w} ={ fun => sub { return &cmd_whisper(@_); } };
@command{doing} ={ fun => sub { return &cmd_DOING(@_); } };
@command{"\@doing"} ={ fun => sub { return &cmd_doing(@_); } };
@command{"\@poll"} ={ fun => sub { return &cmd_doing(@_[0],@_[1],
@_[2],{ header=>1}); } };
@command{help} ={ fun => sub { return &cmd_help(@_); } };
@command{"\@dig"} ={ fun => sub { return &cmd_dig(@_); } };
@command{"\@idesc"} ={ fun => sub { return &cmd_generic_set(@_); } };
@command{"\@parent"} ={ fun => sub { return &cmd_parent(@_); } };
@command{"look"} ={ fun => sub { return &cmd_look(@_); } };
@command{"l"} ={ fun => sub { return &cmd_look(@_); } };
@command{quit} ={ fun => sub { return &cmd_quit(@_); } };
@command{"\@trigger"} ={ fun => sub { return &cmd_trigger(@_); } };
@command{"\@set"} ={ fun => sub { return &cmd_set(@_); } };
@command{"\@cls"} ={ fun => sub { return &cmd_clear(@_); } };
@command{"\@create"} ={ fun => sub { return &cmd_create(@_); } };
@command{"print"} ={ fun => sub { return &cmd_print(@_); } };
@command{"go"} ={ fun => sub { return &cmd_go(@_); } };
@command{"home"} ={ fun => sub { return &cmd_home(@_); } };
@command{"examine"} ={ fun => sub { return &cmd_ex(@_); } };
@command{"brief"} ={ fun => sub { return &cmd_ex($_[0],$_[1],
$_[2],{brief => 1});} };
@command{"\@edit"} ={ fun => sub { return &cmd_edit(@_); } };
@command{"ex"} ={ fun => sub { return &cmd_ex(@_); } };
@command{"e"} ={ fun => sub { return &cmd_ex(@_); } };
@command{"\@last"} ={ fun => sub { return &cmd_last(@_); } };
@command{page} ={ fun => sub { return &cmd_page(@_); } };
@command{p} ={ fun => sub { return &cmd_page(@_); } };
@command{take} ={ fun => sub { return &cmd_take(@_); } };
@command{get} ={ fun => sub { return &cmd_take(@_); } };
@command{drop} ={ fun => sub { return &cmd_drop(@_); } };
@command{"\@force"} ={ fun => sub { return &cmd_force(@_); } };
@command{inventory} ={ fun => sub { return &cmd_inventory(@_); } };
@command{i} ={ fun => sub { return &cmd_inventory(@_); } };
@command{enter} ={ fun => sub { return &cmd_enter(@_); } };
@command{leave} ={ fun => sub { return &cmd_leave(@_); } };
@command{"\@name"} ={ fun => sub { return &cmd_name(@_); } };
@command{"\@moniker"} ={ fun => sub { return &cmd_name(@_); } };
@command{"\@describe"} ={ fun => sub { return &cmd_generic_set(@_); } };
@command{"\@pemit"} ={ fun => sub { return &cmd_pemit(@_); } };
@command{"\@emit"} ={ fun => sub { return &cmd_emit(@_); } };
@command{"think"} ={ fun => sub { return &cmd_think(@_); } };
@command{"version"} ={ fun => sub { return &cmd_version(@_); } };
@command{"\@version"} ={ fun => sub { return &cmd_version(@_); } };
@command{"\@link"} ={ fun => sub { return &cmd_link(@_); } };
@command{"\@teleport"} ={ fun => sub { return &cmd_teleport(@_); } };
@command{"\@tel"} ={ fun => sub { return &cmd_teleport(@_); } };
@command{"\@open"} ={ fun => sub { return &cmd_open(@_); } };
@command{"\@uptime"} ={ fun => sub { return &cmd_uptime(@_); } };
@command{"\@destroy"} ={ fun => sub { return &cmd_destroy(@_); } };
@command{"\@cpattr"} ={ fun => sub { return &cmd_cpattr(@_); } };
@command{"\@wipe"} ={ fun => sub { return &cmd_wipe(@_); } };
@command{"\@toad"} ={ fun => sub { return &cmd_toad(@_); } };
@command{"\@sleep"} ={ fun => sub { return &cmd_sleep(@_); } };
@command{"\@wait"} ={ fun => sub { return &cmd_wait(@_); } };
@command{"\@sweep"} ={ fun => sub { return &cmd_sweep(@_); } };
@command{"\@list"} ={ fun => sub { return &cmd_list(@_); } };
@command{"\@mail"} ={ fun => sub { return &cmd_mail(@_); } };
@command{"score"} ={ fun => sub { return &cmd_score(@_); } };
@command{"\@telnet"} ={ fun => sub { return &cmd_telnet(@_); } };
@command{"\@close"} ={ fun => sub { return &cmd_close(@_); } };
@command{"\@reset"} ={ fun => sub { return &cmd_reset(@_); } };
@command{"\@send"} ={ fun => sub { return &cmd_send(@_); } };
@command{"\@password"} ={ fun => sub { return &cmd_password(@_); } };
@command{"\@newpassword"}={ fun => sub { return &cmd_newpassword(@_); } };
@command{"\@switch"} ={ fun => sub { return &cmd_switch(@_); } };
@command{"\@select"} ={ fun => sub { return &cmd_switch(@_); } };
@command{"\@ps"} ={ fun => sub { return &cmd_ps(@_); } };
@command{"\@kill"} ={ fun => sub { return &cmd_killpid(@_); } };
@command{"\@var"} ={ fun => sub { return &cmd_var(@_); } };
@command{"\@dolist"} ={ fun => sub { return &cmd_dolist(@_); } };
@command{"\@notify"} ={ fun => sub { return &cmd_notify(@_); } };
@command{"\@drain"} ={ fun => sub { return &cmd_drain(@_); } };
@command{"\@while"} ={ fun => sub { return &cmd_while(@_); } };
@command{"\@crash"} ={ fun => sub { return &cmd_crash(@_); } };
@command{"\@\@"} ={ fun => sub { return;} };
@command{"\@lock"} ={ fun => sub { return &cmd_lock(@_);} };
@command{"\@boot"} ={ fun => sub { return &cmd_boot(@_);} };
@command{"\@halt"} ={ fun => sub { return &cmd_halt(@_);} };
@command{"\@sex"} ={ fun => sub { return &cmd_generic_set(@_);} };
@command{"\@apay"} ={ fun => sub { return &cmd_generic_set(@_);} };
@command{"\@opay"} ={ fun => sub { return &cmd_generic_set(@_);} };
@command{"\@pay"} ={ fun => sub { return &cmd_generic_set(@_);} };
@command{"give"} ={ fun => sub { return &cmd_give(@_);} };
@command{"\@squish"} ={ fun => sub { return &cmd_squish(@_);} };
@command{"\@websocket"} ={ fun => sub { return &cmd_websocket(@_); } };
@command{"\@find"} ={ fun => sub { return &cmd_find(@_); } };
@command{"\@bad"} ={ fun => sub { return &cmd_bad(@_); } };
@command{"\@dump"} ={ fun => sub { return &cmd_dump(@_); } };
@command{"\@dirty_dump"} ={ fun => sub { return &cmd_dirty_dump(@_); } };
@command{"\@import"} ={ fun => sub { return &cmd_import(@_); } };
@command{"\@stats"} ={ fun => sub { return &cmd_stats(@_); } };
@command{"\@cost"} ={ fun => sub { return &cmd_generic_set(@_); } };
@command{"\@quota"} ={ fun => sub { return &cmd_quota(@_); } };
@command{"\@player"} ={ fun => sub { return &cmd_player(@_); } };
@command{"\@big"} ={ fun => sub { return &cmd_big(@_); } };
@command{"huh"} ={ fun => sub { return &cmd_huh(@_); } };
@command{"\@capture"} ={ fun => sub { return &cmd_capture(@_); } };
@command{"\@\@"} ={ fun => sub { return 1; } };
@command{"\@shutdown"} ={ fun => sub { return &cmd_shutdown(@_); } };
@command{"train"} ={ fun => sub { return &cmd_train(@_); } };
@command{"teach"} ={ fun => sub { return &cmd_train(@_); } };
@command{"\@restore"} ={ fun => sub { return &cmd_restore(@_); } };
@command{"\@ping"} ={ fun => sub { return &cmd_ping(@_); } };
@command{"\@ban"} ={ fun => sub { return &cmd_ban(@_); } };
@command{"\@missing"} ={ fun => sub { return &cmd_missing(@_); } };
@command{"\@motd"} ={ fun => sub { return &cmd_motd(@_); } };
@command{"\@chown"} ={ fun => sub { return &cmd_chown(@_); } };
@command{"\@nohelp"} ={ fun => sub { return &cmd_nohelp(@_); } };
@command{"\@debug"} ={ fun => sub { return &cmd_debug(@_); } };
@command{"\@free"} ={ fun => sub { return &cmd_free(@_); } };
# ------------------------------------------------------------------------#
# Generate Partial Commands #
# Instead of looping through all the commands every time, we'll just #
# populate the table with all possibilities. #
# ------------------------------------------------------------------------#
for my $key (sort {length($a) <=> length($b)} keys %command) {
for my $i (0 .. length($key)) {
if(!defined @{@command{$key}}{full}) {
@{@command{$key}}{full} = $key;
}
if(!defined @command{substr($key,0,$i)}) {
@command{substr($key,0,$i)} = @command{$key};
}
}
}
delete @command{q}; # no alias for QUIT
delete @command{qu};
delete @command{qui};
delete @command{va};
delete @command{var};
}
# ------------------------------------------------------------------------#
#
# get_mail_idx
# Build an index of attributes for email messages.
#
sub get_mail_idx
{
my $self = shift;
return sort { substr($a,9) <=> substr($b,9) } # build index
grep(/^obj_mail_/i,lattr($self));
}
sub get_mail
{
my ($self,$num) = @_;
return undef if($num !~ /^\s*(\d+)\s*$/ || $num <= 0); # invalid number
my @list = get_mail_idx($self);
return undef if(!defined @list[$num-1]); # invalid email number
my $attr = get($self,@list[$num-1]) ||
return undef;
if($attr =~ /^\s*(\d+)\s*,\s*(\d+)\s*,\s*(\d+)\s*,/) {
return { sent => $1,
from => $2,
new => $3,
msg => $',
attr => @list[$num-1],
num => trim($num)
};
} else {
return undef;
}
}
sub restore_process_line
{
my ($obj, $atr,$state,$list,$line) = @_;
$line =~ s/\r|\n//g;
$$state{chars} += length($_);
if($$state{obj} eq undef && $line =~ # header
/^server: ([^,]+), dbversion=([^,]+), exported=([^,]+), type=/) {
$$state{ver} = $2;
} elsif($line =~ /^\*\* Dump Completed (.*) \*\*$/) {
$$state{complete} = 1; # dump complete
} elsif($$state{obj} eq undef && $line =~ /^obj\[(\d+)]\s*{\s*$/) {
$$state{obj} = $1; # start of object
} elsif($$state{obj} ne undef &&
$line =~ /^\s*([^ \/:]+):(\d+):(\d+):([^:]*):M:/) {
if($$state{obj} eq $obj && $atr eq $1) {
if(!defined $$list{single_line(db_unsafe($'))}) {
$$list{single_line(db_unsafe($'))} = $3;
} elsif($$list{single_line(db_unsafe($'))} < $3) {
$$list{single_line(db_unsafe($'))} = $3;
}
}
} elsif($$state{obj} ne undef &&
$line =~ /^\s*([^ \/:]+):(\d+):(\d+):([^:]*):A:/) {
if($$state{obj} eq $obj && $atr eq $1) {
if(!defined $$list{single_line(db_unsafe($'))}) {
$$list{single_line(db_unsafe($'))} = $3;
} elsif($$list{single_line(db_unsafe($'))} < $3) {
$$list{single_line(db_unsafe($'))} = $3;
}
}
} elsif($$state{obj} ne undef &&
$line =~ /^\s*([^ \/:]+):(\d+):(\d+):([^:]*):L:/) {
# not restoring lists?
} elsif($$state{obj} ne undef &&
$line =~ /^\s*([^ \/:]+):(\d+):(\d+):([^:]*):H:/) {
# not restoring hash lists?
} elsif($$state{obj} ne undef && $line =~ /^\s*}\s*$/) { # end of object
delete @$state{obj};
delete @$state{type};
delete @$state{loc};
} else {
# con("Unable to parse[$$state{obj}]: '%s'\n",$line);
# printf("Unable to parse[$$state{obj}]: '%s'\n",$line);
# printf("%s\n",code("long"));
}
}
sub cmd_debug
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
if(defined $$prog{cmd} && $$prog{cmd}->{source} == 1) {
if(!managed_var_set($prog,"debug",1)) {
necho(self => $self,
prog => $prog,
source => [ managed_var_set_error() ]
);
}
necho(self => $self,
prog => $prog,
source => [ "\@debug running: '%s'\n",$txt ],
);
mushrun(self => $self, # run initial command
prog => $prog,
runas => $self,
source => 0,
cmd => $txt
);
} elsif(defined $$prog{var} &&
defined $$prog{var}->{debug} && $$prog{var}->{debug} == 1) {
mushrun(self => $self, # run only if debug is enabled
prog => $prog,
runas => $self,
source => 0,
child => 2,
cmd => $txt
);
}
}
sub cmd_chown
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my ($o,$t) = besplit($self,$prog,$txt,"=");
my $target;
if($t ne undef) {
$target = find_player($self,$prog,$t) ||
return err($self,$prog,"*Unknown player.");
} else {
$target = $self;
}
my $obj = find($self,$prog,$o) || # can't find object to chown
return err($self,$prog,"I don't see that here. '$o'");
if(hasflag($obj,"PLAYER")) {
return err($self,$prog,"Players can not be \@chowned.");
} elsif(quota($target,"left") <= 0) {
err($self,$prog,name($target) . " does not have enough quota to " .
"\@chown that object");
}
if(!or_flag($self,"WIZARD","GOD") && $t ne undef) {
return err($self,$prog,"Permission denied");
} elsif(!or_flag($self,"WIZARD","GOD")) {
if(hasflag($obj,"OBJECT") && $$target{obj_id} != loc($obj)) {
err($self,$prog,"You don't have that!");
} elsif(hasflag($obj,"EXIT") && loc($target) != loc($obj)) {
err($self,$prog,"You must be in the same as the exit to \@chown it.");
} elsif(hasflag($obj,"ROOM") && loc($target) != $obj) {
err($self,$prog,"You must be in the room to \@chown it.");
} elsif(!hasflag($obj,"CHOWN_OK")) {
err($self,$prog,"Permission denied: The object must be set CHOWN_OK");
}
}
set_quota($obj,"add",1);
db_set($obj,"obj_owner",$$target{obj_id});
set_flag($self,$prog,$obj,"HALTED");
necho(self => $self,
prog => $prog,
source => [ "Set." ]
);
}
sub cmd_motd
{
my ($self,$prog,$txt,$switch) = @_;
verify_switches($self,$prog,$switch,"list") ||
return;
!or_flag($self,"WIZARD","GOD") &&
return err($self,$prog,"Permission denied.");
if(defined $$switch{list}) {
necho(self => $self,
prog => $prog,
source => [ "MOTD: %s", conf("motd") ]
);
} else {
set($self,
$prog,
obj(0),
"conf.motd",
$txt
);
}
}
#
# cmd_missing
# Report on missing commands or functions
#
sub cmd_missing
{
my ($self,$prog,$txt,$switch) = @_;
$$prog{missing} = {}; # setup storage structure
$$prog{missing}->{fun} = {};
$$prog{missing}->{cmd} = {};
mushrun(self => $self, # run specified command
prog => $prog,
runas => $self,
source => 0,
cmd => $txt
);
}
#
# cmd_ban
# List or remove http ban entries.
#
sub cmd_ban
{
my ($self,$prog,$txt,$switch) = @_;
my (@out, $count);
verify_switches($self,$prog,$switch,"unban") ||
return;
!or_flag($self,"WIZARD","GOD") &&
return err($self,$prog,"Permission denied.");
manage_httpd_bans();
my $hash = @info{httpd_ban};
my $pat = glob2re(evaluate($self,$prog,$txt)) if($txt ne undef);
if(defined $$switch{unban}) { # delete entries
my $count = 0;
for my $key (keys %$hash) {
eval { # protect against bad patterns?
if($pat eq undef || $key =~ /$pat/) {
$count++;
delete @$hash{$key};
}
};
}
my $hash = @info{httpd_invalid_data};
for my $key (keys %$hash) {
eval { # protect against bad patterns?
if($pat eq undef || $key =~ /$pat/) {
$count++;
delete @$hash{$key};
}
};
}
necho(self => $self,
prog => $prog,
source => [ "%d entries removed.", $count ]
);
} else { # show reverse date sorted list
for my $key (sort {fuzzy($$hash{$b}) <=> fuzzy($$hash{$a})} keys %$hash) {
eval { # protect against bad patterns?
if($pat eq undef || $key =~ /$pat/) {
push(@out,sprintf("%-55s %s",$key,ts(fuzzy($$hash{$key}))));
}
};
}
if($#out == -1) { # show results
necho(self => $self,
prog => $prog,
source => [ "No sites matched." ]
);
} else {
necho(self => $self,
prog => $prog,
source => [ "%s", join("\n",@out) ]
);
}
}
}
#
# cmd_ping
# Internal command for finding out which object/attribute match the
# provided command.
#
sub cmd_ping
{
my ($self,$prog,$cmd) = @_;
my $tmp = $$prog{ping}; # save ping variable if already set?
$$prog{ping} = 1; # tell mush command is just a ping
my $fake = {
runas => $self,
created_by => $self,
cmd => $cmd,
};
spin_run($prog,$fake);
if($tmp eq undef) {
delete @$prog{tmp};
} else {
$$prog{ping} = $tmp;
}
}
sub fn_secs
{
my $fn = shift;
if($fn =~ /\.(\d{2})(\d{2})(\d{2})_(\d{2})(\d{2})(\d{2})\./){
return timelocal($6,$5,$4,$3,$2,$1);
}
}
sub cmd_restore
{
my ($self,$prog) = (obj(shift),shift);
my $cmd = $$prog{cmd};
my @list;
if(in_run_function($prog)) {
return out($prog,"#-1 \@DUMP can not be called from RUN function");
} elsif(!hasflag($self,"WIZARD") && !hasflag($self,"GOD")) {
return err($self,$prog,"Permission denied.");
}
if(!defined $$cmd{restore_list}) { # initialize "loop"
($$cmd{obj},$$cmd{atr}) = balanced_split(shift,"/",4);
if($$cmd{obj} ne undef && $$cmd{atr} eq undef) {
if($$cmd{obj} =~ /^\s*#(\d+)\s*/) {
$$cmd{obj} = $1;
} else {
return err($self,$prog,"usage: \@resTore <#dbref> '$$cmd{obj}'\n" .
" \@restore <object>/<attribute>");
}
if(valid_dbref($$cmd{obj})) {
return err($self,$prog,"\@restore only a \@destroyed object");
}
} elsif($$cmd{obj} ne undef && $$cmd{atr} ne undef) {
my $target = find($self,$prog,$$cmd{obj}) || # can't find target
return err($self,$prog,"No match on object.");
$$cmd{obj} = $$target{obj_id};
} elsif($$cmd{obj} eq undef && $$cmd{atr} eq undef) {
return err($self,$prog,"usage: \@restore <#dbref>\n" .
" \@restore <object>/<attribute>");
}
if(!defined $$cmd{restore_list}) { # initialize "loop"
my $dir;
$$cmd{restore_file} = [];
$$cmd{restore_list} = {};
opendir($dir,"@info{dumps}") ||
return err($self,$prog,"Could not open directory @info{dumps}.");
for my $file (readdir($dir)) {
if($file =~ /\.tdb$/) {
push(@{$$cmd{restore_file}},$file);
}
}
closedir($dir);
# sort list by filenames not stat();
my $list = $$cmd{restore_file};
$$cmd{restore_file} = [ sort {fn_secs($a) <=> fn_secs($b)} @$list ];
necho(self => $self,
prog => $prog,
source => [ "Restoring from %s db files in @info{dumps} folder...",
$#{$$cmd{restore_file}} ],
);
}
}
if($#{$$cmd{restore_file}} == -1) {
if($$cmd{atr} eq undef) { # object not found
necho(self => $self,
prog => $prog,
source => [ "Restore object #%s failed, not found.", $$cmd{obj}]
);
return "DONE";
}
my $list = $$cmd{restore_list};
my $count = 0;
delete @$list{single_line(get($$cmd{obj},$$cmd{atr}))};
for my $i (keys %$list) {
db_set($$cmd{obj},$$cmd{atr} . "_" . @$list{$i},$i); # copy attr back
$count++;
}
necho(self => $self,
prog => $prog,
source => [ "Restore done: %s versions restored to #%s/%s_*",
$count, $$cmd{obj},$$cmd{atr} ]
);
return "DONE";
} elsif(defined $$cmd{restore_fd}) {
my $fd = $$cmd{restore_fd};
my $count = 0;
# printf(" RESTORE: $fd\n");
# printf(" # %s\n",<$fd>);
while(<$fd>) {
if($$cmd{atr} ne undef) {
restore_process_line($$cmd{obj},
$$cmd{atr},
$$cmd{restore_state},
$$cmd{restore_list},
$_
);
} else {
db_process_line($$cmd{restore_state},
$_,
$$cmd{obj}
);
}
if(++$count > 500) { # 500 lines max at a time
return "RUNNING";
}
}
close($fd);
delete @$cmd{restore_fd}; # dump file is done
if($$cmd{atr} eq undef && valid_dbref($$cmd{obj})) {
necho(self => $self,
prog => $prog,
source => [ "\@restore of object #%s complete.", $$cmd{obj} ]
);
return "DONE";
}
return "RUNNING";
} else {
my $fd;
my $fn = "@info{dumps}/" . pop(@{$$cmd{restore_file}});
# printf("Restore: $fn\n");
open($fd,$fn); # get file to process
$$cmd{restore_fd} = $fd;
$$cmd{restore_state} = {};
return "RUNNING";
}
}
#
# cmd_train
# Command to echo the unevaluated command followed by the results
# for training purposes.
#
sub cmd_train
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
necho(self => $self,
prog => $prog,
room => [ $self, "%s types -=> %s", name($self),$txt ],
source => [ "%s types -=> %s",name($self),$txt ]
);
mushrun(self => $self,
prog => $prog,
runas => $self,
source => 0,
cmd => $txt
);
}
#
# cmd_home: move the player to their home
#
sub cmd_home
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if($txt !~ /^\s*$/) { # simulate non-command
return cmd_huh($self,$prog);
} else {
cmd_go($self,$prog,"home");
}
}
#
# cmd_wall
# Send a message to everyone or just the wizards
#
sub cmd_wall
{
my ($self,$prog) = (obj(shift),shift);
my ($msg,$hash);
hasflag($self,"GOD") || hasflag($self,"WIZARD") ||
return err("Permission denied.");
my $txt = evaluate($self,$prog,shift);
my $switch = shift;
verify_switches($self,$prog,$switch,"emit","pose","wizard","no_prefix") ||
return;
if($$switch{emit}) { # determine msg format
$msg = "Announcment: " . trim($txt);
} elsif($$switch{pose}) {
$msg = "Announcment: " . name($self) . " " . trim($txt);
} elsif($$switch{wizard}) {
$msg = "Broadcast: " . name($self) . " says, \"" . trim($txt) . "\"";
} elsif($$switch{no_prefix}) {
$msg = name($self) . " shouts, \"" . trim($txt) . "\"";
} else {
$msg = "Announcment: " . name($self) . " shouts, \"" . trim($txt) . "\"";
}
for my $key (keys %connected) {
$hash = @connected{$key};
next if $$hash{raw} != 0;
next if($$switch{wizard} && !hasflag($hash,"WIZARD"));
necho(self => $self,
prog => $prog,
target => [ $hash, "%s", $msg ],
always => 1
);
}
}
sub cmd_shutdown
{
my ($self,$prog) = (obj(shift),shift);
if(hasflag($self,"GOD") || hasflag($self,"WIZARD")) {
cmd_wall($self,$prog,$_[0]) if($_[0] !~ /^\s*/);
audit($self,$prog,"\@shutdown");
for my $key (keys %connected) {
my $hash = @connected{$key};
necho(self => $self,
prog => $prog,
target => [ $hash, "%s has been shutdown by %s.",
conf("mudname"),obj_name($self,$self,1) ]
);
cmd_boot($self,$prog,"#" . $$hash{obj_id});
}
@info{run} = 0; # signal shutdown
@info{shutdown_by} = obj_name($self,$self,1);
} else {
err($self,$prog,"Permission denied.");
}
}
sub cmd_slash
{
my ($self,$prog) = (obj(shift),shift);
my $txt = @{$$prog{cmd}}{cmd};
if($txt =~ /^\\\\/) {
cmd_emit($self,$prog,$');
} elsif($txt =~ /^\s\\$/) {
# no op, do nothing.
} elsif($txt =~ /^\\ /) {
cmd_emit($self,$prog,$txt);
}
}
sub cmd_parent
{
my ($self,$prog) = (obj(shift),shift);
my $parent;
my ($object,$par) = balanced_split(shift,"=",4);
my $target = find($self,$prog,$object) || # can't find target
return err($self,$prog,"No match on object.");
controls($self,$target) ||
return err($self,$prog,"Permission denied on target.");
if($par !~ /^\s*$/) { # set parent
$parent = find($self,$prog,$par) || # can't find parent
return err($self,$prog,"No match on parent.");
controls($self,$parent) ||
return err($self,$prog,"Permission denied on parent.");
}
if($parent eq undef) {
set($self,$prog,$target,"obj_parent",undef,1);
necho(self => $self,
prog => $prog,
source => [ "Unset." ]
);
} else {
set($self,$prog,$target,"obj_parent",$$parent{obj_id},1);
necho(self => $self,
prog => $prog,
source => [ "Set." ]
);
}
}
sub cmd_capture
{
my ($self,$prog) = (obj(shift),shift);
my ($attr,$command) = balanced_split(shift,"=",4);
$attr = evaluate($self,$prog,$attr);
$command = evaluate($self,$prog,$command);
if($attr eq undef || $command eq undef) {
return err($self,$prog,"Usage: \@capture [attribute] = [command]");
}
$$prog{capture} = { type => "pemit",
attr => trim($attr),
output => $$prog{output},
self => $self
};
necho(self => $self,
prog => $prog,
source => [ "Capture started (%s / %s)." , $attr,$command]
);
mushrun(self => $self,
prog => $prog,
runas => $self,
source => 0,
cmd => trim($command),
output => [],
);
}
sub cmd_search
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my (@out, $start,$max);
# if in run() search entire db, or 100 at a time
my $max = in_run_function($prog) ? $#db + 1 : 100;
my $cmd = $$prog{cmd};
if(!defined $$cmd{search_pos}) { # initialize "loop"
if($txt =~ /(type|flags|eval|object)\s*=\s*/i) {
$txt = $`;
$$cmd{search_type} = lc($1);
$$cmd{search_txt} = $';
if($$cmd{search_type} eq "type") {
if($$cmd{search_txt} =~ /^\s*(room|player|object|exit)\s*$/i) {
$$cmd{search_txt} = lc($1);
} else {
return err($self,$prog,"$$cmd{search_txt}: unknown type");
}
}
}
if($txt =~ /^\s*$/) { # default to current user
$$cmd{search_target} = $self;
} else { # use provided user
$$cmd{search_target} = find_player($self,$prog,$txt) ||
return err($self,$prog,"Unknown player.");
}
$$cmd{search_pos} = 0;
$$cmd{out} = [];
$$prog{iter_stack} = [] if !defined $$prog{iter_stack};
$$cmd{search_loc} = $#{$$prog{iter_stack}} + 1;
}
for($start=$$cmd{search_pos}; # loop for $max objects
$$cmd{search_pos} < $#db &&
$$cmd{search_pos} - $start < $max;
$$cmd{search_pos}++) {
if(valid_dbref($$cmd{search_pos})) { # does object match?
if(owner_id($$cmd{search_pos}) == @{$$cmd{search_target}}{obj_id}) {
my $add = 1;
if($$cmd{search_type} eq "flags") {
for my $letter (split(//,$$cmd{search_txt})) {
$add = 0 if(!hasflag($$cmd{search_pos},$letter));
}
} elsif($$cmd{search_type} eq "type") {
$add = 0 if(!hasflag($$cmd{search_pos},$$cmd{search_txt}));
} elsif($$cmd{search_type} eq "object") {
if(lc(substr(name($$cmd{search_pos}),0,
length($$cmd{search_txt}))) ne lc($$cmd{search_txt})) {
$add = 0;
}
} elsif($$cmd{search_type} eq "eval") {
my $array = $$prog{iter_stack};
$$array[$$cmd{search_loc}] =
{val => "#$$cmd{search_pos}", pos => 1 };
if(evaluate($self,$prog,$$cmd{search_txt}) == 0) {
$add = 0;
}
delete @$array[$$cmd{search_loc} .. $#$array];
}
if($add) {
if(defined $$prog{nomushrun}) {
push(@{$$cmd{out}},"#$$cmd{search_pos}");
} else {
push(@{$$cmd{out}},obj_name($self,$$cmd{search_pos}));
}
}
}
}
}
if($$cmd{search_pos} >= $#db) { # search is done
delete @$cmd{search_pos};
if($#{$$cmd{out}} == -1) {
necho(self => $self,
prog => $prog,
source => [ "Nothing found." ]
);
} else {
necho(self => $self,
prog => $prog,
source => [ join(($$prog{nomushrun}) ? " " : "\n",@{$$cmd{out}})]
);
}
} else {
return "RUNNING"; # more to do
}
}
sub cmd_big
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
my (@out, $start);
if(defined $$prog{nomushrun}) {
return err($self,$prog,"This command is not run() safe.");
}
my $cmd = $$prog{cmd};
if(!defined $$cmd{big_pos}) { # initialize "loop"
$$cmd{big_pos} = 0;
$$cmd{hash} = {};
}
my $hash = $$cmd{hash};
for($start=$$cmd{big_pos}; # loop for 100 objects
$$cmd{big_pos} < $#db &&
$$cmd{big_pos} - $start < 100;
$$cmd{big_pos}++) {
if(valid_dbref($$cmd{big_pos})) { # does object match?
if($txt eq "player") {
$$hash{name(owner($$cmd{big_pos}))} += length(db_object($$cmd{big_pos}));
} else {
$$hash{length(db_object($$cmd{big_pos}))} = $$cmd{big_pos};
}
}
}
if($$cmd{big_pos} >= $#db) { # search is done
delete @$cmd{big_pos};
my @out;
if($txt eq "player") {
for my $i (sort {$$hash{$b} <=> $$hash{$a}} keys %$hash) {
push(@out,"$i is $$hash{$i} bytes.");
last if $#out > 10;
}
} else {
for my $i (sort {$b <=> $a} keys %$hash) {
push(@out,"#" . $$hash{$i} . " is " . $i . " bytes.");
last if $#out > 10;
}
}
necho(self => $self,
prog => $prog,
source => [ join("\n",@out) ]
);
delete @$cmd{big_pos};
} else {
return "RUNNING"; # more to do
}
}
sub list_user_functions
{
my $out;
if(!defined @info{mush_function} || ref(@info{mush_function}) ne "HASH") {
return "No user functions defined.";
}
$out = sprintf("%-28s %-10s %s\n","Function Name","Dbref","Attribute");
$out .= sprintf("%s %s %s\n","-" x 28,"-" x 10,"-" x 30);
for my $key (keys %{@info{mush_function}}) {
if(@info{mush_function}->{$key} =~ /\//) {
$out .= sprintf("%-28s %-10s %s\n",
$key,
$`,
$'
)
}
}
$out .= sprintf("%s %s %s\n","-" x 28,"-" x 10,"-" x 30);
}
sub cmd_function
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
hasflag($self,"WIZARD") ||
return err($self,$prog,"Permission denied.");
verify_switches($self,$prog,$switch,"list") || return;
if(defined $$switch{list} || $txt =~ /^\s*$/) {
necho(self => $self, # notify user
prog => $prog,
source => [ list_user_functions() ]
);
return;
}
my ($name,$atr) = besplit($self,$prog,shift,"=");
if($name =~ /^\s*([a-z])([a-z0-9_]*)\s*$/) {
$name = "$1$2";
} else {
return err($self,$prog,"Invalid user defined function name '$name'");
}
my $data = fun_get($self,$prog,trim($atr));
if($atr eq undef) {
return err($self,$prog,"Invalid object/attribute specified.");
}
@info{mush_function} = {} if(!defined @info{mush_function});
@{@info{mush_function}}{$name} = trim($atr);
necho(self => $self, # notify user
prog => $prog,
source => [ "Set." ]
);
}
sub cmd_quota
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
my ($player,$value) = balanced_split($txt,"=",4);
$player = "me" if ($player eq undef);
my $target = find_player($self,$prog,evaluate($self,$prog,$player)) ||
return err($self,$prog,"Unknown player.");
if(!controls($self,$target)) {
return err($self,$prog,"Permission denied.");
}
if($value ne undef) {
if(!hasflag($self,"WIZARD")) {
return err($self,$prog,"Permission denied.");
} elsif($value =~ /^\s*(\d+)\s*$/) {
set_quota($target,"max",$1);
} else {
return err($self,$prog,"Invalid number ($value).");
}
}
necho(self => $self, # notify user
prog => $prog,
source => [ "%s Quota: %9s Used: %9s",
obj_name($target),
quota($target,"max"),
quota($target,"used"),
]
);
}
#
# cmd_wipe
# Erase all the attribute on an object.
#
sub cmd_wipe
{
my ($self,$prog,$txt) = (obj(shift),shift);
my $count = 0;
my ($obj,$pattern) = meval($self,$prog,balanced_split(shift,"/",4));
my $target = find($self,$prog,$obj) || # can't find target
return err($self,$prog,"No match.");
if(!controls($self,$target)) { # check permissions
return err($self,$prog,"Permission denied.");
} elsif(hasflag($target,"GOD") && !hasflag($self,"GOD")) {
return err($self,$prog,"Permission denied.");
}
my $pat = glob2re($pattern) if($pattern ne undef); # convert pattern to
# regular expression
for my $attr (grep {!/^obj_/} lattr($target)) { # search object
if($pat eq undef || $attr =~ /$pat/i) { # wipe specified attrs
set($self,$prog,$target,$attr,undef,1);
$count++;
}
}
necho(self => $self, # notify user
prog => $prog,
source => [ "Wiped - %d attribute%s.",$count,($count != 1) ? "s" : ""]
);
}
#
# cmd_generic_set
# Lots of mush commands just set attributes. In TinyMUSH these each might
# be handled differently, but they're all just attributes in TeenyMUSH.
#
sub cmd_generic_set
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my $cmd = $$prog{cmd}; # the command isn't passed in, so get it.
if(lc($$cmd{mushcmd}) eq "\@desc" ||
lc($$cmd{mushcmd}) eq "\@describe") {
$$cmd{mushcmd} = "\@description";
} elsif(defined @command{$$cmd{mushcmd}} &&
defined @{@command{$$cmd{mushcmd}}}{full}) {
$$cmd{mushcmd} = @{@command{$$cmd{mushcmd}}}{full};
}
cmd_set2($self,$prog,substr($$cmd{mushcmd},1) . " " . $txt,$switch);
}
sub gather_stats
{
my ($type,$txt,$target) = (shift,lc(trim(shift)),shift);
my $owner;
my $hash = {
PLAYER => 0,
OBJECT => 0,
EXIT => 0,
ROOM => 0,
GARBAGE => 0
};
$txt eq "all" if($txt eq undef); # default to all
if($target ne undef) {
$owner = owner_id($target);
}
if($type == 2) {
$$hash{OBJECT} = $#db + 1;
} else {
for my $i (0 .. $#db) {
if(!valid_dbref($i)) {
$$hash{GARBAGE}++;
} elsif($txt eq "all" || owner($i) == $owner) {
if(hasflag($i,"PLAYER")) {
$$hash{PLAYER}++;
} elsif(hasflag($i,"OBJECT")) {
$$hash{OBJECT}++;
} elsif(hasflag($i,"EXIT")) {
printf("HERE 3\n") if($i == 1);
$$hash{EXIT}++;
} elsif(hasflag($i,"ROOM")) {
$$hash{ROOM}++;
}
}
}
}
return $hash;
}
sub cmd_stats
{
my ($self,$prog,$txt,$switch) = (obj(shift),obj(shift),shift,shift);
my ($hash, $target);
verify_switches($self,$prog,$switch,"all","quiet") || return;
$txt = evaluate($self,$prog,$txt);
if(defined $$switch{all}) {
$hash = gather_stats(1,"all");
} elsif($txt =~ /^\s*$/) {
$hash = gather_stats(2);
return necho(self => $self,
prog => $prog,
source => [ "The universe contains %d objects.",
$$hash{OBJECT} ]
);
} else {
$target = find_player($self,$prog,$txt) ||
return err($self,$prog,"Unknown player.");
$hash = gather_stats(1,"",$target);
}
necho(self => $self,
prog => $prog,
source => [ "%s objects = %s rooms, %s exits, %s things, %s " .
"players. (%s garbage)",
$$hash{ROOM} + $$hash{EXIT} + $$hash{OBJECT} +
$$hash{PLAYER} + $$hash{GARBAGE},
$$hash{ROOM},
$$hash{EXIT},
$$hash{OBJECT},
$$hash{PLAYER},
$$hash{GARBAGE} ]
);
}
sub cmd_import
{
my ($self,$prog,$txt) = (obj(shift),obj(shift),shift);
if(!hasflag($self,"GOD")) {
return err($self,$prog,"Permission denied.");
} else {
db_read_import($self,$prog,$txt);
}
}
#
# cmd_mail
# Command for sending internal email.
#
sub cmd_mail
{
my ($self,$prog) = (obj(shift),obj(shift));
my ($txt,$value) = balanced_split(shift,"=",4);
$txt = evaluate($self,$prog,$txt);
my $switch = shift;
if(defined $$switch{delete}) { # handle delete
return err($self,$prog,"Invalid email message.") if ($value ne undef);
my $mail = get_mail($self,$txt);
return err($self,$prog,"Invalid email message.") if ($mail eq undef);
set($self,$prog,$self,$$mail{attr},undef,1);
necho(self => $self,
prog => $prog,
source => [ "MAIL: Deleted." ]
);
} elsif($value ne undef) { # handle mail send
$value = evaluate($self,$prog,$value) if(@{$$prog{cmd}}{source} == 0);
my $target = find_player($self,$prog,$txt) ||
return err($self,$prog,"Unknown player.");
my @list = (get_mail_idx($target)); # get next seq number
my $seq = ($#list == -1) ? 1 : (substr(@list[$#list],9)+1);
set($self,$prog,$target,"OBJ_MAIL_$seq", # save email message
time() .",". owner_id($self) . ",1," . trim($value),1);
necho(self => $self,
prog => $prog,
source => [ "MAIL: You have sent mail to %s.", name($target) ],
target => [ $target, "MAIL: You have a new message from %s.",
name(owner($self))]
);
} elsif($txt =~ /^\s*short\s*$/) {
my @list = get_mail_idx($self);
necho(self => $self,
prog => $prog,
source => [ "MAIL: You have %s messages.", $#list + 1 ]
);
} elsif($txt =~ /^\s*(\d+)\s*$/) { # display 1 email
my $mail = get_mail($self,$1) ||
return err($self,$prog,"Invalid email message.");
necho(self => $self, # show results
prog => $prog,
source => [ "%s\nFrom: %-37s At: %s\n%s\n%s\n%s\n",
("-" x 75),
name($$mail{from}),
scalar localtime($$mail{sent}),
("-" x 75),
trim($$mail{msg}),
("-" x 75)
]
);
set($self,$prog,$self,$$mail{attr}, # set read flag
"$$mail{sent},$$mail{from},0,$$mail{msg}",1);
} else { # show detailed mail list
my $out;
my @list = get_mail_idx($self);
for my $pos (0 .. $#list) {
my $mail = get_mail($self,$pos+1);
my ($sec,$min,$hr,$day,$mon,$yr) = localtime($$mail{sent});
my $name = ansi_substr(name($$mail{from}),0,15);
$out .= sprintf("%3s|%4s | %02d:%02d %02d:%02d/%02d | %s%s " .
"| %s\n",
$pos+1,
$$mail{new} ? "Yes" : "",
$hr,$min,$mon+1,$day,$yr%100,$name,
(" " x (15 - ansi_length($name))),
(ansi_length($$mail{msg}) > 29) ?
(ansi_substr($$mail{msg},0,26) . "...") :
$$mail{msg}
);
}
$out .= " * No email *\n" if $out eq undef;
necho(self => $self,
prog => $prog,
source => [ " # | New | Sent | Sender |" .
" Message\n" .
"---|-----|----------------|" . ("-"x17) ."|" .
("-" x30)."\n" .
$out .
"---|-----|----------------|" . ("-"x17) ."|" .
("-" x30) . "\n"
]
);
}
}
#
# cmd_while
# Loop while the expression is true
#
sub cmd_while
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
my (%last,$first);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
in_run_function($prog) &&
return out($prog,"#-1 \@WHILE can not be called from RUN function");
my $cmd = $$prog{cmd};
if(!defined $$cmd{while_test}) { # initialize "loop"
$first = 1;
if($txt =~ /^\s*\(\s*(.*?)\s*\)\s*{\s*(.*?)\s*}\s*$/s) {
($$cmd{while_test},$$cmd{while_count}) = ($1,0);
$$cmd{while_cmd} = $2;
} else {
return err($self,$prog,"usage: while (<expression>) { commands }");
}
}
$$cmd{while_count}++;
if($$cmd{while_count} >= 5000) {
con(" %s loop exeeded max of 5000, \@while aborting.\n",ts());
con(" cmd: %s by %s\n",$$prog{invoking_command},
obj_name($$prog{created_by}));
return err($self,$prog,"while exceeded maxium loop of 5000, stopped");
} elsif(test($self,$prog,$$cmd{while_test})) {
mushrun(self => $self,
prog => $prog,
source => 0,
cmd => $$cmd{while_cmd},
child => 1
);
return "RUNNING";
}
return "DONE";
}
#
# cmd_imc
# interanal mush command - Execute a command without a password or
# a messy temp file.
#
sub cmd_imc
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
my (%last,$first);
hasflag($self,"GOD") ||
return err($self,$prog,"Permission denied.");
in_run_function($prog) &&
return err($self,$prog,"#-1 \@WHILE can not be called from RUN function");
my $cmd = $$prog{cmd};
if(!defined @info{imc} || ref(@info{imc}) ne "HASH") {
return err($self,$prog,"imc command not recieved via HTTPD");
} elsif(!defined $$cmd{imc_start}) { # initialize "loop"
delete @info{sigusr1};
$$cmd{imc_start} = time();
} elsif(defined $$cmd{imc_running}) { # finished?
delete @info{imc};
delete @info{imc_running};
delete @info{sigusr1};
return "DONE";
} elsif(time() - $$cmd{imc_start} > 10) {
delete @info{imc};
return err($self,$prog,"SIGUSR1 signal not recieved within 10 seconds");
}
my $hash = @info{imc};
if(defined @info{sigusr1} && # wait for permission to start
time() - @info{sigusr1} < 10 &&
time() - $$hash{timestamp} < 10) {
$$prog{from} = "ATTR"; # a lie, but it gets us where we want.
mushrun(self => $self,
prog => $prog,
source => 0,
cmd => @{@info{imc}}{command},
child => 1
);
$$cmd{imc_running} = time();
}
$$prog{idle} = 1;
return "RUNNING";
}
#
# inlist
# Find out if a given pattern matches any item of the provided list;
#
sub inlist
{
my ($item,@list) = @_;
my $result = 0;
for my $i (@list) {
eval { # protect against bad regexps
my $pat = glob2re($i);
$result = 1 if(trim($item) =~ /$pat/i);
};
return $result if($result == 1);
}
return 0;
}
sub member
{
my ($loc,$id,@list) = @_;
for my $i (@list) {
return 1 if($id eq $$i{obj_id});
}
return 0;
}
sub bad_object
{
my $obj = shift;
if(ref($obj) ne "HASH") {
$obj = { obj_id => $obj };
}
if(!valid_dbref($obj,1)) {
return 3;
# } elsif(name($obj) eq undef) {
# return 1;
} elsif(flag_list($obj,1) eq undef) {
return 2;
} else {
return 0;
}
}
sub cmd_bad
{
my ($self,$prog) = (obj(shift),shift);
my (@out, $start);
if(defined $$prog{nomushrun}) {
return err($self,$prog,"This command is not run() safe.");
}
my $cmd = $$prog{cmd};
$$cmd{bad_pos} = 0 if(!defined $$cmd{bad_pos}); # initialize "loop"
$$cmd{quota} = {} if(!defined $$cmd{quota});
my $quota = $$cmd{quota};
for($start=$$cmd{bad_pos}; # loop for 100 objects
$$cmd{bad_pos} < $#db &&
$$cmd{bad_pos} - $start < 100;
$$cmd{bad_pos}++) {
# printf("Processing: $$cmd{bad_pos}\n");
if(valid_dbref($$cmd{bad_pos})) { # does object match?
if(owner($$cmd{bad_pos}) eq undef) {
push(@out,"#" . $$cmd{bad_pos} . " has no owner");
}
if(!hasflag($$cmd{bad_pos},"PLAYER")) {
$$quota{owner_id($$cmd{bad_pos})}++;
}
if(bad_object($$cmd{bad_pos})) {
push(@out,"#" . $$cmd{bad_pos} . " is corrupted, deleting.");
db_delete($$cmd{bad_pos});
} else {
if(!hasflag($$cmd{bad_pos},"PLAYER") &&
!hasflag($$cmd{bad_pos},"OBJECT") &&
!hasflag($$cmd{bad_pos},"EXIT") &&
!hasflag($$cmd{bad_pos},"ROOM")) {
push(@out,"#" . $$cmd{bad_pos} ." No TYPE flag, set to -> '".
type($self,$prog,$$cmd{bad_pos}) . "'");
}
# arbitrarly choose exit over object due to previous bug.
if(and_flag($$cmd{bad_pos},"EXIT","OBJECT")) {
db_remove_list($$cmd{bad_pos},"obj_flag","OBJECT");
}
my $count += hasflag($$cmd{bad_pos},"PLAYER");
$count += hasflag($$cmd{bad_pos},"OBJECT");
$count += hasflag($$cmd{bad_pos},"EXIT");
$count += hasflag($$cmd{bad_pos},"ROOM");
if($count != 1) {
push(@out,obj_name($$cmd{bad_pos}) ." has $count types.");
}
if(hasflag($$cmd{bad_pos},"EXIT") &&
hasflag(loc($$cmd{bad_pos}),"EXIT")) {
my $loc = loc($$cmd{bad_pos});
push(@out,
"#" . obj_name($self,$$cmd{bad_pos}) .
" not in a room, is in " .
(($loc eq undef) ? "N/A" : obj_name($self,$loc))
);
}
if(hasflag($$cmd{bad_pos},"PLAYER") &&
money($$cmd{bad_pos}) eq undef) {
push(@out,"#" . $$cmd{bad_pos} ." no money");
db_set($$cmd{bad_pos},"obj_money",conf("starting_money"));
}
if(hasflag($$cmd{bad_pos},"ROOM")) {
my $loc = get($$cmd{bad_pos},"obj_location");
if($loc ne undef) {
push(@out, "Room #$$cmd{bad_pos} has a location[$loc], removed.");
db_set($$cmd{bad_pos},"obj_location");
if(valid_dbref($loc)) {
db_remove_list($loc,"obj_content",$$cmd{bad_pos});
}
}
}
for my $obj (lcon($$cmd{bad_pos})) {
if(!valid_dbref($obj)) {
push(@out,"#" . $$cmd{bad_pos} . " removed from contents " .
"#" . $$obj{obj_id} . "[destroyed object]");
db_remove_list($$cmd{bad_pos},"obj_content",$$obj{obj_id});
} elsif(!hasflag($obj,"PLAYER") && !hasflag($obj,"OBJECT")) {
push(@out,
"#$$obj{obj_id} is not an object in #$$cmd{bad_pos}");
} elsif(loc($obj) != $$cmd{bad_pos}) {
my $l = loc($obj);
if($l ne undef) {
printf("Remove: $$obj{obj_id} from $$cmd{bad_pos}\n");
printf(" Add: %s to %s\n",$$obj{obj_id},$l);
db_remove_list($$cmd{bad_pos},"obj_content",$$obj{obj_id});
db_set_list($l,"obj_content",$$obj{obj_id});
} else {
push(@out,sprintf("#$$obj{obj_id}'s home is %s and " .
"not %s\n",home($obj),$$cmd{bad_pos}));
}
}
}
for my $obj (lexits($$cmd{bad_pos})) {
if(!valid_dbref($obj)) {
con("Removing \@destroyed obj #%s from exit list of #%s\n",
$$obj{obj_id},$$cmd{bad_pos});
db_remove_list($$cmd{bad_pos},"obj_exits",$$obj{obj_id});
} elsif(!hasflag($obj,"EXIT")) {
push(@out,"#$$obj{obj_id} is not an exit [$$cmd{bad_pos}]. ");
}
}
if(!hasflag($$cmd{bad_pos},"ROOM")) {
my $loc = loc($$cmd{bad_pos});
if($loc eq undef) {
push(@out,"#" . $$cmd{bad_pos} ." No location, sent home(#".
home($$cmd{bad_pos}) . ").");
teleport($self,$prog,$$cmd{bad_pos},home($$cmd{bad_pos}));
} elsif(hasflag($$cmd{bad_pos},"EXIT")) {
if(!member($loc,$$cmd{bad_pos},lexits($loc))) {
push(@out,"#" . $$cmd{bad_pos} ." not in lexit() of " .
"$loc");
}
} elsif(!member($loc,$$cmd{bad_pos},lcon($loc))) {
if(valid_dbref($loc) && !bad_object($loc)) {
push(@out,"#" . $$cmd{bad_pos} ." not in lcon() of $loc," .
"teleporting to $loc.");
teleport($self,$prog,$$cmd{bad_pos},$loc);
} else {
push(@out,"#" . $$cmd{bad_pos} ." No location, sent " .
"home(#" . home($$cmd{bad_pos}) . ").");
teleport($self,$prog,$$cmd{bad_pos},home($$cmd{bad_pos}));
}
}
}
}
}
}
if($#out > -1) {
necho(self => $self,
prog => $prog,
source => [ join("\n",@out) ]
);
}
if($$cmd{bad_pos} >= $#db) { # search is done
delete @$cmd{bad_pos};
my $hash = $$cmd{quota};
for(my $obj=0;$obj < $#db;$obj++) {
if(valid_dbref($obj) && hasflag($obj,"PLAYER")) {
if(quota($obj,"used") != $$hash{$obj}) {
push(@out,"#" . obj_name($obj) .
"'s used quota updated to " . $$hash{$obj} .
" from " . quota($obj,"left"));
set_quota($obj,"used",$$hash{$obj});
}
}
}
necho(self => $self,
prog => $prog,
source => [ join("\n",@out) . "\n**End of List***" ]
);
delete @$cmd{bad_pos};
} else {
return "RUNNING"; # more to do
}
}
#
# cmd_find
# Search the entire database for objects. When using a memory database,
# search in 100 object segments.
#
sub cmd_find
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
my ($start,@out);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
if(defined $$prog{nomushrun}) {
out($prog,"#-1 \@find can not be used in the run() function");
return;
}
my $cmd = $$prog{cmd};
if(!defined $$cmd{find_pos}) { # initialize "loop"
$$cmd{find_pos} = 0;
$$cmd{find_pat} = glob2re("*$txt*");
$$cmd{find_owner} = owner_id($self);
}
for($start=$$cmd{find_pos}; # loop for 100 objects
$$cmd{find_pos} < $#db &&
$$cmd{find_pos} - $start < 100;
$$cmd{find_pos}++) {
if(valid_dbref($$cmd{find_pos}) && # does object match?
controls($$cmd{find_owner},$$cmd{find_pos}) &&
name($$cmd{find_pos},1) =~ /$$cmd{find_pat}/i) {
push(@out,obj_name($self,$$cmd{find_pos}));
}
}
if($$cmd{find_pos} >= $#db) { # search is done
push(@out,"***End of List***");
necho(self => $self,
prog => $prog,
source => [ join("\n",@out) ]
);
delete $$cmd{find_pos}; # clean up
delete $$cmd{find_pat};
delete $$cmd{find_owner};
} else {
if($#out > -1) {
necho(self => $self,
prog => $prog,
source => [ join("\n",@out) ]
);
}
return "RUNNING"; # more to do
}
}
sub cmd_perl
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if(hasflag($self,"GOD")) {
audit($self,$prog,"\@perl");
eval ( $txt );
necho(self => $self,
prog => $prog,
source => [ "Done." ],
);
} else {
necho(self => $self,
prog => $prog,
source => [ "Permission Denied." ],
);
}
}
#
# websocket
# Instruct the client to sent a command to the server.
#
sub cmd_websocket
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if(hasflag(owner($self),"WIZARD")) {
websock_wall($txt);
} else {
necho(self => $self,
prog => $prog,
source => [ "Permission Denied." ],
);
}
}
#
# cmd_score
# Tell the player how much money it has.
#
sub cmd_score
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if($txt =~ /^\s*$/) {
necho(self => $self,
prog => $prog,
source => [ "You have %s.", money($self,1) ],
);
} else {
necho(self => $self,
prog => $prog,
source => [ "Score expects no arguments." ],
);
}
}
#
# give
# Give someone else penies and optionally handle @cost/@pay.
#
sub cmd_give
{
my ($self,$prog) = (obj(shift),obj(shift));
my ($apay, $cost);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
my ($obj,$amount) = meval($self,$prog,balanced_split(shift,"=",4));
my $target = find($self,$prog,$obj) ||
return err($self,$prog,"Give to whom?");
hasflag(owner($target),"GUEST") &&
return err($self,$prog,"Guests don't need that.");
hasflag(owner($target),"EXIT") &&
return err($self,$prog,"Exits don't need that.");
hasflag(owner($target),"ROOM") &&
return err($self,$prog,"Rooms don't need that.");
if($$self{obj_id} == $$target{obj_id} && !hasflag($self,"WIZARD")) {
return err($self,$prog,"You may not give yourself money.");
} elsif($amount !~ /^\s*\-{0,1}(\d+)\s*$/) {
return err($self,$prog,"That is not a valid amount.");
} elsif($amount <= 0 && !hasflag($self,"WIZARD")) {
return err($self,$prog,"You look through your pockets. Nope, no " .
pennies("negative") . ".");
} elsif($amount > money($self) && !hasflag($self,"WIZARD")) {
return err($self,$prog,"You don't have %s to give!");
}
if(($apay = get($target,"APAY")) ne undef && # handle @pay/@apay
($cost = get($target,"COST")) ne undef) {
if($cost !~ /^\s*(\d+)\s*$/) {
return err($self,$prog,"Invalid \@cost set on object.");
}
if($amount > $cost) { # paid too much
necho(self => $self,
prog => $prog,
source => [ "You get %s %s in change.",
trim($amount) - $cost, ($amount - $cost == 1) ?
conf("money_name_singular") :
conf("money_name_plural") ]
);
} elsif($amount < $cost) { # not enough
return err($self,$prog,"Feeling poor today?");
}
mushrun(self => $self, # run code
prog => $prog,
runas => $target,
invoker=> $self,
source => 0,
cmd => $apay,
);
$amount = $cost;
}
give_money($self,"-$amount");
give_money($target,"$amount");
necho(self => $self,
prog => $prog,
source => [ "You give %s %s to %s.",
trim($amount),
($amount== 1) ? conf("money_name_singular") :
conf("money_name_plural"),
name($target) ],
target => [ $target, "%s gives you %s %s.",
name($self),
trim($amount),
($amount == 1) ? conf("money_name_singular") :
conf("money_name_plural") ]
);
}
#
# mini_trigger
# Used after the command envoked by capture has finished to run the
# code which should be outputing the results.
#
sub mini_trigger
{
# my ($self,$prog,$a,$data) = @_;
my $prog = shift; # setup some shortcuts
my $self = $$prog{user};
my $hash = $$prog{capture};
my $out = $$prog{output};
delete @$prog{capture};
my $data;
@{$$prog{cmd}}{done} = 1;
# get output to send
if(defined $$prog{output} && $#{$$prog{output}} >= 0) {
$data = join("\n",@{$$prog{output}});
} else {
$data = "No data returned";
}
delete @$prog{output}; # clean up.
my $cmd = pget($$hash{self},trim($$hash{attr}));
if($cmd eq undef) {
delete @$prog{capture};
return err($self,$prog,"No such attribute");
}
# if @capture was called from inside session already recording output,
# it needs to be "restored" byt passing in the output into the mushrun().
if(defined @$hash{output} && ref($$hash{output}) eq "ARRAY") {
# $$prog{output} = $$hash{output};
mushrun(self => $self,
runas => $$hash{self},
prog => $prog,
source => 0,
cmd => $cmd,
wild => [ $data ],
invoker=> $self,
output => []
);
} else {
mushrun(self => $self,
runas => $$hash{self},
prog => $prog,
source => 0,
cmd => $cmd,
wild => [ $data ],
invoker=> $self,
);
}
}
sub cmd_trigger
{
my ($self,$prog) = (obj(shift),obj(shift));
my (@wild,$last,$target,$name);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
# find where the "=" is without evaluating things.
my ($txt,$params) = balanced_split(shift,"=",4);
my $switch = shift;
# where the / is without evaluating things
($target,$name) = balanced_split($txt,"\/",4);
# okay to evaluate object / attribute
$target = find($self,$prog,evaluate($self,$prog,$target));
$name = trim(evaluate($self,$prog,$name));
return err($self,$prog,"No match.") if($target eq undef);
my $attr = pget($target,$name,1) ||
return err($self,$prog,"No such attribute.");
# printf("ATTR: '%s'\n",$$attr{value});
if(!defined $$attr{glob} && !controls($self,$target)) {
return err($self,$prog,"PermiSsion denied");
}
# for my $i (balanced_split($params,',',2)) { # split param list
# if($$switch{noeval} && $last eq undef) {
# printf("Add[1]: $i\n");
# $last = $i;
# } elsif($$switch{noeval}) {
# printf("Add[2]: $i\n");
# push(@wild,$i);
# } elsif($last eq undef) {
# $last = evaluate($self,$prog,$i);
# printf("Add[3]: %s\n",$last);
# } else {
# printf("Add[4]: %s\n",evaluate($self,$prog,$i));
# push(@wild,evaluate($self,$prog,$i));
# }
# }
# push(@wild,$last) if($last ne undef);
for my $i (balanced_split($params,',')) {
if($$switch{noeval}) {
push(@wild,$i);
} else {
# printf("trig_Add: '%s' -> '%s'\n",$i,evaluate($self,$prog,$i));
push(@wild,evaluate($self,$prog,$i));
}
}
if($#wild >= 0) { # first item is remainder, it should be last item
push(@wild,shift(@wild));
}
# printf("SELF: '$$self{obj_id}'\n");
# printf("CMD: '%s'\n",$$attr{value});
# printf("RUNAS: '%s'\n",$$target{obj_id});
# printf("WILD: '%s'\n",join(',',@wild));
# printf("PROG: '%s'\n",$$prog{pid});
# printf("%s\n",print_var($prog));
mushrun(self => $self,
prog => $prog,
runas => $target,
source => 0,
cmd => $$attr{value},
child => 2,
wild => [ @wild ],
invoker=> (defined $$prog{created_by}) ? $$prog{created_by} : $self,
);
}
#
# cmd_huh
# Unknown command has been issued. Handle the echoing of VERBOSE
# here for the unknown command.
#
sub cmd_huh
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
$$prog{huh} = 1;
if(defined $$prog{hint} &&
($$prog{hint} eq "WEB" || $$prog{hint} eq "WEBSOCKET")) {
if(!(defined $$prog{from} && $$prog{from} eq "ATTR")) {
$$prog{huh} = 1;
}
}
# printf("%s\n",code("long"));
if(hasflag($self,"VERBOSE")) {
necho(self => owner($self),
prog => $prog,
target => [ owner($self),
"%s] %s",
name($self),
trim((($txt eq undef) ? "" : " " . $txt))
]
);
}
# record missing command for @missing
if(defined $$prog{missing} && ref($$prog{missing}) eq "HASH") {
$$prog{missing}->{cmd}->{fun_extract($self,$prog,$txt,1,1)}++;
}
if(lord(@{$$prog{cmd}}{cmd}) ne 0) {
# printf("HuH: '%s' -> '%s'\n",$$self{obj_id},@{$$prog{cmd}}{cmd});
necho(self => $self,
prog => $prog,
source => [ "Huh? (Type \"HELP\" for help.)" ]
);
}
}
sub cmd_offline_huh
{
my $sock = $$user{sock};
my $obj = obj(0); # show login in readonly mode
my $prog = prog($obj,$obj,$obj);
$$prog{read_only} = 1;
if(@{@connected{$sock}}{type} eq "WEBSOCKET") {
ws_echo($sock,add_return(evaluate($obj,$prog,conf("login"))));
} else {
printf($sock "%s",add_return(evaluate($obj,$prog,conf("login"))));
}
}
sub cmd_version
{
my ($self,$prog) = (obj(shift),shift);
my $src = "https://github.com/c-hudson/teenymush";
my $ver = (conf("version") =~ /^TeenyMUSH ([\d\.]+)$/i) ? $1 : "N/A";
$src = "<a href=$src>$src</a>" if($$prog{hint} eq "WEB");
necho(self => $self,
prog => $prog,
source => [ "TeenyMUSH : Version %s [cmdhudson\@gmail.com]\n".
" Source : %s",
$ver,$src
]
);
}
sub cmd_crash
{
my ($self,$prog) = (obj(shift),shift);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
necho(self => $self,
prog => $prog,
source => [ "You \@crash the server, yee haw.\n%s",code("long") ],
room => [ $self, "%s \@crashes the server.", name($self) ],
);
my $foo;
@{$$foo{crash}};
}
sub cmd_reset
{
my ($self,$prog) = (obj(shift),shift);
if(!hasflag($self,"WIZARD")) {
return err($self,$prog,"Permission Denied.");
} else {
delete @info{io};
necho(self => $self,
prog => $prog,
source => [ "All telnet connections reset." ]
);
}
}
# my $eval = lock_eval($self,$prog,$self,$txt);
sub cmd_lock
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
if($txt =~ /^\s*([^ ]+)\s*=\s*/) {
my $target = find($self,$prog,$1); # find target
if($target eq undef) { # found invalid object
return err($self,$prog,"I don't see that here.");
} elsif(!controls($self,$target)) { # can modify object?
return err($self,$prog,"Permission denied.");
} else { # set the lock
my $lock = lock_compile($self,$prog,$self,$');
if($$lock{error}) { # did lock compile?
necho(self => $self,
prog => $prog,
source => [ "I don't understand that key, $$lock{errormsg}" ]
);
} else {
set($self,$prog,$target,"OBJ_LOCK_DEFAULT",$$lock{lock},1);
necho(self => $self,
prog => $prog,
source => [ "Set." ]
);
}
}
} else {
necho(self => $self,
prog => $prog,
source => [ "usage: \@lock <object> = <key>" ],
);
}
}
#
# BEGIN statement with including code, and most of socket_connect were
# copied from from: http://aspn.activestate.com/ASPN/Mail/Message/
# perl-win32-porters/1449297.
#
BEGIN {
# This nonsense is needed in 5.6.1 and earlier -- I'm too lazy to
# test if it's been fixed in 5.8.0.
if( $^O eq 'MSWin32' ) {
*EWOULDBLOCK = sub () { 10035 };
*EINPROGRESS = sub () { 10036 };
*IO::Socket::blocking = sub {
my ($self, $blocking) = @_;
my $nonblocking = $blocking ? "0" : "1";
ioctl($self, 0x8004667e, $nonblocking);
};
} else {
require Errno;
import Errno qw(EWOULDBLOCK EINPROGRESS);
}
}
#
# set_var
# Set a variable. Since this is controlled by the MUSH and is used
# to control the flow of the program, do not use managed_var_set to
# prevent using to much memory.
#
sub set_var
{
my ($prog,$var,$value) = @_;
$$prog{var} = {} if(!defined $$prog{var});
@{$$prog{var}}{$var} = $value;
return 0;
}
sub cmd_var
{
my ($self,$prog,$var,$rest);
my $value;
if($#_ == 2) { # current behavior
($self,$prog,$var,$rest) = (obj(shift),shift,trim(shift),shift);
} else { # emulate previous behavior
($self,$prog,$var) = (obj(shift),shift,shift); # @var <var> = <value>
if($var =~ /(=|\+=|-=|\*=|\/=|\+\+|\-\-)\s*/) {
($var,$rest) = (trim($`),$1 . $');
}
}
$var = evaluate($self,$prog,$var);
show_verbose($prog,$$prog{cmd}); # doesn't hit verbose code, so run it
$$prog{var} = {} if !defined $$prog{var};
if($var =~ /^\s*\d+/) {
necho(self => $self,
prog => $prog,
source => [ "Variables may not start with numbers\n" ],
);
} elsif($rest =~ /^\s*\+\+\s*$/) { # increment
$value = @{$$prog{var}}{$var} + 1;
} elsif($rest =~ /^\s*\-\-\s*$/) { # decrement
$value = @{$$prog{var}}{$var} - 1;
} elsif($rest =~ /^\s*\+=\s*/) { # add
$value = @{$$prog{var}}{$var} + evaluate($self,$prog,$');
} elsif($rest =~ /^\s*-=\s*/) { # sub
$value = @{$$prog{var}}{$var} - evaluate($self,$prog,$');
} elsif($rest =~ /^\s*\*=\s*/) { # mult
$value = @{$$prog{var}}{$var} *= evaluate($self,$prog,$');
} elsif($rest =~ /^\s*\/=\s*/) { # divide
my $num = evaluate($self,$prog,$');
if($num == 0) {
return err($self,$prog,"Divide by Zero not allowed.");
} else {
$value = @{$$prog{var}}{$var} / $num;
}
} elsif($rest =~ /^\s*\.=\s*/) { # append
if(@{$$prog{cmd}}{source} == 0) {
$value = @{$$prog{var}}{$var} . evaluate($self,$prog,$');
} else {
$value = $';
}
} elsif($rest =~ /^\s*=\s*/) { # set
if(trim($') eq undef) { # no value, delete
# do nothing
} elsif(@{$$prog{cmd}}{source} == 0) { # from prog, evaluate
$value = evaluate($self,$prog,$');
} else { # from person, do not evaluate
$value = $';
}
} else {
return err($self,$prog,"Invalid command.");
}
if(!managed_var_set($prog,$var,$value)) {
necho(self => $self,
prog => $prog,
source => [ managed_var_set_error() ]
);
}
}
sub cmd_boot
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my ($boot,$target) = (0,undef);
if(hasflag($self,"GUEST")) {
return err($self,$prog,"Permission denied.");
}
my $god = hasflag($self,"GOD");
$txt =~ s/^\s+|\s+$//g;
if(defined $$switch{port}) {
if($txt !~ /^\d+$/) {
return err($self,$prog,"Ports numbers must be numeric.");
}
} else {
$target = find_player($self,$prog,$txt) ||
return necho(self => $self,
prog => $prog,
source => [ "I don't see that here." ]
);
}
for my $key (keys %connected) {
my $hash = @connected{$key};
if(!$god && hasflag(@connected{$key},"GOD") ||
!controls($self,@connected{$key})) {
# god can not be booted by non-god.
# must control the object to boot it
} elsif((defined $$switch{port} && $$hash{port} == $txt) ||
(!defined $$switch{port} && name($hash) eq name($target))) {
if(defined $$switch{port}) {
necho(self => $self,
target => $hash,
prog => $prog,
source => [ "You \@booted port %s off!", $$hash{port} ],
);
audit($self,$prog,"Port $$hash{port} \@booted");
} else {
necho(self => $self,
target => $hash,
prog => $prog,
target => [ $hash, "%s has \@booted you.", name($self)],
source => [ "You \@booted %s off!", obj_name($self,$hash)],
room => [ $hash, "%s has been \@booted.",name($hash) ],
);
audit($self,$prog,"%s \@booted",obj_name($target,$target));
}
my $sock=$$hash{sock};
server_disconnect($sock);
$boot++;
}
}
if($boot == 0) {
if($$switch{port} && $boot == 0) {
necho(self => $self,
prog => $prog,
source => [ "Unknown port specified." ],
);
} else {
necho(self => $self,
prog => $prog,
source => [ "Unknown connected person specified." ],
);
}
}
}
sub cmd_killpid
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if(!hasflag($self,"WIZARD")) {
return err($self,$prog,"Permission Denied.");
} elsif($txt =~ /^\s*(\d+)\s*$/) {
if(!defined @engine{$1}) {
necho(self => $self, # target's room
prog => $prog,
source => [ "PID '%s' does not exist.", $1 ],
);
} elsif(hasflag(@engine{$1}->{created_by},"GOD") &&
!hasflag($self,"GOD")) {
necho(self => $self, # target's room
prog => $prog,
source => [ "Permission denied, pid $1 owned by a GOD." ],
);
} elsif(!controls($self,@engine{$1}->{created_by})) {
necho(self => $self, # target's room
prog => $prog,
source => [ "Permission denied, you do not control pid $1." ],
);
} else {
delete @engine{$1};
necho(self => $self,
prog => $prog,
source => [ "PID '%s' has been killed", $1 ],
);
}
} else {
necho(self => $self, # target's room
prog => $prog,
source => [ "Usage: \@kill <pid>", $1 ],
);
}
}
sub cmd_ps
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my (@out, $var, %max);
verify_switches($self,$prog,$switch,"var") || return;
# determine max column sizes
@max{pid} = 3;
@max{owner} = 5;
@max{obj} = 3;
for my $pid (keys %engine) {
my $p = @engine{$pid};
if(defined $$p{stack} && ref($$p{stack}) eq "ARRAY" &&
controls($self,$$p{created_by}) &&
(!hasflag($$p{created_by},"GOD") || hasflag($self,"GOD"))) {
@max{pid} = length($pid) if (length($pid) > @max{pid});
for my $i (0 .. $#{$$p{stack}}) {
my $obj = @{@{@{$$p{stack}}[0]}{runas}}{obj_id};
my $size = ansi_length(obj_name($self,$$p{created_by},1));
$size = length($$p{created_by}) + 1 if($size > 20);
@max{owner} = $size if $size > @max{owner};
@max{obj} = length($obj) + 1 if (length($obj)+1 > @max{obj});
}
}
}
@max{cmd} = 68 - (@max{pid} + @max{owner} + @max{obj});
# show header
push(@out,sprintf("%-*s | %-*s | %-*s | %s",
@max{pid},"Pid",
@max{owner},"Owner",
@max{obj},"Obj",
"Command"));
push(@out,sprintf("%s=|=%s=|=%s=|=%s",
"=" x @max{pid},
"=" x @max{owner},
"=" x @max{obj},
"=" x @max{cmd}),
);
for my $pid (sort {$a <=> $b} keys %engine) { # show detail
my $p = @engine{$pid};
$$p{command} = 0 if !defined $$prog{command};
$$p{function} = 0 if !defined $$p{function};
$var = undef;
if(defined $$p{stack} && ref($$p{stack}) eq "ARRAY" &&
controls($self,$$p{created_by}) &&
(!hasflag($$p{created_by},"GOD") || hasflag($self,"GOD"))) {
# can only see processes they control
# non-gods can not see god processes
for my $i (0 .. $#{$$p{stack}}) {
my $cmd = @{$$p{stack}}[$i];
my ($max,$name,$sleep);
# get owner details but shorten if bigger then > 20
my $obj = @{@{@{$$p{stack}}[0]}{runas}}{obj_id};
my $size = ansi_length(obj_name($self,$$p{created_by},1));
if($size > 20) {
$name = "#" . $$p{created_by};
$max = @max{owner};
} else {
$name = obj_name($self,$$p{created_by},1);
$max = (@max{owner} - $size) +
length(obj_name($self,$$p{created_by},1));
}
# fill in command details + sleep
my $c = single_line($$cmd{cmd});
if(defined $$cmd{sleep}) { # show sleeping data
$sleep = "[" . ($$cmd{sleep} - time()) . "s left]";
}
if(length($c . $sleep) > @max{cmd}) { # shorten command
$c = substr($c,0,@max{cmd} - length($sleep));
}
if($sleep ne undef) { # put sleep at end of line
$sleep=(" " x (@max{cmd}-length($c)-length($sleep))) . $sleep;
}
push(@out,sprintf("%*s | %*s | %*s | %s",
@max{pid},
($i == 0) ? $pid : "",
($i == 0) ? $max : @max{owner},
($i == 0) ? $name : "",
@max{obj},
"#" . $obj,
$c . $sleep
)
);
}
}
}
necho(self => $self, # target's room
prog => $prog,
source => [ "%s", join("\n",@out) ]
);
}
#
# cmd_halt
# Delete all processes owned by the object running the @halt command.
#
sub cmd_halt
{
my ($self,$prog) = (obj(shift),shift);
my $obj = owner($self);
my $count = 0;
my ($ldbref,$lpid);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
my $lookfor = ansi_remove(evaluate($self,$prog,shift));
my $iswiz = hasflag($self,"WIZARD");
if($lookfor =~ /^\s*#(\d+)\s*$/) {
$ldbref = $1;
} elsif($lookfor =~ /^\s*(\d+)\s*$/) {
$lpid = $1;
} elsif($lookfor ne undef) {
return err($self,$prog,"Invalid PID or dbref '%s' specified.");
}
for my $pid (keys %engine) { # look at each pid
my $program = @engine{$pid};
my $cmd = @{$$program{stack}}[0];
# kill only your stuff but not the halt command
if($$prog{pid} != $pid &&
($$obj{obj_id} == @{$$program{created_by}}{obj_id} || $iswiz) &&
($lookfor eq undef || $lpid eq $pid ||
$ldbref eq $cmd->{runas}->{obj_id})) {
necho(self => $self,
prog => $prog,
source => [ "Pid %s stopped : %s%s" ,
$pid,
substr(single_line($$cmd{cmd}),0,40),
(length(single_line($$cmd{cmd})) > 40) ? "..." : ""
]
);
close_telnet($program);
delete @engine{$pid};
$count++;
}
}
necho(self => $self,
prog => $prog,
source => [ "%s queue entries removed." , $count]
);
}
#
# tval
# return an evaluated string suitable for test to use
#
sub tval
{
my ($self,$prog,$txt) = @_;
return lc(trim(evaluate($self,$prog,$txt)));
}
sub test
{
my ($self,$prog,$txt) = @_;
if($txt =~ / <= /) {
return (tval($self,$prog,$`) <= tval($self,$prog,$')) ? 1 : 0;
} elsif($txt =~ / == /) {
return (tval($self,$prog,$`) == tval($self,$prog,$')) ? 1 : 0;
} elsif($txt =~ / >= /) {
return (tval($self,$prog,$`) >= tval($self,$prog,$')) ? 1 : 0;
} elsif($txt =~ / > /) {
return (tval($self,$prog,$`) > tval($self,$prog,$')) ? 1 : 0;
} elsif($txt =~ / < /) {
return (tval($self,$prog,$`) < tval($self,$prog,$')) ? 1 : 0;
} elsif($txt =~ / eq /) {
return (tval($self,$prog,$`) eq tval($self,$prog,$')) ? 1 : 0;
} elsif($txt =~ / ne /) {
return (tval($self,$prog,$`) ne tval($self,$prog,$')) ? 1 : 0;
} else {
return evaluate($self,$prog,$txt) ? 1 : 0;
}
}
#
# find_free_dbrefs
# Populate @free with recycled database objects without pausing the
# mush.
#
sub cmd_free
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my $start;
my $cmd = $$prog{cmd};
if(!defined $$cmd{free_pos}) {
delete @free[0 .. $#free];
$$cmd{free_pos} = 1;
necho(self => $self,
prog => $prog,
source => [ "\@free dbref sweep started." ],
) if $self ne undef;
}
for($start=$$cmd{free_pos}; # loop for 100 objects
$$cmd{free_pos} < $#db &&
$$cmd{free_pos} - $start < 100;
$$cmd{free_pos}++) {
push(@free,$$cmd{free_pos}) if(!valid_dbref($$cmd{free_pos}));
}
if($$cmd{bad_pos} >= $#db) { # search is done
necho(self => $self,
prog => $prog,
source => [ "\@free dbree sweep completed." ],
) if $self ne undef;
delete @$cmd{bad_pos};
} else {
return "RUNNING";
}
}
#
# find_free_dbref
# Search the entire db for free dbrefs. Use @free if you don't want
# to pause the mush.
#
sub find_free_dbref
{
my $self;
my $prog = {};
$$prog{cmd} = {};
while(cmd_free($self,$prog) eq "RUNNING") {
# cmd_free does all the work.
}
}
sub cmd_player
{
my ($self,$prog,$type) = (obj(shift),shift,shift);
delete @player{keys %player};
for(my $i=0;$i <= $#db;$i++) {
if(valid_dbref($i) && hasflag($i,"PLAYER")) {
@player{lc(name($i,1))} = $i;
}
}
}
#
# cmd_dump
# Dump the database to a file in segments so that the mush doesn't
# need to "pause" while writing out the database. Why hang the mush
# for no reason? This also does not fork() off a second copy of the
# database to background the database like standard MUSHes do.
#
sub cmd_dump
{
my ($self,$prog,$type) = (obj(shift),shift,shift);
my ($file,$start);
@info{"conf.mudname"} = "TeenyMUSH" if(conf("mudname") eq undef);
if(in_run_function($prog)) {
return out($prog,"#-1 \@DUMP can not be called from RUN function");
} elsif(!hasflag($self,"WIZARD") && !hasflag($self,"GOD")) {
return err($self,$prog,"Permission denied.");
}
return if $#db == -1; # nothing to dump;
con("**** Program EXITING ******\n") if($type eq "CRASH");
$type = "normal" if($type eq undef);
#-----------------------------------------------------------------------#
# initialize loop #
#-----------------------------------------------------------------------#
my $cmd = $$prog{cmd};
if(!defined $$cmd{dump_pos}) { # initialize "loop"
@info{dirty} = {}; # clear dirty bits
if(defined @info{backup_mode} && is_running(@info{backup_mode})) {
return err($self,$prog,"Backup is already running.");
}
$$cmd{dump_pos} = 0;
if(@info{shell}) { # rewrite script
my $src = getfile($0); # read sourse into memory
open($file,"> $0") ||
return err($self,$prog,"Unable to open $0 for writing");
for my $line (split(/\n/,$src)) { # copy over source
$line =~ s/\r//g;
if($line eq "__END__") { # stop at db
printf($file "%s\n",$line);
last;
} else {
printf($file "%s\n",$line);
}
}
} else {
my ($sec,$min,$hour,$day,$mon,$yr,$wday,$yday,$isdst) =
localtime(time);
$mon++;
$yr -= 100;
#
my $fn = sprintf("@info{dumps}/%s.%02d%02d%02d_%02d%02d%02d",
conf("mudname"),$yr,$mon,$day,$hour,$min,$sec);
open($file,"> $fn.tdb") ||
return err($self,$prog,"Unable to open $fn for writing");
@info{dump_name} = $fn;
printf($file "server: %s, version=%s, change#=0, exported=%s, " .
"type=%s\n", conf("version"),db_version(),scalar localtime(),
$type);
}
@info{change} = 0;
$$cmd{dump_file} = $file;
@info{backup_mode} = $$prog{pid};
if($type ne "CRASH" && $user ne undef) {
echo_flag($user,
prog($user,$user),
"CONNECTED,PLAYER,LOG",
"<LOG> Database backup started.",name($user)
);
}
} else {
$file = $$cmd{dump_file};
}
my $start = $$cmd{dump_pos};
#-----------------------------------------------------------------------#
# write out the database in 50 object segments #
#-----------------------------------------------------------------------#
while($$cmd{dump_pos} <= $#db &&
($$cmd{dump_pos} - $start <= 50 || $type eq "CRASH" || @info{run} ==0)) {
if(valid_dbref($$cmd{dump_pos})) {
printf($file "%s", db_object($$cmd{dump_pos}));
}
$$cmd{dump_pos}++;
}
#-----------------------------------------------------------------------#
# handle dump clean up or notify still running #
#-----------------------------------------------------------------------#
if($$cmd{dump_pos} > $#db) { # dump done
if(defined @$cmd{dump_file}) { # should not happen?
printf($file "** Dump Completed %s **\n", scalar localtime());
close($file);
delete @$cmd{dump_file};
}
# sync changes back into the database
for(my $i=0;$i <= $#delta;$i++) {
if(defined @delta[$i] && ref(@delta[$i]) eq "HASH") {
@db[$i] = @delta[$i];
}
}
delete @delta[0 .. $#delta]; # empty the delta
delete @info{backup_mode}; # turn off backup mode
if($type ne "CRASH") {
echo_flag($user,
prog($user,$user),
"CONNECTED,PLAYER,LOG",
"<LOG> Database finished."
);
necho(self => $self,
prog => $prog,
source => [ "\@dump completed." ],
) if !@info{shell};
}
con("**** Dump Complete: Exiting ******\n") if($type eq "CRASH");
$$prog{command} = 1; # delete cost of running command
# so it doesn't show in console
# as expensive command
return;
} else {
return "RUNNING"; # still running
}
}
sub do_full_dump
{
my $obj = obj(1);
my $prog= prog($obj,$obj,$obj);
while(cmd_dump($obj,$prog,"",{}) eq "RUNNING") {
# everything happens in cmd_dump
}
}
sub do_full_dirty_dump
{
my $obj = obj(1);
my $prog= prog($obj,$obj,$obj);
while(cmd_dirty_dump($obj,$prog,"",{}) eq "RUNNING") {
# everything happens in cmd_dump
}
}
sub cmd_dirty_dump
{
my ($self,$prog,$txt,$switch) = @_;
$self = $$self{obj_id} if ref($self) eq "HASH";
my ($file,$out);
my $count = 0;
my $dirty = @info{dirty};
if(ref($dirty) ne "HASH" ||
(ref($dirty) eq "HASH" && scalar keys %$dirty == 0)) {
return; # nothing to dump
}
if(defined @info{backup_mode} && is_running(@info{backup_mode})) {
return err($self,$prog,"Backup is already running.");
}
my $cmd = $$prog{cmd};
if(!defined $$cmd{dirty_list}) { # initialize "loop"
@info{change} = 0 if !defined @info{change};
$$cmd{dirty_list} = [ %{@info{dirty}} ];
@info{dump_name} = $' if(@info{dump_name} =~ /^dumps\//i);
if(@info{shell}) {
open($file,">> $0") ||
return err($self,$prog,"Unable to open $0 for writing.");
} else {
open($file,">> @info{dumps}/@info{dump_name}.tdb") ||
return err($self,$prog,"Unable to open @info{dumps}/" .
"@info{dump_name}.tdb for writing");
}
$$cmd{dirty_file} = $file;
printf($file "server: %s, version=%s, change#=%s, exported=%s, " .
"type=archive_log\n",conf("version"),db_version(),@info{change}++,
scalar localtime());
}
my $dirty = @info{dirty};
my $list = $$cmd{dirty_list};
while($#$list >= 0 && $count++ < 51) { # do 50 objects a cycle
my $dbref = pop(@$list);
my $dobj = $$dirty{$dbref};
my $obj = dbref($dbref);
if(!valid_dbref($dbref)) {
$out .= "$dbref,delobj";
} else {
# mark as previously deleted.
printf($file "%s,delobj\n",$dbref) if(defined $$dobj{destroyed});
# cycle all attributes that are dirty
for my $key (sort keys %$dobj) {
if($key =~ /^A_/ && !defined $$obj{$'}) {
printf($file "%s,delatr,%s\n",$dbref,$');
} elsif($key =~ /^A_/) {
my $attr = $$obj{$'};
my $name = $';
$$attr{created} = time() if !defined $$attr{created};
$$attr{modified} = time() if !defined $$attr{modified};
if(reserved($name) && defined $$attr{value} &&
$$attr{type} eq "list") {
printf($file "%s,setatr,%s:%s:%s::L:%s\n",
$dbref,$name,$$attr{created},$$attr{modified},
join(',',keys %{$$attr{value}}));
} elsif(defined $$attr{value} && $$attr{type} eq "hash") {
printf($file "%s,setatr,%s:%s:%s::H:%s\n",
$dbref,$name,$$attr{created},$$attr{modified},
hash_serialize($$attr{value},$name,$dbref));
} else {
printf($file "%s,setatr,%s\n",$dbref,
serialize($name,$attr));
}
}
}
}
delete @$dirty{$dbref};
}
if($#$list== -1) {
printf($file "** Dump Completed %s **\n", scalar localtime());
close($file);
delete $$cmd{dirty_list};
delete $$cmd{dirty_file};
} else {
return "RUNNING";
}
}
#
# show_stack
# print out the stack to the console for a program
#
sub show_stack
{
my ($prog,$txt) = @_;
if($txt ne undef) {
con("---[ start ]---- [%s]\n",$txt);
} else {
con("---[ start ]----\n",$txt);
}
for my $i (0 .. $#{$$prog{stack}}) {
my $cmd = @{$$prog{stack}}[$i];
con(" %3s[%s] : %s\n",
$i,
defined $$cmd{done} ? 1 : 0,
substr(single_line($$cmd{cmd}),0,40)
);
}
con("---[ end ]----\n");
}
sub out
{
my ($prog,$fmt,@args) = @_;
if(defined $$prog{output}) {
my $stack = $$prog{output};
push(@$stack,sprintf($fmt,@args));
}
return undef;
}
sub cmd_notify
{
my ($self,$prog,$txt,$switch)=(obj(shift),shift,shift,shift);
verify_switches($self,$prog,$switch,"first","all","quiet") || return;
if(defined $$switch{all} && defined $$switch{first}) {
return err($self,$prog,"Illegal combination of switches.");
}
#
# semaphores will be triggered by setting their wait_time to 0, which
# will cause them to be run on the next run through of the spin() loop.
# We could execute the commands right now but this seems elegantly simple.
#
my $stack = $$prog{stack};
my $current = $$prog{cmd};
for my $i (0 .. $#$stack) {
if($current eq $$stack[$i]) {
last; # don't run commands in the future
} elsif(defined @{$$stack[$i]}{wait_semaphore}) {
@{$$stack[$i]}{wait_time} = 0;
last if(defined $$switch{first}); # notify 1, jump out of loop
}
}
if(!defined $$switch{quiet}) {
necho(self => $self,
prog => $prog,
source => [ "Notified." ],
);
}
}
sub cmd_drain
{
my ($self,$prog,$txt,$switch)=(obj(shift),shift,shift,shift);
verify_switches($self,$prog,$switch,"quiet") || return;
#
# The command that contains the semaphore will be just erased and
# marked as done. The spin() function will delete the command as soon
# as it sees it next.
#
my $stack = $$prog{stack};
my $current = $$prog{cmd};
for my $i (0 .. $#$stack) {
if($current eq $$stack[$i]) {
return; # don't run commands in the future
} elsif(defined @{$$stack[$i]}{wait_semaphore}) {
my $hash = $$stack[$i];
delete @$hash{keys %$hash};
$$hash{done} = 1;
}
}
if(!defined $$switch{quiet}) {
necho(self => $self,
prog => $prog,
source => [ "Notified." ],
);
}
}
#
# cmd_dolist
# Loop though a list running specified commands.
#
sub cmd_dolist
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my $cmd = $$prog{cmd};
my ($delim, %last, $count);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
in_run_function($prog) &&
return out($prog,"#-1 \@DOLIST can not be called from RUN function");
verify_switches($self,$prog,$switch,"delimit","notify") || return;
if(defined $$switch{delimit}) { # handle delimiter
if($txt =~ /^\s*([^ ]+)\s*/) {
$txt = $'; # first word of list is delimiter
$delim = evaluate($self,$prog,$1);
} else {
return err($self,$prog,"Could not determine delimiter");
}
} else {
$delim = " ";
}
if(!defined $$cmd{dolist_list}) { # initialize dolist
my ($first,$second) = balanced_split($txt,"=",4);
# printf("FIRST: '%s'\n",$first);
# printf("SECOND: '%s'\n",$second);
$$cmd{dolist_cmd} = $second;
my $txt = evaluate($self,$prog,$first);
# printf("TXT: '%s'\n",$txt);
$$cmd{dolist_list} = [safe_split($txt,$delim)];
$$cmd{dolist_count} = 0;
$$prog{iter_stack} = [] if(!defined $$prog{iter_stack});
$$cmd{dolist_loc} = $#{$$prog{iter_stack}} + 1;
} elsif($#{$$cmd{dolist_list}} == -1) {
if(defined $$switch{notify}) {
mushrun(self => $self,
prog => $prog,
runas => $self,
source => 0,
cmd => "\@notify/first/quiet",
child => 2,
);
}
if(defined $$prog{iter_stack}) {
my $array = $$prog{iter_stack};
delete @$array[$$cmd{dolist_loc} .. $#$array];
}
}
$$cmd{dolist_count}++;
if($$cmd{dolist_count} > 500) { # force users to be nice
return err($self,$prog,"dolist execeeded maxium count of 500, stopping");
} elsif($#{$$cmd{dolist_list}} < 0) {
return; # already done
}
my $item = trim(shift(@{$$cmd{dolist_list}}));
# printf("ITEM: '%s'\n",$item);
if($item !~ /^\s*$/) {
# $item = fun_escape($self,$prog,$item);
my $cmds = $$cmd{dolist_cmd};
# $cmds =~ s/\#\#/$item/g;
@{$$prog{iter_stack}}[$$cmd{dolist_loc}]={val => $item, pos=>++$count};
delete $$prog{attr} if defined $$prog{attr};
if(defined $$prog{cmd} && @{$$prog{cmd}}{source} == 1) {
my $new = prog($self,$self,$self);
$$new{iter_stack} = [];
@{$$new{iter_stack}}[0]={val => $item, pos=> 0 };
mushrun(self => $self, # player typed in command,
runas => $self, # new environment for each command
prog => $new,
source => 0,
cmd => $cmds,
child => 1,
invoker=> $self,
);
} else {
mushrun(self => $self,
prog => $prog,
runas => $self,
source => 0,
cmd => $cmds,
child => 1,
);
}
}
return "RUNNING";
}
#
# good_password
# enforce password pollicy
#
sub good_password
{
my $txt = shift;
if($txt !~ /^\s*.{8,999}\s*$/) {
return "#-1 Passwords must be 8 characters or more";
} elsif($txt !~ /[0-9]/) {
return "#-1 Passwords must one digit [0-9]";
} elsif($txt !~ /[A-Z]/) {
"#-1 Passwords must contain at least one upper case character";
} elsif($txt !~ /[a-z]/) {
return "#-1 Passwords must contain at least one lower case character";
} else {
return undef;
}
}
sub cmd_password
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if(hasflag($self,"GUEST")) {
return err($self,$prog,"Permission Denied.");
} elsif(!hasflag($self,"PLAYER")) {
necho(self => $self,
prog => $prog,
source => [ "Non-players do not need passwords." ],
);
} elsif($txt =~ /^\s*([^ ]+)\s*=\s*([^ ]+)\s*$/) {
my $result = good_password($2);
if($result ne undef) {
return necho(self => $self,
prog => $prog,
source => [ "%s", $result ],
);
}
if(mushhash($1) ne get($self,"obj_password")) {
necho(self => $self,
prog => $prog,
source => [ "Invalid old password." ],
);
} else {
db_set($self,"obj_password",mushhash($2));
necho(self => $self,
prog => $prog,
source => [ "Password changed." ],
);
}
} else {
necho(self => $self,
prog => $prog,
source => [ "usage: \@password <old_password> = <new_password>" ],
);
}
}
sub cmd_wait
{
my ($self,$prog) = (obj(shift),shift);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
in_run_function($prog) &&
return out($prog,"#-1 \@WAIT can not be called from RUN function");
my $cmd = $$prog{cmd};
if(!defined $$cmd{wait_time}) {
($$cmd{wait_time},$$cmd{wait_cmd}) = balanced_split(shift,"=",4);
my ($obj,$time) = balanced_split($$cmd{wait_time},"/",4);
if($time ne undef) {
$$cmd{wait_time} = $time;
$$cmd{wait_semaphore} = 1;
my $target = find($self,$prog,evaluate($self,$prog,$obj)) ||
return err($self,$prog,"I don't see that here.");
if($$target{obj_id} != $$self{obj_id}) {
return err($self,$prog,"Semaphores on other objects are not " .
"supported yet.");
}
}
if(!looks_like_number(ansi_remove($$cmd{wait_time}))) {
return err($self,$prog,"Invalid wait time provided.");
} elsif($$cmd{wait_cmd} =~ /^\s*$/) {
return; # TinyMUSH actually waits, but we'll just quietly
# do nothing unless a reason to wait is found.
} else {
$$cmd{wait_time} += time();
}
} elsif($$cmd{wait_time} <= time()) {
return mushrun(self => $self,
prog => $prog,
source => 0,
child => 1,
cmd => $$cmd{wait_cmd},
);
}
$$prog{idle} = 1;
return "BACKGROUNDED";
}
#
# cmd_sleep
# Let a program sleep for X seconds
#
sub cmd_sleep
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
hasflag($self,"GUEST") && # no sleeping for guests
return err($self,$prog,"Permission denied.");
in_run_function($prog) && # sleep can not be called from inside run()
return out($prog,"#-1 \@SLEEP can not be called from RUN function");
my $cmd = $$prog{cmd};
if(defined $$cmd{sleep}) { # spin() will not run this command again
delete @$cmd{sleep}; # until the sleep is done.
} elsif(!isint($txt) || $txt > 5400) {
necho(self => $self,
prog => $prog,
source => [ "\@sleep is limited to 5400 seconds." ],
);
} elsif($txt > 0) {
$$cmd{sleep} = time() + $txt; # signal spin() to wait.
return "RUNNING";
}
}
sub cmd_read
{
my ($self,$prog,$txt,$switch,$flag) = (obj(shift),shift,shift,shift,shift);
my ($file, $data, $name);
my $count = 0;
if(!hasflag($self,"WIZARD") && !$flag) {
necho(self => $self,
prog => $prog,
source => [ "Permission denied." ],
);
} elsif($txt =~ /^\s*help\s*$/) { # import help data
if(!open($file,"files/help.txt")) {
return necho(self => $self,
prog => $prog,
source => [ "Could not open help.txt for reading." ],
);
}
delete @help{keys %help};
while(<$file>) {
s/\r|\n//g;
if(/^& /) {
if($data ne undef) {
$count++;
$data =~ s/\n$//g;
@help{$name} = $data;
}
$name = lc($');
$data = undef;
} else {
$data .= $_ . "\n";
}
}
if($data ne undef) {
$data =~ s/\n$//g;
@help{$name} = $data;
$count++;
}
necho(self => $self,
prog => $prog,
source => [ "%s help items read containing %d lines of text.",
$count, $. ],
);
close($file);
} else {
necho(self => $self,
prog => $prog,
source => [ "Unknown read item '%s' specified.", trim($txt) ],
);
}
}
sub cmd_squish
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
my ($obj,$atr,$out);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
if($txt =~ /[\/,]/) {
($obj,$atr) = ($`,$');
} else {
return err($self,$prog,"usage: \@squish <object>/<attribute");
}
my $target = find($self,$prog,evaluate($self,$prog,$obj));
if($target eq undef ) {
return err($self,$prog,"Unknown object '$obj'");
return "#-1 Unknown object";
} elsif(!controls($self,$target)) {
return "#-1 Permission Denied $$self{obj_id} -> $$target{obj_id}";
}
my $hash = mget($target,$atr);
$$hash{glob} =~ s/:/\\:/g if(defined $$hash{type});
for my $line (split(/\n/,get($target,$atr))) {
$line =~ s/^\s+//;
$out .= $line;
}
$out =~ s/\r|\n//g;
set($self,$prog,$target,$atr,$out);
necho(self => $self,
prog => $prog,
source => [ "%s",$out ],
);
}
sub invoker
{
my ($prog,$self,$flag) = @_;
if(ref($prog) eq "HASH" &&
defined $$prog{cmd} &&
defined @{$$prog{cmd}}{invoker}) {
return ($flag) ? @{@{$$prog{cmd}}{invoker}}{obj_id} :
@{$$prog{cmd}}{invoker};
} elsif($self eq undef && $flag) {
return undef;
} else {
return ($flag) ? $$self{obj_id} : $self;
}
}
sub code_history
{
my $prog = shift;
printf("-----[ start ]----------\n");
if(defined $$prog{cmd} &&
defined @{$$prog{cmd}}{stack}) {
my $hash = @{$$prog{cmd}}{stack};
push(@$hash,invoker($prog,undef,1) . "->" . code());
for my $i (0 .. $#$hash) {
printf("$i : %s\n",$$hash[$i]);
}
} else {
printf("0 : No stack history provided.\n");
printf("1 : %s\n",invoker($prog,undef,1) . "->" . code());
}
printf("-----[ end ]----------\n");
}
sub cmd_switch
{
my ($self,$prog,@list) = (obj(shift),shift,balanced_split(shift,',',3));
my $switch = shift;
my (%last, $pat,$done);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
my ($first,$second) = bsplit(shift(@list),"=");
$first = ansi_trim(evaluate($self,$prog,$first));
$first =~ s/[\r\n]//g;
$first =~ tr/\x80-\xFF//d;
unshift(@list,$second);
while($#list >= 0) {
# ignore default place holder used for readability
if($#list == 1 && @list[0] =~ /^\s*DEFAULT\s*$/) {
shift(@list);
}
if($#list >= 1) {
my $txt=ansi_remove(single_line(evaluate($self,$prog,shift(@list))));
if(defined $$switch{regexp}) {
$pat = $txt;
} else {
$pat = glob2re($txt);
}
my $cmd = shift(@list);
$cmd =~ s/^[\s\n]+//g;
$txt =~ s/^\s+|\s+$//g;
if($txt =~ /^\s*(<|>)\s*/) {
my $val = evaluate($self,$prog,$');
if(($1 eq ">" && $first > $') || ($1 eq "<" && $first < $')) {
$cmd =~ s/\\,/,/g;
return mushrun(self => $self,
prog => $prog,
source => 0,
child => 1,
invoker=> invoker($prog,$self),
cmd => $cmd,
);
}
} else {
my @wild = ansi_match($first,$txt);
if($#wild >=0) {
$cmd =~ s/\\,/,/g;
mushrun(self => $self,
prog => $prog,
source => 0,
cmd => $cmd,
child => 1,
invoker=> invoker($prog,$self),
match => { 0 => @wild[0], 1 => @wild[1], 2 => @wild[2],
3 => @wild[3], 4 => @wild[4], 5 => @wild[5],
6 => @wild[6], 7 => @wild[7], 8 => @wild[8]
}
);
return;
}
}
} else {
@list[0] = $1 if(@list[0] =~ /^\s*{(.*)}\s*$/);
@list[0] =~ s/\r|\n//g;
@list[0] =~ s/\\,/,/g;
mushrun(self => $self,
prog => $prog,
source => 0,
child => 1,
invoker=> invoker($prog,$self),
cmd => @list[0],
);
return;
}
}
}
sub cmd_newpassword
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
if(!hasflag($self,"PLAYER")) {
return err($self,$prog,"Permission Denied, non-players do not need " .
"passwords.");
} elsif($txt =~ /^\s*([^ ]+)\s*=\s*([^ ]+)\s*$/) {
my $player = find_player($self,$prog,$1) ||
return err($self,$prog,"Unknown player '%s' specified",$1);
if(!controls($self,$player)) {
return err($self,$prog,"Permission denied.");
}
# good_password($2) || return;
db_set($player,"obj_password",mushhash($2));
necho(self => $self,
prog => $prog,
source => [ "The password for %s has been updated.",name($player) ],
);
} else {
err($self,$prog,"usage: \@newpassword <player> = <new_password>");
}
}
sub cmd_telnet
{
my ($self,$prog,$txt) = (obj(shift),shift);
my $txt = evaluate($self,$prog,shift);
my $pending = 1;
my $puppet = hasflag($self,"SOCKET_PUPPET");
my $input = hasflag($self,"SOCKET_INPUT");
if(!$input && !$puppet) {
return err($self,$prog,"Permission DENIED.");
} elsif(find_socket($self,$prog) ne undef) {
return err($self,$prog,"A \@telnet/url() connection is already open");
} elsif($txt =~ /^\s*([^:]+)\s*[:| ]\s*(\d+)\s*$/) {
my ($host,$port) = ($1,$2);
# printf("cmd_telnet: opening connection to '$host:$port'\n");
my $sock = IO::Socket::INET->new(Proto => 'tcp',
Blocking => 0) ||
return err($self,$prog,"Socket error, $!.");
my $iaddr = inet_aton($host) ||
return err($self,$prog,"Unknown host '%s'",$host);
my $paddr = sockaddr_in($port,$iaddr);
my $ret = connect($sock,$paddr);
if (!$ret && ! $!{EINPROGRESS}) {
return err($self,$prog,"Unable to connect") if (!$ret);
}
$$prog{socket_id} = $sock;
@connected{$sock} = { # store socket details
obj_id => $$self{obj_id},
sock => $sock,
raw => ($puppet) ? 1 : 2,
hostname => $host,
port => $port,
loggedin => 0,
opened => time(),
enactor => $enactor,
pending => ($!{EINPROGRESS}) ? 1 : 0, # socket still opening?
prog => $prog
};
() = IO::Select->new($sock)->can_write(.2) # see if socket is pending
or @{@connected{$sock}}{pending} = 2;
$readable->add($sock); # add to select() listener
@info{io} = {} if(!defined @info{io}); # create input buffer
@info{io}->{$sock} = {};
@info{io}->{$sock}->{buffer} = [];
return 1;
} else {
necho(self => $self,
prog => $prog,
source => [ "usage: \@telnet <id>=<hostname>:<port> {$txt}" ],
);
return 0;
}
}
sub find_socket
{
my ($self,$prog) = (obj(shift),shift);
my $sock;
if(!hasflag($self,"WIZARD")) { # wizard only
return err($self,$prog,"Permission Denied.");
} elsif(defined hasflag($self,"SOCKET_PUPPET")) {
# search for socket if set SOCKET_PUPPET.
# 1. only one socket per object allowed
# 2. for convenience sake, a socket "name" isn't required.
# So we search for it.
if(defined hasflag($self,"SOCKET_PUPPET")) {
for my $key (keys %connected) {
if($$self{obj_id} eq @{@connected{$key}}{obj_id} &&
defined @{@connected{$key}}{prog}) {
return @{@connected{$key}}{sock};
}
}
}
} elsif(hasflag($self,"SOCKET_INPUT") && defined $$prog{socket_id}) {
return $$prog{socket_id};
}
return undef;
}
#
# send data to a connected @telnet socket. If the socket is pending,
# the socket will "pause" the @send till it times out or connects.
#
sub cmd_send
{
my ($self,$prog) = (obj(shift),shift);
my $sock;
hasflag($self,"WIZARD") || # wizard only
return err($self,$prog,"Permission Denied.");
my $sock = find_socket($self,$prog);
if($sock eq undef) {
return err($self,$prog,"Telnet connection needs to be opened first");
} elsif(@{@connected{$sock}}{pending} == 2) {
$$prog{idle} = 1; # socket pending, try again later
return "RUNNING";
} else {
my $txt = ansi_remove(evaluate($self,$prog,shift));
my $switch = shift;
$txt =~ s/\r|\n//g;
$txt =~ tr/\x80-\xFF//d;
if(defined $$switch{lf}) {
printf($sock "%s\n",$txt);
} elsif(defined $$switch{cr}) {
printf($sock "%s\r",$txt);
} elsif(defined $$switch{crlf}) {
printf($sock "%s\r\n",$txt);
} else {
printf($sock "%s\r\n",$txt);
}
}
}
sub cmd_close
{
my ($self,$prog) = (obj(shift),shift);
hasflag($self,"WIZARD") ||
return err($self,$prog,"Permission Denied.");
my $sock = find_socket($self,$prog) ||
return err($self,$prog,"No sockets open.");
server_disconnect($sock);
necho(self => $self,
prog => $prog,
source => [ "Socket Closed." ],
);
}
sub cmd_uptime
{
my ($self,$prog) = @_;
my $diff = time() - @info{server_start};
my $days = int($diff / 86400);
$diff -= $days * 86400;
my $hours = int($diff / 3600);
$diff -= $hours * 3600;
my $minutes = int($diff / 60);
necho(self => $self,
prog => $prog,
source => [ "Uptime: %s days, %s hours, %s minutes",
$days,$hours,$minutes ]
);
}
sub cmd_force
{
my ($self,$prog) = (obj(shift),shift);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
my ($left,$right) = besplit($self,$prog,shift,"=");
my $target = find($self,$prog,$left) ||
return err($self,$prog,"I can't find that - '$left'");
if(!controls($self,$target)) {
return err($self,$prog,"Permission Denied.");
}
if(owner_id($self) != owner_id($target)) {
audit($self,$prog,"%s \@forced",obj_name($target,$target));
}
mushrun(self => $target,
prog => $prog,
runas => $target,
source => 0,
cmd => $right,
child => 2,
hint => "ALWAYS_RUN"
);
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# -------------------------------[ MOTD ]-------------------------------
# ------------------------------[ MOTD ]------------------------------
#
# motd
# Display the message of the day. Since this will be run as #0,
# don't allow any modifications to the db to prevent wizards
# from doing anything interesting.
#
sub motd
{
my ($self,$prog) = @_;
my $atr = conf("motd"); # get motd
if($atr eq undef) { # no motd, provide a default
$atr = " " .
ansi_center("There is no MOTD today",70) .
"\n " .
ansi_center("&conf.motd #0=<message> for your MOTD",70);
} else { # evaluate the motd
my $tmp = $$prog{read_only}; # set readonly mode
$$prog{read_only} = 1;
$atr = evaluate($self,$prog,$atr);
if($tmp eq undef) {
delete @$prog{read_only};
} else {
$$prog{read_only} = $tmp;
}
}
return " " . ("-" x 31) . "[ MOTD ]" . ("-" x 31) . "\n\n".
$atr . "\n\n " . ("-" x 70) . "\n";
}
sub cmd_list
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if($txt =~ /^\s*motd\s*$/i) {
necho(self => $self,
prog => $prog,
source => [ "%s", motd($self,$prog) ]
);
} elsif($txt =~ /^\s*functions\s*$/i) {
my $user;
$Text::Wrap::columns=75;
if(!defined @info{mush_function}||ref(@info{mush_function}) ne "HASH") {
$user = "N/A"
} else {
$user = uc(join(' ',keys %{@info{mush_function}}));
}
necho(self => $self,
prog => $prog,
source => [ "%s\n%s",
wrap("Functions: x",
" ",
uc(list_functions())
),
wrap("User-Functions: ",
" ",
$user
),
]
);
} elsif($txt =~ /^\s*commands\s*$/i) {
my %short;
for my $key (keys %command) {
if(defined @{@command{$key}}{full}) {
@short{@{@command{$key}}{full}} = 1;
}
}
$Text::Wrap::columns=75;
necho(self => $self,
prog => $prog,
source => [ "%s\n",
wrap("Commands: ",
" ",
uc(join(' ',sort keys %short))
)
]
);
} elsif($txt =~ /^\s*flags{0,1}\s*$/) {
my @out;
for my $key (keys %flag) {
push(@out,$key . "(" . @flag{$key}->{letter} . ")");
}
necho(self => $self,
prog => $prog,
source => [ "Flags: %s", join(', ',@out) ]
);
} elsif(!hasflag($self,"WIZARD")) {
return err($self,$prog,"Permission Denied.");
} elsif($txt =~ /^\s*buffers{0,1}\s*$/) {
my $hash = @info{io};
necho(self => $self,
prog => $prog,
source => [ "%s",print_var($hash) ],
);
} elsif($txt =~ /^\s*sockets\s*$/) {
my $out;
for my $key (keys %connected) {
my $hash = @connected{$key};
$out .= sprintf("%s:%s [%s]\n Opened: %s, Object: %s\n",
$$hash{hostname},
$$hash{port},
(($$hash{raw} == 0) ? "PLAYER" : "SOCKET"),
ts($$hash{start}),
(defined $$hash{obj_id}) ? obj_name($$hash{obj_id}) : "N/A",
obj_name($$hash{obj_id}));
}
necho(self => $self,
prog => $prog,
source => [ "%s",$out ],
);
} elsif($txt =~ /^\s*(conf|config|configuration)\s*$/) {
my $out;
for my $key (sort grep {/^conf\./} keys %info) {
if(length(@info{$key}) > 40) {
$out .= sprintf("%-30s : %s...\n",$key,
substr(single_line(@info{$key}),0,37));
} else {
$out .= sprintf("%-30s : %s\n",$key,single_line(@info{$key}));
}
}
necho(self => $self,
prog => $prog,
source => [ "%s", $out ]
);
} elsif($txt =~ /^\s*last request\s*$/) {
necho(self => $self,
prog => $prog,
source => [ "%s", @info{socket_buffer} ]
);
} else {
err($self,
$prog,
"syntax: \@list <option>\n\n" .
" Options: site,functions,commands,sockets"
);
}
}
sub cmd_destroy
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
return err($self,$prog,"syntax: \@destroy <object>") if($txt =~ /^\s*$/);
my $target = find($self,$prog,$txt) ||
return err($self,$prog,"I can't find an object named '%s'",$txt);
if(hasflag($target,"PLAYER")) {
return err($self,$prog,"Players are \@toaded not \@destroyed.");
} elsif(!controls($self,$target)) {
return err($self,$prog,"Permission Denied.");
}
my $name = name($target);
my $loc = loc($target);
necho(self => $self,
prog => $prog,
source => [ "Destroyed %s", obj_name($target) ],
);
destroy_object($self,$prog,$target);
}
#
# cmd_toad
# Delete a player. This cycles through the whole db, so the code will
# search in 100 object increments.
#
sub cmd_toad
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
my $start;
if(!hasflag($self,"WIZARD")) {
return err($self,$prog,"Permission Denied.");
} elsif($txt =~ /^\s*$/) {
return err($self,$prog,"syntax: \@toad <object>");
}
#-----------------------------------------------------------------------#
# initialize loop #
#-----------------------------------------------------------------------#
my $cmd = $$prog{cmd};
if(!defined $$cmd{toad_pos}) {
my $target = find($self,$prog,$txt) ||
return err($self,$prog,"I don't see that here.");
if(!hasflag($target,"PLAYER")) {
return err($self,$prog,"Try \@destroy instead");
}
$$cmd{toad_pos} = 0;
$$cmd{toad_dbref} = $$target{obj_id};
$$cmd{toad_name} = name($target);
$$cmd{toad_name2} = name($target,1);
$$cmd{toad_objname} = obj_name($self,$target);
$$cmd{toad_loc} = loc($target);
audit($self,$prog,"%s \@toaded",obj_name($target,$target));
if(hasflag($target,"CONNECTED")) {
cmd_boot($self,$prog,"#" . $$target{obj_id});
}
}
#-----------------------------------------------------------------------#
# do 100 objects at a time #
#-----------------------------------------------------------------------#
for($start=$$cmd{toad_pos};
$$cmd{toad_pos} < $#db &&
$$cmd{toad_pos} - $start < 100;
$$cmd{toad_pos}++) {
if(valid_dbref($$cmd{toad_pos}) &&
$$cmd{toad_pos} != $$cmd{toad_dbref} &&
owner_id($$cmd{toad_pos}) == $$cmd{toad_dbref}) {
destroy_object($self,$prog,$$cmd{toad_pos});
}
}
#-----------------------------------------------------------------------#
# done? #
#-----------------------------------------------------------------------#
if($$cmd{toad_pos} >= $#db) {
if($$cmd{toad_loc} ne loc($self)) {
necho(self => $self,
prog => $prog,
source => [ "%s was \@toaded.",$$cmd{toad_objname} ],
all_room => [ $$cmd{toad_loc},
"%s was \@toaded.",
$$cmd{toad_name}
],
all_room2 => [ $$cmd{toad_dbref}, "%s has left.",
$$cmd{toad_name} ]
);
} else {
necho(self => $self,
prog => $prog,
source => [ "%s was \@toaded.",$$cmd{toad_objname} ],
all_room => [ $$cmd{toad_loc},
"%s was \@toaded.",
$$cmd{toad_name}
],
all_room2 => [ $$cmd{toad_dbref}, "%s has left.",
$$cmd{toad_name} ]
);
}
delete @player{trim(ansi_remove(lc($$cmd{toad_name2})))};
db_delete($$cmd{toad_dbref});
} else {
return "RUNNING"; # still running
}
}
sub cmd_think
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
verify_switches($self,$prog,$switch,"noeval") || return;
if(!$$switch{noeval}) {
$txt = evaluate($self,$prog,$txt);
}
if($txt !~ /^\s*$/) {
necho(self => $self,
prog => $prog,
source => [ "%s", $txt ],
);
}
}
sub cmd_pemit
{
my ($self,$prog) = (obj(shift),shift);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
my ($obj,$txt) = balanced_split(shift,"=",4);
if($txt eq undef) {
return err($self,$prog,"syntax: \@pemit <object> = <message> '$txt'");
}
my $target = find($self,$prog,evaluate($self,$prog,$obj));
if($target eq undef) {
return err($self,$prog,"I don't see that here - '$target'");
}
my $txt = evaluate($self,$prog,trim($txt));
if($txt !~ /^\s*$/) {
necho(self => $self,
prog => $prog,
target => [ $target, "%s", $txt ],
);
}
}
sub cmd_emit
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
my $txt = evaluate($self,$prog,$txt);
necho(self => $self,
prog => $prog,
source => [ "%s", $txt ],
room => [ $self, "%s", $txt ],
always => 1,
);
}
sub cmd_drop
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if(hasflag($self,"GUEST")) {
return err($self,$prog,"Permission Denied.");
}
my $target = find_content($self,$prog,$txt) ||
return err($self,$prog,"I don't see that here.");
if(hasflag($target,"ROOM") || hasflag($target,"EXIT")) {
return err($self,$prog,"You may not drop exits or rooms.");
} elsif($$target{obj_id} == $$self{obj_id}) {
return err($self,$prog,"You may not drop yourself.");
}
my $loc = loc($self);
teleport($self,$prog,$target,$loc) ||
return err($self,$prog,"Internal error, unable to drop that object");
# provide some visual feed back to the player
generic_action($self,
$prog,
$target,
"DROP",
[ "dropped %s.\n%s has arrived.",
name($target),name($target) ],
[ "Dropped." ]);
# necho(self => $self,
# prog => $prog,
# source => [ "You have dropped %s.\n%s has arrived.",
# name($target), name($target)
# ],
# room => [ $self, "%s dropped %s.", name($self),name($target) ],
# room2 => [ $self, "%s has arrived.",name($target) ]
# );
cmd_look($target,$prog,undef,undef,1);
}
sub cmd_leave
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
my $container = loc($self);
if($container eq undef || hasflag($container,"ROOM")) {
return err($self,$prog,"You can't leave.");
}
my $dest = loc($container);
cmd_go($self,$prog,"home") if($dest eq undef);
necho(self => $self,
prog => $prog,
room => [ $self, "%s dropped %s", name($container),name($self) ],
room2 => [ $self, "%s has left.",name($self) ],
always => 1
);
# my ($self,$prog,$target,$dest,$type) = (obj($_[0]),obj($_[1]),obj($_[2]),$_[3]);
teleport($self,$prog,$self,$dest) ||
return err($self,$prog,"Internal error, unable to leave that object");
# provide some visual feed back to the player
necho(self => $self,
prog => $prog,
room => [ $self, "%s dropped %s.", name($container),name($self) ],
room2 => [ $self, "%s has arrived.",name($self) ],
always => 1
);
cmd_look($self,$prog,undef,undef,1);
}
sub cmd_take
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission Denied.");
my $target = find($self,$prog,$txt) ||
return err($self,$prog,"I don't see that here.");
if(hasflag($target,"EXIT")) {
return err($self,$prog,"You may not pick up exits.");
} elsif(hasflag($target,"ROOM")) {
return err($self,$prog,"You may not pick up rooms.");
} elsif($$target{obj_id} eq $$self{obj_id}) {
return err($self,$prog,"You may not pick up yourself!");
} elsif(loc($target) == $$self{obj_id}) {
return err($self,$prog,"You already have that!");
} elsif(loc($target) != loc($self)) {
return err($self,$prog,"That object is to far away");
}
my $atr = get($target,"OBJ_LOCK_DEFAULT");
if($atr ne undef) {
my $lock = lock_eval($self,$prog,$target,$atr);
if($$lock{error}) {
return err($self,$prog,"Permission denied, the lock has broken.");
} elsif(!$$lock{result}) {
return err($self,$prog,"You can't pick that up.");
}
}
generic_action($self,
$prog,
$target,
"SUCC",
[ "takes %s.\n%s has left.", # msg to room
name($target),name($target) ],
[ "Taken." ] # msg to enactor
);
necho(self => $self,
prog => $prog,
target => [ $target, "%s has picked you up.", name($self) ],
);
teleport($self,$prog,$target,$self) ||
return err($self,$prog,"Internal error, unable to pick up that object");
necho(self => $self,
prog => $prog,
room => [ $target, "%s has arrived.",name($target) ],
always => 1
);
cmd_look($target,$prog,undef,undef,1);
}
sub cmd_cpattr
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my ($i, $data, @todo, @out);
my ($left,$right) = bsplit($txt,"=");
my ($src_obj,$src_atr) = besplit($self,$prog,$left,"/");
my $src = find($self,$prog,$src_obj) ||
return err($self,$prog,"I don't see '%s' here.",$src_obj);
if(!(hasflag($src,"VISUAL") || controls($self,$src))) {
return err($self,$prog,"Permission denied on object '%s'.",
obj_name($self,$src));
}
# Do not do anything unless iall the checks look good, so
# enqueue and go when checks are complete.
#
my $pat = glob2re(trim($src_atr));
for my $name (lattr($src)) {
if($name !~ /^obj_/ && $name =~ /$pat/) {
# printf(" NAME: '%s' -> '$src_atr'\n",$name);
my $txt = $right;
$i = 0;
while($i++ < 20 && $txt ne undef) {
($data,$txt) = bsplit($txt,",");
my ($dst_obj,$dst_atr) = besplit($self,$prog,$data,"/");
$dst_obj = trim(ansi_remove($dst_obj));
$dst_atr = trim(ansi_remove($dst_atr));
$dst_atr = $name if(empty($dst_atr)); # default to same name
# verify information before doing work.
my $dest = find($self,$prog,evaluate($self,$prog,$dst_obj)) ||
return err($self,$prog,"I don't see '%s' here.",$dst_obj);
good_atr_name($dst_atr) ||
return err($self,$prog,"Invalid attribute name '%s'",$dst_atr);
controls($self,$dest) ||
return err($self,$prog,"Permission denied on object '%s'.",
obj_name($self,$dest));
push(@todo,{ src_atr => $name, # enqueue todo
dst_obj => $dest,
dst_atr => $dst_atr
}
)
}
}
}
for my $i (0 .. $#todo) { # do it, do it now!
my $hash = @todo[$i];
my $atr = get($src,$$hash{src_atr}); # get attribute
set($self,$prog,$$hash{dst_obj},$$hash{dst_atr},$atr,1); # copy it over
push(@out, "Set " .
obj_name($self,$$hash{dst_obj}) .
"/" .
$$hash{dst_atr}
);
}
push(@out,"No matching attributes.") if($#out == -1);
necho(self => $self,
prog => $prog,
source => [ join("\n",@out) ]
);
}
sub cmd_name
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
verify_switches($self,$prog,$switch,"quiet") || return;
if(hasflag($self,"GUEST")) {
return err($self,$prog,"Permission Denied.");
} elsif($txt =~ /^\s*([^=]+?)\s*=\s*(.+?)\s*$/) {
my $target = find($self,$prog,evaluate($self,$prog,$1)) ||
return err($self,$prog,"I don't see that here.");
my $cname = trim(evaluate($self,$prog,$2));
my $name = ansi_remove($cname);
my $old = name($target);
controls($self,$target) ||
return err($self,$prog,"Permission Denied.");
if($name =~ /^([^a-zA-Z\_\-0-9\.]+)$/) {
return err($self,$prog,"Invalid names, names may only " .
"contain A-Z, 0-9, _, ., and -");
}
if(hasflag($target,"PLAYER") && inuse_player_name($2,$self)) {
return err($self,$prog,"That name is already in use");
} elsif($name =~ /^\s*(\#|\*)/) {
return err($self,$prog,"Names may not start with * or #");
} elsif(length($name) > 50) {
return err($self,$prog,"Names may only be 50 charaters");
}
if(hasflag($target,"PLAYER")) {
delete @player{trim(ansi_remove(lc(name($target,1))))};
@player{trim(ansi_remove(lc($name)))} = $$target{obj_id};
}
db_set($target,"obj_name",$name);
db_set($target,"obj_cname",$cname);
if(!defined $$switch{quiet}) {
necho(self => $self,
prog => $prog,
source => [ "Set." ],
);
}
} else {
err($self,$prog,"syntax: \@name <object> = <new_name>");
}
}
sub cmd_enter
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
my $target = find($self,$prog,$txt) ||
return err($self,$prog,"I don't see that here.");
if($$target{obj_id} == $$self{obj_id}) {
return err($self,$prog,"You can't enter yourself!");
}
# enter your own objects or things set ENTER_OK. This should be a
# controls() for TinyMUSH compat but i'm against wizards entering that
# aren't specifically set enter_ok. They can @teleport if they really
# need too.
if(!(owner_id($target) == owner_id($self) || hasflag($target,"ENTER_OK"))) {
return err($self,$prog,"Permission denied.");
} elsif(!(hasflag($target,"OBJECT") || hasflag($target,"PLAYER"))) {
return err($self,$prog,"I don't see that here.");
}
# check to see if object can pass enter lock
my $atr = get($target,"OBJ_LOCK_ENTER");
if($atr ne undef) {
my $lock = lock_eval($self,$prog,$target,$atr);
if($$lock{error}) {
return err($self,$prog,"Permission denied, the lock has broken.");
} elsif(!$$lock{result}) {
return err($self,$prog,"Permission denied.");
}
}
necho(self => $self,
prog => $prog,
room => [ $self, "%s enters %s.",name($self),name($target)],
room2 => [ $self, "%s has left.", name($self) ],
always => 1,
);
teleport($self,$prog,$self,$target) ||
return err($self,$prog,"Internal error, unable to pick up that object");
# provide some visual feed back to the player
necho(self => $self,
prog => $prog,
source => [ "You have entered %s.",name($target) ],
room => [ $self, "%s entered %s.",name($self),name($target)],
room2 => [ $self, "%s has arrived.", name($self) ],
always => 1,
);
cmd_look($self,$prog,undef,undef,1);
}
sub cmd_to
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if($txt =~ /^\s*([^ ]+)\s*/) {
my $tg = find($self,$prog,$1) ||
return err($self,$prog,"I don't see that here.");
necho(self => $self,
prog => $prog,
source => [ "%s [to %s]: %s\n",name($self),name($tg),$' ],
room => [ $self, "%s [to %s]: %s\n",name($self),name($tg),$' ],
always => 1
);
} else {
err($self,$prog,"syntax: `<person> <message>");
}
}
sub whisper
{
my ($self,$prog,$target,$msg) = @_;
my $obj = find($self,$prog,$target);
if($obj eq undef) {
return err($self,$prog,"I don't see that here.");
} elsif(hasflag($obj,"EXIT") || hasflag($obj,"ROOM")) {
return err($self,$prog,"You may only whisper to objects or players");
} elsif(loc($obj) != loc($self)) {
return err($self,$prog,"%s is not here.",name($obj));
} elsif($msg =~ /^\s*:/) {
necho(self => $self,
prog => $prog,
source => [ "%s senses, \"%s %s\"",
name($obj),name($self),trim($')
],
target => [ $obj, "You sense, %s %s",name($self),trim($') ],
always => 1,
);
} else {
necho(self => $self,
prog => $prog,
source => [ "You whisper, \"%s\" to %s.",trim($msg),name($obj) ],
target => [ $obj, "%s whispers, \"%s\"",name($self),trim($msg) ],
always => 1,
);
}
if(hasflag($self,"PLAYER")) {
set($self,$prog,$self,"OBJ_LAST_WHISPER","#$$obj{obj_id}",1,1);
}
return 1;
}
#
# cmd_whisper
# person to person communication in the same room.
#
sub cmd_whisper
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if($txt =~ /^\s*([^ ]+)\s*=/) { # standard whisper
whisper($self,$prog,$1,$');
} else {
my $target = get($self,"OBJ_LAST_WHISPER"); # no target whisper
return whisper($self,$prog,$target,$txt) if ($target ne undef);
err($self,
$prog,
"usage: whisper <user> = <message>\n" .
" whisper <message>"
);
}
}
sub page
{
my ($self,$prog,$name,$msg) = @_;
my $target = find_player($self,$prog,$name) ||
return err($self,$prog,"I don't recognize '%s'",trim($name));
if(!hasflag($target,"CONNECTED")) {
return err($self,$prog,"Sorry, %s is not connected.",name($target));
}
# my $target = fetch($$target{obj_id});
my $msg = evaluate($self,$prog,$msg);
if($msg =~ /^\s*:\s*/) {
necho(self => $self,
prog => $prog,
source => [ "Long distance to %s: %s %s",name($target),
name($self),$'
],
target => [ $target, "From afar, %s %s\n",name($self),$msg ],
always => 1,
);
} else {
$msg =~ s/^\s*//g;
necho(self => $self,
prog => $prog,
source => [ "You paged %s with '%s'",name($target),$msg ],
target => [ $target, "%s pages: %s\n",name($self),$msg ],
always => 1,
);
}
if(hasflag($self,"PLAYER")) {
set($self,$prog,$self,"OBJ_LAST_PAGE","#$$target{obj_id}",1);
}
}
#
# cmd_page
# Person to person communication reguardless of location.
#
sub cmd_page
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
return page($self,$prog,$1,$') if($txt =~ /^\s*([^ ]+)\s*=/); # standard page
my $target = get($self,"OBJ_LAST_PAGE"); # no target page
return page($self,$prog,$target,$txt) if($target ne undef);
err($self,
$prog,
"usage: page <user> = <message>\n page <message>"
);
}
sub cmd_last
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my ($target,$extra, $hostname, $count,$out, $h);
my $max = 0;
verify_switches($self,$prog,$switch,"full") || return;
if($txt =~ /^\s*$/) {
if(hasflag($self,"PLAYER")) {
$target = $self;
} else {
return err($self,$prog,"Only players may use this command.");
}
} else {
$target = find_player($self,$prog,$txt) ||
return err($self,$prog,"I couldn't find that player.");
}
if($$switch{full} && !hasflag($self,"GOD")) {
return err($self,$prog,"Permission denied.");
}
!controls($self,$target) &&
return err($self,$prog,"Permission denied.");
my $attr = mget($target,"obj_lastsite");
if($attr eq undef || !defined $$attr{value} ||
ref($$attr{value}) ne "HASH") {
return err($self,$prog,"Internal error, unable to continue");
}
# deterime site column sizing
for my $key (sort {$b <=> $a} keys %{$$attr{value}}) {
last if($count++ > 15);
if(@{$$attr{value}}{$key} =~ /^([^,]+)\,([^,]+)\,/) {
$h = (defined $$switch{full}) ? $' : short_hn($');
$max = ansi_length($h) if ansi_length($h) >= $max;
}
}
$count = 0; # build header
$out .= "Site:" . (" " x ($max-2)) . "Connection Start | ".
"Connection End\n";
$out .= ("-" x ($max+1)) . "|-------------------|" .
("-" x 18) . "\n";
for my $key (sort {$b <=> $a} keys %{$$attr{value}}) { # build contents
last if($count++ > 15);
if(@{$$attr{value}}{$key} =~ /^([^,]+)\,([^,]+)\,/) {
$h = (defined $$switch{full}) ? $' : short_hn($');
$out .= sprintf("%s%s | %s | %s\n",
$h,
" " x ($max - ansi_length($h)),
minits($key),
minits($1)
);
}
}
$out .= ("-" x ($max+1)) . "|-------------------|" . # footer
("-" x 18) . "\n";
necho(self => $self,
prog => $prog,
source => [ "%s", $out ],
);
}
#
# cmd_go
# Move an object from one location to another via an exit.
#
sub cmd_go
{
my ($self,$prog) = (obj(shift),shift);
my ($exit ,$dest);
my $txt = evaluate($self,$prog,shift);
$txt =~ s/^\s+|\s+$//g;
my $loc = loc($self);
if(conf_true("master_override")) { # search master room first?
$dest = find_exit($self,$prog,conf("master"),$txt);
if(dest($dest) eq undef) {
return err($self,$prog,"That exit does not go anywhere");
}
}
if($dest eq undef && $txt =~ /^home$/i) {
necho(self => $self,
prog => $prog,
source => [ "There's no place like home...\n" .
"There's no place like home...\n" .
"There's no place like home..." ],
room => [ $loc, "%s goes home.",name($self) ],
room2 => [ $loc, "%s has left.",name($self) ],
);
$dest = home($self);
} elsif($dest eq undef) {
# find the exit to go through
$exit = find_exit($self,$prog,loc($self),$txt);
if($exit eq undef && conf("master") ne undef) { # try master room
$exit = find_exit($self,$prog,conf("master"),$txt);
}
if($exit eq undef) {
return err($self,$prog,"You can't go that way.");
}
$dest = dest($exit);
# grab the destination object
if(dest($exit) eq undef) {
return err($self,$prog,"That exit does not go anywhere");
}
necho(self => $self,
prog => $prog,
room => [ $self, "%s goes %s.",name($self),
first(name($exit))
],
room2 => [ $self, "%s has left.",name($self) ],
);
}
# move it, move it, move it. I like to move it, move it.
teleport($self,$prog,$self,$dest) ||
return err($self,$prog,"Internal error, unable to go that direction");
# generic_action($self,$prog,$self,"MOVE",$loc);
generic_action($self,
$prog,
$self,
"MOVE",
[ "has arrived." ],
[ "" ]);
# provide some visual feed back to the player
# necho(self => $self,
# prog => $prog,
# room => [ $self, "%s has arrived.",name($self) ]
# );
cmd_look($self,$prog,undef,undef,1);
}
sub cmd_teleport
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my ($target,$location,$obj,$dst);
my ($left,$right) = besplit($self,$prog,$txt,"=");
if(empty($right)) { # one arguement, @tel $self
$obj = "#$$self{obj_id}";
$dst = $left;
} else { # @tel specified object
$obj = $left;
$dst = $right;
}
$target = find($self,$prog,$obj) ||
return err($self,$prog,"I don't see that object here.");
$location = find($self,$prog,$dst) ||
return err($self,$prog,"I don't see that object here.");
controls($self,$target) || # must control object to teleport
return err($self,$prog,"Permission Denied.");
if(hasflag($location,"EXIT")) {
if((owner_id(loc($location)) == $$self{obj_id} &&
loc($location) == loc($target)) ||
hasflag($self,"WIZARD")) {
$location = dest($location);
if($location eq undef) {
return err($self,$prog,"That exit does not go anywhere.");
}
} else {
return err($self,$prog,"Permission Denied.");
}
} elsif(!(controls($self,$location) || hasflag($location,"JUMP_OK"))) {
return err($self,$prog,"Permission Denied.");
}
necho(self => $self,
prog => $prog,
all_room => [ $target, "%s has left.",name($target) ]
);
teleport($self,$prog,$target,$location) ||
return err($self,$prog,"Unable to teleport to that location");
necho(self => $self,
prog => $prog,
all_room => [ $target, "%s has arrived.",name($target) ]
);
cmd_look($target,$prog,undef,undef,1);
}
#
# cmd_print
# Provide some debuging information
#
sub cmd_print
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
$txt =~ s/^\s+|\s+$//g;
if(!hasflag($self,"WIZARD")) {
err($self,$prog,"Permission denied.");
} elsif($txt eq "connected") {
necho(self => $self,
prog => $prog,
source => [ "%s",print_var(\%connected) ]
);
} elsif($txt eq "connected_user") {
necho(self => $self,
prog => $prog,
source => [ "%s",print_var(\%connected_user) ]
);
} else {
err($self,$prog,"Invalid variable '%s' specified.",$txt);
}
}
sub cmd_clear
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
if(!or_flag($self,"WIZARD","GOD")) {
err($self,$prog,"Permission denied.");
} elsif($txt ne undef) {
err($self,$prog,"\@clear expect no arguments");
} else {
$| = 1;
con("%s\n%s\n%s\n","#" x 65,"-" x 65,"#" x 65);
con("\033[2J"); #clear the screen
con("\033[0;0H"); #jump to 0,0
printf("%s\n%s\n%s\n","#" x 65,"-" x 65,"#" x 65);
printf("\033[2J"); #clear the screen
printf("\033[0;0H"); #jump to 0,0
necho(self => $self,
prog => $prog,
source => [ "Done." ]
);
}
}
sub cmd_quit
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
if(!defined $$prog{user} || !defined $$prog{user}->{sock}) {
return err($self,$prog,"Non-Players may not QUIT");
}
my $sock = $$prog{user}->{sock};
my $logoff = conf("logoff");
$logoff .= "\n" if($logoff !~ /\n$/);
if(defined @connected{$sock} && @connected{$sock}->{type} eq "WEBSOCKET") {
ws_echo($sock,$logoff);
ws_disconnect(@c{$sock}) if(defined @c{$sock});
} else {
printf($sock "%s",$logoff);
server_disconnect($sock);
}
}
sub cmd_help
{
my ($self,$prog,$txt) = (obj(shift),shift,ansi_remove(shift));
my $help;
$txt = "help" if($txt =~ /^\s*$/);
# initalize help variable if needed
cmd_read($self,$prog,"help",undef,1) if(scalar keys %help == 0);
if(defined @help{lc(trim($txt))}) {
$help = @help{lc(trim($txt))};
} elsif(defined @help{lc(trim($txt)). "()"}) {
$help = @help{lc(trim($txt)) . "()"};
} elsif($txt =~ /\(\s*\)\s*$/ && defined @help{lc(trim($`))}) {
$help = @help{lc(trim($`))};
} elsif(defined @help{"@" . lc(trim($txt))}) {
$help = @help{"@" . lc(trim($txt))};
} else {
$help = "No entry for '" . lc(trim($txt) . "'");
}
if($help =~ /^run: /i) { # run a command to provide help
mushrun(self => $self,
prog => $prog,
runas => $self,
source => 0,
cmd => $'
);
} else { # send help output to user
necho(self => $self,
prog => $prog,
source => [ "%s", $help ],
);
}
}
sub cmd_nohelp
{
my ($self,$prog,$txt,$switch,$flag) = (obj(shift),shift,shift,shift,shift);
my @result;
for my $key (sort keys %command) {
if(@command{$key}->{full} eq $key && !defined @help{$key}) {
push(@result,$key);
}
}
necho(self => $self,
prog => $prog,
source => [ wrap("commands: ",
" ",
join(', ',@result)
)
]
);
delete @result[0 .. $#result];
for my $key (sort keys %fun) {
if(!defined @help{"$key()"}) {
push(@result,$key);
}
}
necho(self => $self,
prog => $prog,
source => [ wrap("functions: ",
" ",
join(', ',@result)
)
]
);
delete @result[0 .. $#result];
}
sub cmd_pcreate
{
my ($self,$prog,$txt,$switch,$flag) = (obj(shift),shift,shift,shift,shift);
if($$user{site_restriction} == 3) {
necho(self => $self,
prog => $prog,
source => [ "%s", conf("registration") ],
);
} elsif($txt =~ /^\s*([^ ]+) ([^ ]+)\s*$/) {
if(inuse_player_name($1)) {
err($user,$prog,"That name is already in use.");
} else {
$$user{obj_id} = create_object($self,$prog,$1,$2,"PLAYER");
$$user{obj_name} = $1;
cmd_connect($self,$prog,$txt) if !$flag;
}
} else {
err($user,$prog,"Invalid create command, try: create <user> <password> [$txt]");
}
}
sub create_exit
{
my ($self,$prog,$name,$in,$out,$verbose) = @_;
# only ROOM, OBJECT, or PLAYERS may have exits;
return undef if(!or_flag($in,"ROOM","OBJECT","PLAYER"));
# only ROOM, OBJECT, or PLAYERS may have destinations;
return undef if(!or_flag($out,"ROOM","OBJECT","PLAYER"));
my $exit = create_object($self,$prog,$name,undef,"EXIT") ||
return undef;
if(!link_exit($self,$exit,$in,$out,1)) {
return undef;
}
return $exit;
}
sub cmd_create
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,trim(shift),shift);
my ($name,$value) = besplit($self,$prog,$txt,"=");
my $result = create_thing($self,$prog,$name,$value);
if($result =~ /^(\d+)$/) { # success
necho(self => $self,
prog => $prog,
source => [ "%s created as #%s.",obj_name($result),$result ],
);
} else { # error
necho(self => $self,
prog => $prog,
source => [ "%s", $result ],
);
}
}
sub create_thing
{
my ($self,$prog,$name,$cost) = @_;
$name = ansi_trim($name);
$cost = trim(ansi_remove($cost));
$cost = conf("createcost") if $cost eq undef;
my $owner = owner($self);
if(hasflag($owner,"GUEST")) {
return "Permission denied.";
} elsif(quota($owner,"left") <= 0) {
return "You are out of QUOTA to create an object.";
} elsif(length($name) > 160) {
return "Thats a silly name for a thing.";
} elsif(money($owner) < $cost) {
return "You need at least " . pennies($cost) . ".";
} elsif($cost < conf("createcost")) {
return "Objects cost at least " . pennies("createcost") . ".";
} elsif($cost < 0) {
return "You may not create objects with negative money";
}
my $dbref = create_object($self,$prog,$name,undef,"OBJECT") ||
return "Unable to create object";
give_money($self,"-$cost") ||
return "Unable to deduct " . pennies("-$cost") . " from you($cost).";
give_money($dbref,$cost,1) ||
return "Couldn't give " . obj_name($dbref) . " " . pennies($cost) . ".";
set_quota($self,"sub");
return $dbref;
}
sub cmd_link
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my ($name,$target,$destination);
hasflag($self,"GUEST") &&
return err($self,$prog,"Permission denied.");
if($txt =~ /^\s*([^=]+)\s*=\s*(.+?)\s*$/) {
($name,$destination) = ($1,$2);
} else {
return err($self,$prog,"syntax: \@link <exit> = <room_dbref>\n" .
" \@link <exit> = here\n");
}
my $target = find($self,$prog,$name) ||
return err($self,$prog,"I don't see '$name' here");
my $dest = find($self,$prog,$destination) ||
err($self,$prog,"I don't see '$destination' here.");
if(hasflag($target,"EXIT") &&
(controls($self,$dest) || hasflag($dest,"LINK_OK"))) {
printf("Link: $$target{obj_id} -> $$dest{obj_id}\n");
link_exit($self,$target,undef,$dest) ||
return err($self,$prog,"Internal error while trying to link exit");
necho(self => $self, prog => $prog, source => [ "Set." ],);
} elsif(!hasflag($target,"EXIT") &&
(controls($self,$dest) || hasflag($dest,"ABODE"))) {
printf("Link: $$target{obj_id} -> $$dest{obj_id}\n");
set_home($self,$prog,$target,$dest) ||
return err($self,$prog,"Internal error while trying to link exit");
necho(self => $self, prog => $prog, source => [ "set." ],);
} else {
return err($self,$prog,"Permission denied");
}
}
sub cmd_dig
{
my ($self,$prog,$txt,$switch,$flag) = (obj(shift),shift,shift,shift,shift);
my ($room_name,$rest) = bsplit($txt,"=");
my $room_name = evaluate($self,$prog,$room_name);
my ($in,$out) = besplit($self,$prog,$rest,",");
my $result = dig_room($self,$prog,$room_name,$in,$out,$flag);
if($result =~ /^(\d+)$/) { # success
necho(self => $self,
prog => $prog,
source => [ "%s created as #%s.",obj_name($result),$result ],
);
} else { # error
necho(self => $self,
prog => $prog,
source => [ "%s", $result ],
);
}
}
#
# empty
# Determine if a string is empty or not. Unfortunately the ansi functions
# are not optimized to use less characters and a string can be empty but
# contain ansi escape codes.
#
sub empty
{
my $txt = ansi_remove(shift);
if($txt eq undef || $txt =~ /^\s*$/) {
return 1;
} else {
return 0;
}
}
sub dig_room
{
my ($self,$prog,$room_name,$in,$out,$flag) = @_;
my ($loc,$cost,$quota);
printf("NAME: '$room_name'\n");
printf("IN : '$in'\n");
printf("OUT : '$out'\n");
hasflag($self,"GUEST") &&
return "Permission Denied.";
if(!$flag && !(empty($in) && empty($out))) {
$loc = loc($self) ||
return "Unable to determine your location for exit creation";
}
$quota = 1; # determine required quota & cost
$cost = conf("digcost");
if(!empty($in)) {
$cost += conf("linkcost");
$quota++;
}
if(!empty($out)) {
$cost += conf("linkcost");
$quota++;
}
# permission / quota check.
if(hasflag($self,"WIZARD") || hasflag($self,"GOD")) {
# ignore QUOTA restrictions
} elsif(quota($self,"left") < $quota) {
return "A quota of $quota is needed for this \@dig.";
} elsif($cost > money($self)) {
return pennies($cost) . "is needed for this \@dig.";
} elsif((!empty($out) || !empty($in)) &&
!(controls($self,$loc)||hasflag($loc,"LINK_OK"))) {
return "Permission denied (your location is not owned by you or LINK_OK)";
}
# non-quota / permisison checks.
if(empty($room_name)) { # no room name
return "Dig what?";
} elsif(!empty($in) && find_exit($self,$prog,loc($self),$in)) {
return "Exit '$in' already exists in this location";
} elsif(!empty($in) && hasflag($loc,"EXIT")) {
return "You can not \@dig from inside an exit.";
} elsif(!empty($in) && !(controls($self,$loc) || hasflag($loc,"LINK_OK"))){
return "Permission denied (your location is not owned by you or LINK_OK)";
} else { # okay to start @digging
# create room
my $room = create_object($self,$prog,$room_name,undef,"ROOM")||
return "Unable to create a new object";
give_money($self,"-" . $cost) ||
return "Couldn't debit " . pennies($cost);
set_quota($self,"sub") ||
return err($self,$prog,"Couldn't update quota.");
give_money($room,conf("digcost"),1) ||
return err($self,$prog,"Couldn't debit %s",pennies($cost));
# create exit going into the room
my $result = open_exit($self,$prog,$loc,$in,$room) if(!empty($in));
printf("Result1: '%s'\n",$result);
# create exit going into the room
my $result = open_exit($self,$prog,$room,$out,$loc) if(!empty($out));
printf("Result2: '%s'\n",$result);
return $room;
}
}
sub cmd_open
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my ($name,$dbref) = besplit($txt,"=");
my $result = open_exit($self,$prog,loc($self),$name,$dbref);
if($result =~ /^(\d+)$/) { # success
necho(self => $self,
prog => $prog,
source => [ "Opened." ],
);
} else { # error
necho(self => $self,
prog => $prog,
source => [ "%s", $result ],
);
}
}
sub open_exit
{
my ($self,$prog,$loc,$exit,$destination) = @_;
my $dest;
print("open_exit: '$exit' -> '$destination'\n");
hasflag($self,"GUEST") &&
return "Permission denied.";
if(quota($self,"left") < 1) {
return "You are out of QUOTA to create objects";
}
!find_exit($self,$prog,$loc,$exit,"EXACT") ||
return "Exit '$exit' already exists in this location";
# my $loc = loc($self) ||
# return "Unable to determine your location";
if(!(controls($self,$loc) || hasflag($loc,"ABODE"))) {
return "You do not own this room and it is not ABODE";
}
if(!empty($destination)) {
if(valid_dbref($destination)) {
$dest = obj($destination);
} else {
return "That's not a valid object - $destination";
}
if(!(controls($self,$loc) || hasflag($loc,"LINK_OK"))) {
return "This is not your room and it is not LINK_OK";
}
if(!or_flags($dest,"ROOM","OBJECT")) {
return "You may only open exits to rooms or objects";
}
}
my $dbref = create_exit($self,$prog,$exit,$loc,$dest) ||
return "Internal error, unable to create the exit";
set_quota($self,"sub");
return $dbref;
}
sub mushhash
{
return "*" . uc(sha1_hex(sha1(shift)));
}
#
# invalid_player
# Determine if the request is valid or not, provide feed back and log
# if the attempt wasn't valid.
#
sub invalid_player
{
my ($self,$name,$pass) = (shift,ansi_remove(shift),shift);
if($name =~ /^\s*#(\d+)\s*$/) {
if(valid_dbref($1) && hasflag($1,"PLAYER") &&
get($1,"obj_password") eq mushhash($pass)) {
$$self{obj_id} = $1;
return 0;
} else {
return 1;
}
} elsif(!defined @player{trim(ansi_remove(lc($name)))}) {
return 1;
} elsif(@player{trim(ansi_remove(lc($name)))} eq conf("webuser")) {
printf("PLAYER: '%s' -> '%s'\n",@player{trim(ansi_remove(lc($name)))},conf("webuser"));
return 1; # don't allow webuser in
} elsif(lc($name) eq "guest") { # any password for guest
$$self{obj_id} = @player{lc($name)};
return 0;
} elsif(!valid_dbref(@player{trim(ansi_remove(lc($name)))}) ||
get(@player{trim(ansi_remove(lc($name)))},"obj_password") ne
mushhash($pass)) {
return 1;
} else {
$$self{obj_id} = @player{trim(ansi_remove(lc($name)))};
return 0;
}
}
sub calculate_login_stats
{
my $add = shift;
my $count = 0;
#---[ make timestamp ]------------------------------------------------#
my ($hour,$mday,$mon,$year) = (localtime())[2..5]; # make timestamps
$mon++;
$year = $year % 100;
my $tsday = sprintf("%02d/%02d/%02d",$mon,$mday,$year);
#---[ count players ]-------------------------------------------------#
for my $key (keys %connected) { # count players
if(@connected{$key}->{raw} == 0 && @connected{$key}->{loggedin} == 1) {
$count++;
}
}
#---[ clean up old data > 9 days ]------------------------------------#
my $data = mget(0,"stat_login");
if($data ne undef && defined $$data{value}) {
my $attr = $$data{value};
for my $i (keys %$attr) {
if(time() - fuzzy($i) > 86400 * 30) {
db_remove_hash(0,"stat_login",$i); # delete entry
}
}
#---[ Caculate max logged in for day ]------------------------------#
if($attr eq undef || $$attr{$tsday} < $count) {
db_set_hash(0,"stat_login",$tsday,$count);
}
}
}
#
# cmd_connect
# Verify password, populate @connect / @connected_user hash. Allow player
# to connected.
#
sub cmd_connect
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my $sock = @$user{sock};
my ($atr,$player,$count);
if($txt =~ /^\s*"\s*([^"]+)\s*"\s+([^ ]+)\s*$/ || #parse player password
$txt =~ /^\s*([^ ]+)\s+([^ ]+)\s*$/ || #parse player password
$txt =~ /^\s*"\s*([^"]+)\s*"\s*$/ ||
$txt =~ /^\s*([^ ]+)\s*$/) {
my ($username,$pass) = ($1,$2);
# --- Valid User ------------------------------------------------------#
if(invalid_player($self,$username,$pass)) {
delete $$self{obj_id}; # be paranoid
if(@{@connected{$sock}}{type} eq "WEBSOCKET") {
ws_echo($sock,"Either that player does not exist, or has a " .
"different password.\n");
} else {
printf($sock "Either that player does not exist, or has a " .
"different password.\n");
}
return;
}
# --- Hook connected user up to local structures ----------------------#
$$player{connect_time} = time();
for my $key (keys %$player) { # copy object structure
$$user{$key} = $$player{$key};
}
$$user{loggedin} = 1;
if(!defined @connected_user{$$user{obj_id}}) { # reverse lookup
@connected_user{$$user{obj_id}} = {}; # setup
}
@{@connected_user{$$user{obj_id}}}{$$user{sock}} = $$user{sock};
# --- log connnect ----------------------------------------------------#
@{@connected{$sock}}{connect} = time();
db_set_hash($$user{obj_id},
"obj_lastsite",
time(),
time() . ",1,$$user{hostname}"
);
calculate_login_stats();
# --- Provide users visual feedback / MOTD --------------------------#
$prog = prog($user,$user);
$$prog{created_by} = $user; # force output to only connected socket
$$prog{cmd}->{source} = 1;
$$user{sock} = $sock;
echo_socket($user,
$prog,
"%s%s",
motd($user,$prog),
);
cmd_mail($user,$prog,"short");
if(defined conf("paycheck") && conf("paycheck") > 0) {
if(ts_date(lasttime($user)) ne ts_date()) {
give_money($user,conf("paycheck"));
}
}
necho(self => $user,
prog => $prog,
source => [ "\n" ]
);
cmd_look($user,$prog); # show room
con(" %s@%s\n",name($user),$$user{hostname});
# notify users local and users with monitor flag
$$prog{cmd}->{source} = 0;
for my $key (keys %connected) {
if(defined @connected{$key} &&
$$user{obj_id} == @connected{$key}->{obj_id}) {
$count++;
}
}
if($count > 1) {
necho(self => $user,
prog => prog($user,$user),
room => [ $user , "%s has re-connected.",name($user) ],
source => [ "%s has re-connected.", name($user) ],
);
} else {
necho(self => $user,
prog => prog($user,$user),
room => [ $user , "%s has connected.",name($user) ],
);
}
$$prog{cmd}->{source} = 1;
echo_flag($user,
$prog,
"CONNECTED,PLAYER,MONITOR",
"[Monitor] %s has connected.",name($user));
# --- Handle @ACONNECTs on masteroom and players-----------------------#
if(conf("master") ne undef) {
for my $obj (lcon(conf("master")),$player) {
if(($atr = get($obj,"ACONNECT")) && $atr ne undef){
mushrun(self => $obj, # handle aconnect
runas => $obj,
invoker => $self,
source => 0,
cmd => $atr
);
}
}
}
} else {
# not sure this can actually happen
if(@{@connected{$sock}}{type} eq "WEBSOCKET") {
ws_echo($sock,"Invalid command, try: Connect <user> <password>");
} else {
printf($sock "Invalid command, try: cOnnect <user> <password>\r\n");
}
}
}
#
# cmd_doing
# Set the @doing that is visible from the WHO/Doing command
#
sub cmd_doing
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
if(hasflag($self,"GUEST")) {
necho(self => $self,
prog => $prog,
source => [ "Permission denieD." ]
);
} elsif(defined $$switch{header} && $txt =~ /^\s*$/) {
if(!hasflag($self,"WIZARD")) {
return necho(self => $self,
prog => $prog,
source => [ "Permission denIed." ]
);
}
@info{"doing_header"} = $txt;
return necho(self => $self,
prog => $prog,
source => [ "Removed." ]
);
} elsif(defined $$switch{header}) {
if(!hasflag($self,"WIZARD")) {
return necho(self => $self,
prog => $prog,
source => [ "Permission deNied." ]
);
}
@info{"doing_header"} = $txt;
return necho(self => $self,
prog => $prog,
source => [ "Set." ]
);
} elsif($txt =~ /^\s*$/) {
for my $s (keys %{@connected_user{$$self{obj_id}}}) {
delete @connected{$s}->{obj_doing};
}
necho(self => $self,
prog => $prog,
source => [ "Removed." ]
);
} else {
for my $s (keys %{@connected_user{$$self{obj_id}}}) {
$connected{$s}->{obj_doing} = trim($txt);
}
necho(self => $self,
prog => $prog,
source => [ "Set." ]
);
}
}
#
# reconstitute
# Take the an attribute value and put it back together so that it resembles
# what was originally entered in + formating.
#
sub reconstitute
{
my ($name,$type,$pattern,$value,$flag,$switch) = @_;
# $value =~ s/\r|\n//g if !defined $$switch{raw};
# printf("###GOT HERE###\n");
# if($type eq undef && defined $$switch{command}) {
# printf("###GOT HERE 2###\n");
# return;
# } elsif($type eq undef && $value !~ /^\s*\@/) {
# if($flag eq undef) {
# printf("###GOT HERE 3###\n");
# return color("h",uc($name)) . ": $value" if($type eq undef);
# } else {
# printf("###GOT HERE 4###\n");
# return color("h",uc($name)) . "[$flag]: $value" if($type eq undef);
# }
# }
if($type eq 0) {
$type = undef;
} elsif($type eq 1) { # memorydb / mysql don't agree on
$type = "\$"; # how the type is defined
} elsif($type eq 2) {
$type = "^";
} elsif($type eq 3) {
$type = "!";
}
# exclude attributes that are not commands when $$switch{command}
return if($type eq undef && defined $$switch{command});
# convert single line unreadable mushcode into hopefully readable
# multiple line code
if(defined $$switch{command}) {
$value = undef;
} elsif(!$$switch{raw} &&
length($value) > 78 &&
$value !~ /\n/ &&
($pattern ne undef || $value =~ /^\s*([\$|\[|^|!|@])/)) {
if($1 eq "[") {
$value = "\n" . function_print(3,single_line($value));
} else {
$value = "\n" . pretty(3,single_line($value));
}
$value =~ s/\n+$//;
}
if($type eq "hash") {
my $hash = $value;
$value = undef;
for my $key (keys %$hash) {
if($value eq undef) {
$value = $key . " -> " . $$hash{$key};
} else {
$value .= ", " . $key . " -> " . $$hash{$key};
}
}
return color("h",uc($name)) . (($flag ne undef) ? "[$flag]: " : ": ") .
"[" . $value . "]";
}
return color("h",uc($name)) .
(($flag ne undef) ? "[$flag]: " : ": ") .
(($type ne undef) ? "$type$pattern:$value" : $value);
}
sub list_attr_flags
{
my $attr = shift;
my $result;
for my $name (keys %{$$attr{flag}}) {
$result .= flag_letter($name);
}
return $result;
}
#
# viewable
# Determine if an attribute should be viewable or not. Providing a
# pattern will show more attributes.
#
sub viewable
{
my ($obj,$name,$pat) = @_;
if($$obj{obj_id} == 0 && $pat eq undef && $name =~ /^conf./i) {
return 0; # hide conf. attrs on #0 without a pattern
} elsif($name eq "description") {
return ($pat ne undef) ? 1 : 0;
} elsif($name eq "obj_last") {
return 1;
} elsif($name eq "obj_lastsite") {
return 1;
} elsif($name eq "obj_created_by" && hasflag($obj,"PLAYER")) {
return 1;
} elsif($name !~ /^obj/) {
return 1;
} elsif($pat ne undef &&
$name =~ /^obj_(last|last_page|created_date|last_whisper)$/) {
return 1;
} else {
return 0;
}
}
sub list_attr
{
my ($obj,$pattern,$subpat,$switch) = @_;
my (@out,$pat,$spat,$val,$keys);
$pat = glob2re($pattern) if($pattern ne undef);
$spat = glob2re($subpat) if($subpat ne undef);
for my $name (lattr($obj), "last") {
my $short = $name;
$short =~ s/^obj_//;
next if($pat ne undef && $short !~ /$pat/i || ($name eq "last" && $pat eq undef));
if(viewable($obj,$name,$pat)) {
my $attr = mget($obj,$name);
if($name !~ /^obj_/ && db_set_ishash($obj,$name)) {
next if($pattern ne undef && $short !~ /$pat/i);
if($pattern eq undef) {
my $hash = db_hash_keys($obj,$name);
push(@out,color("h",$name) . ": [ " . $hash . " hash entries ]");
} else {
my $count = 0;
for my $key (db_hash_keys($obj,$name)) {
if($subpat eq undef || $key =~ /$spat/i) {
push(@out,color("h",$name)) if($count++ == 0);
push(@out," + " . color("h","$key") . " : " .
@{$$attr{value}}{$key});
}
}
}
} else {
if($name eq "obj_lastsite") {
$val = reconstitute($short,"","",short_hn(lastsite($obj)));
} elsif($name eq "obj_created_by") {
$val = reconstitute("first","","",short_hn($$attr{value}));
} elsif($name eq "last" && $pat ) {
$val = reconstitute($short,"","",lasttime($obj));
} else {
$val = reconstitute($short,
$$attr{type},
$$attr{glob},
$$attr{value},
list_attr_flags($attr),
$switch
)
}
if(defined $$switch{detail}) {
$val = color("h","Mod") . ":" . ts($$attr{created}). "," .
color("h","Created") . ":". ts($$attr{modified}) . "," .
color("h","Value") . ":" . $val;
}
push(@out,$val);
}
}
}
if($#out == -1 && $pattern ne undef) {
return "No matching attributes";
} else {
return join("\n",@out);
}
}
sub cmd_edit
{
my ($self,$prog) = (obj(shift),shift);
my (@out,$change,$txt,$new,$start,$type);
my ($left,$right) = bsplit(shift,"="); # parse text coming in
my ($object,$atr) = besplit($self,$prog,$left,"\/");
my ($search,$replace) = besplit($self,$prog,$right,",");
$search = trim($search);
$replace = trim($replace);
my $target = find($self,$prog,$object) ||
return err($self,$prog,"I don't see that here.");
!controls($self,$target) &&
return err($self,$prog,"Permission denied");
my $pat = glob2re($atr);
my $size = ansi_length($search);
for my $name (lattr($target)) {
if($name =~ /$pat/) {
if($search eq "\$") {
$txt = get($target,$name);
set($self, $prog, $target, $name, $txt . $replace);
push(@out,"Set - $name: $txt$replace");
} elsif($search eq "^") {
$txt = get($target,$name);
set($self, $prog, $target, $name, $replace . $txt);
push(@out,"Set - $name: $replace$txt");
} else {
$change = 0;
$new = undef;
$txt = ansi_init(get($target,$name));
for(my $i = 0, $start=0;$i <= $#{$$txt{ch}};$i++) {
if(ansi_remove(ansi_substr($txt,$i,$size)) eq $search) {
$change = 1;
if($start ne undef || $i != $start) {
$new .= ansi_substr($txt,$start,$i - $start);
}
$new .= ansi_clone($txt,$i,$replace);
$i += $size;
$start = $i;
last if($type);
}
}
if($start ne undef or $start >= $#{$$txt{ch}}) { # add left over
$new .= ansi_substr($txt,$start,$#{$$txt{ch}} - $start + 1);
}
if($change) {
push(@out,"Set - $name: $new");
set($self, $prog, $target, $name, $new);
}
}
}
}
push(@out,"No matching attribute") if($#out == -1);
necho(self => $self,
prog => $prog,
source => [ "%s",join("\n",@out) ],
);
}
sub cmd_ex
{
my ($self,$prog) = (obj(shift),shift);
my ($sub,$target,$desc,@exit,@content,$atr,$out);
my ($txt,$atr) = bsplit(shift,"/");
my ($atr,$sub) = besplit($self,$prog,$atr,":");
my $txt = evaluate($self,$prog,$txt);
my $switch = shift;
verify_switches($self,$prog,$switch,"raw","command","detail","brief") || return;
if($txt =~ /^\s*$/) {
$target = loc_obj($self);
} else {
$target = find($self,$prog,$txt) ||
return err($self,$prog,"I don't see that here. '$txt'");
}
my $perm = (controls($self,$target) || readonly($self,$target)) ? 1 : 0;
if($atr ne undef) {
if($perm) {
return necho(self => $self,
prog => $prog,
source => [ "%s",list_attr($target,$atr,$sub,$switch)],
);
}
return err($self,$prog,"Permission denied.");
}
if(hasflag($target,"ROOM") && !($perm || $$target{obj_id} == loc($self))) {
return necho(self => $self,
prog => $prog,
source => [ "%s is owned by %s.",
name($target),
name(owner($target))],
);
}
$out .= obj_name($self,$target,$perm);
my $flags = flag_list($target,1);
if($flags =~ /(PLAYER|OBJECT|ROOM|EXIT)/i) {
$out .= "\n" . color("h","Type") . ": $1 " .
color("h","Flags") . ": ";
my $rest = trim($` . $');
$rest =~ s/\s{2,99}/ /g;
$out .= $rest;
} else {
$out .= "\n" . color("h","Type") . ": *UNKNOWN* " .
color("h","Flags") . ": " . $flags;
}
$out .= "\n" .
nvl(get($$target{obj_id},"DESCRIPTION"),
"You see nothing special."
);
if($perm) {
my $owner = owner($target);
$out .= "\n" . color("h","Owner") . ": " . obj_name($self,$owner,$perm) .
" " . color("h","Key") . " : " . nvl(lock_uncompile($self,
$prog,
get($target,"OBJ_LOCK_DEFAULT")
),
"*UNLOCKED*"
) .
" " . color("h",ucfirst(conf("money_name_plural"))) .
": ". money($target,1);
my $parent = get($target,"obj_parent");
if($parent ne undef) {
$out .= "\n" . color("h","Parent") . ": " . obj_name($self,$parent);
}
}
$out .= "\n" . color("h","Created") . ": " . firsttime($target);
if(hasflag($target,"PLAYER")) {
my $last = lasttime($target);
if($last eq undef) {
$out .= "\nLast: N/A";
} else {
$out .= "\n" . color("h","Last") . ": ". $last;
}
}
if($perm && !$$switch{brief}) { # show attributes
my $attr = list_attr($target,$atr,$sub,$switch);
$out .= "\n" . $attr if($attr ne undef);
}
if($perm || $$target{obj_id} == loc($self)) {
for my $obj (lcon($target)) {
push(@content,obj_name($self,$obj));
}
if($#content > -1) {
$out .= "\n" . color("h","Contents") . ":\n" . join("\n",@content);
}
}
if(hasflag($target,"EXIT")) {
my $src = loc_obj($target);
if($src eq undef) {
$out .= "\nSource: N/A";
} else {
$out .= "\nSource: " . obj_name($self,$src);
}
my $dest = dest($target);
if($dest eq undef) {
$out .= "\nDestination: *UNLINKED*";
} else {
$out .= "\nDestination: " . obj_name($self,$dest);
}
}
for my $obj (lexits($target)) {
push(@exit,obj_name($self,$obj)) if(!hasflag($obj,"DARK") || $perm);
}
if($#exit >= 0) {
$out .= "\nExits:\n" . join("\n",@exit);
}
if($perm && (hasflag($target,"PLAYER") || hasflag($target,"OBJECT"))) {
$out .= "\n" . color("h","Home") . ": " .
obj_name($self,home($target),$perm) .
"\n" . color("h","Location") . ": " .
obj_name($self,loc_obj($target),$perm);
}
necho(self => $self,
prog => $prog,
source => [ "%s", $out ]
);
}
sub cmd_inventory
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my $out;
my $inv = [ lcon($self) ];
if($#$inv == -1) {
$out .= "You are not carrying anything.";
} else {
$out = "You are carrying:";
for my $i (0 .. $#$inv) {
$out .= "\n" . obj_name($self,$$inv[$i]);
}
}
necho(self => $self,
prog => $prog,
source => [ "%s\nYou have %s", $out,pennies($self) ],
);
}
#
# cmd_look
#
# Show the player what is around it.
#
sub cmd_look
{
my ($self,$prog,$txt,$switch,$always) = (obj(shift),shift,shift,shift,shift);
my ($flag,$desc,$target,@exit,@con,$out,$name,$attr);
my $owner = owner_id($self);
my $perm = hasflag($self,"WIZARD");
if($txt =~ /^\s*$/) {
$target = loc_obj($self);
return err($self,$prog,"I don't see that here.") if $target eq undef;
} elsif(!($target = find($self,$prog,evaluate($self,$prog,$txt)))) {
return err($self,$prog,"I don't see that here.");
}
$out = obj_name($self,$target);
if(!hasflag($target,"ROOM") && loc($self) == $$target{obj_id}) {
if(hasattr($target,"A_IDESC")) {
$out .= "\n" . evaluate($self,$prog,get($$target{obj_id},"A_IDESC"));
} elsif(hasattr($target,"idesc")) {
$out .= "\n" . evaluate($self,$prog,get($$target{obj_id},"idesc"));
}
} elsif(($desc = get($$target{obj_id},"DESCRIPTION")) && $desc ne undef) {
$out .= "\n" . evaluate($target,$prog,$desc);
} else {
$out .= "\nYou see nothing special.";
}
$attr = get($target,"CONFORMAT") if($$prog{hint} ne "WEB");
for my $obj (lcon($target)) {
if(!hasflag($obj,"DARK") &&
((hasflag($obj,"PLAYER") && hasflag($obj,"CONNECTED") ||
!hasflag($obj,"PLAYER"))) &&
$$obj{obj_id} ne $$self{obj_id}) {
if(!defined @db[$$obj{obj_id}]) { # corrupt list, fix
db_remove_list($target,"obj_content",$$obj{obj_id});
} elsif($attr ne undef) {
push(@con,"#" . $$obj{obj_id});
} else {
$out .= "\n" . color("h","Contents") . ":" if(++$flag == 1);
if($$prog{hint} eq "WEB") {
$out .= "\n<a href=/look/$$obj{obj_id}/>" .
obj_name($self,$obj,undef,1) . "</a>";
} else {
$out .= "\n" . obj_name($self,$obj);
}
}
}
}
if($attr ne undef) {
my $prev = get_digit_variables($prog); # save %0 .. %9
if(!set_digit_variables($self,$prog,"",join(' ',@con))) {# update to new
$out .= "\n" . managed_var_set_error("#-1");
} else {
$out .= "\n" . evaluate($target,$prog,$attr);
}
if(!set_digit_variables($self,$prog,"",$prev)) { # restore %0 .. %9
$out .= "\n" . managed_var_set_error("#-1");
}
}
for my $obj (lexits($target)) {
if($obj ne undef && !hasflag($obj,"DARK")) {
if($$prog{hint} eq "WEB") {
push(@exit,
"<a href=/look/" . dest($obj) . ">" .
first(name($obj)) .
"</a>"
);
} else {
push(@exit,first(name($obj)));
}
}
}
$out .= "\n" . color("h","Exits") . ":\n" .
join(" ",@exit) if($#exit >= 0); # add any exits
if($always) {
necho(self => $self,
prog => $prog,
source => ["%s",$out ],
always => 1
);
} else {
necho(self => $self,
prog => $prog,
source => ["%s",$out ]
);
}
generic_action($self,
$prog,
$target,
"describe",
[ "" ],
[ "" ]);
# run_attr($self,$prog,$target,"ADESCRIBE");
}
sub is_true
{
my $txt = shift;
if($txt =~ /^\s*(yes|ye|y|1)\s*$/) {
return 1;
} else {
return 0;
}
}
#
# generic function to run attributes if they exist
#
sub run_attr
{
my ($self,$prog,$target,$attr) = (obj(shift),shift,obj(shift),shift);
my @args = @_;
my $txt;
return 0 if(conf_true("safemode")); # nothing runs in safemode
$txt = get($target,$attr) ||
return 0;
mushrun(self => $self, # handle adesc
prog => $prog,
runas => $target,
invoker=> $self,
source => 0,
wild => [ @args ],
cmd => $txt
);
return 1;
}
sub cmd_pose
{
my ($self,$prog,$txt,$switch,$flag) = (obj(shift),shift,shift,shift,shift);
my $space = ($flag) ? "" : " ";
my $pose = colorize($self,$prog,cf_convert(evaluate($self,$prog,$txt)));
necho(self => $self,
prog => $prog,
source => [ "%s%s%s",name($self),$space,$pose ],
room => [ $self, "%s%s%s",name($self),$space,$pose ],
always => 1,
);
}
#
# cmd_set
# Set flags on objects or attributes. Setting attributes is no longer
# supported, use &attribute object = value synax.
#
sub cmd_set
{
my ($self,$prog) = (obj(shift),obj(shift));
return err($self,$prog,"Permission denied") if hasflag($self,"GUEST");
# find object / value
my ($obj,$value) = balanced_split(shift,"=",4);
# find attr name if provided
my ($name,$attr) = balanced_split($obj,"\/",4);
$attr = ansi_remove($attr);
my $switch = shift;
verify_switches($self,$prog,$switch,"quiet") || return;
my $target = find($self,$prog,evaluate($self,$prog,$name)) || # find target
return err($self,$prog,"I don't see that here");
!controls($self,$target) &&
return err($self,$prog,"Permission denied");
if($attr ne undef) { # attr flag
$attr = evaluate($self,$prog,$attr);
if(!isatrflag($value)) {
return err($self,$prog,"Invalid attribute flag");
} else {
necho(self => $self,
prog => $prog,
source => [ "%s", set_atr_flag($target,$attr,$value,0,$switch) ]
);
}
} else { # standard flag
necho(self => $self,
prog => $prog,
source => [ set_flag($self,$prog,$target,$value,0,$switch) ]
);
}
}
sub besplit
{
my ($self,$prog,$txt,$delim) = @_;
my ($first,$second) = balanced_split($txt,$delim,4);
return evaluate($self,$prog,$first), evaluate($self,$prog,$second);
}
sub bsplit
{
return balanced_split($_[0],$_[1],4);
}
#
# cmd_set2
# Set a user defined attribute.
#
sub cmd_set2
{
my ($self,$prog) = (obj(shift),obj(shift));
my ($obj,$append,$attr);
hasflag($self,"GUEST") && # don't let guests modify
return err($self,$prog,"Permission denied");
my ($txt,$value) = bsplit(shift,"=");
my $switch = shift;
verify_switches($self,$prog,$switch,"quiet","notrim") || return;
my $flag = shift;
my ($attr,$obj) = bsplit($txt," ");
my ($attr,$sub) = besplit($self,$prog,$attr,":");
$attr = ansi_remove($attr);
if($sub ne undef) {
# hash set
}
$obj = evaluate($self,$prog,$obj);
($obj,$append) = ($`,1) if($obj =~ /\s*\+$/); # flag appending
my $target = find($self,$prog,$obj) || # find target
return err($self,$prog,"I don't see that here. '$obj'");
if(!controls($self,$target)) { # nope
return err($self,$prog,"Permission denied");
} elsif(!good_atr_name($attr,$flag)) {
return err($self,$prog,"Thats not a good name for an attribute. '$attr'");
} elsif($sub ne undef && !good_atr_name($sub,$flag)) {
return err($self,$prog,"Thats not a good name for an sub attribute.");
} elsif($sub ne undef && !db_set_hashable($target,$attr)) {
return err($self,$prog,"That variable needs to be cleared before " .
"adding hash values.");
} elsif($sub ne undef) { # handle hash table entries
if($value eq undef) {
db_remove_hash($target,$attr,$sub); # delete entry
} else {
db_set_hash($target,$attr,$sub,$value); # add entry
}
necho(self => $self,
prog => $prog,
source => [ "Set." ],
);
} else {
if($append && get($target,$attr) ne undef) {
$append = get($target,$attr) . " ";
}
if(@{$$prog{cmd}}{source} == 0) {
set($self,
$prog,
$target,
$attr,
$append . trim(evaluate($self,$prog,$value)),
$$switch{quiet}
);
} elsif(defined $$prog{multi}) {
set($self,$prog,$target,$attr,join("\n",@{$$prog{multi}}));
} else {
set($self,$prog,$target,$attr,$append . trim($value),$$switch{quiet});
}
}
}
sub myisnum
{
my $num = shift;
if($num =~ /^\s*-?(\d+)\s*$/ && substr($1,0,1) ne "0") {
return 1;
} elsif($num =~ /^\s*-?(\d+)\.\d+\s*$/ && substr($1,1,1) ne "0") {
return 1;
} else {
return 0;
}
}
sub cf_convert
{
my $txt = shift;
my $out;
while($txt =~ /(\-{0,1})(\d+)(\.?)(\d*)(\s*)(F|C)/ && myisnum("$1$2$3$4")) {
$out .= $`;
$txt = $';
if (!(substr($`,-1) eq " " || $` eq undef)) {
$out .= "$1$2$3$4$5$6";
next;
}
if($6 eq "F") {
my $value = sprintf("%s%s%s%s%s (%.1fC)",
$1,$2,$3,$4,$6,("$1$2$3$4" - 32) * .5556);
$value =~ s/\.0//g;
$out .= $value;
} else {
my $value = sprintf("%s%s%s%s%s (%.1fF)",
$1,$2,$3,$4,$6,"$1$2$3$4" * 1.8 + 32);
$value =~ s/\.0$//g;
$out .= $value;
}
}
return $out . $txt;
}
sub colorize
{
my ($self,$prog,$txt) = @_;
my (%list,$out);
# instead of creating a list each word, just initialize it once
# per call.
for my $key (keys %connected) {
next if defined @connected{$key}->{raw} && @connected{$key}->{raw} != 0;
@list{lc(name(@connected{$key},1))} = @connected{$key}->{obj_id};
}
for my $obj (lcon(loc($self))) {
if(hasflag($obj,"PLAYER") && time()-lasttime($obj,1) < 604800) {
@list{lc(name($obj,1))} = $$obj{obj_id};
}
}
for my $word (safe_split($txt," ",1)) {
my $look = lc(ansi_remove($word));
my $before;
if($word =~ /^([=\s\.;,'"?!\(\[\]\-):]+)/) {
($before,$look) = ($1,$');
}
$before = " " . $before if($out ne undef);
if($look =~ /'s([=\s\.;,'"?!\(\):\[\]\-{}<>]*)$/&&defined @list{$`}) {
$out .= $before . name(@list{$`}) . "'s$1";
} elsif($look =~ /([=\s\.;,'"?!\(\):\[\]\-{}<>]+)$/&&defined @list{$`}) {
$out .= $before . name(@list{$`}) . "$1";
} elsif(defined @list{$look}) {
$out .= $before . name(@list{$look});
} else {
$out .= (($out ne undef) ? " " : "") . $word;
}
}
return $out;
}
#
# cmd_say
# Say something outloud to anyone in the room the player is in.
#
sub cmd_say
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my $out;
verify_switches($self,$prog,$switch,"noeval","eval") || return;
if(defined $$switch{noeval}) {
$out = $txt;
} elsif(defined $$switch{eval}) {
$out = evaluate($self,$prog,$txt);
} else {
$out = colorize($self,$prog,cf_convert(evaluate($self,$prog,$txt)));
}
necho(self => $self,
prog => $prog,
source => [ "You say, \"%s\"",$out],
room => [ $self, "%s says, \"%s\"",name($self),$out ],
always => 1
);
}
sub get_source_checksums
{
my $src = shift;
my (%data, $file,$pos);
my $ln = 0;
open($file,$0) || die("Unable to read $0");
for my $line (<$file>) {
$ln++;
if($_ eq "__END__") {
last;
} elsif($_ =~ /ALWAYS_LOAD/ || $_ !~ /#!#/) {
if($line =~ /^sub\s+([^ \n\r]+)\s*$/) {
$pos = $1;
@data{$pos} = { chk => Digest::MD5->new,
};
@{@data{$pos}}{chk}->add($line);
@{@data{$pos}}{src} .= qq[#line 0 "$pos"\n] . $line if $src;
@{@data{$pos}}{ln} .= $ln;
} elsif($pos ne undef && $line !~ /^\s*$/) {
@{@data{$pos}}{chk}->add($line);
@{@data{$pos}}{src} .= $line if $src;
# end of function
if($line =~ /^}\s*$/) {
@{@data{$pos}}{chk} = @{@data{$pos}}{chk}->hexdigest;
$pos = undef;
}
} elsif($pos ne undef) {
@{@data{$pos}}{src} .= "\n";
}
}
}
close($file);
for my $pos (keys %data) {
if(@{@data{$pos}}{chk} =~ /^Digest::MD5=SCALAR\((.*)\)$/) {
con("WARNING: Didn't find end to $pos -> '%s'\n",@{@data{$pos}}{chk});
}
}
return \%data;
}
sub reload_code
{
return if @info{shell};
my ($self,$prog,$sub) = @_;
my $count = 0;
my $prev = @info{source_prev};
my $curr = get_source_checksums(1);
if(!defined @info{reload_init}) {
@info{reload_init} = 1;
} else {
@info{reload_init} = 0;
}
for my $key (sort keys %$curr) {
if(($key eq $sub || $sub eq undef) &&
(@{$$prev{$key}}{chk} ne @{$$curr{$key}}{chk} || @info{reload_init})) {
$count++;
con("Reloading: %-40s",$key) if($self ne undef);
eval(@{$$curr{$key}}{src});
if($@) {
con("*FAILED*\n%s\n",renumber_code($@)) if($self ne undef);
@{$$curr{$key}}{chk} = -1;
if($self ne undef) {
necho(self => $self,
prog => $prog,
source => [ "Reloading %-40s *FAILED*", $key ]
);
}
} else {
if($self ne undef) {
con("Successful\n");
necho(self => $self,
prog => $prog,
source => [ "Reloading %-40s Success", $key ]
);
}
}
} else {
$$curr{$key}->{chk} = $$prev{$key}->{chk};
}
@{$$curr{$key}}{src} = undef;
}
@info{source_prev} = $curr;
load_modules();
initialize_functions();
initialize_commands();
initialize_ansi();
initialize_flags();
return $count;
}
#
# cmd_reload_code
# Let the code be reloaded from within the server. This should not be
# disabled, so ignore the conf option unless its set to -1.
#
sub cmd_reload_code
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my $count = 0;
if(!hasflag($self,"GOD")) {
return err($self,$prog,"Permission denied.");
} elsif(!module_enabled("md5")) {
return err($self,$prog,"#-1 \@RELOAD DISABLED (MD5 MODULE DISABLED)");
}
audit($self,$prog,"\@reload $txt");
$count = reload_code($self,$prog,$txt);
if($count == 0) {
necho(self => $self,
prog => $prog,
source => [ "No code to load, no changes made." ]
);
} else {
necho(self => $self,
prog => $prog,
source => [ "%s re-loads %d subrountines.\n",name($self),$count ]
);
}
}
#Player Name On For Idle WHO WOULD MAKE THE BEST PRESIDENT?
#Thoran 3d 23:55 1h
#Finrod 4d 04:28 12h
#Dream 4d 09:59 4d Groot
#Ivos 7d 14:03 2d
#Adrick 16d 18:35 0s
#RedWolf 63d 07:03 7h The Who
#1234567890123451234567890
#6 Players logged in, 16 record, no maximum.
sub nvl
{
return (@_[0] eq '') ? @_[1] : @_[0];
}
sub short_hn
{
my $addr = shift;
my ($val,$name) = (0,undef);
my $data;
if(conf("hostmask") =~ /^\s*(color|mask|colormask)\s*$/) {
if($addr =~ /^\s*(\d+)\.(\d+)\.(\d+)\.(\d+)\s*$/) {
$addr = "$1.$2.*.*";
} elsif($addr =~ /[A-Za-z]/ && $addr =~ /\.([^\.]+)\.([^\.]+)$/) {
$addr = "*.$1.$2";
} else {
$addr = "*" . substr($addr,length($addr) * .3);
}
return $addr if conf("hostmask") eq "mask";
for my $i (split(//,$addr)) {
$val += ord($i);
}
if(!defined @info{short_hn}) {
$data = {};
for my $key (sort keys %ansi_name) {
if(@ansi_name{$key} !~
/^(15|195|222|223|224|230|253|255|118|187)$/) {
if($key =~ /^light/) {
# skip
} elsif($key =~ /^deep(.*)([^\d]+)/) {
$$data{$1} = $key;
} elsif($key =~ /^([^\d]+)/) {
$$data{$1} = $key;
}
}
}
@info{short_hn} = [ sort values(%$data) ];
}
$data = @info{short_hn};
if($val > $#$data) {
$name = @$data[$val % $#$data];
} else {
$name = @$data[$#$data % $val];
}
if(conf("hostmask") eq "colormask") {
return "\e[38;5;@ansi_name{$name}m$addr\e[0m";
} elsif($name =~ /\d+$/) {
return "\e[38;5;@ansi_name{$name}m$`\e[0m";
} else {
return "\e[38;5;@ansi_name{$name}m$name\e[0m";
}
} else {
return $addr;
}
}
#
# cmd_who
# Show the users who is conected. There is a priviledged version
# and non-privileged version. The DOING command is just a non-priviledged
# version of the WHO command.
#
sub cmd_who
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
necho(self => $self,
prog => $prog,
source => [ "%s", who($self,$prog,$txt) ]
);
}
sub cmd_DOING
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
necho(self => $self,
prog => $prog,
source => [ "%s", who($self,$prog,$txt,1) ]
);
}
sub who
{
my ($self,$prog,$txt,$flag) = (obj(shift),shift,shift,shift);
my ($max,$online,@who,$idle,$count,$out,$extra,$hasperm,$name) = (2,0);
my ($nomushrun,$readonly) = (0,0);
if(ref($self) eq "HASH") {
$hasperm = ($flag || !hasflag($self,"WIZARD")) ? 0 : 1;
} else {
$hasperm = 0;
}
# query the database for connected user, location, and socket
# details.
$readonly = 1 if(defined $$prog{read_only});
$nomushrun = 1 if(defined $$prog{nomushrun});
$$prog{read_only} = 1;
$$prog{nomushrun} = 1;
for my $key (sort {@{@connected{$b}}{start} <=> @{@connected{$a}}{start}}
keys %connected) {
my $hash = @connected{$key};
next if $$hash{raw} != 0;
# only list users that start with provided text
if($$hash{obj_id} ne undef) {
if(($txt ne undef &&
lc(substr(name($hash,1),0,length($txt))) eq lc($txt)) ||
$txt eq undef) {
if(length(loc($hash)) + 1 > $max) {
$max = length(loc($hash)) + 1;
}
push(@who,$hash);
}
$online++;
}
}
# show headers for normal / wiz who
if($hasperm) {
$out .= sprintf("%-15s%10s%5s %-*s %-4s %s\r\n","Player Name","On For",
"Idle",$max,"Loc","Port","Hostname");
} else {
$out .= sprintf("%-15s%10s%5s %s\r\n","Player Name","On For","Idle",
defined @info{"doing_header"} ?
@info{"doing_header"} : "\@doing"
);
}
$max = 3 if($max < 3);
# generate detail for every connected user
for my $hash (@who) {
# determine idle details
if(defined $$hash{last}) {
$idle = date_split(time() - @{$$hash{last}}{time});
} else {
$idle = { max_abr => 's' , max_val => 0 };
}
# determine connect time details
my $online = date_split(time() - fuzzy($$hash{start}));
if($$online{max_abr} =~ /^(M|w|d)$/) {
$extra = sprintf("%4s",$$online{max_val} . $$online{max_abr});
} else {
$extra = " ";
}
if($$prog{hint} eq "WEB") {
$name = name($hash);
$name = "<a href=look/$$hash{obj_id}>$name</a>" .
(" " x (15 - ansi_length($name)));
} else {
$name = ansi_substr(name($hash),0,15);
$name = $name . (" " x (15 - ansi_length($name)));
}
# show connected user details
if($hasperm) {
$out .= sprintf("%s%4s %02d:%02d %4s %-*s %-4s %s%s\r\n",
$name,$extra,$$online{h},$$online{m},$$idle{max_val} .
$$idle{max_abr},$max,"#" . loc($hash),$$hash{port},
short_hn($$hash{hostname}),
($$hash{site_restriction} == 69) ? " [HoneyPoted]" : ""
);
} elsif($$hash{site_restriction} != 69) {
my $doing = evaluate($self,$prog,$$hash{obj_doing});
$doing =~ s/\r|\n//g;
$out .= sprintf("%s%4s %02d:%02d %4s %s\r\n",$name,$extra,
$$online{h},$$online{m},$$idle{max_val} . $$idle{max_abr},
ansi_substr($doing,0,44));
}
}
$out .= sprintf("%d Players logged in\r\n",$online); # show totals
delete @$prog{read_only} if !$readonly;
delete @$prog{nomushrun} if !$nomushrun;
return $out;
}
sub sweep_obj
{
my ($self,$obj,$out) = @_;
my @list;
for my $obj (lcon($obj)) {
delete @list[0 .. $#list];
push(@list,"listening") if(hasflag($obj,"LISTENER"));
push(@list,"commands") if(!hasflag($obj,"NO_COMMAND"));
push(@list,"player") if(hasflag($obj,"PLAYER"));
push(@list,"connected") if(hasflag($obj,"CONNECTED"));
if($#list >= 0) {
push(@$out," " . obj_name($self,$obj) . " is listening. [" .
join(" ",@list) . "]");
}
}
}
sub cmd_sweep
{
my ($self,$prog,$txt,$switch) = (obj(shift),shift,shift,shift);
my @out;
push(@out,"Sweeping location...");
sweep_obj($self,loc($self),\@out);
push(@out,"Sweeping inventory...");
sweep_obj($self,$self,\@out);
push(@out,"Sweep Complete.");
necho(self => $self,
prog => $prog,
source => [ "%s", join("\n",@out) ]
);
}
sub atr_case
{
return atr_hasflag(shift,shift,"CASE");
}
sub atr_hasflag
{
my ($obj,$atr,$flag) = (obj(shift),shift,shift);
if(ref($obj) ne "HASH" || !defined $$obj{obj_id} || !valid_dbref($obj)) {
return undef;
}
my $attr = mget($obj,$atr);
if($attr eq undef ||
!defined $$attr{flag} ||
!defined $$attr{flag}->{lc($flag)}) {
return 0;
} else {
return 1;
}
}
sub latr_regexp
{
my ($obj,$type) = (obj(shift),shift);
my @result;
return undef if !valid_dbref($obj);
for my $name ( lattr($obj) ) {
my $attr = mget($obj,$name);
if(defined $$attr{type} && defined $$attr{regexp}) {
if(($type == 1 && $$attr{type} eq "\$") ||
($type == 2 && $$attr{type} eq "^") ||
($type == 3 && $$attr{type} eq "!")) {
push(@result,{ atr_regexp => $$attr{regexp},
atr_value => $$attr{value},
atr_name => $name,
atr_owner => $$obj{obj_id}
}
);
}
}
}
return @result;
}
sub lcon
{
return if $_[0] eq undef; # no arguments, nothing to do
my $object = obj_nocheck(shift);
my @result;
my $attr = mget($object,"obj_content");
if($attr eq undef) {
return @result;
} else {
for my $id ( keys %{$$attr{value}} ) {
push(@result,obj($id));
}
return @result;
}
}
sub lexits
{
my $object = obj_nocheck(shift);
my @result;
my $attr = mget($object,"obj_exits");
if($attr eq undef) {
return @result;
} else {
for my $id ( keys %{$$attr{value}} ) {
push(@result,obj($id));
}
return @result;
}
}
sub money
{
my ($target,$flag) = (obj(shift),shift);
$target = owner($target) if !$flag;
return 0 if($target eq undef);
return get($target,"obj_money");
}
#
# name
# Return the name of the object from the database if it hasn't already
# been pulled.
#
sub name
{
my ($target,$flag,$self,$prog) = (obj(shift),shift,shift,shift);
if($flag) {
return get($target,"obj_name");
} elsif(get($target,"obj_cname") ne undef) {
return get($target,"obj_cname");
} elsif($prog ne undef && $$target{obj_id} eq conf("webuser")) {
# return the hostname of the webuser object when coming from a http call
if(defined $$prog{hint} && $$prog{hint} eq "WEB" &&
defined $$prog{user} && defined @{$$prog{user}}{hostname}) {
return @{$$prog{user}}{hostname}
} else {
return get($target,"obj_name");
}
} else {
return get($target,"obj_name");
}
}
sub flag_list
{
my ($obj,$flag) = (obj($_[0]),uc($_[1]));
my (@list,$array,$connected);
$flag = 0 if !$flag;
my $attr = mget($obj,"obj_flag");
if($attr eq undef) {
return undef;
} else {
my $hash = $$attr{value};
# connected really isn't a flag, but should be
for my $key (sort {@flag{uc($a)}->{ord} <=> @flag{uc($b)}->{ord}}
keys %$hash) {
push(@list,$flag ? uc($key) : flag_letter($key));
}
if(defined $$hash{player} && defined @connected_user{$$obj{obj_id}}) {
push(@list,$flag ? "CONNECTED" : 'c');
}
return join($flag ? ' ' : '',@list);
}
}
#
# owner
# Return the owner of an object. Players own themselves for coding
# purposes but are displayed as being owned by #1.
#
sub owner
{
my $obj = obj(shift);
my $owner;
if(!valid_dbref($obj)) {
# printf("owner: Invalid dbref\n");
return undef;
} elsif(hasflag($obj,"PLAYER")) {
# printf("owner: player\n");
return $obj;
} else {
my $owner = get($obj,"obj_owner");
# printf("owner: obj_owner -> '%s'\n",$owner);
if($owner eq undef) {
return undef;
} else {
return obj($owner);
}
}
}
#
# hasflag
# Return if an object has a flag or not
#
sub hasflag
{
my ($target,$name) = (obj(shift),shift);
my $val;
if(!valid_dbref($target)) {
return 0;
} elsif($name eq "CONNECTED" || $name eq "c") { # not stored in db
return (defined @connected_user{$$target{obj_id}}) ? 1 : 0;
}
my $prev = $target;
$target = owner($target) if($name eq "WIZARD" || $name eq "GOD");
my $attr = mget($target,"obj_flag");
return 0 if(!defined $$attr{value}); # no flags at all
my $flag = $$attr{value};
if(uc($name) eq "WIZARD") { # all gods are wizards
return (defined $$flag{wizard}||defined $$flag{god}) ? 1 : 0;
} elsif(length($name) == 1) { # look for flag letter
for my $key (keys %$flag) {
if(defined @flag{uc($key)} && @{@flag{uc($key)}}{letter} eq $name) {
return 1; # must match case
}
}
return 0;
} elsif(defined $$flag{lc($name)}) { # flag name match
return 1;
} else {
return 0;
}
}
sub or_flag
{
my ($obj,@flags) = @_;
for my $flag (@flags) {
return 1 if(hasflag($obj,$flag));
}
return 0;
}
sub and_flag
{
my ($obj,@flags) = @_;
for my $flag (@flags) {
return 0 if(!hasflag($obj,$flag));
}
return 1;
}
sub dest
{
my $obj = obj(shift);
return get($obj,"obj_destination");
}
sub home
{
my $obj = obj(shift);
my $home = get($obj,"obj_home");
if(valid_dbref($home)) { # use object's home
return $home;
} elsif(valid_dbref(conf("starting_room")) &&
hasflag(conf("starting_room"),"ROOM")) {
# use starting_room
db_set($obj,"obj_home",conf("starting_room"));
return conf("starting_room");
} else { # default to first availible room
my $first = first_room();
db_set($obj,"obj_home",$first);
return $first;
}
}
sub loc_obj
{
my $obj = obj(shift);
my $loc = get($obj,"obj_location");
return ($loc eq undef) ? undef : obj($loc);
}
sub lattr
{
my $obj = obj(shift);
return () if(!valid_dbref($obj));
my $hash = dbref($obj);
return ($hash eq undef) ? undef : (sort keys %$hash);
}
#
# ansi_debug
# Convert an ansi string into something more readable.
#
sub ansi_debug
{
my $txt = shift;
$txt =~ s/\e/<ESC>/g;
return $txt;
}
#
# ansi_char
# Returns one character of the current string. Due to the nature of the
# ansi functions, this will only return characters not in ansi character
# strings. While this is silly to use a function to do this, this helps
# abstract the data set for situations in which the ansi functions are
# replaced by standard string functions.
#
sub ansi_char
{
my ($data,$pos) = @_;
return @{$$data{ch}}[$pos];
}
sub is_ansi_string
{
my $txt = shift;
if(ref($txt) ne "HASH" ||
!defined $$txt{ch} ||
!defined $$txt{snap} ||
!defined $$txt{code}) {
return 0;
} else {
return 1;
}
}
sub ansi_reset
{
my ($data,$pos) = @_;
my $string = (is_ansi_string($data)) ? $data : ansi_init($data);
printf("Ansi_reset: returning\n") if $pos < 0;
return $string if $pos < 0; # sanity check
my $code = $$string{code};
my $array = $$code[$pos];
# check to see if the last code is a reset, or no codes at all
if($#$array == -1 || $$array[$#$array] ne "\e[0m") {
push(@$array,"\e[0m");
}
return $string;
}
#
# ansi_add
# Add a character or escape code to the data array. Every add of a
# character results in a new element, escape codes are added to existing
# elements as long as a character has not been added yet. The ansi state
# is also kept track of here.
#
sub ansi_add
{
my ($data,$type,$txt) = @_;
my $ch = $$data{ch}; # make things more readable
my $code = $$data{code};
my $snap = $$data{snap};
if($#$ch == -1 || $$ch[$#$ch] ne undef) {
$$ch[$#$ch+1] = undef;
$$code[$#$ch] = [];
$$snap[$#$ch] = [];
}
if($type) {
for my $c (split(//,$txt)) { # add multiple characters
$$ch[ $#$ch + ((@$ch[$#$ch] ne undef) ? 1 : 0) ] = $c;
@$code[$#$ch] = [] if(!defined @$code[$#$ch]);
@$snap[$#$ch] = [ @{@$data{state}} ];
}
} else { # add escape sequence
push(@{$$code[$#$ch]},$txt);
if($txt eq "\e[0m") {
$$data{state} = [];
} else {
push(@{$$data{state}},$txt);
}
}
}
#
# ansi_init
# Read in a string and convert it into a data structure that can be
# easily parsed / modified, i hope.
#
# {
# code => [ [ array of arrays containing escape codes ] ]
# ch => [ Array containing each character one by one ]
# snap => [ [ array of arrays containing all active escape codes
# at the time the character was encountered ] ]
# state=> [ internal, current state of active escape does ]
# }
#
sub ansi_init
{
my $str = shift;
my $data = { ch => [], code => [], state => [], snap => [] };
while($str =~ /\e\[([\d;]*)([a-zA-Z])/) {
$str = $';
ansi_add($data,1,$`) if $` ne undef;
ansi_add($data,0,"\e[$1$2");
}
ansi_add($data,1,$str) if($str ne undef);
return $data;
}
#
# ansi_clone
# Clone the ansi escape codes at a particular position to the new
# string.
#
sub ansi_clone
{
my ($str,$pos,$txt) = @_;
if(ref($str) ne "HASH") {
$str = ansi_init($str);
}
my $snap = $$str{snap};
if($#$snap >= 0 && $#$snap > $pos) {
return join('',@{@$snap[$pos]}) . $txt . "\e[0m";
} else {
return $txt;
}
}
#sub ansi_debug
#{
# my @array = @_;
# my $result;
#
# for my $i (0 .. $#array) {
# $result .= "<ESC>" . substr(@array[$i],1);
# }
# return $result;
#}
#
# ansi_string
# Take ansi data structure and return
# type => 0 : everything but the escape codes
# type => 1 : original string [including escape codes]
#
sub ansi_string
{
my ($data,$type) = @_;
my $buf;
for my $i (0 .. $#{$$data{ch}}) {
$buf .= join('', @{@{$$data{code}}[$i]}) if($type);
$buf .= @{$$data{ch}}[$i];
}
return $buf;
}
#
# ansi_substr
# Do a substr on a string while preserving the escape codes.
#
# no-ansi flag : do not copy over escape sequences
#
sub ansi_substr
{
my ($txt,$start,$count,$noansi) = @_;
my ($result,$data);
my $last = -1;
if(ref($txt) eq "HASH") {
$data = $txt;
} else {
$data = ansi_init($txt);
}
$start = 0 if($start !~ /^\s*\d+\s*$/); # sanity checks
if($count !~ /^\s*\d+\s*$/) {
$count = ansi_length($txt);
} else {
$count += $start;
}
return undef if($start < 0); # no starting point
# loop through each "character" w/attached ansi codes
for(my $i = $start;$i < $count && $i <= $#{$$data{ch}};$i++) {
if(!$noansi) {
my $code=join('',@{@{$$data{($i == $start) ? "snap" : "code"}}[$i]});
$result .= $code . @{$$data{ch}}[$i];
} else {
$result .= @{$$data{ch}}[$i];
}
$last = $#{@{$$data{snap}}[$i]};
}
# are attributes turned on on last character? if so, reset them.
return $result . (($last == -1) ? "" : (chr(27) . "[0m"));
}
#
# ansi_length
# Return the length of a string without counting all those pesky escape
# codes.
#
sub ansi_length
{
my $txt = shift;
my $data = shift;
if(ref($txt) eq "HASH") { # already inited txt?
$data = $txt;
} else {
$data = ansi_init($txt);
}
if($#{$$data{ch}} == -1) { # empty
return 0;
} elsif(@{$$data{ch}}[-1] eq undef) { # last char pos empty?
return $#{$$data{ch}};
} else {
return $#{$$data{ch}} + 1; # last char populated
}
}
#
# ansi_post_match
# Match up $1 .. $9 with the original string.
#
sub ansi_post_match
{
my ($data,$pat,@arg) = @_;
my ($pos,$wild,@wildcard) = (0,0);
while($pat =~ /(\*|\?)/ && $wild < 10) {
$pat = $';
$pos += length($`) if($` ne undef);
push(@wildcard,ansi_substr($data,$pos,length(@arg[$wild])));
$pos += length(@arg[$wild]);
$wild++;
}
if($#wildcard > 8) {
delete @wildcard[ 9 .. $#wildcard];
} elsif($#wildcard < 8) {
for my $i (($#wildcard+1) .. 8) {
push(@wildcard,undef);
}
}
return @wildcard
}
#
# ansi_match
#
# Match a string with a glob pattern and return the result containing
# escape sequences. Since string matching can't be accurately done with
# escape codes in them the following is done:
#
# 1. Perform a match after removing all escape sequences.
# 2. Pull the glob pattern apart to seperate wild cards
# from non-wildcards.
# 3. Use the results from the match without escape sequences
# to determine how to tear apart the original string
# containing the escape sequences. This will allow the code
# to return string segments with any escape sequences without
# having to write a full pattern match algorithm.
#
sub ansi_match
{
my ($txt,$pattern) = @_;
my $pat = glob2re($pattern); # convert pat to regexp
my $str = ansi_init($txt);
my $non = ansi_remove($txt);
if($non =~ /$pat/) { # matched
return ansi_post_match($str,$pattern,$1,$2,$3,$4,$5,$6,$7,$8,$9);
} else {
return (); # no match
}
}
sub color
{
my ($codes,$txt,$type) = @_;
my $pre;
#
# conversion table for letters to numbers used in escape codes as defined
# by TinyMUSH, or maybe TinyMUX.
#
my %ansi = (
x => 30, X => 40, r => 31, R => 41, g => 32, G => 42, y => 33,
Y => 43, b => 34, B => 44, m => 35, M => 45, c => 36, C => 46,
w => 37, W => 47, u => 4, i => 7, h => 1, f => 5, n => 0
);
for my $ch (split(//,$codes)) {
$pre .= "\e[@ansi{$ch}m" if(defined @ansi{$ch});
}
if($type eq 1) {
return $pre;
} else {
return $pre . $txt . "\e[0m";
}
}
#
# ansi_remove
# remove any escape codes from the string
#
sub ansi_remove
{
# my $txt = ansi_init(shift);
# return ansi_print($txt,0);
my $txt = shift;
$txt =~ s/\e\[[\d;]*[a-zA-Z]//g;
return $txt;
}
sub space_scan
{
my ( $data, $start )= @_;
for my $i ( $start .. $#{$$data{ch}}) {
return $i if(@{$$data{ch}}[$i] ne " ");
}
return $#{$$data{ch}};
}
sub ansi_wrap
{
my $rules = {
max_x => 79,
max_word => 25,
};
my $txt = ansi_init(shift);
my $str = $$txt{ch};
my ($start,$word_end,$i,$out) = (0,0,0,undef);
while($i < $#$str) {
if($i - $start >= $$rules{max_x}) {
if($i - $word_end >= $$rules{max_word}) { # split at screen
$out .= ansi_substr($txt,$start,$i-$start) . "\n";
$i = space_scan($txt,$i);
$start = $i;
} else { # split at word
$out .= ansi_substr($txt,$start,$word_end-$start) . "\n";
$i = space_scan($txt,$word_end + 1);
$start = $i;
}
$word_end = $start + 1;
} elsif($$str[$i] eq " " && ($i == 0 || $$str[$i-1] ne " ")) {
$word_end = $i;
$i++;
} else {
$i++;
}
}
if($start < $#$str) {
$out .= ansi_substr($txt,$start,$#$str);
}
return $out;
}
#
# ansi_trim
# Remove leading and trailing spaces from any string while ignoring
# vt100 escape codes.
#
sub ansi_trim
{
my ($start, $end);
my $txt = (ref($_) eq "HASH") ? shift : ansi_init(shift);
for my $i ( 0 .. $#{$$txt{ch}}) { # find leading spaces
if(@{$$txt{ch}}[$i] ne " ") {
$start = $i;
last;
}
}
for my $i ( reverse 0 .. $#{$$txt{ch}}) { # find trailing spaces
if(@{$$txt{ch}}[$i] ne " ") {
$end = $i;
last;
}
}
if($start eq undef || $end eq undef) {
return undef;
} else { # let ansi_substr do the work
return ansi_substr($txt,$start,$end - $start + 1);
}
}
# open(FILE,"iweb") ||
# die("Could not open file iweb for reading");
#
# while(<FILE>) {
# s/\r|\n//g;
# # if(/This/) {
# printf("%s\n",ansi_wrap($_));
# # }
# }
# close(FILE);
#my $str = "[32;1m|[0m [1m[34;1m<*>[0m [32;1m|[0m [31;1mA[0m[31ms[0m[31mh[0m[31me[0m[31mn[0m[33;1m-[0m[31;1mS[0m[31mh[0m[31mu[0m[31mg[0m[31mar[0m [32;1m|[0m Meetme(#260V) [32;1m|[0m";
#for my $i (0 .. 78) {
# printf("%0d : '%s'\n",$i,ansi_length(ansi_substr($str,$i,7)));
#}
#my $str = decode_base64("CiAgICAtLS0tLS0tLS0tLS0tLS0gICAgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLQogMSB8LnwufC58LnwufC58LnwufCAgfCAgICAgICBUYW86IFRoaXMgQWluJ3QgT3RoZWxsbyAgICAgICB8CiAyIHwufC58T3xPfC58LnwufC58ICB8ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIHwKIDMgfC58I3xPfE98I3xPfC58LnwgIHwgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgfAogNCB8LnwufCN8T3xPfC58LnwufCAgfCAgIzogV2ViT2JqZWN0ICAgICAgICBoYXMgIDYgcGllY2VzICB8CiA1IHwufCN8T3xPfE98T3wufC58ICB8ICBPOiAbWzM0bUFkcmljaxtbMG0bW20gICAgICAgICAgIGhhcyAxMSBwaWVjZXMgIHwKIDYgfC58LnwufCN8LnwjfC58LnwgIHwgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgfAogNyB8LnwufC58LnwufC58LnwufCAgfCAgICoqKiBJdCBpcyBXZWJPYmplY3QncyB0dXJuICoqKiAgICB8CiA4IHwufC58LnwufC58LnwufC58ICB8ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIHwKICAgIC0tLS0tLS0tLS0tLS0tLSAgICAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tCiAgICAxIDIgMyA0IDUgNiA3IDhd");
# printf("%s\n",ansi_debug($str));
#my $a = ansi_init($str);
#printf("%s\n",$str);
#printf("%s\n",lord(ansi_string($a,1)));
#printf("SUB:%s\n",ansi_substr($a,11,1));
# flag definitions
# letter => 1 letter unique abbrivation for flag
# perm => flags required to set this flag
# type => 1 for object flag, 2 for attribute flag
# ord => display flag order for vague compt w/tinymush.
# target_type => object must have these flags to get the flag
# i.e. objects can not be set wizard, but players can.
#
sub initialize_flags
{
delete @flag{keys %flag};
@flag{ANYONE} ={ letter => "+", type => 1, ord=>99 };
@flag{GOD} ={ letter => "G",
perm => "GOD",
type => 1,
ord => 5,
target_type => "PLAYER"
};
@flag{WIZARD} ={ letter => "W",
perm => "GOD",
type => 1,
ord => 6,
target_type => "PLAYER"
};
@flag{CHOWN_OK} ={ letter => "C",
perm => "!GUEST",
type => 1,
ord => 28,
target_type => "!PLAYER"
};
@flag{HALTED} ={ letter => "H",
perm => "",
type => 1,
ord => 29,
target_type => ""
};
@flag{COMPAT} ={ letter => "*",
perm => "PLAYER",
type => 1,
ord => 30,
target_type => ""
};
@flag{PLAYER} ={ letter => "P", perm => "GOD", type => 1, ord=>1 };
@flag{ROOM} ={ letter => "R", perm => "GOD", type => 1, ord=>2 };
@flag{EXIT} ={ letter => "e", perm => "GOD", type => 1, ord=>3 };
@flag{OBJECT} ={ letter => "o", perm => "GOD", type => 1, ord=>4 };
@flag{LISTENER} ={ letter => "M", perm => "!GUEST", type => 1, ord=>7 };
@flag{SOCKET_PUPPET}={ letter => "S", perm => "WIZARD", type => 1, ord=>8 };
@flag{PUPPET} ={ letter => "p", perm => "!GUEST", type => 1, ord=>9 };
@flag{GUEST} ={ letter => "g", perm => "WIZARD", type => 1, ord=>10 };
@flag{SOCKET_INPUT} ={ letter => "I", perm => "WIZARD", type => 1, ord=>11 };
@flag{DARK} ={ letter => "D", perm => "!GUEST", type => 1, ord=>12 };
@flag{CASE} ={ letter => "C", perm => "!GUEST", type => 2, ord=>13 };
@flag{NOSPOOF} ={ letter => "N", perm => "!GUEST", type => 1, ord=>14 };
@flag{VERBOSE} ={ letter => "v", perm => "!GUEST", type => 1, ord=>15 };
@flag{MONITOR} ={ letter => "M", perm => "WIZARD", type => 1, ord=>16 };
@flag{SQL} ={ letter => "Q", perm => "WIZARD", type => 1, ord=>17 };
@flag{ABODE} ={ letter => "A", perm => "!GUEST", type => 1, ord=>18 };
@flag{LINK_OK} ={ letter => "L", perm => "!GUEST", type => 1, ord=>19 };
@flag{ENTER_OK} ={ letter => "E", perm => "!GUEST", type => 1, ord=>20 };
@flag{VISUAL} ={ letter => "V", perm => "!GUEST", type => 3, ord=>21 };
@flag{ANSI} ={ letter => "X", perm => "!GUEST", type => 1, ord=>22 };
@flag{LOG} ={ letter => "l", perm => "WIZARD", type => 1, ord=>23 };
@flag{NO_COMMAND} ={ letter => "n", perm => "!GUEST", type => 1, ord=>24 };
@flag{GOING} ={ letter => "g", perm => "GOD", type => 1, ord=>25 };
@flag{IMPORTED} ={ letter => "I", perm => "GOD", type => 1, ord=>26 };
@flag{JUMP_OK} ={ letter => "J", perm => "!GUEST", type => 1, ord=>27 };
}
#
# db_version
# Define which version of the database the mush is dumping. This
# should be incremented when anything changes.
#
# 1.5: Introduced attribute timestamps
#
sub db_version
{
return "3.0";
}
sub dirty_bit
{
my ($obj,$atr) = @_;
@info{dirty} = {} if !defined @info{dirty};
my $dirty = @info{dirty};
my $obj = $$obj{obj_id} if(ref($obj) eq "HASH");
if($atr eq undef) {
$$dirty{$obj} = { destroyed => 1 }; # deleted attribute
} else {
# new object in dirty bit, or object no longer deleted.
if(!defined $$dirty{$obj} || ref($$dirty{$obj}) ne "HASH") {
$$dirty{$obj} = {};
}
$$dirty{$obj}->{"A_$atr"} = scalar localtime; # don't allow overwrite of deleted 'flag'
}
}
sub hasparent
{
my $obj = obj(shift);
my $parent = mget($obj,"obj_parent");
return ($parent ne undef && valid_dbref($parent)) ? 1 : 0;
}
sub parent
{
my $obj = obj(shift);
my $parent = get($obj,"obj_parent");
$parent =~ s/^\s*#\s*//g;
return ($parent ne undef && valid_dbref($parent)) ? $parent : undef;
}
sub hasattr
{
my ($obj,$attr,$parent,$debug) = (obj(shift),ansi_remove(shift),shift,shift);
my $data;
# handle if object exists
$attr = "description" if lc($attr) eq "desc";
my $data = dbref($obj);
return undef if $data eq undef;
$parent = 1 if(lc($parent) eq "parent");
# handle if attribute exits on object
printf("hasattr: '%s'\n",$$data{obj_id}) if $debug;
if(!$parent && defined $$data{lc($attr)}) { # check if attribute exists
return 1; # exists
} elsif($parent && hasparent($obj)) { # check parent?
my $parent = parent($obj);
my $data = dbref($parent);
return (defined $$data{lc($attr)}) ? 1 : 0;
} else {
return 0; # doesn't exist
}
}
#
# mget
# Get a record from the memory database. This will return the hash that
# contains the data. You'll need to look at the value hash item for the
# actual contents of the attribute. The attribute flag(s) are also
# accessible here.
#
# This function also honors the backup mode and @deleted by grabbing
# the data from either @delta (contains any changes) or @db (actual
# database). @deleted defines if the object was deleted while the
# database was in backup mode.
#
sub mget
{
my ($obj,$attr,$debug) = (obj(shift),ansi_remove(shift),shift);
my $data;
# handle if object exists
$attr = "description" if lc($attr) eq "desc";
if(defined @info{backup_mode} && @info{backup_mode}) {
if(defined @deleted{$$obj{obj_id}}) { # obj was deleted
return undef;
} elsif(defined @delta[$$obj{obj_id}]) { # obj changed during backup
$data = @delta[$$obj{obj_id}];
} elsif(defined @db[$$obj{obj_id}]) { # in actual db
$data = @db[$$obj{obj_id}];
} else { # obj doesn't exist
return undef;
}
} elsif(defined @db[$$obj{obj_id}]) { # non-backup mode object
$data = @db[$$obj{obj_id}];
} else {
return undef; # obj doesn't exist
}
# handle if attribute exits on object
if(!defined $$data{lc($attr)}) { # check if attribute exists
return undef; # nope
} else {
return $$data{lc($attr)}; # exists
}
}
#
# db_readonly
#
# There are some situations where the program shouldn't modify the
# database. Determine what those are.
#
sub db_readonly
{
return 0 if !defined @info{prog}; # no program info, assume RW
if(defined @info{prog}->{read_only}) { # program is set RO
return 1;
} else {
return 0; # Read/Write
}
}
#
# db_delete
# Clean up an object if needed. This could cause problems if
# used to delete an object but currently it is only used to
# clean up an object. This means there will always be a new
# object in @delta... or the code crashed and burned and its
# okay to use @db.
#
sub db_delete
{
my $obj = obj(shift);
return if db_readonly();
dirty_bit($obj); # mark object dirty
if(defined @info{backup_mode} && @info{backup_mode}) { # in backup mode
delete @delta[$$obj{obj_id}] if(defined @delta[$$obj{obj_id}]);
@deleted{$$obj{obj_id}} = 1;
} elsif(defined @db[$$obj{obj_id}]) { # non-backup mode delete
delete @db[$$obj{obj_id}];
}
}
#
# dbref_mutate
# Get an object's hash table reference and make a copy of it in @delta
# if it already hasn't. This should only be called if the object is
# going to be changed.
#
sub dbref_mutate
{
my $obj = obj(shift);
if(defined @info{backup_mode} && @info{backup_mode}) {
if(defined @deleted{$$obj{obj_id}}) {
return undef;
} elsif(defined @delta[$$obj{obj_id}] &&
ref(@delta[$$obj{obj_id}]) eq "HASH") {
return @delta[$$obj{obj_id}];
} elsif(defined @db[$$obj{obj_id}] && ref(@db[$$obj{obj_id}]) eq "HASH") {
@delta[$$obj{obj_id}] = dclone(@db[$$obj{obj_id}]);
return @delta[$$obj{obj_id}];
} else {
return undef;
}
} elsif(defined @db[$$obj{obj_id}] && ref(@db[$$obj{obj_id}]) eq "HASH") {
return @db[$$obj{obj_id}];
} else {
@db[$$obj{obj_id}] = {};
return @db[$$obj{obj_id}];
}
}
#
# dbref
# Return the hash table entry for an object. The code should not be
# making changes to this data.
#
sub dbref
{
my $obj = obj(shift);
if(defined @info{backup_mode} && @info{backup_mode}) {
if(defined @deleted{$$obj{obj_id}}) {
return undef;
} elsif(defined @delta[$$obj{obj_id}] &&
ref(@delta[$$obj{obj_id}]) eq "HASH") {
return @delta[$$obj{obj_id}];
} elsif(defined @db[$$obj{obj_id}] && ref(@db[$$obj{obj_id}]) eq "HASH") {
return @db[$$obj{obj_id}];
} else {
return undef;
}
} elsif(defined @db[$$obj{obj_id}] && ref(@db[$$obj{obj_id}]) eq "HASH") {
return @db[$$obj{obj_id}];
} else {
return undef;
}
}
#
# get_next_object
# return the dbref of the next free object. The assumption is searching the
# entire db would be bad.
#
sub get_next_dbref
{
if($#free > -1) { # prefetched list of free objects
my $dbref = shift(@free);
return $dbref if(!valid_dbref($dbref));
# invalid free list, repopulate in the background.
my $self = obj(0);
mushrun(self => $self,
runas => $self,
invoker=> $self,
source => 0,
cmd => "\@free",
from => "ATTR",
hint => "ALWAYS_RUN"
);
}
# no objects in the free list, grab the next new dbref.
if(defined @info{backup_mode} && @info{backup_mode}) { # in backupmode
if($#delta > $#db) { # return the largest next number
return $#delta + 1; # in @delt or @db
} else {
return $#db + 1;
}
} else { # return next number in @db
return $#db + 1;
}
}
#
# can_set_flag
# Return if an object can set the flag in question
#
sub can_set_flag
{
my ($self,$obj,$flag) = @_;
$flag = trim($') if($flag =~ /^\s*!/);
if(!defined @flag{uc($flag)}) { # not a flag
return 0;
}
my $hash = @flag{uc($flag)};
if(defined $$hash{target_type} && $$hash{target_type} =~ /^!/ &&
hasflag($obj,$')) {
return 0;
} elsif(defined $$hash{target_type} &&
!empty($$hash{target_type}) &&
$$hash{target_type} !~ /^!/ &&
!hasflag($obj,$$hash{target_type})) {
return 0;
} elsif($$hash{perm} =~ /^!/) { # can't have this perm flag and set flag
return (!hasflag($self,$')) ? 1 : 0;
} elsif(!defined $$hash{perm} || $$hash{perm} eq undef) {
return 1;
} else { # has to have this flag to set flag
return (hasflag($self,$$hash{perm})) ? 1 : 0;
}
}
#
# flag_letter
# Return the single letter associated with the flag. Does this need a
# function? only when TeenyMUSH is using multiple files because of how
# code is reloaded. I.e. variables are not exposed to other files but
# functions are.
#
sub flag_letter
{
my $txt = shift;
if(defined @flag{uc($txt)}) {
return @flag{uc($txt)}->{letter};
} else {
return undef;
}
}
sub get_flag_by_letter
{
my $letter = trim(shift);
for my $key (keys %flag) {
if(@flag{$key}->{letter} eq $letter) {
return $key;
}
}
return undef;
}
#
# flag
# Is the flag actually a valid object flag or not.
#
sub flag
{
my $txt = shift;
$txt = $' if($txt =~ /^\s*!\s*/);
if(defined @flag{uc($txt)} &&
(@flag{uc($txt)}->{type} == 1 ||
@flag{uc($txt)}->{type} == 3)) {
return 1;
} else {
return 0;
}
}
#
# flag_attr
# Is the flag actually a valid attribute flag or not.
#
sub flag_attr
{
my $txt = shift;
if(defined @flag{uc($txt)} &&
(@flag{uc($txt)}->{type} == 2 ||
@flag{uc($txt)}->{type} == 3)) {
return 1;
} else {
return 0;
}
}
#
# serialize
# This converts an attribute into a database safe string. Attributes are
# also reconstituted from multiple segments into one segment as the
# $commands are pre-parsed.
#
# This code probably should just handle the very limited number of
# characters that are problematic. Instead if it finds a character of
# concern, the whole string is mime encoded... which introduces a bit
# of overhead. Putting a compress() around the string could be done
# as well... but I havn'e gotten myself to pull the trigger on that
# one for concerns over speed.
#
sub serialize
{
my ($name,$attr) = @_;
my ($txt,$flag);
if(defined $$attr{glob}) {
my $pat = $$attr{glob};
$pat =~ s/:/\\:/g if($$attr{glob} =~ /:/); # escape out :'s in pattern
$txt = "$$attr{type}$pat:$$attr{value}";
} else {
$txt = $$attr{value};
}
if(defined $$attr{flag} && ref($$attr{flag}) eq "HASH") {
$flag = lc(join(',',keys %{$$attr{flag}}));
}
# so, the user could put a <RETURN> in their attribute... big deal?
if($txt =~ /[\r\n]/) {
$txt = db_safe($txt);
return "$name:$$attr{created}:$$attr{modified}:$flag:M:$txt";
} else {
return "$name:$$attr{created}:$$attr{modified}:$flag:A:$txt";
}
}
#
# db_safe
# Make a string safe for writing to a db flat file. In the past, this
# was just a call to encode_base64() but that is less readable.
#
sub db_safe
{
my $txt = shift;
my $ret = chr(23);
$txt =~ s/\r\n/$ret/g;
$txt =~ s/\n/$ret/g;
$txt =~ s/\r/$ret/g;
my $semi = chr(24);
$txt =~ s/;/$semi/g;
return $txt;
}
#
# db_unsafe
# Take those special characters and convert them back to what they
# really should be. This should only be used when reading from a
# db flat file.
#
sub db_unsafe
{
my $txt = shift;
my $ret = chr(23);
my $semi = chr(24);
$txt =~ s/$ret/\n/g;
$txt =~ s/$semi/;/g;
return $txt;
}
#
# hash_serialize
# Convert a hash table into a text based version that can be
# written to a file. Limit some hash tables to certain sizes.
#
sub hash_serialize
{
my ($attr,$name,$dbref) = @_;
my ($out, $i);
return undef if ref($attr) ne "HASH";
for my $key (sort {$b cmp $a} keys %$attr) {
$out .= ";" if($out ne undef);
if($$attr{$key} =~ /;/) {
$out .= "$key:M:" . db_safe($$attr{$key});
} else {
$out .= "$key:A:$$attr{$key}";
}
if(++$i >= 20 && $name eq "obj_lastsite") {
return $out;
}
}
return $out;
}
sub reserved
{
my $attr = shift;
if($attr =~ /^obj_/i) {
return 1;
} else {
return 0;
}
}
sub db_attr_exist
{
my ($id,$key) = (obj(shift),trim(lc(shift)));
my $obj = dbref($id);
if($obj eq undef) {
return 0;
} elsif(reserved($key)) {
return (defined $$obj{obj_$key}) ? 1 : 0;
} else {
return (defined $$obj{$key}) ? 1 : 0;
}
}
sub db_set
{
my ($id,$key,$value,$created,$modified)=
(obj(shift),lc(shift),shift,shift,shift);
return if db_readonly();
croak() if($$id{obj_id} =~ /^HASH\(.*\)$/);
my $obj = dbref_mutate($id);
dirty_bit($id,$key);
if($value eq undef) {
delete @$obj{$key};
return;
}
$$obj{$key} = {} if(!defined $$obj{$key}); # create attr if needed
my $attr = $$obj{$key};
if($created ne undef) {
$$attr{created} = $created;
} elsif(!defined $$attr{created}) {
$$attr{created} = time();
}
if($modified ne undef) {
@$attr{modified} = $modified;
} else {
@$attr{modified} = time();
}
# listen/command
if(!reserved($attr) && $value =~ /^([\$\^\!])(.+?)(?<![\\])([:])/) {
my ($type,$pat,$seg) = ($1,$2,$');
$pat =~ s/\\:/:/g;
$$attr{type} = $type;
$$attr{glob} = $pat;
$$attr{regexp} = glob2re($pat);
$$attr{value} = $seg;
} else { # non-listen/command
$$attr{value} = $value; # set attribute value
delete @$attr{type};
delete @$attr{glob};
delete @$attr{regexp};
}
}
sub db_set_flag
{
my ($id,$key,$flag,$value) = (obj(shift),lc(shift),shift,shift);
return if db_readonly();
return if $flag eq undef;
croak() if($$id{obj_id} =~ /^HASH\(.*\)$/);
$id = $$id{obj_id} if(ref($id) eq "HASH");
my $obj = dbref_mutate($id);
$$obj{$key} = {} if(!defined $$obj{$key}); # create attr if needed
my $attr = $$obj{$key};
dirty_bit($id,"flag");
$$attr{flag} = {} if(!defined $$attr{flag});
if($value eq undef) {
delete @{$$attr{flag}}{$flag};
} else {
@{$$attr{flag}}{$flag} = 1;
}
}
sub db_set_list
{
my ($id,$key,$value,$created,$modified) =
(obj(shift),lc(shift),lc(shift),shift,shift);
return if db_readonly();
return if $value eq undef;
croak() if($$id{obj_id} =~ /^HASH\(.*\)$/);
my $obj = dbref_mutate($id);
dirty_bit($id,$key);
$$obj{$key} = {} if(!defined $$obj{$key});
my $attr = $$obj{$key};
if($created ne undef) {
$$attr{created} = $created;
} elsif(!defined $$attr{created}) {
$$attr{created} = time();
}
if($modified ne undef) {
$$attr{modified} = $modified;
} else {
$$attr{modified} = time();
}
$$attr{value} = {} if(!defined $$attr{value});
$$attr{type} = "list";
@{$$attr{value}}{$value} = 1;
}
sub db_remove_list
{
my ($id,$key,$value) = (obj(shift),lc(shift),lc(shift));
return if db_readonly();
return if $value eq undef;
croak() if($$id{obj_id} =~ /^HASH\(.*\)$/);
my $obj = dbref_mutate($id);
dirty_bit($id,$key);
$$obj{key} = {} if(!defined $$obj{$key});
my $attr = $$obj{$key};
$$attr{value} = {} if(!defined $$attr{value});
$$attr{type} = "list";
delete @{$$attr{value}}{$value};
}
#
# db_set_hashable
# Can this attribute be used as a hash table.
#
sub db_set_hashable
{
my ($id,$attr) = @_;
my $obj = dbref_mutate($id);
if(!defined $$obj{$attr}) { # empty attribute can be set
return 1;
} elsif(db_set_ishash($id,$attr)) {
return 1;
} else {
return 0; # must be cleared
}
}
sub db_set_ishash
{
my ($id,$attr) = @_;
my $obj = dbref_mutate($id);
if(ref($$obj{$attr}) eq "HASH" && defined $$obj{$attr}->{value} &&
ref($$obj{$attr}->{value}) eq "HASH") {
return 1; # is already hash
} else {
return 0; # must be cleared
}
}
sub db_hash_keys
{
my ($id,$key,$sub) = (obj(shift),lc(shift),lc(shift));
my $obj = dbref_mutate($id);
return undef if $obj eq undef;
return undef if(!defined $$obj{$key});
my $attr = $$obj{$key};
return undef if(!defined $$attr{value} || ref($$attr{value}) ne "HASH");
return keys %{$$attr{value}};
}
sub db_set_hash
{
my ($id,$key,$value,$sub,$created,$modified) =
(obj(shift),lc(shift),lc(shift),shift,shift,shift);
return if db_readonly();
return if $value eq undef;
croak() if($$id{obj_id} =~ /^HASH\(.*\)$/);
my $obj = dbref_mutate($id);
dirty_bit($id,$key);
$$obj{$key} = {} if(!defined $$obj{$key});
my $attr = $$obj{$key};
if($created ne undef) {
$$attr{created} = $created;
} elsif(!defined $$attr{created}) {
$$attr{created} = time();
}
if($modified ne undef) {
$$attr{modified} = $modified;
} else {
$$attr{modified} = time();
}
$$attr{value} = {} if(!defined $$attr{value});
$$attr{type} = "hash";
@{$$attr{value}}{$value} = $sub;
}
sub db_remove_hash
{
my ($id,$key,$value,$clean) = (obj(shift),lc(shift),lc(shift),shift);
return if db_readonly();
return if $value eq undef;
croak() if($$id{obj_id} =~ /^HASH\(.*\)$/);
my $obj = dbref_mutate($id);
dirty_bit($id,$key);
$$obj{$key} = {} if(!defined $$obj{$key});
my $attr = $$obj{$key};
$$attr{value} = {} if(!defined $$attr{value});
$$attr{type} = "hash";
delete @{$$attr{value}}{$value};
if(scalar keys %{$$attr{value}} == 0) {
delete @$obj{$key};
}
}
#
# db_object
# Export an object from memory to a somewhat readable ascii
# format.
#
sub db_object
{
my $i = shift;
my $out;
if(defined @db[$i]) {
$out = "obj[$i] {\n";
my $obj = @db[$i];
for my $name ( (sort grep {/^obj_/} keys %$obj),
(sort grep {!/^obj_/} keys %$obj) ) {
my $attr = $$obj{$name};
$$attr{created} = time() if !defined $$attr{created};
$$attr{modified} = time() if !defined $$attr{modified};
if(reserved($name) && defined $$attr{value} &&
$$attr{type} eq "list") {
$out .= " $name\:$$attr{created}:$$attr{modified}::L:" .
join(',',keys %{$$attr{value}}) . "\n";
} elsif(defined $$attr{value} && $$attr{type} eq "hash") {
$out .= " $name\:$$attr{created}:$$attr{modified}::H:" .
hash_serialize($$attr{value},$name,$i)."\n";
} else {
$out .= " " . serialize($name,$attr) . "\n";
}
}
$out .= "}\n";
}
return $out;
}
#
# db_process_line
# Read one line from the db at a time, storing any vital information
# in the state hash table.
#
# When in a restore and an object number is passed in, then only that
# object is restored. The process will not die() when restoring.
#
sub db_process_line
{
my ($state,$line,$obj) = @_;
my $archive;
$line =~ s/\r|\n//g;
$$state{chars} += length($_);
if($line =~ /^(\d+),([^,]+),{0,1}/) { # handle archive log type entries
$$state{obj} = $1;
my $type = $2;
my $rest = $';
$archive = 1;
if($type eq "delatr") {
my $obj = @db[$$state{obj}];
delete @$obj{$rest};
return;
} elsif($type eq "delobj") {
delete @db[$$state{obj}];
return;
} else {
$line = $rest;
}
}
if($$state{obj} eq undef && $line =~ # header
/^server: ([^,]+), dbversion=([^,]+), exported=([^,]+), type=/) {
$$state{ver} = $2;
delete @$state{complete}; # dump complete
} elsif($$state{obj} eq undef && $line =~ # header
/^server: ([^,]+), version=([^,]+), change#=([^,]+), exported=([^,]+), type=/) {
delete @$state{complete}; # dump complete
$$state{ver} = $2;
@info{change} = $3;
} elsif($line =~ /^\*\* Dump Completed (.*) \*\*$/) {
$$state{complete} = 1; # dump complete
delete $$state{obj};
} elsif($$state{obj} eq undef && $line =~ /^obj\[(\d+)]\s*{\s*$/) {
$$state{obj} = $1; # start of object
} elsif($$state{obj} ne undef &&
$line =~ /^\s*([^ :]+):(\d+):(\d+):([^:]*):M:/) {
if($obj eq undef || $$state{obj} eq $obj) {
db_set($$state{obj},$1,db_unsafe($'),$2,$3); # MIME attribute
db_set_flag($$state{obj},$1,$4,1) if($4 ne undef);
}
} elsif($$state{obj} ne undef &&
$line =~ /^\s*([^ :]+):(\d+):(\d+):([^:]*):A:/) {
if($obj eq undef || $$state{obj} eq $obj) {
db_set($$state{obj},$1,$',$2,$3); # standard attribute
db_set_flag($$state{obj},$1,$4,1) if($4 ne undef);
}
$$state{loc} = $' if($1 eq "obj_location");
} elsif($$state{obj} ne undef &&
$line =~ /^\s*([^ :]+):(\d+):(\d+):([^:]*):L:/) {
my ($attr,$list,$created,$modified) = ($1,$',$2,$3); # list attribute
# delete attribute if already exists, this should only happen
# when a entry is being replaced via an incremental backup.
if(defined @db[$$state{obj}] && defined @{@db[$$state{obj}]}{$attr}) {
delete @{@db[@$state{obj}]}{$attr};
}
if($obj eq undef || $$state{obj} eq $obj) {
for my $item (split(/,/,$list)) {
db_set_list($$state{obj},$attr,$item,$created,$modified);
if($attr eq "obj_flag" && $item =~ /^\s*(PLAYER|EXIT)\s*$/i) {
$$state{type} = uc($1);
}
}
}
} elsif($$state{obj} ne undef &&
$line =~ /^\s*([^ :]+):(\d+):(\d+):([^:]*):H:/) {
my ($attr,$list,$created,$mod) = ($1,$'); # hash attribute
# delete attribute if already exists, this should only happen
# when a entry is being replaced via an incremental backup.
if(defined @db[$$state{obj}] && defined @{@db[$$state{obj}]}{$attr}) {
delete @{@db[@$state{obj}]}{$attr};
}
if($obj eq undef || $$state{obj} eq $obj) {
for my $item (split(/;/,$list)) {
if($item =~ /^([^:]+):A:([^;]+)/) {
db_set_hash($$state{obj},$attr,$1,$2,$created,$mod);
} elsif($item =~ /^([^:]+):M:([^;]+)/) {
db_set_hash($$state{obj},$attr,$1,db_unsafe($2),$created,$mod);
}
}
}
} elsif($$state{obj} ne undef && $line =~ /^\s*}\s*$/) { # end of object
if($$state{type} eq "PLAYER" && ($obj eq undef || $$state{obj} eq $obj)) {
@player{lc(@{@{@db[$$state{obj}]}{obj_name}}{value})} = $$state{obj};
}
delete @$state{obj};
delete @$state{type};
delete @$state{loc};
} elsif($obj eq undef) {
con("Unable to parse[$$state{obj}]: '%s'\n",$line);
printf("Unable to parse[$$state{obj}]: '%s'\n",$line);
printf("%s\n",code("long"));
die();
}
}
$SIG{'INT'} = sub { if(defined @info{controlc} &&
time() - @info{controlc} < 30) {
do_full_dirty_dump();
@info{crash_dump_complete} = 1;
exit(1);
} else {
printf("Warning: A Control-C was recieved. Two " .
"are needed within 30 seconds to shutdown ".
"the MUSH. This is a pre-caution against " .
"accidental aborts.\n");
@info{controlc} = time();
}
};
$SIG{'USR1'} = sub { @info{sigusr1} = time(); };
END {
if(@info{run} == 0) {
con("%s shutdown by %s.\n",conf("mudname"),@info{shutdown_by});
do_full_dirty_dump();
@info{crash_dump_complete} = 1;
} elsif(!defined @info{crash_dump_complete} && $#db > -1) {
do_full_dirty_dump();
}
}
sub single_line
{
my $txt = shift;
$txt =~ s/\r\s*|\n\s*//g;
$txt =~ s/\r\s*|\n\s*//g;
return $txt;
}
sub run_obj_commands
{
my ($self,$prog,$runas,$obj,$cmd)= (obj(shift),shift,shift,obj(shift),shift);
$cmd =~ s/\r|\n//g;
my $match = 0;
if(!or_flag($obj,"NO_COMMAND","HALTED")) {
# for my $hash (latr_regexp($obj,1)) {
for my $hash (sort {length(@{$b}{atr_regexp}) <=>
length(@{$a}{atr_regexp})} latr_regexp($obj,1)) {
if($cmd =~ /$$hash{atr_regexp}/i) {
# run attribute only if last run attritube isn't the new
# attribute to run. I.e. infinite loop. Since we're not keeping
# a stack of exec() attributes, this won't catch more complex
# recursive calls. Future feature?
if(!defined $$prog{attr} ||
!(@{$$prog{attr}}{atr_owner} eq $$obj{obj_id} &&
@{$$prog{attr}}{atr_name} eq $$hash{atr_name})) {
# http head request requires just find the command, no run
if(defined $$prog{ping} && $$prog{ping}) {
necho(self => $self,
prog => $prog,
source => [ "PONG: \$command : %s/%s in %s",
obj_name($obj,$obj),
$$hash{atr_name},
obj_name(loc($obj),loc($obj)) ]
);
} elsif(!defined $$prog{head}) {
mushrun(self => $self,
prog => $prog,
runas => $obj,
invoker=> $self,
cmd => single_line($$hash{atr_value}),
wild => [ $1,$2,$3,$4,$5,$6,$7,$8,$9 ],
from => "ATTR",
attr => $hash,
source => 0,
);
}
return 1;
}
}
}
}
my $parent = mget($obj,"obj_parent");
return 0 if($parent eq undef || !valid_dbref($$parent{value}));
# printf("Parent: '$$parent{value}'\n");
if(!or_flag($$parent{value},"NO_COMMAND","HALTED")) {
for my $hash (latr_regexp($$parent{value},1)) {
if($cmd =~ /$$hash{atr_regexp}/i) {
# run attribute only if last run attritube isn't the new
# attribute to run. I.e. infinite loop. Since we're not keeping
# a stack of exec() attributes, this won't catch more complex
# recursive calls. Future feature?
if(!defined $$prog{attr} ||
!(@{$$prog{attr}}{atr_owner} eq $$obj{obj_id} &&
@{$$prog{attr}}{atr_name} eq $$hash{atr_name})) {
# printf("RUNNING: '%s' -> '%s'\n",$$obj{obj_id},$$hash{atr_name});
# printf(" '%s'\n",single_line($$hash{atr_value}));
if(!defined $$prog{head}) {
mushrun(self => $self,
prog => $prog,
runas => $obj,
invoker=> $self,
cmd => single_line($$hash{atr_value}),
wild => [ $1,$2,$3,$4,$5,$6,$7,$8,$9 ],
from => "ATTR",
attr => $hash,
source => 0,
);
}
return 1;
}
}
}
}
return 0;
}
#
# mush_command
# Search Order is objects you carry, objects around you, and objects in
# the master room. http/non-interactive websocket requests only search
# objects you carry.
#
sub mush_command
{
my ($self,$prog,$runas,$cmd,$src) = @_;
my $match = 0;
return if(conf_true("safemode"));
$cmd = evaluate($self,$prog,$cmd) if($src ne undef && $src == 0);
if(conf_true("master_override")) { # search master room first
for my $obj (lcon(conf("master"))) {
run_obj_commands($self,$prog,$runas,$obj,$cmd) && return 1;
}
}
# search player
run_obj_commands($self,$prog,$runas,$self,$cmd) && return 1;
# search player's contents
for my $obj (lcon($self)) {
if(!hasflag($obj,"PLAYER")) {
run_obj_commands($self,$prog,$runas,$obj,$cmd) && return 1;
}
}
# don't search past the initial player if coming from web / websocket
# unless the command came from an attribute.
if(!defined $$prog{attr} &&
defined $$prog{hint} &&
($$prog{hint} eq "WEB" || $$prog{hint} eq "WEBSOCKET")){
return 0;
}
if(!conf_true("master_override")) { # search master room
for my $obj (lcon(conf("master"))) { # but not twice
if(!hasflag($obj,"PLAYER")) {
run_obj_commands($self,$prog,$runas,$obj,$cmd) && return 1;
}
}
}
# search all objects in player's location's contents
for my $obj (lcon(loc($self))) {
if(!hasflag($obj,"PLAYER")) {
$match += run_obj_commands($self,$prog,$runas,$obj,$cmd);
}
}
return ($match) ? 1 : 0;
}
sub inattr
{
my ($self,$source) = @_;
if(ref($self) ne "HASH" ||
!defined $$self{sock} ||
!defined @connected{$$self{sock}} ||
ref(@connected{$$self{sock}}) ne "HASH" ||
!defined @{@connected{$$self{sock}}}{inattr}) {
return undef;
} else {
return @{@connected{$$self{sock}}}{inattr};
}
}
sub prog
{
my ($self,$runas,$invoker) = @_;
return {
stack => [ ],
created_by => $self,
user => $runas,
var => {},
invoker => $invoker,
calls => 0
};
}
sub mushrun_add_cmd
{
my ($arg,@cmd) = @_;
my $invoker;
# add to command stack or program stack
my $prog = @$arg{prog};
my $stack = $$prog{stack};
for my $i (0 .. $#cmd) {
my $data = { runas => $$arg{runas},
source => $$arg{source},
invoker => $$arg{invoker},
prog => $$arg{prog},
mdigits => $$arg{match}
};
if(conf_true("debug")) {
#
# Extra Debuging to trace calls back to the begining, when needed.
# useful for code_history()
if(defined $$data{invoker} && ref($$data{invoker}) eq "HASH") {
$invoker = @{$$data{invoker}}{obj_id};
} else {
$invoker = "N/A";
}
if(defined $$prog{cmd} && defined @{$$prog{cmd}}{stack}) {
$$data{stack} = [ join("-#-",@{@{$$prog{cmd}}{stack}}), $invoker .
"->" . code() ];
} else {
$$data{stack} = [ $invoker . ":" . code() ];
}
}
$$data{wild} = $$arg{wild} if(defined $$arg{wild});
if($$arg{child} == 1) { # add to top of stack
$$data{cmd} = @cmd[$#cmd - $i];
unshift(@$stack,$data);
$$prog{mutated} = 1; # current cmd changed location
# printf("add[1-%s]: '%s'\n",@{$$data{invoker}}{obj_id},@cmd[$#cmd - $i]);
} elsif($$arg{child} == 2) { # add after current cmd
$$data{cmd} = @cmd[$#cmd - $i];
my $current = $$prog{cmd};
for my $i (0 .. $#$stack) { #find current cmd in stack
splice(@$stack,$i+1,0,$data) if($current eq $$stack[$i]);
}
# printf("add[2-%s]: '%s'\n",@{$$data{invoker}}{obj_id},@cmd[$#cmd - $i]);
} else { # add to bottom
$$data{cmd} = @cmd[$i];
push(@$stack,$data);
# printf("add[3-%s]: '%s'\n",@{$$data{invoker}}{obj_id},@cmd[$i]);
}
}
}
#
# multiline
# handle multiline input from the user
#
sub multiline
{
my ($arg,$multi) = @_;
# handle multi-line && command
if($$arg{source} == 1 && $multi eq undef) {
if($$arg{cmd} =~ /^\s*&&([^& =]+)\s+([^ =]+)\s*= *(.*?) *$/) {
@{@connected{@{$$arg{self}}{sock}}}{inattr} = {
attr => $1,
object => $2,
content => ($3 eq undef) ? [] : [ $3 ],
prog => $$arg{prog},
};
return 1;
}
} elsif($$arg{source} == 1 && $multi ne undef) {
my $stack = $$multi{content};
if($$arg{cmd} =~ /^\s*$/) { # attr is done
$$arg{cmd} = "&$$multi{attr} $$multi{object}= multi";
delete @{$connected{@{$$arg{self}}{sock}}}{inattr};
@$arg{prog}->{multi} = $stack;
return 0;
} elsif($$arg{cmd} =~ /^\s*\.\s*$/) { # blank line
push(@$stack,"");
return 1;
} else { # another line of atr
push(@$stack,$$arg{cmd});
return 1;
}
};
return 0;
}
#
# in_run_function
# Determine if the run() function has already been called or not.
#
sub in_run_function
{
my $prog = shift;
if(defined $$prog{nomushrun} && $$prog{nomushrun}){
return 1;
} else {
return 0;
}
}
#
# mushrun
# Add the command to the que of what to run. The command will be run
# later.
#
# $source (1 = direct user input, 0 = indirect user input)
sub mushrun
{
my %arg = @_;
my $prog;
# initialize variables.
my $multi = inattr(@arg{self},@arg{source}); # multi-line attr
@arg{match} = {} if(!defined @arg{match});
@arg{runas} = @arg{self} if !defined @arg{runas};
@arg{source} = 0 if(@arg{hint} eq "WEB");
if(!$multi) {
return if($arg{cmd} =~ /^\s*$/);
@arg{cmd} = $1 if(ansi_remove($arg{cmd}) =~ /^\s*{(.*)}\s*$/s);
}
if(@arg{prog} eq undef) { # new prog
$prog = prog(@arg{self},@arg{runas});
@arg{prog} = $prog;
@engine{++$info{pid}} = $prog; # add to process list
$$prog{pid} = $info{pid};
} else { # existing prog
$prog = @arg{prog};
if(!defined $$prog{pid}) {
@engine{++$info{pid}} = $prog; # add to process list
$$prog{pid} = $info{pid};
}
}
if(!defined @arg{invoker}) { # handle who issued the command
if(defined $$prog{cmd} && defined @$prog{cmd}->{invoker}) {
@arg{invoker} = @$prog{cmd}->{invoker};
# printf(" INVOKER1: '%s'\n",@arg{invoker});
} elsif(defined $$prog{invoker}) {
@arg{invoker} = $$prog{invoker};
# printf(" INVOKER2: '%s'\n",@arg{invoker});
} else {
con(" INVOKER: NONE '%s' -> '%s'\n",@arg{invoker},code());
}
} else {
# printf(" INVOKER: ALREADY SET\n",@arg{invoker});
}
# copy over program level data
for my $i ("hint", "attr", "sock", "output", "from") {
if(defined @arg{$i} && !defined $$prog{$i}) {
$$prog{$i} = @arg{$i};
}
}
if(defined @arg{ppid}) {
$$prog{var} = {} if not defined $$prog{var};
@{$$prog{var}}{calling_pid} = @arg{ppid};
}
if(in_run_function($prog)) {
my $stack = $$prog{stack};
push(@$stack,"#-1 Not a valid command inside RUN function");
return;
} elsif(multiline(\%arg,$multi)) { # multiline handled in function
return;
} elsif(@arg{source} == 1 || @arg{nosplit} == 1) {# from user input, no split
if(!defined $$prog{invoking_command}) {
$$prog{invoking_command} = @arg{cmd};
}
mushrun_add_cmd(\%arg,@arg{cmd});
} else { # non-user input, slice and dice
mushrun_add_cmd(\%arg,balanced_split(@arg{cmd},";",3,1));
}
# if(defined $arg{wild}) {
# set_digit_variables($arg{self},$arg{prog},"",@{$arg{wild}}); # copy %0-%9
# }
return @arg{prog};
}
#
# it was assumed that variables going into %0 - %9 should be
# evaluated. This seems to be not true, so evaluation is currently
# disabled at this level. The commented code can be removed if it doesn't
# impact things after testing.
#
sub set_digit_variables
{
my ($self,$prog,$sub) = (shift,shift,shift);
my $hash;
# clear previous variables > 9
for my $i ( grep {/^$sub\d+$/} keys %{$$prog{var}}) {
return 0 if(!managed_var_set($prog,$sub . $i,undef));
}
if(ref($_[0]) eq "HASH") {
my $new = shift;
for my $i (0 .. 9) {
return 0 if(!managed_var_set($prog,$sub . $i,$$new{$i}));
}
} else {
my @var = @_;
for my $i ( 0 .. 9 ) {
return 0 if (!managed_var_set($prog,$sub . $i,$var[$i]));
}
}
return 1;
}
sub get_digit_variables
{
my ($prog,$sub) = (shift,shift);
my $result = {};
for my $i ( grep {/^\d+$/} keys %{$$prog{var}}) {
$$result{$sub . $i} = @{$$prog{var}}{$sub . $i};
}
return $result;
}
#
# is_running
# Return if a program is still running or not
#
sub is_running
{
my $pid = shift;
if(!defined @info{engine}) {
return 0;
} elsif(defined @{@info{engine}}{$pid}) {
return 1;
} else {
return 0;
}
}
sub mushrun_done
{
my $prog = shift;
my $cost = ($$prog{command} + ($$prog{function} / 10)) / 128;
my $attr;
# if(defined $$prog{attr}) {
# printf("%s\n",print_var($prog));
# }
if(defined $$prog{capture} && ref($$prog{capture}) eq "HASH") { # nope, not actually done
return if mini_trigger($prog); # handle trigger part of @capture
}
if($cost > .5) { # handle cost
if(defined $$prog{attr}) {
$attr = "#@{$$prog{attr}}{atr_owner}/@{$$prog{attr}}{atr_name} => ";
}
logit($$prog{hint} eq "WEB" ? "weblog" : "conlog",
"Cost: %s%.3f pennies [%.1fs/%sb/%sc/%sf]\n",
$attr,
$cost,
$$prog{function_duration} + $$prog{command_duration},
nvl($$prog{max_bytes_used},0),
nvl($$prog{command},0),
nvl($$prog{function},0),
) if !@info{shell};
# for my $key (grep {/^fun_/} keys %$prog) {
# printf(" $key = $$prog{$key}\n");
# }
}
if($$prog{hint} eq "WEBSOCKET") {
my $msg = join("",@{@$prog{output}});
$prog->{sock}->send_utf8(ansi_remove($msg));
} elsif($$prog{hint} eq "IMC") {
http_out($$prog{sock},"%s",join("",@{@$prog{output}}));
http_disconnect($$prog{sock});
} elsif($$prog{hint} eq "WEB") {
if(defined $$prog{output}) {
if(defined $$prog{huh}) {
http_error($$prog{sock},"Page not found");
} elsif(defined $$prog{head}) {
http_reply_simple($$prog{sock},"html","","");
} elsif(defined $$prog{get} && $$prog{get} =~ /^\~/) {
http_out($$prog{sock},"%s",join("",@{@$prog{output}}));
http_disconnect($$prog{sock});
} elsif(defined $$prog{get} &&
$$prog{get} =~ /\.(js|css)$/i ||
$$prog{get} =~ /_raw\.(html)$/i) {
http_reply_simple($$prog{sock},
$1,
"%s",
join("\n",@{@$prog{output}})
);
} else {
http_reply($prog,"%s",join("",@{@$prog{output}}));
}
} else {
http_error($prog,"%s","Page not found");
}
} elsif(defined $$prog{missing} && ref($$prog{missing}) eq "HASH") {
my (@cmds, @fun); # show result for @missing command
my $c = $$prog{missing}->{cmd};
my $clist = join(', ',keys %$c);
$clist = "None" if $clist eq undef;
my $f = $$prog{missing}->{fun};
my $flist = join(', ',keys %$f);
$flist = "None" if $flist eq undef;
necho(self => $$prog{created_by},
prog => $prog,
target => [ $$prog{created_by}, "Missing commands: %s\n".
"Missing functions: %s",
$clist,$flist
]
);
}
close_telnet($prog);
delete @engine{$$prog{pid}};
}
sub spin_done
{
die("alarm");
}
#
# spin
# Run one command from each program that is running
#
sub spin
{
my $start = Time::HiRes::gettimeofday();
my ($count,$pid,$result);
$SIG{ALRM} = \&spin_done;
# eval {
ualarm(15_000_000); # err out at 8 seconds
local $SIG{__DIE__} = sub {
delete @engine{@info{current_pid}};
con("----- [ Crash REPORT@ %s ]-----\n",scalar localtime());
con("%s\n",code("long"));
};
if(!defined @info{stat_time} || time() - @info{stat_time} > 3600) {
calculate_login_stats();
@info{stat_time} = time();
}
if(!defined @info{dump_time}) {
@info{dump_time} = time();
} elsif(time()-@info{dump_time} > nvl(conf("dump_interval"),86400)) {
@info{dump_time} = time();
my $self = obj(0);
mushrun(self => $self,
runas => $self,
invoker=> $self,
source => 0,
cmd => "\@dump",
from => "ATTR",
hint => "ALWAYS_RUN"
);
}
if(!defined @info{dirty_time}) {
@info{dirty_time} = time();
} elsif(time()-@info{dirty_time} > 300 && defined @info{dump_name}) {
@info{dirty_time} = time();
my $self = obj(0);
mushrun(self => $self,
runas => $self,
invoker=> $self,
source => 0,
cmd => "\@dirty_dump",
from => "ATTR",
hint => "ALWAYS_RUN"
);
}
for $pid (sort {$a cmp $b} keys %engine) {
@info{current_pid} = $pid;
if(defined @info{timeout_pid} && @info{timeout_pid} == $pid) {
delete @info{timeout_pid};
next;
}
my $prog = @engine{$pid};
my $stack = $$prog{stack};
my $pos = 0;
$count = 0;
@info{prog} = @engine{$pid};
# run 100 commands, backgrounded command are excluded because
# someone could put 100 waits in for far in the furture, the code
# would never run the next command.
while($#$stack - $pos >= 0 && ++$count <= 100 + $pos) {
my $cmd = $$stack[$pos]; # run 100 cmds
my $before = $#$stack;
if($$cmd{cmd} =~ /^\s*$/ || defined $$cmd{done}) { # cmd already
splice(@$stack,$pos,1); # finished or null
next; # cmd. safe to delete now
}
# optimization for sleeping process
last if(defined $$cmd{sleep} && $$cmd{sleep} > time());
if(!hasflag($$cmd{runas},"HALTED")) {
$result = spin_run($prog,$cmd);
}
if($result eq "BACKGROUNDED") {
$pos++;
} elsif($result ne "RUNNING") { # command done
if(defined $$prog{mutated}) { # cmd moved from pos 0,
delete @$cmd{keys %$cmd}; # but where? delete later
$$cmd{done} = 1;
} else {
splice(@$stack,$pos,1); # safe to delete cmd
}
} elsif(defined $$prog{idle}) { # program idle
delete @$prog{idle};
last;
}
delete @$prog{mutated} if defined @$prog{mutated};
if(Time::HiRes::gettimeofday() - $start >= 1) { # stop
# con(" Time slice ran long, exiting correctly [%d cmds]\n",
# $count);
mushrun_done($prog) if($#$stack == -1); # program is done
ualarm(0);
@info{timeout_pid} = $pid;
return;
}
}
mushrun_done($prog) if($#$stack == -1); # program is done
delete @info{prog};
}
ualarm(0);
# };
if($@ =~ /alarm/i) {
con("Time slice timed out (%2f w/%s cmd) $@\n",
Time::HiRes::gettimeofday() - $start,$count);
}
}
sub show_verbose
{
my ($prog,$command) = @_;
if(hasflag($$command{runas},"VERBOSE")) {
my $owner= owner($$command{runas});
necho(self => $owner,
prog => $prog,
target => [ $owner,
"%s] %s",
name($$command{runas}),
$$command{cmd}
]
);
}
}
#
# run_internal
# Handle all switches and call the internal mush command
#
sub run_internal
{
my ($hash,$cmd,$command,$prog,$arg,$type) = @_;
my (%switch,$result,$runas);
# The player is probably disconnected but there are commands in the queue.
# These orphaned commands are being run against the not logged in commands
# set which will crash this function. These commands should just be ignored.
return if($$hash{cmd} =~ /^CODE\(.*\)$/);
# the object was probably destroyed, do not run any more code from it.
return if(!valid_dbref($$command{runas}));
$$prog{cmd} = $command;
show_verbose($prog,$command);
my $start = Time::HiRes::gettimeofday();
$$prog{function_command} = 0;
# handle cost of running commands
my $cost = sprintf("%d",($$prog{command} + ($$prog{function} / 10)) / 128);
if($cost != 0 && $$prog{cost} != $cost &&
!hasflag($$command{runas},"WIZARD")) {
$$prog{cost} = $cost;
give_money($$command{runas},-1);
}
if(defined $$command{runas}) {
if(ref($$command{runas}) eq "HASH") {
$runas = $$command{runas}->{obj_id};
} else {
$runas = $$command{runas};
}
}
if($$prog{hint} eq "ALWAYS_RUN" ||
$runas eq conf("webobject") ||
$$command{source} == 1 ||
money($$command{runas}) > 0) {
my $target = $$command{runas};
if(defined $$command{wild}) {
if(!set_digit_variables($$command{runas}, # copy %0-%9
$prog,
"",
@{$$command{wild}}
)) {
necho(self => $target,
prog => $prog,
source => [ managed_var_set_error("#-1") ]
);
return;
}
}
# command is just a @ping, echo to user but do not run.
if(defined $$prog{ping} && $$prog{ping}) {
necho(self => $$command{created_by},
prog => $prog,
source => [ "PONG: \@command : Internal Command" ]
);
return;
}
$target = $$target{obj_id} if(ref($target) eq "HASH");
$result = &{@{$$hash{$cmd}}{fun}}($target,
$prog,
trim($arg),
$$command{switch}
);
$$prog{command_duration} += Time::HiRes::gettimeofday() - $start;
$$prog{command}++;
# $$prog{"command_$cmd"}++;
return $result;
}
}
#
# parse_switch
# Take a command and split off the switches at the end of the command.
#
sub parse_switch
{
my ($command,$txt) = @_;
my ($count,$name);
return $$command{cmd} if defined $$command{switch};
return $txt if($txt =~ /^("|;|&)/);
my ($txt,$args)= bsplit($txt," ");
$args = " " . $args if($args ne undef);
$$command{switch} = {};
my ($cmd,$rest) = balanced_split($txt,"/",4);
return $cmd . $args if($rest eq undef);
while($rest ne undef) {
($name,$rest) = balanced_split($rest,"/",4);
@{$$command{switch}}{lc($name)} = 1;
return $cmd . $args if($count++ > 20); # no more then 20 switches
}
return $cmd . $args;
}
#
# spin_run
# Run a command that came from spin() doing the following:
#
# 1. Determine which command set may be used.
# 2. Handle %{variable} holding command / variable set
# 3. Check/run internal command
# 4. Check/run mushcoded command.
# 5. Check/use exit
# 6. Show huh message
#
sub spin_run
{
my ($prog,$cmd,$foo) = @_;
my $self = $$cmd{runas};
my ($hash,$arg,%switch);
$$cmd{origcmd} = $$cmd{cmd};
$$prog{cmd} = $cmd;
# printf("RUN %s -> %s\n",obj_name($$cmd{runas}),$$cmd{cmd});
# determine which command set to use
if($$prog{hint} eq "WEB" || $$prog{hint} eq "WEBSOCKET") {
if(defined $$prog{from} && $$prog{from} eq "ATTR") {
$hash = \%command; # from attr, use all commands
} else {
$hash = \%switch; # no internal commands
}
} else {
$hash = \%command; # all internal commands
}
$$cmd{origcmd} = $$cmd{cmd};
# printf("PING: '%s'\n",$$prog{ping});
if($$cmd{cmd} =~ /^\s*$/) {
return; # empty command
} elsif($$cmd{cmd} =~ /^\s*%\{([^ ]+)\}/) { # found variable
my ($var,$rest) = ($1,$');
if($rest =~ /^\s*(=|\+=|-=|\*=|\/=|\+\+|\-\-)\s*/) { # variable operation
return cmd_var($$cmd{runas},$prog,$var,$rest);
} elsif(!defined $$prog{var} || !defined @{$$prog{var}}{$var}) {
return cmd_huh($$cmd{runas},$prog,$$cmd{cmd}); # invalid var
} else {
$$cmd{cmd} = @{$$prog{var}}{$var} . $rest;
}
}
$$cmd{cmd} =~ s/^\s+//g; # strip leading spaces
$$cmd{cmd} =~ s/^\\//g if($$cmd{source} == 0); # fix for escape()
$$cmd{cmd} = parse_switch($cmd,$$cmd{cmd});
$$cmd{cmd} =~ s/^\s+//g; # strip leading spaces
my ($first,$arg) = bsplit($$cmd{cmd}," ");
$$cmd{mushcmd} = $first;
if(lc($first) eq "\@while" && # optimization for @while
defined $$prog{socket_id} &&
!defined $$prog{socket_closed} &&
(!defined $$prog{socket_buffer} ||
$#{$$prog{socket_buffer}} == -1)) {
$$prog{idle} = 1;
return "RUNNING";
} elsif(defined $$hash{lc($first)}) { # internal cmd
return run_internal($hash,lc($first),$cmd,$prog,$arg);
} elsif(defined $$hash{substr($first,0,1)} && # internal 1 char cmd
(defined $$hash{substr($first,0,1)}{nsp} ||
substr($first,1,1) eq " " ||
length($first) == 1
)) {
$$cmd{mushcmd} = substr($first,0,1);
return run_internal($hash,
$$cmd{mushcmd},
$cmd,
$prog,
substr($first,1) . " " . $arg,
{},
1
);
} elsif(find_exit($self,$prog,loc($self),$$cmd{cmd})) { # exit as command
return &{@{$$hash{"go"}}{fun}}($$cmd{runas},$prog,$$cmd{cmd});
} elsif(find_exit($self,$prog,conf("master"),$$cmd{cmd})) { # exit as master room command
return &{@{$$hash{"go"}}{fun}}($$cmd{runas},$prog,$$cmd{cmd});
} elsif(mush_command($self,$prog,$$cmd{runas},$$cmd{origcmd},$$cmd{source})) {
return 1; # mush_command runs command
} else { # no match, show HUH?
if(defined $$prog{ping} && $$prog{ping}) {
necho(self => $$cmd{created_by},
prog => $prog,
source => [ "PONG: No matching command found." ]
);
return;
}
return cmd_huh($$cmd{runas},$prog,$$cmd{cmd});
}
return 1;
}
#
# find_in_list
# given an @array, find $thing within the list using matching.
#
sub find_in_list
{
my $thing = lc(shift);
my (@list) = @_;
my ($start_count,$start_obj,$middle_count,$middle_obj);
return undef if $thing eq undef;
my $start = glob2re("$thing*");
my $middle = glob2re("*$thing*");
for my $obj (@list) {
my $name = lc(name($obj,1));
if($name eq $thing) { # exact match
my $obj = obj($obj);
$$obj{find_type} = 1;
return $obj;
} elsif($start > 1 || $middle > 1) { # fuzzy match failed
# skip
} else {
if($name =~ /$start/) {
$start_count++;
$start_obj = $obj;
} elsif($name =~ /$middle/) {
$middle_count++;
$middle_obj = $obj;
}
}
}
if($start_count == 1) { # one match at begining of string
my $obj = obj($start_obj);
$$obj{find_type} = 2;
return $obj;
} elsif($middle_count == 1) { # one match in middle of string
my $obj = obj($middle_obj);
$$obj{find_type} = 2;
return $obj;
} else {
return undef; # too many matches, or none
}
}
#
# find
# Try to find something. Search order:
#
# 1 Exact match in contents
# 2 Exact match in current location
# 3 Exact match in exit list
# 4 First indirect match in above list.
#
sub find
{
my ($self,$prog,$thing,$debug) = (shift,shift,trim(lc(shift)),shift);
my ($partial, $dup, $indirect);
$thing = ansi_remove($thing);
my $debug = 0;
if(empty($thing)) {
return undef;
} elsif($thing =~ /^\s*#(\d+)\s*$/) {
return valid_dbref($1) ? obj($1) : undef;
} elsif($thing =~ /^\s*here\s*$/) {
return loc_obj($self);
} elsif($thing =~ /^\s*%#\s*$/) {
return $$prog{created_by};
} elsif($thing =~ /^\s*#master\s*$/) { # return master room
my $master = get(0,"conf.master");
return ($master =~ /^\s*#{0,1}(\d+)\s*/) ? obj($1) : undef;
} elsif($thing =~ /^\s*#web\s*$/) { # return web object
my $master = get(0,"conf.webobject");
return ($master =~ /^\s*#{0,1}(\d+)\s*/) ? obj($1) : undef;
} elsif($thing =~ /^\s*#starting\s*$/) { # return starting room
my $master = get(0,"conf.starting_room");
return ($master =~ /^\s*#{0,1}(\d+)\s*/) ? obj($1) : undef;
} elsif($thing =~ /^\s*me\s*$/) {
return $self;
} elsif($thing =~ /^\s*\*/) {
my $player = trim(ansi_remove(lc($')));
if(defined @player{$player}) {
return obj(@player{$player});
} else {
return undef
}
}
# search in contents of object for exact match, save indirect for later.
my $obj = find_in_list($thing,lcon($self));
return $obj if($obj ne undef && $$obj{find_type} == 1);
if(ref($obj) eq "HASH" && $$obj{find_type} == 2 && $indirect eq undef) {
$indirect = $obj;
}
# search around object for exact match, save indirect for later.
my $obj = find_in_list($thing,lcon(loc($self)));
return $obj if($obj ne undef && $$obj{find_type} == 1);
if(ref($obj) eq "HASH" && $$obj{find_type} == 2 && $indirect eq undef) {
$indirect = $obj;
}
# search exits around object for exact match, save indirect for later.
my $obj = find_exit($self,$prog,loc($self),$thing);
return $obj if(ref($obj) eq "HASH" && $$obj{find_type} == 1);
if(ref($obj) eq "HASH" && $$obj{find_type} == 2 && $indirect eq undef) {
$indirect = $obj;
}
return $indirect; # its later
}
#
# find_exit
# Given a location, see if there is an exit named after $thing
#
sub find_exit
{
my ($self,$prog,$loc,$thing) =
(obj(shift),shift,shift,trim(ansi_remove(lc(shift))));
my ($partial,$dup);
if($thing =~ /^\s*#(\d+)\s*$/) {
return hasflag($1,"EXIT") ? obj($1) : undef;
}
for my $obj (lexits($loc)) {
for my $partial (split(';',name($obj,1))) {
my $part = trim($partial);
if(lc($part) eq $thing) {
my $obj = obj($obj);
$$obj{find_type} = 1;
return $obj;
} elsif(lc(substr($part,0,length($thing))) eq $thing) {
if($partial eq undef) {
$partial = $obj;
} elsif($dup) {
$dup = 1;
}
}
}
}
if($partial ne undef) {
my $obj = obj($partial);
$$obj{find_type} = 2;
return $obj;
}
}
sub find_content
{
my ($self,$prog,$thing) = (obj(shift),shift,trim(lc(shift)));
if($thing =~ /^\s*#(\d+)\s*$/) {
return ($$self{obj_id} == loc($1)) ? obj($1) : undef;
}
my $obj = find_in_list($thing,lcon($self));
return $obj;
}
#
# find_player
# Search for a player
#
sub find_player
{
my ($self,$prog,$thing) = (obj(shift),shift,trim(ansi_remove(lc(shift))));
my ($partial,$dup);
if($thing =~ /^\s*#(\d+)\s*$/) {
return hasflag($1,"PLAYER") ? obj($1) : undef;
} elsif($thing =~ /^\s*me\s*$/ ) {
return hasflag($self,"PLAYER") ? $self : undef;
} elsif($thing =~ /^\s*%#\s*$/) {
return $$prog{created_by};
} elsif($thing =~ /^\s*\*/) {
my $player = trim(ansi_remove(lc($')));
if(defined @player{$player}) {
return obj(@player{$player});
} else {
return undef
}
}
if(defined @player{lc($thing)}) {
return obj(@player{lc($thing)});
} else {
return find_in_list($thing,values %player);
}
return obj($partial);
}
#
# balanced_split
# Split apart a string but allow the string to have "",{},()s
# that keep segments together... but only if they have a matching
# pair.
#
sub fmt_balanced_split
{
my ($txt,$delim,$type,$debug) = @_;
my ($last,$i,@stack,@depth,$ch,$buf) = (0,-1);
my $size = length($txt);
while(++$i < $size) {
$ch = substr($txt,$i,1);
if($ch eq "\\") {
$buf .= substr($txt,$i++,2);
next;
} else {
if($ch eq "(" || $ch eq "{") { # start of segment
$buf .= $ch;
push(@depth,{ ch => $ch,
last => $last,
i => $i,
stack => $#stack+1,
buf => $buf
});
} elsif($#depth >= 0) {
$buf .= $ch;
if($ch eq ")" && @{@depth[$#depth]}{ch} eq "(") {
pop(@depth);
} elsif($ch eq "}" && @{@depth[$#depth]}{ch} eq "{") {
pop(@depth);
}
} elsif($#depth == -1) {
if($ch eq $delim) { # delim at right depth
push(@stack,$buf . $delim);
$last = $i+1;
$buf = undef;
} elsif($type <= 2 && $ch eq ")") { # func end
push(@stack,$buf);
$last = $i;
$i = $size;
$buf = undef;
last; # jump out of loop
} else {
$buf .= $ch;
}
} else {
$buf .= $ch;
}
}
if($i +1 >= $size && $#depth != -1) { # parse error, start unrolling
my $hash = pop(@depth);
$i = $$hash{i};
delete @stack[$$hash{stack} .. $#stack];
$last = $$hash{last};
$buf = $$hash{buf};
}
}
if($type == 3) {
push(@stack,substr($txt,$last));
return @stack;
} else {
unshift(@stack,substr($txt,$last));
return ($#depth != -1) ? undef : @stack;
}
}
#
# dprint
# Return a string that is at the proper "depth". Some generic mush
# formating is also done here.
#
sub dprint
{
my ($depth,$fmt,@args) = @_;
my $out;
my $txt = sprintf($fmt,@args);
if($depth + length($txt) < conf("max")) { # short, copy it as is.
# $out .= sprintf("%s%s [%s]\n"," " x $depth,$txt,code());
$out .= sprintf("%s%s\n"," " x $depth,$txt);
# Text enclosed in {}, split apart?
} elsif($txt =~ /^\s*{\s*(.+?)}\s*([;,]{0,1})\s*$/s) {
my ($grouped,$ending) = ($1,$2);
$txt = pretty($depth+3,$grouped);
$txt =~ s/^\s+//;
$out .= sprintf("%s{ %s"," " x $depth,$txt);
$out .= sprintf("%s}%s\n"," " x $depth,$ending);
} else { # generic text, wrapping it
# $out .= sprintf("%s%s\n"," " x $depth,$txt);
$out .= wrap(" " x $depth," " x ($depth+3),$txt) . "\n";
}
return $out;
}
#
# fmt_dolist
# Handle formating for @dolist like
#
# @dolist list =
# @commands
#
sub fmt_dolist
{
my ($depth,$cmd,$txt) = @_;
my $out;
# to short, don't seperate
if($depth + length($cmd . " " . $txt) < conf("max")) {
return dprint($depth,$cmd . " " . $txt);
}
# find '=' at the right depth
my @array = fmt_balanced_split($txt,"=",3);
$out .= dprint($depth,"%s %s",$cmd,trim(@array[0])); # show cmd + list
if($#array >= 0) { # show commands to run
$out .= pretty($depth+3,join('',@array[1 .. $#array]));
}
return $out;
}
sub fmt_while
{
my ($depth,$cmd,$txt) = @_;
my $out;
if($txt =~ /^\s*\(\s*(.*?)\s*\)\s*{\s*(.*?)\s*}\s*(;{0,1})\s*$/s) {
$out .= dprint($depth,"%s ( %s ) {",$cmd,$1);
$out .= pretty($depth+3,$2);
$out .= dprint($depth,"}%s",$3);
return $out;
} else {
return dprint($depth,"%s",$cmd . " " . $txt);
}
}
#
# fmt_switch
# Handle formating for @switch/select
#
# @select value =
# text,
# commands,
# text,
# commands
#
sub fmt_switch
{
my ($depth,$cmd,$txt) = @_;
my $out;
# to small, do nothing
if(length($txt)+$depth + 3 < conf("max")) {
return dprint($depth,"%s %s",$cmd,$txt);
}
# split up command by ','
my @list = fmt_balanced_split($txt,',',3);
# split up first segment again by "="
my ($first,$second) = fmt_balanced_split(shift(@list),'=',3);
my $len = $depth + length($cmd) + 1; # first subsegment
if($len + length($first) > conf("max")) { # multilined
$first =~ s/=\s*$//g;
$out .= dprint($depth,
"%s %s=",
$cmd,
substr(noret(function_print($len-3,trim($first))),$len)
);
} else { # single lined
$out .= dprint($depth,"%s %s",$cmd,trim($first),code());
}
$out .= dprint($depth+3,"%s",$second); # second subsegment
# show the rest of the segments at alternating depths
for my $i (0 .. $#list) {
my $indent = ($i % 2 == 0) ? 6 : 3;
if($i % 2 == 1) {
if($i == $#list) { # default test condition
$out .= dprint($depth+3,"DEFAULT" . ",");
$out .= dprint($depth+6,"%s",@list[$i]);
} else { # test condition
$out .= dprint($depth+3,"%s",@list[$i]);
}
} elsif($depth + $indent + length(@list[$i]) > conf("max") || # long cmd
@list[$i] =~ /^\s*{.*}\s*;{0,1}\s*$/) {
$out .= pretty($depth+6,@list[$i]);
} else { # short cmd
$out .= dprint($depth + 6,"%s",@list[$i]);
}
}
return $out;
}
sub fmt_amper
{
my ($depth,$cmd,$txt) = @_;
my $out;
if($txt =~ /^([^ ]+)\s+([^=]+)\s*=/) {
my ($atr,$obj,$val) = ($1,$2,$');
if(length($val) + $depth < conf("max")) {
$out .= dprint($depth,"%s","$cmd$txt");
} elsif($val =~ /^\s*\[.*\]\s*(;{0,1})\s*$/) {
$out .= dprint($depth,"%s","&$atr $obj=");
$out .= function_print($depth+3,$val);
} else {
$out .= dprint($depth,"%s",$cmd . $txt);
}
}
return $out;
}
#
# noret
# Strip the ending return from a string of text.
sub noret
{
my $txt = shift;
$txt =~ s/\n$//;
return $txt;
}
#
# function_print_segment
# Maybe this function should be called function_print as this
# function is really just printing out the function.
#
sub function_print_segment
{
my ($depth,$left,$function,$arguments,$right,$type) = @_;
my ($mleft,$mright) = (quotemeta($left),quotemeta($right));
my $len = length("$function.$left( ");
my $out;
my @array = fmt_balanced_split($arguments,",",2);
$function =~ s/^\s+//; # strip leading spaces
#
# if function is short enough, so leave it alone. However, but it unkown
# how much of the text to leave alone since there could be more then one
# function in $arguments. @array has the left over bits and what should
# be skipped over... the only downfall is we have to reconstruct the
# skipped over parts.
#
# FYI This comparison is slighytly wrong, but close
if($depth + length("$left$function($arguments)$right") - length(@array[0])
< conf("max")) {
if($mright ne undef) { # does the function end right?
if(@array[0] =~ /^\s*\)$mright/) {
@array[0] = $'; # yes
} else {
return (undef, undef, 1); # no, umatched "]"
}
}
return (dprint($depth, # put together and return it
"%s",
"$left$function(" .
join('',@array[1 .. $#array])
. ")$right"
),
"@array[0]",
0
);
}
$out .= dprint($depth,"%s","$left$function( " . @array[1]);
my $ident = length("$left$function( ") + $depth;
for my $i (2 .. $#array) { # show function arguments
$out .= noret(function_print($ident,"@array[$i]")) . "\n";
}
$out .= dprint($depth,"%s",")$right"); # show ending )
if($mright ne undef) {
if(@array[0] =~ /^\s*\)$mright/) {
return ($out,$',0);
} else {
return (undef,undef,2);
}
} elsif(@array[0] =~ /\s*\)\s*(,)/) {
return ($out,"$1$'",0);
} else {
return (undef,undef,3);
}
}
# function_print
# Print out a function as is if short enough, or split it apart
# into multiple lines.
#
sub function_print
{
my ($depth,$txt) = @_;
my $out;
if($depth + length($txt) < conf("max")) { # too small
return dprint($depth,"%s",$txt);
}
while($txt =~ /^(\s*)([a-zA-Z_]+)\(/s) {
my ($fmt,$left,$err) = function_print_segment($depth,
'',
$2,
$',
'',
2
);
if($err) {
return $txt;
} else {
$out .= $1 . $fmt;
$txt = $left;
}
}
return $out if($out ne undef and $txt =~ /^\s*$/);
@info{debug_count} = 0;
while($txt =~ /([\\]*)\[([a-zA-Z_]+)\(/s) {
my ($esc,$before,$after,$unmod) = ($1,$`,$',$2);
if(length($esc) % 2 == 0) {
my ($fmt,$left,$err) = function_print_segment($depth,
'[',
$unmod,
$after,
']',
1
);
if($err) {
$out .= $before ."[$unmod(";
$txt = $after;
} else {
$out .= $fmt;
$txt = $left;
}
} else {
$out .= "[$unmod(";
$txt = $after;
}
}
if($txt ne undef) {
$out =~ s/\n$//;
return $out . "$txt\n";
} else {
return $out . "$txt";
}
# } elsif($txt =~ /^\s*\[([a-zA-Z0-9_]+)\((.*)\)(\s*)\]\s*(;{0,1})\s*$/) {
# $out .= function_print_segment($depth+3,'[',$1,"$2)$3$4",']',1);
# # function()
# } elsif($txt =~ /^\s*([a-zA-Z0-9_]+)\((.*)\)(\s*)(,{0,1})(\s*)$/) {
# $out .= function_print_segment($depth+3,'',$1,"$2)$3$4$5",'',2);
# } else { # no idea?
# $out .= dprint($depth,"%s",$txt);
# }
# return $out;
}
#
# split_commmand
# Determine what the possible cmd and arguements are.
#
sub split_command
{
my $txt = shift;
if($txt =~ /^\s*&/) {
return ('&',$');
} elsif($txt =~ /^\s*([^ \/=]+)/) {
return ($1,$');
} else {
return $txt;
}
}
sub pretty
{
my ($depth,$txt) = @_;
my $out;
#
# these commands are handled differently then other commands.
#
my %fmt_cmd = (
'@switch' => sub { fmt_switch(@_); },
'@select' => sub { fmt_switch(@_); },
'@dolist' => sub { fmt_dolist(@_); },
'&' => sub { fmt_amper(@_); },
'@while' => sub { fmt_while(@_); },
);
if($depth + length($txt) < conf("max")) {
return (" " x $depth) . $txt;
}
for my $txt ( fmt_balanced_split($txt,';',3,1) ) {
my ($cmd,$arg) = split_command($txt);
if(defined @fmt_cmd{$cmd}) {
$out =~ s/\s+$//g;
$out .= "\n" if $out ne undef;
$out .= &{@fmt_cmd{$cmd}}($depth,$cmd,$arg);
$out =~ s/\n+$//g if($depth==3);
} elsif(defined @fmt_cmd{lc($cmd)}) {
$out .= &{@fmt_cmd{lc($cmd)}}($depth,$cmd,$arg);
$out =~ s/\n+$//g if($depth==3);
} else {
$out .= dprint($depth,"%s",$txt);
}
}
if($depth == 0) {
return noret($out);
} else {
return $out;
}
}
#
# test code for use outside the mush
#
# my $code = '@select 0=[not(eq(words(first(v(won))),1))],{@pemit %#=Connect 4: Game over, [name(first(v(won)))] has won.},[match(v(who),%#|*)],{@pemit %#=Connect 4: Sorry, Your not playing right now.},[match(first(v(who)),%#|*)],{@pemit %#=Connect 4: Sorry, its [name(before(first(v(who)),|))] turn right now.},[and(isnum(%0),gt(%0,0),lt(%0,9))],{@pemit %#=Connect 4: That is not a valid move, try again.},[not(gte(strlen(v(c[first(%0)])),8))],{@pemit %#=Connect 4: Sorry, that column is filled to the max.},{&who me=[rest(v(who))] [first(v(who))];&won me=[switch(1,u(fnd,%0,add(1,strlen(v(c[first(%0)]))),after(rest(v(who)),|)),%#)];&c[first(%0)] me=[v(c[first(%0)])][after(rest(v(who)),|)];@pemit %#=[u(board,{%n played in column [first(%0)]})];@pemit [before(first(v(who)),|)]=[u(board,{%n played in column [first(%0)]})];@switch [web()]=0,@websocket connect}';
# my $code = '@select 0=[member(type(num(%1)),PLAYER)],@pemit %#=Connect 4: Sorry I dont see that person here.,{&won me=;&who me=%#|# [num(%1)]|O;"%N has challenged [name(num(%1))].;&c1 me=;&c2 me=;&c3 me=;&c4 me=;&c5 me=;&c6 me=;&c7 me=;&c8 me=;@pemit %#=[u(board)];@pemit [num(%1)]=[u(board)]}';
#
# my $code='&list me=[u(fnd,%0,%1,after(first(v(who)),|))];@select 0=[match(v(who),%#|*)],{@pemit %#=Tao: Sorry, Your not playing right now.},[match(first(v(who)),%#|*)],{@pemit %#=Tao: Sorry, its [name(before(first(v(who)),|))] turn right now.},[u(isval,%0,%1,.)],{@pemit %#=Tao: That is not a valid move, try again.},[words(v(list))],{@pemit %#=Tao: Sorry, that move does not result in a capture.},{&who me=[rest(v(who))] [first(v(who))];@dolist [first(%0)]|[first(%1)] [v(list)] END=@select ##=END,{@pemit %#=[u(board,{%n played [first(%0)],[first(%1)]})];@pemit [before(first(v(who)),|)]=[u(board,{%n played [first(%0)],[first(%1)]})]},{&c[before(##,|)] me=[replace(v(c[before(##,|)]),after(##,|),after(rest(v(who)),|),|)]}}';
# my $code='[setq(0,iter(u(num,3),[u(ck,2,%2,add(%0,##),add(%1,##))][u(ck,3,%2,add(%0,##),%1)][u(ck,4,%2,add(%0,##),add(%1,-##))][u(ck,5,%2,%0,add(%1,-##))][u(ck,6,%2,add(%0,-##),add(%1,-##))][u(ck,7,%2,add(%0,-##),%1)][u(ck,8,%2,add(%0,-##),add(%1,##))]))]';
# my $code='@switch [t(match(get(#5/hangout_list),%1))][match(bus cab bike motorcycle car walk boomtube,%0)]=0*,@pemit %#=Double-check the DB Number. That does not seem to be a viable option.,11,{@tel %#=%1;@wait 1=@remit [loc(%#)]=A bus pulls up to the local stop. %N steps out.},12,{@tel %#=%1;@wait 1=@remit [loc(%#)]=A big yellow taxi arrives. A figure inside pays the tab%, then steps out and is revealed to be %N.},13,{@tel %#=%1;@wait 1=@remit [loc(%#)]=%N arrives in the area%, pedaling %p bicycle.},14,{@tel %#=%1;@wait 1=@remit [loc(%#)]=%N pulls up on %p motorcycle%, kicking the stand and stepping off.},15,{@tel %#=%1;@wait 1=@remit [loc(%#)]=%N pulls up in %p car%, parking and then getting out.},16,{@tel %#=%1;@wait 1=@remit %N walks down the street in this direction.=<an emit>},17,{@tel %#=%1;@wait 1=@remit [loc(%#)]=A boomtube opens%, creating a spiraling rift in the air. After a moment%, %N steps out.},@pemit %#=That method of travel does not seem to exist.';
#my $code ='&won me=[switch(1,u(fnd,%0,add(1,strlen(v(c[first(%0)]))),after(rest(v(who)),|)),%#)]';
#my $code = '[setq(1,)][setq(2,)][setq(3,)][setq(4,)][setq(5,)][setq(6,)][setq(7,)][setq(8,)][setq(9,)][setq(0,)]';
# my $code = '@switch 0=run(@telnet wttr.in 80),say Weather is temporarly unavailible.,{ @var listen=off;@send GET /@%1?0?T HTTP/1.1;@send Host: wttr.in;@send Connection: close;@send User-Agent: curl/7.52.1;@send Accept: */*;@send ;@while ( telnet_open(%{input}) eq 1 ) {@var input = [input()];@switch on-done-%{input}=on-%{listen}-*,@@ ignore,on-done-*out of queries*,{say Weather Website is down [out of queries];@var listen=done},on-done-ERROR*,{say Unknown Location: %1;@var listen=done},on-done-#-1 *,@@ ignore,on-done-Weather report:*,{@var listen=on;@emit %{input}},%{listen}-done-,@@ ignore,%{listen}-done-*,@emit > [decode_entities(%{input})]}';
#
#
# printf("%s\n",pretty(3,$code));
# printf("%s\n",function_print(3,$code));
#
# define which function's arguements should not be evaluated before
# executing the function. The sub-hash defines exactly which argument
# should be not evaluated ( starts at 1 not 0 )
#
#my %exclude =
#(
# iter => { 2 => 1 },
# parse => { 2 => 1 },
# setq => { 2 => 1 },
# switch => { all => 1 },
## u => { 2 => 1, 3 => 1, 4 => 1, 5 => 1, 6 => 1, 7 => 1, 8 => 1,
## 9 => 1, 10 => 1 },
#);
sub initialize_functions
{
delete @fun{keys %fun};
@fun{info} = sub { return &fun_info(@_); };
@fun{cat} = sub { return &fun_cat(@_); };
@fun{dump} = sub { return &fun_dump(@_); };
@fun{variables} = sub { return &fun_variables(@_); };
@fun{lvariable} = sub { return &fun_lvariable(@_); };
@fun{password} = sub { return &fun_password(@_); };
@fun{s} = sub { return &fun_s(@_); };
@fun{set} = sub { return &fun_set(@_); };
@fun{EVAL} = sub { return &fun_u(@_); };
@fun{ulocal} = sub { return &fun_ulocal(@_); };
@fun{edefault} = sub { return &fun_edefault(@_); };
@fun{html_strip} = sub { return &fun_html_strip(@_); };
@fun{tohex} = sub { return &fun_tohex(@_); };
@fun{foreach} = sub { return &fun_foreach(@_); };
@fun{itext} = sub { return &fun_itext(@_); };
@fun{inum} = sub { return &fun_inum(@_); };
@fun{ilev} = sub { return &fun_ilev(@_); };
@fun{pack} = sub { return &fun_pack(@_); };
@fun{unpack} = sub { return &fun_unpack(@_); };
@fun{round} = sub { return &fun_round(@_); };
@fun{if} = sub { return &fun_if(@_); };
@fun{ifelse} = sub { return &fun_if(@_); };
@fun{pid} = sub { return &fun_pid(@_); };
@fun{lpid} = sub { return &fun_lpid(@_); };
@fun{null} = sub { return &fun_null(@_); };
@fun{args} = sub { return &fun_args(@_); };
@fun{shift} = sub { return &fun_shift(@_); };
@fun{unshift} = sub { return &fun_unshift(@_); };
@fun{pop} = sub { return &fun_pop(@_); };
@fun{push} = sub { return &fun_push(@_); };
@fun{asc} = sub { return &fun_ord(@_); };
@fun{ord} = sub { return &fun_ord(@_); };
@fun{chr} = sub { return &fun_chr(@_); };
@fun{escape} = sub { return &fun_escape(@_); };
@fun{trim} = sub { return &fun_trim(@_); };
@fun{ansi} = sub { return &fun_ansi(@_); };
@fun{ansi_remove}= sub { return &fun_ansi_remove(@_); };
@fun{colors} = sub { return &fun_colors(@_); };
@fun{ansi_debug} = sub { return &fun_ansi_debug(@_); };
@fun{substr} = sub { return &fun_substr(@_); };
@fun{mul} = sub { return &fun_mul(@_); };
@fun{file} = sub { return &fun_file(@_); };
@fun{write} = sub { return &fun_write(@_); };
@fun{space} = sub { return &fun_space(@_); };
@fun{repeat} = sub { return &fun_repeat(@_); };
@fun{time} = sub { return &fun_time(@_); };
@fun{keys} = sub { return &fun_keys(@_); };
@fun{timezone} = sub { return &fun_timezone(@_); };
@fun{flags} = sub { return &fun_flags(@_); };
@fun{quota} = sub { return &fun_quota(@_); };
@fun{mush_address}=sub { return &fun_mush_address(@_); };
@fun{input} = sub { return &fun_input(@_); };
@fun{has_input} = sub { return &fun_has_input(@_); };
@fun{strlen} = sub { return &fun_strlen(@_); };
@fun{right} = sub { return &fun_right(@_); };
@fun{left} = sub { return &fun_left(@_); };
@fun{lattr} = sub { return &fun_lattr(@_); };
@fun{iter} = sub { return &fun_iter(@_); };
@fun{map} = sub { return &fun_map(@_); };
@fun{list} = sub { return &fun_list(@_); };
@fun{citer} = sub { return &fun_citer(@_); };
@fun{parse} = sub { return &fun_iter(@_); };
@fun{huh} = sub { return "#-1 Undefined function"; };
@fun{ljust} = sub { return &fun_ljust(@_); };
@fun{rjust} = sub { return &fun_rjust(@_); };
@fun{loc} = sub { return &fun_loc(@_); };
@fun{extract} = sub { return &fun_extract(@_); };
@fun{elements} = sub { return &fun_elements(@_); };
@fun{lwho} = sub { return &fun_lwho(@_); };
@fun{remove} = sub { return &fun_remove(@_); };
@fun{get} = sub { return &fun_get(@_); };
@fun{xget} = sub { return &fun_get(@_); };
@fun{default} = sub { return &fun_default(@_); };
@fun{eval} = sub { return &fun_eval(@_); };
@fun{edit} = sub { return &fun_edit(@_); };
@fun{add} = sub { return &fun_add(@_); };
@fun{sub} = sub { return &fun_sub(@_); };
@fun{div} = sub { return &fun_div(@_); };
@fun{fdiv} = sub { return &fun_fdiv(@_); };
@fun{secs} = sub { return &fun_secs(@_); };
@fun{loadavg} = sub { return &fun_loadavg(@_); };
@fun{after} = sub { return &fun_after(@_); };
@fun{before} = sub { return &fun_before(@_); };
@fun{member} = sub { return &fun_member(@_); };
@fun{index} = sub { return &fun_index(@_); };
@fun{replace} = sub { return &fun_replace(@_); };
@fun{num} = sub { return &fun_num(@_); };
@fun{locate} = sub { return &fun_locate(@_); };
@fun{lnum} = sub { return &fun_lnum(@_); };
@fun{name} = sub { return &fun_name(0,@_); };
@fun{fullname} = sub { return &fun_name(1,@_); };
@fun{type} = sub { return &fun_type(@_); };
@fun{u} = sub { return &fun_u(@_); };
@fun{v} = sub { return &fun_v(@_); };
@fun{r} = sub { return &fun_r(@_); };
@fun{setq} = sub { return &fun_setq(@_); };
@fun{setr} = sub { return &fun_setr(@_); };
@fun{mid} = sub { return &fun_substr(@_); };
@fun{strtrunc} = sub { return &fun_strtrunc(@_); };
@fun{center} = sub { return &fun_center(@_); };
@fun{inc} = sub { return &fun_inc(@_); };
@fun{dec} = sub { return &fun_dec(@_); };
@fun{rest} = sub { return &fun_rest(@_); };
@fun{first} = sub { return &fun_first(@_); };
@fun{last} = sub { return &fun_last(@_); };
@fun{switch} = sub { return &fun_switch(@_); };
@fun{words} = sub { return &fun_words(@_); };
@fun{eq} = sub { return &fun_eq(@_); };
@fun{not} = sub { return &fun_not(@_); };
@fun{match} = sub { return &fun_match(@_); };
@fun{regedit} = sub { return &fun_regedit(@_); };
@fun{strmatch} = sub { return &fun_strmatch(@_); };
@fun{isnum} = sub { return &fun_isnum(@_); };
@fun{gt} = sub { return &fun_gt(@_); };
@fun{gte} = sub { return &fun_gte(@_); };
@fun{lt} = sub { return &fun_lt(@_); };
@fun{lte} = sub { return &fun_lte(@_); };
@fun{or} = sub { return &fun_or(@_); };
@fun{bor} = sub { return &fun_bor(@_); };
@fun{owner} = sub { return &fun_owner(@_); };
@fun{and} = sub { return &fun_and(@_); };
@fun{hasflag} = sub { return &fun_hasflag(@_); };
@fun{orflags} = sub { return &fun_orflags(@_); };
@fun{squish} = sub { return &fun_squish(@_); };
@fun{capstr} = sub { return &fun_capstr(@_); };
@fun{lcstr} = sub { return &fun_lcstr(@_); };
@fun{ucstr} = sub { return &fun_ucstr(@_); };
@fun{setinter} = sub { return &fun_setinter(@_); };
@fun{listinter} = sub { return &fun_listinter(@_); };
@fun{sort} = sub { return &fun_sort(@_); };
@fun{mudname} = sub { return &fun_mudname(@_); };
@fun{version} = sub { return &fun_version(@_); };
@fun{inuse} = sub { return &inuse_player_name(@_); };
@fun{web} = sub { return &fun_web(@_); };
@fun{run} = sub { return &fun_run(@_); };
@fun{lexits} = sub { return &fun_lexits(@_); };
@fun{lcon} = sub { return &fun_lcon(@_); };
@fun{home} = sub { return &fun_home(@_); };
@fun{rand} = sub { return &fun_rand(@_); };
@fun{lrand} = sub { return &fun_lrand(@_); };
@fun{reverse} = sub { return &fun_reverse(@_); };
@fun{base64} = sub { return &fun_base64(@_); };
@fun{compress} = sub { return &fun_compress(@_); };
@fun{uncompress} = sub { return &fun_uncompress(@_); };
@fun{revwords} = sub { return &fun_revwords(@_); };
@fun{idle} = sub { return &fun_idle(@_); };
@fun{conn} = sub { return &fun_conn(@_); };
@fun{fold} = sub { return &fun_fold(@_); };
@fun{telnet_open}= sub { return &fun_telnet(@_); };
@fun{min} = sub { return &fun_min(@_); };
@fun{find} = sub { return &fun_find(@_); };
@fun{convsecs} = sub { return &fun_convsecs(@_); };
@fun{convtime} = sub { return &fun_convtime(@_); };
@fun{max} = sub { return &fun_max(@_); };
@fun{controls} = sub { return &fun_controls(@_); };
@fun{invocation} = sub { return &fun_invocation(@_); };
@fun{url} = sub { return &fun_url(@_); };
@fun{lflags} = sub { return &fun_lflags(@_); };
@fun{huh} = sub { return "#-1 Undefined function"; };
@fun{money} = sub { return &fun_money(@_); };
@fun{ip} = sub { return &fun_ip(@_); };
@fun{entities} = sub { return &fun_entities(@_); };
@fun{setunion} = sub { return &fun_setunion(@_); };
@fun{setdiff} = sub { return &fun_setdiff(@_); };
@fun{lit} = sub { return &fun_lit(@_); };
@fun{stats} = sub { return &fun_stats(@_); };
@fun{mod} = sub { return &fun_mod(@_); };
@fun{filter} = sub { return &fun_filter(@_); };
@fun{pickrand} = sub { return &fun_pickrand(@_); };
@fun{ldelete} = sub { return &fun_ldelete(@_); };
@fun{hasattr} = sub { return &fun_hasattr(@_); };
@fun{hasattrp} = sub { return &fun_hasattrp(@_); };
@fun{attr_created}=sub { return &fun_attr_created(@_); };
@fun{attr_modified}=sub{ return &fun_attr_modified(@_); };
@fun{ansi2mush} = sub { return &fun_ansi2mush(@_); };
@fun{lhelp} = sub { return &fun_lhelp(@_); };
@fun{conf} = sub { return &fun_conf(@_); };
@fun{help} = sub { return &fun_help(@_); };
@fun{graph} = sub { return &fun_graph(@_); };
@fun{strcat} = sub { return &fun_strcat(@_); };
@fun{readonly} = sub { return &fun_readonly(@_); };
@fun{encrypt} = sub { return &fun_encrypt(@_); };
@fun{decrypt} = sub { return &fun_decrypt(@_); };
@fun{haspower} = sub { return &fun_haspower(@_); };
@fun{zone} = sub { return &fun_zone(@_); };
@fun{starttime} = sub { return &fun_starttime(@_); };
@fun{delete} = sub { return &fun_delete(@_); };
@fun{findable} = sub { return &fun_findable(@_); };
@fun{power} = sub { return &fun_power(@_); };
@fun{create} = sub { return &fun_create(@_); };
@fun{isdbref} = sub { return &fun_isdbref(@_); };
@fun{secure} = sub { return &fun_secure(@_); };
@fun{uri_escape} = sub { return &fun_uri_escape(@_); };
@fun{isupper} = sub { return &fun_isupper(@_); };
@fun{islower} = sub { return &fun_islower(@_); };
}
#
# add_union_element
# Dbrefs can not be sorted directly, so safe the dbref minus the "#"
# as the hash value so it can be used to sort the list.
#
sub add_union_element
{
my ($list,$item,$type) = @_;
if($type eq "d") {
if($item =~ /^\s*#(\d+)\s*$/) {
$$list{$item} = $1;
} else {
$$list{$item} = $item;
}
} else {
$$list{$item} = $item;
}
}
sub atr_get
{
my ($self,$prog) = (shift,shift);
my ($target,$atr);
my $txt = evaluate($self,$prog,shift);
if($txt =~ /\//) {
$target = find($self,$prog,$`) || return undef;
$atr = $';
} else {
$target = $self;
$atr = $txt;
}
return get($target,$atr);
}
#
# tomush
# Convert the a string into its mush equivalent. $flag tells the function
# if the code is going to be used inside a function.
#
sub tomush
{
my ($txt,$flag,$start,$end) = @_;
my ($i,$out,$output);
for($i = 0;$i < length($txt);$i++) { # cycle each char
my $ch = substr($txt,$i,1);
if($ch eq " " && ($i + $start == 0 || ($i + 1 == length($txt) && $flag)||
$i + $start + 1 == $end && !$flag)) {
$out = "%b"; # special case spaces
} elsif($ch eq " ") {
$out = ($out eq " ") ? "%b" : " "; # alternate %bs
} elsif($ch eq "\n") {
$out = "%r";
} elsif($ch eq '[' || $ch eq ']' || $ch eq '%' || $ch eq '\\' ||
$ch eq '{' || $ch eq '}' || $ch eq '(' || $ch eq ')' || $ch eq ",") { # escape char
# $ch eq '{' || $ch eq '}' || $ch eq '(' || $ch eq ')' || ($ch eq "," && $flag)) { # escape char
$out = "\\$ch";
} else {
$out = $ch; # normal char
}
$output .= $out; # add to output
}
return $output;
}
#
# mushify
# Convert a string into its mush equivalent while trying to use as
# few characters as possible. Do character compression using the
# repeat() command.
#
sub mushify
{
my $txt = shift;
my ($ch,$done,$start,$i,$mult,$mush,$out,$loc);
$txt =~ s/\t/ /g; # expand tabs
$txt =~ s/^\n{2,999}/\n/g;
for($loc=0,$done=0;$loc <= length($txt);$loc++,$done=0) {
for($i=1;$i < 10 && $i < (length($txt)- $loc) / 2 && !$done;$i++) {
my $seg = substr($txt,$loc,$i);
for($mult=1;$seg eq substr($txt,$loc + ($i*$mult),$i);$mult++) {};
if(($seg eq " " && $mult > 6) || ((length($mush=tomush($seg,1,0,
length($txt)))+length($mult) + 11) < (length($seg)*$mult))) {
$out .= tomush(substr($txt,$start,$loc-$start),0,$loc,length($txt));
$out .= ($seg eq " ") ? "[space($mult)]" : "[repeat($mush,$mult)]";
$loc += length($seg) * $mult - 1; # skip chars
$done = 1; # get out of loop
}
}
$start = $loc + 1 if($done); # set next starting point
}
return $out . tomush(substr($txt,$start,length($txt)),0,$start,length($txt));
}
#
# crypt_code
# This is a port of the C code in TinyMUSH/Rhost to perl. It is
# functionally the same.
#
sub crypt_code
{
my ($self,$prog,$txt,$pass,$type) = @_;
my $txt = evaluate($self,$prog,$txt);
my $out;
for(my ($x,$y)=(0,0);$x < length($txt);$x++,$y++) {
$y = 0 if $y >= length($pass);
my $ch = ord(substr($txt,$x,1));
my $p = ord(substr($pass,$y,1));
$out .= ($type) ? chr(($ch-32+$p-32)%95+32) : chr(($ch-$p+190)%95+32);
}
return $out;
}
sub fun_isupper
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
return (evaluate($self,$prog,$txt) =~ /[a-z]/) ? 0 : 1;
}
sub fun_islower
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
return (evaluate($self,$prog,$txt) =~ /[A-Z]/) ? 0 : 1;
}
sub fun_uri_escape
{
my ($self,$prog) = (obj(shift),shift);
if(module_enabled("uri_escape")) {
return uri_escape(join(',',@_));
} else {
return "#-1 FUNCTION DISABLED (URI_ESCAPE MODULE DISABLED)";
}
}
#
# fun_haspower
# Place holder for when powers are implimented.
#
sub fun_haspower
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,2) ||
return "#-1 FUNCTION (POWER) EXPECTS 2 ARGUMENTS";
return 0;
}
sub fun_cat
{
my ($self,$prog) = (obj(shift),shift);
my @out;
good_args($#+,0 .. 100) || # only so many cats or they are bunnies
return "#-1 FUNCTION(CAT) EXPECTS 0 TO 100 ARGS";
for my $i (0 .. $#_) { # trim spaces for expected output
push(@out,ansi_trim(evaluate($self,$prog,shift)));
}
return join(" ",@out);
}
sub fun_create
{
my ($self,$prog) = (obj(shift),shift);
my $result;
hasflag($self,"GUEST") &&
return "#-1 PERMISSION DENIED";
return "#-1 FUNCTION (CREATE EXPECTS AT LEAST 2 ARGUMENTS" if($#_ <= 0 );
my $type = lc(trim(ansi_remove(evaluate($self,$prog,pop(@_)))));
my $name = ansi_substr(trim(evaluate($self,$prog,shift)),0,399);
if($type eq "r") {
good_args($#_,0,1,2) ||
return "#-1 FUNCTION (CREATE) EXPECTS 2 TO 4 ARGUMENTS FOR 'R' TYPE";
my $in = ansi_substr(trim(evaluate($self,$prog,shift)),0,399);
my $out = ansi_substr(trim(evaluate($self,$prog,shift)),0,399);
$result = dig_room($self,$prog,$name,$in,$out);
} elsif($type eq "e") { # exit
good_args($#_,0,1) ||
return "#-1 FUNCTION (CREATE) EXPECTS 1 OR 2 ARGUMENTS FOR 'E' TYPE";
my $name = ansi_substr(trim(evaluate($self,$prog,shift)),0,399);
my $dbref = trim(evaluate($self,$prog,shift));
$result = open_exit($self,$prog,loc($self),$name,$dbref);
} elsif($type eq "p") {
return "#-1 NOT SUPPORTED AT THIS TIME.";
# player
} else { # create thing/object
my $value;
if($type ne "t") {
$value = $type;
} else {
$value = evaluate($self,$prog,shift);
}
if(!isint($value) && $value > 0) {
return "#-1 INVALID CREATION AMOUNT";
}
good_args($#_,0,1) ||
return "#-1 FUNCTION (CREATE) EXPECTS 2 OR 3 ARGUMENTS FOR 'T' TYPE";
$result = create_thing($self,$prog,$name,$value);
}
if($result =~ /^(\d+)$/) { # success
return "#$result";
} else { # error
return "#-1 $result";
}
# good_args($#_,2) ||
# return "#-1 FUNCTION (ZONE) EXPECTS 2 ARGUMENTS";
# if(hasflag($self,"GUEST")) {
# return err($self,$prog,"Permission denied.");
# } elsif(quota($self,"left") <= 0) {
# return err($self,$prog,"You are out of QUOTA to create objects.");
# } elsif(length($txt) > 50) {
# return err($self,$prog,
# "Object name may not be greater then 50 characters"
# );
# } elsif(money($self) < conf("createcost")) {
# return err($self,$prog,"You need at least ".pennies("createcost").".");
# }
#
# my $dbref = create_object($self,$prog,$txt,undef,"OBJECT") ||
# return err($self,$prog,"Unable to create object");
#
# if(!give_money($self,"-" . conf("createcost"))) {
# return err($self,$prog,"Unable to deduct cost of object.");
# }
#
# necho(self => $self,
# prog => $prog,
# source => [ "Object created as: %s",obj_name($self,$dbref) ],
# );
#
# set_quota($self,"sub");
}
#
# public_address
# Return the hostname of the MUSH server
#
sub fun_mush_address
{
my ($self,$prog) = (shift,shift);
good_args($#_,0) ||
return "#-1 FUNCTION (MUSH_ADDRESS) EXPECTS NO ARGUMENTS";
if(!module_enabled("dns")) {
return err($self,$prog,"#-1 FUNCTION DISABLED (DNS MODULE DISABLED)");
} elsif(!defined @info{mush_address}) { # not cached, yet
my $r = Net::DNS::Resolver->new(nameservers=>["resolver1.opendns.com"])||
return;
my $query = $r->search("myip.opendns.com") || return;
foreach my $record ($query->answer) {
my $name = gethostbyaddr(inet_aton($record->address),AF_INET);
if($name eq undef || $name =~ /in-addr\.arpa$/) {
@info{mush_address} = $record->address;
return $record->address;
} else {
@info{mush_address} = $name;
return $name;
}
}
} else {
return @info{mush_address}; # return cached address
}
}
sub fun_quota
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (QUOTA) EXPECTS 1 ARGUMENTS";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NO SUCH OBJECT";
return quota($target,"max") . " " .
quota($target,"used") . " " .
quota($target,"left");
}
#
# fun_zone
# Place holder for when powers are implimented.
#
sub fun_zone
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (ENCRYPT) EXPECTS 1 ARGUMENT";
return 0;
}
sub fun_starttime
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,0) ||
return "#-1 FUNCTION (STARTTIME) EXPECTS 0 ARGUMENTS";
return scalar localtime(@info{server_start});
}
sub fun_encrypt
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,2) ||
return "#-1 FUNCTION (ENCRYPT) EXPECTS 2 ARGUMENTS";
my $text = evaluate($self,$prog,shift);
my $pass = evaluate($self,$prog,shift);
return crypt_code($self,$prog,$text,$pass,1);
}
sub fun_decrypt
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,2) ||
return "#-1 FUNCTION (DECRYPT) EXPECTS 2 ARGUMENTS";
my $text = evaluate($self,$prog,shift);
my $pass = evaluate($self,$prog,shift);
return crypt_code($self,$prog,$text,$pass,0);
}
sub fun_readonly
{
my ($self,$prog) = @_;
$$prog{read_only} = 1;
return undef;
}
sub fun_power
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,2) ||
return "#-1 FUNCTION (POWER) EXPECTS 2 ARGUMENTS";
my $num = evaluate($self,$prog,shift);
my $pow = evaluate($self,$prog,shift);
$num = 1 if(!looks_like_number($num));
$pow = 1 if(!looks_like_number($pow));
return $num ** $pow;
}
sub fun_strcat
{
my ($self,$prog) = (obj(shift),shift);
my $result;
for my $i (0 .. $#_) {
$result .= trim(evaluate($self,$prog,shift));
}
return $result;
}
sub fun_info
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (INFO) EXPECTS 1 ARGUMENT";
my $var = evaluate($self,$prog,shift);
if(defined @info{$var}) {
return @info{$var};
} else {
return undef;
}
}
sub fun_graph
{
my ($self,$prog,$x,$y) = @_;
return graph_connected($x,$y);
}
sub fun_password
{
my ($self,$prog) = (obj(shift),shift);
hasflag($self,"WIZARD") ||
hasflag($self,"GOD") ||
owner_id($$self{obj_id}) eq conf("webuser") ||
return "#-1 PERMISSION DENIED";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NO SUCH OBJECT";
if(mushhash(evaluate($self,$prog,shift)) eq get($target,"obj_password")) {
return 1;
} else {
return 0;
}
}
sub fun_lvariable
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,0,1) ||
return "#-1 FUNCTION (LVARIABLE) EXPECTS 0 OR 1 ARGUMENTS";
if(!defined $$prog{var}) {
return undef;
} elsif($#_ == -1) {
return uc(join(' ',keys %{$$prog{var}}));
} else {
my $pat = glob2re(shift);
my @result;
for my $key (keys %{$$prog{var}}) {
push(@result,uc($key)) if($key =~ /$pat/i);
}
return join(' ',@result);
}
}
sub fun_variables
{
my ($self,$prog) = (obj(shift),shift);
my $txt = evaluate($self,$prog,"\@rfind [escape(name(*adrick))]");
for my $i (balanced_split($txt,";",3,1)) {
printf(" split: '%s'\n",$i);
}
return print_var($$prog{var});
}
sub fun_conf
{
my ($self,$prog,$txt) = (obj(shift),shift,lc(trim(shift)));
if($txt ne undef) {
if($txt =~ /^CONF./i && (defined @info{conf}->{$'} ||
hasattr(obj(0),"conf.$'"))) {
printf("Trying: '$''\n");
return conf(lc(trim($')));
} else {
printf("!Trying: '$''\n");
return undef;
}
} else {
my @list;
if(defined @info{conf}) {
for my $key (sort keys %{@info{conf}}) {
push(@list,uc("CONF.$key")) if lc($key) ne "version";
}
return join(' ',@list);
} else {
return undef;
}
}
}
sub fun_lhelp
{
return join(' ',sort keys %help);
}
sub fun_s
{
my ($self,$prog) = (obj(shift),shift);
return evaluate($self,$prog,shift)
}
sub fun_help
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if(defined @help{lc(trim($txt))}) {
return @help{lc(trim($txt))};
} elsif(defined @help{lc(trim($txt)) . "()"}) {
return @help{lc(trim($txt)) . "()"};
} else {
return "#-1";
}
}
# return the flat file database structure for an object
sub fun_dump
{
my ($self,$prog) = (obj(shift),shift);
if(!(hasflag($self,"WIZARD") || hasflag($self,"GOD"))) {
return "#-1 PERMISSION DENIED";
}
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
return "#-1" if(!valid_dbref($target));
return db_object($$target{obj_id});
# return encode_base64(compress(db_object($$target{obj_id})));
}
sub fun_ansi2mush
{
my($self,$prog) = (obj(shift),shift);
my ($depth,$out) = (0);
my %ansi_letter = (
30 => "x", 40 => "X", 31 => "r", 41=> "R", 32 => "g", 42 => "G",
33 => "y", 43 => "Y", 34 => "b", 44 => "B", 35 => "m", 45 => "M",
36 => "c", 46 => "C", 37 => "w", 47 => "W", 4=> "u", 7 => "i",
1 => "h", 5 => "f", 0 => "n"
);
my $txt = evaluate($self,$prog,shift);
# printf("TXT: '%s'\n",ansi_remove($txt));
$txt =~ s/\r//g;
# $txt =~ s/ /%b/g;
my $str = ansi_init($txt);
my $snap = $$str{snap};
my $code = $$str{code};
my $ch = $$str{ch};
my $seg;
for my $i (0 .. $#$ch) {
for my $y (0 .. $#{$$code[$i]}) {
my $seq = @{$$code[$i]}[$y];
if($seq eq "\e[0m") {
$out .= mushify($seg) . (($depth) ? ")]" : "");
$seg = undef;
$depth = 0;
} elsif($seq =~ /^\e\[38;5;(\d+)m/ && defined @ansi_rgb{$1}){
$out .= mushify($seg) . (($depth) ? ")]" : "");
$out .= "[ansi(<#" . @ansi_rgb{$1} . ">,";
$depth = 1;
$seg = undef;
} elsif($seq =~ /^\e\[(\d+)m/ && defined @ansi_letter{$1}){
$out .= mushify($seg) . (($depth) ? ")]" : "");
$out .= "[ansi(" . @ansi_letter{$1} . ",";
$depth = 1;
$seg = undef;
} elsif($seq =~ /^\e\[38;5;(\d+);\d+m/ && defined @ansi_rgb{$1}){
$out .= mushify($seg) . (($depth) ? ")]" : "");
$out .= "[ansi(<#" . @ansi_rgb{$1} . ">,";
$depth = 1;
$seg = undef;
# } else {
# $out .= "[ansi(#unknown-" . ansi_debug($seq,1) . ",";
# $prev = undef;
# $depth++;
}
}
$seg .= $$ch[$i];
}
$out .= mushify($seg) . (($depth) ? "#)]" : "");
return $out;
}
sub fun_hasattr
{
my($self,$prog) = (obj(shift),shift);
my ($obj,$attr);
# handle args in "object/attr" or "object,attr" format
if($#_ == 0) {
($obj,$attr) = balanced_split(shift,"/",4);
} else {
($obj,$attr) = (shift,shift);
}
$obj = evaluate($self,$prog,$obj);
$attr = evaluate($self,$prog,$attr);
my $target = find($self,$prog,evaluate($self,$prog,$obj)) ||
return "#-1 NOT FOUND";
my $hash = mget($target,$attr);
return (ref($hash) eq "HASH") ? 1 : 0;
}
sub fun_hasattrp
{
my($self,$prog) = (obj(shift),shift);
my ($obj,$attr);
# handle args in "object/attr" or "object,attr" format
if($#_ == 0) {
($obj,$attr) = balanced_split(shift,"/",4);
} else {
($obj,$attr) = (shift,shift);
}
$obj = evaluate($self,$prog,$obj);
$attr = evaluate($self,$prog,$attr);
my $target = find($self,$prog,evaluate($self,$prog,$obj)) ||
return "#-1 NOT FOUND";
my $hash = mget($target,$attr); # check object attribute
return 1 if (ref($hash) eq "HASH");
my $parent = mget($target,"obj_parent"); # check parent attribute
return 0 if (ref($parent) ne "HASH" || !valid_dbref($$parent{value}));
if($attr =~ /one/) {
$hash = mget($$parent{value},$attr,1);
} else {
$hash = mget($$parent{value},$attr);
}
return (ref($hash) eq "HASH") ? 1 : 0;
}
sub fun_attr_created
{
my($self,$prog) = (obj(shift),shift);
my ($obj,$attr);
# handle args in "object/attr" or "object,attr" format
if($#_ == 0) {
($obj,$attr) = balanced_split(shift,"/",4);
} else {
($obj,$attr) = (shift,shift);
}
$obj = evaluate($self,$prog,$obj);
$attr = evaluate($self,$prog,$attr);
my $target = find($self,$prog,evaluate($self,$prog,$obj)) ||
return "#-1 NOT FOUND";
my $hash = mget($target,$attr);
if(ref($hash) eq "HASH") {
return $$hash{created};
} else {
return $$hash{created};
}
}
sub fun_attr_modified
{
my($self,$prog) = (obj(shift),shift);
my ($obj,$attr);
# handle args in "object/attr" or "object,attr" format
if($#_ == 0) {
($obj,$attr) = balanced_split(shift,"/",4);
} else {
($obj,$attr) = (shift,shift);
}
$obj = evaluate($self,$prog,$obj);
$attr = evaluate($self,$prog,$attr);
my $target = find($self,$prog,evaluate($self,$prog,$obj)) ||
return "#-1 NOT FOUND";
my $hash = mget($target,$attr);
if(ref($hash) eq "HASH") {
return $$hash{modified};
} else {
return $$hash{modified};
}
}
sub fun_tohex
{
my($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (TOHEX) EXPECTS 1 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
return sprintf("%X",$txt);
}
sub fun_colors
{
my($self,$prog) = (obj(shift),shift);
my @result;
good_args($#_,1,2) ||
return "#-1 FUNCTION (COLORS) EXPECTS 1 OR 2 ARGUMENTS";
my $txt = trim(evaluate($self,$prog,shift));
my $key = evaluate($self,$prog,shift);
if($key =~ /^\s*x\s*$/) {
if($txt =~ /^\s*0x\+\s*(.+?)\s*$/ || $txt =~ /^\s*\+\s*(.+?)\s*$/) {
if(defined @ansi_name{lc($1)}) {
if(!defined @ansi_rgb{@ansi_name{lc($1)}}) {
return "#-1 INTERNAL ERROR - UNDEFINED RGB VALUE " .
@ansi_name{lc($1)};
} else {
return "#" . @ansi_rgb{@ansi_name{lc($1)}};
}
}
}
return "#-1 INVALID COLOR SPECIFIED";
} elsif($key =~ /^\s*n\s*$/) {
if($txt =~ /^\s*0x\+\s*(.+?)\s*$/ || $txt =~ /^\s*\+\s*(.+?)\s*$/) {
if(defined @ansi_name{lc($1)}) {
for my $i (keys %ansi_name) {
if(@ansi_name{$i} eq @ansi_name{lc($1)}) {
push(@result,$i);
}
}
return join(" ",@result);
}
}
return "#-1 INVALID COLOR SPECIFIED";
} else {
return "#-1 UNIMPLIMENTED KEY";
}
}
#
# fun_ldelete
# Delete a word/item from the text.
sub fun_ldelete
{
my($self,$prog) = (obj(shift),shift);
my (@delete, @result);
good_args($#_,2,3,4) ||
return "#-1 FUNCTION (LDELETE) EXPECTS BETWEEN 2 AND 4 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $positions = evaluate($self,$prog,shift);
my $idelim = evaluate($self,$prog,trim(shift));
my $odelim = evaluate($self,$prog,trim(shift));
$idelim = " " if $idelim eq undef;
$odelim = $idelim if $odelim eq undef;
my @list = safe_split($txt,$idelim);
for my $i (sort {$b <=> $a} safe_split($positions," ")) {
if(isint($i) && $i >= 1 && $i <= $#list + 1) {
splice(@list,$i-1,1);
}
}
if($odelim ne " ") {
for my $i (0 .. $#list) {
@list[$i] = fun_squish($self,$prog,@list[$i]);
}
}
return join($odelim,@list);
}
sub fun_ansi_debug
{
my($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (FOREACH) EXPECTS 1 ARGUMENT";
return ansi_debug(evaluate($self,$prog,shift));
}
#
# for_foreach
# Take a list of characters and feed it through the specified function
# like u().
#
sub fun_foreach
{
my($self,$prog) = (obj(shift),shift);
my ($out,$left,$tmp);
good_args($#_,2,4) ||
return "#-1 FUNCTION (FOREACH) EXPECTS 2 OR 4 ARGUMENTS";
my $atr = atr_get($self,$prog,shift); # no attr/ no error
return "#-1 no attr" if($atr eq undef); # emulate mux/mush
my $str = trim(evaluate($self,$prog,shift));
if($#_ == 1) { # handle optional start/stop
my $start = evaluate($self,$prog,shift);
my $end = evaluate($self,$prog,shift);
($out,$tmp) = balanced_split($str,$start,4);
return if($tmp eq undef); # no starting point
# no change
($str,$left) = balanced_split($tmp,$end,4);
}
my $prev = get_digit_variables($prog); # save %0 .. %9
my $count = 0;
for(my ($i,$len)=(0,length($str));$i < $len;$i++) {
if(!set_digit_variables($self,$prog,"",substr($str,$i,1),$count++)) {
return managed_var_set_error("#-1");
}
$out .= evaluate($self,$prog,$atr);
}
if(!set_digit_variables($self,$prog,"",$prev)) { # restore %0 .. %9
return managed_var_set_error("#-1");
}
return $out . $left;
}
# src: http://rosettacode.org/wiki/Non-decimal_radices/Convert#Perl
sub fun_pack
{
my($self,$prog,$n,$b) = (obj(shift),shift);
good_args($#_,1,2,3) ||
return "#-1 FUNCTION (PACK) EXPECTS 1, 2, or 3 ARGUMENTS - $#_";
my $n = evaluate($self,$prog,shift);
my $b = evaluate($self,$prog,shift);
$b = 10 if $b eq undef;
my $s = "";
while ($n) {
printf("Processing $n\n");
$s .= ('0'..'9','a'..'z')[$n % $b];
$n = int($n/$b);
}
return "x" . scalar(reverse($s));
}
sub fun_unpack
{
my($self,$prog) = (obj(shift),shift);
good_args($#_,1,2,3) ||
return "#-1 FUNCTION (PACK) EXPECTS 1, 2, or 3 ARGUMENTS - $#_";
my $n = evaluate($self,$prog,shift);
my $b = evaluate($self,$prog,shift);
$b = 16 if $b eq undef;
my $t = 0;
for my $c (split(//, lc($n))) {
$t = $b * $t + index("0123456789abcdefghijklmnopqrstuvwxyz", $c);
}
return $t;
}
sub fun_pickrand
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1,2) ||
return "#-1 FUNCTION (PICKRAND) EXPECTS 1 OR 2 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $delim = evaluate($self,$prog,shift);
$delim = " " if($delim eq undef);
my $list = [ safe_split($txt,$delim) ];
return $$list[int(rand($#$list+1))];
}
#
# fun_if
#
sub fun_if
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,2,3) ||
return "#-1 FUNCTION (IF/IF_ELSE) EXPECTS 2 OR 3 ARGUMENTS";
my $exp = evaluate($self,$prog,shift);
shift if(!$exp);
return trim(evaluate($self,$prog,shift));
}
#
# fun_round
# Round a number with variable precision
#
sub fun_round
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1,2) ||
return "#-1 FUNCTION (HTML_STRIP) EXPECTS 1 OR 2 ARGUMENTS";
my $num = evaluate($self,$prog,shift);
my $precision = evaluate($self,$prog,shift);
if($precision eq undef || $precision !~ /^\s*\d+\s*$/) { # emulate tinymush
$precision = 0; # behavior
}
return sprintf("%.*f",$precision,$num);
}
sub fun_html_strip
{
my ($self,$prog,$txt) = (obj(shift),shift);
return "#-1 Not enabled" if(!module_enabled("html_restrict"));
good_args($#_,1) ||
return "#-1 FUNCTION (HTML_STRIP) EXPECTS 1 ARGUMENTS";
my $hr = HTML::Restrict->new();
return $hr->process(evaluate($self,$prog,shift));
}
#
# fun_pid
# Return the pid of the current program.
#
sub fun_pid
{
my ($self,$prog,$txt) = (obj(shift),shift);
return $$prog{pid};
}
#
# fun_lpid
# Return all pids that you own / can control.
#
sub fun_lpid
{
my ($self,$prog) = (obj(shift),shift);
my @list;
for my $pid (keys %engine) {
my $p = @engine{$pid};
if(defined $$p{stack} && ref($$p{stack}) eq "ARRAY" &&
controls($self,$$p{created_by}) &&
(!hasflag($$p{created_by},"GOD") || hasflag($self,"GOD"))) {
push(@list,$pid);
}
}
return join(' ',@list);
}
sub fun_null
{
my ($self,$prog,$txt) = (obj(shift),shift);
evaluate($self,$prog,shift);
return undef;
}
sub fun_trim
{
my ($self,$prog) = (obj(shift),shift);
my ($start,$end,%filter);
good_args($#_,1,2,3) ||
return "#-1 FUNCTION (TRIM) EXPECTS 1, 2, OR 3 ARGUMENTS";
my $return = chr(13);
my $input = evaluate($self,$prog,shift);
$input =~ s/\r//mg;
my $type = trim(ansi_remove(evaluate($self,$prog,shift)));
my $chars = trim(ansi_remove(evaluate($self,$prog,shift)));
if($type =~ /^\s*(b|l|r)\s*$/) { # check args
$type = $1;
} else {
$type = "b"; # emulate Mush w/no errors
}
if($chars eq undef) { # set chars to filter
@filter{" "} = 1;
@filter{chr(9)} = 1;
$input =~ s/ +/ /g;
} else {
for my $i (0 .. length($chars)) {
@filter{substr($chars,$i,1)} = 1;
}
}
my $txt = ansi_init($input);
if($type eq "b" || $type eq "l") { # find starting point
for my $i (0 .. ansi_length($txt)) {
$start = $i;
last if(!defined @filter{ansi_remove(ansi_substr($txt,$i,1))});
$start = $i;
}
} else {
$start = 0;
}
if($type eq "b" || $type eq "r") { # find ending point
for my $i (reverse 0 .. ansi_length($txt)) {
$end = $i;
last if(!defined @filter{ansi_remove(ansi_substr($txt,$i-1,1))});
}
} else {
$end = ansi_length($txt);
}
return ansi_substr($txt,$start,$end-$start); # return result
}
sub fun_escape
{
my ($self,$prog,$txt,$noeval) = (obj(shift),shift,shift,shift);
my ($str,$out);
# printf("%s\n",print_var($prog));
if($noeval) {
$str = ansi_init($txt);
} else {
$str = ansi_init(evaluate($self,$prog,$txt));
}
for my $i (0 .. $#{$$str{ch}}) {
if(@{$$str{ch}}[$i] eq "%" ||
@{$$str{ch}}[$i] eq "\\" ||
@{$$str{ch}}[$i] eq "[" ||
@{$$str{ch}}[$i] eq "]" ||
@{$$str{ch}}[$i] eq "(" ||
@{$$str{ch}}[$i] eq ")" ||
@{$$str{ch}}[$i] eq "," ||
@{$$str{ch}}[$i] eq ";") {
$out .= join('',@{@{$$str{code}}[$i]}) . "\\" . @{$$str{ch}}[$i];
} else {
$out .= join('',@{@{$$str{code}}[$i]}) . @{$$str{ch}}[$i];
}
}
return "\\" . $out;
}
#
# fun_mod
# Return the modulus of two numbers
#
sub fun_mod
{
my ($self,$prog,$txt) = (obj(shift),shift);
good_args($#_,2) ||
return "#-1 FUNCTION (MOD) EXPECTS 2 ARGUMENTS";
my $one = ansi_remove(evaluate($self,$prog,shift));
my $two = ansi_remove(evaluate($self,$prog,shift));
# divide by zero should result in an error in my opinion but TinyMUSH
# just returns 0, so we emulate this behavior.
if(!looks_like_number($one) || !looks_like_number($two) || $two == 0) {
return 0;
} else {
return $one % $two;
}
}
sub fun_stats
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
my ($hash, $target);
$txt = evaluate($self,$prog,$txt);
if($txt =~ /^\s*all\s*$/i || $txt =~ /^\s*$/) {
$hash = gather_stats(1,"all");
} else {
$target = find_player($self,$prog,$txt) ||
return "#-1 PLAYER NOT FOUND";
$hash = gather_stats(1,"",$target);
}
return sprintf("%s %s %s %s %s %s",
$$hash{ROOM} + $$hash{EXIT} + $$hash{OBJECT} +
$$hash{PLAYER} + $$hash{GARBAGE},
$$hash{ROOM},
$$hash{EXIT},
$$hash{OBJECT},
$$hash{PLAYER},
$$hash{GARBAGE});
}
sub type
{
my ($self,$prog,$obj) = @_;
if(hasflag($obj,"PLAYER")) {
return "PLAYER";
} elsif(hasflag($obj,"ROOM")) {
return "ROOM";
} elsif(hasflag($obj,"OBJECT")) {
return "OBJECT";
} elsif(hasflag($obj,"EXIT")) {
return "EXIT";
} else {
if(dest($obj) ne undef) { # has destination, exit
set_flag($self,$prog,$obj,"EXIT");
return "EXIT";
} else {
set_flag($self,$prog,$obj,"OBJECT");
return "OBJECT";
}
}
}
sub fun_lit
{
my ($self,$prog) = (obj(shift),shift);
return join(',',@_);
}
sub rgb2ansi
{
my ($r1,$g1,$b1) = @_;
my ($rgb_diff,$rgb_diff2,$result) = (1000,1000);
for my $i (16 .. 255) {
if(@ansi_rgb{$i} =~ /^(.{2})(.{2})(.{2})$/) {
$rgb_diff = abs(hex($1)-$r1) + abs(hex($2)-$g1) + abs(hex($3)-$b1);
if($rgb_diff < $rgb_diff2) {
$rgb_diff2 = $rgb_diff;
$result = $i;
return "\e[38;5;$i\m" if($rgb_diff2 == 0);
}
} else {
printf("Unparseable entry $i -> '@ansi_rgb{$i}'\n");
}
}
return "\e[38;5;$result\m";
}
sub fun_ansi_remove
{
my ($self,$prog,$txt) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (ANSI_REMOVE) EXPECTS 1 ARGUMENT";
return ansi_remove(evaluate($self,$prog,shift));
}
sub fun_ansi
{
my ($self,$prog) = (obj(shift),shift);
my $out;
good_args($#_,2) ||
return "#-1 FUNCTION (ANSI) EXPECTS 2 ARGUMENTS";
my $code = evaluate($self,$prog,shift);
my $txt = evaluate($self,$prog,shift);
my $item = $code;
# for my $item (split(" ",$code)) {
if($item =~ /^\s*<\s*(\d+)\s+(\d+)\s+(\d+)\s*>\s*$/) {
$out .= rgb2ansi($1,$2,$3);
} elsif($item=~/^\s*#\s*([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})\s*$/i ||
$item=~/^\s*<\s*#\s*([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})\s*>\s*$/i){
$out .= rgb2ansi(hex($1),hex($2),hex($3));
} elsif($item=~ /^\s*\+\s*([^ ]+)\s*$/) {
if(defined @ansi_name{lc($1)}) {
$out .= "\e[38;5;" . @ansi_name{lc($1)} . "m";
}
} elsif($code !~ /^\s*</) {
$out .= color($code,undef,1);
}
# }
return $out . $txt . "\e[0m";
}
sub fun_set
{
my ($self,$prog,$value) = (obj(shift),shift);
good_args($#_,2) ||
return "#-1 FUNCTION (SET) EXPECTS 2 ARGUMENTS";
my ($obj,$attr,$delim) = balanced_split(shift,"/",4);
my $target = find($self,$prog,evaluate($self,$prog,$obj)) ||
return "#-1";
return "#-1 PERMISSION DENIED" if(!controls($self,$target));
if($delim) { # set attribute flag
my $flag = trim(evaluate($self,$prog,shift));
if(!isatrflag($flag)) {
return "#-1 INVALID ATTRIBUTE FLAG";
} elsif(!hasattr($target,$attr)) {
return "#-1 ATTRIBUTE DOES NOT EXIST";
} elsif(!can_set_flag($self,$target,$flag)) {
return "#-1 PERMISSION DENIED";
} else {
set_atr_flag($target,$attr,$flag,0);
return undef;
}
}
my ($attr,$value,$delim) = balanced_split(shift,":",4);
my $attr = trim(evaluate($self,$prog,$attr));
if($delim && !reserved($attr)) { # set attribute
set($self,$prog,$target,$attr,evaluate($self,$prog,$value),1);
# set attribute value
} elsif($delim) {
return "#-1 INVALID ATTRIBUTE NAME";
} else { # set flag
my $flag = trim(evaluate($self,$prog,$attr));
if(!can_set_flag($self,$target,$flag)) {
return "#-1 PERMISSION DENIED";
} elsif(flag($flag)) {
set_flag($self,$prog,$target,$flag);
} else {
return "#-1 INVALID FLAG";
}
}
return undef;
}
#
# fun_setunion
# Join two lists together removing duplicates and return sorted.
#
sub fun_setunion
{
my ($self,$prog) = (obj(shift),shift);
my %list;
#--- [ handle arguments ]---------------------------------------------#
good_args($#_,2 .. 5) ||
return "#-1 FUNCTION (SETUNION) EXPECTS 2 to 5 ARGUMENTS";
my $list1 = evaluate($self,$prog,shift);
my $list2 = evaluate($self,$prog,shift);
my $delim = evaluate($self,$prog,shift);
my $sep = evaluate($self,$prog,shift);
my $type = evaluate($self,$prog,shift);
$delim = " " if($delim eq undef);
$sep = " " if($sep eq undef);
#--- [ do the work ]--------------------------------------------------#
for my $i (safe_split($list1,$delim), safe_split($list2,$delim)) {
add_union_element(\%list,$i,$type);
}
#--- [ return the results sorted ]------------------------------------#
if($type eq "d") { # dbref sort
return join($sep,sort({@list{$a} <=> @list{$b}} keys %list));
} elsif($type eq "f" || $type eq "n") { # number sort
return join($sep,sort({$a <=> $b} keys %list));
} else { # alphanumeric sort
return join($sep,sort({$a cmp $b} keys %list));
}
}
#
# fun_listinter
# Return only those items in both lists
#
sub fun_listinter
{
my ($self,$prog) = (obj(shift),shift);
my (%l1, %l2, @result,$count);
#--- [ handle arguments ]---------------------------------------------#
good_args($#_,2 .. 5) ||
return "#-1 FUNCTION (SETUNION) EXPECTS 2 to 5 ARGUMENTS";
my $list1 = evaluate($self,$prog,shift);
my $list2 = evaluate($self,$prog,shift);
my $delim = evaluate($self,$prog,shift);
my $sep = evaluate($self,$prog,shift);
my $type = evaluate($self,$prog,shift);
$delim = " " if($delim eq undef);
$sep = " " if($sep eq undef);
$type = 0 if($type ne 0 && $type ne 1); # emulate rhost behavior
#--- [ do the work ]--------------------------------------------------#
for my $i (safe_split($list2,$delim)) { # split up 2nd list
@l2{$i} = 1;
}
for my $i (safe_split($list1,$delim)) {
if(defined @l2{$i}) { # item in 2nd list
push(@result,$i) if(!defined @l1{$i}); # weed out dups?
@l2{$i} = 1 if($type == 0);
}
}
#--- [ return the results ]-------------------------------------------#
return join($sep,@result);
}
#
# fun_setdiff
# Returns the difference of two sets of lists
#
sub fun_setdiff
{
my ($self,$prog) = (obj(shift),shift);
my (%list, %result);
#--- [ handle arguments ]---------------------------------------------#
good_args($#_,2 .. 5) ||
return "#-1 FUNCTION (SETUNION) EXPECTS 2 to 5 ARGUMENTS";
my $list1 = evaluate($self,$prog,shift);
my $list2 = evaluate($self,$prog,shift);
my $delim = evaluate($self,$prog,shift);
my $sep = evaluate($self,$prog,shift);
my $type = evaluate($self,$prog,shift);
$delim = " " if($delim eq undef);
$sep = " " if($sep eq undef);
#--- [ do the work ]--------------------------------------------------#
for my $i (safe_split($list2,$delim)) {
add_union_element(\%list,$i,$type);
}
for my $i (safe_split($list1,$delim)) {
if(!defined @list{$i}) {
add_union_element(\%result,$i,$type);
}
}
#--- [ return the results sorted ]------------------------------------#
if($type eq "d") { # dbref sort
return join($sep,sort({@result{$a} <=> @result{$b}} keys %result));
} elsif($type eq "f" || $type eq "n") { # number sort
return join($sep,sort({$a <=> $b} keys %result));
} else { # alphanumeric sort
return join($sep,sort({$a cmp $b} keys %result));
}
}
sub fun_entities
{
my ($self,$prog) = (obj(shift),shift);
return "#-1 FUNCTION (ENTITIES) NOT ENABLED" if(!module_enabled("entities"));
good_args($#_,2) ||
return "#-1 FUNCTION (ENTITIES) EXPECTS 2 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
if($txt !~ /^\s*(encode|decode)\s*$/i) {
return "#-1 EXPECTED FIRST ARGUEMENT OF ENCODE OR DECODE";
} elsif($txt =~ /^\s*encode\s*$/i) {
return encode_entities(evaluate($self,$prog,shift));
} else {
return decode_entities(evaluate($self,$prog,shift));
}
}
#
# webobject
# Is the object part of the http webobject?
#
sub webobject
{
my $obj = shift;
if(owner_id($obj) eq owner_id(conf("webobject"))) {
return 1;
} else {
return 0;
}
}
#
# fun_file
# Return the contents of a file
#
sub fun_file
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (FILE) EXPECTS 1 ARGUMENT";
hasflag($self,"WIZARD") || webobject($self) ||
return set_var($prog,"data","#-1 PERMISSION DENIED");
my $fn = evaluate($self,$prog,shift);
if($fn !~ /\.(txt|pl|js|html|css)$/i) {
return "#-1 UNKNOWN FILE";
} else {
my $file = getfile($fn);
if($file eq undef) {
return "#-1 UNKNOWN FILE";
} else {
return $file;
}
}
}
#
# fun_write
# Writ
sub fun_write
{
my ($self,$prog,$fn,$data,$mode) = (obj(shift),shift,shift,shift,shift);
my $file;
if(!hasflag($self,"GOD")) {
return "#-1 PERMISSION DENIED.";
} elsif(uc($mode) ne "WRITE" && uc($mode) ne "W" &&
uc($mode) ne "APPEND" && uc($mode) ne "A" && $mode ne undef) {
return "#-1 INVALID MODE: EXPECTED APPEND[A], WRITE[W], OR NOTHING";
} elsif($fn =~ /[\/\\]/) {
return "#-1 FILENAME SHALL NOT CONTAIN \/ OR \\";
} elsif($fn =~ /^\s*\./) {
return "#-1 FILENAME SHALL NOT START WITH A PERIOD";
} elsif(lc($mode) eq "WRITE" || lc($mode) eq "W" || $mode eq undef) {
open($file,"> files/$fn") || return "#-1 UNABLE TO OPEN FILE 'txt/$fn'";
} elsif(lc($mode) eq "APPEND" || lc($mode) eq "A") {
open($file,"> files/$fn") || return "#-1 UNABLE TO OPEN FILE";
}
printf($file "%s",evaluate($self,$prog,$data));
close($file);
}
sub fun_ip
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (IP) EXPECTS 1 ARGUMENT";
my $target = find_player($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
return "#-1 PERMISSION DENIED" if(!controls($self,$target));
for my $i (keys %connected) {
my $hash = @connected{$i};
if($$hash{raw} == 0 && $$hash{obj_id} == $$target{obj_id}) {
return $$hash{ip};
}
}
return undef;
}
#
# fun_money
# Return how much money the target has. TinyMUSH does not seem to
# put any restrictions on checking to see how much money something
# has.
#
sub fun_money
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (MONEY) EXPECTS 1 ARGUMENT";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
return money($target);
}
#
# fun_lflags
# Return the list of flags of the target in a readable format.
#
sub fun_lflags
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (URL) EXPECTS 1 ARGUMENT";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
return flag_list($target,1);
}
#
# fun_url
# Open up a http/https connection to a website. Input from the socket
# can be recieved by calling this function multiple times with the same
# argument. Data is placed in %{data} variable.
#
sub fun_url
{
my ($self,$prog) = (obj(shift),shift);
my ($host,$path,$sock,$secure);
good_args($#_,1,2) ||
return set_var($prog,"data","#-1 FUNCTION (URL) EXPECTS 1 OR 2 ARGUMENTS");
hasflag($self,"SOCKET_INPUT") ||
return set_var($prog,"data","#-1 PERMISSION DENIED");
my $txt = ansi_remove(evaluate($self,$prog,shift));
my $accept = ansi_remove(evaluate($self,$prog,shift));
$accept = "*/*" if($accept =~ /^\s*$/);
if($txt =~ /^https:\/\/([^\/]+)\//) {
($host,$path,$secure) = ($1,$',1);
} elsif($txt =~ /^http:\/\/([^\/]+)\//) {
($host,$path,$secure) = ($1,$',0);
} else {
return set_var($prog,"data","#-1 Unable to parse URL");
}
if($secure && !module_enabled("url_https")) {
return set_var($prog,"data","#-1 HTTPS DISABLED");
} elsif(!$secure && !module_enabled("url_http")) {
return set_var($prog,"data","#-1 HTTP DISABLED");
} elsif(hasflag($self,"SOCKET_PUPPET") && find_socket($self,$prog) ne undef){
return set_var($prog,"data","#-1 CONNECTION ALREADY OPEN WITH \@TELNET");
} elsif(defined $$prog{socket_id} && $$prog{socket_url} ne $txt &&
!defined $$prog{socket_closed}) {
return set_var($prog,"data","#-1 CONNECTION ALREADY OPEN");
} elsif($$prog{socket_url} eq $txt) { # existing connection
my $buff = $$prog{socket_buffer};
if($#$buff >= 0) {
my $data = shift(@$buff);
# wttr.in debug
# if($data =~ /\d mi/) {
# printf("%s -> %s\n",lord($`));
# printf(" '%s'\n",ansi_debug($data));
# }
set_var($prog,"data",$data);
return 1;
} elsif(!defined $$prog{socket_closed}) {
$$prog{idle} = 1; # hint to queue
set_var($prog,"data","#-1 DATA PENDING");
return 1;
} elsif(defined $$prog{socket_closed}) {
set_var($prog,"data","#-1 CONNECTION CLOSED");
return 0;
}
} else { # new connection
delete @info{socket_buffer}; # last request buffer
if($secure) { # open connection
$sock = Net::HTTPS::NB->new(Host => $host);
} else {
$sock = Net::HTTP::NB->new(Host => $host);
}
# printf("HOST: '%s'\n",$host);
# printf("PATH: '%s'\n",$path);
# printf("SEC: '%s'\n",$secure);
$$prog{socket_url} = $txt;
if(!$sock) {
$$prog{socket_closed} = 1;
$$prog{socket_buffer} = [ "#-1 CONNECTION FAILED" ];
return 1;
}
# $sock->blocking(0); # don't block
$$prog{socket_id} = $sock; # link prog to socket
delete @$prog{socket_closed};
# make request as curl (helps with wttr.in)
$path =~ s/ /%20/g;
set_var($prog,"url",$path);
eval { # protect against uncontrollable problems
if($#_ == 1) {
my ($type,$value) = (shift,shift);
$sock->write_request(GET => "/$path",
'User-Agent' => 'curl/7.52.1',
$type => $value,
Accept => $accept
);
} else {
# printf("ARGS: $#_\n");
$sock->write_request("GET" => "\/$path",
"User-Agent" => "curl/7.52.1",
"Accept" => $accept
);
# printf("got this far\n");
}
# $sock->write_request(GET => "/$path", 'User-Agent' => 'Wget/1.19.4');
# printf($sock "GET /$path HTTP/1.1\n");
# printf($sock "User-Agent: Wget/1.19.4 (linux-gnu)\n");
# printf($sock "Accept: */*\n");
# printf($sock "Accept-Encoding: identity\n");
# printf($sock "Host: $host\n");
# printf($sock "Connection: Keep-Alive\n\n");
# printf("GET /$path HTTP/1.1\n");
# printf("User-Agent: Wget/1.19.4 (linux-gnu)\n");
# printf("Accept: */*\n");
# printf("Accept-Encoding: identity\n");
# printf("Host: $host\n");
# printf("Connection: Keep-Alive\n\n");
# printf("-------[done]-----\n");
};
if($@) { # something went wrong?
printf("ERROR: '%s'\n",$@);
$$prog{socket_closed} = 1;
$$prog{socket_buffer} = [ "#-1 PAGE LOAD FAILURE" ];
return 1;
}
@connected{$sock} = { # add to mush sockets list
obj_id => $$self{obj_id},
sock => $sock,
raw => 1,
hostname => $1,
port => 80,
loggedin => 0,
opened => time(),
enactor => $self,
prog => $prog,
};
# set how socket data will be handled - i.e. @info{io}
@{@connected{$sock}}{raw} = 2;
$readable->add($sock); # add to listener
return 1;
}
}
# what should i draw today
#
# fun_args
# Return all the arguements passed into the calling function.
#
sub fun_args
{
my ($self,$prog) = (shift,shift);
my @result;
my $delim = evaluate($self,$prog,shift);
$delim = " " if($delim eq undef);
for my $i ( sort {$a <=> $b} grep {/^\d+$/} keys %{$$prog{var}}) {
if(@{$$prog{var}} ne undef) {
push(@result,@{$$prog{var}}{$i});
}
}
return join($delim,@result);
}
#
# fun_shift
# Remove an item from the begining of the list (%0 .. %999).
#
sub fun_shift
{
my ($self,$prog) = (shift,shift);
my $result;
for my $i ( sort {$a <=> $b} grep {/^\d+$/} keys %{$$prog{var}}) {
$result = @{$$prog{var}}{$i} if($i == 0);
if(!managed_var_set($prog,$i,@{$$prog{var}}{$i+1})) {
return managed_var_set_error("#-1");
}
}
return $result;
}
#
# fun_unshift
# Add an item to the begining of the list (%0 .. %999).
#
sub fun_unshift
{
my ($self,$prog) = (shift,shift);
my $result;
for my $i ( reverse sort {$a <=> $b} grep {/^\d+$/} keys %{$$prog{var}}) {
if(!managed_var_set($prog,$i+1,@{$$prog{var}}{$i})) {
return managed_var_set_error("#-1");
}
}
if(!managed_var_set($prog,0,shift)) {
return managed_var_set_error("#-1");
}
return undef;
}
#
# fun_pop
# Remove an item from the end of the list (%0 .. %999).
#
sub fun_pop
{
my ($self,$prog) = (shift,shift);
# search for last position
for my $i (sort {$b <=> $a} grep {/^\d+$/} keys %{$$prog{var}}) {
if(@{$$prog{var}}{$i} ne undef) {
my $result = @{$$prog{var}}{$i};
if(!managed_var_set($prog,$i,undef)) {
return managed_var_set_error("#-1");
}
return $result;
}
}
return undef;
}
#
# fun_push
# Add an item to the end of the list (%0 .. %999).
#
sub fun_push
{
my ($self,$prog) = (shift,shift);
my $value = evaluate($self,$prog,shift);
for my $i (sort {$b <=> $a} grep {/^\d+$/} keys %{$$prog{var}}) {
if(@{$$prog{var}}{$i} ne undef) {
if(!managed_var_set($prog,$i+1,$$prog{var}->{$i})) {
return managed_var_set_error("#-1");
}
return undef;
}
}
if(!managed_var_set($prog,0,$value)) {
return managed_var_set_error("#-1");
}
return undef;
}
#
# ord
# Returns the ASCII numberical value of the first character.
#
sub fun_ord
{
my ($self,$prog) = (shift,shift);
return ord(substr(shift,0,1));
}
#
# chr
# Returns the ASCII numberical value of the first character.
#
sub fun_chr
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (CONTROLS) EXPECTS 1 ARGUMENT";
my $num = evaluate($self,$prog,shift);
if(hasflag($self,"WIZARD")) {
return chr($num);
} elsif(($num > 31 && $num < 127) || $num == 11 || $num == 13) {
return chr($num);
} else {
return "!";
}
}
sub fun_invocation
{
return "#-1 FUNCTION INVOCATION LIMIT HIT";
}
sub fun_controls
{
my ($self,$prog) = (shift,shift);
good_args($#_,1,2) ||
return "#-1 FUNCTION (CONTROLS) EXPECTS 2 ARGUMENTS";
my $obj = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 ARG1 NOT FOUND";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 ARG2 NOT FOUND";
return controls($obj,$target);
}
sub fun_max
{
my ($self,$prog,@list) = @_;
my $max;
for my $i (@list) {
my $number = evaluate($self,$prog,$i);
if($number !~ /^\s*(\d+)\s*$/) { # treat like zero
$number = 0;
}
$max = $number if($number > $max || $max eq undef);
}
if($max eq undef) {
return "#-1 FUNCTION (MAX) EXPECTS BETWEEN 1 AND 100 ARGUMENTS";
} else {
return $max;
}
}
#
# fun_convsecs
# Convert number of seconds from epoch to a readable date
#
sub fun_convsecs
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (CONVSECS) EXPECTS 1 ARGUMENT";
my $txt = evaluate($self,$prog,shift);
if($txt =~ /^\s*(\d+)\s*$/) {
return scalar localtime($1);
} else {
return "#-1 INVALID SECONDS";
}
}
#
# convtime
# Convert a time string to epoch time. TinyMUSH's version only converts a
# specific format. This function taps into a function that already exists
# that tries to convert a timestring of almost any format.
#
#
sub fun_convtime
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (CONVTIME) EXPECTS 1 ARGUMENTS";
return fuzzy(evaluate($self,$prog,shift));
}
sub fun_find
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (CONVSECS) EXPECTS 1 ARGUMENT";
my $obj = find($self,$prog,evaluate($self,$prog,shift));
if($obj ne undef) {
return $$obj{obj_id};
} else {
return "#-1 UNFOUND OBJECT";
}
}
sub fun_min
{
my ($self,$prog,$txt) = (obj(shift),shift);
my $min;
good_args($#_,1 .. 100) ||
return "#-1 FUNCTION (MIN) EXPECTS 1 AND 100 ARGUMENTS";
while($#_ >= 0) {
my $txt = evaluate($self,$prog,shift);
if($txt !~ /^\s*-{0,1}\d+\s*$/) { # emulate mush behavior
$min = 0 if ($min > 0 || $min eq undef);
} elsif($min eq undef || $min > $txt) {
$min = $txt;
}
}
return $min;
}
sub fun_fold
{
my ($self,$prog,$txt) = (obj(shift),shift);
my ($count,$atr,$last,$zero,$one);
good_args($#_,2,3,4) ||
return "#-1 FUNCTION (FOLD) EXPECTS 2 TO 3 ARGUMENTS";
my $atr = evaluate($self,$prog,shift);
my $list = evaluate($self,$prog,shift);
my $base = evaluate($self,$prog,shift);
my $idelim = evaluate($self,$prog,shift);
my $prev = get_digit_variables($prog);
my $atr = fun_get($self,$prog,$atr);
return $atr if($atr eq undef || $atr =~ /^#-1 /);
my (@list) = safe_split($list,$idelim);
while($#list >= 0) {
if($count eq undef && $base ne undef) {
($zero,$one) = ($base,shift(@list));
} elsif($count eq undef) {
($zero,$one) = (shift(@list),shift(@list));
} else {
($zero,$one) = ($last,shift(@list));
}
if(!set_digit_variables($self,$prog,"",$zero,$one)) {
return managed_var_set_error("#-1");
}
$last = evaluate($self,$prog,$atr);
$count++;
}
if(!set_digit_variables($self,$prog,"",$prev)) {
return managed_var_set_error("#-1");
}
return $last;
}
sub fun_idle
{
my ($self,$prog,$txt) = (obj(shift),shift);
my $idle;
good_args($#_,1) ||
return "#-1 FUNCTION (IDLE) EXPECTS 1 ARGUMENT";
my $name = evaluate($self,$prog,shift);
my $player = find_player($self,$prog,$name) ||
return -2;
if(!defined @connected_user{$$player{obj_id}}) {
return -3;
} else {
# search all connections
for my $con (keys %{@connected_user{$$player{obj_id}}}) {
if(defined @{@connected{$con}}{last}) {
my $last = @{@connected{$con}}{last};
# find least idle connection
if($idle eq undef || $idle > time() - $$last{time}) {
$idle = time() - $$last{time};
}
}
}
return ($idle eq undef) ? -1 : $idle;
}
}
sub fun_conn
{
my ($self,$prog,$txt) = (obj(shift),shift);
my ($result,$target,$port) = (-1);
good_args($#_,1) ||
return "#-1 FUNCTION (CONN) EXPECTS 1 ARGUMENT";
my $lookfor = evaluate($self,$prog,shift);
if(isint($lookfor)) {
$port = $lookfor;
} else {
$target = find_player($self,$prog,$lookfor) ||
return -1;
}
for my $key (keys %connected) {
my $hash = @connected{$key};
if(!hasflag($hash,"DARK")) {
if(($port eq undef && $$target{obj_id} == $$hash{obj_id}) ||
($port ne undef && $$hash{port} == $port)) {
my $onfor = time() - $$hash{start};
$result = $onfor if($onfor > $result);
}
}
}
return $result;
}
#
# lowercase the provided string(s)
#
sub fun_ucstr
{
my ($self,$prog,$txt) = (obj(shift),shift);
my @out;
while($#_ >= 0) {
my $str = ansi_init(evaluate($self,$prog,shift));
for my $i (0 .. $#{$$str{ch}}) {
@{$$str{ch}}[$i] = uc(@{$$str{ch}}[$i]);
}
push(@out,ansi_string($str,1));
}
return join(',',@out);
}
sub fun_sort
{
my ($self,$prog,$txt) = (obj(shift),shift);
return join(' ',sort split(" ",evaluate($self,$prog,shift)));
}
sub fun_base64
{
my ($self,$prog) = (obj(shift),shift);
if(!module_enabled("mime")) {
return "#-1 FUNCTION DISABLED (MIME MODULE DISABLED)";
}
good_args($#_,2) ||
return "#-1 FUNCTION (BASE64) EXPECTS 2 ARGUMENT ($#_)";
my $type = ansi_remove(evaluate($self,$prog,shift));
my $txt = ansi_remove(evaluate($self,$prog,shift));
if(length($type) == 0) {
return "#-1 FIRST ARGUMENT MUST BE Encode OR DECODE";
} elsif(lc($type) eq substr("encode",0,length($type))) {
my $txt = encode_base64($txt);
$txt =~ s/\r|\n//g;
return $txt;
} elsif(lc($type) eq substr("decode",0,length($type))) {
return decode_base64($txt);
} else {
return "#-1 FIRST ARGUMENT MUST BE ENCODE OR DECODE-",lc($type);
}
}
sub fun_compress
{
my ($self,$prog) = (obj(shift),shift);
if(!module_enabled("compress")) {
return "#-1 FUNCTION DISABLED (COMPRESS MODULE DISABLED)";
}
hasflag($self,"WIZARD") ||
owner_id($$self{obj_id}) eq conf("webuser") ||
return "#-1 FUNCTION (COMPRESS) EXPECTS WIZARD FLAG OR IS WEBUSER";
good_args($#_,1) ||
return "#-1 FUNCTION (COMPRESS) EXPECTS 1 ARGUMENT";
my $txt = evaluate($self,$prog,shift);
return compress($txt);
}
sub fun_uncompress
{
my ($self,$prog) = (obj(shift),shift);
if(!module_enabled("compress")) {
return "#-1 FUNCTION DISABLED (UNCOMPRESS MODULE DISABLED)";
}
hasflag($self,"WIZARD") ||
owner_id($$self{obj_id}) eq conf("webuser") ||
return "#-1 FUNCTION (UNCOMPRESS) EXPECTS WIZARD FLAG OR IS WEBUSER";
good_args($#_,1) ||
return "#-1 FUNCTION (UNCOMPRESS) EXPECTS 1 ARGUMENT";
my $txt = evaluate($self,$prog,shift);
return uncompress($txt);
}
sub fun_reverse
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (REVERSE) EXPECTS 1 ARGUMENT";
return reverse evaluate($self,$prog,shift);
}
sub fun_revwords
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (REVWORDS) EXPECTS 1 ARGUMENT";
return join(' ',reverse split(/\s+/,evaluate($self,$prog,shift)));
}
#
# fun_telnet
# This function just makes it easier for mushcode to exit when
# the connection ends/fails. This function can be updated without
# requiring a change if the implimentation of @telnet changes.
sub fun_telnet
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (TELNET_OPEN) EXPECTS 1 ARGUMENT";
my $txt = lc(evaluate($self,$prog,shift));
if($txt eq "#-1 connection closed" ||
$txt eq "#-1 unknown socket") {
return 0;
} else {
return 1;
}
}
sub fun_rand
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (RAND) EXPECTS 1 ARGUMENT";
my $txt = evaluate($self,$prog,shift);
if($txt =~ /^\s*(\d+)\s*$/) {
if($1 < 1) {
return "#-1 ARGUEMENT MUST BE GREATER OR EQUAL TO 1";
} else {
return sprintf("%d",rand($1));
}
} else {
return "#-1 ARGUEMENT MUST BE INTEGER";
}
}
sub isint
{
my $num = shift;
return ($num =~ /^\s*(\d+)\s*$/) ? 1 : 0;
}
sub fun_lrand
{
my ($self,$prog) = (obj(shift),shift);
my @result;
good_args($#_,3,4) ||
return "#-1 FUNCTION (LRAND) EXPECTS 3 OR 4 ARGUMENTS";
my $lower = evaluate($self,$prog,shift);
my $upper = evaluate($self,$prog,shift);
my $count = evaluate($self,$prog,shift);
my $delim = evaluate($self,$prog,shift);
$lower = 0 if(!isint($lower));
$upper = 0 if(!isint($upper));
$delim = " " if $delim eq undef;
if(!isint($count)) {
$count = 0;
} elsif($count > 4000) { # set upper limit
$count = 4000;
}
my $diff = $upper - $lower;
for my $i (1 .. $count) {
push(@result,int(rand($diff) + $lower));
}
return join("$delim",@result);
}
sub fun_lexits
{
my ($self,$prog) = (obj(shift),shift);
my @result;
good_args($#_,1) ||
return "#-1 FUNCTION (LEXITS) EXPECTS 1 ARGUMENT";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
my $perm = hasflag($self,"WIZARD");
for my $exit (lexits($target)) {
if($perm || !hasflag($exit,"DARK")) {
push(@result,"#" . $$exit{obj_id});
}
}
return join(' ',@result);
}
sub fun_lcon
{
my ($self,$prog) = (obj(shift),shift);
my @result;
good_args($#_,1) ||
return "#-1 FUNCTION (LCON) EXPECTS 1 ARGUMENT";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
my $perm = hasflag($self,"WIZARD");
# object can lcon() its current location or if it owns the object
if(!($perm || owner($target) == owner($self) || loc($self) == loc($target))){
return "#-1";
}
for my $obj (lcon($target)) {
push(@result,"#" . $$obj{obj_id}) if($perm || !hasflag($obj,"DARK"));
}
return join(' ',@result);
}
sub age
{
my $date = shift;
return sprintf("%d",(time() - $date) / 86400);
}
sub graph_connected
{
my ($size_x,$size_y) = @_;
my (%all, %usage,$max,$val,$min,@out, $prev);
$size_y = 8 if($size_y eq undef || $size_y < 8);
my $attr = mget(0,"stat_login");
if($attr ne undef) {
my $hash = $$attr{value};
for my $key (keys %$hash) {
@all{age(fuzzy($key))} = $$hash{$key};
$max = $$hash{$key} if $$hash{$key} > $max;
if($$hash{$key} < $max || $max eq undef) {
$min = $$hash{$key};
}
}
}
$min = 1 if $min == 0;
# build the graph from the data within @all
for my $x ( 1 .. $size_x ){
if($x == 1) {
$val = $max;
# } elsif($x == $size_x) {
# $val = $min;
} else {
$val = sprintf("%d",int($max-($x *($max/$size_x))+1.5));
}
if($val ne $prev) {
@out[$x-1] = sprintf("%*d|",length($max),$val);
$prev = $val;
} else {
@out[$x-1] = sprintf("%*s|",length($max)," ");
}
for my $y ( 0 .. ($size_y-1)) {
if($val <= @all{$y}) {
@out[$x-1] .= "#|";
} elsif($x == $size_x && @all{$y} > 0) {
@out[$x-1] .= "*|";
} else {
@out[$x-1] .= " |";
}
}
}
my $start = $#out+1;
@out[$start] = " " x (length($max)+1);
@out[$start+1] = " " x (length($max)+1);
my $inter = $size_y / 4;
$prev = undef;
for(my $y=0;$y <= $size_y-1;$y++) {
my $curr = sprintf("%02d",(localtime(time() - ($y * 86400)))[3]);
my $next = sprintf("%02d",(localtime(time() - (($y+1) * 86400)))[3]);
if(substr($curr,0,1) ne substr($next,0,1)) {
@out[$start] .= sprintf("=[%s]",substr($next,0,1));
@out[$start+1] .= substr(sprintf("%2d",$curr),1,1) . "|";
@out[$start+1] .= substr(sprintf("%2d",$next),1,1) . "|";
$y++;
} else {
@out[$start] .= "==";
@out[$start+1] .= substr(sprintf("%2d",$curr),1,1) . "|";
}
}
return join("\n",@out);
}
#
# fun_run
# Run a command as if it was a function. Each @command cannot be run
# as a function should will need a test condition to prevent it
# from running like below:
#
# in_run_function($prog) && # sleep can not be called from inside run()
# return out($prog,"#-1 \@SLEEP can not be called from RUN function");
#
sub fun_run
{
my ($self,$prog) = (shift,shift);
my (%none, $hash, %tmp, $match, $cmd,$arg);
good_args($#_,1) ||
return "#-1 FUNCTION (RUN) REQUIRES 1 ARGUMENT";
in_run_function($prog) &&
return "#-1 Function run cannot be called recursively or not allowed.";
my $txt = evaluate($self,$prog,shift);
my $command = { runas => $self };
if($txt =~ /^\s*([^ \/]+)(\s*)/) { # split cmd from args
($cmd,$arg) = (lc($1),$');
} else {
return #-1 No command given to run; # only spaces
}
$$prog{nomushrun} = 1;
my $cmd = { runas => $self,
source => $$prog{source},
invoker => invoker($prog,$self),
prog => $prog,
mdigits => {},
cmd => $txt,
};
my $tmp = $$prog{output};
$$prog{output} = [];
spin_run($prog,$cmd);
my $output = join(',',@{$$prog{output}});
if($tmp eq undef) {
delete @$prog{output};
} else {
$$prog{output} = $tmp;
}
delete @$prog{nomushrun};
$output =~ s/\n+$//;
return $output;
}
sub safe_split
{
my ($txt,$delim,$flag) = @_;
my ($start,$pos,@result) = (0,0);
my $orig = $txt;
$delim = ansi_remove($delim);
if($delim =~ /^\s*\n\s*/m) {
$delim = "\n";
} else {
$delim =~ s/^\s+|\s+$//g;
if($delim eq " " || $delim eq undef) {
# $txt =~ s/\s+/ /g;
# $txt =~ s/^\s+|\s+$//g;
$delim = " ";
}
}
my $txt = ansi_init($txt);
my $size = ansi_length($txt);
my $dsize = ansi_length($delim);
my $ch = $$txt{ch};
if($delim eq " " && !$flag) { # exclude inital spaces
for(;$pos < $size;$pos++) { # when delim is a space
last if(ansi_substr($txt,$pos,$dsize,1) ne $delim);
}
}
for(;$pos < $size;$pos++) {
if(ansi_substr($txt,$pos,$dsize,1) eq $delim) {
if($delim eq " ") {
for($pos++;$pos < $size &&
ansi_substr($txt,$pos,1,1) eq " ";$pos++) {};
$pos-- if($$ch[$pos] ne " ");
}
push(@result,ansi_substr($txt,$start,$pos-$start));
$start = $pos + $dsize;
}
}
push(@result,ansi_substr($txt,$start,$size)) if($start < $size);
return @result;
}
sub list_functions
{
return join(' ',sort keys %fun);
}
sub good_args
{
my ($count,@possible) = @_;
$count++;
for my $i (0 .. $#possible) {
return 1 if($count eq $possible[$i]);
}
return 0;
}
# sub quota
# {
# my $self = shift;
#
# return quota_left($self);
# }
sub quota
{
my ($self,$type) = (obj(shift),shift);
my $target = owner($self);
return undef if($type !~ /^(max|used|left)$/);
return undef if(!valid_dbref($self) || !hasflag($target,"PLAYER"));
if(get($target,"obj_quota") =~ /^([-\d]+),([-\d]+)$/) {
if($type eq "max") {
return $1;
} elsif($type eq "used") {
return $2;
} elsif($type eq "left") {
return $1 - $2;
}
} else {
return 0;
}
}
#
# set_quota
# type
# max : set the maxium allowed objects
# used : set number of used objects
# add : Add one object to the number of used objects
# sub : Subtract one object to the number of used objects
#
sub set_quota
{
my ($target,$type,$amount) = (obj(shift),shift,shift);
my $owner = owner($target);
# verify arguments
return 0 if($type !~ /^(max|used|add|subtract|sub)$/);
if(!(($type =~ /^(max|used)$/ && $amount =~ /^\s*(\d+)\s*$/) ||
($type =~ /^(add|sub)$/ && $amount eq undef))) {
return 0;
}
return 0 if($owner eq undef);
# do the work
if(get($owner,"obj_quota") =~ /^([-\d]*),([-\d]*)$/) {
if($type eq "max") {
db_set($owner,"obj_quota","$amount," . nvl($2,0));
} elsif($type eq "used") {
db_set($owner,"obj_quota",nvl($1,0) . ",$amount");
} elsif($type eq "add") {
db_set($owner,"obj_quota",nvl($1,0) . "," . ($2 - 1));
} elsif($type eq "subtract" || $type eq "sub") {
db_set($owner,"obj_quota",nvl($1,0) . "," . ($2 + 1));
} else {
return 0;
}
} elsif($type eq "max") {
db_set($owner,"obj_quota","$amount,1");
} else {
return 0;
}
return 1;
}
sub fun_mudname
{
my ($self,$prog) = (shift,shift);
my $name = conf("mudname");
return ($name eq undef) ? "TeenyMUSH" : $name;
}
sub fun_version
{
my ($self,$prog) = @_;
if(hasflag($self,"COMPAT")) {
my $atr = get($self,"TEENY_VERSION");
if(empty($atr)) {
return "TinyMUSH version 3.1 patchlevel 3 #1 [06/06/2006]";
} else {
return $atr;
}
} else {
return conf("version");
}
}
#
# fun_web
# Returns if the current session is coming from a web
# connection or a normal mush connection
#
sub fun_web
{
my ($self,$prog) = @_;
return ($$prog{hint} eq "WEB") ? 1 : 0;
}
#
# fun_setinter
# Return any matching item in both lists
#
sub fun_setinter
{
my ($self,$prog) = (shift,shift);
my (%list, %out);
for my $i (split(/ /,evaluate($self,$prog,@_[0]))) {
$i =~ s/^\s+|\s+$//g;
@list{$i} = 1;
}
for my $i (split(/ /,evaluate($self,$prog,@_[1]))) {
$i =~ s/^\s+|\s+$//g;
@out{$i} = 1 if(defined @list{$i});
}
return join(' ',sort keys %out);
}
sub fun_lwho
{
my ($self,$prog) = (shift,shift);
my @who;
good_args($#_,0,1) ||
return "#-1 FUNCTION (LWHO) EXPECTS 0 OR 1 ARGUMENTS-$#_";
my $flag = evaluate($self,$prog,shift);
if($flag ne undef && $flag !~ /^\s*(0|1)\s*$/) {
return "#-1 ARGUMENT 1 SHOULD BE EITHER 0 OR 1";
}
for my $key (sort {@{@connected{$b}}{start} <=> @{@connected{$a}}{start}}
keys %connected) {
my $hash = @connected{$key};
if($$hash{raw} != 0||!defined $$hash{obj_id}||$$hash{obj_id} eq undef) {
next;
}
if($flag) {
push(@who,
"#" .
@{@connected{$key}}{obj_id} . ":" .
@{@connected{$key}}{port}
);
} else {
push(@who,"#" . @{@connected{$key}}{obj_id});
}
}
return join(' ',@who);
}
sub fun_lcstr
{
my ($self,$prog) = (shift,shift);
my @out;
good_args($#_,1) ||
return "#-1 FUNCTION (LCSTR) EXPECTS 1 ARGUMENT ($#_)";
while($#_ >= 0) {
my $str = ansi_init(evaluate($self,$prog,shift));
for my $i (0 .. $#{$$str{ch}}) {
@{$$str{ch}}[$i] = lc(@{$$str{ch}}[$i]);
}
push(@out,ansi_string($str,1));
}
return join(',',@out);
}
sub fun_home
{
my ($self,$prog) = (shift,shift);
good_args($#_,0,1) ||
return "#-1 FUNCTION (HOME) EXPECT 0 OR 1 ARGUMENT";
if(@_[0] eq undef) {
return home($self);
}
my $target = find($self,$prog,evaluate($self,$prog,shift));
if($target eq undef) {
return "#-1 NOT FOUND";
} elsif(hasflag($target,"EXIT")) {
return "#" . loc($target);
} else {
return "#" . home($target);
}
}
#
# capitalize the provided string
#
sub fun_capstr
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (SQUISH) EXPECTS 1 ARGUMENT ($#_)";
return ucfirst(evaluate($self,$prog,shift));
}
#
# fun_squish
# 1. Convert multiple spaces into a single space,
# 2. remove any leading or ending spaces
#
sub fun_squish
{
my ($self,$prog) = (shift,shift);
my $txt = @_[0];
my $y;
good_args($#_,1) ||
return "#-1 FUNCTION (SQUISH) EXPECTS 1 ARGUMENT ($#_)";
my $txt = ansi_init(evaluate($self,$prog,shift));
my $ch = $$txt{ch};
my $snap = $$txt{snap};
my $code = $$txt{code};
for(my $i=0;$i <= $#$ch;$i++) {
if($i == 0 || ( $i < $#$ch && $$ch[$i] eq " " && $$ch[$i+1] eq " ")) {
for($y=0;$y < $#$ch;$y++) {
if($$ch[$i + $y] ne " ") { # found non-space, exit
last;
}
last if $y > 500;
}
if($y > 0) {
$$code[$i+2] = [ "\e[0m", @{@$snap[$i+1]} ];
if($i == 0) {
splice(@$ch,$i,$y);
} else {
splice(@$ch,$i+1,$y-1);
splice(@$snap,$i+1,$y-1);
splice(@$code,$i+1,$y-1);
}
if($i == 0) {
$$code[$i] = [ @{@$snap[$i]} ];
} elsif(join('',@{$$snap[$i]}) eq join('',@{$$snap[$i+1]})) {
# ansi codes are the same, do nothing.
} else {
$$code[$i+1] = [ "\e[0m", @{@$snap[$i+1]} ];
}
$i--;
}
}
last if $i > 500;
}
if($$ch[$#$ch-1] eq " ") { # trim end, should be one space at this point
delete @$ch[$#$ch-1];
ansi_reset($txt,$#$ch-1);
}
return ansi_string($txt,1);
}
sub fun_eq
{
my ($self,$prog) = (shift,shift);
good_args($#_,2) ||
return "#-1 FUNCTION (EQ) EXPECTS 2 ARGUMENTS";
my $one = evaluate($self,$prog,shift);
my $two = evaluate($self,$prog,shift);
$one =~ s/^\s+|\s+$//g;
$two =~ s/^\s+|\s+$//g;
return ($one eq $two) ? 1 : 0;
}
sub fun_loc
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,1) ||
return "#-1 FUNCTION (LOC) EXPECTS 1 ARGUMENT";
my $target = find($self,$prog,evaluate($self,$prog,shift));
if($target eq undef) {
return "#-1 NOT FOUND";
} elsif(hasflag($target,"ROOM")) { # rooms can't be anywhere
return "#-1";
} elsif(hasflag($target,"EXIT")) {
my $dest = dest($target);
if($dest eq undef) {
return "#-1";
} else {
return "#" . dest($target);
}
} elsif(controls($self,$target)) {
return "#" . loc($target);
} elsif(hasflag($target,"UNFINDABLE") || hasflag($target,"DARK")) {
return "#-1";
} else {
return "#" . loc($target);
}
}
sub fun_findable
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,2) ||
return "#-1 FUNCTION (FINDABLE) EXPECTS 2 ARGUMENTS";
my $obj = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
return "#-1 PERMISSION DENIED" if(!readonly($self,$obj));
my $loc = fun_loc($obj,$prog,"#" . $$target{obj_id});
if($loc =~ /^#-/) {
return 0;
} else {
return 1;
}
}
sub fun_orflags
{
my ($self,$prog) = (shift,shift);
good_args($#_,2) ||
return "#-1 FUNCTION (HASFLAG) EXPECTS 2 ARGUMENTS";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
my $flags = shift;
$flags =~ s/ //g;
for my $i (split(//,$flags)) {
my $flag = get_flag_by_letter($i);
return 1 if($flag ne undef && hasflag($target,$flag));
}
return 0;
}
sub fun_hasflag
{
my ($self,$prog) = (shift,shift);
good_args($#_,2) ||
return "#-1 FUNCTION (HASFLAG) EXPECTS 2 ARGUMENTS";
if((my $target = find($self,$prog,evaluate($self,$prog,shift))) ne undef) {
return hasflag($target,shift);
} else {
return "#-1 Unknown Object";
}
}
sub fun_gt
{
my ($self,$prog) = (shift,shift);
good_args($#_,2) ||
return "#-1 FUNCTION (GT) EXPECTS 2 ARGUMENTS";
my $one = evaluate($self,$prog,shift);
my $two = evaluate($self,$prog,shift);
return ($one > $two) ? 1 : 0;
}
sub fun_gte
{
my ($self,$prog) = (shift,shift);
good_args($#_,2) ||
return "#-1 FUNCTION (GTE) EXPECTS 2 ARGUMENTS";
my $one = evaluate($self,$prog,shift);
my $two = evaluate($self,$prog,shift);
return ($one >= $two) ? 1 : 0;
}
sub fun_lt
{
my ($self,$prog) = (shift,shift);
good_args($#_,2) ||
return "#-1 FUNCTION (LT) EXPECTS 2 ARGUMENTS";
my $one = evaluate($self,$prog,shift);
my $two = evaluate($self,$prog,shift);
return ($one < $two) ? 1 : 0;
}
sub fun_lte
{
my ($self,$prog) = (shift,shift);
good_args($#_,2) ||
return "#-1 FUNCTION (LT) EXPECTS 2 ARGUMENTS";
my $one = evaluate($self,$prog,shift);
my $two = evaluate($self,$prog,shift);
return ($one <= $two) ? 1 : 0;
}
sub fun_or
{
my ($self,$prog) = (shift,shift);
while($#_ >= 0) {
my $val = evaluate($self,$prog,shift);
return 1 if($val);
}
return 0;
}
sub fun_bor
{
my ($self,$prog) = (shift,shift);
my $result = 0;
good_args($#_,1 .. 100) ||
return "#-1 FUNCTION (BOR) EXPECTS 1 AND 100 ARGUMENTS";
for my $i (@_) {
my $value = evaluate($self,$prog,$i);
if(isint($value)) {
$result |= $value;
} else {
return "#-1 ARGUMENTS MUST BE INTEGERS"
}
}
return $result;
}
sub fun_isnum
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (ISNUM) EXPECTS 1 ARGUMENT";
my $val = evaluate($self,$prog,shift);
return looks_like_number(ansi_remove($val)) ? 1 : 0;
}
sub fun_lnum
{
my ($self,$prog) = (shift,shift);
my @result;
good_args($#_,1,2,3,4) ||
return "#-1 FUNCTION (LNUM) EXPECTS 1,2,3 OR 4 ARGUMENTS";
my $start = evaluate($self,$prog,shift);
my $end = evaluate($self,$prog,shift);
my $odelim = evaluate($self,$prog,shift);
my $step = evaluate($self,$prog,shift);
if($end eq undef && $start ne undef) {
$end = $start - 1;
$start = 0;
}
$start = 0 if $start eq undef;
$end = 0 if $end eq undef;
$odelim = " " if $odelim eq undef;
$step = 1 if $step eq undef;
if($start <= $end) {
for(my $i=$start;$i <= $end && $#result < 2000;$i += $step) {
push(@result,$i);
}
} else {
for(my $i=$start;$i >= $end && $#result < 2000;$i -= $step) {
push(@result,$i);
}
}
return join($odelim,@result);
}
sub fun_and
{
my ($self,$prog) = (shift,shift);
while($#_ >= 0) {
my $num = evaluate($self,$prog,shift);
return 0 if($num eq 0 || !isint($num));
}
return 1;
}
sub fun_not
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (NOT) EXPECTS 1 ARGUMENTS";
return (! evaluate($self,$prog,shift)) ? 1 : 0;
}
sub fun_words
{
my ($self,$prog) = (shift,shift);
good_args($#_,1,2) ||
return "#-1 FUNCTION (WORDS) EXPECTS 1 OR 2 ARGUMENTS";
my $txt = trim(evaluate($self,$prog,shift));
my $delim = evaluate($self,$prog,shift);
return scalar(safe_split(ansi_remove($txt),
($delim eq undef) ? " " : $delim
)
);
}
#
# fun_match
# Match a string against a pattern with an optional delimiter.
#
sub fun_match
{
my ($self,$prog) = (obj(shift),shift);
my $count = 1;
good_args($#_,1,2,3) ||
return "#-1 FUNCTION (MATCH) EXPECTS 1, 2 OR 3 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $pat = evaluate($self,$prog,shift);
my $delim = evaluate($self,$prog,shift);
$delim = " " if $delim eq undef;
$pat = glob2re($pat);
for my $word (safe_split(ansi_remove($txt),$delim)) {
return $count if($word =~ /$pat/);
$count++;
}
return 0;
}
#
# fun_match
# Match a string against a pattern with an optional delimiter.
#
sub fun_regedit
{
my ($self,$prog) = (obj(shift),shift);
my ($tmp, $count);
my $txt = evaluate($self,$prog,shift);
$$prog{reg} = {} if !defined $$prog{reg};
for my $i (0 .. 9) { # backup existing variables?
if(defined $$prog{reg}->{$i}) {
$$tmp{$i} = $$prog{var}->{$i};
}
}
while($#_ > -1 && $count++ < 15) {
my $pat = trim(ansi_remove(evaluate($self,$prog,shift)));
my $replace = ansi_trim(shift);
eval {
if($txt =~ /$pat/) {
$$prog{reg} = {} if !defined $$prog{reg};
$$prog{reg} = {
0 => $&, 1 => $1, 2 => $2, 3 => $3, 4 => $4, 5 => $5,
6 => $6, 7 => $7, 8 => $8, 9 => $9
};
$txt = $` . evaluate($self,$prog,$replace) . $';
}
};
return "#-1 INVALID REGEXP" if($@);
}
for my $i (0 .. 9) { # restore existing variables?
if(defined $$tmp{$i}) {
$$prog{var}->{$i} = $$tmp{$i};
} else {
delete @$prog{reg}->{$i};
}
}
delete @$prog{reg} if(scalar keys %{$$prog{reg}} == 0);
return $txt;
}
#
# fun_strmatch
# Match a string against a pattern with an optional delimiter.
#
sub fun_strmatch
{
my ($self,$prog) = (shift,shift);
good_args($#_,2) ||
return "#-1 FUNCTION (STRMATCH) EXPECTS 2 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $pat = evaluate($self,$prog,shift);
$pat = glob2re($pat);
return ($txt =~ /^$pat$/i) ? 1 : 0;
}
sub fun_inc
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,0,1) ||
return "#-1 FUNCTION (INC) EXPECTS 0 OR 1 ARGUMENTS";
my $number = evaluate($self,$prog,shift);
if($number =~ /^\s*(\d+)\s*$/) {
return sprintf("%d",$1 + 1);
} else {
return 1;
}
}
sub fun_dec
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,0,1) ||
return "#-1 FUNCTION (DEC) EXPECTS 0 OR 1 ARGUMENTS";
my $number = evaluate($self,$prog,shift);
if($number =~ /^\s*(\d+)\s*$/) {
return sprintf("%d",$1 - 1);
} else {
return -1;
}
}
sub fun_center
{
my ($self,$prog) = (shift,shift);
good_args($#_,2,3) ||
return "#-1 FUNCTION (CENTER) EXPECTS 2 OR 3 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $size = evaluate($self,$prog,shift);
my $fill = evaluate($self,$prog,shift);
if(!isint($size)) {
return "#-1 SECOND ARGUMENT MUST BE NUMERIC - '$size'";
} elsif($size eq 0) {
return "#-1 SECOND ARGUMENT MUST NOT BE ZERO";
} elsif($size >= 8000) {
return "#-1 OUT OF RANGE";
}
$fill = " " if($fill eq undef);
$txt = ansi_substr($txt,0,$size);
my $len = ansi_length($txt);
my $lpad = sprintf("%d",($size - $len) / 2);
my $ltxt = ansi_substr($fill x $lpad,0,$lpad);
my $rpad = $size - $lpad - $len;
my $rtxt = ansi_substr($fill x $rpad,0,$rpad);
return "$ltxt$txt$rtxt";
}
sub ansi_center
{
my ($txt,$size,$fill) = @_;
$fill = " " if($fill eq undef);
$txt = ansi_substr($txt,0,$size);
my $len = ansi_length($txt);
my $lpad = sprintf("%d",($size - $len) / 2);
my $ltxt = ansi_substr($fill x $lpad,0,$lpad);
my $rpad = $size - $lpad - $len;
my $rtxt = ansi_substr($fill x $rpad,0,$rpad);
return "$ltxt$txt$rtxt";
}
sub fun_switch
{
my ($self,$prog) = (shift,shift);
my $first = single_line(evaluate($self,$prog,trim(shift)));
while($#_ >= 0) {
if($#_ >= 1) {
my $txt = single_line(evaluate($self,$prog,trim(shift)));
my $cmd = shift;
if(ansi_remove($txt) =~ /^\s*(<|>)\s*/) {
if($1 eq ">" && $first > $' || $1 eq "<" && $first < $') {
return evaluate($self,$prog,$cmd);
}
} else {
my @wild = ansi_match($first,$txt);
if($#wild >=0) {
my $prev = get_digit_variables($prog);
my $tmp = {};
my $mdig = $$prog{cmd}->{mdigits};
for my $key (keys %$mdig) {
@$tmp{$key} = $$mdig{$key};
}
@{$$prog{cmd}}{mdigits} = {
0 => @wild[0], 1 => @wild[1], 2 => @wild[2], 3 => @wild[3],
4 => @wild[4], 5 => @wild[5], 6 => @wild[6], 7 => @wild[7],
8 => @wild[8], 9 => @wild[9],
};
my $result = evaluate($self,$prog,$cmd);
@{$$prog{cmd}}{mdigits} = $tmp;
return $result;
}
}
} else { # handle switch() default
return evaluate($self,$prog,shift);
}
}
}
sub fun_member
{
my ($self,$prog) = (shift,shift);
my $i = 1;
good_args($#_,2,3) ||
return "#-1 FUNCTION (MEMBER) EXPECTS 2 OR 3 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $word = evaluate($self,$prog,shift);
my $delim = evaluate($self,$prog,shift);
return 1 if($txt =~ /^\s*$/ && $word =~ /^\s*$/);
$delim = " " if $delim eq undef;
for my $x (safe_split($txt,$delim)) {
return $i if($x eq $word);
$i++;
}
return 0;
}
sub fun_index
{
my ($self,$prog) = (shift,shift);
good_args($#_,4) ||
return "#-1 FUNCTION (INDEX) EXPECTS 4 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $delim = evaluate($self,$prog,shift);
my $first = evaluate($self,$prog,shift);
my $size = evaluate($self,$prog,shift);
my $i = 1;
if(!looks_like_number($first)) {
return "#-1 THIRD ARGUMENT MUST BE A NUMERIC VALUE";
} elsif(!looks_like_number($size)) {
return "#-1 THIRD ARGUMENT MUST BE A NUMERIC VALUE";
} elsif($txt =~ /^\s*$/) {
return undef;
}
$first--;
$size--;
$delim = " " if $delim eq undef;
return join($delim,(safe_split($txt,$delim))[$first .. ($size+$first)]);
}
sub fun_replace
{
my ($self,$prog) = (shift,shift);
my $i = 1;
if(!good_args($#_,3,4,5)) {
return "#-1 FUNCTION (REPLACE) EXPECTS 3, 4 or 5 ARGUMENTS";
}
my $txt = evaluate($self,$prog,shift);
my $positions = evaluate($self,$prog,shift);
my $word = evaluate($self,$prog,shift);
my $idelim = evaluate($self,$prog,shift);
my $odelim = evaluate($self,$prog,shift);
$txt =~ s/^\s+|\s+$//g;
$positions=~ s/^\s+|\s+$//g;
$word =~ s/^\s+|\s+$//g;
$idelim =~ s/^\s+|\s+$//g;
$odelim =~ s/^\s+|\s+$//g;
$idelim = ' ' if($idelim eq undef);
$odelim = $idelim if($odelim eq undef);
my @array = safe_split($txt,$idelim);
for my $i (split(' ',$positions)) {
@array[$i-1] = $word if(defined @array[$i-1]);
}
return join($odelim,@array);
}
sub fun_after
{
my ($self,$prog) = (shift,shift);
if($#_ != 0 && $#_ != 1) {
return "#-1 Function (AFTER) EXPECTS 1 or 2 ARGUMENTS";
}
my $txt = evaluate($self,$prog,shift);
my $after = evaluate($self,$prog,shift);
my $loc = index($txt,$after);
if($loc == -1) {
return undef;
} else {
my $result = substr($txt,$loc + length($after));
return $result;
}
}
sub fun_rest
{
my ($self,$prog) = (shift,shift);
good_args($#_,1 .. 2) ||
return "#-1 Function (REST) EXPECTS 1 or 2 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $delim = ansi_remove(evaluate($self,$prog,shift));
$delim = " " if($delim eq undef);
my $loc = index(ansi_remove($txt),$delim);
if($loc == -1) {
return $txt;
} else {
return fun_trim($self,$prog,ansi_substr($txt,$loc + length($delim),9999));
}
}
sub fun_first
{
my ($self,$prog) = (shift,shift);
good_args($#_,1,2) ||
return "#-1 Function (FIRST) EXPECTS 1 or 2 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $delim = ansi_remove(evaluate($self,$prog,shift));
if($delim eq undef || $delim eq " ") {
$txt =~ s/^\s+|\s+$//g;
$txt =~ s/\s+/ /g;
$delim = " ";
}
my $loc = index(evaluate($self,$prog,ansi_remove($txt)),$delim);
if($loc == -1) {
return $txt;
} else {
return fun_trim($self,$prog,ansi_substr($txt,0,$loc));
}
}
sub fun_last
{
my ($self,$prog) = (shift,shift);
good_args($#_,1,2) ||
return "#-1 Function (LAST) EXPECTS 1 or 2 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
# $txt =~ s/°//g;
my $txt = ansi_init($txt);
my $delim = ansi_remove(evaluate($self,$prog,shift));
$delim = " " if($delim eq undef);
my $dsize = length($delim);
my $array = $$txt{ch};
my $endable = ($delim eq " ") ? 0 : 1;
for(my $i = $#$array;$i >= 0;$i--) {
next if $$array[$i] eq undef;
if($endable && join('',@$array[$i .. ($i + $dsize - 1)]) eq $delim) {
if($delim eq " ") {
return ansi_trim(ansi_substr($txt,$i + $dsize));
} else {
return ansi_substr($txt,$i + $dsize);
}
} elsif(!$endable && $$array[$i] ne " ") {
$endable = 1; # look for non-space for space delim
}
}
}
#
# fun_before
# Moddled after fun_last except regular order..
#
sub fun_before
{
my ($self,$prog) = (shift,shift);
good_args($#_,1,2) ||
return "#-1 Function (BEFORE) EXPECTS 1 or 2 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $txt = ansi_init($txt);
my $delim = ansi_remove(evaluate($self,$prog,shift));
$delim = " " if($delim eq undef);
my $dsize = length($delim);
my $array = $$txt{ch};
my $endable = ($delim eq " ") ? 0 : 1;
for(my $i = 0;$i <= $#$array;$i++) {
next if $$array[$i] eq undef;
if($endable && join('',@$array[$i .. ($i + $dsize - 1)]) eq $delim) {
if($delim eq " ") {
return ansi_trim(ansi_substr($txt,0,$i));
} else {
return ansi_substr($txt,0,$i);
}
} elsif(!$endable && $$array[$i] ne " ") {
$endable = 1; # look for non-space for space delim
}
}
return ansi_string($txt);
}
sub fun_loadavg
{
my ($self,$prog) = (shift,shift);
my $file;
if(-e "/proc/loadavg") {
open($file,"/proc/loadavg") ||
return "#-1 Unable to determine load average";
while(<$file>) {
if(/^\s*([0-9\.]+)\s+([0-9\.]+)\s+([0-9\.]+)\s+/) {
close($file);
return "$1 $2 $3";
}
}
close($file);
return "#-1 Unable to determine load average";
} else {
return "#-1 Unable to determine load average";
}
}
#
# fun_secs
# Return the current epoch time
#
sub fun_secs
{
my ($self,$prog) = (shift,shift);
return time();
}
#
# fun_div
# Divide a number
#
sub fun_div
{
my ($self,$prog) = (shift,shift);
return "#-1 Add requires at least two arguments" if $#_ < 1;
my $one = ansi_remove(evaluate($self,$prog,shift));
my $two = ansi_remove(evaluate($self,$prog,shift));
$one = hex(trim($one)) if($one =~ /^\s*0x([0-9a-f]{2})\s*$/i);
$two = hex(trim($two)) if($two =~ /^\s*0x([0-9a-f]{2})\s*$/i);
if($two eq undef || $two == 0) {
return "#-1 DIVIDE BY ZERO";
} else {
return sprintf("%d",$one / $two);
}
}
#
# fun_fdiv
# Divide a number
#
sub fun_fdiv
{
my ($self,$prog) = (shift,shift);
return "#-1 Add requires at least two arguments" if $#_ < 1;
my $one = ansi_remove(evaluate($self,$prog,shift));
my $two = ansi_remove(evaluate($self,$prog,shift));
if($two eq undef || $two == 0) {
return "#-1 DIVIDE BY ZERO";
} else {
my $result = sprintf("%.6f",$one / $two);
$result =~ s/0+$//g;
$result =~ s/\.$//g;
return $result;
}
}
#
# fun_add
# Add multiple numbers together
#
sub fun_add
{
my ($self,$prog) = (shift,shift);
my $result = 0;
my (@out, @before);
return "#-1 Add requires at least one argument" if $#_ < 0;
for my $i (0 .. $#_) {
push(@before,@_[$i]);
my $val = ansi_remove(evaluate($self,$prog,@_[$i]));
push(@out,$val);
if($val =~ /^\s*0x([0-9a-f]{2})\s*$/i) {
$result += hex(trim($val));
} else {
$result += $val;
}
}
return $result;
}
#
# fun_mul
# Multiple some numbers
#
sub fun_mul
{
my ($self,$prog) = (shift,shift);
good_args($#_,1 .. 100) ||
return "#-1 FUNCTION (MUL) EXPECTS BETWEEN 1 and 100 ARGUMENTS";
my $result = ansi_remove(evaluate($self,$prog,shift));
$result = tohex($1) if($result =~ /^\s*0x([0-9a-f]{2})\s*$/i);
while($#_ > -1) {
my $val = ansi_remove(evaluate($self,$prog,shift));
$val = tohex($1) if($val =~ /^\s*0x([0-9a-f]{2})\s*$/i);
$result *= $val;
}
return $result;
}
#
# fun_sub
# Subtract some numbers
#
sub fun_sub
{
my ($self,$prog) = (shift,shift);
return "#-1 Sub requires at least one argument" if $#_ < 0;
my $result = ansi_remove(evaluate($self,$prog,shift));
$result = hex(trim($result)) if($result =~ /^\s*0x([0-9a-f]{2})\s*$/i);
while($#_ >= 0) {
my $val = ansi_remove(evaluate($self,$prog,shift));
if($val =~ /^\s*0x([0-9a-f]{2})\s*$/i) {
$result -= hex(trim($val));
} else {
$result -= $val;
}
}
return $result;
}
sub lord
{
my $txt = shift;
my @result;
# $txt =~ s/\e/<ESC>/g;
# return $txt;
for my $i (0 .. (length($txt)-1)) {
push(@result,ord(substr($txt,$i,1)));
}
return join(',',@result);
}
sub fun_edit
{
my ($self,$prog) = (shift,shift);
my ($start,$out);
good_args($#_,3,4,5) ||
return "#-1 FUNCTION (EDIT) EXPECTS 3 AND 5 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $from = ansi_remove(evaluate($self,$prog,trim(shift)));
# my $from = trim(ansi_remove(evaluate($self,$prog,shift)));
my $to = evaluate($self,$prog,shift);
my $type = evaluate($self,$prog,shift);
my $strict = evaluate($self,$prog,shift);
my $size = ansi_length($from);
$strict = 1 if($strict eq undef || ($strict ne 1 & $strict ne 2));
if($strict == 2) { # edit whole string
my $size = length($from);
for(my $i = 0, $start = 0;$i <= length($txt);$i++) {
if(substr($txt,$i,$size) eq $from) {
if($start ne undef || $i != $start) {
$out .= substr($txt,$start,$i - $start);
}
$out .= $to;
$i += $size;
$start = $i;
last if($type);
}
}
if($start ne undef or $start >= length($txt)) { # add left over chars
$out .= substr($txt,$start,length($txt) - $start + 1);
}
} else { # don't edit ansi strings
$txt = ansi_init($txt);
my $size = length($from);
for(my $i = 0, $start=0;$i <= $#{$$txt{ch}};$i++) {
next if @{$$txt{ch}}[$i] eq undef;
if(join('',@{$$txt{ch}}[$i .. ($i + $size - 1)]) eq $from) {
if($start ne undef || $i != $start) {
$out .= ansi_substr($txt,$start,$i - $start);
}
$out .= ansi_clone($txt,$i,$to);
$i += $size - 1;
$start = $i + 1;
last if($type);
}
}
if($start ne undef or $start >= $#{$$txt{ch}}) { # add left over chars
$out .= ansi_substr($txt,$start,$#{$$txt{ch}} - $start + 1);
}
}
return $out;
}
sub fun_num
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (NUM) EXPECTS 1 ARGUMENT";
my $result = find($self,$prog,evaluate($self,$prog,$_[0]));
if($result eq undef) {
return "#-1";
} else {
return "#$$result{obj_id}";
}
}
#
# fun_isdbref
# Determine if the passed in text is a valid dbref.
#
sub fun_isdbref
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (ISDBREF) EXPECTS 1 ARGUMENT";
my $dbref =evaluate($self,$prog,shift);
if($dbref =~ /^\s*#(\d+)\s*$/ && valid_dbref($1)) {
return 1;
} else {
return 0;
}
}
sub fun_locate
{
my ($self,$prog) = (shift,shift);
my (%result, @r, $prefer);
my $random = 0;
good_args($#_,3) ||
return "#-1 FUNCTION (LOCATE) EXPECTS 3 ARGUMENT";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
readonly($self,$target) ||
return err($self,$prog,"#-1 PERMISSION DENIED");
my $what = lc(trim(ansi_remove(evaluate($self,$prog,shift))));
my $where = evaluate($self,$prog,shift);
for(my $i=0;$i < length($where);$i++) {
if(substr($where,$i,1) eq "a") {
@result{"a"} = $1 if($what =~ /^\s*#(\d+)\s*$/ && valid_dbref($1));
} elsif(substr($where,$i,1) eq "c") {
my $obj= find_exit($self,$prog,$target,$what);
@result{c} = $$obj{obj_id} if $obj ne undef;
} elsif(substr($where,$i,1) eq "e") {
my $obj = find_exit($self,$prog,loc($target),$what);
@result{e} = $$obj{obj_id} if $obj ne undef;
} elsif(substr($where,$i,1) eq "h") {
if($what eq lc(ansi_remove(name(loc($target))))) {
@result{h} = return loc($target);
}
} elsif(substr($where,$i,1) eq "i") {
my $obj = find_in_list($what,lcon($target));
@result{e} = $$obj{obj_id} if $obj ne undef;
} elsif(substr($where,$i,1) eq "m") {
@result{m} = $$target{obj_id} if $what eq "me";
} elsif(substr($where,$i,1) eq "n") {
my $obj = find_in_list($what,lcon(loc($target)));
@result{n} = $$obj{obj_id} if $obj ne undef;
} elsif(substr($where,$i,1) eq "p") {
if($what =~ /^\s*\*/) {
my $player = trim(ansi_remove(lc($')));
if(defined @player{$player}) {
@result{p} = @player{$player};
}
}
} elsif(substr($where,$i,1) eq "E") {
$prefer = "E";
} elsif(substr($where,$i,1) eq "L") {
$prefer = "L";
} elsif(substr($where,$i,1) eq "P") {
$prefer = "P";
} elsif(substr($where,$i,1) eq "R") {
$prefer = "R";
} elsif(substr($where,$i,1) eq "T") {
$prefer = "T";
} elsif(substr($where,$i,1) eq "V") {
$prefer = "V";
} elsif(substr($where,$i,1) eq "X") {
$random = 1;
}
}
for my $key (keys %result) {
if($prefer eq undef) {
return "#-2" if(!$random && $#r == 0);
push(@r,@result{$key});
} else {
if($prefer eq "E" && hasflag(@result{$key},"EXIT")) {
return "#-2" if(!$random && $#r == 0);
push(@r,@result{$key});
}
if($prefer eq "L" && hasflag(@result{$key},"EXIT")) {
my $atr = get($target,"OBJ_LOCK_DEFAULT");
if($atr ne undef) {
my $lock = lock_eval($self,$prog,$target,$atr);
if(!$$lock{error} && $$lock{result}) {
return "#-2" if(!$random && $#r == 0);
push(@r,@result{$key});
}
}
}
if($prefer eq "P" && hasflag(@result{$key},"PLAYER")) {
return "#-2" if(!$random && $#r == 0);
push(@r,@result{$key});
}
if($prefer eq "T" && hasflag(@result{$key},"OBJECT")) {
return "#-2" if(!$random && $#r == 0);
push(@r,@result{$key});
}
}
}
if($random) {
return @r[rand($#r + 1)];
} else {
return @r[0];
}
}
sub fun_owner
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (OWNER) EXPECTS 1 ARGUMENT";
my $target = find($self,$prog,evaluate($self,$prog,shift)) ||
return "#-1 NOT FOUND";
my $owner = owner($target);
if(ref($owner) eq "HASH") {
return "#" . $$owner{obj_id};
} else {
return "#-1"; # this should never happen
}
}
sub fun_name
{
# for my $i (0 .. $#_) {
# printf("$i: '%s'\n",$_[$i]);
# }
my ($flag,$self,$prog) = (shift,shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (NAME) EXPECTS 1 ARGUMENT - $#_";
my $target = find($self,$prog,evaluate($self,$prog,shift));
if($target eq undef) {
return "#-1";
} elsif(hasflag($target,"EXIT") && !$flag) {
return first(name($target));
} else {
# printf("%s\n",print_var($prog));
return name($target,undef,$self,$prog);
}
}
sub fun_type
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (TYPE) EXPECTS 1 ARGUMENT";
my $target= find($self,$prog,evaluate($self,$prog,$_[0])) ||
return "#-1 NOT FOUND";
return type($self,$prog,$target);
}
sub fun_filter
{
my ($self,$prog) = (obj(shift),shift);
my @result;
good_args($#_,2,3,4) ||
return "#-1 FUNCTION (FILTER) EXPECTS BETWEEN 2 and 4 ARGUMENTS";
my ($obj,$atr) = meval($self,$prog,balanced_split(shift,"\/",4));
my $list = evaluate($self,$prog,shift);
my $delim = evaluate($self,$prog,shift);
my $odelim = evaluate($self,$prog,shift);
# TinyMUSH doesn't provide any details if there is an error.
if($atr eq undef) {
($obj,$atr) = ($self,$obj);
} elsif(($obj = find($self,$prog,$obj)) eq undef) {
return undef;
}
$delim = " " if($delim eq undef);
$odelim = " " if($odelim eq undef);
my $value = pget($obj,$atr) ||
return undef;
my $prev = get_digit_variables($prog); # save %0 .. %9
for my $word (safe_split($list,$delim)) {
if(!set_digit_variables($self,$prog,"",$word)) { # update to new values
return managed_var_set_error("#-1");
}
if(evaluate($self,$prog,$value)) {
push(@result,$word);
}
}
if(!set_digit_variables($self,$prog,"",$prev)) { # restore %0 .. %9
return managed_var_set_error("#-1");
}
return join($odelim,@result);
}
sub fun_u
{
my ($self,$prog) = (shift,shift);
my ($txt,$obj,$attr,@arg);
# stack_print();
if(defined $$prog{mush_function_name}) {
if(defined @info{mush_function} &&
defined @{@info{mush_function}}{$$prog{mush_function_name}}) {
$txt = @{@info{mush_function}}{$$prog{mush_function_name}};
} else {
return "#-1 INVALID USER DEFINED FUNCTION";
}
} else {
$txt = evaluate($self,$prog,shift);
}
for my $i (0 .. $#_) {
@arg[$i] = evaluate($self,$prog,$_[$i]);
}
if($txt =~ /\//) { # input in object/attribute format?
($obj,$attr) = (find($self,$prog,$`,"LOCAL"),$');
} else { # nope, just contains attribute
($obj,$attr) = ($self,$txt);
}
if($obj eq undef) {
return "#-1 Unknown object";
} elsif(!(controls($self,$obj) ||
hasflag($obj,"VISUAL") ||
atr_hasflag($obj,$attr,"VISUAL")
)) {
return "#-1 PerMISSion Denied";
}
my $prev = get_digit_variables($prog); # save %0 .. %9
if(!set_digit_variables($self,$prog,"",@arg)) { # update to new values
return managed_var_set_error("#-1");
}
# printf("---[ start ]-----\n");
# for my $i (0 .. $#arg) {
# printf("$i : '%s'\n",@arg[$i]);
# }
# printf("---[ end ]-----\n");
my $result = evaluate($obj,$prog,single_line(pget($obj,$attr)));
if(!set_digit_variables($self,$prog,"",$prev)) { # restore %0 .. %9
return managed_var_set_error("#-1");
}
return $result;
}
sub fun_map
{
my ($self,$prog) = (shift,shift);
my (@out);
my ($obj,$atr)= bsplit(evaluate($self,$prog,shift),"/");
my $list = evaluate($self,$prog,shift);
my $idelim = trim(ansi_remove(evaluate($self,$prog,shift)));
my $odelim = evaluate($self,$prog,shift);
$odelim = " " if(empty($odelim));
$idelim = " " if(empty($idelim));
my $target = find($self,$prog,$obj) ||
return undef; # no error in TinyMUSH
if(!(controls($self,$target) ||
hasflag($target,"VISUAL") ||
atr_hasflag($target,$atr,"VISUAL")
)
) {
return undef; # no error in TinyMUSH
}
return undef if(empty($atr));
my $attribute = pget($target,$atr);
my $prev = get_digit_variables($prog); # save %0 .. %9
for my $i (safe_split($list,$idelim)) {
if(!set_digit_variables($self,$prog,"",$i,@_)) {
return managed_var_set_error("#-1");
}
push(@out,ansi_trim(evaluate($self,$prog,$attribute)));
}
if(!set_digit_variables($self,$prog,"",$prev)) { # restore %0 .. %9
return managed_var_set_error("#-1");
}
return join($odelim,@out);
}
sub fun_secure
{
my ($self,$prog) = (obj(shift),shift);
my @out;
while($#_ > -1) {
my $txt = ansi_init(evaluate($self,$prog,shift));
my $len = ansi_length($txt);
for(my $i = 0;$i < $len;$i++) {
my $str = $$txt{ch};
if($$str[$i] eq "[" ||
$$str[$i] eq "]" ||
$$str[$i] eq "(" ||
$$str[$i] eq ")" ||
$$str[$i] eq "{" ||
$$str[$i] eq "}" ||
$$str[$i] eq "\;" ||
$$str[$i] eq "%" ||
$$str[$i] eq "\\" ||
$$str[$i] eq "^" ||
$$str[$i] eq "," ||
$$str[$i] eq "\$") {
$$str[$i] = " ";
}
}
push(@out,ansi_string($txt));
}
return join(" ",@out);
}
sub fun_ulocal
{
my ($self,$prog) = (obj(shift),shift);
my ($txt,$obj,$attr,@arg,%temp);
# stack_print();
if(defined $$prog{mush_function_name}) {
if(defined @info{mush_function} &&
defined @{@info{mush_function}}{$$prog{mush_function_name}}) {
$txt = @{@info{mush_function}}{$$prog{mush_function_name}};
} else {
return "#-1 INVALID USER DEFINED FUNCTION";
}
} else {
$txt = evaluate($self,$prog,shift);
}
if($txt =~ /\//) { # input in object/attribute format?
($obj,$attr) = (find($self,$prog,$`,"LOCAL"),$');
} else { # nope, just contains attribute
($obj,$attr) = ($self,$txt);
}
for my $i (0 .. $#_) {
@arg[$i] = evaluate($self,$prog,$_[$i]);
}
if($obj eq undef) {
return "#-1 Unknown object";
} elsif(!(controls($self,$obj) ||
hasflag($obj,"VISUAL") ||
atr_hasflag($obj,$attr,"VISUAL")
)) {
return "#-1 PerMISSion Denied";
}
my $prev = get_digit_variables($prog); # save %0 .. %9
if(!set_digit_variables($self,$prog,"",@arg)) { # update to new values
return managed_var_set_error("#-1");
}
if(defined $$prog{var}) {
for my $key (grep {/^setq_/} keys %{$$prog{var}}) { # store prev values
@temp{$key} = $$prog{var}->{$key};
if(!managed_var_set($prog,$key,undef)) {
return managed_var_set_error("#-1");
}
}
}
my $result = evaluate($self,$prog,single_line(pget($obj,$attr)));
if(!set_digit_variables($self,$prog,"",$prev)) { # restore %0 .. %9
return managed_var_set_error("#-1");
}
if(defined $$prog{var}) {
for my $key (grep {/^setq_/} keys %{$$prog{var}}) { # restore prev values
if(!managed_var_set($prog,$key,undef)) {
return managed_var_set_error("#-1");
}
}
for my $key (keys %temp) {
if(!managed_var_set($prog,$key,@temp{$key})) {
return managed_var_set_error("#-1");
}
}
}
return $result;
}
sub fun_edefault
{
my ($self,$prog) = (shift,shift);
my ($txt,$obj,$attr,@arg,%temp);
good_args($#_,2) ||
return "#-1 FUNCTION (EDEFAULT) EXPECTS 2 ARGUMENTS";
my ($target,$atr) = besplit($self,$prog,shift);
my $target = find($self,$prog,evaluate($self,$prog,$obj));
return evaluate($self,$prog,shift) if($target eq undef);
my $dat = get($target,$atr);
return evaluate($self,$prog,shift) if($target eq $dat);
return evalate($self,$prog,$dat);
}
sub hash_item
{
my ($obj,$key,$sub) = @_;
my $attr = mget($obj,$key);
return undef if $attr eq undef; # invalid attribute
if(ref($$attr{value}) eq "HASH") { # is hash?
my $hash = $$attr{value};
if(defined $$hash{$sub}) { # valid sub key
return $$hash{$sub};
} else { # invalid sub key
return undef;
}
} else { # not a hash
return undef;
}
}
sub fun_keys
{
my ($self,$prog) = (shift,shift);
my ($obj,$atr,$sub);
good_args($#_,1,2) ||
return "#-1 FUNCTION (KEYS) EXPECTS BETWEEN 1 and 2 ARGUMENTS";
if($#_ == 0) {
($obj,$atr) = besplit($self,$prog,shift,"\/");
} else {
($obj,$atr) = (shift,shift);
}
($atr,$sub) = besplit($self,$prog,$atr,".");
my $target = find($self,$prog,$obj);
if($target eq undef ) {
return "#-1 Unknown object";
} elsif(!(controls($self,$target) ||
hasflag($target,"VISUAL") || atr_hasflag($target,$atr,"VISUAL"))) {
return "#-1 Permission Denied ($$self{obj_id} -> $$target{obj_id}/$atr)";
} elsif(db_set_ishash($target,$atr)) {
return join(" ",db_hash_keys($target,$atr,$sub));
} else {
return undef;
}
if($sub ne undef) {
return hash_item($target,$atr,$sub);
}
}
sub fun_get
{
my ($self,$prog) = (obj(shift),shift);
my ($obj,$atr,$sub);
good_args($#_,1,2) ||
return "#-1 FUNCTION (GET) EXPECTS BETWEEN 1 and 2 ARGUMENTS";
if($#_ == 0) {
($obj,$atr) = besplit($self,$prog,shift,"\/");
} else {
($obj,$atr) = (evaluate($self,$prog,shift),evaluate($self,$prog,shift));
}
($atr,$sub) = besplit($self,$prog,$atr,":");
my $target = find($self,$prog,$obj);
$atr = "description" if($atr =~ /^\s*desc\s*$/);
if($target eq undef ) {
return "#-1 Unknown object";
} elsif(!(controls($self,$target) ||
hasflag($target,"VISUAL") || atr_hasflag($target,$atr,"VISUAL") ||
hasflag($target,"WIZARD"))) {
return "#-1 Permission Denied";
}
if($sub ne undef) {
return hash_item($target,$atr,$sub);
} elsif($atr =~
/^(last|last_page|last_created_date|create_by|last_whisper)$/) {
return pget($target,"obj_$atr");
} elsif(lc($atr) eq "lastsite") {
return short_hn(lastsite($target));
} else {
return pget($target,$atr);
}
}
sub fun_default
{
my ($self,$prog) = (obj(shift),shift);
my ($obj,$atr,$sub);
good_args($#_,2) ||
return "#-1 FUNCTION (DEFAULT) EXPECTS 2 ARGUMENTS";
($obj,$atr) = besplit($self,$prog,shift,"\/");
my $target = find($self,$prog,$obj);
$atr = "description" if($atr =~ /^\s*desc\s*$/);
if($target eq undef ) {
return "#-1 Unknown object";
} elsif(!(controls($self,$target) ||
hasflag($target,"VISUAL") || atr_hasflag($target,$atr,"VISUAL") ||
hasflag($self,"WIZARD"))) {
return "#-1 Permission Denied ($$self{obj_id} -> $$target{obj_id}/$atr)";
}
if(hasattr($target,$atr)) { # has attribute
return get($target,$atr);
} elsif(hasattr($target,$atr,"PARENT")) { # parent
return get(parent($target),$atr);
} else {
return evaluate($self,$prog,shift);
}
}
sub fun_eval
{
my ($self,$prog,$txt) = (shift,shift,shift);
# printf("EVAL: '%s' -> '%s'\n",$txt,evaluate($self,$prog,evaluate($self,$prog,evaluate($self,$prog,$txt))));
if($#_ == 0) {
return evaluate($self,$prog,fun_get($self,$prog,$txt . "/" . $_));
} elsif($txt =~ /\//) {
return evaluate($self,$prog,fun_get($self,$prog,$txt));
} else {
return evaluate($self,$prog,evaluate($self,$prog,evaluate($self,$prog,$txt)));
}
}
#
# fun_v
# Return a un-evaluated attribute
#
sub fun_v
{
my ($self,$prog,$txt) = (shift,shift,shift);
return pget($self,evaluate($self,$prog,$txt));
}
#
# manage_set
# Keep track of how much memory a program is using in $$prog{var}
# and enforce the cap defined in memory_prog_limit.
#
sub managed_var_set
{
my ($prog,$var,$new) = @_;
# determine new amount to be allocated
my $used = length($new);
# subtract what is currently being used
$used -= length($$prog{var}->{$var}) if(defined $$prog{var}->{$var});
if($used + $$prog{bytes_use} > conf("memory_prog_limit")){
@info{bytes_attempted} = $$prog{bytes_used} + $used;
return 0;
} else {
if($$prog{max_bytes_used} < $$prog{bytes_used} + $used) {
$$prog{max_bytes_used} = $$prog{bytes_used} + $used;
}
$$prog{bytes_used} += $used;
if($new eq undef) {
delete @$prog{var}->{$var};
} else {
$$prog{var}->{$var} = $new;
}
return 1;
}
}
sub managed_var_set_error
{
my $pre = shift;
$pre .= " " if($pre ne undef);
my $txt = $pre . " " if ($pre ne undef);
$txt .= "Process exceeded " . conf("memory_prog_limit") .
" bytes. Tried to use ". @info{bytes_attempted};
return ($pre ne undef) ? uc($txt) : $txt;
}
sub fun_setr
{
my ($self,$prog) = (shift,shift);
my ($new_size, $old_size);
good_args($#_,2) ||
return "#-1 FUNCTION (SETR) EXPECTS 2 ARGUMENTS";
my $register = lc(trim(evaluate($self,$prog,shift)));
# emulate setq register bucket
$register = "setq_$register" if($register =~ /^\s*([0-9a-z])\s*$/);
my $out = evaluate($self,$prog,shift);
if(!managed_var_set($prog,$register,$out)) {
return managed_var_set_error("#-1");
}
return $out;
}
#
# fun_setq
# Stores a temporary variable for use in mushcode.
#
sub fun_setq
{
good_args($#_ - 2,2) ||
return "#-1 FUNCTION (SETQ) EXPECTS 2 ARGUMENTS";
fun_setr(@_); # reuse code
return undef;
}
sub fun_r
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (R) EXPECTS 1 ARGUMENTS";
my $register = trim(evaluate($self,$prog,shift));
if($register =~ /^\s*(0|1|2|3|4|5|6|7|8|9)\s*$/) {
if(defined $$prog{var}->{"setq_$register"}) {
return $$prog{var}->{"setq_$register"};
} else {
return undef;
}
} elsif(defined $$prog{var}->{$register}) {
return $$prog{var}->{$register};
} else {
return undef;
}
}
sub fun_elements
{
my ($self,$prog) = (shift,shift);
my (@list,@number,@out);
good_args($#_,2,3,4) ||
return "#-1 FUNCTION (ELEMENTS) EXPECTS BETWEEN 2 AND 4 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $numbers = ansi_remove(evaluate($self,$prog,shift));
my $idelim = ansi_remove(evaluate($self,$prog,shift));
my $odelim = evaluate($self,$prog,shift);
$idelim = " " if($idelim eq undef);
$odelim = " " if($odelim eq undef);
@list = safe_split($txt,$idelim);
@number = safe_split($numbers," ");
for my $num (@number) {
if(isint($num) && $num > 0 && $num <= $#list+1) {
push(@out,@list[$num-1]);
}
}
return join($odelim,@out);
}
sub fun_extract
{
my ($self,$prog) = (shift,shift);
good_args($#_,3,4,5) ||
return "#-1 FUNCTION (EXTRACT) EXPECTS BETWEEN 3 AND 5 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $first = evaluate($self,$prog,shift);
my $length = evaluate($self,$prog,shift);
my $idelim = evaluate($self,$prog,shift);
my $odelim = evaluate($self,$prog,shift);
my $orig = $length;
my (@list,$last);
$idelim = " " if($idelim eq undef);
$odelim = " " if($odelim eq undef);
return if $first == 0;
if($first !~ /^\s*\d+\s*$/) {
return "#-1 EXTRACT EXPECTS NUMERIC VALUE FOR SECOND ARGUMENT";
} elsif($length !~ /^\s*\d+\s*$/) {
return "#-1 EXTRACT EXPECTS NUMERIC VALUE FOR THIRD ARGUMENT";
}
$first--;
@list = safe_split($txt,$idelim);
if($first + $length > $#list) {
$length = $#list - $first;
} else {
$length--;
}
if($idelim eq " ") {
# printf("1Extract: %s,%s,%s,%s='%s'\n",$txt,$first,$length,$idelim,$odelim,
# trim(join($odelim,@list[$first .. ($first+$length)])));
return trim(join($odelim,@list[$first .. ($first+$length)]));
} else {
# printf("2Extract: %s,%s,%s,%s='%s'\n",$txt,$first,$length,$idelim,$odelim,
# join($odelim,@list[$first .. ($first+$length)]));
return join($odelim,@list[$first .. ($first+$length)]);
}
}
sub fun_delete
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,2,3) ||
return "#-1 FUNCTION (DELETE) EXPECTS 3 OR 4 ARGUMENTS";
my $txt = shift;
my $first = ansi_remove(evaluate($self,$prog,shift));
my $len = ansi_remove(evaluate($self,$prog,shift));
if($first !~ /^\s*(\d+)\s*$/) { # compat with TinyMUSH
return $txt;
} elsif($first !~ /^\s*(\d+)\s*$/) { # compat with TinyMUSH
return $txt;
}
$txt = ansi_init(evaluate($self,$prog,$txt));
return ansi_substr($txt,0,trim($first)) . ansi_substr($txt,$first + $len)
}
sub fun_remove
{
my ($self,$prog) = (shift,shift);
my (%remove, @result);
good_args($#_,2,3) ||
return "#-1 FUNCTION (REMOVE) EXPECTS 2 OR 3 ARGUMENTS";
my $list = evaluate($self,$prog,shift);
my $words = evaluate($self,$prog,shift);
my $delim = evaluate($self,$prog,shift);
if($delim eq undef || $delim eq " ") {
$list =~ s/^\s+|\s+$//g;
$list =~ s/\s+/ /g;
$words =~ s/^\s+|\s+$//g;
$words =~ s/\s+/ /g;
$delim = " ";
}
for my $word (safe_split($words,$delim)) {
@remove{$word} = 1;
}
for my $word (safe_split($list,$delim)) {
if(defined @remove{$word}) {
delete @remove{$word}; # only remove once
} else {
push(@result,$word);
}
}
return join($delim,@result);
}
sub fun_rjust
{
my ($self,$prog) = (shift,shift);
good_args($#_,2,3) ||
return "#-1 FUNCTION (RJUST) EXPECTS 2 OR 3 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $size = evaluate($self,$prog,shift);
my $fill = evaluate($self,$prog,shift);
# printf("%s",print_var($$prog{var}));
$fill = " " if($fill =~ /^$/);
if($size =~ /^\s*$/) {
return $txt;
} elsif($size !~ /^\s*(\d+)\s*$/) {
return "#-1 rjust expects a numeric value for the second argument";
} elsif($size <= 0 || $size >= 8000) {
return "#-1 OUT OF RANGE";
} else {
return ($fill x ($size - length(substr($txt,0,$size)))) .
substr($txt,0,$size);
}
}
sub fun_ljust
{
my ($self,$prog) = (shift,shift);
good_args($#_,2,3) ||
return "#-1 FUNCTION (LJUST) EXPECTS 2 OR 3 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $size = evaluate($self,$prog,shift);
my $fill = evaluate($self,$prog,shift);
$fill = " " if($fill =~ /^$/);
if($size =~ /^\s*$/) {
return $txt;
} elsif($size !~ /^\s*(\d+)\s*$/) {
return "#-1 ljust expects a numeric value for the second argument";
} elsif($size <= 0 || $size >= 8000) {
return "#-1 OUT OF RANGE";
} else {
my $sub = ansi_substr($txt,0,$size);
return $sub . ($fill x ($size - ansi_length($sub)));
}
}
sub fun_strlen
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
return "#-1 FUNCTION (STRLEN) EXPECTS 1 ARGUMENTS";
return ansi_length(ansi_trim(evaluate($self,$prog,shift)));
}
sub fun_strtrunc
{
my ($self,$prog) = (shift,shift);
good_args($#_,2,3) ||
return "#-1 FUNCTION (STRTRUNC) EXPECTS 2 arguments";
return fun_substr($self,$prog,shift,0,shift);
}
#
# fun_substr
# substring function
#
sub fun_substr
{
my ($self,$prog) = (shift,shift);
good_args($#_,2,3) ||
return "#-1 Substr expects 2 - 3 arguments";
my $txt = evaluate($self,$prog,shift);
my $start = evaluate($self,$prog,shift);
my $end = evaluate($self,$prog,shift);
if($start !~ /^\s*\d+\s*/) {
return "#-1 Substr expects a numeric value for second argument";
} elsif($end !~ /^\s*\d+\s*/) {
return "#-1 Substr expects a numeric value for third argument";
}
return ansi_substr($txt,$start,$end);
}
sub fun_right
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,2) ||
return "#-1 FUNCTION (RIGHT) EXPECTS 2 ARGUMENT";
my $txt = evaluate($self,$prog,shift);
my $size = evaluate($self,$prog,shift);
if($size !~ /^\s*\d+\s*/) {
return "#-1 FUNCTION (RIGHT) EXPECTS 2 ARGUMENT TO BE NUMERIC";
}
return ansi_substr($txt,length($txt) - $size,$size);
}
sub fun_left
{
my ($self,$prog) = (obj(shift),shift);
good_args($#_,2) ||
return "#-1 FUNCTION (LEFT) EXPECTS 2 ARGUMENT";
my $txt = evaluate($self,$prog,shift);
my $size = evaluate($self,$prog,shift);
if($size !~ /^\s*\d+\s*/) {
return "#-1 FUNCTION (RIGHT) EXPECTS 2 ARGUMENT TO BE NUMERIC";
}
return ansi_substr($txt,0,$size);
}
#
# fun_input
# Check to see if there is any input in the specified input buffer
# variable. If there is, return the data or return #-1 No Data Found
#
sub fun_input
{
my ($self,$prog,$txt) = (obj(shift),shift,shift);
if($txt =~ /^\s*last\s*$/i) {
if(hasflag($self,"WIZARD")) {
return necho(self => $self,
prog => $prog,
source => [ "%s", @info{connected_raw} ],
);
} else {
return "#-1 PERMISSION DENIED";
}
}
if(!defined $$prog{socket_id} && !defined $$prog{socket_buffer}) {
return "#-1 Connection Closed";
} elsif(defined $$prog{socket_id} && !defined $$prog{socket_buffer}) {
$$prog{idle} = 1; # hint to queue
return "#-1 No data found";
}
my $input = $$prog{socket_buffer};
# check if there is any buffered data and return it.
# if not, the socket could have closed
if($#$input == -1) {
if(defined $$prog{socket_id} &&
defined @connected{$$prog{socket_id}}) {
$$prog{idle} = 1; # hint to queue
return "#-1 No data found"; # wait for more data?
} else {
return "#-1 Connection closed"; # socket closed
}
} else {
my $data = shift(@$input); # return buffered data
# $data =~ s/\\/\\\\/g;
# $data =~ s/\//\\\//g;
$data =~ s/â/'/g;
$data =~ s/â/-/g;
$data =~ s/`/`/g;
$data =~ s/â/`/g;
$data =~ s/â/,/g;
$data =~ s/â¡/`/g;
$data =~ s/â /N /g;
$data =~ s/â /S /g;
$data =~ s/â /SE /g;
$data =~ s/â /E /g;
my $ch = chr(226) . chr(134) . chr(152);
$data =~ s/$ch/SE/g;
my $ch = chr(226) . chr(134) . chr(147);
$data =~ s/$ch/S/g;
my $ch = chr(226) . chr(134) . chr(145);
$data =~ s/$ch/N/g;
my $ch = chr(226) . chr(134) . chr(146);
$data =~ s/$ch/E/g;
my $ch = chr(226) . chr(134) . chr(151);
$data =~ s/$ch/NE/g;
my $ch = chr(226) . chr(134) . chr(150);
$data =~ s/$ch/NW/g;
return $data;
}
}
sub fun_flags
{
my ($self,$prog) = (shift,shift);
good_args($#_,1) ||
"#-1 FUNCTION (FLAGS) EXPECTS 1 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
# verify arguments
return "#-1" if($txt =~ /^\s*$/);
# find object
my $target = find($self,$prog,$txt);
return "#-1" if($target eq undef);
# return results
return flag_list($target);
}
#
# fun_space
#
sub fun_space
{
my ($self,$prog) = (shift,shift);
good_args($#_,0,1) ||
return "#-1 Space expects 0 or 1 values";
my $count = evaluate($self,$prog,shift);
if($count =~ /^\s*$/) {
$count = 1;
} elsif($count !~ /^\s*\d+\s*/) {
return undef;
}
return " " x $count ;
}
# [repeat(^'+.\,.+',6)]
#
# fun_repeat
#
sub fun_repeat
{
my ($self,$prog) = (shift,shift);
good_args($#_,2) ||
return "#-1 FUNCTION (REPEAT) EXPECTS 2 ARGUMENTS";
my $txt = evaluate($self,$prog,shift);
my $count = evaluate($self,$prog,shift);
if($count !~ /^\s*\d+\s*/) {
return "#-1 Repeat expects numeric value for the second arguement";
}
if($count > 1000 && $count * length($txt) > 1000) {
return undef;
} else {
return $txt x $count;
}
}
#
# fun_time
#
sub fun_time
{
my ($self,$prog) = (shift,shift);
if($#_ != -1 && $#_ != 0) {
return "#-1 Time expects no arguments but found " . ($#_ +1);
}
return scalar localtime(); # . " " . strftime("%Z",localtime());
}
#
# fun_timezone
#
sub fun_timezone
{
my ($self,$prog) = (shift,shift);
if($#_ != -1 && $#_ != 0) {
return "#-1 Timezone expects no arguments but found " . ($#_ +1);
}
return scalar strftime("%Z",localtime());
}
#
# fun_lattr
# Return a list of attributes on an object or the enactor.
#
sub fun_lattr
{
my ($self,$prog) = (shift,shift);
my ($obj,$atr,@list);
good_args($#_,1) ||
return "#-1 FUNCTION (LATTR) EXPECTS 1 ARGUMENT";
my ($obj,$atr) = bsplit(shift,"/");
my ($atr,$sub) = besplit($self,$prog,$atr,":");
my $target = find($self,$prog,evaluate($self,$prog,$obj)) ||
return "#-1 Unknown object";
if(!controls($self,$target) && !hasflag($target,"VISUAL")) {
return "#-1 Permission Denied.";
}
my $pat = ($atr eq undef) ? undef : glob2re($atr);
my $spat = ($sub eq undef) ? undef : glob2re($sub);
for my $attr (grep {!/^obj_/i} lattr($target)) {
if(db_set_hashable($target,$attr)) {
for my $key (db_hash_keys($target,$attr)) {
if($spat eq undef || $key =~ /$spat/) {
push(@list,uc($attr) . ":" . uc($key));
}
}
} elsif($spat eq undef) {
push(@list,uc($attr)) if($pat eq undef || $attr =~ /$pat/i);
}
}
return join(' ',@list);
}
#
# fun_itext
# Returns the current value of iter() by depth.
#
sub fun_itext
{
my ($self,$prog) = (shift,shift);
good_args($#_,0,1) ||
return "#-1 FUNCTION (ITEXT) EXPECTS 0 OR 1 ARGUMENTS";
return if(!defined $$prog{iter_stack}); # not in iter()
my $pos = evaluate($self,$prog,shift);
if($pos eq undef) {
$pos = 0;
} elsif(!isint($pos)) {
return "#-1 INVALID NUMBER";
}
my $stack = $$prog{iter_stack};
return if($pos >= $#$stack+1); # request is to deep and
# MUSH doesn't return error
return @{$$stack[$#$stack - $pos]}{val};
}
#
# fun_inum
# Returns the positional count in the list of where iter() currently
# is by depth.
#
sub fun_inum
{
my ($self,$prog) = (shift,shift);
good_args($#_,0,1) ||
return "#-1 FUNCTION (INUM) EXPECTS 0 OR 1 ARGUMENTS";
return if(!defined $$prog{iter_stack}); # not in iter()
my $pos = evaluate($self,$prog,shift);
if($pos eq undef) {
$pos = 0;
} elsif(!isint($pos)) {
return "#-1 INVALID NUMBER";
}
my $stack = $$prog{iter_stack};
return if($pos >= $#$stack+1); # request is to deep and
# MUSH doesn't return error
return @{$$stack[$#$stack - $pos]}{pos};
}
sub fun_ilev
{
for my $i (0 .. $#_) {
printf("$i : '%s'\n",$_[$i]);
}
my ($self,$prog) = (shift,shift);
good_args($#_,0) ||
return "#-1 FUNCTION (ILEV) EXPECTS 0 ARGUMENTS - $#_";
return -1 if(!defined $$prog{iter_stack}); # not in iter()
return $#{$$prog{iter_stack}};
}
sub stack_print
{
my $count = 0;
my $sub = "N/A";
for my $line (split(/\n/,Carp::shortmess)) {
if($line =~ /^\s*main::([^ \(]+).* at ([^ ]+) line (\d+)/) {
if(++$count == 2) {
$sub = $1;
last;
}
} elsif($count > 3) {
last;
}
}
printf("---[ start: $sub ]---\n");
for my $i (0 .. $#_) {
printf("%-3s : '%s'\n",$i,$_[$i]);
}
printf("---[ End ]---\n");
}
#
# fun_iter
#
sub fun_iter
{
my ($self,$prog) = (shift,shift);
my $count = 0;
good_args($#_,2 .. 4) ||
return "#-1 FUNCTION (ITER) EXPECTS 2 AND 4 ARGUMENTS";
my $argc = $#_;
my ($list,$txt) = ($_[0],$_[1]);
my $idelim = evaluate($self,$prog,$_[2]);
$idelim = " " if($idelim eq undef || $idelim eq "\@\@");
my $odelim = evaluate($self,$prog,$_[3]);
if($odelim eq "\@\@") {
$odelim = "";
} elsif($argc < 3 && $odelim eq undef) {
$odelim = " ";
}
my @result;
$$prog{iter_stack} = [] if(!defined $$prog{iter_stack});
my $loc = $#{$$prog{iter_stack}} + 1;
for my $item (safe_split(evaluate($self,$prog,$list),$idelim)) {
$item = trim($item) if ($idelim eq " ");
@{$$prog{iter_stack}}[$loc] = { val => evaluate($self,$prog,$item),
pos => ++$count };
# $$prog{var} = {} if !defined $$prog{var};
push(@result,evaluate($self,$prog,$txt));
}
delete @{$$prog{iter_stack}}[$loc .. $#{$$prog{iter_stack}}];
return join($odelim,@result);
}
#
# fun_list
#
sub fun_list
{
my ($self,$prog) = (obj(shift),shift);
my ($count,$target) = (0);
good_args($#_,2 .. 4) ||
return "#-1 FUNCTION (LIST) EXPECTS 2 AND 4 ARGUMENTS";
my $argc = $#_;
my ($list,$txt) = ($_[0],$_[1]);
my $idelim = evaluate($self,$prog,$_[2]);
$idelim = " " if($idelim eq undef || $idelim eq "\@\@");
my @result;
$$prog{iter_stack} = [] if(!defined $$prog{iter_stack});
my $loc = $#{$$prog{iter_stack}} + 1;
if(defined $$prog{cmd} && defined @{$$prog{cmd}}{invoker}) {
$target = @{$$prog{cmd}}{invoker};
} else {
$target = $self;
}
for my $item (safe_split(evaluate($self,$prog,$list),$idelim)) {
# printf("LIST: '%s'\n",$item);
$item = trim($item) if ($idelim eq " ");
@{$$prog{iter_stack}}[$loc] = { val => evaluate($self,$prog,$item),
pos => ++$count };
my $result = evaluate($self,$prog,$txt);
# printf(" # '%s'\n",$result);
necho(self => $self,
prog => $prog,
target => [ $target, "%s", $result ],
);
}
delete @{$$prog{iter_stack}}[$loc .. $#{$$prog{iter_stack}}];
return;
}
#
# fun_citer
#
sub fun_citer
{
my ($self,$prog) = (shift,shift);
my ($count) = 0;
my @result;
good_args($#_,2,3) ||
return "#-1 FUNCTION (ITER) EXPECTS 2 OR 3 ARGUMENTS";
my $argc = $#_;
my $list = evaluate($self,$prog,shift);
my $txt = shift;
my $odelim = evaluate($self,$prog,shift);
$odelim = " " if(($argc != 2 && $odelim eq undef) || $odelim eq "\@\@");
$$prog{iter_stack} = [] if(!defined $$prog{iter_stack});
my $loc = $#{$$prog{iter_stack}} + 1;
my $data = ansi_init(evaluate($self,$prog,$list));
for my $i (0 .. $#{$$data{ch}}) {
my $item = ansi_substr($data,$i,1);
@{$$prog{iter_stack}}[$loc] = { val => $item, pos => ++$count };
my $new = trim($txt);
$new =~ s/##/$item/g;
$new =~ s/#\@/$count/g;
push(@result,trim(evaluate($self,$prog,$new)));
}
delete @{$$prog{iter_stack}}[$loc];
return join($odelim,@result);
}
#
# fun_lookup
# See if the function exists or not. Return "huh" if only to be
# consistent with the command lookup
#
sub fun_lookup
{
my ($self,$prog,$name,$before,$flag) = (shift,shift,lc(shift),shift,shift);
if(defined @fun{lc($name)}) {
return lc($name);
} elsif(defined @info{mush_function} &&
defined @{@info{mush_function}}{lc($name)}) {
return "EVAL";
}
# if(!$flag) {
# con("undefined function '%s'\n",$name);
# con(" '%s'\n",ansi_debug($before));
# con("%s",code("long"));
# }
# record missing function for @missing
if(defined $$prog{missing} && ref($$prog{missing}) eq "HASH") {
$$prog{missing}->{fun}->{lc($name)}++;
}
return "huh";
}
#
# function_walk
# Traverse the string till the end of the function is reached.
# Keep track of the depth of {}[]"s so that the function is
# not split in the wrong place.
#
sub parse_function
{
my ($self,$prog,$fun,$txt,$type) = @_;
my (@result, $stack);
if($$prog{function_command}++ > conf("function_limit")) {
return undef; # "#-1 FUNCTION INVOCATION LIMIT HIT";
}
$$prog{function}++;
# my $stack = new_balanced_split("mid(time(woot(biz))x,0,5)");
# for my $i (0 .. $#$stack) {
# printf("%s : %s\n",$$stack[$i]->{depth},$$stack[$i]->{data});
# }
# printf("Parsing: '%s'\n","[$fun($txt");
if(0) {
if($type == 1) {
$stack = new_balanced_split("[$fun($txt");
} else {
$stack = new_balanced_split("$fun($txt");
}
if($stack eq undef || $#$stack < 1) {
return undef if $stack eq undef || $#$stack <= 1;
}
# for my $i (0 .. $#$stack) {
# printf("%s : %s\n",$$stack[$i]->{depth},$$stack[$i]->{data});
# }
for my $i (1 .. $#$stack) { # convert to old data structure
if($i == $#$stack) { # is end of function right?
if($$stack[$i]->{depth} != 0) {
return undef; # parentheses not matched
} elsif($type == 1 && $$stack[$i]->{data} =~ /^\s*\)\s*]/) {
unshift(@result,$');
} elsif($type == 2 && $$stack[$i]->{data} ne ")") {
return undef; # parse error, should be no data
} elsif($type == 2) {
unshift(@result,undef);
}
return \@result;
} else {
push(@result,$$stack[$i]->{data});
}
}
return undef; # shouldn't happen?
}
my @array = balanced_split($txt,",",$type);
return undef if($#array == -1);
# type 1: expect ending ]
# type 2: expect ending ) and nothing else
if(($type == 1 && @array[0] =~ /^ *]/) ||
($type == 2 && @array[0] =~ /^\s*$/)) {
@array[0] = $'; # strip ending ] if there
# for my $i (0 .. $#array) {
# printf("# $i : '%s' -> '%s'\n",@array[$i],@result[$i]);
# }
return \@array;
} else {
return undef;
}
}
# balanced_split
# Split apart a string but allow the string to have "",{},()s
# that keep segments together... but only if they have a matching
# pair. This version should be escape sequence friendly.
#
# types:
# 1 : function split?
# 2 : split until end of function?
# 3 : split at delim
# 4 : split until delim, delim not included in result
#
# FYI: Strings are split using ansi_substr() in as big of segments as
# possible to avoid having extra escape sequences.
sub balanced_split
{
my ($str,$delim,$type,$debug) = (ansi_init(shift),shift,shift,shift);
my $end = ansi_length($str);
my $stack = [];
my $seg = [];
my ($i,$start) = (0,0);
my ($br,$bl,$pr,$pl) = ("{","}","(",")"); # make vi happy
for($i=0;$i < $end;$i++) {
my $ch = ansi_char($str,$i); # get current ch
# escaped character or escaped delim via % char but not %{varable}s
if($ch eq "\\" ||
($ch eq "%" && ansi_substr($str,$i,undef,1) !~ /^%\{[a-zA-Z0-9\_#]+\}/)) {
$i++;
} elsif($ch eq $pr) { # go down one level
push(@$stack,{ ch => $pl, i => $i, start => $start, seg => $#$seg});
} elsif($ch eq $br) { # go down one level
push(@$stack,{ ch => $bl, i => $i, start => $start, seg => $#$seg});
} elsif($ch eq $pl) { # go up one level?
if($#$stack == -1) { # end of function at right depth
if($type <= 2) {
push(@$seg,ansi_substr($str,$start,$i-$start));
$start = $i + 1;
last;
}
} elsif($ch eq @{@$stack[-1]}{ch}) {
pop(@$stack); # pair matched, move up one level
}
} elsif($#$stack >= 0 && $ch eq @{@$stack[-1]}{ch}) {
pop(@$stack); # pair matched, move up one level
} elsif($ch eq $delim && $#$stack == -1) { # delim at right level
push(@$seg,ansi_substr($str,$start,$i-$start));
return $$seg[0], ansi_substr($str,$i+1), 1 if($type == 4);
$start = $i+1;
}
# processed to end of string but there are still unmatched {}() pairs.
# Back out one at a time and see if it eventually parses.
if($i + 1 == $end && $#$stack >= 0) {
my $rp = pop(@$stack); # go back one "restore point"
$i = $$rp{i};
$start = $$rp{start}; # @seg end is invalid, delete
delete @$seg[($$rp{seg}+1) .. $#$seg] if($#$seg > $$rp{seg});
}
}
if($type == 4) { # handle the various return types
return ansi_string($str), undef, 0;
} elsif($type == 3) {
push(@$seg,ansi_substr($str,$start,$end-$start));
return @$seg;
} else {
if($#$stack != -1) {
return undef;
} else {
unshift(@$seg,ansi_substr($str,$start,$end-$start));
return @$seg;
}
}
}
#
# used to debug balanced_split, remove after the new version of
# balanced split is veted properly.
#
sub stack_compare
{
my ($txt,$delim,$type,$flag) = @_;
my ($i,$old,$new,$out1, $out2);
my $orig = $txt;
my $i;
for my $seg (old_balanced_split($txt,$delim,$flag)) {
++$old;
$out1 .= sprintf("%s : '%s'\n",++$i,$seg);
}
my $i;
for my $seg (sbalanced($txt,$delim,$flag)) {
++$new;
$out2 .= sprintf("%s : '%s'\n",++$i,ansi_debug($seg));
}
if(1 || ansi_remove($out1) ne ansi_remove($out2) || $new ne $old || $txt ne $orig) {
printf("TEXT: '%s'\n",$txt);
printf("delim: '%s'\n",$delim);
printf("type: '%s'\n",$type);
printf("code: '%s'\n",code());
printf("---[ OLD Start <$old>]----\n%s--[ OLD End ]----\n",$out1);
printf("---[ NEW Start <$new>]----\n%s--[ NEW End ]----\n\n",$out2);
}
}
#
# script
# Create some output that can be tested against another mush
#
sub script
{
my ($self,$prog,$fun,$args,$result) = @_;
return;
con("think [switch(%s(%s),%s,,{WRONG %s(%s) -> %s})]\n",
$fun,
evaluate_substitutions($self,$prog,$args),
evaluate_substitutions($self,$prog,$result),
$fun,
evaluate_substitutions($self,$prog,$args),
evaluate_substitutions($self,$prog,$result)
);
# if($result =~ /^\s*$/) {
# con("FUN: '%s(%s) returned undef\n",$fun,$args);
# }
# return;
# if($args !~ /(v|u|get|r)\(/i && $fun !~ /^(v|u|get|r)$/) {
# my $eval_args = evaluate($self,$prog,$args);
# con("think [switch(%s(%s),%s,,{WRONG %s(%s) -> %s})]\n",
# $fun,$eval_args,$result,$fun,$eval_args,$result);
## }
}
sub meval
{
my ($self,$prog,@args) = @_;
my @result;
for my $i (0 .. $#args) {
push(@result,evaluate($self,$prog,@args[$i]));
}
return @result;
}
#
# evaluate_string
# Take a string and parse/run any functions in the string.
#
sub evaluate
{
my ($self,$prog,$txt) = @_;
my $id = (ref($self) eq "HASH") ? $$self{obj_id} : $self;
my $out;
#
# handle string containing a single non []'ed function
#
return if(!valid_dbref($self));
return $txt if(conf("safemode"));
if($txt =~ /^\s*([a-zA-Z_0-9]+)\((.*)\)\s*$/m) {
my $fun = fun_lookup($self,$prog,$1,undef,1);
if($fun ne "huh") { # not a function, do not evaluate
my $result = parse_function($self,$prog,$fun,"$2)",2);
if($result ne undef) {
shift(@$result);
con("undefined function: '%s'\n",$fun) if($fun eq "huh");
my $start = Time::HiRes::gettimeofday();
$$prog{mush_function_name} = $1 if($fun eq "EVAL");
my $r=&{@fun{$fun}}($id,$prog,@$result);
delete @$prog{mush_function_name};
$$prog{function_duration} +=Time::HiRes::gettimeofday()-$start;
$$prog{"fun_$fun"}++;
script($self,$prog,$fun,join(',',@$result),$r);
return $r;
}
}
}
if($txt =~ /^\s*{\s*(.*)\s*}\s*$/) { # mush strips these
$txt = $1;
}
#
# pick functions out of string when enclosed in []'s
#
while($txt =~ /([\\]*)\[([a-zA-Z_0-9]+)\(/s && ord(substr($`,-1)) ne 27) {
my ($esc,$before,$after,$unmod) = ($1,$`,$',$2);
$out .= evaluate_substitutions($self,$prog,$before);
$out .= "\\" x (length($esc) / 2);
if(length($esc) % 2 == 0) {
my $fun = fun_lookup($self,$prog,$unmod,$before);
my $result = parse_function($self,$prog,$fun,$',1);
if($result eq undef) {
$txt = $after;
$out .= "[$fun(";
} else { # good function, run it
$txt = shift(@$result);
my $start = Time::HiRes::gettimeofday();
$$prog{mush_function_name} = $unmod if($fun eq "EVAL");
my $r = &{@fun{$fun}}($id,$prog,@$result);
delete @$prog{mush_function_name};
$$prog{function_duration} +=Time::HiRes::gettimeofday()-$start;
script($self,$prog,$fun,join(',',@$result),$r);
$out .= "$r";
}
} else { # start of function escaped out
$out .= "[$unmod(";
$txt = $after;
}
}
if($txt ne undef) { # return results + leftovers
return $out . evaluate_substitutions($self,$prog,$txt);
} else {
return $out;
}
}
# #!/usr/bin/perl
# Handle the incoming data and look for disconnects.
#
sub http_io
{
my $s = shift;
my $buf;
if(sysread($s,$buf,1024) <= 0) { # oops socket died
http_disconnect($s);
} else {
$buf =~ s/\r//g;
@{@http{$s}}{buf} .= $buf; # store new input
while(defined @http{$s} && @{@http{$s}}{buf} =~ /\n/){
@{@http{$s}}{buf} = $'; # process any full lines
http_process_line($s,$`);
}
if(defined @http{$s} && defined @{@http{$s}}{data}) {
my $data = @{@http{$s}}{data};
if(defined $$data{headers_done}) {
http_process_line($s,@{@http{$s}}{buf});
@{@http{$s}}{buf} = undef;
}
}
}
}
#
# http_accept
# The listener has detected a new socket
#
sub http_accept
{
my $s = shift;
my $new = $web->accept();
my $addr = server_hostname($new);
if(defined @info{httpd_ban} && defined @{@info{httpd_ban}}{$addr}) {
web(" %s %s\@web [BANNED-CLOSE]\n",ts(),$addr);
$new->close();
} else {
$readable->add($new);
@http{$new} = { sock => $new,
data => {},
ip => $addr,
};
}
}
sub http_disconnect
{
my $s = shift;
delete @http{$s};
$readable->remove($s);
$s->close;
}
sub manage_httpd_bans
{
my $s = shift;
my ($ip,@list, $max);
if($s ne undef) {
$ip = (defined @http{$s}->{$ip}) ? @http{$s}->{$ip} : $s->peerhost;
@info{httpd_invalid_data} = {} if !defined @info{httpd_invalid_data};
if(!defined @info{httpd_invalid_data}->{$ip}) {
@info{httpd_invalid_data}->{$ip} = {};
}
@info{httpd_invalid_data}->{$ip}->{time()} = 1;
push(@list,$ip);
} elsif(!defined @info{httpd_invalid_data}) {
return;
} else {
@info{httpd_ban} = {}; # reinitialize
@list = (keys %{@info{httpd_invalid_data}});
}
my $hash = @info{httpd_invalid_data};
for my $host (@list) {
$max = undef;
for my $hit (keys %{$$hash{$host}}) {
$max = $hit if($hit > $max); # find newest offense
delete $$hash{$hit} if(time() - $hit > 3600); # delete older offenses
}
if(scalar keys %{$$hash{$host}} == 0) { # nothing current, delete
delete @$hash{$host};
} elsif(scalar keys %{$$hash{$host}} > 4) { # recently bad, keep ban
@info{http_ban} = {} if(!defined @info{http_ban});
@info{http_ban}->{$host} = scalar localtime($max);
}
}
}
#
# http_error
# Something has gone wrong, inform the broswer.
#
sub http_error
{
my ($s,$fmt,@args) = @_;
if(defined @http{$s} && defined @http{$s}->{data}) {
if(@http{$s}->{data}->{get} !~ /^\s*(favicon\.ico|robots.txt)\s*$/i) {
manage_httpd_bans($s);
}
}
#
# show the invalid page responce
#
http_out($s,"HTTP/1.1 404 Not Found");
http_out($s,"Date: %s",scalar localtime());
http_out($s,"Last-Modified: %s",scalar localtime());
http_out($s,"Connection: close");
http_out($s,"Content-Type: text/html; charset=ISO-8859-1");
http_out($s,"");
http_out($s,"<html><meta name=\"viewport\" content=\"initial-scale=.5, maximum-scale=1\">");
http_out($s,"<style>");
http_out($s,".big {");
http_out($s," line-height: .7;");
http_out($s," margin-bottom: 0px;");
http_out($s," font-size: 100pt;");
http_out($s," color: hsl(0,100%,30%);");
http_out($s,"}");
http_out($s,"div.big2 {");
# http_out($s," border: 2px solid red;");
http_out($s," line-height: .2;");
http_out($s," display:inline-block;");
http_out($s," -webkit-transform:scale(2,1); /* Safari and Chrome */");
http_out($s," -moz-transform:scale(2,1); /* Firefox */");
http_out($s," -ms-transform:scale(2,1); /* IE 9 */");
http_out($s," -o-transform:scale(2,1); /* Opera */");
http_out($s," transform:scale(2,1); /* W3C */");
http_out($s,"}");
http_out($s,"</style>");
http_out($s,"<body>");
http_out($s,"<br>");
http_out($s,"<table width=100%>");
http_out($s," <tr>");
http_out($s," <td width=30px>");
http_out($s," <div class=\"big\">404</div><br>");
http_out($s," <center>");
http_out($s," <div class=\"big2\">Page not found</div>");
http_out($s," </center>");
http_out($s," </td>");
http_out($s," <td width=30px>");
http_out($s," </td>");
http_out($s," <td>");
http_out($s," <center><hr size=2>$fmt<hr></center>",@args);
http_out($s," <pre>%s</pre>\n",code("long"));
http_out($s," </td>");
http_out($s," </td>");
http_out($s," <td width=30px>");
http_out($s," </td>");
http_out($s," </tr>");
http_out($s,"</table>");
http_out($s,"</body>");
http_out($s,"</html>");
http_disconnect($s);
}
#
# http_reply
# A http reply with evaluation but no fries.
#
sub http_reply
{
my ($prog,$fmt,@args) = @_;
my $s = $$prog{sock};
my $msg = sprintf($fmt,@args);
http_out($s,"HTTP/1.1 200 Default Request");
http_out($s,"Date: %s",scalar localtime());
http_out($s,"Last-Modified: %s",scalar localtime());
http_out($s,"Connection: close");
http_out($s,"Content-Type: text/html; charset=ISO-8859-1");
# must store result so cookies can be checked after evaluation
my $result = ansi_remove(evaluate($$prog{user},
$prog,
conf("httpd_template")
)
);
if(defined $$prog{var} && defined $$prog{var}->{cookie}) {
http_out($s,"Set-Cookie: %s",$$prog{var}->{cookie});
}
http_out($s,"");
$result =~ s/[\s\n]+$//g;
http_out($s,"%s\n",$result);
$msg = ansi_remove($msg);
$msg =~ s/[\s\n]+$//g;
http_out($s,"%s\n",$msg);
http_out($s,"</div>\n");
http_out($s,"</body>\n");
http_disconnect($s);
}
#
# http_reply_simple
# A simple http reply with no evaluation.
#
sub http_reply_simple
{
my ($s,$type,$fmt,@args) = @_;
my $msg = sprintf($fmt,@args);
http_out($s,"HTTP/1.1 200 Default Request");
http_out($s,"Date: %s",scalar localtime());
http_out($s,"Last-Modified: %s",scalar localtime());
http_out($s,"Connection: close");
if(lc($type) eq "pdf") {
http_out($s,"Content-Type: application/pdf; charset=ISO-8859-1");
} elsif(lc($type) eq "png") {
http_out($s,"Content-Type: image/png; charset=ISO-8859-1");
} else {
http_out($s,"Content-Type: text/$type; charset=ISO-8859-1");
}
http_out($s,"");
printf({@{@http{$s}}{sock}} "%s",$msg);
http_disconnect($s);
}
#
# http_out
# Send something out to an http socket if its still connected.
#
sub http_out
{
my ($s,$fmt,@args) = @_;
if(defined @http{$s}) {
printf({@{@http{$s}}{sock}} "$fmt\r\n", @args);
}
}
#
# banable_urls
# If you hit one of these urls, you're running a script to look for
# security vulnerabilities and/or hacking... either way, you need to
# go away. This should probably be a permanent ban.
#
sub banable_urls
{
my $data = shift;
if($$data{get} =~ /wget http/i) { # poor wget is abused by hackers
return 1;
} elsif($$data{get} =~ /;wget/i) { # more wget
return 1;
} elsif($$data{get} =~ /phpMyAdmin/i) { # really, no php here
return 1;
} elsif($$data{get} =~ /trinity/i) { # matrix trinity?
return 1;
} elsif($$data{get} =~ /w00tw00t/i) { # woot woot!
return 1;
} elsif($$data{get} =~ /testget/i) { # woot woot!
# example: http://110.249.212.46/testget?q=23333&port=80
return 1;
} elsif($$data{get} =~ /\.(php|cgi|asp)/i) { # no php/cgi/asp here
return 1;
} else {
return 0;
}
}
sub ban_add
{
my $sock = shift;
# setup structures
@info{httpd_ban} = {} if(!defined @info{httpd_ban});
@info{httpd_invalid_data} = {} if(!defined @info{httpd_invalid_data});
if($sock ne undef) {
my $ip = @http{$sock}->{ip};
if(!defined @{@http{$sock}}{$ip}) {
@{@http{$sock}}{$ip} = {};
}
for my $i (0 .. 10) {
@info{httpd_invalid_data}->{$ip}->{time()-$i} = 1;
}
manage_httpd_bans($sock);
}
}
#
# http_process_line
#
# A line of data has been found, store the information for later
# use if the request is not done.
#
sub http_process_line
{
my ($s,$txt) = @_;
my $data = @{@http{$s}}{data};
# printf("# %s\n",$txt);
if($txt =~ /^GET (.*) HTTP\/([\d\.]+)$/i) { # record details
$$data{get} = $1;
} elsif($txt =~ /^POST \/{0,1}(.*) HTTP\/([\d\.]+)$/i) {
$$data{post} = $1;
} elsif($txt =~ /^HEAD (.*) HTTP\/([\d\.]+)$/i) { # record details
$$data{get} = $1;
$$data{head} = 1;
} elsif(defined $$data{post} && defined $$data{headers_done}) {
$$data{post_data} .= $txt;
if($$data{"VAR_content-length"} == length($$data{post_data})) {
my $addr = @{@http{$s}}{hostname};
my $self = obj(conf("webuser"));
my $prog = mushrun(self => $self,
runas => $self,
invoker=> $self,
source => 0,
cmd => $$data{post},
hint => "WEB",
sock => $s,
output => [],
nosplit => 1,
);
$$prog{get} = $$data{post};
$$self{hostname} = $addr;
@{$$prog{var}}{post}=$$data{post};
for my $item (keys %$data) { # make header data availible
@{$$prog{var}}{$'}=$$data{$item} if($item =~ /^VAR_/);
}
# make post data availible via variable
for my $item (split('&',$$data{post_data})) {
if($item =~ /=/ && length($`) < 80) { # and variable names
my ($var,$dat) = (lc($`),$'); # need to be <80 chars
$var =~ s/ //g; # removes spaces
$dat =~ s/\+/ /g;
if(module_enabled("uri_escape")) {
@{$$prog{var}}{$var}=uri_unescape($dat);
} else {
@{$$prog{var}}{$var}=$dat;
}
}
}
}
} elsif($txt =~ /^([\w\-]+): /) {
if(lc($1) eq "content-length" && $' > 4096) {
http_error($s,"%s","POST REQUEST TO BIG");
}
$$data{"VAR_" . lc($1)} = $';
} elsif($txt =~ /^\s*$/ && defined $$data{post}) {
$$data{headers_done} = 1;
} elsif($txt =~ /^\s*$/ && defined $$data{get}) { # end of request
$$data{get} = uri_unescape($$data{get}) if(module_enabled("uri_escape"));
$$data{get} =~ s/\// /g;
$$data{get} =~ s/^\s+|\s+$//g;
$$data{get} = "default" if($$data{get} =~ /^\s*$/);
if($$data{get} eq undef) {
http_error($s,"Malformed Request");
} else {
my $id = conf("webuser");
my $self = obj(conf("webuser"));
# run the $default mush command as the default webpage.
my $addr = @{@http{$s}}{hostname};
$addr = @{@http{$s}}{ip} if($addr =~ /^\s*$/);
$addr = $s->peerhost if($addr =~ /^\s*$/);
return http_error($s,"Malformed Request or IP") if($addr =~ /^\s*$/);
@http{$s}->{ip} = $addr;
@info{httpd_ban} = {} if(!defined @info{httpd_ban});
# html/js/css should be a static file, so just return the file
if($$data{get} eq "unban") {
delete @{@info{httpd_ban}}{$addr};
delete @info{httpd_invalid_data}->{$addr};
http_reply_simple($s,"html","%s","$addr has been unbanned.");
} elsif(banable_urls($data)) {
ban_add($s);
web(" %s %s\@web [BANNED-%s]\n",ts(),$addr,$$data{get});
http_error($s,"%s","BANNED for HACKING");
} elsif(defined @{@info{httpd_ban}}{$addr}) {
web(" %s %s\@web [BANNED-%s]\n",ts(),$addr,$$data{get});
http_error($s,"%s","BANNED for invalid requests");
} elsif(($$data{get} =~ /_notemplate\.(html)$/i || # no template used
$$data{get} =~ /\.(ico)$/i) &&
-e "files/" . trim($$data{get})) {
web(" %s %s\@web [%s]\n",ts(),$addr,$$data{get});
http_reply_simple($s,$1,"%s",getfile(trim($$data{get})));
} elsif($$data{get} !~ /[\\\/]/ &&
$$data{get} ne ".." &&
$$data{get} =~ /\.([^.]+)$/ &&
-e "files/" . trim($$data{get})) {
web(" %s %s\@web [%s]\n",ts(),$addr,$$data{get});
http_reply_simple($s,$1,"%s",getbinfile(trim($$data{get})));
} elsif($$data{get} =~ /\.html$/i && -e "files/".trim($$data{get})) {
my $prog = prog($self,$self); # uses template
$$prog{sock} = $s;
web(" %s %s\@web [%s]\n",ts(),$addr,$$data{get});
http_reply($prog,getfile(trim($$data{get})));
} elsif($$data{get} =~ /^pid$/) {
web(" * %s %s\@web [%s]\n",ts(),$addr,$$data{get});
if($addr eq "localhost" || $addr eq "127.0.0.1") {
if(module_enabled("cwd")) {
http_reply_simple($s,$1,"%s",$$.",".getcwd());
} else {
http_reply_simple($s,$1,"%s","$$,%s");
}
} else {
http_error($s,"%s","pid request from bad location. '$addr'");
}
} elsif($$data{get} =~ /^imc /) {
delete @info{sigusr1};
web(" * %s %s\@web [%s]\n",ts(),$addr,$$data{get});
if($addr eq "localhost" || $addr eq "127.0.0.1") {
@info{imc}={ timestamp => time(), command => substr($',0,1024) };
my $god = obj(0);
my $prog = mushrun(self => $god,
runas => $god,
invoker=> $god,
source => 0,
cmd => "\@imc",
hint => "IMC",
sock => $s,
output => [],
nosplit => 1,
);
$$prog{get} = $$data{get};
$$prog{head} = $$data{head} if defined $$data{head};
@{$$prog{var}}{get}=$$data{get};
for my $item (keys %$data) { # make header data availible
@{$$prog{var}}{$'}=$$data{$item} if($item =~ /^VAR_/);
}
} else {
http_error($s,"%s","imc request from bad location.");
}
} else { # mush command
web(" %s %s\@web [%s]\n",ts(),$addr,$$data{get});
my $prog = mushrun(self => $self,
runas => $self,
invoker=> $self,
source => 0,
cmd => $$data{get},
hint => "WEB",
sock => $s,
output => [],
nosplit => 1,
);
$$prog{get} = $$data{get};
$$prog{head} = $$data{head} if defined $$data{head};
$$self{hostname} = $addr;
@{$$prog{var}}{get}=$$data{get};
for my $item (keys %$data) { # make header data availible
@{$$prog{var}}{$'}=$$data{$item} if($item =~ /^VAR_/);
}
}
}
} else {
web("---BAD REQUEST--- '$txt'\n");
http_error($s,"Malformed Request");
}
}
#
# dump_complete
# Determine if a dump file is complete by looking at the last 45
# characters in the file for a dump complete message
#
sub dump_complete
{
my $filename = shift;
my ($buf,$fh);
return 1 if(arg("forceload"));
open($fh,$filename) || return 0;
my $eof = sysseek($fh,0,SEEK_END); # seek to end to determine size
seek($fh,$eof - 46,SEEK_SET); # backup 46 characters
sysread($fh,$buf,45); # read 45 characters
close($fh);
if($buf =~ /^\*\* Dump Completed (.*) \*\*$/) { # verify if complete
return 1;
} else {
return 0;
}
}
#
# load_db
#
sub load_db
{
my ($dir, $file, %state);
# look for db stored inside script. if there is one, invoke tmshell
# mode.
for my $line (<DATA>) {
db_process_line(\%state,$line);
@info{shell} = 1;
}
if(@info{shell}) {
@info{dumps} = ".";
} else {
@info{shell} = 0;
@info{dumps} = "dumps";
if(!-d "@info{dumps}") {
mkdir(@info{dumps}) ||
die("Unable to create directory '@info{dumps}'.");
}
opendir($dir,"@info{dumps}") ||
die("Unable to find @info{dumps} directory");
my $fn=(sort {(stat("@info{dumps}/$a"))[9] <=>
(stat("@info{dumps}/$b"))[9]}
grep {/\.tdb$/} # find most current db
readdir($dir))[-1];
closedir($dir);
if(!dump_complete("@info{dumps}/$fn")) {
die("$fn is incomplete, remove or use --forceload to override");
}
open($file,"< @info{dumps}/$fn") ||
die("Unable to open database '@info{dumps}/$fn'\n");
@info{dump_name} = $` if($fn =~ /\.tdb$/);
while(<$file>) {
db_process_line(\%state,$_);
}
close($file);
printf(" + Database: %s [%s Version, %s bytes]\n",
$fn,@state{ver},@state{chars});
}
if($#db == -1) {
printf("\nNo database found, loading starter database.\n\n");
printf("Connect as: god potrzebie\n\n") if !@info{shell};
my $obj = {obj_id => 0};
my $prog = prog($obj,$obj,$obj);
cmd_pcreate($obj,$prog,"god potrzebie",{},1); # create god
set_flag($obj,$prog,$obj,"GOD",,1); # set god wizard
create_object($obj,$prog,"The Void",undef,"ROOM",1);
set($obj,$prog,$obj,"CONF.STARTING_ROOM","#1",1); # set starting room
teleport($obj,$prog,$obj,1); # teleport god into the void
cmd_pcreate($obj,$prog,"webuser potrzebie",{},1); # create webuser
cmd_give(3,$prog,"#0 = 9999999"); # give webobject money
teleport(3,$prog,$obj,1); # teleport god into the void
set($obj,$prog,$obj,"CONF.WEBUSER","#2",1); # set webuser object
create_object(obj(2),$prog,"WebSecurityObject",undef,"OBJECT",1);
set($obj,$prog,$obj,"CONF.WEBOBJECT","#3",1); # set webuser object
set_flag($obj,$prog,3,"!NO_COMMAND",,1); # remove NO_COMMAND
set($obj,$prog,3,"DEFAULT",
"\$default:\@pemit %#=This is the minimal default web page for " .
"[version()]. Please update this with: &default #3=Your web page",1);
set($obj,$prog,$obj,"CONF.MUDNAME","TeenyMUSH",1); # set mudname
do_full_dump();
}
delete @info{dirty}; # delete, this will get populated by the db load
}
sub generic_action
{
my ($self,$prog,$target,$action,$target_msg,$src_msg) = @_;
# if((my $atr = get($target,$action)) ne undef) {
# necho(self => $self,
# prog => $prog,
# room => [ $self,
# "%s %s",
# name($self),
# evaluate($self,$prog,$atr)
# ],
# );
# }
run_attr($self,$prog,$target,"A$action"); # handle @aACTION
# actions off the web shouldn't trigger any messages outside of
# maybe actions.
return if(defined $$prog{hint} && $$prog{hint} eq "WEB");
my ($sfmt,@sargs) = @$src_msg;
my $msg = sprintf($sfmt,@sargs); # handle msg to enactor
if($msg !~ /^\s*$/) {
necho(self => $self,
prog => $prog,
source => [ "%s", evaluate($self,$prog,$msg) ],
always => 1,
);
}
my $atr = get($target,"o$action");
if($atr ne undef) { # standard message
necho(self => $self,
prog => $prog,
room => [ $self,
"%s %s",
name($self),
evaluate($self,$prog,$atr)
],
always => 1,
);
} else { # oACTION message
my ($tfmt,@targs) = @$target_msg;
my $msg = sprintf($tfmt,@targs);
if($msg !~ /^\s*$/) {
necho(self => $self,
prog => $prog,
room => [ $self, "%s %s", name($self), $msg ],
always => 1,
);
}
}
}
#
# glob2re
# Convert a global pattern into a regular expression
#
sub glob2re
{
my ($pat) = trim(single_line(ansi_remove(shift)));
return "^\s*\$" if $pat eq undef;
$pat =~ s{(\W)}{
$1 eq '?' ? '(.)' :
$1 eq '*' ? '(*PRUNE)(.*?)' :
'\\' . $1
}eg;
$pat =~ s/\\\(.\)/?/g;
# return "(?mnsx:\\A$pat\\z)";
return "(?msix:\\A$pat\\z)";
}
#
# the mush program has finished, so clean up any telnet connections.
#
sub close_telnet
{
my $prog = shift;
if(!defined $$prog{socket_id}) {
return;
} elsif(!defined @connected{$$prog{socket_id}}) {
return;
} elsif(hasflag(@{@connected{$$prog{socket_id}}}{obj_id},
"SOCKET_PUPPET"
)
) {
return;
} else {
$$prog{socket_closed} = 1;
my $hash = @connected{$$prog{socket_id}};
# delete any pending input
con("Closed orphaned mush telnet socket to %s:%s\n",
$$hash{hostname},$$hash{port});
server_disconnect($$prog{socket_id});
delete @$prog{socket_id};
}
}
sub verify_switches
{
my ($self,$prog,$switch,@switches) = @_;
my (%hash,$name);
@hash{@switches} = (0 .. $#switches);
for my $key (keys %$switch) {
if(!defined @hash{$key}) {
if(@{$$prog{cmd}}{cmd} =~ /^\s*([^ \/]+)/) {
$name = $1;
} else {
$name = "N/A";
}
necho(self => $self,
prog => $prog,
source => [ "Unrecognized switch '%s' for command '%s'",
$key,$name ],
);
return 0;
}
}
return 1;
}
#
# err
# Show the user a the provided message. These could be logged
# eventually too.
#
sub err
{
my ($self,$prog,$fmt) = (obj(shift),obj(shift),shift);
my (@args) = @_;
necho(self => $self,
prog => $prog,
source => [ $fmt,@args ],
);
return 0;
# return sprintf($fmt,@args);
# insert log entry?
}
sub first
{
my ($txt,$delim) = @_;
$delim = ';' if $delim eq undef;
return (split($delim,$txt))[0];
}
sub pennies
{
my $what = shift;
my $amount;
if(ref($what) eq "HASH" && defined $$what{obj_id}) {
$amount = money($what);
} elsif($what !~ /^\s*\-{0,1}(\d+)\s*$/) {
$amount = conf("$what");
} else {
$amount = $what;
}
if($amount == 1) {
return $amount . " " . conf("money_name_singular");
} else {
return $amount . " " . conf("money_name_plural");
}
}
sub code
{
my $type = shift;
my @stack;
return "N/A" if(!module_enabled("carp"));
my $prev = @info{source_prev};
if(!$type || $type eq "short") {
for my $line (split(/\n/,Carp::shortmess)) {
if($line =~ / at ([^ ]+) line (\d+)/) {
my ($fun,$ln) = ($1,$2);
if(defined $$prev{$fun}) {
push(@stack,@{$$prev{$fun}}{ln} + $2);
} else {
push(@stack,"$ln*");
}
}
}
return join(',',@stack);
} else {
return renumber_code(Carp::shortmess);
}
}
#
# renumber_code
# When code is reloaded, only the changed subroutines are reloaded
# and one by one. This cuts down the re-load time significantly.
# The downfall of this is that line numbers returned by shortmess()
# will be reset to 1 at the start of every subroutine. Line numbers
# directly from shortmess() are now worthless. To get around this
# problem, the starting line number of each subroutinue is recorded
# and added to the line number of the subroutine returned by shortmess().
# This will usually cause the line numbers to be correct as long as
# shortmess() is properly parsed.
#
sub renumber_code
{
my @out;
my $prev = @info{source_prev};
for my $line (split(/\n/,shift)) {
if(!@info{shell} &&
$line =~ / at ([^ ]+) line (\d+)/ &&
defined $$prev{$1}){
push(@out,"$` at $1 line " . ($2 + @{$$prev{$1}}{ln}));
} else {
push(@out,$line . " [*]");
}
}
return join("\n",@out);
}
#
# gender
# Handle gender pronouns. Peek at the currently running $prog
# to determine the gender of the thing invoking the command.
# Then use the $male, $female, or $it version that is passed
# in based upon that gender.
#
sub gender
{
my ($prog,$case,$male,$female,$it,$other) = @_;
my ($atr, $result);
$result = $it; # default to it
if(defined $$prog{cmd} && defined $$prog{cmd}->{invoker}) {
$atr = get($$prog{cmd}->{invoker},"sex");
if($atr =~ /(female|girl|woman|lady|dame|chick|gal|bimbo|ms|mrs|miss)/i) {
$result = $female;
} elsif($atr =~ /(male|boy|garson|gent|father|mr|man|sir|son|brother)/i) {
$result = $male;
} elsif($atr =~ /(plural|enby|fluid|mx)/i) {
$result = $other
}
}
# does the result need to be first character uppercased?
return ($case =~ /[A-Z]/) ? ucfirst($result) : $result;
}
#
# evaluate
# Take a string and evaluate any functions, and mush variables
#
sub evaluate_substitutions
{
my ($self,$prog,$t) = (obj(shift),shift,shift);
my ($out,$seq,$debug);
my $orig = $t;
while($t =~ /(\\|%m[0-9]|%q[0-9a-z]|%i[0-9]|%[!psaobrtnk#0-9%]|%(v|w)[a-zA-Z]|%=<[^>]+>|%\{[a-zA-Z0-9\_#]+\}|\$[0-9]|##|#@)/i) {
($seq,$t)=($1,$'); # store variables
$out .= $`;
if($seq eq "\\") { # skip over next char
$out .= ansi_substr($t,0,1);
$t = ansi_substr($t,1,ansi_length($t));
} elsif($seq eq "%%") {
$out .= "\%";
} elsif($seq eq "##") {
if(!defined $$prog{iter_stack} || $#{$$prog{iter_stack}} == -1 ) {
$out .= "##";
} else {
$out .= @{@{$$prog{iter_stack}}[-1]}{val};
}
} elsif($seq eq "#@") {
if(!defined $$prog{iter_stack} || $#{$$prog{iter_stack}} == -1 ) {
$out .= "#@";
} else {
$out .= @{@{$$prog{iter_stack}}[-1]}{pos};
}
} elsif($seq eq "[") { # remove this later?
$out .= "[" if(ord(substr($`,-1)) == 27); # escape sequence?
# } elsif($seq eq "]") { # removed for compat
# printf("FOUND: ']'\n");
# # ignore
} elsif($seq eq "%b") { # space
$out .= " ";
} elsif($seq eq "%r") { # return
$out .= "\n";
} elsif($seq eq "%t") { # tab
$out .= "\t";
} elsif($seq eq "%!") { # tab
if(defined $$self{obj_id}) {
$out .= "#$$self{obj_id}";
}
} elsif(lc($seq) eq "%p") {
$out .= gender($prog,$seq,"his","her","its","their");
} elsif(lc($seq) eq "%s") {
$out .= gender($prog,$seq,"he","she","it","they");
} elsif(lc($seq) eq "%o") {
$out .= gender($prog,$seq,"him","her","it","them");
} elsif(lc($seq) eq "%a") {
$out .= gender($prog,$seq,"his","hers","its","theirs");
} elsif($seq eq "%#") { # current dbref
if(defined $$prog{cmd} && defined @{$$prog{cmd}}{invoker}) {
if(ref($$prog{cmd}->{invoker}) eq "HASH") {
$out .= "#" . $$prog{cmd}->{invoker}->{obj_id};
} else {
$out .= "#" . $$prog{cmd}->{invoker};
}
} else {
$out .= "#" . $$self{obj_id};
}
} elsif(lc($seq) eq "%n" || lc($seq) eq "%k") { # current name
if(!defined $$prog{cmd}) {
$out .= name($self,undef,$self,$prog);
} else {
$out .= name($$prog{cmd}->{invoker},undef,$self,$prog);
}
} elsif($seq =~ /^%q([0-9a-z])$/i) {
if(defined $$prog{var} && defined $$prog{var}->{"setq_" . lc($1)}) {
$out .= $$prog{var}->{"setq_" . lc($1)};
}
} elsif($seq =~ /^\$([0-9])$/i) {
if(defined $$prog{reg} && defined $$prog{reg}->{$1}) {
$out .= $$prog{reg}->{$1};
} else {
$out .= $seq;
}
} elsif($seq =~ /^%m([0-9])$/ ||
$seq =~ /^%\{m([0-9])\}$/) {
if(defined $$prog{cmd} &&
defined @{$$prog{cmd}}{mdigits}) {
$out .= @{@{$$prog{cmd}}{mdigits}}{$1};
}
} elsif($seq =~ /^%i([0-9])$/) {
if(defined $$prog{iter_stack}) {
$out .= fun_itext($self,$prog,$1);
}
} elsif($seq =~ /^%([0-9])$/ || $seq =~ /^%\{([^}]+)\}$/) { # temp vars
if($1 eq "hostname") {
$out .= $$user{raw_hostname};
} elsif($1 eq "##") {
if(defined $$prog{iter_stack} && $#{$$prog{iter_stack}} != -1 ) {
my $var = @{@{$$prog{iter_stack}}[-1]}{val};
$out .= @{$$prog{var}}{$var} if(defined $$prog{var});
}
} elsif($1 eq "socket") {
$out .= $$user{raw_socket};
} else {
$out .= @{$$prog{var}}{$1} if(defined $$prog{var});
}
} elsif($seq =~ /^%((v|w)[a-zA-Z])$/ || $seq =~ /^%=<([^>]+)>$/) {
$out .= get($user,$1);
}
}
return $out . $t;
}
#
# controls
# Does the $enactor control the $target?
#
sub controls
{
my ($enactor,$target,$flag) = (obj(shift),obj(shift),shift);
if(hasflag($enactor,"GOD")) { # gods control everything
return 1;
} elsif(hasflag($target,"GOD") && !hasflag($enactor,"GOD")) {
return 0; # nothing can modify a god, but a god
} elsif(hasflag($enactor,"WIZARD")) {
return 1; # wizards can modify everything but a god
} elsif(owner_id($enactor) == owner_id($target)) {
return 1; # you can modify your own stuff
} else {
return 0;
}
}
#
# controls
# Does the $enactor control the $target?
#
sub readonly
{
my ($enactor,$target,$flag) = (obj(shift),obj(shift),shift);
if(hasflag($enactor,"GOD")) { # gods control everything
return 1;
} elsif(owner($target) == 0) {
return 0;
} elsif(hasflag($enactor,"WIZARD")) {
return 1; # wizards can modify everything but a god
} elsif(owner_id($enactor) == owner_id($target)) {
return 1; # you can modify your own stuff
} else {
return 0;
}
}
sub handle_object_listener
{
my ($target,$txt,@args) = @_;
my $parent = get($target,"obj_parent");
return if handle_socket_listener($target,$target,$txt,@args);
if($parent ne undef) { # handle parent
$parent = obj($parent);
if(valid_dbref($parent)) {
return if handle_socket_listener($parent,$target,$txt,@args);
}
}
}
sub handle_socket_listener
{
my ($src,$target,$txt,@args) = @_;
my $msg = ansi_remove(sprintf($txt,@args));
$msg =~ s/(%|\\)/\\$1/g;
for my $hash (sort {length(@{$b}{atr_regexp}) <=>
length(@{$a}{atr_regexp})} latr_regexp($src,3)) {
if($msg =~ /$$hash{atr_regexp}/i) {
mushrun(self => $target,
runas => $target,
cmd => single_line($$hash{atr_value}),
wild => [$1,$2,$3,$4,$5,$6,$7,$8,$9],
source => 0,
invoker=> $target,
from => "ATTR",
attr => $hash,
);
return 1;
}
}
return 0;
}
sub handle_directed_listen
{
my ($self,$prog,$target,$msg) = (obj(shift),shift,obj(shift),shift);
if($$target{obj_id} == $$self{obj_id} ||
!hasflag($target,"LISTENER")) {
return;
}
for my $hash (sort {length(@{$b}{atr_regexp}) <=>
length(@{$a}{atr_regexp})} latr_regexp($target,2)) {
# for my $hash (latr_regexp($target,2)) {
if(atr_case($target,$$hash{atr_name})) {
$$hash{atr_regexp} =~ s/^\(\?msix/\(\?msx/; # make case sensitive
if($msg =~ /$$hash{atr_regexp}/) {
mushrun(self => $self,
runas => $target,
cmd => single_line($$hash{atr_value}),
wild => [$1,$2,$3,$4,$5,$6,$7,$8,$9],
source => 0,
attr => $hash,
invoker=> $self,
from => "ATTR",
ppid => $$prog{pid}
);
return;
}
} elsif($msg =~ /$$hash{atr_regexp}/i) {
mushrun(self => $self,
runas => $target,
invoker=> $self,
cmd => single_line($$hash{atr_value}),
wild => [$1,$2,$3,$4,$5,$6,$7,$8,$9],
source => 0,
attr => $hash,
from => "ATTR",
ppid => $$prog{pid}
);
return;
}
}
}
sub handle_listener
{
my ($self,$prog,$runas,$txt,@args) = @_;
my $match = 0;
my $msg = sprintf($txt,@args);
for my $obj (lcon(loc($self))) {
# don't listen to one self, or doesn't have listener flag
next if($$obj{obj_id} eq $$self{obj_id} || !hasflag($obj,"LISTENER"));
for my $hash (sort {length(@{$b}{atr_regexp}) <=>
length(@{$a}{atr_regexp})} latr_regexp($obj,2)) {
if(atr_case($obj,$$hash{atr_name})) {
$$hash{atr_regexp} =~ s/^\(\?msix/\(\?msx/; # make case sensitive
if($msg =~ /$$hash{atr_regexp}/) {
mushrun(self => $self,
runas => $obj,
cmd => single_line($$hash{atr_value}),
wild => [$1,$2,$3,$4,$5,$6,$7,$8,$9],
source => 0,
attr => $hash,
invoker=> $self,
from => "ATTR"
);
$match=1;
return 1;
}
} elsif($msg =~ /$$hash{atr_regexp}/i) {
mushrun(self => $self,
runas => $obj,
invoker=> $self,
cmd => single_line($$hash{atr_value}),
wild => [$1,$2,$3,$4,$5,$6,$7,$8,$9],
source => 0,
attr => $hash,
from => "ATTR"
);
$match=1;
return 1;
}
}
}
return $match;
}
sub nospoof
{
my ($self,$prog,$dest) = (obj($_[0]),obj($_[1]),obj($_[2]));
if(hasflag($dest,"NOSPOOF")) {
# printf("%s\n",code("long"));
return "[" . obj_name($self,$$prog{created_by},1) . "] ";
}
return undef;
}
sub ts
{
my $time = shift;
$time = time() if $time eq undef;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime($time);
$mon++;
return sprintf("%02d:%02d@%02d/%02d",$hour,$min,$mon,$mday);
}
sub ts_date
{
my $time = shift;
$time = time() if $time eq undef;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime($time);
$mon++;
return sprintf("%02d/%02d/%02d",$mon,$mday,$year % 100);
}
sub minits
{
my $time = shift;
$time = time() if $time eq undef;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime($time);
$mon++;
return sprintf("%02d:%02d:%02d %02d/%02d/%02d",
$hour,$min,$sec,$mon,$mday,$year % 100);
}
sub filter_chars
{
my $txt = shift;
$txt .= "\n" if($txt !~ /\n$/); # add return if none exists
$txt =~ s/\n/\r\n/g if($txt !~ /\r/); # add linefeeds
$txt =~ tr/\x80-\xFF//d; # strip control chars
return $txt;
}
sub logit
{
my ($type,$fmt,@args) = @_;
my ($msg,$fd,$fn);
# add newline if needed except when the fmt starts with a escape code
$fmt .= "\n" if(substr($fmt,0,1) ne chr(27) && $fmt !~ /\n$/);
$fd = @info{"$type.fd"} if defined @info{"$type\.fd"}; # get existing fd
# do not log requests
return if(conf("$type") =~ /^\s*nolog\s*$/i);
# printf("$fmt", @args);
# open log as needed if not using console
if($type eq "weblog") {
$fn = "teenymush.web.log";
} elsif($type eq "auditlog") {
$fn = "teenymush.audit.log";
} else {
$fn = "teenymush.log";
}
if(conf($type) !~ /^\s*console\s*$/i &&
(!-e $fn || !defined @info{"$type\.fd"})) {
if(open($fd,">> $fn")) {
$fd->autoflush(1);
@info{"$type\.fd"} = $fd;
} else {
$fd = undef;
}
}
if($type eq "conlog") {
# if($fd eq undef || !defined @info{initial_load_done}) { # console
printf($fmt, @args);
}
my $txt = sprintf("$fmt",@args);
# $txt =~ s/[^[::ascii::]]//g;
printf($fd "%s", ansi_remove($txt)) if($fd ne undef);
}
sub web
{
return if(@info{shell}); # less verbose in shell mode
logit("weblog",@_) if(conf_true("weblog"));
}
sub con
{
return if(@info{shell}); # less verbose in shell mode
logit("conlog",@_) if(conf_true("conlog"));
}
sub audit
{
my ($self,$prog,$fmt,@args) = @_;
return if(!conf_true("auditlog"));
return if(@info{shell}); # less verbose in shell mode
my $info = sprintf("[%s] $fmt by " . obj_name($self,$self),ts(),@args);
# add actual command issued
if(defined $$prog{created_by} &&
defined $$prog{created_by}->{last} &&
defined $$prog{created_by}->{last}->{cmd}) {
$info .= ", cmd: '" . $$prog{created_by}->{last}->{cmd} . "'";
} elsif(defined $$prog{user} &&
defined $$prog{user}->{last} &&
defined $$prog{user}->{last}->{cmd}) {
$info .= ", cmd: '" . $$prog{user}->{last}->{cmd} . "'";
}
# add hostname / ip information
if(defined $$prog{created_by} &&
defined $$prog{created_by}->{hostname}) {
$info .= ", Host: " . $$prog{created_by}->{hostname};
} elsif(defined $$prog{created_by} &&
defined $$prog{created_by}->{ip}) {
$info .= ", Host: " . $$prog{created_by}->{ip};
} elsif(defined $$prog{user} &&
defined $$prog{user}->{hostname}) {
$info .= ", Host: '" . $$prog{user}->{hostname};
} elsif(defined $$prog{user} &&
defined $$prog{user}->{ip}) {
$info .= ", Host: '" . $$prog{user}->{ip};
}
logit("auditlog","%s",$info);
}
sub echo_socket
{
my ($obj,$prog,$fmt,@args) = (obj(shift),shift,shift,@_);
my $msg = sprintf($fmt,@args);
$msg = ansi_remove($msg) if !hasflag($obj,"ANSI");
if(defined $$obj{sock} && (!defined $$obj{raw} || $$obj{raw} == 0)) {
if(defined @connected{$$obj{sock}} &&
@connected{$$obj{sock}}->{type} eq "WEBSOCKET") {
ws_echo($$obj{sock},$msg);
} else {
my $s = $$obj{sock};
printf($s "%s",$msg);
}
} elsif(defined @connected_user{$$obj{obj_id}}) { # connected player
# manually inputed going to creator of comand, direct to socket
if(defined $$prog{created_by} &&
defined $$prog{cmd}->{source} &&
defined $$prog{created_by}->{sock} && # have socket
$$obj{obj_id} == $$prog{created_by}->{obj_id} && # going to invoker
$$prog{cmd}->{source} == 1 && # manually inputed
!defined $$prog{always}) { # to all sockets override
if(defined @connected{$$prog{created_by}->{sock}} &&
@connected{$$prog{created_by}->{sock}}->{type} eq "WEBSOCKET") {
ws_echo($$prog{created_by}->{sock},ansi_remove($msg));
} else {
my $s = $$prog{created_by}->{sock};
printf($s "%s", $msg);
}
} else { # fall back to "indirect" to socket
my $list = @connected_user{$$obj{obj_id}};
for my $socket (keys %$list) {
my $s = $$list{$socket};
if(defined @connected{$s} &&
@connected{$s}->{type} eq "WEBSOCKET"){
ws_echo($s,$msg);
} else {
printf($s "%s",$msg);
}
}
}
} elsif(hasflag($obj,"PUPPET") && !hasflag($obj,"PLAYER")) { # puppet
my $owner = owner($obj); # output
if(defined @connected_user{$$owner{obj_id}}) {
my $list = @connected_user{$$owner{obj_id}};
for my $socket (keys %$list) {
my $s = $$list{$socket};
if(@{@connected{$s}}{type} eq "WEBSOCKET") {
ws_echo($s,name($obj) . "> " .$msg);
} else {
printf($s "%s> %s",name($obj),$msg);
}
}
}
}
}
sub necho_shell
{
my ($self,$arg) = @_;
my $type;
if(defined $$arg{"source"}) {
$type = "source";
unshift(@{$$arg{source}},$self);
} elsif(defined $$arg{"target"}) {
$type = "target";
}
my ($target,$fmt) = (obj(shift(@{$$arg{$type}})), shift(@{$$arg{$type}}));
return if $$target{obj_id} != 0;
my $msg = filter_chars(sprintf($fmt,@{$$arg{$type}}));
printf("%s\n",$msg);
}
sub necho
{
my %arg = @_;
my $prog = $arg{prog};
my $self = obj($arg{self});
my $loc;
my $always;
return necho_shell($self,\%arg) if(@info{shell});
if(defined $$prog{always}) {
$always = $$prog{always};
}
$$prog{always} = $arg{always} if defined $arg{always};
# if($arg{self} eq undef) {
# con("%s\n",print_var(\%arg));
# con("%s\n",code("long"));
# }
if(loggedin($self)) {
# skip checks for non-connected players
} elsif(!defined $arg{self}) { # checked passed in arguments
err($self,$prog,"Echo expects a self argument passed in");
} elsif(!defined $arg{prog}) {
err($self,$prog,"Echo expects a prog argument passed in");
} elsif(defined $arg{room}) {
if(ref($arg{room}) ne "ARRAY") {
err($self,$prog,"Echo expects a room argument expects array data");
} elsif(ref(@{$arg{room}}[0]) ne "HASH") {
err($self,$prog,"Echo expects first room argument to be HASH " .
"data '%s'",@{$arg{room}}[0]);
}
}
for my $type ("room", "room2","all_room","all_room2") { # handle room echos
if(defined $arg{$type}) {
my $array = $arg{$type};
my $target = obj(shift(@$array));
my $fmt = shift(@$array);
my $msg = filter_chars(sprintf($fmt,@{$arg{$type}}));
$target = loc($target) if(!hasflag($target,"ROOM"));
if($target ne undef) {
for my $obj ( lcon($target) ) {
if($$self{obj_id} != $$obj{obj_id} || $type =~ /^all_/) {
echo_socket($obj,
@arg{prog},
"%s%s",
nospoof($self,$prog,$obj),
$msg
);
}
}
}
handle_listener($self,$prog,$target,$fmt,@$array);
}
}
if(defined $arg{"source"}) {
unshift(@{$arg{source}},$self);
# if(defined $$prog{created_by}) {
# unshift(@{$arg{source}},$$prog{created_by});
# } else {
# unshift(@{$arg{source}},$self);
# }
}
for my $type ("source", "target") {
next if !defined $arg{$type};
if(ref($arg{$type}) ne "ARRAY") {
if($always eq undef) {
delete $$prog{always};
} else {
$$prog{always} = $always;
}
return err($self,$prog,"Argument $type is not an array");
}
my ($target,$fmt) = (obj(shift(@{$arg{$type}})), shift(@{$arg{$type}}));
my $msg = filter_chars(sprintf($fmt,@{$arg{$type}}));
handle_directed_listen($self,$prog,$target,$msg);
# output needs to be saved for use by http, websocket, or run()
if(defined $$prog{output}) {
my $stack = $$prog{output};
if(@{obj($$prog{created_by})}{obj_id} == $$target{obj_id} ||
(defined $$prog{capture} &&
$$target{obj_id} == @{@{$$prog{capture}}{self}}{obj_id}) ||
@{obj($$prog{created_by})}{obj_id} == loc($target)) {
if(defined $$prog{capture}) {
my $h = $$prog{capture};
if($$h{type} eq "all" ||
($$h{type} eq "pemit" &&
defined $$prog{cmd} &&
defined @{$$prog{cmd}}{cmd} &&
lc(@{$$prog{cmd}}{mushcmd}) eq "\@pemit"
)
) {
push(@$stack,$msg);
@$stack[$#$stack] =~ s/\n+$//;
# printf("ADD: '%s' - '%s'\n",$msg,$#{$$prog{output}});
next;
} else {
# printf("CMD: '%s'\n",lc(@{$$prog{cmd}}{mushcmd}));
# printf("SKIP1: '%s'\n",$msg);
}
} else {
push(@$stack,$msg);
next;
}
} else {
# printf("WHO: '%s' -> '%s' -> '%s'\n",
# @{$$prog{created_by}}{obj_id},
# $$target{obj_id},
# $$self{obj_id});
# printf("%s\n",print_var($prog));
# printf("SKIP2: '%s'\n",$msg);
}
}
if(!loggedin($target) &&
!defined $$target{port} &&
!defined $$target{hostname} && defined $$target{sock}) {
my $s = @{$connected{$$self{sock}}}{sock};
# this might crash if the websocket dies, the evals should
# probably be removed once this is more stable. With that in mind,
# currently crash will be treated as a disconnect.
if(defined @connected{$s} &&
@{@connected{$s}}{type} eq "WEBSOCKET") {
ws_echo($s,$msg);
} elsif(defined @connected{$s}) {
printf($s "%s",$msg);
}
} elsif(!loggedin($target)) {
echo_socket($target,
@arg{prog},
"%s",
$msg
);
} else {
echo_socket($$target{obj_id},
@arg{prog},
"%s%s",
nospoof(@arg{self},@arg{prog},$$target{obj_id}),
$msg
);
}
}
if($always eq undef) {
delete $$prog{always};
} else {
$$prog{always} = $always;
}
}
sub echo_flag
{
my ($self,$prog,$flags,$fmt,@args) = @_;
my $echo;
for my $key (keys %connected) {
if(defined @connected{$key}->{obj_id}) {
$echo = 1;
for my $flag (split(/,/,$flags)) {
if(!hasflag(@connected{$key},$flag)) {
$echo = 0;
last;
}
}
next if !$echo;
my $msg = sprintf($fmt,@args);
if(defined @connected{$key}->{type} &&
@connected{$key}->{type} eq "WEBSOCKET") {
ws_echo(@connected{$key}->{sock},ansi_remove($msg));
} else {
my $s = @connected{$key}->{sock};
printf($s "%s\n", $msg);
}
}
}
}
sub connected_user
{
my $target = shift;
if(!defined @connected_user{$$target{obj_id}}) {
return undef;
}
my $hash = @connected_user{$$target{obj_id}};
for my $key (keys %$hash) {
if($key eq $$target{sock}) {
return $key;
}
}
return undef;
}
sub loggedin
{
my $target = obj(shift);
if(defined $$target{obj_id} &&
defined @connected_user{$$target{obj_id}}) {
return 1;
} else {
return 0;
}
}
sub valid_dbref
{
my ($id,$no_check_bad) = (shift,shift);
$id = { obj_id => $id } if(ref($id) ne "HASH");
$$id{obj_id} =~ s/#//g;
if($$id{obj_id} =~ /^\s*(\d+)\s*$/) {
if(!$no_check_bad && bad_object($1)) {
return 0;
} elsif(defined @info{backup_mode} && @info{backup_mode}) {
if(defined @deleted{$1}) {
return 0;
} elsif(defined @db[$1] || @delta[$1]) {
return 1;
} else {
return 0;
}
} elsif(defined @db[$1]) {
return 1;
} else {
return 0;
}
} else {
return 0;
}
}
sub owner_id
{
my $object = obj(shift);
my $owner = owner($object);
return $owner if $owner eq undef;
return $$owner{obj_id};
}
#
# set_flag
# Add a flag to an object. Verify that the object does not already have
# the flag first.
#
sub set_flag
{
my ($self,$prog,$obj,$flag,$override) =
(obj($_[0]),$_[1],obj($_[2]),trim(uc($_[3])),$_[4]);
my $who = $$user{obj_name};;
my ($remove,$count);
if(!$override && !controls($user,$obj)) {
return err($self,$prog,"#-1 PERMission denied.");
}
if(!is_flag($flag)) {
return "I don't understand that flag. '$flag'" . code();
}
if($flag =~ /^\s*!\s*/) {
$remove = 1;
$flag = trim($');
}
if(!$override && !can_set_flag($self,$obj,$flag)) {
return "Permission DeNied";
} elsif($remove) { # remove, don't check if set or not
if(($flag eq "WIZARD" || $flag eq "GOD") && hasflag($obj,$flag)) {
audit($self,$prog,"%s set !%s",obj_name($obj,$obj),$flag);
}
db_remove_list($obj,"obj_flag",$flag); # to mimic original mush
return "Cleared.";
} else {
if(($flag eq "WIZARD" || $flag eq "GOD") && !hasflag($obj,$flag)) {
audit($self,$prog,"%s set %s",obj_name($obj,$obj),$flag);
}
db_set_list($obj,"obj_flag",$flag);
return "Set.";
}
}
#
# set_atr_flag
# Add a flag to an object. Verify that the object does not already have
# the flag first.
#
sub set_atr_flag
{
my ($object,$atr,$flag,$override,$switch) =
(obj(shift),shift,shift,shift,shift);
my $who = $$user{obj_name};
my ($remove,$count);
$flag = uc(trim($flag));
$atr = "obj_$atr" if reserved($atr);
if($flag =~ /^\s*!\s*(.+?)\s*$/) {
($remove,$flag) = (1,$1);
}
if(!$override && !can_set_flag($object,$object,$flag)) {
return "#-1 Permission Denied.";
} elsif(!db_attr_exist($object,$atr)) {
return "#-1 UNKNOWN ATTRIBUTE ($atr).";
} else {
db_set_flag($$object{obj_id},$atr,lc($flag),$remove ? undef : 1);
return "Set." if(!defined $$switch{quiet});
}
}
sub first_room
{
my $skip = shift;
for my $i (0 .. $#db) { # ick, pick first room
return $i if($skip != $i && valid_dbref($i) && hasflag($i,"ROOM"));
}
return undef;
}
#
# destroy_object
# Delete an object from the database and cache. This is not for deleting
# players.
#
sub destroy_object
{
my ($self,$prog,$target) = (obj(shift),shift,obj(shift));
my $loc = loc($target);
my $owner = owner($target);
for my $exit (lexits($target)) { # destroy all exits
if(valid_dbref($exit)) {
give_money($owner,money($exit,1)); # refund money
set_quota($owner,"add"); # refund quota
db_delete($exit);
}
}
for my $obj (lcon($target)) { # move objects out of the way
my $home = home($obj);
necho(self => $self,
prog => $prog,
target => [ $obj, "The room shakes and begins to crumble." ],
room => [ $obj, "%s has left.", name($obj) ]
);
# default to first room if home can't be determined.
if($home eq undef || $home == $$target{obj_id}) {
$home = first_room($$obj{obj_id});
}
set_home($self,$prog,$obj,$home);
teleport($self,$prog,$obj,$home);
cmd_look($obj,prog($obj,$obj,$obj),undef,undef,1);
}
if(!hasflag($target,"ROOM")) {
my $loc = loc($target); # remove from location
db_remove_list($loc,"obj_content",$$target{obj_id});
db_remove_list($loc,"obj_exits",$$target{obj_id});
necho(self => $self,
prog => $prog,
all_room => [ $target, "%s was destroyed.", name($target) ],
all_room2 => [ $target, "%s has left.", name($target) ]
);
}
push(@free,$$target{obj_id});
if(valid_dbref($$owner{obj_id})) { # shouldn't happen
give_money($owner,money($target,1)); # refund money
set_quota($owner,"add"); # refund quota
}
db_delete($target);
return 1;
}
sub create_object
{
my ($self,$prog,$name,$pass,$type,$flag) = @_;
my ($where,$id);
my $who = $$user{obj_name};
my $owner = $$user{obj_id};
# check quota
if(!$flag && !or_flag($self,"WIZARD","GOD") &&
$type ne "PLAYER" && quota($owner,"left") <= 0) {
return 0;
}
if($type eq "PLAYER") {
$where = get(0,"CONF.STARTING_ROOM");
$where =~ s/^\s*#//;
$who = $$user{hostname};
$owner = 0;
} elsif($type eq "OBJECT") {
$where = $$self{obj_id};
} elsif($type eq "ROOM") {
$where = -1;
} elsif($type eq "EXIT") {
$where = -1;
}
my $id = get_next_dbref();
db_delete($id);
db_set($id,"obj_name",$name);
db_set($id,"obj_created_by",$$user{hostname});
if($pass ne undef && $type eq "PLAYER") {
db_set($id,"obj_password",mushhash($pass));
}
my $out = set_flag($self,$prog,$id,$type,1);
set_flag($self,$prog,$id,"NO_COMMAND",1);
if($out =~ /^#-1 /) {
necho(self => $self,
prog => $prog,
source => [ "%s", $out ]
);
db_delete($id);
push(@free,$id);
return undef;
}
if($type eq "PLAYER") {
db_set($id,"obj_lock_default","#" . $id);
db_set($id,"obj_lock_enter","#" . $id);
db_set($id,"obj_home",$where);
db_set($id,"obj_money",conf("starting_money"));
db_set($id,"obj_firstsite",$where);
db_set($id,"obj_quota",nvl(conf("starting_quota"),0) . ",0");
@player{trim(ansi_remove(lc($name)))} = $id;
} else {
db_set($id,"obj_home",$$self{obj_id});
db_set($id,"obj_lock_default","#" . $id);
db_set($id,"obj_lock_enter","#" . $id);
}
db_set($id,"obj_owner",$owner);
db_set($id,"obj_created_date",scalar localtime());
# #0 was just created, don't move it around
if($id != 0 && ($type eq "PLAYER" || $type eq "OBJECT")) {
teleport($self,$prog,$id,$where);
}
return $id;
}
#
# ignoreit
# Ignore certain hash key entries at all depths or just the specified
# depth.
#
sub ignoreit
{
my ($skip,$key,$depth) = @_;
if(!defined $$skip{$key}) {
return 0;
} elsif($$skip{$key} < 0 || ($$skip{$key} >= 0 && $$skip{$key} == $depth)) {
return 1;
} else {
return 0;
}
}
#
# print_var
# Return a "text" printable version of a HASH / Array
#
sub print_var
{
my ($var,$depth,$name,$skip,$recursive) = @_;
my ($PL,$PR) = ('{','}');
my $out;
if($depth > 4) {
return (" " x ($depth * 2)) . " -> TO_BIG\n";
}
$depth = 0 if $depth eq "";
$out .= (" " x ($depth * 2)) . (($name eq undef) ? "UNDEFINED" : $name) .
" $PL\n" if(!$recursive);
$depth++;
for my $key (sort ((ref($var) eq "HASH") ? keys %$var : 0 .. $#$var)) {
my $data = (ref($var) eq "HASH") ? $$var{$key} : $$var[$key];
if((ref($data) eq "HASH" || ref($data) eq "ARRAY") &&
!ignoreit($skip,$key,$depth)) {
$out .= sprintf("%s%s $PL\n"," " x ($depth*2),$key);
$out .= print_var($data,$depth+1,$key,$skip,1);
$out .= sprintf("%s$PR\n"," " x ($depth*2));
} elsif(!ignoreit($skip,$key,$depth)) {
$out .= sprintf("%s%s = %s\n"," " x ($depth*2),$key,$data);
}
}
$out .= (" " x (($depth-1)*2)) . "$PR\n" if(!$recursive);
return $out;
}
sub inuse_player_name
{
my ($name,$self) = @_;
$name =~ s/^\s+|\s+$//g;
if($self ne undef && lc(trim($name)) eq lc(name($self,1))) {
return 0; # allow for changes in case
}
return defined @player{trim(ansi_remove(lc($name)))} ? 1 : 0;
}
#
# give_money
# Give money to a person. Objects can't have money, so its given to
# the object's owner.
#
sub give_money
{
my ($target,$amount,$flag) = (obj(shift),shift,shift);
$target = owner($target) if(!$flag);
# $money doesn't contain a number
return 0 if($amount !~ /^\s*\-{0,1}(\d+)\s*$/);
if($flag) {
db_set($target,"obj_money",$amount);
} else {
my $money = money($target);
db_set($target,"obj_money",$money + $amount);
}
return 1;
}
#
# set_used_quota
# Update how much quota has been used by $obj
#
sub good_atr_name
{
my ($attr,$flag) = @_;
if(reserved($attr) && !$flag) { # don't set that!
return 0;
} elsif($attr =~ /^\s*([#a-zA-Z0-9\_\-\.\/\\\+]+)\s*$/i) {
return 1;
} else {
return 0;
}
}
sub set
{
my ($self,$prog,$obj,$attribute,$value,$quiet,$override)=
(obj($_[0]),$_[1],obj($_[2]),lc($_[3]),$_[4],$_[5]);
my ($pat,$first,$type);
# don't strip leading spaces on multi line attributes
$value =~ s/^\s+//g if(!defined $$prog{multi});
if(!good_atr_name($attribute),$override) {
err($self,$prog,"Attribute name is bad, use the following characters: " .
"A-Z, 0-9, and _ : $attribute");
} elsif($value =~ /^\s*$/) { # delete attribute
db_set($obj,$attribute,undef);
if(!$quiet) {
necho(self => $self,
prog => $prog,
source => [ "Set." ]
);
}
} else { # set attribute
db_set($obj,$attribute,$value);
if(!$quiet) {
necho(self => $self,
prog => $prog,
source => [ "Set." ]
);
}
}
}
sub subget
{
my ($attr,$debug) = @_;
if(ref($attr) eq "HASH") {
if(defined $$attr{regexp}) {
return "$$attr{type}$$attr{glob}:$$attr{value}";
} else {
return $$attr{value};
}
}
}
#
# pget
# A get with a fall back to the parent
#
sub pget
{
my ($obj,$attribute,$flag) = @_;
my $attr = mget($obj,$attribute); # check object
return $attr if(ref($attr) eq "HASH" && $flag);
return subget($attr) if(ref($attr) eq "HASH");
my $parent = mget($obj,"obj_parent"); # look up parent
return undef if(ref($parent) ne "HASH" || !valid_dbref($$parent{value}));
return mget($$parent{value},$attribute) if $flag; # get attr from parent
return subget(mget($$parent{value},$attribute)); # get attr from parent
}
#
# module_enabled
# Unified way to determine if a module is availible / should be used.
#
sub module_enabled
{
my $mod = shift;
if(defined @info{$mod} && @info{$mod} == 1) {
return 1;
} else {
return 0;
}
}
#
# conf
# Grab a configuration option from off of "#0/conf.name" or the @default
# variable. Also strip any "#" from dbrefs.
#
sub conf
{
my $attr;
@info{conf} = {} if !defined @info{conf};
@info{conf}->{$_[0]} = 1; # auto store used config options
if($_[0] eq "version") {
return version();
} elsif(hasattr(obj(0),"conf.$_[0]")) {
$attr = get(obj(0),"conf." . $_[0]);
} elsif(defined @default{lc($_[0])}) { # use @defaults?
$attr = @default{lc($_[0])};
} else {
return undef;
}
if($attr =~ /^\s*#(\d+)\s*$/) { # return just the number of a dbref
return $1;
} else {
return $attr;
}
}
sub conf_true
{
return is_true(conf($_[0]));
}
sub get
{
my ($obj,$attribute,$flag) = (obj($_[0]),$_[1],$_[2]);
my $hash;
$attribute = "description" if(lc($attribute) eq "desc");
my $attr = subget(mget($obj,$attribute,$flag),$flag);
return $attr;
}
sub loc
{
my $loc = loc_obj($_[0]);
return ($loc eq undef) ? undef : $$loc{obj_id};
}
sub player
{
my $obj = shift;
return hasflag($obj,"PLAYER");
}
sub obj_name
{
my ($self,$obj,$flag,$noansi) = (obj(shift),shift,shift,shift);
if($obj eq undef) { # assume full name if not qualified
$obj = $self;
} else {
$obj = obj($obj); # convert to obj
}
if(controls($self,$obj) || $flag) {
return name($obj,$noansi) . "(#" . $$obj{obj_id} . flag_list($obj) . ")";
} else {
return name($obj,$noansi);
}
}
#
# date_split
# Segment up the seconds into somethign more readable then displaying
# some large number of seconds.
#
sub date_split
{
my $time = shift;
my (%result,$num);
# define how the date will be split up (i.e by month,day,..)
my %chart = ( 3600 * 24 * 30 => 'M',
3600 * 24 * 7 => 'w',
3600 * 24 => 'd',
3600 => 'h',
60 => 'm',
0 => 's',
);
# loop through the chart and split the dates up
for my $i (sort {$b <=> $a} keys %chart) {
if($i == 0) { # handle seconds/leftovers
@result{s} = ($time > 0) ? $time : 0;
if(!defined $result{max_val}) {
@result{max_val} = $result{s};
@result{max_abr} = $chart{$i};
}
} elsif($time > $i) { # remaining seconds is larger
$num = int($time / $i); # add it to the list
$time -= $num * $i;
@result{$chart{$i}} = $num;
if(!defined $result{max_val}) {
@result{max_val} = $num;
@result{max_abr} = $chart{$i};
}
} else {
@result{$chart{$i}} = 0; # fill in blanks
}
}
return \%result;
}
#
# teleport
# move an object from to a new location.
#
sub teleport
{
my ($self,$prog,$target,$dest,$type) =
(obj($_[0]),obj($_[1]),obj($_[2]),obj($_[3]),$_[4]);
my $loc = loc($target);
if($loc ne undef) {
db_set($loc,"OBJ_LAST_INHABITED",scalar localtime());
db_remove_list($loc,"obj_content",$$target{obj_id});
}
db_set($target,"OBJ_LAST_INHABITED",scalar localtime());
db_set($target,"obj_location",$$dest{obj_id});
db_set_list($dest,"obj_content",$$target{obj_id});
return 1;
}
sub obj
{
my $id = shift;
if(ref($id) eq "HASH") {
return $id;
} else {
$id =~ s/#//g;
if($id !~ /^\s*\d+\s*$/) {
con("ID: '%s' -> '%s'\n",$id,code());
croak();
}
return { obj_id => $id };
}
}
sub obj_nocheck
{
my $id = shift;
if(ref($id) eq "HASH") {
return $id;
} else {
return { obj_id => $id };
}
}
sub obj_import
{
my @result;
for my $i (0 .. $#_) {
if(ref($_[$i]) eq "HASH") {
push(@result,$_[$i]);
} else {
push(@result,{ obj_id => $_[$i] });
}
}
return (@result);
}
sub set_home
{
my ($self,$prog,$obj,$dest) = (obj(shift),obj(shift),obj(shift),obj(shift));
db_set($obj,"obj_home",$$dest{obj_id});
return 1;
}
sub link_exit
{
my ($self,$exit,$src,$dst) = obj_import(@_);
if($src ne undef && defined $$src{obj_id}) {
db_set_list($$src{obj_id},"obj_exits",$$exit{obj_id});
db_set($$exit{obj_id},"obj_location",$$src{obj_id});
}
if($dst ne undef && defined $$exit{obj_id}) {
db_set($$exit{obj_id},"obj_destination",$$dst{obj_id});
}
return 1;
}
sub lastsite
{
my $target = obj(shift);
my $attr = mget($target,"obj_lastsite");
if($attr eq undef) {
return undef;
} else {
my $list = $$attr{value};
my $last = (sort {$a <=> $b} keys %$list)[-1];
# printf("%s\n",print_var($$attr{value}));
# for my $key (keys %$list) {
# if($$list{$key} =~ /^(\d+),/) {
# printf("diff: '%s' - '%s' = '%s'\n",$1,$key,$1 - $key);
# }
# }
if($$list{$last} =~ /^\d+,\d+,(.*)$/) {
return $1;
} else {
delete @$list{$last};
return undef;
}
}
}
sub lasttime
{
my ($target,$flag) = (obj(shift),shift);
if(!hasflag($target,"PLAYER")) {
return undef;
} else {
my $attr = mget($target,"obj_lastsite");
if($attr eq undef) {
return undef;
} else {
my $list = $$attr{value};
if($flag) {
return (sort keys %$list)[-1];
} else {
return scalar localtime((sort keys %$list)[-1]);
}
}
}
}
sub firstsite
{
my $target = obj(shift);
if(!hasflag($target,"PLAYER")) {
return undef;
}
return get($target,"obj_created_by");
}
sub firsttime
{
my $target = obj(shift);
return scalar localtime(fuzzy(get($target,"obj_created_date")));
}
#
# fuzzy_secs
# Determine a date based upon what each word looks like.
#
sub fuzzy
{
my ($time) = @_;
my ($sec,$min,$hour,$day,$mon,$year);
my $AMPM = 1;
my %months = (
jan => 1, feb => 2, mar => 3, apr => 4, may => 5, jun => 6,
jul => 7, aug => 8, sep => 9, oct => 10, nov => 11, dec => 12,
);
my %days = (
mon => 1, tue => 2, wed => 3, thu => 4, fri => 5, sat => 6, sun => 7,
);
return $1 if($time =~ /^\s*(\d+)\s*$/);
for my $word (split(/\s+/,$time)) {
if($word =~ /^(\d+):(\d+):(\d+)$/) {
($hour,$min,$sec) = ($1,$2,$3);
} elsif($word =~ /^(\d+):(\d+)$/) {
($hour,$min) = ($1,$2);
} elsif($word =~ /^(\d{4})[\/\-](\d+)[\/\-](\d+)$/) {
($mon,$day,$year) = ($2,$3,$1);
} elsif($word =~ /^(\d+)[\/\-](\d+)[\/\-](\d+)$/) {
($mon,$day,$year) = ($1,$2,$3);
} elsif(defined @months{lc($word)}) {
$mon = @months{lc($word)};
} elsif($word =~ /^\d{4}$/) {
$year = $word;
} elsif($word =~ /^\d{1,2}$/ && $word < 31) {
$day = $word;
} elsif($word =~ /^(AM|PM)$/i) {
$AMPM = uc($1);
} elsif(defined @days{lc($word)}) {
# okay to ignore day of the week
} else {
# printf("Skipped: $word\n");
}
}
$year = (localtime())[5] if $year eq undef;
$day = 1 if $day eq undef;
if($AMPM eq "AM" || $AMPM eq "PM") { # handle am/pm hour
if($hour == 12 && $AMPM eq "AM") {
$hour = 0;
} elsif($hour == 12 && $AMPM eq "PM") {
# do nothing
} elsif($AMPM eq "PM") {
$hour += 12;
}
}
# don't go negative on which month it is, this will make
# timelocal assume its the current month.
if($mon eq undef) {
return timelocal($sec,$min,$hour,$day,$mon,$year);
} else {
return timelocal($sec,$min,$hour,$day,$mon-1,$year);
}
}
sub isatrflag
{
my $txt = shift;
$txt = $' if($txt =~ /^\s*!/);
return flag_attr(trim($txt));
}
sub is_flag
{
my $flag = shift;
$flag = trim($') if($flag =~ /^\s*!/);
return (flag_letter($flag) eq undef) ? 0 : 1;
}
sub lock_error
{
my ($hash,$err) = @_;
$$hash{errormsg} = $err;
$$hash{error} = 1;
$$hash{result} = 0;
$$hash{lock} = undef;
return $hash;
}
#
# do_lock_compare
#
# A lock item has been found, which means that there should be
# either a pending item and pending operand, or nothing at all.
# Do the compare if need or store the item for later.
#
sub do_lock_compare
{
my ($lock,$value) = @_;
#
# handle comparison
#
if($$lock{result} eq undef) { # first comp
$$lock{result} = $value;
} elsif($$lock{op} eq undef) { # second comp w/o op,err
lock_error($lock,"Expecting next item instead of operand");
} elsif($$lock{op} eq "&") { # have 2 operands with & op
delete @$lock{op};
if($value && $$lock{result}) {
$$lock{result} = 1; # success
} else {
$$lock{result} = 0; # fail
}
} elsif($$lock{op} eq "|") { # have 2 operands with | op
delete @$lock{op};
if($value || $$lock{result}) {
$$lock{result} = 1; # sucess
} else {
$$lock{result} = 0; # fail
}
}
}
#
# lock_item_eval
# Each item is a comparison against the object trying to pass throught the
# lock
#
sub lock_item_eval
{
my ($self,$prog,$obj,$lock,$item) = @_;
my ($not, $target,$result);
return if(defined $$lock{error} && $$lock{error}); # prev parse error
if($item =~ /^\s*([\|\&]{1})\s*$/) { # handle op
if(defined $$lock{op}) { # too many ops
return lock_error($lock,"Too many operators ($$lock{op} and $1)");
} else {
$$lock{op} = $1;
}
} elsif($item =~ /^\s*\((.*)\)\s*/) { # handle ()'s
$result = lock_eval($self,$prog,$obj,$1);
if($$result{error}) {
lock_error($lock,$$result{errormsg});
} else {
do_lock_compare($lock,$$result{result});
}
} elsif($item =~ /^\s*(!{0,1})\s*([^ ]+)\s*$/) { # handle item
$not = ($1 eq "!") ? 1 : 0;
$target = find($obj,$prog,$2);
if($target eq undef) { # verify item exists
return lock_error($lock,"Target($2) does not exist.");
} elsif(($not && $$target{obj_id} ne $$self{obj_id}) || # compare item
(!$not && $$target{obj_id} eq $$self{obj_id})) {
$result = 1; # success
} else {
$result = 0; # failure
}
do_lock_compare($lock,$result);
} else {
return lock_error($lock,"Invalid item '$item'"); # invalid item/op
}
return $lock;
}
#
# lock_eval
# This is the inital call to evaluating a lock.
#
sub lock_eval
{
my ($self,$prog,$obj,$txt) = @_;
my ($start,$depth) = (0,0);
my $lock = {};
my @list = split(/([\(\)&\|])/,$txt);
for my $i (0 .. $#list) {
if(@list[$i] eq "(") {
$depth++;
} elsif(@list[$i] eq ")") {
$depth--;
if($depth == 0) {
lock_item_eval($self,$prog,$obj,$lock,join('',@list[$start .. $i]));
$start = $i + 1;
}
} elsif($depth == 0 &&
( @list[$i] eq "&" ||
@list[$i] eq "|" ||
@list[$i] =~ /^\s*[^\(\)\s]/
)
) {
lock_item_eval($self,$prog,$obj,$lock,join('',@list[$start .. $i]));
$start = $i + 1;
}
}
return $lock;
}
#
# lock_item_compile
# Each item is a comparison against the object trying to pass throught the
# lock
#
sub lock_item_compile
{
my ($self,$prog,$obj,$lock,$item,$flag) = @_;
my ($not, $target,$result);
return if(defined $$lock{error} && $$lock{error}); # prev parse error
if($item =~ /^\s*([\|\&]{1})\s*$/) { # handle op
if(defined $$lock{op}) { # too many ops
return lock_error($lock,"Too many operators ($$lock{op} and $1)");
} else {
my $lock = $$lock{lock};
push(@$lock,$1);
}
} elsif($item =~ /^\s*\((.*)\)\s*$/) { # handle ()'s
my ($array,$txt) = ($$lock{lock},$1);
if($#$array >= 0 && @$array[$#$array] !~ /^\s*[\|\&]\s*$/) {
lock_error($lock,"Expected operand but found '$item'");
}
$result = lock_compile($self,$prog,$obj,$txt);
if($$result{error}) {
lock_error($lock,$$result{errormsg});
} else {
push(@$array,"(".$$result{lock}.")");
}
} elsif($item =~ /^\s*(!{0,1})\s*([^ ]+)\s*$/) { # handle item
my ($array,$not,$txt) = ($$lock{lock},$1,$2);
if($#$array >= 0 && @$array[$#$array] !~ /^\s*[\|\&]\s*$/) {
lock_error($lock,"Expected operand but found '$item'");
}
$target = find($obj,$prog,$txt);
if($target eq undef) { # verify item exists
return lock_error($lock,"Target($obj) does not exist");
} elsif($flag) {
push(@$array,"$not" . obj_name($self,$target));
} else {
push(@$array,"$not#$$target{obj_id}");
}
} else {
return lock_error($lock,"Invalid item '$item'"); # invalid item/op
}
return $$lock{result};
}
#
# lock_compile
# Convert a string into a lock of dbrefs to protect against player
# renames.
#
sub lock_compile
{
my ($self,$prog,$obj,$txt,$flag) = @_;
my ($start,$depth) = (0,0);
my $lock = {
lock => []
};
my @list = split(/([\(\)&\|])/,$txt);
for my $i (0 .. $#list) {
if(@list[$i] eq "(") {
$depth++;
} elsif(@list[$i] eq ")") {
$depth--;
if($depth == 0) {
lock_item_compile($self,
$prog,
$obj,
$lock,
join('',@list[$start .. $i]),
$flag
);
$start = $i + 1;
}
} elsif($depth == 0 &&
( @list[$i] eq "&" ||
@list[$i] eq "|" ||
@list[$i] =~ /^\s*[^\(\)\s]/
)
) {
lock_item_compile($self,
$prog,
$obj,
$lock,
join('',@list[$start .. $i]),
$flag);
$start = $i + 1;
}
}
if($$lock{error}) {
return $lock;
} else {
$$lock{lock} = join('',@{@$lock{lock}});
return $lock;
}
}
#
# lock_uncompile
# Alias for lock_compile but return object names instead of object
# dbrefs.
#
sub lock_uncompile
{
my ($self,$prog,$txt) = @_;
my $result = lock_compile($self,$prog,$self,$txt,1);
if($$result{error}) {
return "*UNLOCKED*";
} else {
return $$result{lock};
}
}
#
# add_last_info
#
# Add details about when a user last did something.
#
sub add_last_info
{
my $cmd = shift;
# create structure to hold last info if needed
$$user{last} = {} if(!defined $$user{last});
# populate last hash with the info
my $last = $$user{last};
$$last{time} = time();
$$last{cmd} = $cmd;
}
sub trim
{
my $txt = shift;
$txt =~ s/^ +| +$//g;
return $txt;
}
# ste_type
#
# -- 1 close connection as soon as possible
# -- 2 show banned.txt
# -- 3 registration
# -- 4 open
#
sub add_site_restriction
{
my $sock = shift;
$$sock{site_restriction} = 4;
}
#
# lookup_command
# Try to find a internal command, exit, or mush command to run.
#
sub lookup_command
{
my ($self,$hash,$cmd,$txt,$type,$debug) =
($_[0],$_[1],lc($_[2]),$_[3],$_[4],$_[5]);
my $match;
if(defined $$hash{$cmd}) { # match on internal cmd
return ($cmd,trim($txt));
} elsif(defined $$hash{substr($cmd,0,1)} && # one letter cmd
(defined @{$$hash{substr($cmd,0,1)}}{nsp} || # w/wo space after
substr($cmd,1,1) eq " " || # command
length($cmd) == 1
)
) {
return (substr($cmd,0,1),trim(substr($cmd,1) . $txt));
} else { # match on partial cmd name
return ('huh',trim($txt));
$txt =~ s/^\s+|\s+$//g;
for my $key (keys %$hash) { # find partial unique match
if(substr($key,0,length($cmd)) eq $cmd) {
if($match eq undef) {
$match = $key;
} else {
$match = undef;
last;
}
}
}
printf("FIND($cmd): '%s'\n",find_exit($self,{},conf("master"),$cmd));
if($match ne undef && lc($cmd) ne "q") { # found match
return ($match,trim($txt));
} elsif($$user{site_restriction} == 69) {
return ('huh',trim($txt));
} elsif($txt =~ /^\s*$/ && $type && find_exit($self,{},loc($self),$cmd)){
return ("go",$cmd); # exit
} elsif($txt =~ /^\s*$/ && $type &&
find_exit($self,{},conf("master"),$cmd)){ # master room exit
return ("go",$cmd);
} elsif(mush_command($self,$hash,trim($cmd . " " . $txt,1))) { #mush cmd
return ("\@\@",$cmd . " " . $txt);
} else { # no match
return ('huh',trim($txt));
}
}
}
sub add_telnet_data
{
my($sock,$txt) = @_;
my $prog = $$sock{prog};
$$prog{socket_buffer} = [] if(!defined $$prog{socket_buffer});
my $stack = $$prog{socket_buffer};
if(!defined $$prog{socket_buffer}) {
$$prog{socket_buffer} = [];
delete @info{socket_buffer};
}
@info{socket_buffer} .= (defined @info{socket_buffer} ? "\n" : "") . $txt;
if($$prog{socket_url}) {
$$prog{socket_count}++;
# if its a url() request, read the header and determine if there
# was an error or not.
if($$prog{socket_count} == 1 &&
$txt =~ /^HTTP\/[\d\.]+ (\d+)/ &&
$1 >= 500) {
push(@$stack,"#-1 PAgE LOAD FAILURE");
server_disconnect($$prog{socket_id});
}
}
push(@$stack,$txt);
}
#
# server_process_line
#
# A line of text has finally come in, see if its a valid command and
# run it. Commands differ for if the user is connected or not.
# This is also where some server crashes are detected.
#
sub server_process_line
{
my ($hash,$input) = @_;
# if($input !~ /^\s*$/) {
# con("#%s# '%s'\n",((defined $$hash{obj_id}) ? obj_name($hash) : "?"),
# $input);
# }
my $data = @connected{$$hash{sock}};
if(defined $$data{raw} && $$data{raw} == 1) {
$input =~ s/\r//mg;
handle_object_listener($data,"%s",$input);
} elsif(defined $$data{raw} && $$data{raw} == 2) {
$input =~ s/\r//mg;
add_telnet_data($data,$input);
} else {
eval { # catch errors
local $SIG{__DIE__} = sub {
con("----- [ Crash Report@ %s ]-----\n",scalar localtime());
con("User: %s\nCmd: %s\n",name($user),$_[0]);
con("%s",code("long"));
};
if($input =~ /^\s*([^ ]+)/ || $input =~ /^\s*$/) {
$user = $hash;
my ($in,$rest) = ($1,$');
if(loggedin($hash) ||
(defined $$hash{obj_id} && hasflag($hash,"OBJECT"))) {
add_last_info($input); #logit
return mushrun(self => $user,
runas => $user,
invoker=> $user,
source => 1,
cmd => $input,
);
} else {
if(conf("show_offline_cmd") && $input !~ /^\s*connect/i) {
my $ignore = conf("host_filter");
if($ignore eq undef ||
!inlist($$hash{hostname},split(/,/,$ignore))) {
con("[%s:%s] %s <Offline>\n",ts(),$$hash{hostname},$input);
}
}
my ($cmd,$arg) = lookup_command($data,\%offline,$in,$rest,0);
&{@offline{$cmd}}($hash,prog($user,$user),$arg); # invoke cmd
}
}
};
if($@) { # oops., you sunk my battle ship
my $msg;
if($_[1] =~ /^\s*connnect\s+/) {
$msg = sprintf("%s crashed the server with: connect blah blah",
name($hash),$_[1]);
} else {
$msg = sprintf("%s crashed the server with: %s",name($hash),$_[1]);
}
necho(self => $hash,
prog => prog($hash,$hash),
source => [ "%s",$msg ]
);
if($msg ne $$user{crash}) {
necho(self => $hash,
prog => prog($hash,$hash),
room => [ $hash, "%s",$msg ]
);
$$user{crash} = $msg;
}
delete @$hash{buf};
}
}
}
#
# server_hostname
# lookup the hostname based upon the ip address
#
sub server_hostname
{
my $sock = shift;
my $ip = $sock->peerhost; # contains ip address
my $name = gethostbyaddr(inet_aton($ip),AF_INET);
if($name =~ /^\s*$/ || $name =~ /in-addr\.arpa$/) {
return $ip; # last resort, return ip address
} else {
return $name; # return hostname
}
}
sub get_free_port
{
my ($i,%used);
my $max = (scalar keys %connected) + 2;
for my $key (keys %connected) {
my $hash = @connected{$key};
if(defined $$hash{port}) {
@used{$$hash{port}} = 1;
};
}
for($i=1;$i < $max;$i++) {
return $i if(!defined @used{$i});
}
return $i; # should never happen
}
#
# server_handle_sockets
# Open Handle all incoming I/O and try to sleep frequently enough
# so that all of the cpu is not being used up.
#
sub server_handle_sockets
{
if(!defined @info{server_start} || @info{server_start} =~ /^\s*$/) {
@info{server_start} = time();
}
eval {
local $SIG{__DIE__} = sub {
con("----- [ Crash Report@ %s ]-----\n",scalar localtime());
printf("User: %s\nCmd: %s\n",name($user),$_[0]);
con("%s",code("long"));
};
# wait for IO or 1 second
my ($sockets) = IO::Select->select($readable,undef,undef,.1);
my $buf;
# process any IO
foreach my $s (@$sockets) { # loop through active sockets [if any]
if($s == $web) { # new web connection
http_accept($s);
} elsif(defined @http{$s}) {
http_io($s);
} elsif($s == $websock || defined $ws->{conns}{$s}) {
websock_io($s);
} elsif($s == $listener) { # new mush connection
my $new = $listener->accept(); # accept it
if($new) { # valid connect
$readable->add($new); # add 2 watch list 4 input
my $hash = { sock => $new, # store connect details
hostname => server_hostname($new),
ip => $new->peerhost,
loggedin => 0,
raw => 0,
start => time(),
port => get_free_port(),
type => "MUSH",
last => { time => time(),
cmd => "connect"
}
};
add_site_restriction($hash);
@connected{$new} = $hash;
my $ignore = conf("host_filter");
if($ignore eq undef ||
!inlist($$hash{hostname},split(/,/,$ignore))) {
con("# Connect from: %s [%s]\n",$$hash{hostname},ts());
}
if($$hash{site_restriction} <= 2) { # banned
con(" BANNED [Booted]\n");
if($$hash{site_restriction} == 2) {
printf($new "%s",conf("badsite"));
}
server_disconnect(@{@connected{$new}}{sock});
} elsif(!defined conf("login")) {
printf($new "Welcome to %s\r\n\r\n",conf("version"));
} else {
my $obj = obj(0); # show login in readonly mode
my $prog = prog($obj,$obj,$obj);
$$prog{read_only} = 1;
printf($new "%s",
add_return(evaluate($obj,$prog,conf("login"))));
}
}
} elsif(sysread($s,$buf,1024) <= 0) { # socket disconnected
server_disconnect($s);
} else { # socket has input
@{@connected{$s}}{pending} = 1;
$buf =~ s/\r//g; # remove returns
# $buf =~ tr/\x80-\xFF//d;
# $buf =~ s/\e\[[\d;]*[a-zA-Z]//g;
@{@connected{$s}}{buf} .= $buf; # store input
# breakapart by line
while(defined @connected{$s} && @{@connected{$s}}{buf} =~ /\n/) {
@{@connected{$s}}{buf} = $'; # store left overs
server_process_line(@connected{$s},$`); # process line
# # store last transaction in @info{connected_raw_socket}
# if(defined @connected{$s} && @{@connected{$s}}{raw} > 0) {
# if(@info{connected_raw_socket} ne $s) {
# delete @info{connected_raw};
# @info{connected_raw_socket} = $s;
# }
# @info{connected_raw} .= $` . "\n";
# }
# if(!defined @connected{$s}) {
# printf("## no socket??? '$s'\n");
# } elsif(@{@connected{$s}}{raw} > 0) {
# my $tmp = $`;
# $tmp =~ s/\e\[[\d;]*[a-zA-Z]//g;
# printf("#%s# %s\n",@{@connected{$s}}{raw},$tmp);
# }
}
}
}
spin();
};
if($@){
con("Server Crashed, minimal details [main_loop]\n");
con("%s\n---[end]-------\n",$@);
}
}
#
# server_disconnect
# Either the user has QUIT or disconnected, so handle the disconnect
# approprately.
#
sub server_disconnect
{
my $id = shift;
my ($prog, $type);
calculate_login_stats();
# notify connected users of disconnect
if(defined @connected{$id}) {
my $hash = @connected{$id};
my $attr = mget(@connected{$id},"obj_lastsite");
if($attr ne undef && defined $$attr{value} &&
ref($$attr{value}) eq "HASH" && defined $$hash{connect}) {
my $last = $$attr{value};
my $ctime = $$hash{connect};
if(defined $$last{$ctime} && $$last{$ctime} =~ /,([^,]+)$/) {
db_set_hash(@connected{$id},
"obj_lastsite",
$ctime,
time() . ",1,$1"
);
}
}
if(defined @connected{$id} && defined @{@connected{$id}}{prog}) {
$prog = @{@connected{$id}}{prog};
} else {
$prog = prog($hash,$hash);
}
$type = @{@connected{$id}}{type};
# tell the running mushcode that the socket closed
if(defined $$hash{prog} && defined @{$$hash{prog}}{socket_id}) {
delete @{$$hash{prog}}{socket_id};
@{$$hash{prog}}{socket_closed} = 1;
}
if(defined $$hash{raw} && $$hash{raw} > 0) { # MUSH Socket
if($$hash{buf} !~ /^\s*$/) {
server_process_line($hash,$$hash{buf}); # process pending line
} # needed for www
necho(self => $hash,
prog => $prog,
"[ Connection closed ]"
);
} elsif(defined $$hash{connect_time}) { # Player Socket
my $key = connected_user($hash);
if(defined @connected_user{$$hash{obj_id}}) {
delete @{@connected_user{$$hash{obj_id}}}{$key};
if(scalar keys %{@connected_user{$$hash{obj_id}}} == 0) {
delete @connected_user{$$hash{obj_id}};
}
}
# necho(self => $hash,
# prog => $prog,
# room => [ $hash, "%s has disconnected.",name($hash) ]
# );
generic_action($hash,
$prog,
$hash,
"disconnect",
[ "has disconnected." ],
[ "" ]);
echo_flag($hash,$prog,"CONNECTED,PLAYER,MONITOR",
"[Monitor] %s has disconnected.",name($hash));
}
}
# remove user out of the loop
$readable->remove($id);
#
# closing the socket here on a websocket causes a crash later on.
# not closing it here doesn't seem to cause any problems.
# i.e. no orphaned connections in netstat.
#
if($type eq "WEBSOCKET" && defined @c{$id}) {
@c{$id}->disconnect();
delete @c{$id};
} else {
$id->close;
}
delete @connected{$id};
}
#
# server_start
#
# Start listening on the specified port for new connections.
#
sub server_start
{
my @port;
my @tried;
# my dev instant just needs a free port, so choose from a list
for my $p (split(/,/,conf("port"))) {
$listener = IO::Socket::INET->new(LocalPort => $p,
Listen => 1,
Reuse => 1
);
if($listener ne undef) {
push(@port,"$p\{Mush\}");
last;
} else {
push(@tried,$p);
}
}
die("Ports " . join(',',@tried) . " already in use.") if $listener eq undef;
# uri_escape is required for httpd
if(!module_enabled("uri_escape") && conf("httpd") > 0) {
con("httpd disabled because of missing URI::Escape module");
} elsif(module_enabled("uri_escape") && conf("httpd") > 0) {
if(conf("httpd") =~ /^\s*(\d+)\s*$/) {
push(@port,conf("httpd") . "{httpd}");
$web = IO::Socket::INET->new(LocalPort => conf("httpd"),
Listen =>1,
Reuse =>1
);
} else {
con("Invalid httpd port number specified in #0/conf.httpd");
}
}
if(module_enabled("websocket") && conf("websocket") > 0) {
if(conf("websocket") =~ /^\s*(\d+)\s*$/) {
push(@port,conf("websocket") . "{websocket}");
websock_init();
} else {
con("Invalid websocket port number specified in #0/conf.websocket");
}
}
@info{initial_load_done} = 1;
if($ws eq undef) { # emulate websocket listener
$ws = {}; # when not in use
$ws->{select_readable} = IO::Select->new();
}
$ws->{select_readable}->add($listener);
if(conf("httpd") ne undef) {
$ws->{select_readable}->add($web);
}
$readable = $ws->{select_readable};
printf(" + Listening on ports: %s\n",join(',',@port));
# main loop;
@info{run} = 1;
run_attr(0,{},0,"conf.startup");
if(!conf("safemode")) {
for my $obj (lcon(conf("master"))) { # handle astartup
my $atr;
if(hasflag($obj,"WIZARD") &&
($atr = get($obj,"ASTARTUP")) &&
$atr ne undef) {
mushrun(self => $obj,
runas => $obj,
invoker => $obj,
source => 0,
cmd => $atr
);
}
}
}
while(@info{run}) {
eval {
server_handle_sockets();
};
if($@){
con("Server Crashed, minimal details [main_loop]\n");
con("%s\n---[end]-------\n",$@);
}
}
}
sub websock_init
{
$websock = IO::Socket::INET->new( Listen => 5,
LocalPort => conf("websocket"),
Proto => 'tcp',
Domain => AF_INET,
ReuseAddr => 1,
)
or die "failed to set up TCP listener: $!";
$ws = Net::WebSocket::Server->new(
listen => $websock,
tick_period => 1,
on_connect => sub { my( $serv, $conn ) = @_;
$conn->on( ready => sub{ ws_login_screen(@_); },
utf8 => sub{ ws_process( @_, 0 );},
disconnect => sub { ws_disconnect(@_); },
);
},
);
$ws->{select_readable}->add($websock);
$ws->{conns} = {};
}
sub ws_disconnect
{
my ($conn, $code, $reason) = @_;
my $sock = $conn->{socket};
server_disconnect( $conn->{socket} );
$ws->{select_readable}->remove( $conn->{socket} );
delete $ws->{conns}{$sock};
}
sub add_return
{
if(@_[0] =~ /\n$/) {
return @_[0];
} else {
return @_[0] . "\r\n";
}
}
sub ws_login_screen
{
my $conn = shift;
# setup fake $prog variable
my $prog = prog(obj(0),obj(0),obj(0));
$$prog{read_only} = 1;
ws_echo($conn->{socket},add_return(evaluate(obj(0),$prog,conf("login"))));
}
#
# ws_echo
# The send might crash if the websocket has disconnected the evals should
# probably be removed once this is more stable. With that in mind,
# currently crash will be treated as a disconnect.
#
sub ws_echo
{
my ($s, $msg) = @_;
return if not defined @connected{$s};
my $conn = @{@connected{$s}}{conn};
# this might crash if the websocket dies, the evals should
# probably be removed once this is more stable. With that in mind,
# currently crash will be treated as a disconnect.
eval {
$conn->send('','t'.$msg);
};
if($@) {
ws_disconnect($conn);
}
}
sub websock_io
{
my $sock = shift;
if( $sock == $ws->{listen} ) {
my $sock = $ws->{listen}->accept;
my $conn = new Net::WebSocket::Server::Connection(
socket => $sock, server => $ws );
$ws->{conns}{$sock} = { conn => $conn,
lastrecv => time,
ip => server_hostname($sock)
};
$ws->{select_readable}->add( $sock );
$ws->{on_connect}($ws, $conn );
@c{$sock} = $conn;
# attach the socket to the mush data structure
my $hash = { sock => $sock, # store connect details
conn => $conn,
hostname => server_hostname($sock),
ip => $sock->peerhost,
loggedin => 0,
raw => 0,
start => time(),
port => get_free_port(),
type => "WEBSOCKET"
};
add_site_restriction($hash);
@connected{$sock} = $hash;
} elsif( $ws->{watch_readable}{$sock} ) {
$ws->{watch_readable}{$sock}{cb}( $ws , $sock );
} elsif( $ws->{conns}{$sock} ) {
my $connmeta = $ws->{conns}{$sock};
$connmeta->{lastrecv} = time;
$connmeta->{conn}->recv();
} else {
warn "filehandle $sock became readable, but no handler took " .
"responsibility for it; removing it";
$ws->{select_readable}->remove( $sock );
}
# if( $ws->{watch_writable}{$sock} ) {
# $ws->{watch_writable}{$sock}{cb}( $ws, $sock);
# } else {
# warn "filehandle $sock became writable, but no handler took ".
# "responsibility for it; removing it";
# $ws->{select_writable}->remove( $sock );
# }
}
#
# ws_process
# A message has come in via the websocket, hand it off to the MUSH
# via the server_proces_line() function. The websocket client sends
# a flag via the first character (text, html, and publeo, etc).
# Currently, that flag is just being stripped and ignored. Maybe
# later?
#
sub ws_process
{
my( $conn, $msg, $ssl ) = @_;
$msg =~ s/\r|\n//g;
$ssl = $ssl ? ',SSL' : '';
if($msg =~ /^#M# /) {
web(" %s %s\@ws [%s]\n",ts(),@{$ws->{conns}{$conn->{socket}}}{ip},$');
@{$ws->{conns}{$conn->{socket}}}{type} = "NON_INTERACTIVE";
my $self = conf("webuser");
my $prog = mushrun(self => $self,
runas => $self,
invoker=> $self,
source => 0,
cmd => $',
hint => "WEBSOCKET",
sock => $conn,
output => []
);
$$prog{sock} = $conn;
} else {
$msg = substr($msg,1);
web(" %s %s\@ws [%s]\n",ts(),@{$ws->{conns}{$conn->{socket}}}{ip},$msg);
server_process_line(@connected{$conn->{socket}},$msg);
}
}
sub websock_wall
{
my $txt = shift;
my $hash = $ws->{conns};
for my $key ( keys %$hash) {
my $client = $$hash{$key}->{conn};
if(@{$ws->{conns}{$client->{socket}}}{type} eq "NON_INTERACTIVE") {
eval {
$client->send_utf8("### Trigger ### $txt");
};
if($@) {
ws_disconnect($client);
}
} else {
# web("Skipped $client\n");
}
}
}
#
# balanced
# Determine if a line of text has a set of balanced parentheses
#
sub balanced
{
my $txt = shift;
my $open = $txt =~ tr/\(//;
my $close = $txt =~ tr/\)//;
return ($open == $close) ? 1 : 0;
}
sub decode_flags
{
my @list;
my ($flag,$num,$id) = @_;
if($id == 1) {
for my $type (grep {/^TYPE_/} keys %$flag) {
# there has to be a better way to do this, but what i found
# fails when comparing 0 to 0x0, and this is my work around.
if(sprintf("'%032b'",$num & 0x7) eq
sprintf("'%032b'",oct($$flag{$type}))){
push(@list,substr($type,5));
}
}
}
for my $type (grep {/_$id$/} keys %$flag) {
if($num & oct($$flag{$type})) {
push(@list,substr($type,0,-2));
}
}
return @list;
}
#
# post_db_read_fix
# TinyMUSH's db stores contents and exits in a linked list style format,
# where the object in the list stores a pointer to the next object.
# Teenymush just stores an array of objects. This function will
#
#
sub post_db_read_fix
{
my $start = shift;
my $max;
for my $i ($start .. $#db) {
$max = length(db_object($i)) if(length(db_object($i)) > $max);
if(valid_dbref($i) && defined @db[$i]->{obj_content}) {
my $hash = @db[$i]->{obj_content}->{value};
my $obj = (keys %$hash)[0];
if($obj == -1) {
db_set($i,"obj_content");
} else {
while($obj != -1 && valid_dbref($obj)) { # traverse list
db_set_list($i,"obj_content",$obj); # add next item
db_set($obj,"obj_location",$i);
if(defined @db[$obj]->{obj_next}->{value} &&
@db[$obj]->{obj_next}->{value} != -1) {
my $prev = $obj;
$obj = @db[$obj]->{obj_next}->{value}; # move to next hop
db_set($prev,"obj_next"); # delete next attr
} else {
$obj = -1;
}
}
}
}
if(valid_dbref($i) && defined @db[$i]->{obj_exits}) {
my $hash = @db[$i]->{obj_exits}->{value};
my $obj = (keys %$hash)[0];
if($obj == -1) {
db_set($i,"obj_exits");
} else {
while($obj != -1 && valid_dbref($obj)) { # traverse list
db_set_list($i,"obj_exits",$obj); # add next item
if(hasflag($obj,"EXIT")) {
if(@db[$obj]->{obj_location}->{value} == -1) {
db_set($obj,"obj_destination");
} else {
db_set($obj,
"obj_destination",
@db[$obj]->{obj_location}->{value});
}
my $loc = @db[$obj]->{obj_exits}->{value};
db_set($obj,"obj_location",(keys %$loc)[0]);
db_set($obj,"obj_exits");
}
if(defined @db[$obj]->{obj_next}->{value} &&
@db[$obj]->{obj_next}->{value} != -1) {
my $prev = $obj;
$obj = @db[$obj]->{obj_next}->{value}; # move to next hop
db_set($prev,"obj_next"); # delete next attr
} else {
$obj = -1;
}
}
}
}
}
for my $i ($start .. $#db) { # going objects are handled diferently
delete @db[$i] if(hasflag($i,"GOING"));
}
}
sub fudge
{
my $txt = shift;
# return $txt;
if($txt < 3) {
return $txt;
} elsif($txt == 3) {
return -99999999;
} else {
return ($txt - 1);
}
}
#
# db_read_import
# Read a mush flat file and put it at the "end" of the database.
# Dbrefs in code are not remapped but non-code things like exits and
# contents are. This was only tested with a 1994 flat file database.
#
sub db_read_import
{
my ($self,$prog,$file) = @_;
my ($inattr,$id,$pos,$lock,$attr_id,%attr,$name,%impflag,$prev) = (1, undef);
my $unnamed = 0;
# The data from the flags.h and attrs.h could be hard coded into the
# db but reading it from the source will probably allow for different
# versions to be supported?
# return if $#db > -1;
my $start = $#db + 1;
open(FILE,"attrs.h") ||
die("Could not open 'attrs.h' for reading.");
while(<FILE>) {
s/\r|\n//g;
if(/^\s*#define\s+A_(\w+)\s+(\d+)/) { # get attribute ids
@attr{$2} = "A_$1";
}
}
close(FILE);
for my $y ( "A" .. "Z" ) { # not defined in attrs.h fully
@attr{ord($y) + 35} = "V_V" . $y; # so fill in the blanks
@attr{ord($y) + 64} = "V_Z" . $y;
}
# read flags.h for use in decoding flags
$id = 1;
open(FILE,"flags.h") ||
die("Could not open 'flags.h' for reading.");
while(<FILE>) {
s/\r|\n//g;
if(/^#define TYPE_(\w+)\s+([\dx]+)/) {
@impflag{"TYPE_$1"} = $2;
} elsif(/^#define\s+(\w+)\s+([\dx]+)/) {
@impflag{"$1_$id"} = $2;
} elsif(/Second word/) {
$id = 2;
} elsif(/Third word/) {
$id = 3;
} elsif(/^#define\s+\w+\(.+\).*Flags[2|3].*&\s+(\w+)\)/) {
delete @impflag{$1};
}
}
close(FILE);
delete @impflag{"FLAG_WORD1_1"}; # delete unused flags that cause problems
delete @impflag{"FLAG_WORD2_1"};
delete @impflag{"FLAG_WORD3_1"};
delete @impflag{"GOODTYPE_1"};
delete @impflag{"NOTYPE_1"};
my $ctl_a = chr(1);
open(FILE,$file) || # start reading actual db
return err($self,$prog,"Could not open file '%s' for reading",$file);
# my $one = char(1);
while(<FILE>) {
if($_ =~ /^"$ctl_a(\d+):(\d+):(.*)"$/) {
$_ = $3;
} elsif($_ =~ /^"(.*)"$/) {
$_ = $1;
}
if($_ =~ /\r$/) {
$prev = $_;
next;
} elsif($prev ne undef) {
$_ = $prev . $_;
$prev = undef;
}
s/\r|\n//g;
if($. == 1 || $. == 2 || $. == 3) {
# printf("# $_\n");
} elsif($inattr && /^\+A(\d+)$/) { # attr id
$id = $1;
} elsif($inattr && $id ne undef && # attr flag/name
(/^(\d+):([^ ]+)$/ || /^"(\d+):([^ ]+)"$/)) {
@attr{$id} = $2;
$id = undef;
} elsif(/^!(\d+)$/) { # new object
$inattr = 0;
$id = $1;
$pos = $.;
$unnamed = 1;
db_set($id+$start,"imported_dbref",$id);
} elsif($inattr) {
printf("INATTR[$.,%s]: '$_'\n",$. - $pos);
# exit();
} elsif(fudge($. - $pos) == 1) { # name
$name = $_;
db_set($id+$start,"obj_name",$_);
db_set($id+$start,"obj_cname",$_);
} elsif(fudge($. - $pos) == 2) {
db_set($id+$start,"obj_location",($_ == -1) ? -1 : ($_+$start));
} elsif(fudge($. - $pos) == 3) {
db_set_list($id+$start,"obj_content",($_ == -1) ? -1 : ($_+$start));
} elsif(fudge($. - $pos) == 4) {
db_set_list($id+$start,"obj_exits",($_ == -1) ? -1 : ($_+$start));
} elsif(fudge($. - $pos) == 5) {
db_set($id+$start,"obj_home",$_+$start);
} elsif(fudge($. - $pos) == 6) { # unused, but needed during clean up
db_set($id+$start,"obj_next",($_ == -1) ? -1 : ($_+$start));
} elsif($lock ne undef || fudge($. - $pos) == 7) {
$lock .= $_;
if(($lock =~ /\(/ && balanced($lock)) || $_ eq undef) {
db_set($id+$start,"obj_lock_default",$lock);
$lock = undef;
} else {
$pos++;
}
} elsif(fudge($. - $pos) == 8) {
db_set($id+$start,"obj_owner",($_ == -1) ? -1 : ($_+$start));
} elsif(fudge($. - $pos) == 9) {
db_set($id+$start,"A_PARENT",$_) if($_ ne "-1");
} elsif(fudge($. - $pos) == 10) {
db_set($id+$start,"obj_money",$_);
} elsif(fudge($. - $pos) == 11) {
my %list;
for my $flag (decode_flags(\%impflag,$_,1)) {
@list{$flag} = 1;
if(defined @flag{uc($flag)}) {
db_set_list($id+$start,"obj_flag",lc($flag));
}
if($flag eq "PLAYER") {
@player{trim(ansi_remove(lc($name)))} = $id;
db_set($id+$start,"obj_name","imp_$name");
db_set($id+$start,"obj_cname","imp_$name");
}
}
if(!defined @list{PLAYER} && !defined @list{ROOM}) {
db_set_list($id+$start,"obj_flag","object");
}
db_set_list($id+$start,"obj_flag","imported");
} elsif(fudge($. - $pos) == 12) {
for my $flag (decode_flags(\%impflag,$_,2)) {
if(defined @flag{lc($flag)}) {
db_set_list($id+$start,"obj_flag",lc($flag));
}
}
} elsif($_ =~ /^>(\d+)$/) {
$unnamed = 0;
db_set($id+$start,"obj_created_date",scalar localtime());
$attr_id = $1;
} elsif($attr_id ne undef) {
if(@attr{$attr_id} eq "A_PASS") { # set password to name
db_set($id+$start,"obj_password",mushhash(lc("imp_$name")));
} elsif(@attr{$attr_id} eq "A_DESC") { # set password to name
db_set($id+$start,"DESCRIPTION",$_);
} elsif(@attr{$attr_id} eq "A_LAST") { # set password to name
db_set($id+$start,"obj_last",$_);
} elsif(defined @attr{$attr_id}) {
db_set($id+$start,@attr{$attr_id},$_);
} else {
db_set($id+$start,"UNKNOWN_$attr_id",$_);
}
$attr_id = undef;
} elsif($_ =~ /^<$/) { # end of object
# printf("----[ End of $id ]----\n");
$id = undef;
} elsif(/^\*\*\*END OF DUMP\*\*\*$/) {
# yay!
} elsif($unnamed == 1) {
# unsupported attribute type?
} else {
# printf("UNKNOWN[$.,%s]: '$_'\n",$. - $pos);
# exit();
}
# exit() if $id == 8;
}
close(FILE);
post_db_read_fix($start);
necho(self => $self,
prog => $prog,
source => [ "Import starts at object $start" ]
);
necho(self => $self,
prog => $prog,
source => [ " Objects Imported: %s",$#db - $start ]
);
}
main(); #!# run only once